diff --git a/LeanPool.lean b/LeanPool.lean index a124eb85b6..f7ca0da4d0 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -441,6 +441,714 @@ public import LeanPool.Besicovitch.SixPoint.WeightedFailure public import LeanPool.Besicovitch.SixPoint.WeightedReduction public import LeanPool.Besicovitch.Statement public import LeanPool.Besicovitch.Topology.ConnectedComponent +public import LeanPool.BeyondBethe +public import LeanPool.BeyondBethe.BeyondBethe +public import LeanPool.BeyondBethe.BeyondBethe.AdaptiveRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.BeyondBethe.ApproximateKKT +public import LeanPool.BeyondBethe.BeyondBethe.AxiomAudit +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import LeanPool.BeyondBethe.BeyondBethe.BetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphGeometry +public import LeanPool.BeyondBethe.BeyondBethe.BetheFloorCutFormula +public import LeanPool.BeyondBethe.BeyondBethe.BetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BinaryDirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.BinaryLongDivision +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalComparison +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import LeanPool.BeyondBethe.BeyondBethe.Capacity +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import LeanPool.BeyondBethe.BeyondBethe.CapacityScaling +public import LeanPool.BeyondBethe.BeyondBethe.CertificateCapacity +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.CertifiedPairWeights +public import LeanPool.BeyondBethe.BeyondBethe.CleanConstants +public import LeanPool.BeyondBethe.BeyondBethe.CleanGain +public import LeanPool.BeyondBethe.BeyondBethe.CleanWitness +public import LeanPool.BeyondBethe.BeyondBethe.ClusterAlpha +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ClusterFactors +public import LeanPool.BeyondBethe.BeyondBethe.ClusterProduct +public import LeanPool.BeyondBethe.BeyondBethe.Completion +public import LeanPool.BeyondBethe.BeyondBethe.CoreEncoding +public import LeanPool.BeyondBethe.BeyondBethe.CycleTransfer +public import LeanPool.BeyondBethe.BeyondBethe.Cycles +public import LeanPool.BeyondBethe.BeyondBethe.DirectedCertificateValue +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.DirectedOptimizerOracle +public import LeanPool.BeyondBethe.BeyondBethe.DirectedPairCost +public import LeanPool.BeyondBethe.BeyondBethe.DyadicMagnitudePrecision +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import LeanPool.BeyondBethe.BeyondBethe.ExcursionTransfer +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableInterior +public import LeanPool.BeyondBethe.BeyondBethe.ExecutablePositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableTransfer +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBounds +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitOptimizerScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitPositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import LeanPool.BeyondBethe.BeyondBethe.Gibbs +public import LeanPool.BeyondBethe.BeyondBethe.GoodRowScore +public import LeanPool.BeyondBethe.BeyondBethe.GreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.KuhnMatching +public import LeanPool.BeyondBethe.BeyondBethe.KuhnSmallStep +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineLineSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityFit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilitySemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorScan +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorTest +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightCap +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryDivision +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryGCD +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListSnoc +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinarySub +public import LeanPool.BeyondBethe.BeyondBethe.MachineBitAssembly +public import LeanPool.BeyondBethe.BeyondBethe.MachineBool +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateAssembly +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificatePotentials +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertifiedPairEligibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineCompletedAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedEpigraphNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedTransferCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutablePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableScannedOptimizerOutput +public import LeanPool.BeyondBethe.BeyondBethe.MachineExplicitCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics +public import LeanPool.BeyondBethe.BeyondBethe.MachineFactorial +public import LeanPool.BeyondBethe.BeyondBethe.MachineFinalScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineFourCoreCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineGreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnInvariant +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnRunner +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnStep +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatchingGain +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateAllSome +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixAddDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNonnegative +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalizeEntries +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSupportProduct +public import LeanPool.BeyondBethe.BeyondBethe.MachineNaturalCombinators +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineNestedMatrixMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerCertificateBoundary +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerDerivedScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerEntryLength +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilityCall +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilitySchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerInteriorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerMatrixBitBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerRoundingSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerStateBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachinePerfectMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineRAMBridge +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalBallInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateRow +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidCenterUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalExp +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixColumn +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMin +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalizedDirection +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowDivide +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalTransposeMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorDot +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorL1 +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSub +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRepeatPair +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowComplementUpperSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowPairDisjoint +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLogWidth +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledStateEncodingBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmallDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothedMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothingDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineTrimHighZeros +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryMatrixGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryRange +public import LeanPool.BeyondBethe.BeyondBethe.Main +public import LeanPool.BeyondBethe.BeyondBethe.MatchingAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MatrixPerturbation +public import LeanPool.BeyondBethe.BeyondBethe.NearCase +public import LeanPool.BeyondBethe.BeyondBethe.NumericalAffine +public import LeanPool.BeyondBethe.BeyondBethe.NumericalCapacity +public import LeanPool.BeyondBethe.BeyondBethe.NumericalInterior +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import LeanPool.BeyondBethe.BeyondBethe.NumericalPotentials +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import LeanPool.BeyondBethe.BeyondBethe.NumericalTransfer +public import LeanPool.BeyondBethe.BeyondBethe.NumericalWitness +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.OptimizerOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.PairFactorization +public import LeanPool.BeyondBethe.BeyondBethe.PairStability +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate +public import LeanPool.BeyondBethe.BeyondBethe.PalomarComplexity +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import LeanPool.BeyondBethe.BeyondBethe.RationalEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import LeanPool.BeyondBethe.BeyondBethe.RationalEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RationalLinearOracle +public import LeanPool.BeyondBethe.BeyondBethe.RawRational +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RobustCycle +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidIterationBounds +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidScales +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibilityBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RowStability +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoidIteration +public import LeanPool.BeyondBethe.BeyondBethe.Sequential +public import LeanPool.BeyondBethe.BeyondBethe.SequentialNormalization +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import LeanPool.BeyondBethe.BeyondBethe.Smoothing +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaei +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiList +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiMerge +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheLower +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheUpper +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableBivariate +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableClosure +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableEncoding +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableInduction +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSlice +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSpecialization +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableTable +public import LeanPool.BeyondBethe.BeyondBethe.SourceVontobel +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import LeanPool.BeyondBethe.BeyondBethe.StrongEntropy +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import LeanPool.BeyondBethe.BeyondBethe.WeakSeparation +public import LeanPool.BeyondBethe.Complexitylib +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolyBound +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolynomialComposition +public import LeanPool.BeyondBethe.Complexitylib.Circuits +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Basic +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal.Codec +public import LeanPool.BeyondBethe.Complexitylib.Classes +public import LeanPool.BeyondBethe.Complexitylib.Classes.Containments +public import LeanPool.BeyondBethe.Complexitylib.Classes.Exponential +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.L +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP.Witness +public import LeanPool.BeyondBethe.Complexitylib.Classes.P +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Blocks +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Cat +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Extract +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.HeadFlag +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Iterate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.MulLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reorder +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reverse +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Simulate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.TakeLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Preimage +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Preimage +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Classes.Randomized +public import LeanPool.BeyondBethe.Complexitylib.Classes.Space +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time +public import LeanPool.BeyondBethe.Complexitylib.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Data +public import LeanPool.BeyondBethe.Complexitylib.Encoding.DataEncode +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Delimit +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Languages +public import LeanPool.BeyondBethe.Complexitylib.Languages.LastBit +public import LeanPool.BeyondBethe.Complexitylib.Mathlib +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.FinsetPrefixes +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.LinearInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookupRestore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.BoundsInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.End +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Hit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Miss +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Progress +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Source +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Tagged +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Types +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dense +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseControl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseCtrlSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDirect +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseImm +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseLoad +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimData +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Direct +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Immediate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Data +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Store +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Tapes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Assemble +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Prepare +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Reset +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Restore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Value +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.ResetLayout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DecisionInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Initialization +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.LinearInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Capture +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Marshal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Iteration +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Soundness +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Compiled +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Apply +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Helpers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Complement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.If +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Seq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Union +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.FirstPhase +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.Tail +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Frame +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.RetargetOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal.OutputBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.OutputBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Arith +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Emit +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.ForReg +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Horner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.InputLen +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Backward +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ParkAll +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetTapes +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeLoop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeStep +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.WorkReadOnly +public import LeanPool.BeyondBethe.Complexitylib.SAT +public import LeanPool.BeyondBethe.Complexitylib.SAT.Encoding +public import LeanPool.BeyondBethe.Complexitylib.SAT.Language +public import LeanPool.BeyondBethe.Complexitylib.SAT.Rename +public import LeanPool.BeyondBethe.Complexitylib.SAT.Semantics +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeCNF +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT.Syntax +public import LeanPool.BeyondBethe.Complexitylib.SAT.Verifier +public import LeanPool.BeyondBethe.Solution public import LeanPool.BicausalOT public import LeanPool.BicausalOT.BicausalOT public import LeanPool.BicausalOT.BicausalOT.Basic diff --git a/LeanPool/BeyondBethe.lean b/LeanPool/BeyondBethe.lean new file mode 100644 index 0000000000..a74654f7c5 --- /dev/null +++ b/LeanPool/BeyondBethe.lean @@ -0,0 +1,732 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe +public import LeanPool.BeyondBethe.BeyondBethe.AdaptiveRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.BeyondBethe.ApproximateKKT +public import LeanPool.BeyondBethe.BeyondBethe.AxiomAudit +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import LeanPool.BeyondBethe.BeyondBethe.BetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphGeometry +public import LeanPool.BeyondBethe.BeyondBethe.BetheFloorCutFormula +public import LeanPool.BeyondBethe.BeyondBethe.BetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BinaryDirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.BinaryLongDivision +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalComparison +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import LeanPool.BeyondBethe.BeyondBethe.Capacity +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import LeanPool.BeyondBethe.BeyondBethe.CapacityScaling +public import LeanPool.BeyondBethe.BeyondBethe.CertificateCapacity +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.CertifiedPairWeights +public import LeanPool.BeyondBethe.BeyondBethe.CleanConstants +public import LeanPool.BeyondBethe.BeyondBethe.CleanGain +public import LeanPool.BeyondBethe.BeyondBethe.CleanWitness +public import LeanPool.BeyondBethe.BeyondBethe.ClusterAlpha +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ClusterFactors +public import LeanPool.BeyondBethe.BeyondBethe.ClusterProduct +public import LeanPool.BeyondBethe.BeyondBethe.Completion +public import LeanPool.BeyondBethe.BeyondBethe.CoreEncoding +public import LeanPool.BeyondBethe.BeyondBethe.CycleTransfer +public import LeanPool.BeyondBethe.BeyondBethe.Cycles +public import LeanPool.BeyondBethe.BeyondBethe.DirectedCertificateValue +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.DirectedOptimizerOracle +public import LeanPool.BeyondBethe.BeyondBethe.DirectedPairCost +public import LeanPool.BeyondBethe.BeyondBethe.DyadicMagnitudePrecision +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import LeanPool.BeyondBethe.BeyondBethe.ExcursionTransfer +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableInterior +public import LeanPool.BeyondBethe.BeyondBethe.ExecutablePositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableTransfer +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBounds +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitOptimizerScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitPositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import LeanPool.BeyondBethe.BeyondBethe.Gibbs +public import LeanPool.BeyondBethe.BeyondBethe.GoodRowScore +public import LeanPool.BeyondBethe.BeyondBethe.GreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.KuhnMatching +public import LeanPool.BeyondBethe.BeyondBethe.KuhnSmallStep +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineLineSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityFit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilitySemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorScan +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorTest +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightCap +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryDivision +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryGCD +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListSnoc +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinarySub +public import LeanPool.BeyondBethe.BeyondBethe.MachineBitAssembly +public import LeanPool.BeyondBethe.BeyondBethe.MachineBool +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateAssembly +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificatePotentials +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertifiedPairEligibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineCompletedAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedEpigraphNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedTransferCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutablePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableScannedOptimizerOutput +public import LeanPool.BeyondBethe.BeyondBethe.MachineExplicitCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics +public import LeanPool.BeyondBethe.BeyondBethe.MachineFactorial +public import LeanPool.BeyondBethe.BeyondBethe.MachineFinalScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineFourCoreCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineGreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnInvariant +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnRunner +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnStep +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatchingGain +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateAllSome +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixAddDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNonnegative +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalizeEntries +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSupportProduct +public import LeanPool.BeyondBethe.BeyondBethe.MachineNaturalCombinators +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineNestedMatrixMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerCertificateBoundary +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerDerivedScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerEntryLength +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilityCall +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilitySchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerInteriorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerMatrixBitBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerRoundingSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerStateBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachinePerfectMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineRAMBridge +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalBallInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateRow +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidCenterUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalExp +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixColumn +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMin +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalizedDirection +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowDivide +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalTransposeMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorDot +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorL1 +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSub +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRepeatPair +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowComplementUpperSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowPairDisjoint +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLogWidth +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledStateEncodingBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmallDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothedMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothingDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineTrimHighZeros +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryMatrixGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryRange +public import LeanPool.BeyondBethe.BeyondBethe.Main +public import LeanPool.BeyondBethe.BeyondBethe.MatchingAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MatrixPerturbation +public import LeanPool.BeyondBethe.BeyondBethe.NearCase +public import LeanPool.BeyondBethe.BeyondBethe.NumericalAffine +public import LeanPool.BeyondBethe.BeyondBethe.NumericalCapacity +public import LeanPool.BeyondBethe.BeyondBethe.NumericalInterior +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import LeanPool.BeyondBethe.BeyondBethe.NumericalPotentials +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import LeanPool.BeyondBethe.BeyondBethe.NumericalTransfer +public import LeanPool.BeyondBethe.BeyondBethe.NumericalWitness +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.OptimizerOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.PairFactorization +public import LeanPool.BeyondBethe.BeyondBethe.PairStability +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate +public import LeanPool.BeyondBethe.BeyondBethe.PalomarComplexity +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import LeanPool.BeyondBethe.BeyondBethe.RationalEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import LeanPool.BeyondBethe.BeyondBethe.RationalEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RationalLinearOracle +public import LeanPool.BeyondBethe.BeyondBethe.RawRational +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RobustCycle +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidIterationBounds +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidScales +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibilityBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RowStability +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoidIteration +public import LeanPool.BeyondBethe.BeyondBethe.Sequential +public import LeanPool.BeyondBethe.BeyondBethe.SequentialNormalization +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import LeanPool.BeyondBethe.BeyondBethe.Smoothing +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaei +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiList +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiMerge +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheLower +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheUpper +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableBivariate +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableClosure +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableEncoding +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableInduction +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSlice +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSpecialization +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableTable +public import LeanPool.BeyondBethe.BeyondBethe.SourceVontobel +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import LeanPool.BeyondBethe.BeyondBethe.StrongEntropy +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import LeanPool.BeyondBethe.BeyondBethe.WeakSeparation +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolyBound +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolynomialComposition +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Basic +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal.Codec +public import LeanPool.BeyondBethe.Complexitylib.Classes.Containments +public import LeanPool.BeyondBethe.Complexitylib.Classes.Exponential +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.L +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP.Witness +public import LeanPool.BeyondBethe.Complexitylib.Classes.P +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Blocks +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Cat +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Extract +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.HeadFlag +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Iterate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.MulLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reorder +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reverse +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Simulate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.TakeLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Preimage +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Preimage +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Classes.Randomized +public import LeanPool.BeyondBethe.Complexitylib.Classes.Space +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Data +public import LeanPool.BeyondBethe.Complexitylib.Encoding.DataEncode +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Delimit +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Languages.LastBit +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.FinsetPrefixes +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.LinearInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookupRestore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.BoundsInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Types +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.End +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Hit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Miss +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Progress +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Source +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Tagged +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Tapes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dense +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseControl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseCtrlSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDirect +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseImm +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseLoad +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimData +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Direct +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Immediate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Data +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Store +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.ResetLayout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Assemble +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Prepare +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Reset +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Restore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Value +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DecisionInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Initialization +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.LinearInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Capture +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Marshal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Iteration +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Soundness +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Compiled +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Helpers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Apply +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Complement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.If +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Seq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Union +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.FirstPhase +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.Tail +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Frame +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.RetargetOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal.OutputBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.OutputBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Arith +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Emit +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.ForReg +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Horner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.InputLen +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Backward +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ParkAll +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetTapes +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeLoop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeStep +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.WorkReadOnly +public import LeanPool.BeyondBethe.Complexitylib.SAT.Encoding +public import LeanPool.BeyondBethe.Complexitylib.SAT.Language +public import LeanPool.BeyondBethe.Complexitylib.SAT.Rename +public import LeanPool.BeyondBethe.Complexitylib.SAT.Semantics +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeCNF +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT.Syntax +public import LeanPool.BeyondBethe.Complexitylib.SAT.Verifier +public import LeanPool.BeyondBethe.Solution + +/-! +# Beyond the Bethe approximation of the permanent + +Source: url:https://github.com/nimaanari/formalization-beyond-bethe +Authors: Nima Anari, Samuel Schlesinger, Bolton Bailey, Christian Reitwiessner +Status: verified +Main declarations: `BeyondBethe.theoremOne` +Tags: permanent, approximation-algorithms, computational-complexity, stable-polynomials +MSC: 68W25, 15A15 +-/ + +@[expose] public section + +/- +Upstream attribution notices: + +# Third-party notices + +## pomegranate.sty + +The vendored `pomegranate.sty` is from Nima Anari's `tex-garden` and is used +to make the paper and arXiv source bundle self-contained. + +Copyright (c) 2020 Nima Anari + +Licensed under the MIT License: + +> Permission is hereby granted, free of charge, to any person obtaining a copy +> of this software and associated documentation files (the "Software"), to +> deal in the Software without restriction, including without limitation the +> rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +> sell copies of the Software, and to permit persons to whom the Software is +> furnished to do so, subject to the following conditions: +> +> The above copyright notice and this permission notice shall be included in +> all copies or substantial portions of the Software. +> +> THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +> IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +> FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +> AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +> LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +> FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +> IN THE SOFTWARE. + +-/ diff --git a/LeanPool/BeyondBethe/BeyondBethe.lean b/LeanPool/BeyondBethe/BeyondBethe.lean new file mode 100644 index 0000000000..1bd897c8a8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import LeanPool.BeyondBethe.BeyondBethe.Capacity +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import LeanPool.BeyondBethe.BeyondBethe.CapacityScaling +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate +public import LeanPool.BeyondBethe.BeyondBethe.PairStability +public import LeanPool.BeyondBethe.BeyondBethe.PairFactorization +public import LeanPool.BeyondBethe.BeyondBethe.ClusterProduct +public import LeanPool.BeyondBethe.BeyondBethe.ClusterFactors +public import LeanPool.BeyondBethe.BeyondBethe.ClusterAlpha +public import LeanPool.BeyondBethe.BeyondBethe.CertificateCapacity +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.Gibbs +public import LeanPool.BeyondBethe.BeyondBethe.SequentialNormalization +public import LeanPool.BeyondBethe.BeyondBethe.Sequential +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import LeanPool.BeyondBethe.BeyondBethe.CoreEncoding +public import LeanPool.BeyondBethe.BeyondBethe.Cycles +public import LeanPool.BeyondBethe.BeyondBethe.GoodRowScore +public import LeanPool.BeyondBethe.BeyondBethe.RobustCycle +public import LeanPool.BeyondBethe.BeyondBethe.RowStability +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaei +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiMerge +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiList +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheUpper +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheLower +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableClosure +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableBivariate +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableTable +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSpecialization +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSlice +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableInduction +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableEncoding +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.CycleTransfer +public import LeanPool.BeyondBethe.BeyondBethe.ExcursionTransfer +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import LeanPool.BeyondBethe.BeyondBethe.CleanWitness +public import LeanPool.BeyondBethe.BeyondBethe.CleanGain +public import LeanPool.BeyondBethe.BeyondBethe.CleanConstants +public import LeanPool.BeyondBethe.BeyondBethe.Smoothing +public import LeanPool.BeyondBethe.BeyondBethe.Completion +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.BeyondBethe.PalomarComplexity +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBounds +public import LeanPool.BeyondBethe.BeyondBethe.KuhnMatching +public import LeanPool.BeyondBethe.BeyondBethe.GreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.NearCase +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableTransfer +public import LeanPool.BeyondBethe.BeyondBethe.DirectedCertificateValue +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import LeanPool.BeyondBethe.BeyondBethe.NumericalInterior +public import LeanPool.BeyondBethe.BeyondBethe.NumericalCapacity +public import LeanPool.BeyondBethe.BeyondBethe.NumericalTransfer +public import LeanPool.BeyondBethe.BeyondBethe.NumericalPotentials +public import LeanPool.BeyondBethe.BeyondBethe.NumericalAffine +public import LeanPool.BeyondBethe.BeyondBethe.DirectedOptimizerOracle +public import LeanPool.BeyondBethe.BeyondBethe.WeakSeparation +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableInterior +public import LeanPool.BeyondBethe.BeyondBethe.RationalEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import LeanPool.BeyondBethe.BeyondBethe.DyadicMagnitudePrecision +public import LeanPool.BeyondBethe.BeyondBethe.MatrixPerturbation +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidScales +public import LeanPool.BeyondBethe.BeyondBethe.AdaptiveRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidIterationBounds +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoidIteration +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import LeanPool.BeyondBethe.BeyondBethe.BinaryLongDivision +public import LeanPool.BeyondBethe.BeyondBethe.RawRational +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalComparison +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBool +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinarySub +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryDivision +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryGCD +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMin +public import LeanPool.BeyondBethe.BeyondBethe.MachineFactorial +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothingDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowAdd +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixAddDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothedMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineCompletedAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerCertificateBoundary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificatePotentials +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLogWidth +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowComplementUpperSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedTransferCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineFourCoreCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertifiedPairEligibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowPairDisjoint +public import LeanPool.BeyondBethe.BeyondBethe.MachineGreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatchingGain +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateAssembly +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.MachineExplicitCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerEntryLength +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerMatrixBitBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerInteriorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerDerivedScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilitySchedule +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScheduledFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerRoundingSchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalBallInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorDot +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorL1 +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalizedDirection +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSub +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidCenterUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateRow +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorMatrix +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixColumn +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalTransposeMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineLineSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorTest +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorScan +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightCap +public import LeanPool.BeyondBethe.BeyondBethe.BetheFloorCutFormula +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListSnoc +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedEpigraphNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilitySemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledStateEncodingBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityFit +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerStateBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilityCall +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionLoop +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSemantics +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.OptimizerOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryMatrixGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableScannedOptimizerOutput +public import LeanPool.BeyondBethe.BeyondBethe.ExecutablePositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutablePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalExp +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNonnegative +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmallDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowDivide +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalizeEntries +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSupportProduct +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnStep +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnInvariant +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnRunner +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateAllSome +public import LeanPool.BeyondBethe.BeyondBethe.MachinePerfectMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineFinalScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineRAMBridge +public import LeanPool.BeyondBethe.BeyondBethe.MachineBitAssembly +public import LeanPool.BeyondBethe.BeyondBethe.MachineTrimHighZeros +public import LeanPool.BeyondBethe.BeyondBethe.BinaryDirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibilityBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.RationalLinearOracle +public import LeanPool.BeyondBethe.BeyondBethe.RationalEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.StrongEntropy +public import LeanPool.BeyondBethe.BeyondBethe.ApproximateKKT +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphGeometry +public import LeanPool.BeyondBethe.BeyondBethe.BetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitOptimizerScales +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitPositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.NumericalWitness +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.Main + +/-! # Beyond Bethe -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/BeyondBethe/AdaptiveRoundedEllipsoid.lean b/LeanPool/BeyondBethe/BeyondBethe/AdaptiveRoundedEllipsoid.lean new file mode 100644 index 0000000000..0ffb17d7b2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/AdaptiveRoundedEllipsoid.lean @@ -0,0 +1,587 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidScales +public import Mathlib.Tactic + +/-! # Adaptive Rounded Ellipsoid -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The proof-specification rounded ellipsoid update + +This file discharges the quantitative hypotheses of +`inflatedDyadicRound_contains` using the least precision selected from the +exact determinant. This update is a mathematical specification used to prove +the rounding estimates. The machine implementation must instead use an +a-priori precision schedule proved to dominate this selector; it must not +evaluate `Matrix.det` at run time. +-/ + +/-- Round one exact state at the proof-specification precision. -/ +def adaptiveRoundedEllipsoid {d : β„•} (U : RationalEllipsoidState d) : + RationalEllipsoidState d := + inflatedDyadicRound (roundedEllipsoidPrecision U) + (roundedEllipsoidInflation d) U + +/-- Exact central cut followed by adaptive bounded-bit rounding. -/ +def adaptiveRoundedEllipsoidCentralUpdate {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + RationalEllipsoidState d := + adaptiveRoundedEllipsoid (rationalEllipsoidCentralUpdate E a) + +theorem rationalMatrixAbsBound_one_le {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : + 1 ≀ rationalMatrixAbsBound A := by + rw [rationalMatrixAbsBound] + exact le_add_of_nonneg_right + (Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ abs_nonneg _) + +theorem adaptiveRounded_entry_bound {d : β„•} + (U : RationalEllipsoidState d) (i j : Fin d) : + abs (((dyadicFloorMatrix (roundedEllipsoidPrecision U) + U.basis i j : β„š) : ℝ)) ≀ + (2 * rationalMatrixAbsBound U.basis : β„š) := by + let M := rationalMatrixAbsBound U.basis + have hM1 : (1 : β„š) ≀ M := rationalMatrixAbsBound_one_le U.basis + have hentry : abs (U.basis i j) < M := + abs_entry_lt_rationalMatrixAbsBound U.basis i j + have hround := abs_dyadicFloor_le (roundedEllipsoidPrecision U) (U.basis i j) + have hmesh := dyadicMesh_le_one (roundedEllipsoidPrecision U) + have hq : abs (dyadicFloor (roundedEllipsoidPrecision U) (U.basis i j)) ≀ + 2 * M := by + dsimp only [M] at hM1 hentry ⊒ + linarith + exact_mod_cast hq + +theorem adaptiveRounded_det_lower {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) : + ((abs (Matrix.det U.basis) / 2 : β„š) : ℝ) ≀ + abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix (roundedEllipsoidPrecision U) + U.basis i j : β„š) : ℝ))) := by + let Mq := rationalMatrixAbsBound U.basis + let p := roundedEllipsoidPrecision U + let Ξ”q := abs (Matrix.det U.basis) + let A : Matrix (Fin d) (Fin d) ℝ := + fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ) + let B : Matrix (Fin d) (Fin d) ℝ := + fun i j ↦ ((U.basis i j : β„š) : ℝ) + have hMq1 : (1 : β„š) ≀ Mq := rationalMatrixAbsBound_one_le U.basis + have hMreal : (1 : ℝ) ≀ (Mq : ℝ) := by exact_mod_cast hMq1 + have hBentry : βˆ€ i j, abs (B i j) ≀ (Mq : ℝ) := by + intro i j + change abs (((U.basis i j : β„š) : ℝ)) ≀ (Mq : ℝ) + exact_mod_cast (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hpert := abs_det_dyadicFloorMatrix_sub_det_le p U.basis hMreal + (by simpa only [B] using hBentry) + have hlossQ := adaptive_determinant_rounding_loss_lt hd U hdet + have hloss : + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) < + (Ξ”q : ℝ) / (128 * (d : ℝ) ^ 3) := by + have hc : + ((roundedDeterminantCoefficient d Mq * + dyadicMesh p : β„š) : ℝ) < + ((Ξ”q / (128 * d ^ 3) : β„š) : ℝ) := by + exact_mod_cast hlossQ + norm_num only [roundedDeterminantCoefficient, Rat.cast_mul, + Rat.cast_pow, Rat.cast_natCast, Rat.cast_div] at hc + convert hc using 1 <;> ring + have hsmallLoss : + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) < + (Ξ”q : ℝ) / 2 := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hΞ” : 0 < (Ξ”q : ℝ) := by + exact_mod_cast (abs_pos.mpr hdet) + have hden : (2 : ℝ) ≀ 128 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + have hfrac : (Ξ”q : ℝ) / (128 * (d : ℝ) ^ 3) ≀ (Ξ”q : ℝ) / 2 := + div_le_div_of_nonneg_left hΞ”.le (by norm_num) hden + exact hloss.trans_le hfrac + have htriangle : abs (Matrix.det B) ≀ + abs (Matrix.det A - Matrix.det B) + abs (Matrix.det A) := by + calc + abs (Matrix.det B) = + abs ((Matrix.det B - Matrix.det A) + Matrix.det A) := by ring_nf + _ ≀ abs (Matrix.det B - Matrix.det A) + abs (Matrix.det A) := + abs_add_le _ _ + _ = abs (Matrix.det A - Matrix.det B) + abs (Matrix.det A) := by + rw [show Matrix.det B - Matrix.det A = + -(Matrix.det A - Matrix.det B) by ring, abs_neg] + have hcastB : Matrix.det B = ((Matrix.det U.basis : β„š) : ℝ) := by + rw [show B = U.basis.map (fun q : β„š ↦ (q : ℝ)) by rfl, Rat.cast_det] + have hpert' : abs (Matrix.det A - Matrix.det B) ≀ + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) := by + simpa only [A, B] using hpert + rw [hcastB] at htriangle hpert' + have hΞ”cast : abs (((Matrix.det U.basis : β„š) : ℝ)) = (Ξ”q : ℝ) := by + exact_mod_cast (show abs (Matrix.det U.basis) = Ξ”q by rfl) + rw [hΞ”cast] at htriangle + have hresult : (Ξ”q : ℝ) / 2 ≀ abs (Matrix.det A) := by linarith + simpa only [A, p, Ξ”q, Rat.cast_div, Rat.cast_ofNat] using hresult + +theorem adaptiveRounded_contains {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint (adaptiveRoundedEllipsoid U) y' = + rationalEllipsoidPoint U y := by + let Mq := rationalMatrixAbsBound U.basis + let Mr : ℝ := 2 * (Mq : ℝ) + let Ξ”q := abs (Matrix.det U.basis) + let D : ℝ := ((Ξ”q / 2 : β„š) : ℝ) + let Ξ· := roundedEllipsoidInflation d + let p := roundedEllipsoidPrecision U + have hMq : 0 < Mq := rationalMatrixAbsBound_pos U.basis + have hMr : (1 : ℝ) ≀ Mr := by + dsimp only [Mr] + have hMq1 := rationalMatrixAbsBound_one_le U.basis + exact_mod_cast (show (1 : β„š) ≀ 2 * Mq by linarith) + have hD : 0 < D := by + dsimp only [D, Ξ”q] + exact_mod_cast (div_pos (abs_pos.mpr hdet) (by norm_num : (0 : β„š) < 2)) + have hΞ· : 0 ≀ Ξ· := roundedEllipsoidInflation_nonneg d + have hentries : βˆ€ i j, + abs (((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) ≀ Mr := by + intro i j + simpa only [p, Mr, Rat.cast_mul, Rat.cast_ofNat] using + adaptiveRounded_entry_bound U i j + have hdetLower : D ≀ abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ))) := by + simpa only [D, Ξ”q, p] using adaptiveRounded_det_lower hd U hdet + have hinverseQ := adaptive_inverse_rounding_loss_lt hd U hdet + have hinverse : + (roundedInverseCoefficient d Mq : ℝ) * (dyadicMesh p : ℝ) < + (Ξ· : ℝ) * (Ξ”q : ℝ) / (2 * (d : ℝ)) := by + exact_mod_cast hinverseQ + let V : ℝ := + (d * (d.factorial * Mr ^ d) * + (((d + 1 : β„•) : ℝ) * (dyadicMesh p : ℝ))) / D + have hVform : V = + ((roundedInverseCoefficient d Mq : β„š) : ℝ) * + (dyadicMesh p : ℝ) / D := by + have hCcast : ((roundedInverseCoefficient d Mq : β„š) : ℝ) = + (d : ℝ) * (d.factorial * (2 * (Mq : ℝ)) ^ d) * (d + 1) := by + simp [roundedInverseCoefficient] + rw [hCcast] + dsimp only [V, Mr] + norm_num only [Nat.cast_add, Nat.cast_one] + ring + have hV0 : 0 ≀ V := by + have hMr0 : 0 ≀ Mr := by linarith [hMr] + have hMrpow : 0 ≀ Mr ^ d := pow_nonneg hMr0 _ + have hmesh0 : 0 ≀ (dyadicMesh p : ℝ) := by + exact_mod_cast dyadicMesh_nonneg p + dsimp only [V] + exact div_nonneg + (mul_nonneg + (mul_nonneg (by positivity) + (mul_nonneg (by positivity) hMrpow)) + (mul_nonneg (by positivity) hmesh0)) hD.le + have hV : V ≀ (Ξ· : ℝ) / d := by + rw [hVform] + have hΞ” : 0 < (Ξ”q : ℝ) := by + exact_mod_cast (abs_pos.mpr hdet) + have hdR : (0 : ℝ) < d := by exact_mod_cast hd + have hDform : D = (Ξ”q : ℝ) / 2 := by + dsimp only [D] + norm_num + rw [hDform] + have hposDen : 0 < (Ξ”q : ℝ) / 2 := div_pos hΞ” (by norm_num) + rw [div_le_iffβ‚€ hposDen] + have hΞ·R : 0 ≀ (Ξ· : ℝ) := by exact_mod_cast hΞ· + calc + ((roundedInverseCoefficient d Mq : β„š) : ℝ) * + (dyadicMesh p : ℝ) ≀ + (Ξ· : ℝ) * (Ξ”q : ℝ) / (2 * (d : ℝ)) := hinverse.le + _ = ((Ξ· : ℝ) / d) * ((Ξ”q : ℝ) / 2) := by ring + have hsmall : + d * V ^ 2 ≀ (Ξ· : ℝ) ^ 2 := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hΞ·R : 0 ≀ (Ξ· : ℝ) := by exact_mod_cast hΞ· + have hdiv0 : 0 ≀ (Ξ· : ℝ) / d := div_nonneg hΞ·R (by positivity) + have hsq : V ^ 2 ≀ ((Ξ· : ℝ) / d) ^ 2 := + (sq_le_sqβ‚€ hV0 hdiv0).2 hV + have hdpos : (0 : ℝ) < d := by positivity + calc + (d : ℝ) * V ^ 2 ≀ d * ((Ξ· : ℝ) / d) ^ 2 := + mul_le_mul_of_nonneg_left hsq hdpos.le + _ = (Ξ· : ℝ) ^ 2 / d := by field_simp + _ ≀ (Ξ· : ℝ) ^ 2 := + (div_le_self (sq_nonneg (Ξ· : ℝ)) hdR) + have hsmall' : + d * + ((d * (d.factorial * Mr ^ d) * + ((d + 1 : β„•) * (dyadicMesh p : ℝ))) / D) ^ 2 ≀ + (Ξ· : ℝ) ^ 2 := by simpa only [V] using hsmall + simpa only [adaptiveRoundedEllipsoid, p, Ξ·] using + inflatedDyadicRound_contains hd p Ξ· U hΞ· hD hMr hentries + hdetLower hsmall' hy + +theorem det_adaptiveRoundedEllipsoid_ne_zero {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) : + Matrix.det (adaptiveRoundedEllipsoid U).basis β‰  0 := by + let p := roundedEllipsoidPrecision U + have hround : Matrix.det (dyadicFloorMatrix p U.basis) β‰  0 := by + intro hz + have hlower := adaptiveRounded_det_lower hd U hdet + have hzeroReal : Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = 0 := by + rw [show (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + (dyadicFloorMatrix p U.basis).map (fun q : β„š ↦ (q : ℝ)) by rfl, + ← Rat.cast_det, hz] + simp + rw [hzeroReal] at hlower + have hpos : (0 : ℝ) < ((abs (Matrix.det U.basis) / 2 : β„š) : ℝ) := by + exact_mod_cast div_pos (abs_pos.mpr hdet) (by norm_num : (0 : β„š) < 2) + linarith + rw [adaptiveRoundedEllipsoid, det_inflatedDyadicRound_basis] + exact mul_ne_zero + (pow_ne_zero _ (by + have hΞ· := roundedEllipsoidInflation_pos hd + linarith)) hround + +theorem det_adaptiveRoundedEllipsoidCentralUpdate_ne_zero {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) : + Matrix.det (adaptiveRoundedEllipsoidCentralUpdate E a).basis β‰  0 := by + let U := rationalEllipsoidCentralUpdate E a + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + exact det_adaptiveRoundedEllipsoid_ne_zero hd U hdetU + +/-- The adaptive central-cut update preserves every point surviving the cut, +with no residual numerical hypothesis. -/ +theorem adaptiveRoundedEllipsoidCentralUpdate_contains {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) + (hcut : finiteDot + (fun i ↦ (rationalPulledBackNormal E a i : ℝ)) y ≀ 0) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint + (adaptiveRoundedEllipsoidCentralUpdate E a) y' = + rationalEllipsoidPoint E y := by + let U := rationalEllipsoidCentralUpdate E a + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + obtain ⟨z, hz, hpoint⟩ := + rationalEllipsoidCentralUpdate_contains hd E a hb hy hcut + obtain ⟨z', hz', hround⟩ := adaptiveRounded_contains hd U hdetU hz + refine ⟨z', hz', ?_⟩ + rw [adaptiveRoundedEllipsoidCentralUpdate, hround, hpoint] + +/-- The determinant cost of the explicit inflation is tiny compared with a +central-cut contraction. -/ +theorem roundedEllipsoidInflation_pow_bound {d : β„•} (hd : 0 < d) : + (1 + (roundedEllipsoidInflation d : ℝ)) ^ d ≀ + 1 + 1 / (512 * (d : ℝ) ^ 3) := by + let Ξ· : ℝ := (roundedEllipsoidInflation d : ℝ) + let t : ℝ := d * Ξ· + have hΞ· : 0 < Ξ· := by + dsimp only [Ξ·] + exact_mod_cast roundedEllipsoidInflation_pos hd + have htform : t = 1 / (1024 * (d : ℝ) ^ 3) := by + dsimp only [t, Ξ·, roundedEllipsoidInflation] + push_cast + field_simp [Nat.ne_of_gt hd] + have ht0 : 0 ≀ t := mul_nonneg (by positivity) hΞ·.le + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have ht1 : t ≀ 1 := by + rw [htform] + have hden : (1 : ℝ) ≀ 1024 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact (div_le_one (by positivity : (0 : ℝ) < 1024 * (d : ℝ) ^ 3)).2 hden + have hbase : 1 + Ξ· ≀ Real.exp Ξ· := by + simpa [add_comm] using Real.add_one_le_exp Ξ· + have hpow : (1 + Ξ·) ^ d ≀ (Real.exp Ξ·) ^ d := + pow_le_pow_leftβ‚€ (by positivity) hbase d + have hexpEq : (Real.exp Ξ·) ^ d = Real.exp t := by + rw [← Real.exp_nat_mul] + have hrem := Real.abs_exp_sub_one_sub_id_le + (x := t) (by rw [abs_of_nonneg ht0]; exact ht1) + have hexpUpper : Real.exp t ≀ 1 + t + t ^ 2 := by + have hle := le_trans (le_abs_self (Real.exp t - 1 - t)) hrem + linarith + have htSq : t ^ 2 ≀ t := by nlinarith + calc + (1 + (roundedEllipsoidInflation d : ℝ)) ^ d = (1 + Ξ·) ^ d := rfl + _ ≀ (Real.exp Ξ·) ^ d := hpow + _ = Real.exp t := hexpEq + _ ≀ 1 + t + t ^ 2 := hexpUpper + _ ≀ 1 + 2 * t := by linarith + _ = 1 + 1 / (512 * (d : ℝ) ^ 3) := by + rw [htform] + ring + +theorem roundedContraction_arithmetic {d : β„•} (hd : 0 < d) : + (1 + 1 / (512 * (d : ℝ) ^ 3)) * + (1 - 7 / (128 * (d : ℝ) ^ 3)) ≀ + 1 - 1 / (32 * (d : ℝ) ^ 3) := by + let u : ℝ := 1 / (d : ℝ) ^ 3 + have hu0 : 0 ≀ u := by dsimp only [u]; positivity + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hu1 : u ≀ 1 := by + dsimp only [u] + exact (div_le_one (by positivity : (0 : ℝ) < (d : ℝ) ^ 3)).2 + (one_le_powβ‚€ (n := 3) hdR) + have hrewrite : + (1 + 1 / (512 * (d : ℝ) ^ 3)) * + (1 - 7 / (128 * (d : ℝ) ^ 3)) = + (1 + u / 512) * (1 - 7 * u / 128) := by + dsimp only [u] + ring + have htarget : + 1 - 1 / (32 * (d : ℝ) ^ 3) = 1 - u / 32 := by + dsimp only [u] + ring + rw [hrewrite, htarget] + nlinarith [sq_nonneg u] + +/-- Every adaptive rounded central cut still contracts the stored determinant +by an explicit inverse-polynomial factor. -/ +theorem abs_det_adaptiveRoundedCentralUpdate_le {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) : + abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + let U := rationalEllipsoidCentralUpdate E a + let Mq := rationalMatrixAbsBound U.basis + let p := roundedEllipsoidPrecision U + let Ξ· := roundedEllipsoidInflation d + let L : ℝ := d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) + let Ξ”E : ℝ := abs ((Matrix.det E.basis : β„š) : ℝ) + let Ξ”U : ℝ := abs ((Matrix.det U.basis : β„š) : ℝ) + let q : ℝ := + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + have hΞ”E0 : 0 ≀ Ξ”E := abs_nonneg _ + have hΞ”U0 : 0 ≀ Ξ”U := abs_nonneg _ + have hq0 : 0 ≀ q := by + dsimp only [q] + exact mul_nonneg + (pow_nonneg (Rat.cast_nonneg.mpr + (rationalEllipsoidPerpScale_pos d).le) _) + (Rat.cast_nonneg.mpr (rationalEllipsoidParallelScale_pos hd).le) + have hq1 : q ≀ 1 := + (rationalEllipsoid_volumeFactor_lt_one hd).le + have hqContract : q ≀ 1 - 1 / (16 * (d : ℝ) ^ 3) := + rationalEllipsoid_volumeFactor_le_one_sub hd + have hΞ”eq : Ξ”U = Ξ”E * q := by + have hdetEq := det_rationalEllipsoidCentralUpdate hd E a hb + dsimp only [U, Ξ”U, Ξ”E, q] + rw [hdetEq, Rat.cast_mul, abs_mul] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_sub, + Rat.cast_div, Rat.cast_one, Rat.cast_natCast] + rw [abs_of_nonneg hq0] + have hΞ”Ule : Ξ”U ≀ Ξ”E := by + rw [hΞ”eq] + simpa only [mul_one] using mul_le_mul_of_nonneg_left hq1 hΞ”E0 + have hMq1 : (1 : ℝ) ≀ (Mq : ℝ) := by + exact_mod_cast rationalMatrixAbsBound_one_le U.basis + have hUentry : βˆ€ i j, abs ((U.basis i j : β„š) : ℝ) ≀ (Mq : ℝ) := by + intro i j + exact_mod_cast (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hupper0 := abs_det_inflatedDyadicRound_le p Ξ· U + (roundedEllipsoidInflation_nonneg d) hMq1 hUentry + have hupper : + abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) ≀ + (1 + (Ξ· : ℝ)) ^ d * (Ξ”U + L) := by + simpa only [adaptiveRoundedEllipsoidCentralUpdate, + adaptiveRoundedEllipsoid, U, p, Ξ·, Ξ”U, L] using hupper0 + have hlossQ := adaptive_determinant_rounding_loss_lt hd U hdetU + have hloss : L < Ξ”U / (128 * (d : ℝ) ^ 3) := by + have hc : + ((roundedDeterminantCoefficient d Mq * dyadicMesh p : β„š) : ℝ) < + ((abs (Matrix.det U.basis) / (128 * d ^ 3) : β„š) : ℝ) := by + exact_mod_cast hlossQ + norm_num only [roundedDeterminantCoefficient, Rat.cast_mul, + Rat.cast_pow, Rat.cast_natCast, Rat.cast_div] at hc + have hc' : L < + ((abs (Matrix.det U.basis) : β„š) : ℝ) / + (128 * (d : ℝ) ^ 3) := by + dsimp only [L] + simpa [mul_assoc, mul_left_comm, mul_comm] using hc + have habsCast : ((abs (Matrix.det U.basis) : β„š) : ℝ) = Ξ”U := by + dsimp only [Ξ”U] + exact_mod_cast (show abs (Matrix.det U.basis) = + abs (Matrix.det U.basis) by rfl) + rw [habsCast] at hc' + exact hc' + have hlossE : L ≀ Ξ”E / (128 * (d : ℝ) ^ 3) := by + have hden : 0 < (128 : ℝ) * (d : ℝ) ^ 3 := by positivity + exact hloss.le.trans + (div_le_div_of_nonneg_right hΞ”Ule hden.le) + have hbracket : Ξ”U + L ≀ + Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3)) := by + rw [hΞ”eq] + have hq' : q ≀ 1 - 8 / (128 * (d : ℝ) ^ 3) := by + convert hqContract using 1 <;> ring + have hqmul := mul_le_mul_of_nonneg_left hq' hΞ”E0 + calc + Ξ”E * q + L ≀ + Ξ”E * (1 - 8 / (128 * (d : ℝ) ^ 3)) + + Ξ”E / (128 * (d : ℝ) ^ 3) := add_le_add hqmul hlossE + _ = Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3)) := by ring + have hfactor0 : 0 ≀ 1 - 7 / (128 * (d : ℝ) ^ 3) := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hden : (7 : ℝ) ≀ 128 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact sub_nonneg.mpr + ((div_le_one (by positivity : (0 : ℝ) < 128 * (d : ℝ) ^ 3)).2 hden) + have hscale := roundedEllipsoidInflation_pow_bound hd + have hscale0 : 0 ≀ (1 + (Ξ· : ℝ)) ^ d := by + exact pow_nonneg (by + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith) _ + calc + abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) ≀ + (1 + (Ξ· : ℝ)) ^ d * (Ξ”U + L) := hupper + _ ≀ (1 + (Ξ· : ℝ)) ^ d * + (Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3))) := + mul_le_mul_of_nonneg_left hbracket hscale0 + _ ≀ (1 + 1 / (512 * (d : ℝ) ^ 3)) * + (Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3))) := by + exact mul_le_mul_of_nonneg_right hscale + (mul_nonneg hΞ”E0 hfactor0) + _ = Ξ”E * ((1 + 1 / (512 * (d : ℝ) ^ 3)) * + (1 - 7 / (128 * (d : ℝ) ^ 3))) := by ring + _ ≀ Ξ”E * (1 - 1 / (32 * (d : ℝ) ^ 3)) := + mul_le_mul_of_nonneg_left (roundedContraction_arithmetic hd) hΞ”E0 + _ = (1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + simp only [Ξ”E] + ring + +/-- Rounding also retains a fixed fraction of the old determinant from +below. Hence the determinant magnitude can lose only two binary bits per +iteration, even on infeasible instances. -/ +theorem quarter_abs_det_le_adaptiveRoundedCentralUpdate {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) : + (1 / 4 : ℝ) * abs ((Matrix.det E.basis : β„š) : ℝ) ≀ + abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) := by + let U := rationalEllipsoidCentralUpdate E a + let p := roundedEllipsoidPrecision U + let Ξ· := roundedEllipsoidInflation d + let Ξ”E : ℝ := abs ((Matrix.det E.basis : β„š) : ℝ) + let Ξ”U : ℝ := abs ((Matrix.det U.basis : β„š) : ℝ) + let q : ℝ := + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + have hq0 : 0 ≀ q := by + dsimp only [q] + exact mul_nonneg + (pow_nonneg (Rat.cast_nonneg.mpr + (rationalEllipsoidPerpScale_pos d).le) _) + (Rat.cast_nonneg.mpr (rationalEllipsoidParallelScale_pos hd).le) + have hΞ”eq : Ξ”U = Ξ”E * q := by + have hdetEq := det_rationalEllipsoidCentralUpdate hd E a hb + dsimp only [U, Ξ”U, Ξ”E, q] + rw [hdetEq, Rat.cast_mul, abs_mul] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_sub, + Rat.cast_div, Rat.cast_one, Rat.cast_natCast] + rw [abs_of_nonneg hq0] + have hqLower : (1 / 2 : ℝ) ≀ q := by + simpa only [q] using rationalEllipsoid_volumeFactor_ge_half hd + have hΞ”lower : (1 / 2 : ℝ) * Ξ”E ≀ Ξ”U := by + rw [hΞ”eq] + have hh : (1 / 2 : ℝ) * Ξ”E ≀ q * Ξ”E := + mul_le_mul_of_nonneg_right hqLower (by + dsimp only [Ξ”E] + exact abs_nonneg _) + simpa only [mul_comm] using hh + have hround0 := adaptiveRounded_det_lower hd U hdetU + have hround : Ξ”U / 2 ≀ + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) := by + have hcastDet : Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + ((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ) := by + rw [show (fun i j ↦ + ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + (dyadicFloorMatrix p U.basis).map (fun q : β„š ↦ (q : ℝ)) by rfl, + Rat.cast_det] + have habsCast : + (((abs (Matrix.det U.basis) : β„š) : β„š) : ℝ) = + abs (((Matrix.det U.basis : β„š) : ℝ)) := by + exact_mod_cast (show abs (Matrix.det U.basis) = + abs (Matrix.det U.basis) by rfl) + norm_num only [Rat.cast_div, Rat.cast_ofNat] at hround0 + rw [hcastDet] at hround0 + simpa only [p, Ξ”U, habsCast] using hround0 + have hscale : (1 : ℝ) ≀ (1 + (Ξ· : ℝ)) ^ d := by + apply one_le_powβ‚€ + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + dsimp only [Ξ·] + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith + have hstored : + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) ≀ + abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) := by + rw [adaptiveRoundedEllipsoidCentralUpdate, adaptiveRoundedEllipsoid, + det_inflatedDyadicRound_basis, Rat.cast_mul, abs_mul] + change abs (((1 + Ξ·) ^ d : β„š) : ℝ) * + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) β‰₯ _ + have hscaleAbs : (1 : ℝ) ≀ abs (((1 + Ξ·) ^ d : β„š) : ℝ) := by + rw [Rat.cast_pow, Rat.cast_add, Rat.cast_one, + abs_of_nonneg (pow_nonneg (by + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + dsimp only [Ξ·] + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith) d)] + exact hscale + simpa only [one_mul] using mul_le_mul_of_nonneg_right hscaleAbs + (abs_nonneg (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ))) + calc + (1 / 4 : ℝ) * Ξ”E = ((1 / 2 : ℝ) * Ξ”E) / 2 := by ring + _ ≀ Ξ”U / 2 := div_le_div_of_nonneg_right hΞ”lower (by norm_num) + _ ≀ abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) := hround + _ ≀ abs ((Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis : β„š) : ℝ) := hstored + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/AlgorithmicSpec.lean b/LeanPool/BeyondBethe/BeyondBethe/AlgorithmicSpec.lean new file mode 100644 index 0000000000..9c4d936634 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/AlgorithmicSpec.lean @@ -0,0 +1,522 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Completion +public import LeanPool.BeyondBethe.Complexitylib.Classes.P +public import LeanPool.BeyondBethe.Complexitylib.Encoding.DataEncode +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import Mathlib.Data.List.OfFn +public import Mathlib.Data.Nat.Pairing + +/-! # Algorithmic Spec -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- A square rational matrix together with its dimension. Bundling the +dimension turns the family of inputs in Theorem 1 into one machine input +type. -/ +abbrev RationalMatrixInput := Ξ£ n : β„•, Matrix (Fin n) (Fin n) β„š + +/-- The signed-magnitude payload used for integers. The Boolean distinguishes +`ofNat` from `negSucc`, so this representation has no duplicate zero. -/ +def integerPayload : β„€ β†’ Bool Γ— β„• + | .ofNat n => (false, n) + | .negSucc n => (true, n + 1) + +theorem integerPayload_injective : Function.Injective integerPayload := by + intro a b h + cases a <;> cases b <;> simp [integerPayload] at h ⊒ <;> omega + +/-- Explicit tree encoding of an integer: one sign bit and the binary natural +payload supplied by `DataEncode β„•`. -/ +instance integerDataEncode : DataEncode β„€ where + encode z := DataEncode.encode (integerPayload z) + h_inj := DataEncode.h_inj.comp integerPayload_injective + +/-- A rational is represented by its canonical reduced numerator and positive +denominator. These are fields of Lean's `Rat`, rather than an arbitrary +fraction representing the same number. -/ +def rationalPayload (q : β„š) : β„€ Γ— β„• := (q.num, q.den) + +theorem rationalPayload_injective : Function.Injective rationalPayload := by + intro p q h + exact Rat.ext (congrArg Prod.fst h) (congrArg Prod.snd h) + +instance rationalDataEncode : DataEncode β„š where + encode q := DataEncode.encode (rationalPayload q) + h_inj := DataEncode.h_inj.comp rationalPayload_injective + +/-- Row-major list representation of a fixed-size matrix. -/ +def rationalMatrixRows {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : List (List β„š) := + List.ofFn fun i ↦ List.ofFn fun j ↦ A i j + +theorem rationalMatrixRows_injective {n : β„•} : + Function.Injective (@rationalMatrixRows n) := by + intro A B hrows + change List.ofFn (fun i ↦ List.ofFn (A i)) = + List.ofFn (fun i ↦ List.ofFn (B i)) at hrows + have houter := List.ofFn_injective hrows + ext i j + have hinner := congrFun houter i + exact congrFun (List.ofFn_injective hinner) j + +/-- Dimension followed by exactly `n` rows of exactly `n` rational entries. -/ +def rationalMatrixInputPayload : RationalMatrixInput β†’ β„• Γ— List (List β„š) + | ⟨n, A⟩ => (n, rationalMatrixRows A) + +theorem rationalMatrixInputPayload_injective : + Function.Injective rationalMatrixInputPayload := by + intro x y h + obtain ⟨n, A⟩ := x + obtain ⟨m, B⟩ := y + have hnm : n = m := congrArg Prod.fst h + subst m + have hrows : rationalMatrixRows A = rationalMatrixRows B := + congrArg Prod.snd h + have hAB : A = B := rationalMatrixRows_injective hrows + subst B + rfl + +instance rationalMatrixInputDataEncode : DataEncode RationalMatrixInput where + encode x := DataEncode.encode (rationalMatrixInputPayload x) + h_inj := DataEncode.h_inj.comp rationalMatrixInputPayload_injective + +/-- An explicit injective binary code. We retain injectivity in the structure +so no later complexity statement can silently identify distinct typed inputs. -/ +structure OrdinaryBinaryEncoding (Ξ± : Type*) where + /-- The finite binary word representing a value; injectivity is required by the encoding + structure. -/ + encode : Ξ± β†’ List Bool + injective : Function.Injective encode + +/-- The least-significant-bit-first binary expansion is injective, including +the convention `Nat.bits 0 = []`. -/ +theorem natBits_injective : Function.Injective Nat.bits := by + intro a b h + have hrec : βˆ€ n : β„•, + n.bits.foldr (fun bit acc => Nat.bit bit acc) 0 = n := by + intro n + induction n using Nat.binaryRec' with + | zero => simp + | bit bit n hn ih => + rw [Nat.bits_append_bit n bit hn] + simp [ih] + have := congrArg (List.foldr (fun bit acc => Nat.bit bit acc) 0) h + simpa [hrec] using this + +/-- Canonical signed binary code. `false` denotes `Int.ofNat`; `true` +denotes `Int.negSucc`. The payload is an ordinary binary natural. -/ +def integerBinaryCode (z : β„€) : List Bool := + Int.casesOn z (fun n ↦ false :: n.bits) (fun n ↦ true :: n.bits) + +@[simp] theorem integerBinaryRec_ofNat (n : β„•) : + Int.rec (fun k ↦ false :: k.bits) (fun k ↦ true :: k.bits) + (Int.ofNat n) = false :: n.bits := by + rfl + +@[simp] theorem integerBinaryRec_natCast (n : β„•) : + Int.rec (fun k ↦ false :: k.bits) (fun k ↦ true :: k.bits) (n : β„€) = + false :: n.bits := by + rfl + +@[simp] theorem integerBinaryRec_negSucc (n : β„•) : + Int.rec (fun k ↦ false :: k.bits) (fun k ↦ true :: k.bits) + (Int.negSucc n) = true :: n.bits := by + rfl + +@[simp] theorem integerBinaryRec_zero : + Int.rec (fun n ↦ false :: n.bits) (fun n ↦ true :: n.bits) (0 : β„€) = + [false] := by + rfl + +@[simp] theorem integerBinaryRec_one : + Int.rec (fun n ↦ false :: n.bits) (fun n ↦ true :: n.bits) (1 : β„€) = + [false, true] := by + rfl + +@[simp] theorem integerBinaryCode_ofNat (n : β„•) : + integerBinaryCode (Int.ofNat n) = false :: n.bits := by + rfl + +@[simp] theorem integerBinaryCode_negSucc (n : β„•) : + integerBinaryCode (Int.negSucc n) = true :: n.bits := by + rfl + +theorem integerBinaryCode_injective : Function.Injective integerBinaryCode := by + intro a b h + cases a with + | ofNat a => + cases b with + | ofNat b => + simp only [integerBinaryCode, List.cons.injEq, true_and] at h + exact congrArg Int.ofNat (natBits_injective h) + | negSucc b => + simp [integerBinaryCode] at h + | negSucc a => + cases b with + | ofNat b => + simp [integerBinaryCode] at h + | negSucc b => + simp only [integerBinaryCode, List.cons.injEq, true_and] at h + exact congrArg Int.negSucc (natBits_injective h) + +/-- A natural-number code for integers. Even naturals encode nonnegative +integers, while odd naturals encode `Int.negSucc`. -/ +def integerNatCode (z : β„€) : β„• := + Int.casesOn z (fun n ↦ 2 * n) (fun n ↦ 2 * n + 1) + +@[simp] theorem integerNatRec_ofNat (n : β„•) : + Int.rec (fun k ↦ 2 * k) (fun k ↦ 2 * k + 1) (Int.ofNat n) = + 2 * n := by + rfl + +@[simp] theorem integerNatRec_natCast (n : β„•) : + Int.rec (fun k ↦ 2 * k) (fun k ↦ 2 * k + 1) (n : β„€) = 2 * n := by + rfl + +@[simp] theorem integerNatRec_negSucc (n : β„•) : + Int.rec (fun k ↦ 2 * k) (fun k ↦ 2 * k + 1) (Int.negSucc n) = + 2 * n + 1 := by + rfl + +@[simp] theorem integerNatRec_zero : + Int.rec (fun n ↦ 2 * n) (fun n ↦ 2 * n + 1) (0 : β„€) = 0 := by + rfl + +@[simp] theorem integerNatCode_ofNat (n : β„•) : + integerNatCode (Int.ofNat n) = 2 * n := by + rfl + +@[simp] theorem integerNatCode_negSucc (n : β„•) : + integerNatCode (Int.negSucc n) = 2 * n + 1 := by + rfl + +theorem integerNatCode_injective : Function.Injective integerNatCode := by + intro a b h + cases a with + | ofNat a => + cases b with + | ofNat b => + simp only [integerNatCode] at h + exact congrArg Int.ofNat (by omega) + | negSucc b => + have hparity := congrArg (fun n : β„• => n % 2) h + simp [integerNatCode] at hparity + | negSucc a => + cases b with + | ofNat b => + have hparity := congrArg (fun n : β„• => n % 2) h + simp [integerNatCode] at hparity + | negSucc b => + simp only [integerNatCode] at h + exact congrArg Int.negSucc (by omega) + +/-- A matrix entry is stored as a self-delimiting pair, so a machine can +extract its numerator and denominator without first implementing arithmetic +unpairing. -/ +def rationalEntryBinaryCode (q : β„š) : List Bool := + pair (integerBinaryCode q.num) q.den.bits + +theorem rationalEntryBinaryCode_injective : + Function.Injective rationalEntryBinaryCode := by + intro p q h + obtain ⟨hnum, hden⟩ := pair_inj h + exact Rat.ext (integerBinaryCode_injective hnum) (natBits_injective hden) + +/-- A rational output is represented by one natural number: Szudzik's +pairing of the canonical integer code of its numerator and its positive +denominator. -/ +def rationalNatCode (q : β„š) : β„• := + Nat.pair (integerNatCode q.num) q.den + +theorem rationalNatCode_injective : Function.Injective rationalNatCode := by + intro p q h + have hpayload : + integerNatCode p.num = integerNatCode q.num ∧ p.den = q.den := + Nat.pair_eq_pair.mp h + exact Rat.ext (integerNatCode_injective hpayload.1) hpayload.2 + +/-- Canonical rational output code. Using the ordinary binary expansion of +one natural makes every output bit accessible to the verified RAM decision +simulator. -/ +def rationalBinaryCode (q : β„š) : List Bool := + (rationalNatCode q).bits + +theorem rationalBinaryCode_injective : Function.Injective rationalBinaryCode := by + exact natBits_injective.comp rationalNatCode_injective + +/-- Right-nested self-delimiting encoding of a finite list. The empty list +is empty, while a nonempty list starts with the nonempty `pair` code. -/ +def binaryListCode {Ξ± : Type*} (encode : Ξ± β†’ List Bool) : + List Ξ± β†’ List Bool + | [] => [] + | x :: xs => pair (encode x) (binaryListCode encode xs) + +theorem binaryListCode_injective {Ξ± : Type*} {encode : Ξ± β†’ List Bool} + (hencode : Function.Injective encode) : + Function.Injective (binaryListCode encode) := by + intro xs + induction xs with + | nil => + intro ys h + cases ys with + | nil => rfl + | cons y ys => + have hlen := congrArg List.length h + simp [binaryListCode] at hlen + omega + | cons x xs ih => + intro ys h + cases ys with + | nil => + have hlen := congrArg List.length h + simp [binaryListCode] at hlen + | cons y ys => + simp only [binaryListCode] at h + obtain ⟨hxy, hxsys⟩ := pair_inj h + exact congrArgβ‚‚ List.cons (hencode hxy) (ih hxsys) + +/-- Machine-facing matrix code: binary dimension followed by the right-nested +row list, whose rows and rational entries use the same canonical pairing +scheme. -/ +def rationalMatrixBinaryCode (x : RationalMatrixInput) : List Bool := + pair x.1.bits + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows x.2)) + +theorem rationalMatrixBinaryCode_injective : + Function.Injective rationalMatrixBinaryCode := by + intro x y h + obtain ⟨n, A⟩ := x + obtain ⟨m, B⟩ := y + simp only [rationalMatrixBinaryCode] at h + obtain ⟨hnm, hrows⟩ := pair_inj h + have hnm' : n = m := natBits_injective hnm + subst m + have hrowCode : + Function.Injective (binaryListCode rationalEntryBinaryCode) := + binaryListCode_injective rationalEntryBinaryCode_injective + have hrows' : rationalMatrixRows A = rationalMatrixRows B := + binaryListCode_injective hrowCode hrows + have hAB : A = B := rationalMatrixRows_injective hrows' + subst B + rfl + +/-- Canonical machine-facing binary encoding of one rational. -/ +def rationalBinaryEncoding : OrdinaryBinaryEncoding β„š where + encode := rationalBinaryCode + injective := rationalBinaryCode_injective + +/-- Canonical machine-facing binary encoding of the dimension and row-major +matrix entries. -/ +def rationalMatrixBinaryEncoding : OrdinaryBinaryEncoding RationalMatrixInput where + encode := rationalMatrixBinaryCode + injective := rationalMatrixBinaryCode_injective + +/-- Length of the canonical parenthesized binary encoding of typed data. -/ +def encodedBitLength (Ξ± : Type) [DataEncode Ξ±] (x : Ξ±) : β„• := + (DataEncode.bitstringEncode x).length + +theorem encodedBitLength_eq_dataSize + {Ξ± : Type} [DataEncode Ξ±] (x : Ξ±) : + encodedBitLength Ξ± x = (DataEncode.encode x).size := by + simp [encodedBitLength, DataEncode.bitstringEncode_def] + +/-- The canonical natural encoding contains, in particular, every bit of the +ordinary binary expansion. -/ +theorem nat_size_le_encodedBitLength (n : β„•) : + n.size ≀ encodedBitLength β„• n := by + rw [encodedBitLength_eq_dataSize] + change n.size ≀ (Data.l (n.bits.map fun b ↦ DataEncode.encode b)).size + rw [← Nat.size_eq_bits_len] + induction n.bits with + | nil => simp + | cons b bs ih => + cases b <;> simp [DataEncode.encode, Data.size] at ih ⊒ <;> omega + +theorem nat_log_two_lt_encodedBitLength {n : β„•} (hn : n β‰  0) : + Nat.log 2 n < encodedBitLength β„• n := by + exact (Nat.lt_size.mpr (Nat.pow_log_le_self 2 hn)).trans_le + (nat_size_le_encodedBitLength n) + +@[simp] theorem integerPayload_snd (z : β„€) : + (integerPayload z).2 = z.natAbs := by + cases z <;> simp [integerPayload] + +theorem natAbs_encodedBitLength_lt_integer (z : β„€) : + encodedBitLength β„• z.natAbs < encodedBitLength β„€ z := by + rw [encodedBitLength_eq_dataSize, encodedBitLength_eq_dataSize] + change (DataEncode.encode z.natAbs).size < + (DataEncode.encode (integerPayload z)).size + rw [DataEncode_pair] + exact Data.size_lt_of_mem (by simp) + +theorem denominator_encodedBitLength_lt_rational (q : β„š) : + encodedBitLength β„• q.den < encodedBitLength β„š q := by + rw [encodedBitLength_eq_dataSize, encodedBitLength_eq_dataSize] + change (DataEncode.encode q.den).size < + (DataEncode.encode (rationalPayload q)).size + rw [DataEncode_pair] + exact Data.size_lt_of_mem (by simp [rationalPayload]) + +theorem numerator_encodedBitLength_lt_rational (q : β„š) : + encodedBitLength β„€ q.num < encodedBitLength β„š q := by + rw [encodedBitLength_eq_dataSize, encodedBitLength_eq_dataSize] + change (DataEncode.encode q.num).size < + (DataEncode.encode (rationalPayload q)).size + rw [DataEncode_pair] + exact Data.size_lt_of_mem (by simp [rationalPayload]) + +theorem numerator_natAbs_log_lt_rationalBitLength (q : β„š) + (hnum : q.num.natAbs β‰  0) : + Nat.log 2 q.num.natAbs < encodedBitLength β„š q := by + exact (nat_log_two_lt_encodedBitLength hnum).trans + ((natAbs_encodedBitLength_lt_integer q.num).trans + (numerator_encodedBitLength_lt_rational q)) + +theorem denominator_log_lt_rationalBitLength (q : β„š) : + Nat.log 2 q.den < encodedBitLength β„š q := by + exact (nat_log_two_lt_encodedBitLength q.den_nz).trans + (denominator_encodedBitLength_lt_rational q) + +/-- A positive rational is bounded below by a dyadic whose exponent is its +ordinary encoded length. This is the elementary bridge from binary input +size to the lower-entry parameter used by the numerical optimizer. -/ +theorem dyadic_encodedBitLength_lt_positive_rational + {q : β„š} (hq : 0 < q) : + (1 / 2 : β„š) ^ encodedBitLength β„š q < q := by + let L := encodedBitLength β„š q + have hdenlog : Nat.log 2 q.den < L := denominator_log_lt_rationalBitLength q + have hdenpow : q.den < 2 ^ L := Nat.lt_pow_of_log_lt (by norm_num) hdenlog + have hnum : 0 < q.num := Rat.num_pos.mpr hq + have hnum0 : q.num.natAbs β‰  0 := Int.natAbs_ne_zero.mpr hnum.ne' + have hnum1 : 1 ≀ q.num.natAbs := Nat.one_le_iff_ne_zero.mpr hnum0 + have hnumabs : (q.num.natAbs : β„€) = q.num := + Int.natAbs_of_nonneg hnum.le + have hqrep : q = (q.num.natAbs : β„š) / (q.den : β„š) := by + calc + q = (q.num : β„š) / (q.den : β„š) := (Rat.num_div_den q).symm + _ = (q.num.natAbs : β„š) / (q.den : β„š) := by + congr 1 + change (q.num : β„š) = ((q.num.natAbs : β„€) : β„š) + rw [hnumabs] + have hdenpowQ : (q.den : β„š) < (2 : β„š) ^ L := by exact_mod_cast hdenpow + have hrecip : 1 / (2 : β„š) ^ L < 1 / (q.den : β„š) := by + exact one_div_lt_one_div_of_lt (by positivity) hdenpowQ + calc + (1 / 2 : β„š) ^ L = 1 / (2 : β„š) ^ L := by + simp only [one_div, inv_pow] + _ < 1 / (q.den : β„š) := hrecip + _ ≀ (q.num.natAbs : β„š) / (q.den : β„š) := by + have hnum1Q : (1 : β„š) ≀ (q.num.natAbs : β„š) := by + exact_mod_cast hnum1 + exact div_le_div_of_nonneg_right hnum1Q + (by positivity : (0 : β„š) ≀ (q.den : β„š)) + _ = q := hqrep.symm + +/-- The same canonical binary length also gives a coarse dyadic upper bound +on every positive rational. -/ +theorem positive_rational_lt_two_pow_encodedBitLength + {q : β„š} (hq : 0 < q) : + q < (2 : β„š) ^ encodedBitLength β„š q := by + let L := encodedBitLength β„š q + have hnum : 0 < q.num := Rat.num_pos.mpr hq + have hnum0 : q.num.natAbs β‰  0 := Int.natAbs_ne_zero.mpr hnum.ne' + have hnumlog : Nat.log 2 q.num.natAbs < L := + numerator_natAbs_log_lt_rationalBitLength q hnum0 + have hnumpow : q.num.natAbs < 2 ^ L := + Nat.lt_pow_of_log_lt (by norm_num) hnumlog + have hnumabs : (q.num.natAbs : β„€) = q.num := + Int.natAbs_of_nonneg hnum.le + have hqrep : q = (q.num.natAbs : β„š) / (q.den : β„š) := by + calc + q = (q.num : β„š) / (q.den : β„š) := (Rat.num_div_den q).symm + _ = (q.num.natAbs : β„š) / (q.den : β„š) := by + congr 1 + change (q.num : β„š) = ((q.num.natAbs : β„€) : β„š) + rw [hnumabs] + have hdenNat : 1 ≀ q.den := Nat.one_le_iff_ne_zero.mpr q.den_nz + have hden : (1 : β„š) ≀ q.den := by exact_mod_cast hdenNat + have hquot : (q.num.natAbs : β„š) / (q.den : β„š) ≀ + (q.num.natAbs : β„š) := by + rw [div_le_iffβ‚€ (by positivity : (0 : β„š) < q.den)] + have hnumQ : (0 : β„š) ≀ q.num.natAbs := by positivity + nlinarith + calc + q = (q.num.natAbs : β„š) / (q.den : β„š) := hqrep + _ ≀ (q.num.natAbs : β„š) := hquot + _ < (2 : β„š) ^ encodedBitLength β„š q := by + simpa only [L] using (show (q.num.natAbs : β„š) < (2 : β„š) ^ L by + exact_mod_cast hnumpow) + +/-- A deliberately simple common bit bound for all entries of a fixed-size +rational matrix. The sum, rather than a maximum, keeps the definition +primitive and gives an immediate polynomial bound. -/ +def rationalMatrixEntryBitBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : β„• := + 1 + βˆ‘ i, βˆ‘ j, encodedBitLength β„š (A i j) + +theorem entry_encodedBitLength_lt_matrixBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : + encodedBitLength β„š (A i j) < rationalMatrixEntryBitBound A := by + have hrow : encodedBitLength β„š (A i j) ≀ + βˆ‘ k, encodedBitLength β„š (A i k) := + Finset.single_le_sum + (f := fun k ↦ encodedBitLength β„š (A i k)) + (fun k _ ↦ Nat.zero_le _) (Finset.mem_univ j) + have hmatrix : (βˆ‘ k, encodedBitLength β„š (A i k)) ≀ + βˆ‘ l, βˆ‘ k, encodedBitLength β„š (A l k) := + Finset.single_le_sum + (f := fun l ↦ βˆ‘ k, encodedBitLength β„š (A l k)) + (fun l _ ↦ Finset.sum_nonneg fun k _ ↦ Nat.zero_le _) + (Finset.mem_univ i) + simp only [rationalMatrixEntryBitBound] + omega + +/-- Every positive entry is bounded below by the same dyadic determined by +the matrix encoding. -/ +theorem matrix_dyadic_bitBound_lt_entry {n : β„•} + {A : Matrix (Fin n) (Fin n) β„š} (hA : βˆ€ i j, 0 < A i j) + (i j : Fin n) : + (1 / 2 : β„š) ^ rationalMatrixEntryBitBound A < A i j := by + have hlen := (entry_encodedBitLength_lt_matrixBound A i j).le + have hpow : (1 / 2 : β„š) ^ rationalMatrixEntryBitBound A ≀ + (1 / 2 : β„š) ^ encodedBitLength β„š (A i j) := + pow_le_pow_of_le_one (by norm_num) (by norm_num) hlen + exact hpow.trans_lt (dyadic_encodedBitLength_lt_positive_rational (hA i j)) + +/-- Bundle a dimension-indexed rational-matrix algorithm into a single typed +function. -/ +def bundledAlgorithm + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) + (x : RationalMatrixInput) : β„š := + alg x.1 x.2 + +/-- A total string function realizes a typed matrix algorithm when it produces +the canonical rational encoding on every canonically encoded matrix input. +Its behavior on malformed strings is deliberately unrestricted. -/ +def StringRealizes + (F : List Bool β†’ List Bool) + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) : Prop := + βˆ€ x : RationalMatrixInput, + F (rationalMatrixBinaryCode x) = + rationalBinaryCode (bundledAlgorithm alg x) + +/-- The concrete polynomial-time assertion used in Theorem 1. `FP` is +Complexitylib's deterministic multitape-Turing-machine class with a polynomial +step bound. -/ +def RunsInPolynomialTime + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) : Prop := + βˆƒ F : List Bool β†’ List Bool, F ∈ Complexity.FP ∧ StringRealizes F alg + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ApproximateKKT.lean b/LeanPool/BeyondBethe/BeyondBethe/ApproximateKKT.lean new file mode 100644 index 0000000000..e80f246990 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ApproximateKKT.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.StrongEntropy +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBounds +public import LeanPool.BeyondBethe.BeyondBethe.NumericalPotentials +public import Mathlib.Tactic + +/-! # Approximate KKT -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# From objective accuracy to an approximate KKT certificate + +The regularizer makes the objective strongly concave. Consequently an +approximately optimal doubly stochastic matrix is close to an exact +maximizer. On an explicitly truncated interior of the Birkhoff polytope the +logarithmic gradient is Lipschitz, so closeness of the matrices gives +closeness of their gradients. Finally, anchored row and column potentials +turn that gradient estimate into the approximate logarithmic KKT equations +used by the permanent certificate. + +The executable elementary-function oracle approximates the *negative* +gradient. The last theorem below records the corresponding sign and the +additive constant `2 + tau` explicitly. +-/ + +/-- On a common floor `delta`, one coordinate of the regularized Bethe +gradient is `3 / delta`-Lipschitz when `0 <= tau <= 1`. -/ +theorem regularizedBetheGradient_sub_abs_le + {ΞΉ : Type*} {Ο„ Ξ΄ : ℝ} {A X Y : Matrix ΞΉ ΞΉ ℝ} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hΞ΄ : 0 < Ξ΄) + (hXlo : βˆ€ i j, Ξ΄ ≀ X i j) (hYlo : βˆ€ i j, Ξ΄ ≀ Y i j) + (hXcomp : βˆ€ i j, Ξ΄ ≀ 1 - X i j) + (hYcomp : βˆ€ i j, Ξ΄ ≀ 1 - Y i j) + (i j : ΞΉ) : + abs (regularizedBetheGradient Ο„ A X i j - + regularizedBetheGradient Ο„ A Y i j) ≀ + 3 * abs (X i j - Y i j) / Ξ΄ := by + have hlog := abs_log_sub_log_le_div hΞ΄ (hXlo i j) (hYlo i j) + have hcomplog := abs_log_sub_log_le_div hΞ΄ (hXcomp i j) (hYcomp i j) + have hcoef0 : 0 ≀ 1 + Ο„ := by linarith + have hcoef2 : 1 + Ο„ ≀ 2 := by linarith + have hscaled : + abs ((1 + Ο„) * + (Real.log (X i j) - Real.log (Y i j))) ≀ + 2 * (abs (X i j - Y i j) / Ξ΄) := by + rw [abs_mul, abs_of_nonneg hcoef0] + calc + (1 + Ο„) * abs (Real.log (X i j) - Real.log (Y i j)) ≀ + (1 + Ο„) * (abs (X i j - Y i j) / Ξ΄) := + mul_le_mul_of_nonneg_left hlog hcoef0 + _ ≀ 2 * (abs (X i j - Y i j) / Ξ΄) := + mul_le_mul_of_nonneg_right hcoef2 (by positivity) + have hcompdiff : + abs ((1 - X i j) - (1 - Y i j)) = abs (X i j - Y i j) := by + rw [show (1 - X i j) - (1 - Y i j) = + -(X i j - Y i j) by ring, abs_neg] + rw [hcompdiff] at hcomplog + have htriangle := abs_add_le + (-(1 + Ο„) * (Real.log (X i j) - Real.log (Y i j))) + (-(Real.log (1 - X i j) - Real.log (1 - Y i j))) + have hfirst : + abs (-(1 + Ο„) * (Real.log (X i j) - Real.log (Y i j))) = + abs ((1 + Ο„) * (Real.log (X i j) - Real.log (Y i j))) := by + rw [show -(1 + Ο„) * (Real.log (X i j) - Real.log (Y i j)) = + -((1 + Ο„) * (Real.log (X i j) - Real.log (Y i j))) by ring, + abs_neg] + have hid : + regularizedBetheGradient Ο„ A X i j - + regularizedBetheGradient Ο„ A Y i j = + -(1 + Ο„) * (Real.log (X i j) - Real.log (Y i j)) + + -(Real.log (1 - X i j) - Real.log (1 - Y i j)) := by + simp only [regularizedBetheGradient] + ring + rw [hid] + calc + abs (_ + _) ≀ + abs ((1 + Ο„) * + (Real.log (X i j) - Real.log (Y i j))) + + abs (Real.log (1 - X i j) - Real.log (1 - Y i j)) := by + simpa only [hfirst, abs_neg] using htriangle + _ ≀ 2 * (abs (X i j - Y i j) / Ξ΄) + + abs (X i j - Y i j) / Ξ΄ := add_le_add hscaled hcomplog + _ = 3 * abs (X i j - Y i j) / Ξ΄ := by ring + +/-- A single coordinate is bounded by the Frobenius norm. This square-only +form avoids introducing square roots into the rational algorithm. -/ +theorem abs_matrixCoordinate_le_of_sum_sq_le + {ΞΉ ΞΊ : Type*} [Fintype ΞΉ] [Fintype ΞΊ] + {D : Matrix ΞΉ ΞΊ ℝ} {ρ : ℝ} (hρ : 0 ≀ ρ) + (hsq : (βˆ‘ i, βˆ‘ j, (D i j) ^ 2) ≀ ρ ^ 2) + (a : ΞΉ) (b : ΞΊ) : abs (D a b) ≀ ρ := by + have hcoord : (D a b) ^ 2 ≀ βˆ‘ i, βˆ‘ j, (D i j) ^ 2 := by + calc + (D a b) ^ 2 ≀ βˆ‘ j, (D a j) ^ 2 := + Finset.single_le_sum (fun j _ ↦ sq_nonneg (D a j)) + (Finset.mem_univ b) + _ ≀ βˆ‘ i, βˆ‘ j, (D i j) ^ 2 := + Finset.single_le_sum + (fun i _ ↦ Finset.sum_nonneg fun j _ ↦ sq_nonneg (D i j)) + (Finset.mem_univ a) + have habs0 : 0 ≀ abs (D a b) := abs_nonneg _ + rw [← sq_abs] at hcoord + nlinarith [hcoord.trans hsq] + +/-- A sufficiently small objective gap forces entrywise proximity to an exact +regularized maximizer. The arithmetic hypothesis `4 g <= tau rho^2` is +chosen so that every quantity can be selected rationally. -/ +theorem regularizedBetheMaximizer_coordinate_close_of_gap + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ g ρ : ℝ} (hΟ„ : 0 < Ο„) (hρ : 0 ≀ ρ) + (hscale : 4 * g ≀ Ο„ * ρ ^ 2) + {A X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hmax : βˆ€ Z, IsDoublyStochastic Z β†’ + regularizedBetheObjective Ο„ A Z ≀ + regularizedBetheObjective Ο„ A X) + (hgap : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A Y ≀ g) + (i j : ΞΉ) : abs (X i j - Y i j) ≀ ρ := by + have hdist := regularizedBetheMaximizer_distance_sq_le_gap + hcard hΟ„.le hX hY hmax + have hsquares : + (βˆ‘ i, βˆ‘ j, (X i j - Y i j) ^ 2) ≀ ρ ^ 2 := by + nlinarith + exact abs_matrixCoordinate_le_of_sum_sq_le hρ hsquares i j + +/-- Objective accuracy plus a common interior floor controls the model error +between the negative gradients at an approximate and an exact optimizer. -/ +theorem negativeGradient_close_of_objective_gap + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ g ρ Ξ΄ : ℝ} (hΟ„ : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + (hρ : 0 ≀ ρ) (hΞ΄ : 0 < Ξ΄) + (hscale : 4 * g ≀ Ο„ * ρ ^ 2) + {A X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hmax : βˆ€ Z, IsDoublyStochastic Z β†’ + regularizedBetheObjective Ο„ A Z ≀ + regularizedBetheObjective Ο„ A X) + (hgap : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A Y ≀ g) + (hXlo : βˆ€ i j, Ξ΄ ≀ X i j) (hYlo : βˆ€ i j, Ξ΄ ≀ Y i j) + (hXcomp : βˆ€ i j, Ξ΄ ≀ 1 - X i j) + (hYcomp : βˆ€ i j, Ξ΄ ≀ 1 - Y i j) + (i j : ΞΉ) : + abs (-regularizedBetheGradient Ο„ A Y i j - + -regularizedBetheGradient Ο„ A X i j) ≀ 3 * ρ / Ξ΄ := by + have hcoord := regularizedBetheMaximizer_coordinate_close_of_gap + hcard hΟ„ hρ hscale hX hY hmax hgap i j + have hcoord' : abs (Y i j - X i j) ≀ ρ := by + simpa only [abs_sub_comm] using hcoord + have hgrad := regularizedBetheGradient_sub_abs_le (A := A) hΟ„.le hΟ„1 hΞ΄ + hYlo hXlo hYcomp hXcomp i j + rw [show -regularizedBetheGradient Ο„ A Y i j - + -regularizedBetheGradient Ο„ A X i j = + -(regularizedBetheGradient Ο„ A Y i j - + regularizedBetheGradient Ο„ A X i j) by ring, abs_neg] + exact hgrad.trans (by + exact div_le_div_of_nonneg_right + (mul_le_mul_of_nonneg_left hcoord' (by norm_num)) hΞ΄.le) + +/-- The complete analytic bridge to the certificate interface. `Gtilde` is +an executable approximation to the negative gradient at the returned point +`Y`. Anchoring it produces explicit potentials; the signs and the derivative +constant are incorporated in the displayed output potentials. -/ +theorem approximateLogKKT_of_objective_gap + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ g ρ Ξ΄ evaluationError : ℝ} + (hΟ„ : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) (hρ : 0 ≀ ρ) (hΞ΄ : 0 < Ξ΄) + (hscale : 4 * g ≀ Ο„ * ρ ^ 2) + {A X Y Gtilde : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hmax : βˆ€ Z, IsDoublyStochastic Z β†’ + regularizedBetheObjective Ο„ A Z ≀ + regularizedBetheObjective Ο„ A X) + (hgap : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A Y ≀ g) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hXlo : βˆ€ i j, Ξ΄ ≀ X i j) (hYlo : βˆ€ i j, Ξ΄ ≀ Y i j) + (hXcomp : βˆ€ i j, Ξ΄ ≀ 1 - X i j) + (hYcomp : βˆ€ i j, Ξ΄ ≀ 1 - Y i j) + (heval : βˆ€ i j, + abs (-regularizedBetheGradient Ο„ A Y i j - Gtilde i j) ≀ + evaluationError) + (i0 j0 : ΞΉ) : + HasApproximateLogKKT + (evaluationError + 4 * (evaluationError + 3 * ρ / Ξ΄)) Ο„ A Y + (fun i ↦ -anchoredRowPotential Gtilde j0 i + (2 + Ο„)) + (fun j ↦ -anchoredColumnPotential Gtilde i0 j0 j) := by + obtain ⟨R, C, hRC⟩ := exists_rowColumnPotentials_of_rectangle_identity + (fun i j ↦ regularizedBetheGradient Ο„ A X i j) + (fun hik hjl ↦ regularizedGradient_rectangle_identity + hX hXint hmax hik hjl) + have hstar : βˆ€ i j, + -regularizedBetheGradient Ο„ A X i j = -R i + -C j := by + intro i j + rw [hRC i j] + ring + have hmodel : βˆ€ i j, + abs (Gtilde i j - -regularizedBetheGradient Ο„ A X i j) ≀ + evaluationError + 3 * ρ / Ξ΄ := by + intro i j + have hclose := negativeGradient_close_of_objective_gap + hcard hΟ„ hΟ„1 hρ hΞ΄ hscale hX hY hmax hgap + hXlo hYlo hXcomp hYcomp i j + calc + abs (Gtilde i j - -regularizedBetheGradient Ο„ A X i j) = + abs ((Gtilde i j - -regularizedBetheGradient Ο„ A Y i j) + + (-regularizedBetheGradient Ο„ A Y i j - + -regularizedBetheGradient Ο„ A X i j)) := by congr 1 <;> ring + _ ≀ abs (Gtilde i j - -regularizedBetheGradient Ο„ A Y i j) + + abs (-regularizedBetheGradient Ο„ A Y i j - + -regularizedBetheGradient Ο„ A X i j) := abs_add_le _ _ + _ ≀ evaluationError + 3 * ρ / Ξ΄ := by + have heval' : + abs (Gtilde i j - -regularizedBetheGradient Ο„ A Y i j) ≀ + evaluationError := by + simpa only [abs_sub_comm] using heval i j + exact add_le_add heval' hclose + intro i j + have hres := anchoredPotentials_residual_of_evaluation + hstar hmodel heval i0 j0 i j + change abs (Real.log (A i j) - + ((-anchoredRowPotential Gtilde j0 i + (2 + Ο„)) + + -anchoredColumnPotential Gtilde i0 j0 j + + (1 + Ο„) * Real.log (Y i j) + Real.log (1 - Y i j))) ≀ _ + have hid : + Real.log (A i j) - + ((-anchoredRowPotential Gtilde j0 i + (2 + Ο„)) + + -anchoredColumnPotential Gtilde i0 j0 j + + (1 + Ο„) * Real.log (Y i j) + Real.log (1 - Y i j)) = + -(-regularizedBetheGradient Ο„ A Y i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j)) := by + simp only [regularizedBetheGradient] + ring + rw [hid, abs_neg] + exact hres + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/AxiomAudit.lean b/LeanPool/BeyondBethe/BeyondBethe/AxiomAudit.lean new file mode 100644 index 0000000000..0f764e9890 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/AxiomAudit.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe +public import LeanPool.BeyondBethe.Solution + +/-! # Axiom Audit -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/BeyondBethe/Bethe.lean b/LeanPool/BeyondBethe/BeyondBethe/Bethe.lean new file mode 100644 index 0000000000..c2e6556884 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Bethe.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.Analysis.Convex.Function +public import Mathlib.Tactic + +/-! # Bethe -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Every entry of the matrix is strictly positive. -/ +def Matrix.Positive + {m n : Type*} (A : Matrix m n ℝ) : Prop := + βˆ€ i j, 0 < A i j + +/-- Feasibility for the Bethe program on a matrix with possible zero entries. +The support condition realizes the paper's `-∞` convention without using +extended reals in the objective. -/ +def BetheAdmissible + {n : Type*} [Fintype n] (A X : Matrix n n ℝ) : Prop := + IsDoublyStochastic X ∧ βˆ€ i j, A i j = 0 β†’ X i j = 0 + +/-- Bethe objective (paper (2)), using `negMulLog` for the continuous +`-x log x` term. -/ +noncomputable def betheRowObjective + {n : Type*} [Fintype n] (A X : Matrix n n ℝ) (i : n) : ℝ := by + classical + exact βˆ‘ j : n, + (X i j * Real.log (A i j) + Real.negMulLog (X i j) + + (1 - X i j) * Real.log (1 - X i j)) + +/-- The Bethe objective, summed over all rows and columns with the matrix weights and entropy +terms. -/ +noncomputable def betheObjective + {n : Type*} [Fintype n] (A X : Matrix n n ℝ) : ℝ := by + classical + exact βˆ‘ i : n, betheRowObjective A X i + +/-- Singleton factor in logarithmic coordinates. -/ +noncomputable def singletonFactor + {n : Type*} [Fintype n] (A X : Matrix n n ℝ) (i : n) : ℝ := + Real.exp (betheRowObjective A X i) + +theorem prod_singletonFactor_eq_exp_betheObjective + {n : Type*} [Fintype n] + (A X : Matrix n n ℝ) : + ∏ i, singletonFactor A X i = Real.exp (betheObjective A X) := by + classical + simp only [singletonFactor, betheObjective] + exact (Real.exp_sum Finset.univ (betheRowObjective A X)).symm + +/-- Variational logarithm of the Bethe permanent. -/ +noncomputable def betheLogValue + {n : Type*} [Fintype n] (A : Matrix n n ℝ) : ℝ := + sSup {v : ℝ | βˆƒ X, BetheAdmissible A X ∧ betheObjective A X = v} + +/-- Bethe permanent. If the positive support has no perfect matching, both +the permanent and the variational lower bound are zero. -/ +noncomputable def bethePermanent + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) : ℝ := by + classical + exact if Matrix.HasPerfectMatching A then Real.exp (betheLogValue A) else 0 + +theorem bethePermanent_eq_zero_of_noPerfectMatching + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Β¬Matrix.HasPerfectMatching A) : + bethePermanent A = 0 := by + simp [bethePermanent, hA] + +theorem bethePermanent_pos_of_hasPerfectMatching + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Matrix.HasPerfectMatching A) : + 0 < bethePermanent A := by + simp [bethePermanent, hA, Real.exp_pos] + +/-- Exact interface for the Gurvits and Anari--Rezaei Bethe sandwich. -/ +def BetheSandwich : Prop := + βˆ€ {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ), Matrix.Nonnegative A β†’ + bethePermanent A ≀ Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.sqrt 2) ^ Fintype.card n * bethePermanent A + +/-- Exact interface for Vontobel's concavity theorem, restricted to positive +matrices as used in the structural proof. -/ +def VontobelBetheConcavity : Prop := + βˆ€ {n : Type*} [Fintype n] + (A : Matrix n n ℝ), Matrix.Positive A β†’ + ConcaveOn ℝ {X : Matrix n n ℝ | IsDoublyStochastic X} + (betheObjective A) + +/-- Row-entropy regularization from paper (34). -/ +noncomputable def regularizedBetheObjective + {n : Type*} [Fintype n] + (Ο„ : ℝ) (A X : Matrix n n ℝ) : ℝ := + betheObjective A X + Ο„ * totalRowEntropy X + +/-- Comparing a regularized maximizer with any unregularized competitor loses +at most `Ο„ n log n` in the Bethe objective. This is the quantitative part of +paper Lemma 14 that does not use KKT or boundary analysis. -/ +theorem regularized_near_bethe + {n : Type*} [Fintype n] [DecidableEq n] [Nonempty n] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) (A X Y : Matrix n n ℝ) + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hmax : regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) : + betheObjective A Y - + Ο„ * (Fintype.card n * Real.log (Fintype.card n)) + ≀ betheObjective A X := by + have hEY0 := totalRowEntropy_nonneg hY + have hEX := totalRowEntropy_le hX + rw [regularizedBetheObjective, regularizedBetheObjective] at hmax + have hΟ„EX := mul_le_mul_of_nonneg_left hEX hΟ„ + nlinarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheBisection.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheBisection.lean new file mode 100644 index 0000000000..dbadf6a352 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheBisection.lean @@ -0,0 +1,398 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheThresholdFeasibility +public import Mathlib.Tactic + +/-! # Bethe Bisection -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Rational bisection for the regularized Bethe objective + +The bisection uses only the concrete threshold feasibility runner. An +accepted midpoint becomes the new upper endpoint and carries its rational +witness. An exhausted midpoint becomes the new lower endpoint. Correctness +uses the proved implication that exhaustion can occur only below the exact +optimum plus the explicit smoothing slack. +-/ + +/-- The initial lower threshold `-2 * (m + 1)^2` for the negative Bethe objective. -/ +def betheNegativeObjectiveLower (m : β„•) : β„š := + -(2 * (m + 1) ^ 2) + +/-- The negative-objective upper threshold obtained from the dimension and matrix entry bit +bound. -/ +def betheNegativeObjectiveUpper {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + (m + 1) * rationalMatrixEntryBitBound A + (m + 1) + +/-- The smoothing allowance: the mixing weight times the objective range, plus twice the inner +radius. -/ +def betheSmoothingSlack {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (mix r : β„š) : β„š := + mix * rationalRegularizedObjectiveRange A + 2 * r + +/-- The initial upper bisection threshold, including the smoothing allowance. -/ +def betheBisectionInitialHigh {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (mix r : β„š) : β„š := + betheNegativeObjectiveUpper A + betheSmoothingSlack A mix r + +theorem negativeObjective_mem_initial_interval + {m : β„•} {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) : + (betheNegativeObjectiveLower m : ℝ) ≀ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ∧ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ≀ + (betheNegativeObjectiveUpper A : ℝ) := by + have h := negativeRegularizedBetheObjective_rational_bounds + (n := m + 1) (by omega) hΟ„0 hΟ„1 hApos hAupper hX + norm_num [betheNegativeObjectiveLower, betheNegativeObjectiveUpper] at h ⊒ + exact h + +/-- Executable state of the rational bisection. -/ +structure BetheBisectionState (d : β„•) where + /-- The current lower objective threshold of the bisection interval. -/ + low : β„š + /-- The current upper objective threshold of the bisection interval. -/ + high : β„š + /-- The stored accepted feasibility point, if one has been found. -/ + witness : Option (Fin d β†’ β„š) + +/-- One bisection step. -/ +def betheBisectionStep {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) (s : BetheBisectionState (m * m + 1)) : + BetheBisectionState (m * m + 1) := + let mid := (s.low + s.high) / 2 + match runBetheThresholdFeasibility Ο„ A p Ξ΄ mid r with + | .accepted q => ⟨s.low, mid, some q⟩ + | .exhausted _ => ⟨mid, s.high, s.witness⟩ + +/-- Iterate the bisection a prescribed number of times. -/ +def runBetheBisection {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) : + β„• β†’ BetheBisectionState (m * m + 1) β†’ + BetheBisectionState (m * m + 1) + | 0, s => s + | N + 1, s => runBetheBisection Ο„ A p Ξ΄ r N + (betheBisectionStep Ο„ A p Ξ΄ r s) + +/-- Initialize by querying the explicit global upper endpoint. -/ +def initialBetheBisectionState {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ mix r : β„š) : BetheBisectionState (m * m + 1) := + let high := betheBisectionInitialHigh A mix r + match runBetheThresholdFeasibility Ο„ A p Ξ΄ high r with + | .accepted q => ⟨betheNegativeObjectiveLower m, high, some q⟩ + | .exhausted _ => ⟨betheNegativeObjectiveLower m, high, none⟩ + +@[simp] theorem initialBetheBisectionState_low {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ mix r : β„š) : + (initialBetheBisectionState Ο„ A p Ξ΄ mix r).low = + betheNegativeObjectiveLower m := by + rw [initialBetheBisectionState] + split <;> rfl + +@[simp] theorem initialBetheBisectionState_high {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ mix r : β„š) : + (initialBetheBisectionState Ο„ A p Ξ΄ mix r).high = + betheBisectionInitialHigh A mix r := by + rw [initialBetheBisectionState] + split <;> rfl + +/-- A stored witness is certified by an actual accepted run at the state's +current upper endpoint. -/ +def BetheBisectionWitnessValid {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) (s : BetheBisectionState (m * m + 1)) : Prop := + βˆ€ q, s.witness = some q β†’ + runBetheThresholdFeasibility Ο„ A p Ξ΄ s.high r = .accepted q ∧ + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ s.high q + +theorem initialBetheBisectionState_witnessValid {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ mix r : β„š) : + BetheBisectionWitnessValid Ο„ A p Ξ΄ r + (initialBetheBisectionState Ο„ A p Ξ΄ mix r) := by + intro q hq + rw [initialBetheBisectionState] at hq ⊒ + split at hq <;> rename_i hrun + Β· cases hq + exact ⟨hrun, runBetheThresholdFeasibility_acceptsOnly + Ο„ A p Ξ΄ _ r hrun⟩ + Β· contradiction + +theorem betheBisectionStep_witnessValid {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) {s : BetheBisectionState (m * m + 1)} + (hs : BetheBisectionWitnessValid Ο„ A p Ξ΄ r s) : + BetheBisectionWitnessValid Ο„ A p Ξ΄ r + (betheBisectionStep Ο„ A p Ξ΄ r s) := by + intro q hq + rw [betheBisectionStep] at hq ⊒ + split at hq <;> rename_i hrun + Β· cases hq + exact ⟨hrun, runBetheThresholdFeasibility_acceptsOnly + Ο„ A p Ξ΄ _ r hrun⟩ + Β· exact hs q hq + +theorem runBetheBisection_witnessValid {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) {s : BetheBisectionState (m * m + 1)} + (hs : BetheBisectionWitnessValid Ο„ A p Ξ΄ r s) (N : β„•) : + BetheBisectionWitnessValid Ο„ A p Ξ΄ r + (runBetheBisection Ο„ A p Ξ΄ r N s) := by + induction N generalizing s with + | zero => simpa [runBetheBisection] using hs + | succ N ih => + rw [runBetheBisection] + exact ih (betheBisectionStep_witnessValid Ο„ A p Ξ΄ r hs) + +/-- Every step halves the rational interval width exactly. -/ +theorem betheBisectionStep_width {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) (s : BetheBisectionState (m * m + 1)) : + (betheBisectionStep Ο„ A p Ξ΄ r s).high - + (betheBisectionStep Ο„ A p Ξ΄ r s).low = + (s.high - s.low) / 2 := by + rw [betheBisectionStep] + split <;> ring + +theorem runBetheBisection_width {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) (N : β„•) + (s : BetheBisectionState (m * m + 1)) : + (runBetheBisection Ο„ A p Ξ΄ r N s).high - + (runBetheBisection Ο„ A p Ξ΄ r N s).low = + (s.high - s.low) / 2 ^ N := by + induction N generalizing s with + | zero => simp [runBetheBisection] + | succ N ih => + rw [runBetheBisection, ih, betheBisectionStep_width] + rw [pow_succ] + ring + +/-- If every exhausted query lies below `cutoff`, a bisection step preserves +the invariant that the lower endpoint is at most `cutoff`. -/ +theorem betheBisectionStep_low_le_cutoff {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) {cutoff : ℝ} + (hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runBetheThresholdFeasibility Ο„ A p Ξ΄ u r = .exhausted E β†’ + (u : ℝ) < cutoff) + {s : BetheBisectionState (m * m + 1)} + (hlow : (s.low : ℝ) ≀ cutoff) : + ((betheBisectionStep Ο„ A p Ξ΄ r s).low : β„š) ≀ cutoff := by + rw [betheBisectionStep] + split <;> rename_i hrun + Β· exact hlow + Β· exact (hbelow _ _ hrun).le + +theorem runBetheBisection_low_le_cutoff {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) {cutoff : ℝ} + (hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runBetheThresholdFeasibility Ο„ A p Ξ΄ u r = .exhausted E β†’ + (u : ℝ) < cutoff) + {s : BetheBisectionState (m * m + 1)} + (hlow : (s.low : ℝ) ≀ cutoff) (N : β„•) : + (((runBetheBisection Ο„ A p Ξ΄ r N s).low : β„š) : ℝ) ≀ cutoff := by + induction N generalizing s with + | zero => simpa [runBetheBisection] using hlow + | succ N ih => + rw [runBetheBisection] + exact ih (betheBisectionStep_low_le_cutoff Ο„ A p Ξ΄ r hbelow hlow) + +/-- Once a witness exists, every later state still carries one. -/ +theorem runBetheBisection_preserves_some {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ r : β„š) {s : BetheBisectionState (m * m + 1)} + (hsome : βˆƒ q, s.witness = some q) (N : β„•) : + βˆƒ q, (runBetheBisection Ο„ A p Ξ΄ r N s).witness = some q := by + induction N generalizing s with + | zero => simpa [runBetheBisection] using hsome + | succ N ih => + rw [runBetheBisection] + apply ih + rw [betheBisectionStep] + split + Β· rename_i q hrun + exact ⟨q, rfl⟩ + Β· exact hsome + +/-- The explicit global upper endpoint is guaranteed to initialize the +bisection with an accepted witness. -/ +theorem initialBetheBisectionState_has_witness_of_optimizer + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (p : β„•) : + βˆƒ q, (initialBetheBisectionState Ο„ A p Ξ΄ mix r).witness = some q := by + have hupper := (negativeObjective_mem_initial_interval hΟ„0.le hΟ„1 + hApos hAupper hX).2 + have hthreshold : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (betheBisectionInitialHigh A mix r : ℝ) := by + rw [betheBisectionInitialHigh, betheSmoothingSlack] + push_cast + linarith + obtain ⟨q, hrun, _⟩ := runBetheThresholdFeasibility_accepts_of_slack + hm hΟ„0 hΟ„1 hApos hAupper hX hmax hmix0 hmix1 hΞ΄ hr + hspike hfloor hthreshold p + refine ⟨q, ?_⟩ + rw [initialBetheBisectionState, hrun] + +/-- Complete semantic guarantee of executable bisection: it returns a +rational interior doubly stochastic matrix whose regularized objective gap +is the sum of the smoothing slack, the exact dyadic interval width, and the +directed-evaluation loss. -/ +theorem runBetheBisection_objective_gap + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (p N : β„•) : + let s0 := initialBetheBisectionState Ο„ A p Ξ΄ mix r + let sN := runBetheBisection Ο„ A p Ξ΄ r N s0 + βˆƒ q : Fin (m * m + 1) β†’ β„š, + sN.witness = some q ∧ + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ sN.high q ∧ + IsDoublyStochastic (acceptedBetheMatrix q) ∧ + (βˆ€ i j, (Ξ΄ : ℝ) ≀ acceptedBetheMatrix q i j) ∧ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + (betheSmoothingSlack A mix r : ℝ) + + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) + + (betheObjectiveEvaluationError m p : ℝ) := by + dsimp only + let s0 := initialBetheBisectionState Ο„ A p Ξ΄ mix r + let sN := runBetheBisection Ο„ A p Ξ΄ r N s0 + have hsome0 : βˆƒ q, s0.witness = some q := by + simpa only [s0] using initialBetheBisectionState_has_witness_of_optimizer + hm hΟ„0 hΟ„1 hApos hAupper hX hmax hmix0 hmix1 hΞ΄ hr + hspike hfloor p + obtain ⟨q, hq⟩ := runBetheBisection_preserves_some + Ο„ A p Ξ΄ r hsome0 N + have hqN : sN.witness = some q := by simpa only [sN] using hq + have hvalid0 := initialBetheBisectionState_witnessValid + Ο„ A p Ξ΄ mix r + have hvalidN := runBetheBisection_witnessValid + Ο„ A p Ξ΄ r hvalid0 N + have hcertificate : BetheEpigraphOracleAccepted Ο„ A p Ξ΄ sN.high q := by + exact (hvalidN q (by simpa only [sN] using hqN)).2 + have hbounds := negativeObjective_mem_initial_interval hΟ„0.le hΟ„1 + hApos hAupper hX + let cutoff : ℝ := + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (betheSmoothingSlack A mix r : ℝ) + have hslack0 : 0 ≀ betheSmoothingSlack A mix r := by + rw [betheSmoothingSlack] + exact add_nonneg + (mul_nonneg hmix0.le (rationalRegularizedObjectiveRange_nonneg A)) + (mul_nonneg (by norm_num) hr.le) + have hlow0 : (s0.low : ℝ) ≀ cutoff := by + rw [show s0.low = betheNegativeObjectiveLower m by + simp only [s0, initialBetheBisectionState_low]] + dsimp only [cutoff] + have hslack0R : 0 ≀ (betheSmoothingSlack A mix r : ℝ) := + Rat.cast_nonneg.mpr hslack0 + linarith [hbounds.1] + have hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runBetheThresholdFeasibility Ο„ A p Ξ΄ u r = .exhausted E β†’ + (u : ℝ) < cutoff := by + intro u E hrun + have h := runBetheThresholdFeasibility_exhausted_lt_optimum_add_slack + hm hΟ„0 hΟ„1 hApos hAupper hX hmax hmix0 hmix1 hΞ΄ hr + hspike hfloor p hrun + dsimp only [cutoff] + rw [betheSmoothingSlack] + push_cast + simpa [add_assoc] using h + have hlowN : (sN.low : ℝ) ≀ cutoff := by + simpa only [sN] using runBetheBisection_low_le_cutoff + Ο„ A p Ξ΄ r hbelow hlow0 N + have hwidthQ := runBetheBisection_width Ο„ A p Ξ΄ r N s0 + have hwidth : (sN.high : ℝ) - (sN.low : ℝ) = + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) := by + have hwidthQ' : sN.high - sN.low = + (betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N := by + simpa only [sN, s0, initialBetheBisectionState_high, + initialBetheBisectionState_low] using hwidthQ + exact_mod_cast hwidthQ' + have hhigh : (sN.high : ℝ) ≀ cutoff + + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) := by + linarith + have hobjective := + BetheEpigraphOracleAccepted_exact_objective_upper_compact + hm hΟ„0.le hΟ„1 hApos hΞ΄ hcertificate + have hheight : ((epigraphHeight q : β„š) : ℝ) ≀ (sN.high : ℝ) := by + exact_mod_cast hcertificate.2.1 + have hreturned : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + (sN.high : ℝ) + (betheObjectiveEvaluationError m p : ℝ) := by + have hobjective' : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + ((epigraphHeight q : β„š) : ℝ) + + (betheObjectiveEvaluationError m p : ℝ) := by + simpa only [affineNegativeObjective, acceptedBetheMatrix] using hobjective + linarith + refine ⟨q, hqN, hcertificate, + BetheEpigraphOracleAccepted_doublyStochastic hΞ΄.le hcertificate, + BetheEpigraphOracleAccepted_entry_floor hcertificate, ?_⟩ + dsimp only [cutoff] at hhigh + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraph.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraph.lean new file mode 100644 index 0000000000..6fabf0ec6d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraph.lean @@ -0,0 +1,565 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RationalEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.WeakSeparation +public import Mathlib.Tactic + +/-! # Bethe Epigraph -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The concrete directed Bethe epigraph data + +The upper-left `m`-by-`m` affine coordinates are flattened into `m^2` +rational coordinates. This file connects the already certified directed +objective and gradient evaluations to the generic rational epigraph oracle. +-/ + +/-- Flatten a square matrix using the finite product equivalence on its row and column indices. -/ +def squareMatrixToVector {m : β„•} {R : Type*} + (Y : Matrix (Fin m) (Fin m) R) : Fin (m * m) β†’ R := + fun k ↦ + let ij := finProdFinEquiv.symm k + Y ij.1 ij.2 + +/-- Recover a square matrix from its vector of entries using the finite product equivalence. -/ +def vectorToSquareMatrix {m : β„•} {R : Type*} + (y : Fin (m * m) β†’ R) : Matrix (Fin m) (Fin m) R := + fun i j ↦ y (finProdFinEquiv (i, j)) + +@[simp] theorem vectorToSquareMatrix_squareMatrixToVector + {m : β„•} {R : Type*} (Y : Matrix (Fin m) (Fin m) R) : + vectorToSquareMatrix (squareMatrixToVector Y) = Y := by + ext i j + simp [vectorToSquareMatrix, squareMatrixToVector] + +@[simp] theorem squareMatrixToVector_vectorToSquareMatrix + {m : β„•} {R : Type*} (y : Fin (m * m) β†’ R) : + squareMatrixToVector (vectorToSquareMatrix y) = y := by + ext k + change y (finProdFinEquiv (finProdFinEquiv.symm k)) = y k + rw [Equiv.apply_symm_apply] + +theorem squareMatrixToVector_injective {m : β„•} {R : Type*} : + Function.Injective (@squareMatrixToVector m R) := by + intro Y Z h + calc + Y = vectorToSquareMatrix (squareMatrixToVector Y) := + (vectorToSquareMatrix_squareMatrixToVector Y).symm + _ = vectorToSquareMatrix (squareMatrixToVector Z) := by rw [h] + _ = Z := vectorToSquareMatrix_squareMatrixToVector Z + +theorem sum_squareMatrixToVector {m : β„•} {R : Type*} [AddCommMonoid R] + (Y : Matrix (Fin m) (Fin m) R) : + (βˆ‘ k, squareMatrixToVector Y k) = βˆ‘ i, βˆ‘ j, Y i j := by + calc + (βˆ‘ k, squareMatrixToVector Y k) = + βˆ‘ ij : Fin m Γ— Fin m, + squareMatrixToVector Y (finProdFinEquiv ij) := + (finProdFinEquiv.sum_comp (squareMatrixToVector Y)).symm + _ = βˆ‘ ij : Fin m Γ— Fin m, Y ij.1 ij.2 := by + apply Finset.sum_congr rfl + intro ij _ + simp [squareMatrixToVector] + _ = βˆ‘ i, βˆ‘ j, Y i j := Fintype.sum_prod_type _ + +theorem finiteDot_squareMatrixToVector {m : β„•} {R : Type*} [CommSemiring R] + (G D : Matrix (Fin m) (Fin m) R) : + finiteDot (squareMatrixToVector G) (squareMatrixToVector D) = + matrixPairing G D := by + change (βˆ‘ k, squareMatrixToVector + (fun i j ↦ G i j * D i j) k) = βˆ‘ i, βˆ‘ j, G i j * D i j + exact sum_squareMatrixToVector (fun i j => G i j * D i j) + +theorem vectorL1_squareMatrixToVector {m : β„•} + (D : Matrix (Fin m) (Fin m) ℝ) : + vectorL1 (squareMatrixToVector D) = matrixL1 D := by + change (βˆ‘ k, squareMatrixToVector + (fun i j ↦ abs (D i j)) k) = βˆ‘ i, βˆ‘ j, abs (D i j) + exact sum_squareMatrixToVector (fun i j => abs (D i j)) + +/-- Rational affine matrix represented by a flattened epigraph base point. -/ +def betheAffineMatrixQ {m : β„•} (y : Fin (m * m) β†’ β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + birkhoffAffineMap (vectorToSquareMatrix y) + +/-- Concrete directed value and affine-gradient endpoints. -/ +def betheDirectedEpigraphData {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (p : β„•) : + DirectedEpigraphData (m * m) where + lower y := directedNegativeObjectiveLower Ο„ A (betheAffineMatrixQ y) p + gradient y := squareMatrixToVector + (affinePullbackGradient + (directedNegativeGradientLowerMatrix Ο„ A (betheAffineMatrixQ y) p)) + +theorem cast_vectorToSquareMatrix {m : β„•} + (y : Fin (m * m) β†’ β„š) (i j : Fin m) : + ((vectorToSquareMatrix y i j : β„š) : ℝ) = + vectorToSquareMatrix (fun k ↦ (y k : ℝ)) i j := by + rfl + +theorem cast_betheAffineMatrixQ {m : β„•} + (y : Fin (m * m) β†’ β„š) (i j : Fin (m + 1)) : + ((betheAffineMatrixQ y i j : β„š) : ℝ) = + birkhoffAffineMap (vectorToSquareMatrix + (fun k ↦ (y k : ℝ))) i j := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp [betheAffineMatrixQ, vectorToSquareMatrix] + Β· simp [betheAffineMatrixQ, vectorToSquareMatrix] + Β· simp [betheAffineMatrixQ, vectorToSquareMatrix] + Β· simp [betheAffineMatrixQ, vectorToSquareMatrix] + +/-- The stored rational value is a certified lower endpoint for the exact +negative regularized objective at every rational interior query. -/ +theorem betheDirectedEpigraphData_lower {m : β„•} + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {y : Fin (m * m) β†’ β„š} + (hX0 : βˆ€ i j, 0 < betheAffineMatrixQ y i j) + (hX1 : βˆ€ i j, betheAffineMatrixQ y i j < 1) (p : β„•) : + ((betheDirectedEpigraphData Ο„ A p).lower y : ℝ) ≀ + affineNegativeObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) + (vectorToSquareMatrix (fun k ↦ (y k : ℝ))) := by + have h := (directedNegativeObjective_bounds hΟ„0 hΟ„1 hA hX0 hX1 p).1 + simpa [betheDirectedEpigraphData, affineNegativeObjective, + cast_betheAffineMatrixQ] using! h + +/-- The flattened stored gradient has the same explicit coordinate error as +the affine pullback matrix. -/ +theorem betheDirectedEpigraphData_gradient_error {m : β„•} + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {y : Fin (m * m) β†’ β„š} + (hX0 : βˆ€ i j, 0 < betheAffineMatrixQ y i j) + (hX1 : βˆ€ i j, betheAffineMatrixQ y i j < 1) (p : β„•) + (k : Fin (m * m)) : + abs ((((betheDirectedEpigraphData Ο„ A p).gradient y k : β„š) : ℝ) - + squareMatrixToVector + (affinePullbackGradient + (negativeGradientMatrix (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ ((betheAffineMatrixQ y i j : β„š) : ℝ)))) k) ≀ + 16 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + let ij := finProdFinEquiv.symm k + simpa [betheDirectedEpigraphData, squareMatrixToVector, ij, + affinePullbackGradient, abs_sub_comm] using! + directedAffineGradient_error hΟ„0 hΟ„1 hA hX0 hX1 p ij.1 ij.2 + +/-- Exact bounded epigraph body in flattened affine coordinates. -/ +def BetheEpigraphTarget {m : β„•} + (Ο„ : ℝ) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ) + (Ξ΄ upper : ℝ) (z : Fin (m * m + 1) β†’ ℝ) : Prop := + let Y := vectorToSquareMatrix (epigraphBase z) + let X := birkhoffAffineMap Y + (βˆ€ i j, Ξ΄ ≀ X i j) ∧ + affineNegativeObjective Ο„ A Y ≀ epigraphHeight z ∧ + epigraphHeight z ≀ upper + +theorem BetheEpigraphTarget_doublyStochastic {m : β„•} + {Ο„ : ℝ} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + {Ξ΄ upper : ℝ} (hΞ΄ : 0 ≀ Ξ΄) {z : Fin (m * m + 1) β†’ ℝ} + (hz : BetheEpigraphTarget Ο„ A Ξ΄ upper z) : + IsDoublyStochastic + (birkhoffAffineMap (vectorToSquareMatrix (epigraphBase z))) := by + let Y := vectorToSquareMatrix (epigraphBase z) + let X := birkhoffAffineMap Y + have hfloor : βˆ€ i j, Ξ΄ ≀ X i j := by + simpa only [BetheEpigraphTarget, Y, X] using! hz.1 + refine ⟨fun i j ↦ hΞ΄.trans (hfloor i j), ?_, ?_⟩ + Β· exact birkhoffAffineMap_row_sum Y + Β· exact birkhoffAffineMap_col_sum Y + +/-- On the truncated rational domain, the concrete directed nonlinear oracle +returns only valid strict cuts for the exact Bethe epigraph. -/ +theorem betheDirectedEpigraphOracle_cut_valid {m : β„•} (hm : 0 < m) + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {Ξ΄ : β„š} (hΞ΄ : 0 < Ξ΄) {upper : ℝ} (p : β„•) + (E : RationalEllipsoidState (m * m + 1)) + (hqueryFloor : βˆ€ i j, Ξ΄ ≀ + betheAffineMatrixQ (epigraphBase E.center) i j) + {a : Fin (m * m + 1) β†’ β„š} + (hresponse : directedEpigraphOracle + (betheDirectedEpigraphData Ο„ A p) + (16 * (1 / 2 : β„š) ^ p) (m * m) E = .cut a) + {z : Fin (m * m + 1) β†’ ℝ} + (hz : BetheEpigraphTarget (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (Ξ΄ : ℝ) upper z) : + a β‰  0 ∧ finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ z i - rationalCenterReal E i) < 0 := by + let yq : Fin (m * m) β†’ β„š := epigraphBase E.center + let Yq : Matrix (Fin m) (Fin m) β„š := vectorToSquareMatrix yq + let Xq : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + birkhoffAffineMap Yq + let Y : Matrix (Fin m) (Fin m) ℝ := + vectorToSquareMatrix (epigraphBase z) + let X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ := + birkhoffAffineMap Y + have hqueryFloor' : βˆ€ i j, Ξ΄ ≀ Xq i j := by + simpa only [Xq, Yq, yq, betheAffineMatrixQ] using! hqueryFloor + have hquery := birkhoffAffineMap_interior hm hΞ΄ hqueryFloor' + have hXqDS := hquery.1 + have hXqInt := hquery.2 + have hXq0 : βˆ€ i j, 0 < Xq i j := by + intro i j + exact hΞ΄.trans_le (hqueryFloor' i j) + have hXq1 : βˆ€ i j, Xq i j < 1 := by + intro i j + have h := (hXqInt i).2 j |>.2 + change ((Xq i j : β„š) : ℝ) < 1 at h + exact_mod_cast h + have hΞ΄real : 0 ≀ (Ξ΄ : ℝ) := Rat.cast_nonneg.mpr hΞ΄.le + have hXDS : IsDoublyStochastic X := by + simpa only [X, Y] using! + BetheEpigraphTarget_doublyStochastic hΞ΄real hz + have htargetFloor : βˆ€ i j, (Ξ΄ : ℝ) ≀ X i j := by + simpa only [BetheEpigraphTarget, X, Y] using! hz.1 + have htargetEpigraph : + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) Y ≀ + epigraphHeight z := by + simpa only [BetheEpigraphTarget, X, Y] using! hz.2.1 + let YqR : Matrix (Fin m) (Fin m) ℝ := + fun i j ↦ (Yq i j : ℝ) + let Gm : Matrix (Fin m) (Fin m) ℝ := + affinePullbackGradient + (negativeGradientMatrix (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ (Xq i j : ℝ))) + let Gv : Fin (m * m) β†’ ℝ := squareMatrixToVector Gm + have hcastXq : birkhoffAffineMap YqR = + (fun i j ↦ (Xq i j : ℝ)) := by + ext i j + symm + simpa only [Xq, Yq, YqR, yq] using! cast_betheAffineMatrixQ yq i j + have hsupportMatrix := affineNegativeObjective_support hm + (Rat.cast_nonneg.mpr hΟ„0) + (A := fun i j ↦ (A i j : ℝ)) + (Y := YqR) (Z := Y) + (by rw [hcastXq]; exact hXqDS) + hXDS + (by rw [hcastXq]; exact hXqInt) + have hsupport : + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) YqR + + finiteDot Gv + (fun k ↦ epigraphBase z k - (yq k : ℝ)) ≀ + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) Y := by + have hDvec : + (fun k ↦ epigraphBase z k - (yq k : ℝ)) = + squareMatrixToVector (fun i j ↦ Y i j - YqR i j) := by + ext k + have hk : finProdFinEquiv (finProdFinEquiv.symm k) = k := + Equiv.apply_symm_apply finProdFinEquiv k + change epigraphBase z k - (yq k : ℝ) = + epigraphBase z (finProdFinEquiv (finProdFinEquiv.symm k)) - + (yq (finProdFinEquiv (finProdFinEquiv.symm k)) : ℝ) + rw [hk] + rw [hDvec, finiteDot_squareMatrixToVector Gm + (fun i j => Y i j - YqR i j)] + simpa only [Gm, hcastXq] using! hsupportMatrix + have hlower := betheDirectedEpigraphData_lower hΟ„0 hΟ„1 hA + (by simpa only [Xq, yq, betheAffineMatrixQ] using! hXq0) + (by simpa only [Xq, yq, betheAffineMatrixQ] using! hXq1) p + have hgradient : βˆ€ k, + abs ((((betheDirectedEpigraphData Ο„ A p).gradient yq k : β„š) : ℝ) - + Gv k) ≀ 16 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + intro k + simpa only [Gv, Gm, Xq, yq, betheAffineMatrixQ] using! + betheDirectedEpigraphData_gradient_error hΟ„0 hΟ„1 hA hXq0 hXq1 p k + have hD : vectorL1 (fun k ↦ epigraphBase z k - (yq k : ℝ)) ≀ + (m * m : ℝ) := by + rw [vectorL1] + calc + (βˆ‘ k, abs (epigraphBase z k - (yq k : ℝ))) ≀ βˆ‘ _k : Fin (m * m), 1 := by + apply Finset.sum_le_sum + intro k _ + let ij := finProdFinEquiv.symm k + have hk : finProdFinEquiv ij = k := by + simpa only [ij] using! Equiv.apply_symm_apply finProdFinEquiv k + have hz0 : 0 ≀ epigraphBase z k := by + have := hXDS.nonnegative ij.1.castSucc ij.2.castSucc + simp only [X, Y, birkhoffAffineMap_castSucc_castSucc, + vectorToSquareMatrix] at this + rwa [hk] at this + have hz1 : epigraphBase z k ≀ 1 := by + have := hXDS.entry_le_one ij.1.castSucc ij.2.castSucc + simp only [X, Y, birkhoffAffineMap_castSucc_castSucc, + vectorToSquareMatrix] at this + rwa [hk] at this + have hq0 : 0 ≀ (yq k : ℝ) := by + have := hXqDS.nonnegative ij.1.castSucc ij.2.castSucc + simp only [Xq, Yq, birkhoffAffineMap_castSucc_castSucc, + vectorToSquareMatrix] at this + rwa [hk] at this + have hq1 : (yq k : ℝ) ≀ 1 := by + have := hXqDS.entry_le_one ij.1.castSucc ij.2.castSucc + simp only [Xq, Yq, birkhoffAffineMap_castSucc_castSucc, + vectorToSquareMatrix] at this + rwa [hk] at this + rw [abs_le] + constructor <;> linarith + _ = (m * m : ℝ) := by simp + apply directedEpigraphOracle_cut_valid + (data := betheDirectedEpigraphData Ο„ A p) + (he := by positivity) E hresponse + (fY := affineNegativeObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) YqR) + (fZ := affineNegativeObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y) + (G := Gv) (z := z) + Β· simpa only [yq] using! hsupport + Β· simpa only [yq, YqR] using! hlower + Β· simpa only [yq, Rat.cast_mul, Rat.cast_pow, Rat.cast_div, + Rat.cast_one, Rat.cast_ofNat] using! hgradient + Β· norm_num only [Rat.cast_mul, Rat.cast_natCast] + simpa only [yq] using! hD + Β· exact htargetEpigraph + +/-- Matrix covector selecting one full Birkhoff coordinate. -/ +def matrixEntryCovector {n : β„•} (i j : Fin n) : Matrix (Fin n) (Fin n) β„š := + fun a b ↦ if a = i ∧ b = j then 1 else 0 + +/-- Normal for the exact lower-floor inequality at one recovered Birkhoff +entry. The last epigraph coordinate is zero. -/ +def betheFloorCutNormal {m : β„•} (i j : Fin (m + 1)) : + Fin (m * m + 1) β†’ β„š := + Fin.snoc (fun k ↦ + -squareMatrixToVector + (affinePullbackGradient (matrixEntryCovector i j)) k) 0 + +@[simp] theorem betheFloorCutNormal_castSucc {m : β„•} + (i j : Fin (m + 1)) (k : Fin (m * m)) : + betheFloorCutNormal i j k.castSucc = + -squareMatrixToVector + (affinePullbackGradient (matrixEntryCovector i j)) k := by + simp [betheFloorCutNormal] + +@[simp] theorem betheFloorCutNormal_last {m : β„•} + (i j : Fin (m + 1)) : + betheFloorCutNormal i j (Fin.last (m * m)) = 0 := by + simp [betheFloorCutNormal] + +theorem affinePullback_entryCovector_ne_zero {m : β„•} (hm : 0 < m) + (i j : Fin (m + 1)) : + affinePullbackGradient (matrixEntryCovector i j) β‰  0 := by + let k0 : Fin m := ⟨0, hm⟩ + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· intro hzero + have h := congrFun (congrFun hzero k0) k0 + simp [affinePullbackGradient, matrixEntryCovector] at h + Β· intro hzero + have h := congrFun (congrFun hzero k0) j + have hne : Fin.last m β‰  j.castSucc := (Fin.castSucc_ne_last j).symm + simp [affinePullbackGradient, matrixEntryCovector, hne] at h + Β· intro hzero + have h := congrFun (congrFun hzero i) k0 + have hne : Fin.last m β‰  i.castSucc := (Fin.castSucc_ne_last i).symm + simp [affinePullbackGradient, matrixEntryCovector, hne] at h + Β· intro hzero + have h := congrFun (congrFun hzero i) j + have hnei : Fin.last m β‰  i.castSucc := (Fin.castSucc_ne_last i).symm + have hnej : Fin.last m β‰  j.castSucc := (Fin.castSucc_ne_last j).symm + simp [affinePullbackGradient, matrixEntryCovector, hnei, hnej] at h + +theorem betheFloorCutNormal_ne_zero {m : β„•} (hm : 0 < m) + (i j : Fin (m + 1)) : betheFloorCutNormal i j β‰  0 := by + intro hzero + apply affinePullback_entryCovector_ne_zero hm i j + have hvec : squareMatrixToVector + (affinePullbackGradient (matrixEntryCovector i j)) = 0 := by + ext k + have h := congrFun hzero k.castSucc + rw [betheFloorCutNormal_castSucc] at h + simp only [Pi.zero_apply] at h + exact neg_eq_zero.mp h + exact squareMatrixToVector_injective hvec + +/-- Fixed deterministic order of all recovered matrix entries. -/ +def fullMatrixEntryList (m : β„•) : List (Fin (m + 1) Γ— Fin (m + 1)) := + (List.ofFn fun i : Fin (m + 1) ↦ i).flatMap fun i ↦ + (List.ofFn fun j : Fin (m + 1) ↦ j).map fun j ↦ (i, j) + +theorem mem_fullMatrixEntryList (m : β„•) (i j : Fin (m + 1)) : + (i, j) ∈ fullMatrixEntryList m := by + rw [fullMatrixEntryList, List.mem_flatMap] + refine ⟨i, (List.mem_ofFn).2 ⟨i, rfl⟩, ?_⟩ + rw [List.mem_map] + exact ⟨j, (List.mem_ofFn).2 ⟨j, rfl⟩, rfl⟩ + +/-- Scan the supplied entry list for the first affine matrix coordinate strictly below the +floor. -/ +def firstBetheFloorViolation {m : β„•} (Ξ΄ : β„š) + (y : Fin (m * m) β†’ β„š) : + List (Fin (m + 1) Γ— Fin (m + 1)) β†’ + Option (Fin (m + 1) Γ— Fin (m + 1)) + | [] => none + | ij :: entries => + if betheAffineMatrixQ y ij.1 ij.2 < Ξ΄ then some ij + else firstBetheFloorViolation Ξ΄ y entries + +/-- Search every matrix entry for a violation of the prescribed affine-coordinate floor. -/ +def firstBetheFloorViolationAll {m : β„•} (Ξ΄ : β„š) + (y : Fin (m * m) β†’ β„š) : Option (Fin (m + 1) Γ— Fin (m + 1)) := + firstBetheFloorViolation Ξ΄ y (fullMatrixEntryList m) + +theorem firstBetheFloorViolation_is_below {m : β„•} {Ξ΄ : β„š} + {y : Fin (m * m) β†’ β„š} + {entries : List (Fin (m + 1) Γ— Fin (m + 1))} {ij} + (hfind : firstBetheFloorViolation Ξ΄ y entries = some ij) : + betheAffineMatrixQ y ij.1 ij.2 < Ξ΄ := by + induction entries with + | nil => simp [firstBetheFloorViolation] at hfind + | cons ab entries ih => + rw [firstBetheFloorViolation] at hfind + split at hfind <;> rename_i htest + Β· cases hfind + exact htest + Β· exact ih hfind + +theorem firstBetheFloorViolation_eq_none_iff {m : β„•} (Ξ΄ : β„š) + (y : Fin (m * m) β†’ β„š) + (entries : List (Fin (m + 1) Γ— Fin (m + 1))) : + firstBetheFloorViolation Ξ΄ y entries = none ↔ + βˆ€ ij ∈ entries, Ξ΄ ≀ betheAffineMatrixQ y ij.1 ij.2 := by + induction entries with + | nil => simp [firstBetheFloorViolation] + | cons ab entries ih => + rw [firstBetheFloorViolation] + split <;> rename_i htest + Β· constructor + Β· intro hnone + contradiction + Β· intro hall + exact ((not_lt_of_ge (hall ab (by simp))) htest).elim + Β· rw [ih] + have hab : Ξ΄ ≀ betheAffineMatrixQ y ab.1 ab.2 := not_lt.mp htest + simp [hab] + +theorem firstBetheFloorViolationAll_eq_none_iff {m : β„•} (Ξ΄ : β„š) + (y : Fin (m * m) β†’ β„š) : + firstBetheFloorViolationAll Ξ΄ y = none ↔ + βˆ€ i j, Ξ΄ ≀ betheAffineMatrixQ y i j := by + rw [firstBetheFloorViolationAll, + firstBetheFloorViolation_eq_none_iff] + constructor + Β· intro h i j + exact h (i, j) (mem_fullMatrixEntryList m i j) + Β· intro h ij _ + exact h ij.1 ij.2 + +theorem matrixPairing_entryCovector {n : β„•} (i j : Fin n) + (D : Matrix (Fin n) (Fin n) ℝ) : + matrixPairing (fun a b ↦ (matrixEntryCovector i j a b : ℝ)) D = D i j := by + unfold matrixPairing + have hrow : βˆ€ a : Fin n, + (βˆ‘ b, (matrixEntryCovector i j a b : ℝ) * D a b) = + if a = i then D i j else 0 := by + intro a + by_cases hai : a = i + Β· subst a + simp only [if_true] + calc + (βˆ‘ b, (matrixEntryCovector i j i b : ℝ) * D i b) = + (matrixEntryCovector i j i j : ℝ) * D i j := by + apply Finset.sum_eq_single j + Β· intro b _ hbj + simp [matrixEntryCovector, hbj] + Β· simp + _ = D i j := by simp [matrixEntryCovector] + Β· simp [matrixEntryCovector, hai] + simp_rw [hrow] + simp + +/-- A detected floor violation gives a strict cut for every target point +whose recovered matrix satisfies the floor. -/ +theorem betheFloorCut_valid {m : β„•} {Ξ΄ : β„š} + {y : Fin (m * m) β†’ β„š} {i j : Fin (m + 1)} + (hbelow : betheAffineMatrixQ y i j < Ξ΄) + {z : Fin (m * m + 1) β†’ ℝ} + (hfloor : (Ξ΄ : ℝ) ≀ + birkhoffAffineMap (vectorToSquareMatrix (epigraphBase z)) i j) : + finiteDot (fun k ↦ (betheFloorCutNormal i j k : ℝ)) + (fun k ↦ z k - + (((Fin.snoc y (0 : β„š) : Fin (m * m + 1) β†’ β„š) k : β„š) : ℝ)) < 0 := by + let Yq : Matrix (Fin m) (Fin m) ℝ := + vectorToSquareMatrix (fun k ↦ (y k : ℝ)) + let Y : Matrix (Fin m) (Fin m) ℝ := + vectorToSquareMatrix (epigraphBase z) + let Gq : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ := + fun a b ↦ (matrixEntryCovector i j a b : ℝ) + have hadjoint := matrixPairing_affineMap_sub Gq Yq Y + have hentry : + birkhoffAffineMap Y i j - birkhoffAffineMap Yq i j = + matrixPairing + (affinePullbackGradient Gq) (fun a b ↦ Y a b - Yq a b) := by + rw [← hadjoint] + exact (matrixPairing_entryCovector i j + (fun a b => birkhoffAffineMap Y a b - birkhoffAffineMap Yq a b)).symm + have hqueryCast : birkhoffAffineMap Yq i j = + (betheAffineMatrixQ y i j : ℝ) := by + symm + exact cast_betheAffineMatrixQ y i j + have hstrict : 0 < birkhoffAffineMap Y i j - birkhoffAffineMap Yq i j := by + rw [hqueryCast] + have hbelowR : (betheAffineMatrixQ y i j : ℝ) < (Ξ΄ : ℝ) := by + exact_mod_cast hbelow + linarith + have hpullCast : + (fun a b ↦ + ((affinePullbackGradient (matrixEntryCovector i j) a b : β„š) : ℝ)) = + affinePullbackGradient Gq := by + ext a b + simp [Gq, affinePullbackGradient, matrixEntryCovector] + have hnormalCast : + (fun k ↦ ((-squareMatrixToVector + (affinePullbackGradient (matrixEntryCovector i j)) k : β„š) : ℝ)) = + fun k ↦ -squareMatrixToVector (affinePullbackGradient Gq) k := by + ext k + rw [Rat.cast_neg] + congr 1 + have hk := congrFun (congrArg squareMatrixToVector hpullCast) k + exact hk + have hdotBase : + finiteDot + (fun k ↦ ((-squareMatrixToVector + (affinePullbackGradient (matrixEntryCovector i j)) k : β„š) : ℝ)) + (fun k ↦ epigraphBase z k - (y k : ℝ)) = + -matrixPairing (affinePullbackGradient Gq) + (fun a b ↦ Y a b - Yq a b) := by + have hDvec : (fun k ↦ epigraphBase z k - (y k : ℝ)) = + squareMatrixToVector (fun a b ↦ Y a b - Yq a b) := by + ext k + have hk : finProdFinEquiv (finProdFinEquiv.symm k) = k := + Equiv.apply_symm_apply finProdFinEquiv k + change epigraphBase z k - (y k : ℝ) = + epigraphBase z (finProdFinEquiv (finProdFinEquiv.symm k)) - + (y (finProdFinEquiv (finProdFinEquiv.symm k)) : ℝ) + rw [hk] + rw [hDvec, hnormalCast] + rw [finiteDot] + simp_rw [neg_mul, Finset.sum_neg_distrib] + rw [← finiteDot, finiteDot_squareMatrixToVector + (affinePullbackGradient Gq) (fun a b => Y a b - Yq a b)] + rw [finiteDot, Fin.sum_univ_castSucc] + simp only [betheFloorCutNormal_castSucc, betheFloorCutNormal_last, + Rat.cast_neg, Rat.cast_zero, zero_mul, add_zero, Fin.snoc_last, + Fin.snoc_castSucc] + rw [finiteDot] at hdotBase + norm_num only [Rat.cast_neg] at hdotBase + simp only [epigraphBase] at hdotBase + rw [hdotBase, ← hentry] + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphFeasibility.lean new file mode 100644 index 0000000000..5463427925 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphFeasibility.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph +public import Mathlib.Tactic + +/-! # Bethe Epigraph Feasibility -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# A complete executable oracle for the bounded Bethe epigraph + +The oracle first enforces every entry floor exactly, then the rational height +cap, and only then invokes the directed elementary-function oracle. This +ordering makes every logarithm query legal and leaves no domain condition as +an oracle hypothesis. +-/ + +/-- Normal of the upper bound on the last, epigraph-height coordinate. -/ +def epigraphUpperNormal (d : β„•) : Fin (d + 1) β†’ β„š := + Fin.snoc 0 1 + +theorem epigraphUpperNormal_ne_zero (d : β„•) : + epigraphUpperNormal d β‰  0 := by + intro hzero + have h := congrFun hzero (Fin.last d) + norm_num [epigraphUpperNormal] at h + +theorem epigraphUpperNormal_dot_displacement {d : β„•} + (z : Fin (d + 1) β†’ ℝ) (q : Fin (d + 1) β†’ β„š) : + finiteDot (fun k ↦ (epigraphUpperNormal d k : ℝ)) + (fun k ↦ z k - (q k : ℝ)) = + epigraphHeight z - (epigraphHeight q : β„š) := by + rw [finiteDot, Fin.sum_univ_castSucc] + simp [epigraphUpperNormal, epigraphHeight] + +/-- Complete rational oracle for a height-bounded, floor-truncated Bethe +epigraph. -/ +def betheBoundedEpigraphOracle {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper : β„š) : RationalCentralOracle (m * m + 1) := + fun E ↦ + match firstBetheFloorViolationAll Ξ΄ (epigraphBase E.center) with + | some ij => .cut (betheFloorCutNormal ij.1 ij.2) + | none => + if upper < epigraphHeight E.center then + .cut (epigraphUpperNormal (m * m)) + else + directedEpigraphOracle + (betheDirectedEpigraphData Ο„ A p) + (16 * (1 / 2 : β„š) ^ p) (m * m) E + +/-- Exact rational facts obtained whenever the complete oracle accepts. -/ +def BetheEpigraphOracleAccepted {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper : β„š) (q : Fin (m * m + 1) β†’ β„š) : Prop := + (βˆ€ i j, Ξ΄ ≀ betheAffineMatrixQ (epigraphBase q) i j) ∧ + epigraphHeight q ≀ upper ∧ + (betheDirectedEpigraphData Ο„ A p).lower (epigraphBase q) ≀ + epigraphHeight q + (16 * (1 / 2 : β„š) ^ p) * (m * m) + +/-- Full rational objective-evaluation loss charged on acceptance. -/ +def betheObjectiveEvaluationError (m p : β„•) : β„š := + 16 * (1 / 2 : β„š) ^ p * (m * m) + + 3 * (m + 1) ^ 2 * (1 / 2 : β„š) ^ p + +theorem betheObjectiveEvaluationError_nonneg (m p : β„•) : + 0 ≀ betheObjectiveEvaluationError m p := by + rw [betheObjectiveEvaluationError] + positivity + +/-- Real matrix encoded by the base coordinates of an accepted epigraph +point. -/ +def acceptedBetheMatrix {m : β„•} (q : Fin (m * m + 1) β†’ β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ := + birkhoffAffineMap + (vectorToSquareMatrix (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) + +/-- The exact floor tests and affine recovery identities make every accepted +matrix doubly stochastic. -/ +theorem BetheEpigraphOracleAccepted_doublyStochastic {m : β„•} + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + {p : β„•} {Ξ΄ upper : β„š} (hΞ΄ : 0 ≀ Ξ΄) + {q : Fin (m * m + 1) β†’ β„š} + (haccepted : BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q) : + IsDoublyStochastic (acceptedBetheMatrix q) := by + refine ⟨?_, birkhoffAffineMap_row_sum _, birkhoffAffineMap_col_sum _⟩ + intro i j + have hfloorQ := haccepted.1 i j + have hfloor : (Ξ΄ : ℝ) ≀ acceptedBetheMatrix q i j := by + change (Ξ΄ : ℝ) ≀ birkhoffAffineMap + (vectorToSquareMatrix (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) i j + rw [← cast_betheAffineMatrixQ (epigraphBase q) i j] + exact_mod_cast hfloorQ + exact (Rat.cast_nonneg.mpr hΞ΄).trans hfloor + +theorem BetheEpigraphOracleAccepted_entry_floor {m : β„•} + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + {p : β„•} {Ξ΄ upper : β„š} + {q : Fin (m * m + 1) β†’ β„š} + (haccepted : BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q) : + βˆ€ i j, (Ξ΄ : ℝ) ≀ acceptedBetheMatrix q i j := by + intro i j + change (Ξ΄ : ℝ) ≀ birkhoffAffineMap + (vectorToSquareMatrix (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) i j + rw [← cast_betheAffineMatrixQ (epigraphBase q) i j] + exact_mod_cast haccepted.1 i j + +/-- Every cut returned by the complete executable oracle is valid for the +exact bounded epigraph. -/ +theorem betheBoundedEpigraphOracle_valid {m : β„•} (hm : 0 < m) + {Ο„ : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {Ξ΄ : β„š} (hΞ΄ : 0 < Ξ΄) (p : β„•) (upper : β„š) : + RationalCentralOracleValid + (BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ)) + (betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) := by + intro E a hresponse + rw [betheBoundedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hfloorScan + Β· rename_i ij + cases hresponse + refine ⟨betheFloorCutNormal_ne_zero hm ij.1 ij.2, ?_⟩ + intro z hz + have hbelow : betheAffineMatrixQ (epigraphBase E.center) + ij.1 ij.2 < Ξ΄ := by + apply firstBetheFloorViolation_is_below + simpa only [firstBetheFloorViolationAll] using! hfloorScan + have htargetFloor : (Ξ΄ : ℝ) ≀ + birkhoffAffineMap + (vectorToSquareMatrix (epigraphBase z)) ij.1 ij.2 := by + simpa only [BetheEpigraphTarget] using! hz.1 ij.1 ij.2 + have hcut := betheFloorCut_valid hbelow htargetFloor + rw [finiteDot, Fin.sum_univ_castSucc] at hcut ⊒ + simpa [rationalCenterReal, epigraphBase] using! hcut.le + Β· split at hresponse <;> rename_i hheight + Β· cases hresponse + refine ⟨epigraphUpperNormal_ne_zero (m * m), ?_⟩ + intro z hz + have hdot := epigraphUpperNormal_dot_displacement z E.center + rw [show finiteDot + (fun i ↦ (epigraphUpperNormal (m * m) i : ℝ)) + (fun i ↦ z i - rationalCenterReal E i) = + epigraphHeight z - (epigraphHeight E.center : β„š) by + simpa only [rationalCenterReal] using! hdot] + have hzUpper : epigraphHeight z ≀ (upper : ℝ) := by + simpa only [BetheEpigraphTarget] using! hz.2.2 + have hheightReal : (upper : ℝ) < + ((epigraphHeight E.center : β„š) : ℝ) := by + exact_mod_cast hheight + linarith + Β· have hqueryFloor : βˆ€ i j, Ξ΄ ≀ + betheAffineMatrixQ (epigraphBase E.center) i j := + (firstBetheFloorViolationAll_eq_none_iff Ξ΄ + (epigraphBase E.center)).mp hfloorScan + refine ⟨directedEpigraphOracle_cut_ne_zero + (betheDirectedEpigraphData Ο„ A p) + (16 * (1 / 2 : β„š) ^ p) (m * m) E hresponse, ?_⟩ + intro z hz + exact (betheDirectedEpigraphOracle_cut_valid hm hΟ„0 hΟ„1 hA hΞ΄ + (upper := (upper : ℝ)) p E hqueryFloor hresponse hz).2.le + +/-- Acceptance of the complete oracle certifies every rational test in its +three branches. -/ +theorem betheBoundedEpigraphOracle_acceptsOnly {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper : β„š) : + RationalCentralOracleAcceptsOnly + (BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper) + (betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) := by + intro E hresponse + rw [betheBoundedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hfloorScan + Β· contradiction + Β· split at hresponse <;> rename_i hheight + Β· contradiction + Β· rw [directedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hnonlinear + Β· contradiction + Β· cases hresponse + refine ⟨ + (firstBetheFloorViolationAll_eq_none_iff Ξ΄ + (epigraphBase E.center)).mp hfloorScan, + not_lt.mp hheight, ?_⟩ + exact not_lt.mp hnonlinear + +/-- Acceptance controls the exact negative objective, not merely its directed +lower endpoint. The first error term is the safety margin in the nonlinear +cut test; the second is the full width of the directed objective interval. +Keeping both terms explicit prevents a one-sided-evaluation gap in the weak +optimization proof. -/ +theorem BetheEpigraphOracleAccepted_exact_objective_upper {m : β„•} + (hm : 0 < m) {Ο„ : β„š} + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {p : β„•} {Ξ΄ upper : β„š} (hΞ΄ : 0 < Ξ΄) + {q : Fin (m * m + 1) β†’ β„š} + (haccepted : BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q) : + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (vectorToSquareMatrix + (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) ≀ + ((epigraphHeight q : β„š) : ℝ) + + ((16 * (1 / 2 : β„š) ^ p * (m * m) : β„š) : ℝ) + + 3 * ((m + 1 : β„•) : ℝ) ^ 2 * + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + let y : Fin (m * m) β†’ β„š := epigraphBase q + let Xq : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + betheAffineMatrixQ y + have hfloor : βˆ€ i j, Ξ΄ ≀ Xq i j := by + simpa only [Xq, y] using! haccepted.1 + have hX0 : βˆ€ i j, 0 < Xq i j := fun i j ↦ + hΞ΄.trans_le (hfloor i j) + have hinterior := birkhoffAffineMap_interior hm hΞ΄ + (Y := vectorToSquareMatrix y) (by + simpa only [Xq, betheAffineMatrixQ] using! hfloor) + have hX1 : βˆ€ i j, Xq i j < 1 := by + intro i j + have h := (hinterior.2 i).2 j |>.2 + change ((Xq i j : β„š) : ℝ) < 1 at h + exact_mod_cast h + have hbounds := directedNegativeObjective_bounds hΟ„0 hΟ„1 hA hX0 hX1 p + have hlowerAcceptedQ : + directedNegativeObjectiveLower Ο„ A Xq p ≀ + epigraphHeight q + 16 * (1 / 2 : β„š) ^ p * (m * m) := by + simpa only [BetheEpigraphOracleAccepted, + betheDirectedEpigraphData, Xq, y] using! haccepted.2.2 + have hlowerAccepted : + (directedNegativeObjectiveLower Ο„ A Xq p : ℝ) ≀ + ((epigraphHeight q : β„š) : ℝ) + + ((16 * (1 / 2 : β„š) ^ p * (m * m) : β„š) : ℝ) := by + exact_mod_cast hlowerAcceptedQ + have hcast : + birkhoffAffineMap + (vectorToSquareMatrix + (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) = + fun i j ↦ ((Xq i j : β„š) : ℝ) := by + ext i j + symm + simpa only [Xq, y] using! cast_betheAffineMatrixQ y i j + unfold affineNegativeObjective + rw [hcast] + linarith [hbounds.2.1, hbounds.2.2] + +theorem BetheEpigraphOracleAccepted_exact_objective_upper_compact {m : β„•} + (hm : 0 < m) {Ο„ : β„š} + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {p : β„•} {Ξ΄ upper : β„š} (hΞ΄ : 0 < Ξ΄) + {q : Fin (m * m + 1) β†’ β„š} + (haccepted : BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q) : + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (vectorToSquareMatrix + (fun k ↦ ((epigraphBase q k : β„š) : ℝ))) ≀ + ((epigraphHeight q : β„š) : ℝ) + + (betheObjectiveEvaluationError m p : ℝ) := by + have h := BetheEpigraphOracleAccepted_exact_objective_upper + hm hΟ„0 hΟ„1 hA hΞ΄ haccepted + rw [betheObjectiveEvaluationError] + norm_num only [Rat.cast_add, Rat.cast_mul, Rat.cast_pow, Rat.cast_div, + Rat.cast_one, Rat.cast_ofNat, Rat.cast_natCast, Nat.cast_add, + Nat.cast_one, Nat.cast_mul, Nat.cast_pow] at h ⊒ + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphGeometry.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphGeometry.lean new file mode 100644 index 0000000000..19bab98e27 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheEpigraphGeometry.lean @@ -0,0 +1,783 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableInterior +public import LeanPool.BeyondBethe.BeyondBethe.ApproximateKKT +public import Mathlib.Tactic + +/-! # Bethe Epigraph Geometry -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Explicit geometry of the truncated Bethe epigraph + +This file supplies the quantitative geometry needed by the rational +ellipsoid routine. In particular, it records an ordinary binary-input range +bound and exact formulas for one-coordinate perturbations in the flattened +Birkhoff affine coordinates. +-/ + +/-- A polynomially encoded global range for the regularized objective on the +Birkhoff polytope of a normalized positive rational matrix. -/ +def rationalRegularizedObjectiveRange {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : β„š := + n * rationalMatrixEntryBitBound A + 3 * n ^ 2 + +theorem rationalRegularizedObjectiveRange_nonneg {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + 0 ≀ rationalRegularizedObjectiveRange A := by + rw [rationalRegularizedObjectiveRange] + positivity + +/-- The displayed rational range bounds the difference between the objective +at any two doubly stochastic matrices. -/ +theorem regularizedBetheObjective_sub_le_rationalRange + {n : β„•} (hn : 1 ≀ n) {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin n) (Fin n) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X Z : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) (hZ : IsDoublyStochastic Z) : + regularizedBetheObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) Z ≀ + (rationalRegularizedObjectiveRange A : ℝ) := by + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp (by omega) + let B := rationalMatrixEntryBitBound A + let m : β„š := (1 / 2 : β„š) ^ B + have hmQ : 0 < m := by positivity + have hm : 0 < (m : ℝ) := Rat.cast_pos.mpr hmQ + have hAlower : βˆ€ i j, (m : ℝ) ≀ (A i j : ℝ) := by + intro i j + exact_mod_cast (matrix_dyadic_bitBound_lt_entry hApos i j).le + have hAposR : Matrix.Positive (fun i j ↦ (A i j : ℝ)) := by + intro i j + exact Rat.cast_pos.mpr (hApos i j) + have hAupperR : βˆ€ i j, (A i j : ℝ) ≀ 1 := by + intro i j + exact_mod_cast hAupper i j + have hentropyX0 := totalRowEntropy_nonneg hX + have hentropyZ0 := totalRowEntropy_nonneg hZ + have hentropyX := totalRowEntropy_le hX + have hlogn : Real.log n ≀ (n : ℝ) := by + have hlog := log_natCast_le_natCast_mul_log_two hn + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hn0 : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hentropyX' : totalRowEntropy X ≀ (n : ℝ) ^ 2 := by + simp only [Fintype.card_fin] at hentropyX + have hn0 : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hbetheUpper := betheObjective_le_totalRowEntropy + hAposR hAupperR hX + have hbetheLower := betheObjective_lower_of_entry_lower hm hAlower hZ + simp only [Fintype.card_fin] at hbetheLower + have hΟ„0R : 0 ≀ (Ο„ : ℝ) := Rat.cast_nonneg.mpr hΟ„0 + have hΟ„1R : (Ο„ : ℝ) ≀ 1 := by exact_mod_cast hΟ„1 + have hregUpper : + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ≀ 2 * (n : ℝ) ^ 2 := by + unfold regularizedBetheObjective + have hΟ„Entropy : (Ο„ : ℝ) * totalRowEntropy X ≀ totalRowEntropy X := + mul_le_of_le_one_left hentropyX0 hΟ„1R + linarith + have hregLower : + (n : ℝ) * Real.log (m : ℝ) - n ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Z := by + unfold regularizedBetheObjective + have hΟ„Entropy : 0 ≀ (Ο„ : ℝ) * totalRowEntropy Z := + mul_nonneg hΟ„0R hentropyZ0 + linarith + have hlogm : Real.log (m : ℝ) = -(B : ℝ) * Real.log 2 := by + simp only [m, Rat.cast_pow, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] + rw [Real.log_pow] + rw [show (1 / 2 : ℝ) = (2 : ℝ)⁻¹ by norm_num, Real.log_inv] + ring + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hB0 : 0 ≀ (B : ℝ) := by positivity + have hnR : (1 : ℝ) ≀ n := by exact_mod_cast hn + rw [rationalRegularizedObjectiveRange] + push_cast + rw [hlogm] at hregLower + nlinarith [mul_le_mul_of_nonneg_left hlog2 hB0] + +/-- Explicit absolute bounds on the negative regularized objective. These +give rational endpoints for bisection without evaluating a logarithm. -/ +theorem negativeRegularizedBetheObjective_rational_bounds + {n : β„•} (hn : 1 ≀ n) {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin n) (Fin n) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) : + ((-(2 * n ^ 2 : β„š) : β„š) : ℝ) ≀ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ∧ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ≀ + ((n * rationalMatrixEntryBitBound A + n : β„•) : ℝ) := by + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp (by omega) + let B := rationalMatrixEntryBitBound A + let a : β„š := (1 / 2 : β„š) ^ B + have haQ : 0 < a := by positivity + have ha : 0 < (a : ℝ) := Rat.cast_pos.mpr haQ + have hAlower : βˆ€ i j, (a : ℝ) ≀ (A i j : ℝ) := by + intro i j + exact_mod_cast (matrix_dyadic_bitBound_lt_entry hApos i j).le + have hAposR : Matrix.Positive (fun i j ↦ (A i j : ℝ)) := by + intro i j + exact Rat.cast_pos.mpr (hApos i j) + have hAupperR : βˆ€ i j, (A i j : ℝ) ≀ 1 := by + intro i j + exact_mod_cast hAupper i j + have hentropy0 := totalRowEntropy_nonneg hX + have hentropy := totalRowEntropy_le hX + have hlogn : Real.log n ≀ (n : ℝ) := by + have hlog := log_natCast_le_natCast_mul_log_two hn + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hn0 : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hentropy' : totalRowEntropy X ≀ (n : ℝ) ^ 2 := by + simp only [Fintype.card_fin] at hentropy + have hn0 : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hbetheUpper := betheObjective_le_totalRowEntropy + hAposR hAupperR hX + have hbetheLower := betheObjective_lower_of_entry_lower ha hAlower hX + simp only [Fintype.card_fin] at hbetheLower + have hΟ„0R : 0 ≀ (Ο„ : ℝ) := Rat.cast_nonneg.mpr hΟ„0 + have hΟ„1R : (Ο„ : ℝ) ≀ 1 := by exact_mod_cast hΟ„1 + have hregUpper : + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X ≀ 2 * (n : ℝ) ^ 2 := by + unfold regularizedBetheObjective + have hΟ„Entropy : (Ο„ : ℝ) * totalRowEntropy X ≀ totalRowEntropy X := + mul_le_of_le_one_left hentropy0 hΟ„1R + linarith + have hregLower : + (n : ℝ) * Real.log (a : ℝ) - n ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X := by + unfold regularizedBetheObjective + have hΟ„Entropy : 0 ≀ (Ο„ : ℝ) * totalRowEntropy X := + mul_nonneg hΟ„0R hentropy0 + linarith + have hloga : Real.log (a : ℝ) = -(B : ℝ) * Real.log 2 := by + simp only [a, Rat.cast_pow, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] + rw [Real.log_pow] + rw [show (1 / 2 : ℝ) = (2 : ℝ)⁻¹ by norm_num, Real.log_inv] + ring + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hB0 : 0 ≀ (B : ℝ) := by positivity + rw [hloga] at hregLower + constructor + Β· push_cast + linarith + Β· push_cast + nlinarith [mul_le_mul_of_nonneg_left hlog2 hB0] + +/-- A vector with a single nonzero coordinate. -/ +def coordinateSpike {d : β„•} {R : Type*} [Zero R] + (k : Fin d) (r : R) : Fin d β†’ R := + fun i ↦ if i = k then r else 0 + +@[simp] theorem coordinateSpike_apply_self {d : β„•} {R : Type*} [Zero R] + (k : Fin d) (r : R) : coordinateSpike k r k = r := by + simp [coordinateSpike] + +theorem vectorL1_coordinateSpike {d : β„•} (k : Fin d) (r : ℝ) : + vectorL1 (coordinateSpike k r) = abs r := by + classical + rw [vectorL1, Finset.sum_eq_single k] + Β· simp [coordinateSpike] + Β· intro b _ hbk + simp [coordinateSpike, hbk] + Β· simp + +/-- Package a base vector and a height into one epigraph point. -/ +def epigraphPoint {d : β„•} {R : Type*} + (y : Fin d β†’ R) (s : R) : Fin (d + 1) β†’ R := + Fin.snoc y s + +@[simp] theorem epigraphBase_epigraphPoint {d : β„•} {R : Type*} + (y : Fin d β†’ R) (s : R) : epigraphBase (epigraphPoint y s) = y := by + ext i + simp [epigraphBase, epigraphPoint] + +@[simp] theorem epigraphHeight_epigraphPoint {d : β„•} {R : Type*} + (y : Fin d β†’ R) (s : R) : epigraphHeight (epigraphPoint y s) = s := by + simp [epigraphHeight, epigraphPoint] + +/-- Adding one flattened-coordinate spike changes the recovered full matrix +by at most the spike magnitude in every entry. -/ +theorem birkhoffAffineMap_vector_spike_abs_sub_le + {m : β„•} (y : Fin (m * m) β†’ ℝ) (k : Fin (m * m)) (r : ℝ) + (i j : Fin (m + 1)) : + abs (birkhoffAffineMap + (vectorToSquareMatrix (fun l ↦ y l + coordinateSpike k r l)) i j - + birkhoffAffineMap (vectorToSquareMatrix y) i j) ≀ abs r := by + have hmap := birkhoffAffineMap_abs_sub_le_l1 + (vectorToSquareMatrix (fun l ↦ y l + coordinateSpike k r l)) + (vectorToSquareMatrix y) i j + apply hmap.trans_eq + change matrixL1 + (fun i j ↦ + vectorToSquareMatrix (fun l ↦ y l + coordinateSpike k r l) i j - + vectorToSquareMatrix y i j) = abs r + rw [← vectorL1_squareMatrixToVector + (fun i j ↦ + vectorToSquareMatrix (fun l ↦ y l + coordinateSpike k r l) i j - + vectorToSquareMatrix y i j)] + have hvec : squareMatrixToVector + (fun i j ↦ + vectorToSquareMatrix (fun l ↦ y l + coordinateSpike k r l) i j - + vectorToSquareMatrix y i j) = coordinateSpike k r := by + ext l + change (y (finProdFinEquiv (finProdFinEquiv.symm l)) + + coordinateSpike k r (finProdFinEquiv (finProdFinEquiv.symm l))) - + y (finProdFinEquiv (finProdFinEquiv.symm l)) = coordinateSpike k r l + rw [Equiv.apply_symm_apply] + ring + rw [hvec, vectorL1_coordinateSpike] + +/-- Real upper-left coordinates of the Birkhoff barycenter. -/ +noncomputable def uniformAffineCoordinatesReal (m : β„•) : Matrix (Fin m) (Fin m) ℝ := + fun _ _ ↦ 1 / (m + 1) + +@[simp] theorem birkhoffAffineMap_uniformAffineCoordinatesReal + (m : β„•) (i j : Fin (m + 1)) : + birkhoffAffineMap (uniformAffineCoordinatesReal m) i j = 1 / (m + 1) := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp [uniformAffineCoordinatesReal] + field_simp + ring + Β· simp [uniformAffineCoordinatesReal] + field_simp + ring + Β· simp [uniformAffineCoordinatesReal] + field_simp + ring + Β· simp [uniformAffineCoordinatesReal] + +/-- A one-coordinate affine perturbation of the barycenter remains doubly +stochastic as long as its magnitude is at most the uniform entry. -/ +theorem uniformAffineSpike_doublyStochastic + {m : β„•} (hm : 0 < m) (k : Fin (m * m)) {q : ℝ} + (hq : abs q ≀ 1 / (m + 1 : ℝ)) : + IsDoublyStochastic + (birkhoffAffineMap + (vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l))) := by + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + have hu : 0 < 1 / (m + 1 : ℝ) := by positivity + have hnonneg : Matrix.Nonnegative (birkhoffAffineMap Zbase) := by + intro i j + have hclose := birkhoffAffineMap_vector_spike_abs_sub_le + (squareMatrixToVector (uniformAffineCoordinatesReal m)) k q i j + rw [vectorToSquareMatrix_squareMatrixToVector, + birkhoffAffineMap_uniformAffineCoordinatesReal] at hclose + have hlower := (abs_le.mp hclose).1 + dsimp only [Zbase] + linarith + exact ⟨hnonneg, birkhoffAffineMap_row_sum Zbase, + birkhoffAffineMap_col_sum Zbase⟩ + +/-- Mixing an exact feasible point with a perturbed barycenter supplies all +three facts needed for the epigraph geometry: feasibility, a quantitative +entry floor, and an objective upper bound obtained from concavity and the +global range. -/ +theorem smoothedUniformSpike_properties + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) {Ξ΄0 : ℝ} + (hXfloor : βˆ€ i j, Ξ΄0 ≀ X i j) + {mix : ℝ} (hmix0 : 0 ≀ mix) (hmix1 : mix ≀ 1) + (k : Fin (m * m)) {q : ℝ} + (hq : abs q ≀ 1 / (m + 1 : ℝ)) : + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + IsDoublyStochastic (birkhoffAffineMap Ybase) ∧ + (βˆ€ i j, (1 - mix) * Ξ΄0 ≀ birkhoffAffineMap Ybase i j) ∧ + affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) Ybase ≀ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + mix * (rationalRegularizedObjectiveRange A : ℝ) := by + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + have hZ : IsDoublyStochastic (birkhoffAffineMap Zbase) := by + simpa only [Zbase] using! uniformAffineSpike_doublyStochastic hm k hq + have hrecover : birkhoffAffineMap (birkhoffAffineCoordinates X) = X := + birkhoffAffineMap_coordinates_of_unit_sums X hX.row_sum hX.col_sum + have hmap : birkhoffAffineMap Ybase = + matrixSegment mix X (birkhoffAffineMap Zbase) := by + rw [show Ybase = fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j by rfl, + birkhoffAffineMap_affineCombination, hrecover] + rfl + have hmixDS := matrixSegment_doublyStochastic hmix0 hmix1 hX hZ + have hfloor : βˆ€ i j, + (1 - mix) * Ξ΄0 ≀ birkhoffAffineMap Ybase i j := by + intro i j + rw [hmap] + dsimp only [matrixSegment] + have hweight0 : 0 ≀ 1 - mix := sub_nonneg.mpr hmix1 + have hleft := mul_le_mul_of_nonneg_left (hXfloor i j) hweight0 + have hright : 0 ≀ mix * birkhoffAffineMap Zbase i j := + mul_nonneg hmix0 (hZ.nonnegative i j) + linarith + have hconc := regularizedBetheObjective_segment_lower + (show 1 < Fintype.card (Fin (m + 1)) by simp; omega) + (Rat.cast_nonneg.mpr hΟ„0) hmix0 hmix1 + (fun i j ↦ (A i j : ℝ)) hX hZ + have hrange := regularizedBetheObjective_sub_le_rationalRange + (show 1 ≀ m + 1 by omega) hΟ„0 hΟ„1 hApos hAupper hX hZ + refine ⟨by rwa [hmap], hfloor, ?_⟩ + unfold affineNegativeObjective + rw [hmap] + nlinarith + +/-- The unperturbed affine-coordinate center obtained by mixing `X` with the +Birkhoff barycenter. -/ +noncomputable def smoothedUniformAffineBase {m : β„•} + (X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ) (mix : ℝ) : + Matrix (Fin m) (Fin m) ℝ := + fun i j ↦ (1 - mix) * birkhoffAffineCoordinates X i j + + mix * uniformAffineCoordinatesReal m i j + +/-- Multiplying a barycenter spike by the mixing weight produces exactly the +corresponding spike in the flattened mixed coordinates. -/ +theorem squareMatrixToVector_smoothedUniformSpike_of_mul + {m : β„•} (X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ) + (mix : ℝ) (k : Fin (m * m)) (q r : ℝ) (hqr : mix * q = r) : + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + squareMatrixToVector Ybase = + fun l ↦ squareMatrixToVector (smoothedUniformAffineBase X mix) l + + coordinateSpike k r l := by + dsimp only + ext l + simp only [squareMatrixToVector, vectorToSquareMatrix] + rw [show ((finProdFinEquiv.symm l).1, + (finProdFinEquiv.symm l).2) = finProdFinEquiv.symm l by rfl, + Equiv.apply_symm_apply] + have hspike : mix * coordinateSpike k q l = coordinateSpike k r l := by + by_cases hlk : l = k + Β· subst l + simp only [coordinateSpike_apply_self] + exact hqr + Β· simp [coordinateSpike, hlk] + simp only [smoothedUniformAffineBase] + rw [mul_add, hspike] + ring + +/-- A base-coordinate spike leaves the epigraph height unchanged. -/ +theorem epigraphPoint_add_baseSpike {d : β„•} + (y : Fin d β†’ ℝ) (s : ℝ) (k : Fin d) (r : ℝ) : + (fun i ↦ epigraphPoint y s i + + if i = k.castSucc then r else 0) = + epigraphPoint (fun l ↦ y l + coordinateSpike k r l) s := by + ext i + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + simp [epigraphPoint, coordinateSpike, k.castSucc_ne_last, + Ne.symm k.castSucc_ne_last] + +/-- A negative base-coordinate spike leaves the epigraph height unchanged. -/ +theorem epigraphPoint_sub_baseSpike {d : β„•} + (y : Fin d β†’ ℝ) (s : ℝ) (k : Fin d) (r : ℝ) : + (fun i ↦ epigraphPoint y s i - + if i = k.castSucc then r else 0) = + epigraphPoint (fun l ↦ y l - coordinateSpike k r l) s := by + ext i + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + simp [epigraphPoint, coordinateSpike, k.castSucc_ne_last, + Ne.symm k.castSucc_ne_last] + +/-- A spike in the last coordinate changes only the epigraph height. -/ +theorem epigraphPoint_add_heightSpike {d : β„•} + (y : Fin d β†’ ℝ) (s r : ℝ) : + (fun i ↦ epigraphPoint y s i + + if i = Fin.last d then r else 0) = epigraphPoint y (s + r) := by + ext i + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> simp [epigraphPoint] + +/-- A negative spike in the last coordinate changes only the epigraph +height. -/ +theorem epigraphPoint_sub_heightSpike {d : β„•} + (y : Fin d β†’ ℝ) (s r : ℝ) : + (fun i ↦ epigraphPoint y s i - + if i = Fin.last d then r else 0) = epigraphPoint y (s - r) := by + ext i + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> simp [epigraphPoint] + +/-- Convert the three smoothing conclusions into membership in a bounded +Bethe epigraph at an arbitrary admissible height. -/ +theorem smoothedUniformSpike_mem_epigraph + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) {Ξ΄0 : ℝ} + (hXfloor : βˆ€ i j, Ξ΄0 ≀ X i j) + {mix : ℝ} (hmix0 : 0 ≀ mix) (hmix1 : mix ≀ 1) + (k : Fin (m * m)) {q : ℝ} + (hq : abs q ≀ 1 / (m + 1 : ℝ)) + {Ξ΄ s upper : ℝ} (hΞ΄ : Ξ΄ ≀ (1 - mix) * Ξ΄0) + (hobjective : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + mix * (rationalRegularizedObjectiveRange A : ℝ) ≀ s) + (hsupper : s ≀ upper) : + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) Ξ΄ upper + (epigraphPoint (squareMatrixToVector Ybase) s) := by + dsimp only + have hproperties := smoothedUniformSpike_properties hm hΟ„0 hΟ„1 + hApos hAupper hX hXfloor hmix0 hmix1 k hq + simp only [BetheEpigraphTarget, epigraphBase_epigraphPoint, + epigraphHeight_epigraphPoint, + vectorToSquareMatrix_squareMatrixToVector] + constructor + Β· intro i j + convert! hΞ΄.trans (hproperties.2.1 i j) using 1 + exact congrArg (fun B : Matrix (Fin m) (Fin m) ℝ => birkhoffAffineMap B i j) + (vectorToSquareMatrix_squareMatrixToVector _) + Β· constructor + Β· convert! hproperties.2.2.trans hobjective using 1 + exact congrArg (affineNegativeObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ))) + (vectorToSquareMatrix_squareMatrixToVector _) + Β· exact hsupper + +/-- The truncated epigraph above a threshold with two radii of objective +slack contains a full coordinate cross. This is the exact inner-region +statement used by the square-root-free ellipsoid termination theorem. -/ +theorem BetheEpigraphTarget_smoothed_inner_cross + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) {Ξ΄0 : ℝ} + (hXfloor : βˆ€ i j, Ξ΄0 ≀ X i j) + {mix r : ℝ} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) (hr : 0 ≀ r) + (hspike : r / mix ≀ 1 / (m + 1 : ℝ)) + {Ξ΄ upper : ℝ} (hΞ΄ : Ξ΄ ≀ (1 - mix) * Ξ΄0) + (hslack : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + mix * (rationalRegularizedObjectiveRange A : ℝ) + 2 * r ≀ upper) : + let ycenter := squareMatrixToVector (smoothedUniformAffineBase X mix) + let zcenter := epigraphPoint ycenter (upper - r) + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + Ξ΄ upper (fun i ↦ zcenter i + if i = k then r else 0)) ∧ + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + Ξ΄ upper (fun i ↦ zcenter i - if i = k then r else 0)) := by + dsimp only + have hmix0' : 0 ≀ mix := hmix0.le + have hobjectiveCenter : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + mix * (rationalRegularizedObjectiveRange A : ℝ) ≀ upper - r := by + linarith + have hcenterUpper : upper - r ≀ upper := by linarith + have hobjectiveLow : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + mix * (rationalRegularizedObjectiveRange A : ℝ) ≀ upper - 2 * r := by + linarith + have hlowUpper : upper - 2 * r ≀ upper := by linarith + have hqplus : abs (r / mix) ≀ 1 / (m + 1 : ℝ) := by + rw [abs_div, abs_of_nonneg hr, abs_of_pos hmix0] + exact hspike + have hqminus : abs (-r / mix) ≀ 1 / (m + 1 : ℝ) := by + rw [abs_div, abs_neg, abs_of_nonneg hr, abs_of_pos hmix0] + exact hspike + let k0 : Fin (m * m) := ⟨0, Nat.mul_pos hm hm⟩ + constructor + Β· intro k + refine Fin.lastCases ?_ (fun k ↦ ?_) k + Β· let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k0 0 l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + have hmem : BetheEpigraphTarget (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Ξ΄ upper + (epigraphPoint (squareMatrixToVector Ybase) upper) := by + simpa only [Zbase, Ybase] using! + smoothedUniformSpike_mem_epigraph hm hΟ„0 hΟ„1 hApos hAupper + hX hXfloor hmix0' hmix1 k0 (q := 0) (by + simp; positivity) hΞ΄ + (hobjectiveCenter.trans hcenterUpper) le_rfl + have hvec : squareMatrixToVector Ybase = + squareMatrixToVector (smoothedUniformAffineBase X mix) := by + have h := squareMatrixToVector_smoothedUniformSpike_of_mul + X mix k0 0 0 (by ring) + calc + squareMatrixToVector Ybase = + fun l ↦ squareMatrixToVector + (smoothedUniformAffineBase X mix) l + + coordinateSpike k0 0 l := by + simpa only [Zbase, Ybase] using! h + _ = squareMatrixToVector (smoothedUniformAffineBase X mix) := by + ext l + simp [coordinateSpike] + rw [epigraphPoint_add_heightSpike, show upper - r + r = upper by ring, + ← hvec] + exact hmem + Β· let q := r / mix + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + have hmul : mix * q = r := by + dsimp only [q] + field_simp [hmix0.ne'] + have hmem : BetheEpigraphTarget (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Ξ΄ upper + (epigraphPoint (squareMatrixToVector Ybase) (upper - r)) := by + simpa only [Zbase, Ybase, q] using! + smoothedUniformSpike_mem_epigraph hm hΟ„0 hΟ„1 hApos hAupper + hX hXfloor hmix0' hmix1 k hqplus hΞ΄ + hobjectiveCenter hcenterUpper + have hvec : squareMatrixToVector Ybase = + fun l ↦ squareMatrixToVector (smoothedUniformAffineBase X mix) l + + coordinateSpike k r l := by + simpa only [Zbase, Ybase, q] using! + squareMatrixToVector_smoothedUniformSpike_of_mul + X mix k q r hmul + rw [epigraphPoint_add_baseSpike, ← hvec] + exact hmem + Β· intro k + refine Fin.lastCases ?_ (fun k ↦ ?_) k + Β· let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k0 0 l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + have hmem : BetheEpigraphTarget (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Ξ΄ upper + (epigraphPoint (squareMatrixToVector Ybase) (upper - 2 * r)) := by + simpa only [Zbase, Ybase] using! + smoothedUniformSpike_mem_epigraph hm hΟ„0 hΟ„1 hApos hAupper + hX hXfloor hmix0' hmix1 k0 (q := 0) (by + simp; positivity) hΞ΄ hobjectiveLow hlowUpper + have hvec : squareMatrixToVector Ybase = + squareMatrixToVector (smoothedUniformAffineBase X mix) := by + have h := squareMatrixToVector_smoothedUniformSpike_of_mul + X mix k0 0 0 (by ring) + calc + squareMatrixToVector Ybase = + fun l ↦ squareMatrixToVector + (smoothedUniformAffineBase X mix) l + + coordinateSpike k0 0 l := by + simpa only [Zbase, Ybase] using! h + _ = squareMatrixToVector (smoothedUniformAffineBase X mix) := by + ext l + simp [coordinateSpike] + rw [epigraphPoint_sub_heightSpike, + show upper - r - r = upper - 2 * r by ring, ← hvec] + exact hmem + Β· let q := -r / mix + let Zbase := vectorToSquareMatrix + (fun l ↦ squareMatrixToVector (uniformAffineCoordinatesReal m) l + + coordinateSpike k q l) + let Ybase := fun i j ↦ + (1 - mix) * birkhoffAffineCoordinates X i j + mix * Zbase i j + have hmul : mix * q = -r := by + dsimp only [q] + field_simp [hmix0.ne'] + have hmem : BetheEpigraphTarget (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Ξ΄ upper + (epigraphPoint (squareMatrixToVector Ybase) (upper - r)) := by + simpa only [Zbase, Ybase, q] using! + smoothedUniformSpike_mem_epigraph hm hΟ„0 hΟ„1 hApos hAupper + hX hXfloor hmix0' hmix1 k hqminus hΞ΄ + hobjectiveCenter hcenterUpper + have hvec : squareMatrixToVector Ybase = + fun l ↦ squareMatrixToVector (smoothedUniformAffineBase X mix) l + + coordinateSpike k (-r) l := by + simpa only [Zbase, Ybase, q] using! + squareMatrixToVector_smoothedUniformSpike_of_mul + X mix k q (-r) hmul + have hspikeNeg : + (fun l ↦ squareMatrixToVector (smoothedUniformAffineBase X mix) l - + coordinateSpike k r l) = + fun l ↦ squareMatrixToVector (smoothedUniformAffineBase X mix) l + + coordinateSpike k (-r) l := by + ext l + by_cases hlk : l = k + Β· subst l + simp [coordinateSpike] + ring + Β· simp [coordinateSpike, hlk] + rw [epigraphPoint_sub_baseSpike, hspikeNeg, ← hvec] + exact hmem + +/-- A coordinatewise bound controls the Euclidean square norm with a +square-root-free radius. -/ +theorem finiteNormSq_le_dimension_sq_of_abs_le + {d : β„•} (hd : 0 < d) {C : ℝ} (hC : 0 ≀ C) + (x : Fin d β†’ ℝ) (hx : βˆ€ i, abs (x i) ≀ C) : + finiteNormSq x ≀ ((d : ℝ) * C) ^ 2 := by + have hterm : βˆ€ i, x i ^ 2 ≀ C ^ 2 := by + intro i + have habs := hx i + have hlower := (abs_le.mp habs).1 + have hupper := (abs_le.mp habs).2 + nlinarith + rw [finiteNormSq, finiteDot] + calc + (βˆ‘ i, x i * x i) ≀ βˆ‘ _i : Fin d, C ^ 2 := + Finset.sum_le_sum fun i _ ↦ by simpa [pow_two] using! hterm i + _ = (d : ℝ) * C ^ 2 := by simp + _ ≀ ((d : ℝ) * C) ^ 2 := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + nlinarith [sq_nonneg C] + +/-- Every flattened base coordinate of a nonnegatively truncated epigraph +point lies in the unit interval. -/ +theorem BetheEpigraphTarget_epigraphBase_abs_le_one + {m : β„•} {Ο„ : ℝ} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + {Ξ΄ upper : ℝ} (hΞ΄ : 0 ≀ Ξ΄) {z : Fin (m * m + 1) β†’ ℝ} + (hz : BetheEpigraphTarget Ο„ A Ξ΄ upper z) (l : Fin (m * m)) : + abs (epigraphBase z l) ≀ 1 := by + let ij := finProdFinEquiv.symm l + let X := birkhoffAffineMap (vectorToSquareMatrix (epigraphBase z)) + have hX := BetheEpigraphTarget_doublyStochastic hΞ΄ hz + have hentry0 : 0 ≀ X ij.1.castSucc ij.2.castSucc := + hX.nonnegative _ _ + have hentry1 : X ij.1.castSucc ij.2.castSucc ≀ 1 := + hX.entry_le_one _ _ + have hcoordinate : X ij.1.castSucc ij.2.castSucc = epigraphBase z l := by + simp only [X, birkhoffAffineMap_castSucc_castSucc, vectorToSquareMatrix, ij] + rw [show ((finProdFinEquiv.symm l).1, + (finProdFinEquiv.symm l).2) = finProdFinEquiv.symm l by rfl, + Equiv.apply_symm_apply] + rw [← hcoordinate, abs_of_nonneg hentry0] + exact hentry1 + +/-- A coordinate cross in the truncated epigraph is contained in an explicit +ball centered at zero. The center of the cross may depend on the exact +optimizer, but the containing ball depends only on the rational height and +radius supplied to the algorithm. -/ +theorem BetheEpigraphTarget_inner_cross_outer_zero + {m : β„•} (hm : 0 < m) + {Ο„ : ℝ} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + {Ξ΄ upper r : ℝ} (hΞ΄ : 0 ≀ Ξ΄) (hr : 0 ≀ r) + (ycenter : Fin (m * m) β†’ ℝ) + (hplus : βˆ€ k, BetheEpigraphTarget Ο„ A Ξ΄ upper + (fun i ↦ epigraphPoint ycenter (upper - r) i + + if i = k then r else 0)) + (hminus : βˆ€ k, BetheEpigraphTarget Ο„ A Ξ΄ upper + (fun i ↦ epigraphPoint ycenter (upper - r) i - + if i = k then r else 0)) : + let C := 1 + abs upper + 2 * r + (βˆ€ k, finiteNormSq + (fun i ↦ epigraphPoint ycenter (upper - r) i + + if i = k then r else 0) ≀ + (((m * m + 1 : β„•) : ℝ) * C) ^ 2) ∧ + (βˆ€ k, finiteNormSq + (fun i ↦ epigraphPoint ycenter (upper - r) i - + if i = k then r else 0) ≀ + (((m * m + 1 : β„•) : ℝ) * C) ^ 2) := by + dsimp only + let C : ℝ := 1 + abs upper + 2 * r + have hC : 0 ≀ C := by + dsimp only [C] + linarith [abs_nonneg upper] + have honeC : (1 : ℝ) ≀ C := by + dsimp only [C] + linarith [abs_nonneg upper] + constructor + Β· intro k + apply finiteNormSq_le_dimension_sq_of_abs_le (by omega) hC + intro i + refine Fin.lastCases ?_ (fun l ↦ ?_) i + Β· by_cases hk : Fin.last (m * m) = k + Β· have hvalue : + epigraphPoint ycenter (upper - r) (Fin.last (m * m)) + + (if Fin.last (m * m) = k then r else 0) = upper := by + subst k + simp [epigraphPoint] + rw [hvalue] + dsimp only [C] + linarith [abs_nonneg upper] + Β· have htriangle : abs (upper - r) ≀ abs upper + r := by + calc + abs (upper - r) ≀ abs upper + abs r := abs_sub upper r + _ = abs upper + r := by rw [abs_of_nonneg hr] + simp only [epigraphPoint, Fin.snoc_last, ite_eq_right hk, add_zero] + exact htriangle.trans (by dsimp only [C]; linarith) + Β· have hbase := BetheEpigraphTarget_epigraphBase_abs_le_one hΞ΄ + (hplus k) l + simpa only [epigraphBase] using! hbase.trans honeC + Β· intro k + apply finiteNormSq_le_dimension_sq_of_abs_le (by omega) hC + intro i + refine Fin.lastCases ?_ (fun l ↦ ?_) i + Β· by_cases hk : Fin.last (m * m) = k + Β· have htriangle : abs (upper - 2 * r) ≀ abs upper + 2 * r := by + calc + abs (upper - 2 * r) ≀ abs upper + abs (2 * r) := + abs_sub upper (2 * r) + _ = abs upper + 2 * r := by rw [abs_of_nonneg (mul_nonneg (by norm_num) hr)] + have hvalue : + epigraphPoint ycenter (upper - r) (Fin.last (m * m)) - + (if Fin.last (m * m) = k then r else 0) = + upper - 2 * r := by + subst k + simp [epigraphPoint] + ring + rw [hvalue] + exact htriangle.trans (by dsimp only [C]; linarith) + Β· have htriangle : abs (upper - r) ≀ abs upper + r := by + calc + abs (upper - r) ≀ abs upper + abs r := abs_sub upper r + _ = abs upper + r := by rw [abs_of_nonneg hr] + simp only [epigraphPoint, Fin.snoc_last, ite_eq_right hk, sub_zero] + exact htriangle.trans (by dsimp only [C]; linarith) + Β· have hbase := BetheEpigraphTarget_epigraphBase_abs_le_one hΞ΄ + (hminus k) l + simpa only [epigraphBase] using! hbase.trans honeC + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheFloorCutFormula.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheFloorCutFormula.lean new file mode 100644 index 0000000000..423b21a725 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheFloorCutFormula.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph + +/-! +# Coordinate formula for Bethe floor-cut normals + +The machine implementation uses the four signed indicators obtained by +pulling one recovered matrix coordinate back to the flattened upper-left +block. This file proves that direct formula equal to `betheFloorCutNormal`, +separately from any encoding or iteration argument. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- Base-coordinate coefficient of the lower-floor cut at recovered entry +`(i,j)`. It is the negative of the four-corner affine pullback. -/ +def explicitBetheFloorCutBaseEntry {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : β„š := + -(if a.castSucc = i ∧ b.castSucc = j then 1 else 0) + + (if a.castSucc = i ∧ Fin.last m = j then 1 else 0) + + (if Fin.last m = i ∧ b.castSucc = j then 1 else 0) - + (if Fin.last m = i ∧ Fin.last m = j then 1 else 0) + +/-- Full epigraph-vector formula, with zero in the last coordinate. -/ +def explicitBetheFloorCutNormal {m : β„•} (i j : Fin (m + 1)) : + Fin (m * m + 1) β†’ β„š := + Fin.snoc (fun k ↦ + let ab := finProdFinEquiv.symm k + explicitBetheFloorCutBaseEntry i j ab.1 ab.2) 0 + +theorem neg_affinePullback_entryCovector {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : + -affinePullbackGradient (matrixEntryCovector i j) a b = + explicitBetheFloorCutBaseEntry i j a b := by + simp only [affinePullbackGradient, matrixEntryCovector, + explicitBetheFloorCutBaseEntry] + by_cases hab : a.castSucc = i ∧ b.castSucc = j <;> + by_cases haLast : a.castSucc = i ∧ Fin.last m = j <;> + by_cases hLastB : Fin.last m = i ∧ b.castSucc = j <;> + by_cases hLastLast : Fin.last m = i ∧ Fin.last m = j <;> + simp [hab, haLast, hLastB, hLastLast] <;> ring + +theorem explicitBetheFloorCutNormal_eq {m : β„•} + (i j : Fin (m + 1)) : + explicitBetheFloorCutNormal i j = betheFloorCutNormal i j := by + ext k + refine Fin.lastCases ?_ (fun k ↦ ?_) k + Β· simp [explicitBetheFloorCutNormal, betheFloorCutNormal] + Β· rw [betheFloorCutNormal_castSucc] + simp only [explicitBetheFloorCutNormal, Fin.snoc_castSucc, + squareMatrixToVector] + exact (neg_affinePullback_entryCovector i j + (finProdFinEquiv.symm k).1 (finProdFinEquiv.symm k).2).symm + +@[simp] theorem explicitBetheFloorCutBaseEntry_upperLeft {m : β„•} + (i j a b : Fin m) : + explicitBetheFloorCutBaseEntry i.castSucc j.castSucc a b = + if a = i ∧ b = j then -1 else 0 := by + have hi : Fin.last m β‰  i.castSucc := (Fin.castSucc_ne_last i).symm + have hj : Fin.last m β‰  j.castSucc := (Fin.castSucc_ne_last j).symm + by_cases hai : a = i <;> by_cases hbj : b = j <;> + simp [explicitBetheFloorCutBaseEntry, hai, hbj, hi, hj] + +@[simp] theorem explicitBetheFloorCutBaseEntry_lastColumn {m : β„•} + (i a b : Fin m) : + explicitBetheFloorCutBaseEntry i.castSucc (Fin.last m) a b = + if a = i then 1 else 0 := by + have hi : Fin.last m β‰  i.castSucc := (Fin.castSucc_ne_last i).symm + have hb : b.castSucc β‰  Fin.last m := Fin.castSucc_ne_last b + by_cases hai : a = i <;> + simp [explicitBetheFloorCutBaseEntry, hai, hi, hb] + +@[simp] theorem explicitBetheFloorCutBaseEntry_lastRow {m : β„•} + (j a b : Fin m) : + explicitBetheFloorCutBaseEntry (Fin.last m) j.castSucc a b = + if b = j then 1 else 0 := by + have hj : Fin.last m β‰  j.castSucc := (Fin.castSucc_ne_last j).symm + have ha : a.castSucc β‰  Fin.last m := Fin.castSucc_ne_last a + by_cases hbj : b = j <;> + simp [explicitBetheFloorCutBaseEntry, hbj, hj, ha] + +@[simp] theorem explicitBetheFloorCutBaseEntry_corner {m : β„•} + (a b : Fin m) : + explicitBetheFloorCutBaseEntry (Fin.last m) (Fin.last m) a b = -1 := by + have ha : a.castSucc β‰  Fin.last m := Fin.castSucc_ne_last a + have hb : b.castSucc β‰  Fin.last m := Fin.castSucc_ne_last b + simp [explicitBetheFloorCutBaseEntry, ha, hb] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BetheThresholdFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/BetheThresholdFeasibility.lean new file mode 100644 index 0000000000..d08393b356 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BetheThresholdFeasibility.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphGeometry +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledFeasibility +public import Mathlib.Tactic + +/-! # Bethe Threshold Feasibility -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Executable feasibility at a rational Bethe threshold + +This file instantiates the generic rational ellipsoid loop with a completely +explicit zero-centered outer ball and the coordinate cross constructed from +an exact regularized optimizer. The optimizer occurs only in the proof of +termination; the executable state, oracle, radius, and budget use rational +input data alone. +-/ + +/-- A square-root-free rational outer radius for the bounded epigraph cross. -/ +def betheEpigraphOuterRadius (m : β„•) (upper r : β„š) : β„š := + (m * m + 1) * (1 + abs upper + 2 * r) + +theorem betheEpigraphOuterRadius_pos (m : β„•) {upper r : β„š} + (hr : 0 ≀ r) : 0 < betheEpigraphOuterRadius m upper r := by + rw [betheEpigraphOuterRadius] + positivity + +theorem cast_betheEpigraphOuterRadius (m : β„•) (upper r : β„š) : + (betheEpigraphOuterRadius m upper r : ℝ) = + ((m * m + 1 : β„•) : ℝ) * + (1 + abs (upper : ℝ) + 2 * (r : ℝ)) := by + rw [betheEpigraphOuterRadius] + push_cast + rfl + +/-- The exact call budget obtained from the explicit outer and inner radii. -/ +def betheThresholdFeasibilityBudget (m : β„•) (upper r : β„š) : β„• := + let d := m * m + 1 + 32 * d ^ 3 * rationalBallDyadicExponent d + (betheEpigraphOuterRadius m upper r) r + +/-- Execute the complete rational oracle for one rational objective +threshold. The initial ellipsoid is centered at zero and every parameter is +computed from the input rationals. -/ +def runBetheThresholdFeasibility {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper r : β„š) : + RationalFeasibilityResult (m * m + 1) := + runScheduledRationalFeasibility (betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) + (betheThresholdFeasibilityBudget m upper r) + (rationalBallEllipsoid (m * m + 1) 0 + (betheEpigraphOuterRadius m upper r)) + +/-- Every accepted result of the specialized runner satisfies the exact +rational acceptance predicate of the complete oracle. -/ +theorem runBetheThresholdFeasibility_acceptsOnly {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper r : β„š) {q : Fin (m * m + 1) β†’ β„š} + (hrun : runBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = .accepted q) : + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q := by + exact runScheduledRationalFeasibility_acceptsOnly + (betheBoundedEpigraphOracle_acceptsOnly Ο„ A p Ξ΄ upper) + (by simpa only [runBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun) + +/-- If a rational threshold has the displayed smoothing and height slack, +the executable feasibility run returns an accepted rational point. -/ +theorem runBetheThresholdFeasibility_accepts_of_slack + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ upper r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (hslack : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper : ℝ)) + (p : β„•) : + βˆƒ q : Fin (m * m + 1) β†’ β„š, + runBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = .accepted q ∧ + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q := by + let Ξ΄0 : β„š := numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) Ο„ + have hoptimizerFloor : βˆ€ i j, (Ξ΄0 : ℝ) ≀ X i j := by + intro i j + exact (regularizedOptimizer_meets_executable_floor + (n := m + 1) (by omega) hΟ„0 hApos hAupper hX hmax i j).1 + have hcross := BetheEpigraphTarget_smoothed_inner_cross hm hΟ„0.le hΟ„1 + hApos hAupper hX hoptimizerFloor + (Rat.cast_pos.mpr hmix0) (by exact_mod_cast hmix1) + (Rat.cast_nonneg.mpr hr.le) (by + have hs := (Rat.cast_le (K := ℝ)).mpr hspike + norm_num only [Rat.cast_div, Rat.cast_one, Rat.cast_natCast] at hs + simpa using hs) + (Ξ΄ := (Ξ΄ : ℝ)) (upper := (upper : ℝ)) (by + exact_mod_cast hfloor) hslack + let ycenter := squareMatrixToVector (smoothedUniformAffineBase X (mix : ℝ)) + let zcenter := epigraphPoint ycenter ((upper : ℝ) - (r : ℝ)) + have hcross' : + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ) + (fun i ↦ zcenter i + if i = k then (r : ℝ) else 0)) ∧ + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ) + (fun i ↦ zcenter i - if i = k then (r : ℝ) else 0)) := by + simpa only [ycenter, zcenter] using hcross + have houter := BetheEpigraphTarget_inner_cross_outer_zero hm + (Rat.cast_nonneg.mpr hΞ΄.le) (Rat.cast_nonneg.mpr hr.le) ycenter + hcross'.1 hcross'.2 + have hR : 0 < betheEpigraphOuterRadius m upper r := + betheEpigraphOuterRadius_pos m hr.le + obtain ⟨q, hrun, hgood⟩ := runScheduledRationalFeasibility_ball_accepts + (d := m * m + 1) (by omega) + (Target := BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ)) + (Good := BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper) + (oracle := betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) + (betheBoundedEpigraphOracle_valid hm hΟ„0.le hΟ„1 hApos hΞ΄ p upper) + (betheBoundedEpigraphOracle_acceptsOnly Ο„ A p Ξ΄ upper) + (0 : Fin (m * m + 1) β†’ β„š) hR hr + hcross'.1 hcross'.2 + (by + intro k + have hk := houter.1 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + (by + intro k + have hk := houter.2 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + refine ⟨q, ?_, hgood⟩ + simpa only [runBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun + +/-- Conversely, exhaustion certifies that the queried threshold is strictly +below the exact optimum plus the smoothing slack. This is a theorem about +the concrete runner, not an oracle assumption. -/ +theorem runBetheThresholdFeasibility_exhausted_lt_optimum_add_slack + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ upper r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (p : β„•) {E : RationalEllipsoidState (m * m + 1)} + (hrun : runBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = .exhausted E) : + (upper : ℝ) < + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) := by + by_contra hnot + have hslack : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper : ℝ) := not_lt.mp hnot + obtain ⟨q, haccepted, _⟩ := runBetheThresholdFeasibility_accepts_of_slack + hm hΟ„0 hΟ„1 hApos hAupper hX hmax hmix0 hmix1 hΞ΄ hr + hspike hfloor hslack p + rw [hrun] at haccepted + contradiction + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BinaryDirectedElementary.lean b/LeanPool/BeyondBethe/BeyondBethe/BinaryDirectedElementary.lean new file mode 100644 index 0000000000..b1141ca77b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BinaryDirectedElementary.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalComparison +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import Mathlib.Tactic + +/-! # Binary Directed Elementary -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Directed elementary functions through verified binary arithmetic + +The analytic definitions in `DirectedElementary.lean` are convenient field +expressions. The definitions below give extensionally equal, machine-facing +programs whose rational operations are the explicit long-division, bounded +Euclid, and normalization routines from the binary arithmetic layer. +-/ + +/-- Partial sum of the odd logarithm series, evaluated by a fixed natural +loop. -/ +def binaryRationalLogSeriesSum (x : β„š) : β„• β†’ β„š + | 0 => 0 + | N + 1 => + binaryRatAdd (binaryRationalLogSeriesSum x N) + (binaryRatDiv (binaryRatPow x (2 * N + 1)) (2 * N + 1)) + +theorem binaryRationalLogSeriesSum_eq (x : β„š) : βˆ€ N : β„•, + binaryRationalLogSeriesSum x N = + βˆ‘ k ∈ Finset.range N, x ^ (2 * k + 1) / (2 * k + 1) := by + intro N + induction N with + | zero => simp [binaryRationalLogSeriesSum] + | succ N ih => + rw [binaryRationalLogSeriesSum, binaryRatAdd_eq_add, + binaryRatDiv_eq_div, binaryRatPow_eq_pow, ih, + Finset.sum_range_succ] + +/-- Twice the first `N` odd terms of the rational logarithm series, evaluated with binary +arithmetic. -/ +def binaryRationalLogSeries (x : β„š) (N : β„•) : β„š := + binaryRatMul 2 (binaryRationalLogSeriesSum x N) + +theorem binaryRationalLogSeries_eq (x : β„š) (N : β„•) : + binaryRationalLogSeries x N = rationalLogSeries x N := by + rw [binaryRationalLogSeries, rationalLogSeries, + binaryRatMul_eq_mul, binaryRationalLogSeriesSum_eq] + +/-- The rational remainder expression `2 * x^(2*N+1) / (1-x^2)` for the logarithm series. -/ +def binaryRationalLogSeriesError (x : β„š) (N : β„•) : β„š := + binaryRatMul 2 + (binaryRatDiv (binaryRatPow x (2 * N + 1)) + (binaryRatSub 1 (binaryRatPow x 2))) + +theorem binaryRationalLogSeriesError_eq (x : β„š) (N : β„•) : + binaryRationalLogSeriesError x N = rationalLogSeriesError x N := by + simp [binaryRationalLogSeriesError, rationalLogSeriesError, + binaryRatMul_eq_mul, binaryRatDiv_eq_div, binaryRatSub_eq_sub, + binaryRatPow_eq_pow] + +/-- The logarithm-series substitution `(y-1)/(y+1)`, computed with binary rational arithmetic. -/ +def binaryRationalLogUnitParameter (y : β„š) : β„š := + binaryRatDiv (binaryRatSub y 1) (binaryRatAdd y 1) + +theorem binaryRationalLogUnitParameter_eq (y : β„š) : + binaryRationalLogUnitParameter y = rationalLogUnitParameter y := by + simp [binaryRationalLogUnitParameter, rationalLogUnitParameter, + binaryRatDiv_eq_div, binaryRatSub_eq_sub, binaryRatAdd_eq_add] + +/-- The lower unit-logarithm approximation obtained by evaluating the truncated odd-power +series. -/ +def binaryDirectedLogUnitLower (y : β„š) (N : β„•) : β„š := + binaryRationalLogSeries (binaryRationalLogUnitParameter y) N + +theorem binaryDirectedLogUnitLower_eq (y : β„š) (N : β„•) : + binaryDirectedLogUnitLower y N = directedLogUnitLower y N := by + simp [binaryDirectedLogUnitLower, directedLogUnitLower, + binaryRationalLogSeries_eq, binaryRationalLogUnitParameter_eq] + +/-- The upper unit-logarithm approximation obtained by adding the series remainder expression. -/ +def binaryDirectedLogUnitUpper (y : β„š) (N : β„•) : β„š := + binaryRatAdd + (binaryRationalLogSeries (binaryRationalLogUnitParameter y) N) + (binaryRationalLogSeriesError (binaryRationalLogUnitParameter y) N) + +theorem binaryDirectedLogUnitUpper_eq (y : β„š) (N : β„•) : + binaryDirectedLogUnitUpper y N = directedLogUnitUpper y N := by + simp [binaryDirectedLogUnitUpper, directedLogUnitUpper, + binaryRatAdd_eq_add, binaryRationalLogSeries_eq, + binaryRationalLogSeriesError_eq, binaryRationalLogUnitParameter_eq] + +/-- Base-two logarithm read from the length of the canonical binary word. -/ +def binaryNatLog2 (n : β„•) : β„• := n.size - 1 + +theorem binaryNatLog2_eq_log_two (n : β„•) : + binaryNatLog2 n = Nat.log 2 n := by + by_cases hn : n = 0 + Β· subst n + simp [binaryNatLog2] + Β· have hsize := Nat.size_eq_log_two_add_one hn + rw [binaryNatLog2, hsize] + omega + +/-- The power-of-two scale determined by the binary logarithms of the absolute numerator and +denominator. -/ +def binaryRationalBinaryScale (q : β„š) : β„š := + binaryRatDiv + (binaryRatPow 2 (binaryNatLog2 q.num.natAbs)) + (binaryRatPow 2 (binaryNatLog2 q.den)) + +theorem binaryRationalBinaryScale_eq (q : β„š) : + binaryRationalBinaryScale q = rationalBinaryScale q := by + simp [binaryRationalBinaryScale, rationalBinaryScale, + binaryRatDiv_eq_div, binaryRatPow_eq_pow, + binaryNatLog2_eq_log_two] + +/-- Signed range-reduction exponent computed from binary word lengths. -/ +def binaryRationalBinaryExponent (q : β„š) : β„€ := + (binaryNatLog2 q.num.natAbs : β„€) - (binaryNatLog2 q.den : β„€) + +theorem binaryRationalBinaryExponent_eq (q : β„š) : + binaryRationalBinaryExponent q = rationalBinaryExponent q := by + simp [binaryRationalBinaryExponent, rationalBinaryExponent, + binaryNatLog2_eq_log_two] + +/-- The rational input divided by its power-of-two scale. -/ +def binaryRationalBinaryResidual (q : β„š) : β„š := + binaryRatDiv q (binaryRationalBinaryScale q) + +theorem binaryRationalBinaryResidual_eq (q : β„š) : + binaryRationalBinaryResidual q = rationalBinaryResidual q := by + simp [binaryRationalBinaryResidual, rationalBinaryResidual, + binaryRatDiv_eq_div, binaryRationalBinaryScale_eq] + +/-- The binary residual used for logarithm approximation, inverted when it is below one. -/ +def binaryRationalLogUnit (q : β„š) : β„š := + if binaryRatLt (binaryRationalBinaryResidual q) 1 then + binaryRatInv (binaryRationalBinaryResidual q) + else + binaryRationalBinaryResidual q + +theorem binaryRationalLogUnit_eq (q : β„š) : + binaryRationalLogUnit q = rationalLogUnit q := by + simp [binaryRationalLogUnit, rationalLogUnit, + binaryRationalBinaryResidual_eq, binaryRatInv_eq_inv, + binaryRatLt_eq_true_iff] + +/-- The lower endpoint for multiplication of an interval by an integer, accounting for its sign. -/ +def binaryDirectedIntMulLower (k : β„€) (lo hi : β„š) : β„š := + if 0 ≀ k then binaryRatMul k lo else binaryRatMul k hi + +theorem binaryDirectedIntMulLower_eq (k : β„€) (lo hi : β„š) : + binaryDirectedIntMulLower k lo hi = directedIntMulLower k lo hi := by + simp [binaryDirectedIntMulLower, directedIntMulLower, + binaryRatMul_eq_mul] + +/-- The upper endpoint for multiplication of an interval by an integer, accounting for its sign. -/ +def binaryDirectedIntMulUpper (k : β„€) (lo hi : β„š) : β„š := + if 0 ≀ k then binaryRatMul k hi else binaryRatMul k lo + +theorem binaryDirectedIntMulUpper_eq (k : β„€) (lo hi : β„š) : + binaryDirectedIntMulUpper k lo hi = directedIntMulUpper k lo hi := by + simp [binaryDirectedIntMulUpper, directedIntMulUpper, + binaryRatMul_eq_mul] + +/-- Complete directed lower logarithm implemented only with binary rational +primitives and fixed natural loops. -/ +def binaryDirectedLogLower (q : β„š) (N : β„•) : β„š := + let kPart := binaryDirectedIntMulLower (binaryRationalBinaryExponent q) + (binaryDirectedLogUnitLower 2 N) (binaryDirectedLogUnitUpper 2 N) + let y := binaryRationalLogUnit q + binaryRatAdd kPart + (if binaryRatLt (binaryRationalBinaryResidual q) 1 then + binaryRatNeg (binaryDirectedLogUnitUpper y N) + else + binaryDirectedLogUnitLower y N) + +theorem binaryDirectedLogLower_eq (q : β„š) (N : β„•) : + binaryDirectedLogLower q N = directedLogLower q N := by + simp [binaryDirectedLogLower, directedLogLower, + binaryDirectedIntMulLower_eq, binaryDirectedLogUnitLower_eq, + binaryDirectedLogUnitUpper_eq, binaryRationalLogUnit_eq, + binaryRationalBinaryResidual_eq, binaryRatNeg_eq_neg, + binaryRatAdd_eq_add, binaryRationalBinaryExponent_eq, + binaryRatLt_eq_true_iff] + +/-- The upper logarithm approximation combining the binary exponent contribution with the +residual contribution. -/ +def binaryDirectedLogUpper (q : β„š) (N : β„•) : β„š := + let kPart := binaryDirectedIntMulUpper (binaryRationalBinaryExponent q) + (binaryDirectedLogUnitLower 2 N) (binaryDirectedLogUnitUpper 2 N) + let y := binaryRationalLogUnit q + binaryRatAdd kPart + (if binaryRatLt (binaryRationalBinaryResidual q) 1 then + binaryRatNeg (binaryDirectedLogUnitLower y N) + else + binaryDirectedLogUnitUpper y N) + +theorem binaryDirectedLogUpper_eq (q : β„š) (N : β„•) : + binaryDirectedLogUpper q N = directedLogUpper q N := by + simp [binaryDirectedLogUpper, directedLogUpper, + binaryDirectedIntMulUpper_eq, binaryDirectedLogUnitLower_eq, + binaryDirectedLogUnitUpper_eq, binaryRationalLogUnit_eq, + binaryRationalBinaryResidual_eq, binaryRatNeg_eq_neg, + binaryRatAdd_eq_add, binaryRationalBinaryExponent_eq, + binaryRatLt_eq_true_iff] + +/-- Natural ceiling used by the exponential schedule, now routed through the +verified rational-floor implementation. -/ +def binaryRationalCeilNat (t : β„š) : β„• := + Int.toNat (binaryRatCeil t) + +theorem binaryRationalCeilNat_eq (t : β„š) : + binaryRationalCeilNat t = rationalCeilNat t := by + rw [binaryRationalCeilNat, rationalCeilNat, binaryRatCeil_eq_ceil] + +/-- The odd step count `2 * ceil(t + t^2/loss) + 1` used in the exponential approximation. -/ +def binaryRationalExpApproxSteps (t loss : β„š) : β„• := + 2 * binaryRationalCeilNat + (binaryRatAdd t (binaryRatDiv (binaryRatPow t 2) loss)) + 1 + +theorem binaryRationalExpApproxSteps_eq (t loss : β„š) : + binaryRationalExpApproxSteps t loss = + rationalExpApproxSteps t loss := by + simp [binaryRationalExpApproxSteps, rationalExpApproxSteps, + binaryRationalCeilNat_eq, binaryRatAdd_eq_add, + binaryRatDiv_eq_div, binaryRatPow_eq_pow] + +/-- The binomial expression `(1-t/M)^M` used to approximate `exp(-t)` from below. -/ +def binaryRationalNegativeExpLower (t loss : β„š) : β„š := + let M := binaryRationalExpApproxSteps t loss + binaryRatPow + (binaryRatSub 1 (binaryRatDiv t M)) M + +theorem binaryRationalNegativeExpLower_eq (t loss : β„š) : + binaryRationalNegativeExpLower t loss = + rationalNegativeExpLower t loss := by + simp [binaryRationalNegativeExpLower, rationalNegativeExpLower, + binaryRationalExpApproxSteps_eq, binaryRatPow_eq_pow, + binaryRatSub_eq_sub, binaryRatDiv_eq_div] + +/-- The binomial expression `(1+t/M)^M` used to approximate `exp(t)` from below. -/ +def binaryRationalPositiveExpLower (t loss : β„š) : β„š := + let M := binaryRationalExpApproxSteps t loss + binaryRatPow + (binaryRatAdd 1 (binaryRatDiv t M)) M + +theorem binaryRationalPositiveExpLower_eq (t loss : β„š) : + binaryRationalPositiveExpLower t loss = + rationalPositiveExpLower t loss := by + simp [binaryRationalPositiveExpLower, rationalPositiveExpLower, + binaryRationalExpApproxSteps_eq, binaryRatPow_eq_pow, + binaryRatAdd_eq_add, binaryRatDiv_eq_div] + +/-- Select the positive- or negative-exponent binomial approximation according to the sign of +the input. -/ +def binaryRationalExpLower (s loss : β„š) : β„š := + if binaryRatNonnegative s then binaryRationalPositiveExpLower s loss + else binaryRationalNegativeExpLower (binaryRatNeg s) loss + +theorem binaryRationalExpLower_eq (s loss : β„š) : + binaryRationalExpLower s loss = rationalExpLower s loss := by + simp [binaryRationalExpLower, rationalExpLower, + binaryRationalPositiveExpLower_eq, binaryRationalNegativeExpLower_eq, + binaryRatNeg_eq_neg, binaryRatNonnegative_eq_true_iff] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BinaryLongDivision.lean b/LeanPool/BeyondBethe/BeyondBethe/BinaryLongDivision.lean new file mode 100644 index 0000000000..4f87ff449f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BinaryLongDivision.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import Mathlib.Tactic + +/-! # Binary Long Division -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Binary long division + +This file starts the machine-level arithmetic layer with a structural +long-division recurrence on little-endian binary words. The recurrence uses +only doubling, comparison, and subtraction. Its proof does not appeal to +`Nat.div` or `Nat.mod` while the recurrence is running; those operations occur +only in the extensional correctness statement. +-/ + +/-- The numeric value of one bit. -/ +def bitValue (b : Bool) : β„• := if b then 1 else 0 + +@[simp] theorem bitValue_false : bitValue false = 0 := rfl + +@[simp] theorem bitValue_true : bitValue true = 1 := rfl + +theorem bitValue_le_one (b : Bool) : bitValue b ≀ 1 := by + cases b <;> simp [bitValue] + +/-- One most-significant-to-least-significant long-division step. The pair is +`(quotient, remainder)` for the already processed high bits. -/ +def binaryLongDivStep (divisor : β„•) (b : Bool) (qr : β„• Γ— β„•) : β„• Γ— β„• := + let trial := 2 * qr.2 + bitValue b + if divisor = 0 then + (0, trial) + else if divisor ≀ trial then + (2 * qr.1 + 1, trial - divisor) + else + (2 * qr.1, trial) + +/-- Divide a little-endian binary word by processing its high-order tail +first. -/ +def binaryLongDivBits (divisor : β„•) : List Bool β†’ β„• Γ— β„• + | [] => (0, 0) + | b :: bits => binaryLongDivStep divisor b (binaryLongDivBits divisor bits) + +@[simp] theorem binaryLongDivBits_nil (divisor : β„•) : + binaryLongDivBits divisor [] = (0, 0) := rfl + +@[simp] theorem binaryLongDivBits_cons (divisor : β„•) (b : Bool) + (bits : List Bool) : + binaryLongDivBits divisor (b :: bits) = + binaryLongDivStep divisor b (binaryLongDivBits divisor bits) := rfl + +/-- The zero-divisor branch follows Lean's convention: quotient zero and the +entire input as remainder. -/ +theorem binaryLongDivBits_zero (bits : List Bool) : + binaryLongDivBits 0 bits = (0, Nat.fromBitsLE bits) := by + induction bits with + | nil => + change (0, 0) = (0, 0) + rfl + | cons b bits ih => + simp [binaryLongDivBits, binaryLongDivStep, ih, + Nat.fromBitsLE_cons, bitValue, Nat.add_comm] + +/-- Algebraic preservation performed by one positive-divisor step. -/ +theorem binaryLongDivStep_invariant {divisor : β„•} (hdivisor : 0 < divisor) + (b : Bool) (q r : β„•) (hr : r < divisor) : + let out := binaryLongDivStep divisor b (q, r) + 2 * (q * divisor + r) + bitValue b = + out.1 * divisor + out.2 ∧ + out.2 < divisor := by + have htrial : 2 * r + bitValue b < 2 * divisor := by + have hb := bitValue_le_one b + omega + rw [binaryLongDivStep] + simp only [Prod.fst, Prod.snd] + split + Β· rename_i hzero + omega + Β· split + Β· rename_i hle + constructor + Β· have hcancel : divisor + (2 * r + bitValue b - divisor) = + 2 * r + bitValue b := Nat.add_sub_of_le hle + calc + 2 * (q * divisor + r) + bitValue b = + 2 * (q * divisor) + (2 * r + bitValue b) := by ring + _ = 2 * (q * divisor) + + (divisor + (2 * r + bitValue b - divisor)) := by rw [hcancel] + _ = (2 * q + 1) * divisor + + (2 * r + bitValue b - divisor) := by ring + Β· omega + Β· rename_i hnle + constructor + Β· ring + Β· omega + +/-- Fundamental invariant of the recurrence for a positive divisor. -/ +theorem binaryLongDivBits_invariant {divisor : β„•} (hdivisor : 0 < divisor) : + βˆ€ bits : List Bool, + let qr := binaryLongDivBits divisor bits + Nat.fromBitsLE bits = qr.1 * divisor + qr.2 ∧ qr.2 < divisor := by + intro bits + induction bits with + | nil => + simp [binaryLongDivBits, Nat.fromBitsLE, Nat.fromBits, hdivisor] + | cons b bits ih => + let q := (binaryLongDivBits divisor bits).1 + let r := (binaryLongDivBits divisor bits).2 + have ihEq : Nat.fromBitsLE bits = q * divisor + r := by + simpa only [q, r] using ih.1 + have ihRem : r < divisor := by + simpa only [r] using ih.2 + have hstep := binaryLongDivStep_invariant hdivisor b q r ihRem + rw [Nat.fromBitsLE_cons, binaryLongDivBits_cons] + simpa only [bitValue, q, r, ihEq, add_comm] using hstep + +/-- Extensional correctness of binary long division. -/ +theorem binaryLongDivBits_eq_div_mod (divisor : β„•) (bits : List Bool) : + binaryLongDivBits divisor bits = + (Nat.fromBitsLE bits / divisor, Nat.fromBitsLE bits % divisor) := by + by_cases hzero : divisor = 0 + Β· subst divisor + simpa using binaryLongDivBits_zero bits + Β· have hpos : 0 < divisor := Nat.pos_of_ne_zero hzero + let q := (binaryLongDivBits divisor bits).1 + let r := (binaryLongDivBits divisor bits).2 + have hinv := binaryLongDivBits_invariant hpos bits + have hinvEq : Nat.fromBitsLE bits = q * divisor + r := by + simpa only [q, r] using hinv.1 + have hinvRem : r < divisor := by + simpa only [r] using hinv.2 + have hquot : Nat.fromBitsLE bits / divisor = q := by + apply Nat.div_eq_of_lt_le + Β· rw [hinvEq] + omega + Β· rw [hinvEq] + calc + q * divisor + r < q * divisor + divisor := + Nat.add_lt_add_left hinvRem _ + _ = (q + 1) * divisor := by ring + have hrem : Nat.fromBitsLE bits % divisor = r := by + rw [hinvEq, Nat.add_mod] + simp [Nat.mod_eq_of_lt hinvRem] + apply Prod.ext + Β· simpa only [q] using hquot.symm + Β· simpa only [r] using hrem.symm + +/-- Natural-number wrapper using Lean's canonical little-endian bits. -/ +def binaryLongDiv (dividend divisor : β„•) : β„• Γ— β„• := + binaryLongDivBits divisor dividend.bits + +theorem binaryLongDiv_eq_div_mod (dividend divisor : β„•) : + binaryLongDiv dividend divisor = + (dividend / divisor, dividend % divisor) := by + rw [binaryLongDiv, binaryLongDivBits_eq_div_mod, + Nat.fromBitsLE_bits] + +theorem binaryLongDiv_remainder_lt {dividend divisor : β„•} + (hdivisor : 0 < divisor) : + (binaryLongDiv dividend divisor).2 < divisor := by + rw [binaryLongDiv_eq_div_mod] + exact Nat.mod_lt _ hdivisor + +theorem binaryLongDivBits_quotient_le_value (divisor : β„•) + (bits : List Bool) : + (binaryLongDivBits divisor bits).1 ≀ Nat.fromBitsLE bits := by + rw [binaryLongDivBits_eq_div_mod] + exact Nat.div_le_self _ _ + +theorem binaryLongDivBits_remainder_le_value (divisor : β„•) + (bits : List Bool) : + (binaryLongDivBits divisor bits).2 ≀ Nat.fromBitsLE bits := by + rw [binaryLongDivBits_eq_div_mod] + exact Nat.mod_le _ _ + +/-- Both result registers fit in the input word width. -/ +theorem binaryLongDivBits_components_lt_width (divisor : β„•) + (bits : List Bool) : + (binaryLongDivBits divisor bits).1 < 2 ^ bits.length ∧ + (binaryLongDivBits divisor bits).2 < 2 ^ bits.length := by + have hvalue := Nat.fromBitsLE_lt_pow_length bits + exact ⟨(binaryLongDivBits_quotient_le_value divisor bits).trans_lt hvalue, + (binaryLongDivBits_remainder_le_value divisor bits).trans_lt hvalue⟩ + +/-- Euclid's algorithm with its remainder supplied by the verified binary +division recurrence. -/ +def binaryEuclid (a : β„•) : β„• β†’ β„• + | 0 => a + | b + 1 => + binaryEuclid (b + 1) (binaryLongDiv a (b + 1)).2 +termination_by b => b +decreasing_by + exact binaryLongDiv_remainder_lt (by omega) + +theorem binaryEuclid_eq_gcd : βˆ€ a b : β„•, + binaryEuclid a b = Nat.gcd a b := by + intro a b + induction b using Nat.strong_induction_on generalizing a with + | h b ih => + cases b with + | zero => simp [binaryEuclid] + | succ b => + have hrem : a % (b + 1) < b + 1 := Nat.mod_lt _ (by omega) + rw [binaryEuclid, binaryLongDiv_eq_div_mod] + simp only [Prod.snd] + rw [ih (a % (b + 1)) hrem] + calc + Nat.gcd (b + 1) (a % (b + 1)) = + Nat.gcd (a % (b + 1)) (b + 1) := Nat.gcd_comm _ _ + _ = Nat.gcd (b + 1) a := (Nat.gcd_rec (b + 1) a).symm + _ = Nat.gcd a (b + 1) := Nat.gcd_comm _ _ + +/-- One total Euclid step. Once the second register is zero it is a no-op. -/ +def binaryEuclidStep (state : β„• Γ— β„•) : β„• Γ— β„• := + if state.2 = 0 then state + else (state.2, (binaryLongDiv state.1 state.2).2) + +theorem binaryEuclidStep_eq (a b : β„•) : + binaryEuclidStep (a, b) = + if b = 0 then (a, b) else (b, a % b) := by + simp [binaryEuclidStep, binaryLongDiv_eq_div_mod] + +theorem binaryEuclidStep_zero (a : β„•) : + binaryEuclidStep (a, 0) = (a, 0) := by + simp [binaryEuclidStep] + +/-- For `0 < r < b`, the next Euclidean remainder is at most half of +`b`. -/ +theorem mod_le_half_of_pos_of_lt {b r : β„•} (hr0 : 0 < r) (hrb : r < b) : + b % r ≀ b / 2 := by + by_cases hrhalf : r ≀ b / 2 + Β· exact (Nat.mod_lt b hr0).le.trans hrhalf + Β· have hbr : r ≀ b := hrb.le + rw [Nat.mod_eq_sub_mod hbr, Nat.mod_eq_of_lt (by omega)] + omega + +/-- Irrespective of the first register, two Euclid steps halve the second +register. -/ +theorem binaryEuclidStep_two_snd_le_half (a b : β„•) : + ((binaryEuclidStep^[2]) (a, b)).2 ≀ b / 2 := by + by_cases hb : b = 0 + Β· subst b + simp [Function.iterate_succ_apply, binaryEuclidStep_zero] + Β· have hbpos : 0 < b := Nat.pos_of_ne_zero hb + let r := a % b + have hrb : r < b := by + dsimp only [r] + exact Nat.mod_lt _ hbpos + have hfirst : binaryEuclidStep (a, b) = (b, r) := by + rw [binaryEuclidStep_eq, ite_eq_right hb] + rw [show (binaryEuclidStep^[2]) (a, b) = + binaryEuclidStep (binaryEuclidStep (a, b)) by rfl, hfirst] + by_cases hr : r = 0 + Β· rw [hr, binaryEuclidStep_zero] + simp + Β· rw [binaryEuclidStep_eq, ite_eq_right hr] + simp only [Prod.snd] + exact mod_le_half_of_pos_of_lt (Nat.pos_of_ne_zero hr) hrb + +/-- Fixed-budget Euclid loop. -/ +def binaryEuclidIterate (steps : β„•) (state : β„• Γ— β„•) : β„• Γ— β„• := + (binaryEuclidStep^[steps]) state + +theorem binaryEuclidIterate_zero (steps a : β„•) : + binaryEuclidIterate steps (a, 0) = (a, 0) := by + induction steps with + | zero => rfl + | succ steps ih => + rw [binaryEuclidIterate, Function.iterate_succ_apply, + binaryEuclidStep_zero] + simpa only [binaryEuclidIterate] using ih + +/-- Two steps per available input bit suffice to reach remainder zero. -/ +theorem binaryEuclidIterate_snd_eq_zero_of_lt_pow : + βˆ€ k a b : β„•, b < 2 ^ k β†’ + (binaryEuclidIterate (2 * k) (a, b)).2 = 0 := by + intro k + induction k with + | zero => + intro a b hb + have : b = 0 := by simpa using hb + subst b + simp [binaryEuclidIterate] + | succ k ih => + intro a b hb + by_cases hb0 : b = 0 + Β· subst b + simp [binaryEuclidIterate_zero] + Β· let afterTwo := (binaryEuclidStep^[2]) (a, b) + have hhalf := binaryEuclidStep_two_snd_le_half a b + have hbhalf : b / 2 < 2 ^ k := by + rw [pow_succ] at hb + omega + have hafter : afterTwo.2 < 2 ^ k := by + exact hhalf.trans_lt hbhalf + have htail := ih afterTwo.1 afterTwo.2 hafter + rw [binaryEuclidIterate] at htail ⊒ + rw [show 2 * (k + 1) = 2 * k + 2 by omega, + Function.iterate_add_apply] + exact htail + +theorem binaryEuclidStep_gcd (state : β„• Γ— β„•) : + Nat.gcd (binaryEuclidStep state).1 (binaryEuclidStep state).2 = + Nat.gcd state.1 state.2 := by + rcases state with ⟨a, b⟩ + rw [binaryEuclidStep_eq] + split + Β· rfl + Β· simp only [Prod.fst, Prod.snd] + calc + Nat.gcd b (a % b) = Nat.gcd (a % b) b := Nat.gcd_comm _ _ + _ = Nat.gcd b a := (Nat.gcd_rec b a).symm + _ = Nat.gcd a b := Nat.gcd_comm _ _ + +theorem binaryEuclidIterate_gcd (steps : β„•) (state : β„• Γ— β„•) : + Nat.gcd (binaryEuclidIterate steps state).1 + (binaryEuclidIterate steps state).2 = + Nat.gcd state.1 state.2 := by + induction steps generalizing state with + | zero => rfl + | succ steps ih => + rw [binaryEuclidIterate, Function.iterate_succ_apply] + change Nat.gcd + (binaryEuclidIterate steps (binaryEuclidStep state)).1 + (binaryEuclidIterate steps (binaryEuclidStep state)).2 = _ + rw [ih, binaryEuclidStep_gcd] + +/-- Machine-facing gcd: a fixed `2 * bitlength` loop rather than an +unbounded semantic recursion. -/ +def binaryEuclidBounded (a b : β„•) : β„• := + (binaryEuclidIterate (2 * b.size) (a, b)).1 + +theorem binaryEuclidBounded_eq_gcd (a b : β„•) : + binaryEuclidBounded a b = Nat.gcd a b := by + have hb : b < 2 ^ b.size := Nat.lt_size_self b + have hzero := binaryEuclidIterate_snd_eq_zero_of_lt_pow b.size a b hb + have hgcd := binaryEuclidIterate_gcd (2 * b.size) (a, b) + rw [hzero, Nat.gcd_zero_right] at hgcd + exact hgcd + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalComparison.lean b/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalComparison.lean new file mode 100644 index 0000000000..2d97ab4bde --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalComparison.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds +public import Mathlib.Tactic + +/-! # Binary Rational Comparison -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Rational comparison through signed cross multiplication + +The machine-facing numerical path must not hide an order oracle on canonical +rationals. The tests below compare signed cross products of the stored +numerators and positive denominators. Their correctness is a direct +consequence of positivity of the denominators. +-/ + +/-- Strict rational comparison by signed cross multiplication. -/ +def binaryRatLt (q r : β„š) : Bool := + decide (q.num * (r.den : β„€) < r.num * (q.den : β„€)) + +theorem binaryRatLt_eq_true_iff (q r : β„š) : + binaryRatLt q r = true ↔ q < r := by + simp only [binaryRatLt, decide_eq_true_eq] + constructor + Β· intro h + have hcross : (q.num : β„š) * (r.den : β„š) < + (r.num : β„š) * (q.den : β„š) := by + exact_mod_cast h + have hdiv : (q.num : β„š) / (q.den : β„š) < + (r.num : β„š) / (r.den : β„š) := + (div_lt_div_iffβ‚€ (by positivity) (by positivity)).2 hcross + simpa only [q.num_div_den, r.num_div_den] using hdiv + Β· intro h + have hdiv : (q.num : β„š) / (q.den : β„š) < + (r.num : β„š) / (r.den : β„š) := by + simpa only [q.num_div_den, r.num_div_den] using h + have hcross := + (div_lt_div_iffβ‚€ (by positivity : (0 : β„š) < q.den) + (by positivity : (0 : β„š) < r.den)).1 hdiv + exact_mod_cast hcross + +/-- Non-strict rational comparison by signed cross multiplication. -/ +def binaryRatLe (q r : β„š) : Bool := + decide (q.num * (r.den : β„€) ≀ r.num * (q.den : β„€)) + +theorem binaryRatLe_eq_true_iff (q r : β„š) : + binaryRatLe q r = true ↔ q ≀ r := by + simp only [binaryRatLe, decide_eq_true_eq] + constructor + Β· intro h + have hcross : (q.num : β„š) * (r.den : β„š) ≀ + (r.num : β„š) * (q.den : β„š) := by + exact_mod_cast h + have hdiv : (q.num : β„š) / (q.den : β„š) ≀ + (r.num : β„š) / (r.den : β„š) := + (div_le_div_iffβ‚€ (by positivity) (by positivity)).2 hcross + simpa only [q.num_div_den, r.num_div_den] using hdiv + Β· intro h + have hdiv : (q.num : β„š) / (q.den : β„š) ≀ + (r.num : β„š) / (r.den : β„š) := by + simpa only [q.num_div_den, r.num_div_den] using h + have hcross := + (div_le_div_iffβ‚€ (by positivity : (0 : β„š) < q.den) + (by positivity : (0 : β„š) < r.den)).1 hdiv + exact_mod_cast hcross + +/-- Equality of canonical rationals by equality of their stored fields. -/ +def binaryRatEq (q r : β„š) : Bool := + decide (q.num = r.num ∧ q.den = r.den) + +theorem binaryRatEq_eq_true_iff (q r : β„š) : + binaryRatEq q r = true ↔ q = r := by + simp only [binaryRatEq, decide_eq_true_eq] + constructor + Β· rintro ⟨hnum, hden⟩ + exact Rat.ext hnum hden + Β· rintro rfl + exact ⟨rfl, rfl⟩ + +/-- Sign test read directly from the stored numerator. -/ +def binaryRatNonnegative (q : β„š) : Bool := decide (0 ≀ q.num) + +theorem binaryRatNonnegative_eq_true_iff (q : β„š) : + binaryRatNonnegative q = true ↔ 0 ≀ q := by + simp [binaryRatNonnegative, Rat.num_nonneg] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalFloor.lean b/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalFloor.lean new file mode 100644 index 0000000000..1169bcbfbf --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/BinaryRationalFloor.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import Mathlib.Tactic + +/-! # Binary Rational Floor -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Rational floor through verified binary division + +The numerical implementation repeatedly rounds rational state entries to a +dyadic grid. This file removes `Int.floor` from the machine-facing path: the +quotient and remainder are obtained by `binaryLongDiv`, whose recurrence and +fixed-width bounds are proved in `BinaryLongDivision.lean`. +-/ + +/-- Euclidean floor of a canonical rational. For a negative numerator, +`-a/d` rounds to `-(a/d)` when the remainder vanishes and to +`-(a/d+1)` otherwise. -/ +def binaryRatFloor (q : β„š) : β„€ := + let qr := binaryLongDiv q.num.natAbs q.den + if 0 ≀ q.num then + (qr.1 : β„€) + else if qr.2 = 0 then + -(qr.1 : β„€) + else + -((qr.1 + 1 : β„•) : β„€) + +theorem binaryRatFloor_eq_floor (q : β„š) : + binaryRatFloor q = Int.floor q := by + rw [Rat.floor_def', binaryRatFloor, binaryLongDiv_eq_div_mod] + simp only [Prod.fst, Prod.snd] + cases hnum : q.num with + | ofNat n => + simp [hnum, Int.ediv] + | negSucc n => + have hden : 0 < q.den := q.den_pos + by_cases hrem : (n + 1) % q.den = 0 + Β· simp [hnum, hrem, Int.ediv, Int.bdiv, Int.bmod] + have hdvdNat : q.den ∣ n + 1 := Nat.dvd_of_mod_eq_zero hrem + have hdvdInt : (q.den : β„€) ∣ ((n + 1 : β„•) : β„€) := by + exact_mod_cast hdvdNat + have hrepr : Int.negSucc n = -((n + 1 : β„•) : β„€) := by omega + rw [hrepr, Int.neg_ediv_of_dvd hdvdInt] + norm_num + Β· simp [hnum, hrem, Int.ediv, Int.bdiv, Int.bmod] + have hndvdNat : Β¬q.den ∣ n + 1 := by + rwa [Nat.dvd_iff_mod_eq_zero] + have hndvdInt : Β¬(q.den : β„€) ∣ ((n + 1 : β„•) : β„€) := by + exact_mod_cast hndvdNat + have hrepr : Int.negSucc n = -((n + 1 : β„•) : β„€) := by omega + rw [hrepr, Int.neg_ediv, ite_eq_right hndvdInt, + Int.sign_eq_one_of_pos (by exact_mod_cast hden)] + norm_num [Nat.add_comm] + ring + +/-- Ceiling obtained from the same verified floor routine. -/ +def binaryRatCeil (q : β„š) : β„€ := -binaryRatFloor (-q) + +theorem binaryRatCeil_eq_ceil (q : β„š) : + binaryRatCeil q = Int.ceil q := by + rw [binaryRatCeil, binaryRatFloor_eq_floor] + simpa only [neg_neg] using + congrArg Neg.neg (Int.floor_neg (a := q)) + +/-- Machine-facing dyadic floor, using verified integer division in the only +non-field operation. -/ +def binaryDyadicFloor (p : β„•) (q : β„š) : β„š := + (binaryRatFloor (q * (2 : β„š) ^ p) : β„š) / (2 : β„š) ^ p + +theorem binaryDyadicFloor_eq_dyadicFloor (p : β„•) (q : β„š) : + binaryDyadicFloor p q = dyadicFloor p q := by + rw [binaryDyadicFloor, dyadicFloor, binaryRatFloor_eq_floor] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Birkhoff.lean b/LeanPool/BeyondBethe/BeyondBethe/Birkhoff.lean new file mode 100644 index 0000000000..9d2b7f4578 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Birkhoff.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import Mathlib.Tactic + +/-! # Birkhoff -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Membership in the Birkhoff polytope, stated without bundling the matrix. -/ +def IsDoublyStochastic + {n : Type*} [Fintype n] (X : Matrix n n ℝ) : Prop := + Matrix.Nonnegative X ∧ + (βˆ€ i, βˆ‘ j, X i j = 1) ∧ + (βˆ€ j, βˆ‘ i, X i j = 1) + +theorem IsDoublyStochastic.nonnegative + {n : Type*} [Fintype n] {X : Matrix n n ℝ} + (hX : IsDoublyStochastic X) : Matrix.Nonnegative X := + hX.1 + +theorem IsDoublyStochastic.row_sum + {n : Type*} [Fintype n] {X : Matrix n n ℝ} + (hX : IsDoublyStochastic X) (i : n) : + βˆ‘ j, X i j = 1 := + hX.2.1 i + +theorem IsDoublyStochastic.col_sum + {n : Type*} [Fintype n] {X : Matrix n n ℝ} + (hX : IsDoublyStochastic X) (j : n) : + βˆ‘ i, X i j = 1 := + hX.2.2 j + +theorem IsDoublyStochastic.entry_le_one + {n : Type*} [Fintype n] [DecidableEq n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) (i j : n) : + X i j ≀ 1 := by + rw [← hX.row_sum i] + exact Finset.single_le_sum + (fun k _ ↦ hX.nonnegative i k) (Finset.mem_univ j) + +theorem IsDoublyStochastic.entry_lt_one_of_positive + {n : Type*} [Fintype n] [DecidableEq n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) + (hXpos : βˆ€ i j, 0 < X i j) (hcard : 1 < Fintype.card n) + (i j : n) : + X i j < 1 := by + obtain ⟨k, hkj⟩ := Fintype.exists_ne_of_one_lt_card hcard j + rw [← hX.row_sum i] + calc + X i j < X i j + X i k := lt_add_of_pos_right _ (hXpos i k) + _ = βˆ‘ l ∈ ({j, k} : Finset n), X i l := by + rw [Finset.sum_pair hkj.symm] + _ ≀ βˆ‘ l, X i l := Finset.sum_le_sum_of_subset_of_nonneg + (Finset.subset_univ _) (fun l _ _ ↦ hX.nonnegative i l) + +/-- Total column mass of two rows. -/ +def pairAlpha {n : Type*} (X : Matrix n n ℝ) (r s j : n) : ℝ := + X r j + X s j + +theorem pairAlpha_nonneg + {n : Type*} [Fintype n] {X : Matrix n n ℝ} + (hX : IsDoublyStochastic X) (r s j : n) : + 0 ≀ pairAlpha X r s j := by + exact add_nonneg (hX.nonnegative r j) (hX.nonnegative s j) + +theorem pairAlpha_le_one + {n : Type*} [Fintype n] [DecidableEq n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) + {r s : n} (hrs : r β‰  s) (j : n) : + pairAlpha X r s j ≀ 1 := by + rw [← hX.col_sum j] + calc + pairAlpha X r s j = βˆ‘ i ∈ ({r, s} : Finset n), X i j := by + simp [pairAlpha, hrs] + _ ≀ βˆ‘ i, X i j := by + exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + fun i _ _ ↦ hX.nonnegative i j + +theorem exists_ne_ne_of_two_lt_card + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 2 < Fintype.card ΞΉ) (r s : ΞΉ) : + βˆƒ t, t β‰  r ∧ t β‰  s := by + obtain ⟨x, y, z, hxy, hxz, hyz⟩ := Fintype.two_lt_card_iff.mp hcard + by_cases hx : x β‰  r ∧ x β‰  s + Β· exact ⟨x, hx⟩ + by_cases hy : y β‰  r ∧ y β‰  s + Β· exact ⟨y, hy⟩ + simp only [not_and_or, not_ne_iff] at hx hy + rcases hx with hxr | hxs <;> rcases hy with hyr | hys + Β· exact False.elim (hxy (hxr.trans hyr.symm)) + Β· refine ⟨z, ?_, ?_⟩ + Β· exact fun hzr ↦ hxz (hxr.trans hzr.symm) + Β· exact fun hzs ↦ hyz (hys.trans hzs.symm) + Β· refine ⟨z, ?_, ?_⟩ + Β· exact fun hzr ↦ hyz (hyr.trans hzr.symm) + Β· exact fun hzs ↦ hxz (hxs.trans hzs.symm) + Β· exact False.elim (hxy (hxs.trans hys.symm)) + +theorem pairAlpha_lt_one_of_positive + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hXpos : βˆ€ i j, 0 < X i j) (hcard : 2 < Fintype.card ΞΉ) + {r s : ΞΉ} (hrs : r β‰  s) (j : ΞΉ) : + pairAlpha X r s j < 1 := by + obtain ⟨t, htr, hts⟩ := exists_ne_ne_of_two_lt_card hcard r s + calc + pairAlpha X r s j < pairAlpha X r s j + X t j := + lt_add_of_pos_right _ (hXpos t j) + _ = βˆ‘ i ∈ ({r, s, t} : Finset ΞΉ), X i j := by + simp [pairAlpha, hrs, Ne.symm htr, Ne.symm hts] + ring + _ ≀ βˆ‘ i, X i j := Finset.sum_le_sum_of_subset_of_nonneg + (Finset.subset_univ _) (fun i _ _ ↦ hX.nonnegative i j) + _ = 1 := hX.col_sum j + +theorem sum_pairAlpha + {n : Type*} [Fintype n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) (r s : n) : + βˆ‘ j, pairAlpha X r s j = 2 := by + simp_rw [pairAlpha, Finset.sum_add_distrib, hX.row_sum] + norm_num + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Capacity.lean b/LeanPool/BeyondBethe/BeyondBethe/Capacity.lean new file mode 100644 index 0000000000..98f352e551 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Capacity.lean @@ -0,0 +1,359 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.Tactic + +/-! # Capacity -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- A monomial with a natural exponent vector. -/ +noncomputable def natMonomial + {Οƒ : Type*} [Fintype Οƒ] (z : Οƒ β†’ ℝ) (E : Οƒ β†’ β„•) : ℝ := + ∏ j, (z j) ^ (E j) + +/-- A finite positive-coefficient polynomial presented by its list of +monomials. -/ +noncomputable def finitePolynomial + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [Fintype Οƒ] + (c : ΞΊ β†’ ℝ) (E : ΞΊ β†’ Οƒ β†’ β„•) (z : Οƒ β†’ ℝ) : ℝ := + βˆ‘ e, c e * natMonomial z (E e) + +/-- Barycenter of the exponent vectors under a distribution `ΞΈ`. -/ +noncomputable def exponentMoment + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] + (ΞΈ : ΞΊ β†’ ℝ) (E : ΞΊ β†’ Οƒ β†’ β„•) (j : Οƒ) : ℝ := + βˆ‘ e, ΞΈ e * (E e j : ℝ) + +/-- Entropic objective on a positive coefficient representation. -/ +noncomputable def entropyCapacityCertificate + {ΞΊ : Type*} [Fintype ΞΊ] (ΞΈ c : ΞΊ β†’ ℝ) : ℝ := + βˆ‘ e, ΞΈ e * Real.log (c e / ΞΈ e) + +theorem log_natMonomial + {Οƒ : Type*} [Fintype Οƒ] + {z : Οƒ β†’ ℝ} (hz : βˆ€ j, 0 < z j) (E : Οƒ β†’ β„•) : + Real.log (natMonomial z E) = + βˆ‘ j, (E j : ℝ) * Real.log (z j) := by + rw [natMonomial, Real.log_prod] + Β· apply Finset.sum_congr rfl + intro j _ + simpa using Real.log_pow (z j) (E j) + Β· intro j _ + exact (pow_pos (hz j) _).ne' + +theorem log_realMonomial + {Οƒ : Type*} [Fintype Οƒ] + {z Ξ± : Οƒ β†’ ℝ} (hz : βˆ€ j, 0 < z j) : + Real.log (realMonomial z Ξ±) = + βˆ‘ j, Ξ± j * Real.log (z j) := by + rw [realMonomial, Real.log_prod] + Β· apply Finset.sum_congr rfl + intro j _ + exact Real.log_rpow (hz j) (Ξ± j) + Β· intro j _ + exact (Real.rpow_pos_of_pos (hz j) _).ne' + +theorem averaged_log_natMonomial + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [Fintype Οƒ] + (ΞΈ : ΞΊ β†’ ℝ) (E : ΞΊ β†’ Οƒ β†’ β„•) + {z : Οƒ β†’ ℝ} (hz : βˆ€ j, 0 < z j) : + βˆ‘ e, ΞΈ e * Real.log (natMonomial z (E e)) = + βˆ‘ j, exponentMoment ΞΈ E j * Real.log (z j) := by + simp_rw [log_natMonomial hz] + calc + βˆ‘ e, ΞΈ e * (βˆ‘ j, (E e j : ℝ) * Real.log (z j)) = + βˆ‘ e, βˆ‘ j, (ΞΈ e * (E e j : ℝ)) * Real.log (z j) := by + apply Finset.sum_congr rfl + intro e _ + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j _ + ring + _ = βˆ‘ j, βˆ‘ e, (ΞΈ e * (E e j : ℝ)) * Real.log (z j) := + Finset.sum_comm + _ = βˆ‘ j, exponentMoment ΞΈ E j * Real.log (z j) := by + apply Finset.sum_congr rfl + intro j _ + rw [exponentMoment, Finset.sum_mul] + +/-- The certificate-producing direction of paper Lemma 4, for a strictly +positive feasible distribution. Unlike the reverse equality, this direction +uses only finite log-sum and has no convex-duality dependency. -/ +theorem entropyCapacityCertificate_le_log_ratio + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype Οƒ] + {ΞΈ c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± z : Οƒ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 < ΞΈ e) (hΞΈsum : βˆ‘ e, ΞΈ e = 1) + (hc : βˆ€ e, 0 < c e) (hz : βˆ€ j, 0 < z j) + (hmoment : βˆ€ j, exponentMoment ΞΈ E j = Ξ± j) : + entropyCapacityCertificate ΞΈ c ≀ + Real.log (finitePolynomial c E z / realMonomial z Ξ±) := by + let w : ΞΊ β†’ ℝ := fun e ↦ c e * natMonomial z (E e) + have hnatpos : βˆ€ e, 0 < natMonomial z (E e) := by + intro e + rw [natMonomial] + exact Finset.prod_pos fun j _ ↦ pow_pos (hz j) _ + have hw : βˆ€ e, 0 < w e := fun e ↦ mul_pos (hc e) (hnatpos e) + have hlogsum := log_sum_inequality hΞΈ hΞΈsum hw + have hpoly : βˆ‘ e, w e = finitePolynomial c E z := by + rfl + rw [hpoly] at hlogsum + have hsplit : βˆ€ e, + Real.log (w e / ΞΈ e) = + Real.log (c e / ΞΈ e) + Real.log (natMonomial z (E e)) := by + intro e + dsimp [w] + rw [Real.log_div (mul_ne_zero (hc e).ne' (hnatpos e).ne') (hΞΈ e).ne', + Real.log_mul (hc e).ne' (hnatpos e).ne', + Real.log_div (hc e).ne' (hΞΈ e).ne'] + ring + simp_rw [hsplit, mul_add, Finset.sum_add_distrib] at hlogsum + rw [averaged_log_natMonomial ΞΈ E hz] at hlogsum + have hmomlog : + βˆ‘ j, exponentMoment ΞΈ E j * Real.log (z j) = + Real.log (realMonomial z Ξ±) := by + rw [log_realMonomial hz] + apply Finset.sum_congr rfl + intro j _ + rw [hmoment j] + rw [hmomlog] at hlogsum + have hpolypos : 0 < finitePolynomial c E z := by + rw [← hpoly] + exact Finset.sum_pos (fun e _ ↦ hw e) (by + by_contra hempty + have hzero : βˆ‘ e, ΞΈ e = 0 := by + rw [Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + linarith) + have hmonopos : 0 < realMonomial z Ξ± := by + rw [realMonomial] + exact Finset.prod_pos fun j _ ↦ Real.rpow_pos_of_pos (hz j) _ + rw [Real.log_div hpolypos.ne' hmonopos.ne'] + rw [le_sub_iff_add_le] + simpa [entropyCapacityCertificate, add_comm] using hlogsum + +/-- Certificate-producing capacity inequality with zero witness weights +allowed. This is the boundary form used by the clean-pair witness. -/ +theorem entropyCapacityCertificate_le_log_ratio_nonnegative + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype Οƒ] + {ΞΈ c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± z : Οƒ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΞΈsum : βˆ‘ e, ΞΈ e = 1) + (hc : βˆ€ e, 0 < c e) (hz : βˆ€ j, 0 < z j) + (hmoment : βˆ€ j, exponentMoment ΞΈ E j = Ξ± j) : + entropyCapacityCertificate ΞΈ c ≀ + Real.log (finitePolynomial c E z / realMonomial z Ξ±) := by + let w : ΞΊ β†’ ℝ := fun e ↦ c e * natMonomial z (E e) + have hnatpos : βˆ€ e, 0 < natMonomial z (E e) := by + intro e + rw [natMonomial] + exact Finset.prod_pos fun j _ ↦ pow_pos (hz j) _ + have hw : βˆ€ e, 0 < w e := fun e ↦ mul_pos (hc e) (hnatpos e) + have hlogsum := log_sum_inequality_nonnegative hΞΈ hΞΈsum hw + have hpoly : βˆ‘ e, w e = finitePolynomial c E z := by + rfl + rw [hpoly] at hlogsum + have hsplit : βˆ€ e, + ΞΈ e * Real.log (w e / ΞΈ e) = + ΞΈ e * Real.log (c e / ΞΈ e) + + ΞΈ e * Real.log (natMonomial z (E e)) := by + intro e + by_cases hzero : ΞΈ e = 0 + Β· simp [hzero] + Β· dsimp [w] + rw [Real.log_div (mul_ne_zero (hc e).ne' (hnatpos e).ne') hzero, + Real.log_mul (hc e).ne' (hnatpos e).ne', + Real.log_div (hc e).ne' hzero] + ring + simp_rw [hsplit, Finset.sum_add_distrib] at hlogsum + rw [averaged_log_natMonomial ΞΈ E hz] at hlogsum + have hmomlog : + βˆ‘ j, exponentMoment ΞΈ E j * Real.log (z j) = + Real.log (realMonomial z Ξ±) := by + rw [log_realMonomial hz] + apply Finset.sum_congr rfl + intro j _ + rw [hmoment j] + rw [hmomlog] at hlogsum + have hpolypos : 0 < finitePolynomial c E z := by + rw [← hpoly] + exact Finset.sum_pos (fun e _ ↦ hw e) (by + by_contra hempty + have hzero : βˆ‘ e, ΞΈ e = 0 := by + rw [Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + linarith) + have hmonopos : 0 < realMonomial z Ξ± := realMonomial_pos hz Ξ± + rw [Real.log_div hpolypos.ne' hmonopos.ne'] + rw [le_sub_iff_add_le] + simpa [entropyCapacityCertificate, add_comm] using hlogsum + +/-- Capacity of a polynomial given by a finite coefficient/exponent list. -/ +noncomputable def finitePolynomialCapacity + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [Fintype Οƒ] + (c : ΞΊ β†’ ℝ) (E : ΞΊ β†’ Οƒ β†’ β„•) (Ξ± : Οƒ β†’ ℝ) : ℝ := + sInf {v : ℝ | βˆƒ z : Οƒ β†’ ℝ, (βˆ€ j, 0 < z j) ∧ + v = finitePolynomial c E z / realMonomial z Ξ±} + +theorem exp_entropyCapacityCertificate_le_finitePolynomialCapacity + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype Οƒ] + {ΞΈ c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± : Οƒ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΞΈsum : βˆ‘ e, ΞΈ e = 1) + (hc : βˆ€ e, 0 < c e) + (hmoment : βˆ€ j, exponentMoment ΞΈ E j = Ξ± j) : + Real.exp (entropyCapacityCertificate ΞΈ c) ≀ + finitePolynomialCapacity c E Ξ± := by + apply le_csInf + Β· let one : Οƒ β†’ ℝ := fun _ ↦ 1 + exact ⟨finitePolynomial c E one / realMonomial one Ξ±, + ⟨one, fun _ ↦ by norm_num, rfl⟩⟩ + Β· intro value hvalue + obtain ⟨z, hz, rfl⟩ := hvalue + have hlog := entropyCapacityCertificate_le_log_ratio_nonnegative + hΞΈ hΞΈsum hc hz hmoment + have hpolypos : 0 < finitePolynomial c E z := by + rw [finitePolynomial] + exact Finset.sum_pos (fun e _ ↦ mul_pos (hc e) (by + rw [natMonomial] + exact Finset.prod_pos fun j _ ↦ pow_pos (hz j) _)) + (by + by_contra hempty + have hzero : βˆ‘ e, ΞΈ e = 0 := by + rw [Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + linarith) + have hratio : 0 < finitePolynomial c E z / realMonomial z Ξ± := + div_pos hpolypos (realMonomial_pos hz Ξ±) + have hexp := Real.exp_le_exp.mpr hlog + rw [Real.exp_log hratio] at hexp + exact hexp + +theorem entropyCapacityCertificate_le_log_finitePolynomialCapacity + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype Οƒ] + {ΞΈ c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± : Οƒ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΞΈsum : βˆ‘ e, ΞΈ e = 1) + (hc : βˆ€ e, 0 < c e) + (hmoment : βˆ€ j, exponentMoment ΞΈ E j = Ξ± j) : + entropyCapacityCertificate ΞΈ c ≀ + Real.log (finitePolynomialCapacity c E Ξ±) := by + have hexp := exp_entropyCapacityCertificate_le_finitePolynomialCapacity + hΞΈ hΞΈsum hc hmoment + have hcap : 0 < finitePolynomialCapacity c E Ξ± := + (Real.exp_pos _).trans_le hexp + have hlog := Real.log_le_log (Real.exp_pos _) hexp + rw [Real.log_exp] at hlog + exact hlog + +/-- The coefficient of a monomial indexed by an element of the polynomial support. -/ +noncomputable def supportCoefficient + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) (d : p.support) : ℝ := + p.coeff d + +/-- The exponent of coordinate `j` in a supported monomial. -/ +def supportExponent + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) (d : p.support) (j : Οƒ) : β„• := + d.1 j + +theorem finitePolynomial_support_eq_eval + {Οƒ : Type*} [Fintype Οƒ] (p : MvPolynomial Οƒ ℝ) (z : Οƒ β†’ ℝ) : + finitePolynomial (supportCoefficient p) (supportExponent p) z = + p.eval z := by + classical + rw [finitePolynomial, MvPolynomial.eval_eq] + calc + (βˆ‘ d : p.support, + supportCoefficient p d * natMonomial z (supportExponent p d)) = + βˆ‘ d ∈ p.support, p.coeff d * ∏ j, z j ^ d j := by + simpa [supportCoefficient, supportExponent, natMonomial] using + Finset.sum_coe_sort p.support + (fun d ↦ p.coeff d * ∏ j, z j ^ d j) + _ = βˆ‘ d ∈ p.support, + p.coeff d * ∏ i ∈ d.support, z i ^ d i := by + apply Finset.sum_congr rfl + intro d _ + congr 1 + change (∏ j, z j ^ d j) = d.prod (fun i e ↦ z i ^ e) + exact (Finsupp.prod_fintype d (fun i e ↦ z i ^ e) + (fun i ↦ pow_zero (z i))).symm + +theorem finitePolynomialCapacity_support_eq_polynomialCapacity + {Οƒ : Type*} [Fintype Οƒ] (p : MvPolynomial Οƒ ℝ) (Ξ± : Οƒ β†’ ℝ) : + finitePolynomialCapacity (supportCoefficient p) (supportExponent p) Ξ± = + polynomialCapacity Ξ± p := by + rw [finitePolynomialCapacity, polynomialCapacity] + congr 1 + ext value + simp only [Set.mem_setOf_eq] + constructor + Β· rintro ⟨z, hz, rfl⟩ + exact ⟨z, hz, by rw [finitePolynomial_support_eq_eval]⟩ + Β· rintro ⟨z, hz, rfl⟩ + exact ⟨z, hz, by rw [finitePolynomial_support_eq_eval]⟩ + +/-- One-sided entropy certificate for an `MvPolynomial`, including boundary +witnesses with zero weights. Unlike the reverse entropy-duality equality, +this theorem is proved directly from log-sum. -/ +theorem supportEntropyCertificate_le_log_polynomialCapacity + {Οƒ : Type*} [Fintype Οƒ] + {p : MvPolynomial Οƒ ℝ} {ΞΈ : p.support β†’ ℝ} {Ξ± : Οƒ β†’ ℝ} + (hΞΈ : βˆ€ d, 0 ≀ ΞΈ d) (hΞΈsum : βˆ‘ d, ΞΈ d = 1) + (hcoeff : βˆ€ d : p.support, 0 < p.coeff d) + (hmoment : βˆ€ j, + exponentMoment ΞΈ (supportExponent p) j = Ξ± j) : + entropyCapacityCertificate ΞΈ (supportCoefficient p) ≀ + Real.log (polynomialCapacity Ξ± p) := by + classical + rw [← finitePolynomialCapacity_support_eq_polynomialCapacity] + exact entropyCapacityCertificate_le_log_finitePolynomialCapacity + hΞΈ hΞΈsum hcoeff hmoment + +theorem finitePolynomial_nonneg + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [Fintype Οƒ] + {c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {z : Οƒ β†’ ℝ} + (hc : βˆ€ e, 0 ≀ c e) (hz : βˆ€ j, 0 ≀ z j) : + 0 ≀ finitePolynomial c E z := by + rw [finitePolynomial] + exact Finset.sum_nonneg fun e _ ↦ mul_nonneg (hc e) + (Finset.prod_nonneg fun j _ ↦ pow_nonneg (hz j) _) + +/-- A nonnegative finite subpolynomial has no larger capacity than the full +polynomial. This lets the sparse clean-pair witness ignore all unused +monomials. -/ +theorem finitePolynomialCapacity_le_polynomialCapacity_of_eval_le + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] [Fintype Οƒ] + {c : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± : Οƒ β†’ ℝ} + {p : MvPolynomial Οƒ ℝ} + (hc : βˆ€ e, 0 ≀ c e) + (heval : βˆ€ z : Οƒ β†’ ℝ, (βˆ€ j, 0 ≀ z j) β†’ + finitePolynomial c E z ≀ p.eval z) : + finitePolynomialCapacity c E Ξ± ≀ polynomialCapacity Ξ± p := by + apply le_csInf + Β· let one : Οƒ β†’ ℝ := fun _ ↦ 1 + exact ⟨p.eval one / realMonomial one Ξ±, + ⟨one, fun _ ↦ by norm_num, rfl⟩⟩ + Β· intro value hvalue + obtain ⟨z, hz, rfl⟩ := hvalue + have hmono : 0 < realMonomial z Ξ± := realMonomial_pos hz Ξ± + have hfinUpper : finitePolynomialCapacity c E Ξ± ≀ + finitePolynomial c E z / realMonomial z Ξ± := by + apply csInf_le + Β· exact ⟨0, fun value hvalue ↦ by + obtain ⟨w, hw, rfl⟩ := hvalue + exact div_nonneg + (finitePolynomial_nonneg hc (fun j ↦ (hw j).le)) + (realMonomial_pos hw Ξ±).le⟩ + Β· exact ⟨z, hz, rfl⟩ + exact hfinUpper.trans + (div_le_div_of_nonneg_right (heval z (fun j ↦ (hz j).le)) hmono.le) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CapacityOrder.lean b/LeanPool/BeyondBethe/BeyondBethe/CapacityOrder.lean new file mode 100644 index 0000000000..25784c27b6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CapacityOrder.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import Mathlib.Tactic + +/-! # Capacity Order -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +theorem realMonomial_pos + {Οƒ : Type*} [Fintype Οƒ] {z : Οƒ β†’ ℝ} + (hz : βˆ€ i, 0 < z i) (Ξ± : Οƒ β†’ ℝ) : + 0 < realMonomial z Ξ± := by + rw [realMonomial] + exact Finset.prod_pos fun i _ ↦ Real.rpow_pos_of_pos (hz i) _ + +theorem eval_nonneg_of_nonnegativeCoefficients + {Οƒ : Type*} [Fintype Οƒ] + {p : MvPolynomial Οƒ ℝ} (hp : HasNonnegativeCoefficients p) + {z : Οƒ β†’ ℝ} (hz : βˆ€ i, 0 ≀ z i) : + 0 ≀ p.eval z := by + rw [eval_eq] + apply Finset.sum_nonneg + intro d _ + exact mul_nonneg (hp d) (Finset.prod_nonneg fun i _ ↦ + pow_nonneg (hz i) _) + +theorem polynomialCapacity_nonneg + {Οƒ : Type*} [Fintype Οƒ] + {p : MvPolynomial Οƒ ℝ} (hp : HasNonnegativeCoefficients p) + (Ξ± : Οƒ β†’ ℝ) : + 0 ≀ polynomialCapacity Ξ± p := by + apply le_csInf + Β· let one : Οƒ β†’ ℝ := fun _ ↦ 1 + exact ⟨p.eval one / realMonomial one Ξ±, + ⟨one, fun _ ↦ by norm_num, rfl⟩⟩ + Β· intro b hb + obtain ⟨z, hz, rfl⟩ := hb + exact div_nonneg + (eval_nonneg_of_nonnegativeCoefficients hp (fun i ↦ le_of_lt (hz i))) + (le_of_lt (realMonomial_pos hz Ξ±)) + +theorem polynomialCapacity_le_ratio + {Οƒ : Type*} [Fintype Οƒ] + {p : MvPolynomial Οƒ ℝ} (hp : HasNonnegativeCoefficients p) + (Ξ± z : Οƒ β†’ ℝ) (hz : βˆ€ i, 0 < z i) : + polynomialCapacity Ξ± p ≀ p.eval z / realMonomial z Ξ± := by + apply csInf_le + Β· exact ⟨0, fun b hb ↦ by + obtain ⟨w, hw, rfl⟩ := hb + exact div_nonneg + (eval_nonneg_of_nonnegativeCoefficients hp + (fun i ↦ le_of_lt (hw i))) + (le_of_lt (realMonomial_pos hw Ξ±))⟩ + Β· exact ⟨z, hz, rfl⟩ + +theorem le_polynomialCapacity_of_le_ratio + {Οƒ : Type*} [Fintype Οƒ] + {p : MvPolynomial Οƒ ℝ} {Ξ± : Οƒ β†’ ℝ} {L : ℝ} + (hL : βˆ€ z : Οƒ β†’ ℝ, (βˆ€ i, 0 < z i) β†’ + L ≀ p.eval z / realMonomial z Ξ±) : + L ≀ polynomialCapacity Ξ± p := by + apply le_csInf + Β· let one : Οƒ β†’ ℝ := fun _ ↦ 1 + exact ⟨p.eval one / realMonomial one Ξ±, + ⟨one, fun _ ↦ by norm_num, rfl⟩⟩ + Β· intro b hb + obtain ⟨z, hz, rfl⟩ := hb + exact hL z hz + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CapacityScaling.lean b/LeanPool/BeyondBethe/BeyondBethe/CapacityScaling.lean new file mode 100644 index 0000000000..31df624cab --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CapacityScaling.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import Mathlib.Tactic + +/-! # Capacity Scaling -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +theorem realMonomial_pointwise_mul + {Οƒ : Type*} [Fintype Οƒ] + (c z Ξ± : Οƒ β†’ ℝ) (hc : βˆ€ i, 0 ≀ c i) (hz : βˆ€ i, 0 ≀ z i) : + realMonomial (fun i ↦ c i * z i) Ξ± = + realMonomial c Ξ± * realMonomial z Ξ± := by + rw [realMonomial, realMonomial, realMonomial, + ← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro i _ + exact Real.mul_rpow (hc i) (hz i) + +theorem rescaled_polynomial_ratio_eq + {Οƒ : Type*} [Fintype Οƒ] + {p q : MvPolynomial Οƒ ℝ} {Ξ± c z : Οƒ β†’ ℝ} {scale : ℝ} + (hc : βˆ€ i, 0 < c i) (hz : βˆ€ i, 0 < z i) + (heval : βˆ€ w : Οƒ β†’ ℝ, + p.eval w = scale * q.eval (fun i ↦ c i * w i)) : + p.eval z / realMonomial z Ξ± = + (scale * realMonomial c Ξ±) * + (q.eval (fun i ↦ c i * z i) / + realMonomial (fun i ↦ c i * z i) Ξ±) := by + have hcz : realMonomial (fun i ↦ c i * z i) Ξ± = + realMonomial c Ξ± * realMonomial z Ξ± := + realMonomial_pointwise_mul c z Ξ± + (fun i ↦ (hc i).le) (fun i ↦ (hz i).le) + rw [heval, hcz] + field_simp [ne_of_gt (realMonomial_pos hc Ξ±), + ne_of_gt (realMonomial_pos hz Ξ±)] + +/-- Capacity is covariant under a positive scalar and a positive diagonal +change of variables. This is the exact rescaling used in paper Lemma 18. -/ +theorem polynomialCapacity_eq_of_positive_diagonal_rescaling + {Οƒ : Type*} [Fintype Οƒ] + {p q : MvPolynomial Οƒ ℝ} {Ξ± c : Οƒ β†’ ℝ} {scale : ℝ} + (hp : HasNonnegativeCoefficients p) + (hq : HasNonnegativeCoefficients q) + (hscale : 0 < scale) (hc : βˆ€ i, 0 < c i) + (heval : βˆ€ z : Οƒ β†’ ℝ, + p.eval z = scale * q.eval (fun i ↦ c i * z i)) : + polynomialCapacity Ξ± p = + (scale * realMonomial c Ξ±) * polynomialCapacity Ξ± q := by + let k : ℝ := scale * realMonomial c Ξ± + have hk : 0 < k := mul_pos hscale (realMonomial_pos hc Ξ±) + apply le_antisymm + Β· have hdiv : polynomialCapacity Ξ± p / k ≀ + polynomialCapacity Ξ± q := by + apply le_polynomialCapacity_of_le_ratio + intro w hw + let z : Οƒ β†’ ℝ := fun i ↦ w i / c i + have hz : βˆ€ i, 0 < z i := fun i ↦ div_pos (hw i) (hc i) + have hcz : (fun i ↦ c i * z i) = w := by + funext i + dsimp [z] + field_simp [ne_of_gt (hc i)] + have hratio := rescaled_polynomial_ratio_eq (Ξ± := Ξ±) hc hz heval + rw [hcz] at hratio + have hupper := polynomialCapacity_le_ratio hp Ξ± z hz + rw [hratio] at hupper + exact (div_le_iffβ‚€ hk).2 (by simpa [k, mul_comm] using hupper) + simpa [k, mul_comm] using (div_le_iffβ‚€ hk).1 hdiv + Β· apply le_polynomialCapacity_of_le_ratio + intro z hz + let w : Οƒ β†’ ℝ := fun i ↦ c i * z i + have hw : βˆ€ i, 0 < w i := fun i ↦ mul_pos (hc i) (hz i) + have hlower := polynomialCapacity_le_ratio hq Ξ± w hw + have hratio := rescaled_polynomial_ratio_eq (Ξ± := Ξ±) hc hz heval + rw [hratio] + exact mul_le_mul_of_nonneg_left hlower hk.le + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CertificateCapacity.lean b/LeanPool/BeyondBethe/BeyondBethe/CertificateCapacity.lean new file mode 100644 index 0000000000..f4b24af4f9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CertificateCapacity.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ClusterFactors +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import Mathlib.Analysis.MeanInequalities + +/-! # Certificate Capacity -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +/-- The product formula `∏ i, (u i / Ξ± i)^(Ξ± i)` for linear capacity. -/ +noncomputable def linearCapacityValue + {ΞΉ : Type*} [Fintype ΞΉ] + (u Ξ± : ΞΉ β†’ ℝ) : ℝ := + ∏ i, (u i / Ξ± i) ^ (Ξ± i) + +theorem positiveLinearPolynomial_eval + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u z : ΞΉ β†’ ℝ) : + (positiveLinearPolynomial u).eval z = βˆ‘ i, u i * z i := by + rw [positiveLinearPolynomial, eval_sum] + apply Finset.sum_congr rfl + intro i _ + rw [eval_monomial] + simp + +theorem linearCapacityValue_mul_realMonomial + {ΞΉ : Type*} [Fintype ΞΉ] + {u Ξ± z : ΞΉ β†’ ℝ} + (hu : βˆ€ i, 0 < u i) (hΞ± : βˆ€ i, 0 < Ξ± i) + (hz : βˆ€ i, 0 < z i) : + linearCapacityValue u Ξ± * realMonomial z Ξ± = + ∏ i, (u i * z i / Ξ± i) ^ (Ξ± i) := by + rw [linearCapacityValue, realMonomial, ← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro i _ + rw [← Real.mul_rpow (le_of_lt (div_pos (hu i) (hΞ± i))) + (le_of_lt (hz i))] + congr 1 + field_simp + +theorem linearCapacityValue_le_ratio + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u Ξ± z : ΞΉ β†’ ℝ} + (hu : βˆ€ i, 0 < u i) (hΞ± : βˆ€ i, 0 < Ξ± i) + (hΞ±sum : βˆ‘ i, Ξ± i = 1) (hz : βˆ€ i, 0 < z i) : + linearCapacityValue u Ξ± ≀ + (positiveLinearPolynomial u).eval z / realMonomial z Ξ± := by + rw [le_div_iffβ‚€ (realMonomial_pos hz Ξ±), + linearCapacityValue_mul_realMonomial hu hΞ± hz, + positiveLinearPolynomial_eval] + calc + (∏ i, (u i * z i / Ξ± i) ^ (Ξ± i)) ≀ + βˆ‘ i, Ξ± i * (u i * z i / Ξ± i) := by + exact Real.geom_mean_le_arith_mean_weighted Finset.univ Ξ± + (fun i ↦ u i * z i / Ξ± i) + (fun i _ ↦ le_of_lt (hΞ± i)) hΞ±sum + (fun i _ ↦ le_of_lt (div_pos (mul_pos (hu i) (hz i)) (hΞ± i))) + _ = βˆ‘ i, u i * z i := by + apply Finset.sum_congr rfl + intro i _ + field_simp [ne_of_gt (hΞ± i)] + +theorem linearCapacityValue_le_capacity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u Ξ± : ΞΉ β†’ ℝ} + (hu : βˆ€ i, 0 < u i) (hΞ± : βˆ€ i, 0 < Ξ± i) + (hΞ±sum : βˆ‘ i, Ξ± i = 1) : + linearCapacityValue u Ξ± ≀ + polynomialCapacity Ξ± (positiveLinearPolynomial u) := by + apply le_polynomialCapacity_of_le_ratio + intro z hz + exact linearCapacityValue_le_ratio hu hΞ± hΞ±sum hz + +/-- Exact weighted AM--GM capacity of a positive linear form. -/ +theorem linearCapacityValue_eq_capacity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u Ξ± : ΞΉ β†’ ℝ} + (hu : βˆ€ i, 0 < u i) (hΞ± : βˆ€ i, 0 < Ξ± i) + (hΞ±sum : βˆ‘ i, Ξ± i = 1) : + linearCapacityValue u Ξ± = + polynomialCapacity Ξ± (positiveLinearPolynomial u) := by + apply le_antisymm + Β· exact linearCapacityValue_le_capacity hu hΞ± hΞ±sum + Β· let z : ΞΉ β†’ ℝ := fun i ↦ Ξ± i / u i + have hz : βˆ€ i, 0 < z i := fun i ↦ div_pos (hΞ± i) (hu i) + have hupper := polynomialCapacity_le_ratio + (p := positiveLinearPolynomial u) + (positiveLinearPolynomial_nonnegativeCoefficients + (fun i ↦ le_of_lt (hu i))) Ξ± z hz + have heval : (positiveLinearPolynomial u).eval z = 1 := by + rw [positiveLinearPolynomial_eval] + calc + (βˆ‘ i, u i * z i) = βˆ‘ i, Ξ± i := by + apply Finset.sum_congr rfl + intro i _ + dsimp [z] + field_simp [ne_of_gt (hu i)] + _ = 1 := hΞ±sum + have hterm : βˆ€ i, + (z i) ^ (Ξ± i) = ((u i / Ξ± i) ^ (Ξ± i))⁻¹ := by + intro i + have hratio : z i = (u i / Ξ± i)⁻¹ := by + dsimp [z] + field_simp [ne_of_gt (hu i), ne_of_gt (hΞ± i)] + rw [hratio, Real.inv_rpow (le_of_lt (div_pos (hu i) (hΞ± i)))] + have hmono : realMonomial z Ξ± = (linearCapacityValue u Ξ±)⁻¹ := by + rw [realMonomial, linearCapacityValue] + simp_rw [hterm] + exact Finset.prod_inv_distrib _ + rw [heval, hmono, one_div, inv_inv] at hupper + exact hupper + +/-- The product of the unit-coefficient linear capacity expressions, one for each selector +coordinate. -/ +noncomputable def selectorCapacityValue + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + (Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ) : ℝ := + ∏ j, linearCapacityValue (fun _ : ΞΊ ↦ 1) (fun c ↦ Ξ± (c, j)) + +theorem columnSelector_eval + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] + (z : ΞΊ Γ— ΞΉ β†’ ℝ) : + (columnSelector ΞΊ ΞΉ).eval z = ∏ j, βˆ‘ c, z (c, j) := by + rw [columnSelector_eq_product, columnSelectorProduct, eval_prod] + apply Finset.prod_congr rfl + intro j _ + rw [eval_sum] + simp + +theorem realMonomial_eq_prod_columns + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + (z Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ) : + realMonomial z Ξ± = + ∏ j, realMonomial (fun c ↦ z (c, j)) (fun c ↦ Ξ± (c, j)) := by + rw [realMonomial] + simp only [realMonomial, Fintype.prod_prod_type] + exact Finset.prod_comm + +theorem selectorCapacityValue_mul_realMonomial + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + {Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ} {z : ΞΊ Γ— ΞΉ β†’ ℝ} + (hΞ± : βˆ€ v, 0 < Ξ± v) (hz : βˆ€ v, 0 < z v) : + selectorCapacityValue Ξ± * realMonomial z Ξ± = + ∏ j, (linearCapacityValue (fun _ : ΞΊ ↦ 1) + (fun c ↦ Ξ± (c, j)) * + realMonomial (fun c ↦ z (c, j)) (fun c ↦ Ξ± (c, j))) := by + rw [selectorCapacityValue, realMonomial_eq_prod_columns, + ← Finset.prod_mul_distrib] + +theorem selectorCapacityValue_le_ratio + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ} {z : ΞΊ Γ— ΞΉ β†’ ℝ} + (hΞ± : βˆ€ v, 0 < Ξ± v) + (hΞ±col : βˆ€ j, βˆ‘ c, Ξ± (c, j) = 1) + (hz : βˆ€ v, 0 < z v) : + selectorCapacityValue Ξ± ≀ + (columnSelector ΞΊ ΞΉ).eval z / realMonomial z Ξ± := by + rw [le_div_iffβ‚€ (realMonomial_pos hz Ξ±), columnSelector_eval, + selectorCapacityValue_mul_realMonomial hΞ± hz] + apply Finset.prod_le_prodβ‚€ + Β· intro j _ + exact mul_nonneg + (Finset.prod_nonneg fun c _ ↦ Real.rpow_nonneg + (le_of_lt (div_pos (by norm_num) (hΞ± (c, j)))) _) + (le_of_lt (realMonomial_pos (fun c ↦ hz (c, j)) + (fun c ↦ Ξ± (c, j)))) + Β· intro j _ + have hlin := linearCapacityValue_le_ratio + (u := fun _ : ΞΊ ↦ 1) (Ξ± := fun c ↦ Ξ± (c, j)) + (z := fun c ↦ z (c, j)) + (fun _ ↦ by norm_num) (fun c ↦ hΞ± (c, j)) + (hΞ±col j) (fun c ↦ hz (c, j)) + rw [le_div_iffβ‚€ (realMonomial_pos (fun c ↦ hz (c, j)) + (fun c ↦ Ξ± (c, j)))] at hlin + simpa only [positiveLinearPolynomial_eval, one_mul] using hlin + +theorem selectorCapacityValue_le_capacity + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ} + (hΞ± : βˆ€ v, 0 < Ξ± v) + (hΞ±col : βˆ€ j, βˆ‘ c, Ξ± (c, j) = 1) : + selectorCapacityValue Ξ± ≀ + polynomialCapacity Ξ± (columnSelector ΞΊ ΞΉ) := by + apply le_polynomialCapacity_of_le_ratio + intro z hz + exact selectorCapacityValue_le_ratio hΞ± hΞ±col hz + +/-- The product of the capacities of the cluster injection polynomials at the prescribed +exponents. -/ +noncomputable def clusterProductCapacityValue + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) : ℝ := + ∏ c, polynomialCapacity (fun j ↦ Ξ± (c, j)) + (injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j)) + +theorem rowClusterProduct_eval_eq_prod_injection + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (z : C.Cluster Γ— Fin n β†’ ℝ) : + (rowClusterProduct A C).eval z = + ∏ c, (injectionPolynomial + (fun k j ↦ A (C.rows ⟨c, k⟩) j)).eval (fun j ↦ z (c, j)) := by + rw [rowClusterProduct, eval_prod] + apply Finset.prod_congr rfl + intro c _ + rw [rowClusterPolynomial_eq_rename_injectionPolynomial, + eval_rename] + rfl + +theorem realMonomial_eq_prod_clusters + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + (z Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ) : + realMonomial z Ξ± = + ∏ c, realMonomial (fun j ↦ z (c, j)) (fun j ↦ Ξ± (c, j)) := by + rw [realMonomial] + simp only [realMonomial, Fintype.prod_prod_type] + +theorem clusterProductCapacityValue_nonneg + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : Matrix.Nonnegative A) (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) : + 0 ≀ clusterProductCapacityValue A C Ξ± := by + rw [clusterProductCapacityValue] + exact Finset.prod_nonneg fun c _ ↦ polynomialCapacity_nonneg + (injectionPolynomial_nonnegativeCoefficients + (fun k j ↦ hA (C.rows ⟨c, k⟩) j)) _ + +theorem clusterProductCapacityValue_le_ratio + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : Matrix.Nonnegative A) (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) + (z : C.Cluster Γ— Fin n β†’ ℝ) (hz : βˆ€ v, 0 < z v) : + clusterProductCapacityValue A C Ξ± ≀ + (rowClusterProduct A C).eval z / realMonomial z Ξ± := by + rw [clusterProductCapacityValue, + rowClusterProduct_eval_eq_prod_injection, + realMonomial_eq_prod_clusters, ← Finset.prod_div_distrib] + apply Finset.prod_le_prodβ‚€ + Β· intro c _ + exact polynomialCapacity_nonneg + (injectionPolynomial_nonnegativeCoefficients + (fun k j ↦ hA (C.rows ⟨c, k⟩) j)) _ + Β· intro c _ + exact polynomialCapacity_le_ratio + (injectionPolynomial_nonnegativeCoefficients + (fun k j ↦ hA (C.rows ⟨c, k⟩) j)) + (fun j ↦ Ξ± (c, j)) (fun j ↦ z (c, j)) + (fun j ↦ hz (c, j)) + +theorem clusterProductCapacityValue_le_capacity + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : Matrix.Nonnegative A) (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) : + clusterProductCapacityValue A C Ξ± ≀ + polynomialCapacity Ξ± (rowClusterProduct A C) := by + apply le_polynomialCapacity_of_le_ratio + intro z hz + exact clusterProductCapacityValue_le_ratio C hA Ξ± z hz + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CertificateMagnitude.lean b/LeanPool/BeyondBethe/BeyondBethe/CertificateMagnitude.lean new file mode 100644 index 0000000000..31ce27c716 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CertificateMagnitude.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import Mathlib.Tactic + +/-! # Certificate Magnitude -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open Complexity + +/-! +# A polynomial magnitude bound for the final certificate logarithm + +The rational exponential routine necessarily has running time proportional to +the bit length of its answer. This file proves that, on the positive +normalized matrices on which the optimizer is used, the logarithm passed to +that routine has polynomial numerical magnitude. The proof avoids inspecting +the optimizer's rational arithmetic: the certified permanent sandwich and the +elementary input-size bounds on the permanent already give both sides. +-/ + +/-- The certificate magnitude budget `n * (entryBitBound + n + 1)` for a rational matrix. -/ +def explicitCertificateMagnitudeBudget {n : β„•} + (B : Matrix (Fin n) (Fin n) β„š) : β„• := + n * (rationalMatrixEntryBitBound B + n + 1) + +/-- The sum of the encoded bit lengths of the rational entries in a list. -/ +def rationalListDataCost (xs : List β„š) : β„• := + (xs.map fun q ↦ encodedBitLength β„š q).sum + +/-- The total encoded bit length of all rational entries in a list of rows. -/ +def rationalRowsDataCost (rows : List (List β„š)) : β„• := + (rows.map rationalListDataCost).sum + +theorem rational_encodedBitLength_le_entryCode (q : β„š) : + encodedBitLength β„š q ≀ 12 + 8 * (rationalEntryBinaryCode q).length := by + have h := rational_encodedBitLength_le q + have hnum := integerNatAbs_size_le_binaryCode_length q.num + have hnumCode : (integerBinaryCode q.num).length ≀ + (rationalEntryBinaryCode q).length := by + rw [rationalEntryBinaryCode, pair_length] + omega + have hden : q.den.size ≀ (rationalEntryBinaryCode q).length := by + rw [rationalEntryBinaryCode, pair_length, Nat.size_eq_bits_len] + omega + omega + +theorem rationalListDataCost_le (xs : List β„š) : + rationalListDataCost xs ≀ + 12 * xs.length + 8 * (binaryListCode rationalEntryBinaryCode xs).length := by + induction xs with + | nil => simp [rationalListDataCost, binaryListCode] + | cons q qs ih => + rw [rationalListDataCost, List.map_cons, List.sum_cons, + List.length_cons, binaryListCode, pair_length] + have hq := rational_encodedBitLength_le_entryCode q + have ih' : (qs.map fun q ↦ encodedBitLength β„š q).sum ≀ + 12 * qs.length + + 8 * (binaryListCode rationalEntryBinaryCode qs).length := by + simpa only [rationalListDataCost] using ih + omega + +theorem rationalRowsDataCost_le (rows : List (List β„š)) : + rationalRowsDataCost rows ≀ + 12 * (rows.map List.length).sum + + 8 * (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + induction rows with + | nil => simp [rationalRowsDataCost, binaryListCode] + | cons row rows ih => + rw [rationalRowsDataCost, List.map_cons, List.sum_cons, + binaryListCode, pair_length] + simp only [List.map_cons, List.sum_cons] + have hrow := rationalListDataCost_le row + have ih' : (rows.map rationalListDataCost).sum ≀ + 12 * (rows.map List.length).sum + + 8 * (binaryListCode + (binaryListCode rationalEntryBinaryCode) rows).length := by + simpa only [rationalRowsDataCost] using ih + omega + +theorem rationalRowsEntryCount_le_codeLength (rows : List (List β„š)) : + (rows.map List.length).sum ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + induction rows with + | nil => simp [binaryListCode] + | cons row rows ih => + rw [List.map_cons, List.sum_cons, binaryListCode, pair_length] + have hrow := list_length_le_binaryListCode_length + rationalEntryBinaryCode row + omega + +theorem rationalMatrixEntryBitBound_le_machineCode + {n : β„•} (hn : 1 ≀ n) (B : Matrix (Fin n) (Fin n) β„š) : + rationalMatrixEntryBitBound B ≀ + 32 * (rationalMatrixBinaryEncoding.encode ⟨n, B⟩).length := by + let rows := rationalMatrixRows B + let rowsCode := binaryListCode + (binaryListCode rationalEntryBinaryCode) rows + let word := rationalMatrixBinaryEncoding.encode ⟨n, B⟩ + have hrowsCode : rowsCode.length ≀ word.length := by + change rowsCode.length ≀ (pair n.bits rowsCode).length + simpa using machinePairSecond_length_le (pair n.bits rowsCode) + have hcount : n ^ 2 = (rows.map List.length).sum := by + simp only [rows, rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply, List.length_ofFn] + simp + ring + have hnSq : n ^ 2 ≀ word.length := by + rw [hcount] + exact (rationalRowsEntryCount_le_codeLength rows).trans hrowsCode + have hcost : + (βˆ‘ i, βˆ‘ j, encodedBitLength β„š (B i j)) = rationalRowsDataCost rows := by + simp only [rationalRowsDataCost, rationalListDataCost, rows, + rationalMatrixRows, List.map_ofFn, List.sum_ofFn, Function.comp_apply] + have hdata := rationalRowsDataCost_le rows + rw [← hcost, ← hcount] at hdata + have hwordPos : 1 ≀ word.length := hn.trans (matrix_dimension_le_code_length B) + rw [rationalMatrixEntryBitBound] + nlinarith + +theorem positive_normalized_log_permanent_bounds + {n : β„•} (hn : 1 ≀ n) + (B : Matrix (Fin n) (Fin n) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + -(n * rationalMatrixEntryBitBound B : ℝ) ≀ + Real.log (Matrix.permanent (fun i j ↦ (B i j : ℝ))) ∧ + Real.log (Matrix.permanent (fun i j ↦ (B i j : ℝ))) ≀ + (n : ℝ) ^ 2 := by + classical + let Br : Matrix (Fin n) (Fin n) ℝ := fun i j ↦ (B i j : ℝ) + let J : Matrix (Fin n) (Fin n) ℝ := fun _ _ ↦ 1 + let L := rationalMatrixEntryBitBound B + let d : β„š := (1 / 2 : β„š) ^ L + have hBrpos : Matrix.Positive Br := by + intro i j + exact Rat.cast_pos.mpr (hBpos i j) + have hBr0 : Matrix.Nonnegative Br := fun i j ↦ (hBrpos i j).le + have hperpos : 0 < Matrix.permanent Br := + permanent_pos_of_positive Br hBrpos + have hdQ : 0 < d := by positivity + have hdR : 0 < (d : ℝ) := Rat.cast_pos.mpr hdQ + have hmin : βˆ€ i j, (d : ℝ) ≀ Br i j := by + intro i j + have hq := (matrix_dyadic_bitBound_lt_entry hBpos i j).le + have hr : (((1 / 2 : β„š) ^ rationalMatrixEntryBitBound B : β„š) : ℝ) ≀ + (B i j : ℝ) := by exact_mod_cast hq + simpa only [d, L, Br] using hr + have hlowerPermanent : (d : ℝ) ^ n ≀ Matrix.permanent Br := by + simpa using + (Matrix.pow_card_le_permanent_of_hasPerfectMatching Br hdR.le hBr0 + (fun i j _ ↦ hmin i j) (positiveMatrix_hasPerfectMatching hBrpos)) + have hlogLower := Real.log_le_log (pow_pos hdR n) hlowerPermanent + have hlogTwoUpper : Real.log 2 ≀ (1 : ℝ) := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h ⊒ + exact h + have hscaleNonneg : 0 ≀ (n : ℝ) * L := by positivity + have hscaledLog : (n : ℝ) * L * Real.log 2 ≀ (n : ℝ) * L := by + simpa using mul_le_mul_of_nonneg_left hlogTwoUpper hscaleNonneg + have hlower : -(n * L : ℝ) ≀ Real.log (Matrix.permanent Br) := by + rw [Real.log_pow] at hlogLower + have hlogHalf : Real.log (1 / 2 : ℝ) = -Real.log 2 := by + rw [Real.log_div (by norm_num : (1 : ℝ) β‰  0) + (by norm_num : (2 : ℝ) β‰  0)] + norm_num + have hdcast : (d : ℝ) = (1 / 2 : ℝ) ^ L := by + norm_num [d] + rw [hdcast, Real.log_pow] at hlogLower + rw [hlogHalf] at hlogLower + push_cast + nlinarith + have hBJ : βˆ€ i j, Br i j ≀ J i j := by + intro i j + have hr : (B i j : ℝ) ≀ 1 := by exact_mod_cast hBupper i j + simpa only [Br, J] using hr + have hperJ : Matrix.permanent J = (Nat.factorial n : ℝ) := by + simp [J, Matrix.permanent, Fintype.card_perm] + have hupperPermanent : Matrix.permanent Br ≀ (n : ℝ) ^ n := by + calc + Matrix.permanent Br ≀ Matrix.permanent J := + Matrix.permanent_mono_real hBr0 hBJ + _ = (Nat.factorial n : ℝ) := hperJ + _ ≀ ((n ^ n : β„•) : ℝ) := by exact_mod_cast Nat.factorial_le_pow n + _ = (n : ℝ) ^ n := by norm_num + have hnR : 0 < (n : ℝ) := by exact_mod_cast hn + have hpowpos : 0 < (n : ℝ) ^ n := pow_pos hnR n + have hlogUpper := Real.log_le_log hperpos hupperPermanent + rw [Real.log_pow] at hlogUpper + have hlogn : Real.log (n : ℝ) ≀ n := by + have h := Real.log_le_sub_one_of_pos hnR + linarith + have hnnonneg : 0 ≀ (n : ℝ) := hnR.le + have hscaledN := mul_le_mul_of_nonneg_left hlogn hnnonneg + have hupper : Real.log (Matrix.permanent Br) ≀ (n : ℝ) ^ 2 := by + nlinarith + simpa only [Br, L] using And.intro hlower hupper + +theorem preSmoothingBase_explicit_le_exp_one : + preSmoothingBase (explicitCertifiedEpsilon : ℝ) ≀ Real.exp 1 := by + have hΞ΅ : 0 ≀ (explicitCertifiedEpsilon : ℝ) := by + exact_mod_cast explicitCertifiedEpsilon_pos.le + have hexpNonpos : Real.exp + (-(explicitCertifiedEpsilon : ℝ) + + (explicitCertifiedEpsilon : ℝ) / 4) ≀ 1 := by + rw [← Real.exp_zero] + exact Real.exp_le_exp.mpr (by linarith) + have hsqrt : Real.sqrt 2 ≀ (2 : ℝ) := by + rw [Real.sqrt_le_left (by norm_num : (0 : ℝ) ≀ 2)] + norm_num + have hbaseTwo : preSmoothingBase (explicitCertifiedEpsilon : ℝ) ≀ 2 := by + rw [preSmoothingBase] + calc + Real.sqrt 2 * Real.exp + (-(explicitCertifiedEpsilon : ℝ) + + (explicitCertifiedEpsilon : ℝ) / 4) ≀ + Real.sqrt 2 * 1 := + mul_le_mul_of_nonneg_left hexpNonpos (Real.sqrt_nonneg 2) + _ ≀ 2 := by simpa using hsqrt + have htwoExp : (2 : ℝ) ≀ Real.exp 1 := by + have h := Real.add_one_le_exp (1 : ℝ) + norm_num at h ⊒ + exact h + exact hbaseTwo.trans htwoExp + +theorem explicitExpEvaluationLoss_le_one : + (explicitExpEvaluationLoss : ℝ) ≀ 1 := by + have hq : explicitExpEvaluationLoss ≀ (1 : β„š) := by + rw [explicitExpEvaluationLoss, explicitCertifiedEpsilon, + explicitCertifiedEpsilon_eq] + norm_num [explicitXi, explicitDelta, explicitEta, explicitRowRatio] + exact_mod_cast hq + +/-- The magnitude argument depends only on the certified matrix and KKT +relations, not on how the optimizer breaks ties. This form is used by the +row-major executable optimizer. -/ +theorem certificateLog_abs_le_of_feasibleApproximateKKT + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (X : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (R C : Fin (m + 2) β†’ β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) + (hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ))) + (hXpos : βˆ€ i j, 0 < (X i j : ℝ)) + (happrox : HasApproximateLogKKT (explicitKKTError : ℝ) + (explicitRegularizationScale (m + 2) : ℝ) + (fun i j ↦ (B i j : ℝ)) + (fun i j ↦ ((X i j : β„š) : ℝ)) + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ))) : + abs ((explicitDirectedCertificateLog X R C : β„š) : ℝ) ≀ + explicitCertificateMagnitudeBudget B := by + let n := m + 2 + let qlog : ℝ := (explicitDirectedCertificateLog X R C : β„š) + let qvalue : ℝ := (explicitDirectedCertificateValue X R C : β„š) + let P : ℝ := Matrix.permanent (fun i j ↦ (B i j : ℝ)) + change abs qlog ≀ explicitCertificateMagnitudeBudget B + have hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ)) := by + intro i + refine ⟨hX.row_probability i, fun j ↦ ⟨hXpos i j, ?_⟩⟩ + exact hX.entry_lt_one_of_positive hXpos (by simp) i j + have hBR : Matrix.Positive (fun i j ↦ (B i j : ℝ)) := fun i j ↦ + Rat.cast_pos.mpr (hBpos i j) + have hcert := explicitDirectedCertificate_twoSided + anariOveisGharanStableCoefficient (n := m + 2) (by omega) + hBR hX hXint happrox + have hlossQ : 0 < explicitExpEvaluationLoss * (m + 2) := + mul_pos explicitExpEvaluationLoss_pos (by positivity) + have hexp := rationalExpLower_bounds + (s := explicitDirectedCertificateLog X R C) hlossQ + have hexp' : Real.exp + (qlog - (explicitExpEvaluationLoss : ℝ) * n) ≀ qvalue ∧ + qvalue ≀ Real.exp qlog := by + have hdim : m + 1 + 1 = m + 2 := by omega + simpa [qlog, qvalue, n, explicitDirectedCertificateValue, hdim] using hexp + have hperbounds := positive_normalized_log_permanent_bounds + (n := m + 2) (by omega) B hBpos hBupper + have hPpos : 0 < P := permanent_pos_of_positive _ hBR + have hqvaluePos : 0 < qvalue := by + simpa only [qvalue] using explicitDirectedCertificateValue_pos + (n := m + 2) (by omega) X R C + have hqUpperLog : qlog - (explicitExpEvaluationLoss : ℝ) * n ≀ + Real.log P := by + have h := Real.log_le_log (Real.exp_pos _) + (hexp'.1.trans (by simpa only [qvalue, P] using hcert.1)) + simpa using h + have hlossScaled : (explicitExpEvaluationLoss : ℝ) * n ≀ n := by + exact mul_le_of_le_one_left (by positivity) explicitExpEvaluationLoss_le_one + have hqUpper : qlog ≀ (n : ℝ) ^ 2 + n := by + have hp := hperbounds.2 + simp only [P, n] at hqUpperLog hp hlossScaled ⊒ + linarith + have hbasePow : + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n ≀ + Real.exp (n : ℝ) := by + calc + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n ≀ + (Real.exp 1) ^ n := + pow_le_pow_leftβ‚€ (preSmoothingBase_pos _).le + preSmoothingBase_explicit_le_exp_one n + _ = Real.exp (n : ℝ) := by rw [← Real.exp_nat_mul]; norm_num + have hPExp : P ≀ Real.exp ((n : ℝ) + qlog) := by + calc + P ≀ (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n * qvalue := by + simpa only [P, qvalue] using hcert.2 + _ ≀ Real.exp (n : ℝ) * Real.exp qlog := + mul_le_mul hbasePow hexp'.2 hqvaluePos.le (Real.exp_pos _).le + _ = Real.exp ((n : ℝ) + qlog) := by rw [Real.exp_add] + have hqLowerLog : Real.log P ≀ (n : ℝ) + qlog := by + have h := Real.log_le_log hPpos hPExp + simpa using h + have hqLower : -((n : ℝ) * rationalMatrixEntryBitBound B + n) ≀ qlog := by + have hp := hperbounds.1 + simp only [P, n] at hqLowerLog hp ⊒ + linarith + have hbudget : (n : ℝ) * rationalMatrixEntryBitBound B + n ≀ + (explicitCertificateMagnitudeBudget B : β„•) := by + simp only [explicitCertificateMagnitudeBudget, n] + push_cast + nlinarith + have hupperBudget : (n : ℝ) ^ 2 + n ≀ + (explicitCertificateMagnitudeBudget B : β„•) := by + have hL : 1 ≀ rationalMatrixEntryBitBound B := by + rw [rationalMatrixEntryBitBound] + omega + simp only [explicitCertificateMagnitudeBudget, n] + push_cast + nlinarith + rw [abs_le] + exact ⟨(neg_le_neg hbudget).trans hqLower, + hqUpper.trans hupperBudget⟩ + +theorem explicitOptimizerCertificateLog_abs_le + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + abs ((explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) : β„š) : ℝ) ≀ + explicitCertificateMagnitudeBudget B := by + let n := m + 2 + let X := explicitBetheOptimizerMatrix (m := m + 1) B + let R := explicitBetheOptimizerRowPotential (m := m + 1) B + let C := explicitBetheOptimizerColumnPotential (m := m + 1) B + let qlog : ℝ := (explicitDirectedCertificateLog X R C : β„š) + let qvalue : ℝ := (explicitDirectedCertificateValue X R C : β„š) + let P : ℝ := Matrix.permanent (fun i j ↦ (B i j : ℝ)) + change abs qlog ≀ explicitCertificateMagnitudeBudget B + have hpoint := explicitBetheOptimizerPoint_spec (m := m + 1) + (by omega) B hBpos hBupper + have hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ)) := by + simpa only [X] using hpoint.2.1 + have hXlo : βˆ€ i j, (explicitOptimizerFloor B : ℝ) ≀ (X i j : ℝ) := by + simpa only [X] using hpoint.2.2.1 + have hfloor : 0 < (explicitOptimizerFloor B : ℝ) := + Rat.cast_pos.mpr (explicitOptimizerFloor_pos B) + have hXpos : βˆ€ i j, 0 < (X i j : ℝ) := fun i j ↦ + hfloor.trans_le (hXlo i j) + have hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ)) := by + intro i + refine ⟨hX.row_probability i, fun j ↦ ⟨hXpos i j, ?_⟩⟩ + exact hX.entry_lt_one_of_positive hXpos (by simp) i j + have happrox := explicitBetheOptimizer_hasApproximateLogKKT + (m := m + 1) (by omega) B hBpos hBupper + have hBR : Matrix.Positive (fun i j ↦ (B i j : ℝ)) := fun i j ↦ + Rat.cast_pos.mpr (hBpos i j) + have hcert := explicitDirectedCertificate_twoSided + anariOveisGharanStableCoefficient (n := m + 2) (by omega) + hBR hX hXint (by simpa only [X, R, C] using happrox) + have hlossQ : 0 < explicitExpEvaluationLoss * (m + 2) := + mul_pos explicitExpEvaluationLoss_pos (by positivity) + have hexp := rationalExpLower_bounds + (s := explicitDirectedCertificateLog X R C) hlossQ + have hexp' : Real.exp + (qlog - (explicitExpEvaluationLoss : ℝ) * n) ≀ qvalue ∧ + qvalue ≀ Real.exp qlog := by + have hdim : m + 1 + 1 = m + 2 := by omega + simpa [qlog, qvalue, n, explicitDirectedCertificateValue, hdim] using hexp + have hperbounds := positive_normalized_log_permanent_bounds + (n := m + 2) (by omega) B hBpos hBupper + have hPpos : 0 < P := permanent_pos_of_positive _ hBR + have hqvaluePos : 0 < qvalue := by + simpa only [qvalue, R, C] using explicitDirectedCertificateValue_pos + (n := m + 2) (by omega) X R C + have hqUpperLog : qlog - (explicitExpEvaluationLoss : ℝ) * n ≀ + Real.log P := by + have h := Real.log_le_log (Real.exp_pos _) + (hexp'.1.trans (by simpa only [qvalue, P] using hcert.1)) + simpa using h + have hlossScaled : (explicitExpEvaluationLoss : ℝ) * n ≀ n := by + exact mul_le_of_le_one_left (by positivity) explicitExpEvaluationLoss_le_one + have hqUpper : qlog ≀ (n : ℝ) ^ 2 + n := by + have hp := hperbounds.2 + simp only [P, n] at hqUpperLog hp hlossScaled ⊒ + linarith + have hbasePow : + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n ≀ + Real.exp (n : ℝ) := by + calc + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n ≀ + (Real.exp 1) ^ n := + pow_le_pow_leftβ‚€ (preSmoothingBase_pos _).le + preSmoothingBase_explicit_le_exp_one n + _ = Real.exp (n : ℝ) := by rw [← Real.exp_nat_mul]; norm_num + have hPExp : P ≀ Real.exp ((n : ℝ) + qlog) := by + calc + P ≀ (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n * qvalue := by + simpa only [P, qvalue] using hcert.2 + _ ≀ Real.exp (n : ℝ) * Real.exp qlog := + mul_le_mul hbasePow hexp'.2 hqvaluePos.le (Real.exp_pos _).le + _ = Real.exp ((n : ℝ) + qlog) := by rw [Real.exp_add] + have hqLowerLog : Real.log P ≀ (n : ℝ) + qlog := by + have h := Real.log_le_log hPpos hPExp + simpa using h + have hqLower : -((n : ℝ) * rationalMatrixEntryBitBound B + n) ≀ qlog := by + have hp := hperbounds.1 + simp only [P, n] at hqLowerLog hp ⊒ + linarith + have hbudget : (n : ℝ) * rationalMatrixEntryBitBound B + n ≀ + (explicitCertificateMagnitudeBudget B : β„•) := by + simp only [explicitCertificateMagnitudeBudget, n] + push_cast + nlinarith + have hupperBudget : (n : ℝ) ^ 2 + n ≀ + (explicitCertificateMagnitudeBudget B : β„•) := by + have hL : 1 ≀ rationalMatrixEntryBitBound B := by + rw [rationalMatrixEntryBitBound] + omega + simp only [explicitCertificateMagnitudeBudget, n] + push_cast + nlinarith + rw [abs_le] + constructor + Β· exact (neg_le_neg hbudget).trans hqLower + Β· exact hqUpper.trans hupperBudget + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CertifiedPairWeights.lean b/LeanPool/BeyondBethe/BeyondBethe/CertifiedPairWeights.lean new file mode 100644 index 0000000000..b0cb27797d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CertifiedPairWeights.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DirectedPairCost +public import LeanPool.BeyondBethe.BeyondBethe.GreedyRowMatching +public import Mathlib.Tactic + +/-! # Certified Pair Weights -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Executable constant-gain row-pair certificates + +A row pair is retained when some two distinct columns pass the directed +four-core-cost test. Every retained pair receives the same rational gain. +This avoids both numerical pair-capacity optimization and numerical +maximum-weight matching. +-/ + +/-- Finite, decidable eligibility test for a row pair. -/ +def HasCertifiedCorePair {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ : β„š) (p : β„•) (q : RowPair n) : Prop := + βˆƒ a b : Fin n, a β‰  b ∧ + directedFourCoreCostUpper Ο„ X + (rowPairRow q 0) (rowPairRow q 1) a b p ≀ ΞΊ + +instance {n : β„•} (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ : β„š) (p : β„•) (q : RowPair n) : + Decidable (HasCertifiedCorePair Ο„ X ΞΊ p q) := by + unfold HasCertifiedCorePair + infer_instance + +/-- The executable row-pair weight: either the fixed certified gain or zero. -/ +def certifiedConstantRowWeight {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ Ξ³ : β„š) (p : β„•) (q : RowPair n) : β„š := + if HasCertifiedCorePair Ο„ X ΞΊ p q then Ξ³ else 0 + +theorem certifiedConstantRowWeight_nonneg {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ Ξ³ : β„š) (p : β„•) (q : RowPair n) (hΞ³ : 0 ≀ Ξ³) : + 0 ≀ certifiedConstantRowWeight Ο„ X ΞΊ Ξ³ p q := by + rw [certifiedConstantRowWeight] + split_ifs + Β· exact hΞ³ + Β· exact le_rfl + +theorem certifiedConstantRowWeight_eq_gamma_iff {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ Ξ³ : β„š) (p : β„•) (q : RowPair n) (hΞ³ : Ξ³ β‰  0) : + certifiedConstantRowWeight Ο„ X ΞΊ Ξ³ p q = Ξ³ ↔ + HasCertifiedCorePair Ο„ X ΞΊ p q := by + by_cases h : HasCertifiedCorePair Ο„ X ΞΊ p q + Β· simp [certifiedConstantRowWeight, h] + Β· rw [certifiedConstantRowWeight, ite_eq_right h] + exact iff_of_false (fun he ↦ hΞ³ he.symm) h + +theorem certifiedConstantRowWeight_eq_gamma_of_threshold {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (ΞΊ Ξ³ : β„š) (p : β„•) (q : RowPair n) (hΞ³ : 0 < Ξ³) + (hthreshold : Ξ³ ≀ certifiedConstantRowWeight Ο„ X ΞΊ Ξ³ p q) : + certifiedConstantRowWeight Ο„ X ΞΊ Ξ³ p q = Ξ³ := by + by_cases h : HasCertifiedCorePair Ο„ X ΞΊ p q + Β· simp [certifiedConstantRowWeight, h] + Β· simp [certifiedConstantRowWeight, h] at hthreshold + linarith + +/-- Passing the rational test proves the fixed weight is a lower bound on the +true logarithmic pair gain for an exact KKT matrix. -/ +theorem certifiedConstantRowWeight_le_log_pairGain + {n : β„•} {ΞΊ ΞΎβ‚€ Ξ³ ell ΞΎ : ℝ} {Ο„ : β„š} + (hgain : CleanPairGainGuarantee ΞΊ ΞΎβ‚€ Ξ³) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) + (hΟ„scale : (Ο„ : ℝ) = ΞΎ / (4 * ell)) + {A : Matrix (Fin n) (Fin n) ℝ} + {X : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Positive A) + (hXds : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + {R C : Fin n β†’ ℝ} + (hKKT : HasLogKKT (Ο„ : ℝ) A + (fun i j ↦ ((X i j : β„š) : ℝ)) R C) + {ΞΊq Ξ³q : β„š} (hΞΊ : (ΞΊq : ℝ) ≀ ΞΊ) (hΞ³q : (Ξ³q : ℝ) ≀ Ξ³) + (p : β„•) (q : RowPair n) + (heligible : HasCertifiedCorePair Ο„ X ΞΊq p q) : + (Ξ³q : ℝ) ≀ Real.log (pairGain A + (fun i j ↦ ((X i j : β„š) : ℝ)) + (rowPairRow q 0) (rowPairRow q 1)) := by + obtain ⟨a, b, hab, hcostQ⟩ := heligible + have hΟ„lower : (-1 : β„š) ≀ Ο„ := by + have hΟ„pos : (0 : ℝ) < (Ο„ : ℝ) := by rw [hΟ„scale]; positivity + have hΟ„posQ : (0 : β„š) < Ο„ := by exact_mod_cast hΟ„pos + linarith + have hcostUpper := fourCoreTransferCost_le_directedFourCoreCostUpper + hΟ„lower hXint (rowPairRow q 0) (rowPairRow q 1) a b p + have hcostCast : + (directedFourCoreCostUpper Ο„ X + (rowPairRow q 0) (rowPairRow q 1) a b p : ℝ) ≀ (ΞΊq : ℝ) := by + exact_mod_cast hcostQ + have hcost : fourCoreTransferCost (Ο„ : ℝ) + (fun i j ↦ ((X i j : β„š) : ℝ)) + (rowPairRow q 0) (rowPairRow q 1) a b ≀ ΞΊ := + hcostUpper.trans (hcostCast.trans hΞΊ) + let rscale : Fin n β†’ ℝ := fun i ↦ Real.exp (R i) + let cscale : Fin n β†’ ℝ := fun j ↦ Real.exp (C j) + have hmult : HasMultiplicativeKKT (Ο„ : ℝ) A + (fun i j ↦ ((X i j : β„š) : ℝ)) rscale cscale := + hasMultiplicativeKKT_of_logKKT hA hXint hKKT + exact hΞ³q.trans (hgain hell hlogn hΞΎ hΞΎβ‚€ hΟ„scale hA hXds hXint + (fun i ↦ Real.exp_pos _) (fun j ↦ Real.exp_pos _) hmult + (rowPairRow_ne q) hab hcost) + +/-- A true clean pair whose cost has the stated numerical margin passes the +directed test and therefore receives the fixed gain. -/ +theorem successfulCleanCycle_certifiedConstantRowWeight + {n : β„•} {ΞΊstruct Ξ· : ℝ} {Ο„ ΞΊgain Ξ³ : β„š} + {P : Matrix (Fin n) (Fin n) ℝ} + {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (p : β„•) + (hmargin : 4 * (n + 3 : ℝ) * ((1 / 2 : β„š) ^ p : β„š) ≀ + (ΞΊgain : ℝ) - ΞΊstruct) + (f g : Equiv.Perm (Fin n)) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) + (hc : c ∈ successfulCleanCycles ΞΊstruct (Ο„ : ℝ) Ξ· P + (fun i j ↦ ((X i j : β„š) : ℝ)) f g) : + certifiedConstantRowWeight Ο„ X ΞΊgain Ξ³ p (cleanCycleRowPair c) = Ξ³ := by + have hcost : fourCoreTransferCost (Ο„ : ℝ) + (fun i j ↦ ((X i j : β„š) : ℝ)) + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) ≀ ΞΊstruct := by + have hnot : Β¬ ΞΊstruct < fourCoreTransferCost (Ο„ : ℝ) + (fun i j ↦ ((X i j : β„š) : ℝ)) + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := by + simpa [successfulCleanCycles, failedCleanCycles] using hc + exact le_of_not_gt hnot + have hu := directedFourCoreCostUpper_le_add_error hΟ„0 hΟ„1 hXint + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) p + have huΞΊ : (directedFourCoreCostUpper Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) p : ℝ) ≀ + (ΞΊgain : ℝ) := by linarith + have huΞΊq : directedFourCoreCostUpper Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) p ≀ ΞΊgain := by + exact_mod_cast huΞΊ + have hcols := cleanCycle_core_columns c + rw [certifiedConstantRowWeight] + split_ifs with h + Β· rfl + Β· exfalso + apply h + refine ⟨f (cleanCycleRow c 0), g (cleanCycleRow c 0), hcols.2.1, ?_⟩ + simpa only [rowPairRow_cleanCycleRowPair] using huΞΊq + +/-- The disjoint successful clean cycles force a large executable greedy +gain once the directed cost test has enough precision. -/ +theorem greedyCertifiedMatchingGain_ge_successful_of_costMargin + {n : β„•} {ΞΊstruct Ξ· : ℝ} {Ο„ ΞΊgain Ξ³ : β„š} + {P : Matrix (Fin n) (Fin n) ℝ} + {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (p : β„•) (hΞ³ : 0 ≀ Ξ³) + (hmargin : 4 * (n + 3 : ℝ) * ((1 / 2 : β„š) ^ p : β„š) ≀ + (ΞΊgain : ℝ) - ΞΊstruct) + (f g : Equiv.Perm (Fin n)) : + (((successfulCleanCycles ΞΊstruct (Ο„ : ℝ) Ξ· P + (fun i j ↦ ((X i j : β„š) : ℝ)) f g).card : ℝ) * (Ξ³ : ℝ)) / 2 ≀ + (greedyCertifiedMatchingGain + (certifiedConstantRowWeight Ο„ X ΞΊgain Ξ³ p) Ξ³ : ℝ) := by + exact greedyCertifiedMatchingGain_ge_successfulCleanCycles f g + (certifiedConstantRowWeight Ο„ X ΞΊgain Ξ³ p) hΞ³ + (fun c hc ↦ le_of_eq (successfulCleanCycle_certifiedConstantRowWeight + hΟ„0 hΟ„1 hXint p hmargin f g c hc).symm) + +/-- Full near-case conclusion for the executable threshold-greedy +certificate. The structural threshold `ΞΊstruct` is allowed to be smaller +than the certified gain threshold `ΞΊgain`; their difference is exactly the +directed-evaluation margin. -/ +theorem nearCase_greedyCertifiedMatchingGain_ge_threeSixteenths + (hrowInequality : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) + {ΞΊstruct ell ΞΎ Ξ· Ξ΄ : ℝ} {Ο„ ΞΊgain Ξ³ : β„š} + (hΞΊstruct : 0 < ΞΊstruct) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΟ„scale : (Ο„ : ℝ) = ΞΎ / (4 * ell)) + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) (hΞ³ : 0 ≀ Ξ³) + (hΞ· : 0 < Ξ·) (hΞ·tenth : Ξ· ≀ 1 / 10) + (hrowSmall : Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128) + (hcycleSmall : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) ≀ 1 / 16) + (htransferSmall : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊstruct)) + {A : Matrix (Fin n) (Fin n) ℝ} + {X : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + {R C : Fin n β†’ ℝ} + (hKKT : HasLogKKT (Ο„ : ℝ) A + (fun i j ↦ ((X i j : β„š) : ℝ)) R C) + (hnear : betheSlack n (betheLogValue A) + (Real.log (Matrix.permanent A)) < Ξ΄ * n) + (p : β„•) + (hmargin : 4 * (n + 3 : ℝ) * ((1 / 2 : β„š) ^ p : β„š) ≀ + (ΞΊgain : ℝ) - ΞΊstruct) : + 3 * (Ξ³ : ℝ) / 16 * n ≀ + (greedyCertifiedMatchingGain + (certifiedConstantRowWeight Ο„ X ΞΊgain Ξ³ p) Ξ³ : ℝ) := by + obtain ⟨f, g, hsuccess⟩ := + nearCase_successfulCleanCycles_count_ge_threeEighths hrowInequality hn + hΞΊstruct hell hlogn hΞΎ hΟ„scale hΞ· hΞ·tenth hrowSmall hcycleSmall + htransferSmall hA hX hXint hKKT hnear + have hgreedy := greedyCertifiedMatchingGain_ge_successful_of_costMargin + (P := assignmentMarginal A) (Ξ· := Ξ·) + hΟ„0 hΟ„1 hXint p hΞ³ hmargin f g + have hΞ³R : (0 : ℝ) ≀ (Ξ³ : ℝ) := by exact_mod_cast hΞ³ + have hscaled := mul_le_mul_of_nonneg_right hsuccess hΞ³R + calc + 3 * (Ξ³ : ℝ) / 16 * n = ((3 * (n : ℝ) / 8) * (Ξ³ : ℝ)) / 2 := by ring + _ ≀ (((successfulCleanCycles ΞΊstruct (Ο„ : ℝ) Ξ· + (assignmentMarginal A) (fun i j ↦ ((X i j : β„š) : ℝ)) f g).card : ℝ) * + (Ξ³ : ℝ)) / 2 := by linarith + _ ≀ _ := hgreedy + +/-- The matching test uses the same fixed precision as the final certificate +evaluation. The generous additive constant keeps the executable matcher and +its analytic correctness theorem literally aligned. -/ +def directedPairCostPrecision (n : β„•) : β„• := n + 400 + +theorem n_add_three_le_four_mul_two_pow (n : β„•) : + n + 3 ≀ 4 * 2 ^ n := by + induction n with + | zero => norm_num + | succ n ih => + calc + n + 1 + 3 ≀ 2 * (n + 3) := by omega + _ ≀ 2 * (4 * 2 ^ n) := Nat.mul_le_mul_left 2 ih + _ = 4 * 2 ^ (n + 1) := by rw [pow_succ]; ring + +theorem directedPairCostPrecision_error_le (n : β„•) : + 4 * (n + 3 : ℝ) * + ((1 / 2 : β„š) ^ directedPairCostPrecision n : β„š) ≀ + (((1 / 10000 : β„š) : β„š) : ℝ) := by + have hn : (n + 3 : ℝ) ≀ 4 * (2 : ℝ) ^ n := by + exact_mod_cast n_add_three_le_four_mul_two_pow n + rw [directedPairCostPrecision, show n + 400 = n + 400 by rfl, pow_add] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] + have hpowpos : 0 < (2 : ℝ) ^ n := by positivity + calc + 4 * (n + 3 : ℝ) * ((1 / 2 : ℝ) ^ n * (1 / 2 : ℝ) ^ 400) ≀ + 4 * (n + 3 : ℝ) * + ((1 / 2 : ℝ) ^ n * (1 / 1048576 : ℝ)) := by + gcongr + exact (pow_le_pow_of_le_one (by norm_num : (0 : ℝ) ≀ 1 / 2) + (by norm_num : (1 / 2 : ℝ) ≀ 1) (show 20 ≀ 400 by omega)).trans_eq + (by norm_num) + _ ≀ + 4 * (4 * (2 : ℝ) ^ n) * + ((1 / 2 : ℝ) ^ n * (1 / 1048576 : ℝ)) := by gcongr + _ = 1 / 65536 := by + have hcancel : (2 : ℝ) ^ n * (1 / 2 : ℝ) ^ n = 1 := by + rw [← mul_pow] + norm_num + calc + 4 * (4 * (2 : ℝ) ^ n) * + ((1 / 2 : ℝ) ^ n * (1 / 1048576 : ℝ)) = + (16 / 1048576 : ℝ) * + ((2 : ℝ) ^ n * (1 / 2 : ℝ) ^ n) := by ring + _ = 16 / 1048576 := by rw [hcancel, mul_one] + _ = 1 / 65536 := by norm_num + _ ≀ 1 / 10000 := by norm_num + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CleanConstants.lean b/LeanPool/BeyondBethe/BeyondBethe/CleanConstants.lean new file mode 100644 index 0000000000..c39512dc09 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CleanConstants.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CleanGain +public import Mathlib.Tactic + +/-! # Clean Constants -/ + +@[expose] public section + +open scoped BigOperators Topology + +namespace BeyondBethe + +/-- The first line of paper (61), with `negMulLog` encoding the convention +`0 log 0 = 0`. -/ +noncomputable def cleanCoreFunction (ΞΊ ρ : ℝ) : ℝ := + (1 - ρ) * Real.log ((2 * (Real.exp (-ΞΊ)) ^ 2) / (1 - ρ)) + + ρ * Real.log (Real.exp (-ΞΊ)) - Real.negMulLog ρ - ρ + +/-- Separate the core contribution in (61) from its entropy-regularization +loss. -/ +theorem cleanGainLowerBound_eq_core_sub_entropy + {ΞΉ : Type*} [Fintype ΞΉ] + {ΞΊ Ο„ ρ : ℝ} {Ξ± : ΞΉ β†’ ℝ} : + cleanGainLowerBound ΞΊ Ο„ ρ Ξ± = cleanCoreFunction ΞΊ ρ - + Ο„ * (-(βˆ‘ l, Ξ± l * Real.log (Ξ± l)) + ρ * Real.log 2) := by + rw [cleanGainLowerBound, cleanCoreFunction, Real.negMulLog_def] + ring + +/-- If the core term is above `log 2 / 2` and the entropy bracket is below +`4 ell`, the paper's choice `tau = xi / (4 ell)` loses less than `xi`. -/ +theorem cleanGainLowerBound_gt_of_core_and_entropy + {ΞΉ : Type*} [Fintype ΞΉ] + {ΞΊ Ο„ ρ ΞΎ ell : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hΞΎ : 0 < ΞΎ) (hell : 0 < ell) + (hΟ„ : Ο„ = ΞΎ / (4 * ell)) + (hcore : Real.log 2 / 2 < cleanCoreFunction ΞΊ ρ) + (hentropy : -(βˆ‘ l, Ξ± l * Real.log (Ξ± l)) + ρ * Real.log 2 < + 4 * ell) : + Real.log 2 / 2 - ΞΎ < cleanGainLowerBound ΞΊ Ο„ ρ Ξ± := by + let B := -(βˆ‘ l, Ξ± l * Real.log (Ξ± l)) + ρ * Real.log 2 + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + have hloss : Ο„ * B < ΞΎ := by + calc + Ο„ * B < Ο„ * (4 * ell) := mul_lt_mul_of_pos_left hentropy hΟ„pos + _ = ΞΎ := by rw [hΟ„]; field_simp + rw [cleanGainLowerBound_eq_core_sub_entropy] + dsimp only [B] at hloss + linarith + +/-- The outside entropy in (62) is at most `rho log(n/rho)`. The subtype +cardinality argument is explicit: outside columns inject into all `n` +columns. -/ +theorem outsidePairEntropy_le + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + {r s a b : Fin n} + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) : + -(βˆ‘ l : OutsideColumn a b, + pairAlpha X r s l.1 * Real.log (pairAlpha X r s l.1)) ≀ + outsideMassTwo (pairAlpha X r s) a b * + Real.log (n / outsideMassTwo (pairAlpha X r s) a b) := by + let ρ := outsideMassTwo (pairAlpha X r s) a b + let Ξ±o : OutsideColumn a b β†’ ℝ := fun l ↦ pairAlpha X r s l.1 + have hne : Β¬ IsEmpty (OutsideColumn a b) := by + intro hempty + letI : IsEmpty (OutsideColumn a b) := hempty + have hsum := sum_outsideColumn_eq_outsideMassTwo + (pairAlpha X r s) a b + have hzero : (βˆ‘ l : OutsideColumn a b, pairAlpha X r s l.1) = 0 := by + apply Finset.sum_eq_zero + intro l _ + exact isEmptyElim l + linarith [hsum, hzero] + letI : Nonempty (OutsideColumn a b) := not_isEmpty_iff.mp hne + have hsum : βˆ‘ l, Ξ±o l = ρ := by + dsimp only [Ξ±o, ρ] + exact sum_outsideColumn_eq_outsideMassTwo _ _ _ + have hΞ± : βˆ€ l, 0 ≀ Ξ±o l := fun l ↦ pairAlpha_nonneg hX r s l.1 + have hent := shannonEntropy_of_mass_le hΞ± (show 0 < ρ from hρ) hsum + have hcard : Fintype.card (OutsideColumn a b) ≀ n := by + simpa using Fintype.card_le_of_injective + (fun l : OutsideColumn a b ↦ l.1) Subtype.val_injective + have hcardpos : 0 < (Fintype.card (OutsideColumn a b) : ℝ) := by + exact_mod_cast Fintype.card_pos + have hquot : (Fintype.card (OutsideColumn a b) : ℝ) / ρ ≀ n / ρ := by + apply div_le_div_of_nonneg_right _ hρ.le + exact_mod_cast hcard + have hlog : Real.log ((Fintype.card (OutsideColumn a b) : ℝ) / ρ) ≀ + Real.log (n / ρ) := + Real.log_le_log (div_pos hcardpos hρ) hquot + have hfinal := hent.trans (mul_le_mul_of_nonneg_left hlog hρ.le) + dsimp only [Ξ±o, ρ] at hfinal ⊒ + have heq : + -(βˆ‘ l : OutsideColumn a b, + pairAlpha X r s l.1 * Real.log (pairAlpha X r s l.1)) = + shannonEntropy (fun l : OutsideColumn a b ↦ pairAlpha X r s l.1) := by + rw [shannonEntropy, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro l _ + rw [Real.negMulLog_def] + ring + rw [heq] + exact hfinal + +/-- A deliberately slack version of the entropy estimate below (61). +The elementary bound `negMulLog rho <= 1-rho` is already enough once +`rho < 1/10`; the sharper `1/e` in the paper is not needed here. -/ +theorem outsideEntropyBracket_lt_four_scale + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + {r s a b : Fin n} + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρsmall : outsideMassTwo (pairAlpha X r s) a b < 1 / 10) + {ell : ℝ} (hell : 1 ≀ ell) + (hlogn : Real.log n ≀ ell * Real.log 2) : + -(βˆ‘ l : OutsideColumn a b, + pairAlpha X r s l.1 * Real.log (pairAlpha X r s l.1)) + + outsideMassTwo (pairAlpha X r s) a b * Real.log 2 < + 4 * ell := by + let ρ := outsideMassTwo (pairAlpha X r s) a b + have hent := outsidePairEntropy_le hX hρ + have hnpos : 0 < (n : ℝ) := by + exact_mod_cast (show 0 < n from Fin.pos_iff_nonempty.mpr ⟨r⟩) + have hlogdiv : Real.log ((n : ℝ) / ρ) = + Real.log n - Real.log ρ := Real.log_div hnpos.ne' hρ.ne' + have hnml : Real.negMulLog ρ ≀ 1 - ρ := + Real.negMulLog_le_one_sub_self hρ.le + have hlog2pos : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hlog2lt : Real.log 2 < 1 := by + have h := Real.log_lt_sub_one_of_pos (by norm_num : (0 : ℝ) < 2) + (by norm_num : (2 : ℝ) β‰  1) + norm_num at h ⊒ + exact h + have hrlog : ρ * Real.log 2 < 1 / 10 := by + have h := mul_lt_mul_of_pos_right hρsmall hlog2pos + nlinarith + have hellpos : 0 < ell := lt_of_lt_of_le (by norm_num) hell + have hmain : ρ * (ell * Real.log 2) < ell / 10 := by + have h := mul_lt_mul_of_pos_left hrlog hellpos + nlinarith + have hfirst : + -(βˆ‘ l : OutsideColumn a b, + pairAlpha X r s l.1 * Real.log (pairAlpha X r s l.1)) ≀ + ρ * (ell * Real.log 2) + Real.negMulLog ρ := by + calc + -(βˆ‘ l : OutsideColumn a b, + pairAlpha X r s l.1 * Real.log (pairAlpha X r s l.1)) ≀ + ρ * Real.log ((n : ℝ) / ρ) := hent + _ = ρ * Real.log n + Real.negMulLog ρ := by + rw [hlogdiv, Real.negMulLog_def] + ring + _ ≀ ρ * (ell * Real.log 2) + Real.negMulLog ρ := by + gcongr + dsimp only [ρ] at hfirst hnml hmain hrlog hρ hρsmall ⊒ + linarith + +theorem cleanCoreFunction_continuousAt_zero : + ContinuousAt (fun p : ℝ Γ— ℝ => cleanCoreFunction p.1 p.2) (0, 0) := by + unfold cleanCoreFunction + have hfst : ContinuousAt (fun p : ℝ Γ— ℝ => p.1) (0, 0) := continuousAt_fst + have hsnd : ContinuousAt (fun p : ℝ Γ— ℝ => p.2) (0, 0) := continuousAt_snd + have hden : ContinuousAt (fun p : ℝ Γ— ℝ => 1 - p.2) (0, 0) := + continuousAt_const.sub hsnd + have hexp : ContinuousAt (fun p : ℝ Γ— ℝ => Real.exp (-p.1)) (0, 0) := + Real.continuous_exp.continuousAt.comp_of_eq hfst.neg rfl + have hnum : ContinuousAt + (fun p : ℝ Γ— ℝ => 2 * Real.exp (-p.1) ^ 2) (0, 0) := + continuousAt_const.mul (hexp.pow 2) + have hfrac := hnum.div hden (by norm_num) + have hlogfrac := hfrac.log (by norm_num) + have hlogexp := hexp.log (by norm_num) + have hnml : ContinuousAt (fun p : ℝ Γ— ℝ => Real.negMulLog p.2) (0, 0) := + Real.continuous_negMulLog.continuousAt.comp_of_eq hsnd rfl + convert ((hden.mul hlogfrac).add (hsnd.mul hlogexp)).sub hnml |>.sub hsnd using 1 <;> + ext p <;> rfl + +/-- Uniform continuity at `(kappa,rho)=(0,0)` makes the core contribution +strictly larger than `log 2 / 2` throughout a small rectangle. -/ +theorem cleanCore_uniform_rectangle : βˆƒ Ξ΅ : ℝ, 0 < Ξ΅ ∧ βˆ€ ΞΊ ρ : ℝ, + |ΞΊ| < Ξ΅ β†’ |ρ| < Ξ΅ β†’ Real.log 2 / 2 < cleanCoreFunction ΞΊ ρ := by + have hcont := cleanCoreFunction_continuousAt_zero + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hval : Real.log 2 / 2 < cleanCoreFunction 0 0 := by + simp [cleanCoreFunction] + linarith + have hevent : βˆ€αΆ  p : ℝ Γ— ℝ in nhds (0, 0), + Real.log 2 / 2 < cleanCoreFunction p.1 p.2 := + hcont.eventually (isOpen_Ioi.mem_nhds hval) + change {p : ℝ Γ— ℝ | + Real.log 2 / 2 < cleanCoreFunction p.1 p.2} ∈ nhds (0, 0) at hevent + rw [Metric.mem_nhds_iff] at hevent + rcases hevent with ⟨Ρ, hΞ΅, hball⟩ + refine ⟨Ρ, hΞ΅, fun ΞΊ ρ hΞΊ hρ => ?_⟩ + change (ΞΊ, ρ) ∈ {p : ℝ Γ— ℝ | + Real.log 2 / 2 < cleanCoreFunction p.1 p.2} + apply hball + simp only [Metric.mem_ball, Prod.dist_eq, Real.dist_eq, sub_zero, + max_lt_iff] + exact ⟨hΞΊ, hρ⟩ + +/-- The upper envelope `bar rho_kappa` from paper (51). -/ +noncomputable def leakageEnvelope (ΞΊ : ℝ) : ℝ := + 2 * (Real.exp ΞΊ - 1) + +/-- A positive rational local-cost threshold for which every admissible +leakage lies in the uniform core rectangle and is below `1/10`. -/ +theorem exists_rational_core_cost : + βˆƒ ΞΊq : β„š, 0 < ΞΊq ∧ leakageEnvelope (ΞΊq : ℝ) < 1 / 10 ∧ + βˆ€ ρ : ℝ, 0 ≀ ρ β†’ ρ ≀ leakageEnvelope (ΞΊq : ℝ) β†’ + Real.log 2 / 2 < cleanCoreFunction (ΞΊq : ℝ) ρ := by + rcases cleanCore_uniform_rectangle with ⟨Ρ, hΞ΅, hcore⟩ + let Ξ· : ℝ := min Ξ΅ (1 / 10) + have hΞ· : 0 < Ξ· := lt_min hΞ΅ (by norm_num) + have hbarcont : ContinuousAt leakageEnvelope 0 := by + unfold leakageEnvelope + fun_prop + have hbarzero : leakageEnvelope 0 = 0 := by simp [leakageEnvelope] + have hevent : βˆ€αΆ  ΞΊ : ℝ in nhds 0, + -Ξ· < leakageEnvelope ΞΊ ∧ leakageEnvelope ΞΊ < Ξ· := by + exact hbarcont.eventually (show βˆ€αΆ  y : ℝ in nhds (leakageEnvelope 0), + -Ξ· < y ∧ y < Ξ· by + rw [hbarzero] + exact isOpen_Ioo.mem_nhds ⟨neg_lt_zero.mpr hΞ·, hη⟩) + change {ΞΊ : ℝ | + -Ξ· < leakageEnvelope ΞΊ ∧ leakageEnvelope ΞΊ < Ξ·} ∈ nhds 0 at hevent + rw [Metric.mem_nhds_iff] at hevent + rcases hevent with ⟨δ, hΞ΄, hball⟩ + obtain ⟨κq : β„š, hΞΊqpos, hΞΊqsmall⟩ := + exists_rat_btwn (show (0 : ℝ) < min Ξ΅ Ξ΄ from lt_min hΞ΅ hΞ΄) + have hΞΊcastpos : 0 < (ΞΊq : ℝ) := hΞΊqpos + have hΞΊeps : (ΞΊq : ℝ) < Ξ΅ := hΞΊqsmall.trans_le (min_le_left _ _) + have hΞΊΞ΄ : (ΞΊq : ℝ) < Ξ΄ := hΞΊqsmall.trans_le (min_le_right _ _) + have hbarinterval : -Ξ· < leakageEnvelope (ΞΊq : ℝ) ∧ + leakageEnvelope (ΞΊq : ℝ) < Ξ· := by + apply hball + rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_of_pos hΞΊcastpos] + exact hΞΊΞ΄ + refine ⟨κq, ?_, ?_, ?_⟩ + Β· exact_mod_cast hΞΊcastpos + Β· exact hbarinterval.2.trans_le (min_le_right _ _) + Β· intro ρ hρ hρbar + have hρeps : ρ < Ξ΅ := + hρbar.trans_lt (hbarinterval.2.trans_le (min_le_left _ _)) + exact hcore (ΞΊq : ℝ) ρ + (by simpa [abs_of_pos hΞΊcastpos] using hΞΊeps) + (by simpa [abs_of_nonneg hρ] using hρeps) + +/-- The analytic conclusion of the clean-pair lemma, after a clean component +has supplied two distinct rows and two distinct core columns. -/ +def CleanPairGainGuarantee (ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : ℝ) : Prop := + βˆ€ {n : β„•} {ell ΞΎ Ο„ : ℝ} + {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ}, + 1 ≀ ell β†’ + Real.log n ≀ ell * Real.log 2 β†’ + 0 < ΞΎ β†’ ΞΎ ≀ ΞΎβ‚€ β†’ Ο„ = ΞΎ / (4 * ell) β†’ + (βˆ€ i j, 0 < A i j) β†’ + IsDoublyStochastic X β†’ + (βˆ€ i, IsInteriorProbabilityVector (X i)) β†’ + (βˆ€ i, 0 < rscale i) β†’ (βˆ€ j, 0 < cscale j) β†’ + HasMultiplicativeKKT Ο„ A X rscale cscale β†’ + βˆ€ {r s a b : Fin n}, r β‰  s β†’ a β‰  b β†’ + fourCoreTransferCost Ο„ X r s a b ≀ ΞΊβ‚€ β†’ + Ξ³β‚€ ≀ Real.log (pairGain A X r s) + +/-- Paper Lemma 19: rational absolute constants exist for which every clean +pair of small local transfer cost has a uniform positive logarithmic gain. +The graph-theoretic word "clean" is used earlier in the paper only to supply +the two distinct rows and columns appearing in this analytic statement. -/ +theorem exists_rational_cleanPairGain_constants : + βˆƒ ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š, 0 < ΞΊβ‚€ ∧ 0 < ΞΎβ‚€ ∧ 0 < Ξ³β‚€ ∧ + CleanPairGainGuarantee (ΞΊβ‚€ : ℝ) (ΞΎβ‚€ : ℝ) (Ξ³β‚€ : ℝ) := by + rcases exists_rational_core_cost with + βŸ¨ΞΊβ‚€, hΞΊβ‚€pos, hbarSmall, hcore⟩ + have hlog2pos : 0 < Real.log 2 := Real.log_pos (by norm_num) + obtain βŸ¨ΞΎβ‚€ : β„š, hΞΎβ‚€posR, hΞΎβ‚€small⟩ := + exists_rat_btwn (show (0 : ℝ) < Real.log 2 / 4 by positivity) + have hgapPos : 0 < Real.log 2 / 2 - (ΞΎβ‚€ : ℝ) := by + linarith + obtain βŸ¨Ξ³β‚€ : β„š, hΞ³β‚€posR, hΞ³β‚€gap⟩ := exists_rat_btwn hgapPos + refine βŸ¨ΞΊβ‚€, ΞΎβ‚€, Ξ³β‚€, hΞΊβ‚€pos, ?_, ?_, ?_⟩ + Β· exact_mod_cast hΞΎβ‚€posR + Β· exact_mod_cast hΞ³β‚€posR + Β· intro n ell ΞΎ Ο„ A X rscale cscale hell hlogn hΞΎ hΞΎβ‚€ hΟ„ + hApos hX hXint hrscale hcscale hKKT r s a b hrs hab hcost + have hellpos : 0 < ell := lt_of_lt_of_le (by norm_num) hell + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + have hΞΊβ‚€posR : 0 < (ΞΊβ‚€ : ℝ) := by exact_mod_cast hΞΊβ‚€pos + let ρ := outsideMassTwo (pairAlpha X r s) a b + have hρnonneg : 0 ≀ ρ := by + dsimp only [ρ, outsideMassTwo] + exact Finset.sum_nonneg fun j _ ↦ pairAlpha_nonneg hX r s j + by_cases hρzero : ρ = 0 + Β· have hbarNonneg : 0 ≀ leakageEnvelope (ΞΊβ‚€ : ℝ) := by + rw [leakageEnvelope] + have hexp : 1 ≀ Real.exp (ΞΊβ‚€ : ℝ) := by + rw [← Real.exp_zero] + exact Real.exp_le_exp.mpr hΞΊβ‚€posR.le + linarith + have hcoreZero := hcore 0 le_rfl hbarNonneg + have hcoreLog : Real.log 2 / 2 < + Real.log (2 * (Real.exp (-(ΞΊβ‚€ : ℝ))) ^ 2) := by + simpa [cleanCoreFunction] using hcoreZero + have hgain := log_pairGain_ge_core_of_zeroLeakage + hΟ„pos.le hApos hX hXint hrscale hcscale hKKT hrs hab hcost + (by simpa only [ρ] using hρzero) + have hΞ³core : (Ξ³β‚€ : ℝ) < Real.log 2 / 2 := by linarith + exact le_of_lt (hΞ³core.trans (hcoreLog.trans_le hgain)) + Β· have hρpos : 0 < ρ := lt_of_le_of_ne hρnonneg (Ne.symm hρzero) + have hρbar : ρ ≀ leakageEnvelope (ΞΊβ‚€ : ℝ) := by + dsimp only [ρ, leakageEnvelope] + exact pairOutsideMass_le_exp hΟ„pos.le hΞΊβ‚€posR.le hXint hab hcost + have hρsmall : ρ < 1 / 10 := hρbar.trans_lt hbarSmall + have hρone : ρ < 1 := hρsmall.trans (by norm_num) + have hcoreRho := hcore ρ hρnonneg hρbar + have hentropy := outsideEntropyBracket_lt_four_scale hX hρpos + hρsmall hell hlogn + have hclean := cleanGainLowerBound_gt_of_core_and_entropy + hΞΎ hellpos hΟ„ hcoreRho hentropy + have hgain := log_pairGain_ge_cleanGainLowerBound_of_positiveLeakage + hΟ„pos.le hApos hX hXint hrscale hcscale hKKT hrs hab hcost + hρpos hρone + have hΞ³lower : (Ξ³β‚€ : ℝ) < Real.log 2 / 2 - ΞΎ := by + linarith + exact le_of_lt (hΞ³lower.trans (hclean.trans_le hgain)) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CleanGain.lean b/LeanPool/BeyondBethe/BeyondBethe/CleanGain.lean new file mode 100644 index 0000000000..a15ab9a084 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CleanGain.lean @@ -0,0 +1,365 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CleanWitness +public import LeanPool.BeyondBethe.BeyondBethe.PairFactorization +public import Mathlib.Tactic + +/-! # Clean Gain -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The right-hand side of paper (61), before the final uniform choice of +constants. -/ +noncomputable def cleanGainLowerBound + {ΞΉ : Type*} [Fintype ΞΉ] + (ΞΊ Ο„ ρ : ℝ) (Ξ± : ΞΉ β†’ ℝ) : ℝ := + (1 - ρ) * Real.log ((2 * (Real.exp (-ΞΊ)) ^ 2) / (1 - ρ)) + + ρ * Real.log (Real.exp (-ΞΊ)) + ρ * Real.log ρ - ρ - + Ο„ * (-(βˆ‘ l, Ξ± l * Real.log (Ξ± l)) + ρ * Real.log 2) + +theorem isEmpty_outsideColumn_of_pairAlpha_outsideMass_eq_zero + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} + (hzero : outsideMassTwo (pairAlpha X r s) a b = 0) : + IsEmpty (OutsideColumn a b) := by + constructor + intro l + have hsum : (βˆ‘ x : OutsideColumn a b, pairAlpha X r s x.1) = 0 := by + rw [sum_outsideColumn_eq_outsideMassTwo, hzero] + have hle : pairAlpha X r s l.1 ≀ + βˆ‘ x : OutsideColumn a b, pairAlpha X r s x.1 := + Finset.single_le_sum + (fun x _ ↦ pairAlpha_nonneg hX r s x.1) (Finset.mem_univ l) + have hpos : 0 < pairAlpha X r s l.1 := + add_pos ((hXint r).2 l.1).1 ((hXint s).2 l.1).1 + linarith + +/-- At zero leakage the limiting witness mentioned in paper (52) is the +point mass on the core pair, and it has the required exponent moment. -/ +theorem cleanWitness_pairAlpha_zero + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + {r s a b : ΞΉ} (hrs : r β‰  s) (hab : a β‰  b) + (hzero : outsideMassTwo (pairAlpha X r s) a b = 0) + (hempty : IsEmpty (OutsideColumn a b)) : + let Ξ± := pairAlpha X r s + let ΞΈ := capacityWitnessMass 0 0 0 + (fun l : OutsideColumn a b ↦ Ξ± l.1) + IsProbabilityVector ΞΈ ∧ + βˆ€ j, exponentMoment ΞΈ (cleanWitnessExponent a b) j = Ξ± j := by + letI : IsEmpty (OutsideColumn a b) := hempty + dsimp only + have ha : pairAlpha X r s a = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum + (pairAlpha X r s) hab + rw [hzero, sum_pairAlpha hX r s] at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + linarith + have hb : pairAlpha X r s b = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum + (pairAlpha X r s) hab + rw [hzero, sum_pairAlpha hX r s] at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + linarith + constructor + Β· constructor + Β· intro e + rcases e with e | e + Β· simp [capacityWitnessMass] + Β· exact isEmptyElim e + Β· simp [capacityWitnessMass] + Β· intro j + have hj : j = a ∨ j = b := by + by_contra h + push Not at h + let l : OutsideColumn a b := ⟨j, by + simp [outsideColumnFinset, h.1, h.2]⟩ + exact isEmptyElim l + rcases hj with rfl | rfl + Β· rw [exponentMoment] + simp [capacityWitnessMass, cleanWitnessExponent, ha] + Β· rw [exponentMoment] + simp [capacityWitnessMass, cleanWitnessExponent, hb] + +theorem pairTransferPolynomialCapacity_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} (hrs : r β‰  s) (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b ≀ 1) : + 0 < polynomialCapacity (pairAlpha X r s) + (pairPolynomial (fun j ↦ transferU Ο„ (X r) j) + (fun j ↦ transferU Ο„ (X s) j)) := by + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + let Ur : ΞΉ β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : ΞΉ β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let ΞΈ := capacityWitnessMass ρ Ξ΄a Ξ΄b + (fun l : OutsideColumn a b ↦ Ξ± l.1) + have hprob := cleanWitness_pairAlpha_isProbabilityVector + hX hrs hab hρ hρ1 + have hmom := cleanWitness_pairAlpha_moment hX hab hρ + have hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient Ur Us a b e := + cleanWitnessCoefficient_positive + (fun j ↦ transferU_pos (hXint r) j) + (fun j ↦ transferU_pos (hXint s) j) a b + have hexp := exp_entropyCapacityCertificate_le_finitePolynomialCapacity + hprob.1 hprob.2 hcoeff hmom + have hcap := cleanWitnessCapacity_le_pairPolynomialCapacity hab + (u := Ur) (v := Us) (Ξ± := Ξ±) + (fun j ↦ (transferU_pos (Ο„ := Ο„) (hXint r) j).le) + (fun j ↦ (transferU_pos (Ο„ := Ο„) (hXint s) j).le) + dsimp only [Ξ±, Ur, Us] at hcap ⊒ + exact (Real.exp_pos _).trans_le (hexp.trans hcap) + +/-- Positive-leakage branch of paper Lemma 19 through equation (61). Every +factor in the pair factorization and every boundary-sensitive logarithm is +accounted for explicitly. -/ +theorem log_pairGain_ge_cleanGainLowerBound_of_positiveLeakage + {n : β„•} {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hrscale : βˆ€ i, 0 < rscale i) (hcscale : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b < 1) : + cleanGainLowerBound ΞΊ Ο„ + (outsideMassTwo (pairAlpha X r s) a b) + (fun l : OutsideColumn a b ↦ pairAlpha X r s l.1) ≀ + Real.log (pairGain A X r s) := by + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let cap := polynomialCapacity Ξ± (pairPolynomial Ur Us) + let prodFactor := ∏ j, (1 - Ξ± j) ^ (1 - Ξ± j) + let scale := 1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s)) + have hfactor := pairGain_factorization hApos hX hXint + hrscale hcscale hKKT r s + have hcard := two_lt_card_of_outsideMassTwo_pos hab hρ + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hΞ±lt : βˆ€ j, Ξ± j < 1 := fun j ↦ + pairAlpha_lt_one_of_positive hX hXpos hcard hrs j + have hcomp : βˆ€ j, 0 < 1 - Ξ± j := fun j ↦ sub_pos.mpr (hΞ±lt j) + have hprodPos : 0 < prodFactor := by + dsimp only [prodFactor] + exact Finset.prod_pos fun j _ ↦ Real.rpow_pos_of_pos (hcomp j) _ + have hcapPos : 0 < cap := by + dsimp only [cap, Ξ±, Ur, Us] + exact pairTransferPolynomialCapacity_pos hX hXint hrs hab hρ hρ1.le + have hzetaR : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaS : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hzetaRle : rowZeta Ο„ (X r) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability r) + have hzetaSle : rowZeta Ο„ (X s) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability s) + have hdenPos : 0 < rowZeta Ο„ (X r) * rowZeta Ο„ (X s) := + mul_pos hzetaR hzetaS + have hdenLe : rowZeta Ο„ (X r) * rowZeta Ο„ (X s) ≀ 1 := + (mul_le_mul hzetaRle hzetaSle hzetaS.le (by norm_num)).trans_eq + (mul_one 1) + have hscalePos : 0 < scale := by + dsimp only [scale] + exact one_div_pos.mpr hdenPos + have hscaleOne : 1 ≀ scale := by + dsimp only [scale] + exact (le_div_iffβ‚€ hdenPos).2 (by simpa using hdenLe) + have hlogScale : 0 ≀ Real.log scale := Real.log_nonneg hscaleOne + have hlogFactor : Real.log (pairGain A X r s) = + Real.log scale + + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) + + Real.log cap := by + rw [hfactor] + dsimp only [scale, prodFactor, cap, Ξ±, Ur, Us] + rw [Real.log_mul (mul_pos hscalePos hprodPos).ne' hcapPos.ne', + Real.log_mul hscalePos.ne' hprodPos.ne', + Real.log_prod (fun j _ ↦ + (Real.rpow_pos_of_pos (hcomp j) _).ne')] + simp_rw [Real.log_rpow (hcomp _)] + ring + have hsumDecomp : + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) = + Ξ΄a * Real.log Ξ΄a + Ξ΄b * Real.log Ξ΄b + + βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum + (fun j ↦ (1 - Ξ± j) * Real.log (1 - Ξ± j)) hab + rw [← sum_outsideColumn_eq_outsideMassTwo] at hsplit + dsimp only [Ξ΄a, Ξ΄b] + exact hsplit.symm + have houtsideFactor : + -ρ ≀ βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + calc + -ρ = βˆ‘ l : OutsideColumn a b, -Ξ± l.1 := by + rw [Finset.sum_neg_distrib, + show (βˆ‘ l : OutsideColumn a b, Ξ± l.1) = ρ by + exact sum_outsideColumn_eq_outsideMassTwo Ξ± a b] + _ ≀ βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + apply Finset.sum_le_sum + intro l _ + exact neg_alpha_le_one_sub_mul_log (hΞ±lt l.1) + have hsumLower : + Ξ΄a * Real.log Ξ΄a + Ξ΄b * Real.log Ξ΄b - ρ ≀ + βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j) := by + rw [hsumDecomp] + linarith + have hΞ΄pos := pairAlpha_coreDeficit_pos hX hXint hrs hab hρ + have hΞ΄sum : Ξ΄a + Ξ΄b = ρ := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show βˆ‘ j, Ξ± j = 2 by + simpa only [Ξ±] using sum_pairAlpha hX r s] at hsplit + dsimp only [Ξ΄a, Ξ΄b, ρ] + linarith + have hcancel := core_entropy_cancellation + hΞ΄pos.1 hΞ΄pos.2 hρ hΞ΄sum + have hcapLower := pairTransfer_capacity_theta_bound hΟ„ hX hXint + hrs hab hcost hρ hρ1 + rw [hlogFactor] + dsimp only [cleanGainLowerBound, Ξ±, ρ, Ξ΄a, Ξ΄b, Ur, Us, cap] at * + linarith + +/-- Zero-leakage branch of paper Lemma 19. This formalizes the manuscript's +"limiting distribution concentrated on `{a,b}`" directly, without a limit +argument. -/ +theorem log_pairGain_ge_core_of_zeroLeakage + {n : β„•} {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hrscale : βˆ€ i, 0 < rscale i) (hcscale : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) + (hzero : outsideMassTwo (pairAlpha X r s) a b = 0) : + Real.log (2 * (Real.exp (-ΞΊ)) ^ 2) ≀ + Real.log (pairGain A X r s) := by + let Ξ± := pairAlpha X r s + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let cap := polynomialCapacity Ξ± (pairPolynomial Ur Us) + let scale := 1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s)) + letI : IsEmpty (OutsideColumn a b) := + isEmpty_outsideColumn_of_pairAlpha_outsideMass_eq_zero hX hXint hzero + let ΞΈ := capacityWitnessMass 0 0 0 + (fun l : OutsideColumn a b ↦ Ξ± l.1) + have hzeroWitness := cleanWitness_pairAlpha_zero hX hrs hab hzero + (inferInstance : IsEmpty (OutsideColumn a b)) + have hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient Ur Us a b e := + cleanWitnessCoefficient_positive + (fun j ↦ transferU_pos (hXint r) j) + (fun j ↦ transferU_pos (hXint s) j) a b + have hcertUpper := + cleanWitnessEntropyCertificate_le_log_pairPolynomialCapacity hab + hzeroWitness.1.1 hzeroWitness.1.2 hcoeff hzeroWitness.2 + (fun j ↦ (transferU_pos (hXint r) j).le) + (fun j ↦ (transferU_pos (hXint s) j).le) + have hcertCore : entropyCapacityCertificate ΞΈ + (cleanWitnessCoefficient Ur Us a b) = + Real.log (cleanWitnessCoefficient Ur Us a b (Sum.inl ())) := by + dsimp only [ΞΈ] + simp [entropyCapacityCertificate, capacityWitnessMass] + have hcore := fourCoreTransfer_lower hΟ„ hXint hcost + have hcoreCoeff := cleanWitnessCoefficient_core_lower + (Real.exp_pos _).le hcore.1 hcore.2.1 hcore.2.2.1 hcore.2.2.2 + have hcoreBase : 0 < 2 * (Real.exp (-ΞΊ)) ^ 2 := + mul_pos (by norm_num) (sq_pos_of_pos (Real.exp_pos _)) + have hlogCore : Real.log (2 * (Real.exp (-ΞΊ)) ^ 2) ≀ + Real.log (cleanWitnessCoefficient Ur Us a b (Sum.inl ())) := + Real.log_le_log hcoreBase hcoreCoeff + have hcapLower : Real.log (2 * (Real.exp (-ΞΊ)) ^ 2) ≀ + Real.log cap := by + dsimp only [cap] + exact hlogCore.trans (hcertCore β–Έ hcertUpper) + have hexp := exp_entropyCapacityCertificate_le_finitePolynomialCapacity + hzeroWitness.1.1 hzeroWitness.1.2 hcoeff hzeroWitness.2 + have hcapFinite := cleanWitnessCapacity_le_pairPolynomialCapacity hab + (u := Ur) (v := Us) (Ξ± := Ξ±) + (fun j ↦ (transferU_pos (hXint r) j).le) + (fun j ↦ (transferU_pos (hXint s) j).le) + have hcapPos : 0 < cap := by + dsimp only [cap] + exact (Real.exp_pos _).trans_le (hexp.trans hcapFinite) + have ha : Ξ± a = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hb : Ξ± b = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hΞ±one : βˆ€ j, Ξ± j = 1 := by + intro j + have hj : j = a ∨ j = b := by + by_contra h + push Not at h + let l : OutsideColumn a b := ⟨j, by + simp [outsideColumnFinset, h.1, h.2]⟩ + exact isEmptyElim l + exact hj.elim (fun h ↦ h β–Έ ha) (fun h ↦ h β–Έ hb) + have hfactor := pairGain_factorization hApos hX hXint + hrscale hcscale hKKT r s + have hgainEq : pairGain A X r s = scale * cap := by + rw [hfactor] + simp_rw [show βˆ€ j, pairAlpha X r s j = 1 by + simpa only [Ξ±] using hΞ±one] + simp [scale, cap, Ξ±, Ur, Us] + have hzetaR : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaS : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hdenPos : 0 < rowZeta Ο„ (X r) * rowZeta Ο„ (X s) := + mul_pos hzetaR hzetaS + have hdenLe : rowZeta Ο„ (X r) * rowZeta Ο„ (X s) ≀ 1 := by + have hrle := rowZeta_le_one hΟ„ (hX.row_probability r) + have hsle := rowZeta_le_one hΟ„ (hX.row_probability s) + nlinarith [mul_nonneg hzetaR.le hzetaS.le, + mul_nonneg (sub_nonneg.mpr hrle) (sub_nonneg.mpr hsle)] + have hscaleOne : 1 ≀ scale := by + dsimp only [scale] + exact (le_div_iffβ‚€ hdenPos).2 (by simpa using hdenLe) + have hcapGain : cap ≀ pairGain A X r s := by + rw [hgainEq] + exact le_mul_of_one_le_left hcapPos.le hscaleOne + exact hcapLower.trans (Real.log_le_log hcapPos hcapGain) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CleanWitness.lean b/LeanPool/BeyondBethe/BeyondBethe/CleanWitness.lean new file mode 100644 index 0000000000..6df2d927a4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CleanWitness.lean @@ -0,0 +1,981 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate +public import Mathlib.Tactic + +/-! # Clean Witness -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- All column indices except the two distinguished columns. -/ +def outsideColumnFinset + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) : Finset ΞΉ := + (Finset.univ.erase a).erase b + +/-- The subtype of columns outside the two distinguished columns. -/ +abbrev OutsideColumn + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) := + {j // j ∈ outsideColumnFinset a b} + +theorem OutsideColumn.ne_a + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (l : OutsideColumn a b) : l.1 β‰  a := by + exact (Finset.mem_erase.mp (Finset.mem_erase.mp l.2).2).1 + +theorem OutsideColumn.ne_b + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (l : OutsideColumn a b) : l.1 β‰  b := by + exact (Finset.mem_erase.mp l.2).1 + +theorem two_lt_card_of_outsideMassTwo_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} {a b : ΞΉ} (hab : a β‰  b) + (hρ : 0 < outsideMassTwo p a b) : + 2 < Fintype.card ΞΉ := by + have houtside : (outsideColumnFinset a b).Nonempty := by + by_contra hempty + have hzero : outsideMassTwo p a b = 0 := by + rw [outsideMassTwo, show (Finset.univ.erase a).erase b = βˆ… by + exact Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + linarith + obtain ⟨l, hl⟩ := houtside + let lo : OutsideColumn a b := ⟨l, hl⟩ + exact Fintype.two_lt_card_iff.mpr + ⟨a, b, lo.1, hab, Ne.symm lo.ne_a, Ne.symm lo.ne_b⟩ + +theorem pairAlpha_coreDeficit_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} (hrs : r β‰  s) (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) : + 0 < 1 - pairAlpha X r s a ∧ 0 < 1 - pairAlpha X r s b := by + have hcard := two_lt_card_of_outsideMassTwo_pos hab hρ + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + exact ⟨sub_pos.mpr (pairAlpha_lt_one_of_positive hX hXpos hcard hrs a), + sub_pos.mpr (pairAlpha_lt_one_of_positive hX hXpos hcard hrs b)⟩ + +/-- The coordinate indicator of the endpoint pair associated to each clean capacity-witness +edge. -/ +noncomputable def cleanWitnessExponent + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) : + CapacityWitnessEdge (OutsideColumn a b) β†’ ΞΉ β†’ β„• + | Sum.inl _, j => if j = a ∨ j = b then 1 else 0 + | Sum.inr (Sum.inl l), j => if j = a ∨ j = l.1 then 1 else 0 + | Sum.inr (Sum.inr l), j => if j = b ∨ j = l.1 then 1 else 0 + +/-- The unordered pair of columns represented by a clean-witness atom. -/ +noncomputable def cleanWitnessEndpoints + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) : + CapacityWitnessEdge (OutsideColumn a b) β†’ ΞΉ Γ— ΞΉ + | Sum.inl _ => (a, b) + | Sum.inr (Sum.inl l) => (a, l.1) + | Sum.inr (Sum.inr l) => (b, l.1) + +/-- Give a witness edge either of its two ordered orientations. -/ +noncomputable def cleanWitnessOrientedPair + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) : + CapacityWitnessEdge (OutsideColumn a b) Γ— Bool β†’ ΞΉ Γ— ΞΉ := + fun eo ↦ if eo.2 then (cleanWitnessEndpoints a b eo.1).swap + else cleanWitnessEndpoints a b eo.1 + +theorem cleanWitnessOrientedPair_injective + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) : + Function.Injective (cleanWitnessOrientedPair a b) := by + intro x y h + rcases x with ⟨e, o⟩ + rcases y with ⟨f, p⟩ + rcases e with e | e <;> rcases f with f | f + Β· cases e + cases f + cases o <;> cases p <;> + simp_all [cleanWitnessOrientedPair, cleanWitnessEndpoints, hab] + Β· rcases f with l | l <;> cases e + all_goals cases o <;> cases p <;> + simp_all [cleanWitnessOrientedPair, cleanWitnessEndpoints, hab, + l.ne_a, l.ne_b, Ne.symm l.ne_a, Ne.symm l.ne_b] + Β· rcases e with l | l <;> cases f + all_goals cases o <;> cases p <;> + simp_all [cleanWitnessOrientedPair, cleanWitnessEndpoints, hab, + l.ne_a, l.ne_b, Ne.symm l.ne_a, Ne.symm l.ne_b] + Β· rcases e with l | l <;> rcases f with m | m + all_goals cases o <;> cases p <;> + simp_all [cleanWitnessOrientedPair, cleanWitnessEndpoints, hab, + l.ne_a, l.ne_b, m.ne_a, m.ne_b, Ne.symm l.ne_a, + Ne.symm l.ne_b, Ne.symm m.ne_a, Ne.symm m.ne_b] + +/-- The actual coefficient in the pair polynomial of a witness edge. -/ +noncomputable def cleanWitnessCoefficient + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) (a b : ΞΉ) : + CapacityWitnessEdge (OutsideColumn a b) β†’ ℝ := fun e ↦ + let p := cleanWitnessEndpoints a b e + u p.1 * v p.2 + u p.2 * v p.1 + +/-- The weighted sum of the logarithms of the coefficients. -/ +noncomputable def expectedLogCoefficient + {ΞΊ : Type*} [Fintype ΞΊ] (ΞΈ c : ΞΊ β†’ ℝ) : ℝ := + βˆ‘ e, ΞΈ e * Real.log (c e) + +theorem entropyCapacityCertificate_eq_expectedLogCoefficient_add_entropy + {ΞΊ : Type*} [Fintype ΞΊ] {ΞΈ c : ΞΊ β†’ ℝ} + (hc : βˆ€ e, 0 < c e) : + entropyCapacityCertificate ΞΈ c = + expectedLogCoefficient ΞΈ c + shannonEntropy ΞΈ := by + rw [entropyCapacityCertificate, expectedLogCoefficient, shannonEntropy, + ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro e _ + by_cases hΞΈ : ΞΈ e = 0 + Β· simp [hΞΈ, Real.negMulLog_def] + Β· rw [Real.log_div (hc e).ne' hΞΈ, Real.negMulLog_def] + ring + +theorem cleanWitnessExponent_eq_endpoints + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (a b : ΞΉ) (e : CapacityWitnessEdge (OutsideColumn a b)) (j : ΞΉ) : + cleanWitnessExponent a b e j = + if j = (cleanWitnessEndpoints a b e).1 ∨ + j = (cleanWitnessEndpoints a b e).2 then 1 else 0 := by + rcases e with _ | e + Β· rfl + Β· rcases e with l | l <;> rfl + +theorem cleanWitnessEndpoints_ne + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + (e : CapacityWitnessEdge (OutsideColumn a b)) : + (cleanWitnessEndpoints a b e).1 β‰  + (cleanWitnessEndpoints a b e).2 := by + rcases e with _ | e + Β· exact hab + Β· rcases e with l | l + Β· exact Ne.symm l.ne_a + Β· exact Ne.symm l.ne_b + +theorem natMonomial_pair + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (z : ΞΉ β†’ ℝ) {a b : ΞΉ} (hab : a β‰  b) : + natMonomial z (fun j ↦ if j = a ∨ j = b then 1 else 0) = + z a * z b := by + rw [natMonomial] + simp only [pow_ite, pow_one, pow_zero] + rw [Finset.prod_ite] + have hfilter : + Finset.univ.filter (fun j ↦ j = a ∨ j = b) = {a, b} := by + ext j + simp [eq_comm] + rw [hfilter] + simp [hab] + +theorem natMonomial_cleanWitnessExponent + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) (z : ΞΉ β†’ ℝ) + (e : CapacityWitnessEdge (OutsideColumn a b)) : + natMonomial z (cleanWitnessExponent a b e) = + z (cleanWitnessEndpoints a b e).1 * + z (cleanWitnessEndpoints a b e).2 := by + have hexp : cleanWitnessExponent a b e = fun j ↦ + if j = (cleanWitnessEndpoints a b e).1 ∨ + j = (cleanWitnessEndpoints a b e).2 then 1 else 0 := + funext (cleanWitnessExponent_eq_endpoints a b e) + rw [hexp] + exact natMonomial_pair z (cleanWitnessEndpoints_ne hab e) + +/-- The sparse witness polynomial is exactly the sum over both orientations +of its selected two-column sets. -/ +theorem finitePolynomial_cleanWitness_eq_oriented_sum + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) (u v z : ΞΉ β†’ ℝ) : + finitePolynomial (cleanWitnessCoefficient u v a b) + (cleanWitnessExponent a b) z = + βˆ‘ eo : CapacityWitnessEdge (OutsideColumn a b) Γ— Bool, + u (cleanWitnessOrientedPair a b eo).1 * + v (cleanWitnessOrientedPair a b eo).2 * + z (cleanWitnessOrientedPair a b eo).1 * + z (cleanWitnessOrientedPair a b eo).2 := by + rw [finitePolynomial, Fintype.sum_prod_type] + apply Finset.sum_congr rfl + intro e _ + rw [natMonomial_cleanWitnessExponent hab] + simp [cleanWitnessCoefficient, cleanWitnessOrientedPair] + ring + +theorem cleanWitnessOrientedPair_mem_offDiag + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + (eo : CapacityWitnessEdge (OutsideColumn a b) Γ— Bool) : + cleanWitnessOrientedPair a b eo ∈ + (Finset.univ : Finset ΞΉ).offDiag := by + rcases eo with ⟨e, o⟩ + cases o + Β· simp [cleanWitnessOrientedPair, cleanWitnessEndpoints_ne hab e] + Β· simp [cleanWitnessOrientedPair, (cleanWitnessEndpoints_ne hab e).symm] + +/-- The witness polynomial consists of distinct monomials from the full pair +polynomial, so its value is pointwise no larger on the nonnegative orthant. -/ +theorem finitePolynomial_cleanWitness_le_pairPolynomial_eval + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {u v z : ΞΉ β†’ ℝ} (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) + (hz : βˆ€ j, 0 ≀ z j) : + finitePolynomial (cleanWitnessCoefficient u v a b) + (cleanWitnessExponent a b) z ≀ + (pairPolynomial u v).eval z := by + let f : ΞΉ Γ— ΞΉ β†’ ℝ := fun e ↦ + u e.1 * v e.2 * z e.1 * z e.2 + let orient := cleanWitnessOrientedPair a b + have himage : + (βˆ‘ eo : CapacityWitnessEdge (OutsideColumn a b) Γ— Bool, + f (orient eo)) = + βˆ‘ e ∈ Finset.image orient Finset.univ, f e := by + symm + simpa only [Finset.mem_univ, Set.mem_setOf_eq] using + (Finset.sum_image (s := Finset.univ) (f := f) + (g := orient) (cleanWitnessOrientedPair_injective hab).injOn) + have hsubset : Finset.image orient Finset.univ βŠ† + (Finset.univ : Finset ΞΉ).offDiag := by + intro e he + rw [Finset.mem_image] at he + obtain ⟨eo, _, rfl⟩ := he + exact cleanWitnessOrientedPair_mem_offDiag hab eo + rw [finitePolynomial_cleanWitness_eq_oriented_sum hab] + change (βˆ‘ eo, f (orient eo)) ≀ _ + rw [himage, pairPolynomial_eval] + exact Finset.sum_le_sum_of_subset_of_nonneg hsubset (by + intro e _ _ + exact mul_nonneg + (mul_nonneg (mul_nonneg (hu e.1) (hv e.2)) (hz e.1)) (hz e.2)) + +theorem cleanWitnessCoefficient_nonnegative + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) + (a b : ΞΉ) : βˆ€ e, 0 ≀ cleanWitnessCoefficient u v a b e := by + intro e + exact add_nonneg + (mul_nonneg (hu _) (hv _)) (mul_nonneg (hu _) (hv _)) + +theorem cleanWitnessCoefficient_positive + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} (hu : βˆ€ j, 0 < u j) (hv : βˆ€ j, 0 < v j) + (a b : ΞΉ) : βˆ€ e, 0 < cleanWitnessCoefficient u v a b e := by + intro e + exact add_pos (mul_pos (hu _) (hv _)) (mul_pos (hu _) (hv _)) + +theorem cleanWitnessCoefficient_core_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} {a b : ΞΉ} {w : ℝ} (hw : 0 ≀ w) + (hua : w ≀ u a) (hub : w ≀ u b) + (hva : w ≀ v a) (hvb : w ≀ v b) : + 2 * w ^ 2 ≀ + cleanWitnessCoefficient u v a b (Sum.inl ()) := by + simp only [cleanWitnessCoefficient, cleanWitnessEndpoints] + have h₁ : w * w ≀ u a * v b := mul_le_mul hua hvb hw (hw.trans hua) + have hβ‚‚ : w * w ≀ u b * v a := mul_le_mul hub hva hw (hw.trans hub) + nlinarith + +theorem cleanWitnessCoefficient_left_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} {a b : ΞΉ} {w : ℝ} + (hua : w ≀ u a) (hva : w ≀ v a) + (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) + (l : OutsideColumn a b) : + w * (u l.1 + v l.1) ≀ + cleanWitnessCoefficient u v a b (Sum.inr (Sum.inl l)) := by + simp only [cleanWitnessCoefficient, cleanWitnessEndpoints] + have h₁ := mul_le_mul_of_nonneg_right hua (hv l.1) + have hβ‚‚ := mul_le_mul_of_nonneg_right hva (hu l.1) + nlinarith + +theorem cleanWitnessCoefficient_right_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} {a b : ΞΉ} {w : ℝ} + (hub : w ≀ u b) (hvb : w ≀ v b) + (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) + (l : OutsideColumn a b) : + w * (u l.1 + v l.1) ≀ + cleanWitnessCoefficient u v a b (Sum.inr (Sum.inr l)) := by + simp only [cleanWitnessCoefficient, cleanWitnessEndpoints] + have h₁ := mul_le_mul_of_nonneg_right hub (hv l.1) + have hβ‚‚ := mul_le_mul_of_nonneg_right hvb (hu l.1) + nlinarith + +/-- Paper (57): the expected log coefficient of the clean witness. The +proof keeps the two outside families separate and then uses +`delta_a + delta_b = rho`; this is exactly where their normalizing factors +cancel. -/ +theorem cleanWitness_expectedLogCoefficient_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} {a b : ΞΉ} {w ρ Ξ΄a Ξ΄b : ℝ} + {Ξ± : OutsideColumn a b β†’ ℝ} + (hw : 0 < w) (hρ : 0 < ρ) (hρ1 : ρ ≀ 1) + (hΞ΄a : 0 ≀ Ξ΄a) (hΞ΄b : 0 ≀ Ξ΄b) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) (hΞ± : βˆ€ l, 0 ≀ Ξ± l) + (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hu : βˆ€ j, 0 < u j) (hv : βˆ€ j, 0 < v j) + (hua : w ≀ u a) (hub : w ≀ u b) + (hva : w ≀ v a) (hvb : w ≀ v b) : + (1 - ρ) * Real.log (2 * w ^ 2) + ρ * Real.log w + + βˆ‘ l, Ξ± l * Real.log (u l.1 + v l.1) ≀ + expectedLogCoefficient (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessCoefficient u v a b) := by + let V : OutsideColumn a b β†’ ℝ := fun l ↦ u l.1 + v l.1 + have hV : βˆ€ l, 0 < V l := fun l ↦ add_pos (hu l.1) (hv l.1) + have hcoreLower := cleanWitnessCoefficient_core_lower hw.le + hua hub hva hvb + have hcoreBase : 0 < 2 * w ^ 2 := mul_pos (by norm_num) (sq_pos_of_pos hw) + have hcoreLog : Real.log (2 * w ^ 2) ≀ + Real.log (cleanWitnessCoefficient u v a b (Sum.inl ())) := + Real.log_le_log hcoreBase hcoreLower + have hleftLog : βˆ€ l, + Real.log (w * V l) ≀ Real.log + (cleanWitnessCoefficient u v a b (Sum.inr (Sum.inl l))) := by + intro l + apply Real.log_le_log (mul_pos hw (hV l)) + exact cleanWitnessCoefficient_left_lower hua hva + (fun j ↦ (hu j).le) (fun j ↦ (hv j).le) l + have hrightLog : βˆ€ l, + Real.log (w * V l) ≀ Real.log + (cleanWitnessCoefficient u v a b (Sum.inr (Sum.inr l))) := by + intro l + apply Real.log_le_log (mul_pos hw (hV l)) + exact cleanWitnessCoefficient_right_lower hub hvb + (fun j ↦ (hu j).le) (fun j ↦ (hv j).le) l + have hcoreWeighted : + (1 - ρ) * Real.log (2 * w ^ 2) ≀ + (1 - ρ) * Real.log + (cleanWitnessCoefficient u v a b (Sum.inl ())) := + mul_le_mul_of_nonneg_left hcoreLog (sub_nonneg.mpr hρ1) + have hleftWeighted : + (βˆ‘ l, (Ξ΄b / ρ * Ξ± l) * Real.log (w * V l)) ≀ + βˆ‘ l, (Ξ΄b / ρ * Ξ± l) * Real.log + (cleanWitnessCoefficient u v a b (Sum.inr (Sum.inl l))) := by + apply Finset.sum_le_sum + intro l _ + exact mul_le_mul_of_nonneg_left (hleftLog l) + (mul_nonneg (div_nonneg hΞ΄b hρ.le) (hΞ± l)) + have hrightWeighted : + (βˆ‘ l, (Ξ΄a / ρ * Ξ± l) * Real.log (w * V l)) ≀ + βˆ‘ l, (Ξ΄a / ρ * Ξ± l) * Real.log + (cleanWitnessCoefficient u v a b (Sum.inr (Sum.inr l))) := by + apply Finset.sum_le_sum + intro l _ + exact mul_le_mul_of_nonneg_left (hrightLog l) + (mul_nonneg (div_nonneg hΞ΄a hρ.le) (hΞ± l)) + have hlowerIdentity : + (1 - ρ) * Real.log (2 * w ^ 2) + ρ * Real.log w + + βˆ‘ l, Ξ± l * Real.log (V l) = + (1 - ρ) * Real.log (2 * w ^ 2) + + (βˆ‘ l, (Ξ΄b / ρ * Ξ± l) * Real.log (w * V l)) + + βˆ‘ l, (Ξ΄a / ρ * Ξ± l) * Real.log (w * V l) := by + simp_rw [Real.log_mul hw.ne' (hV _).ne', mul_add, + Finset.sum_add_distrib] + rw [show (βˆ‘ l, Ξ΄b / ρ * Ξ± l * Real.log w) = + (Ξ΄b / ρ) * ρ * Real.log w by + calc + (βˆ‘ l, Ξ΄b / ρ * Ξ± l * Real.log w) = + (Ξ΄b / ρ * Real.log w) * βˆ‘ l, Ξ± l := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring + _ = (Ξ΄b / ρ) * ρ * Real.log w := by rw [hΞ±sum]; ring] + rw [show (βˆ‘ l, Ξ΄a / ρ * Ξ± l * Real.log w) = + (Ξ΄a / ρ) * ρ * Real.log w by + calc + (βˆ‘ l, Ξ΄a / ρ * Ξ± l * Real.log w) = + (Ξ΄a / ρ * Real.log w) * βˆ‘ l, Ξ± l := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring + _ = (Ξ΄a / ρ) * ρ * Real.log w := by rw [hΞ±sum]; ring] + rw [show (βˆ‘ l, Ξ΄b / ρ * Ξ± l * Real.log (V l)) = + (Ξ΄b / ρ) * βˆ‘ l, Ξ± l * Real.log (V l) by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring] + rw [show (βˆ‘ l, Ξ΄a / ρ * Ξ± l * Real.log (V l)) = + (Ξ΄a / ρ) * βˆ‘ l, Ξ± l * Real.log (V l) by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring] + field_simp [hρ.ne'] + linear_combination + -(ρ * Real.log w + βˆ‘ x, Ξ± x * Real.log (V x)) * hΞ΄sum + rw [hlowerIdentity] + rw [expectedLogCoefficient] + simp only [Fintype.sum_sum_type, Fintype.sum_unique, + capacityWitnessMass] + linarith + +/-- Paper (58): exact entropy of the clean witness in the positive-leakage +case. -/ +theorem shannonEntropy_capacityWitnessMass + {ΞΉ : Type*} [Fintype ΞΉ] + {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hΞ΄a : 0 < Ξ΄a) (hΞ΄b : 0 < Ξ΄b) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) (hΞ± : βˆ€ l, 0 < Ξ± l) + (hΞ±sum : βˆ‘ l, Ξ± l = ρ) : + shannonEntropy (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) = + -(1 - ρ) * Real.log (1 - ρ) - + (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - + Ξ΄b * Real.log (Ξ΄b / ρ) := by + have hleft : + (βˆ‘ l, -(Ξ΄b / ρ * Ξ± l) * Real.log (Ξ΄b / ρ * Ξ± l)) = + -Ξ΄b * Real.log (Ξ΄b / ρ) - + (Ξ΄b / ρ) * βˆ‘ l, Ξ± l * Real.log (Ξ± l) := by + simp_rw [Real.log_mul (div_pos hΞ΄b hρ).ne' (hΞ± _).ne', mul_add, + Finset.sum_add_distrib] + rw [show (βˆ‘ l, -(Ξ΄b / ρ * Ξ± l) * Real.log (Ξ΄b / ρ)) = + -Ξ΄b * Real.log (Ξ΄b / ρ) by + calc + (βˆ‘ l, -(Ξ΄b / ρ * Ξ± l) * Real.log (Ξ΄b / ρ)) = + (-(Ξ΄b / ρ) * Real.log (Ξ΄b / ρ)) * βˆ‘ l, Ξ± l := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring + _ = -Ξ΄b * Real.log (Ξ΄b / ρ) := by + rw [hΞ±sum] + field_simp [hρ.ne']] + rw [show (βˆ‘ l, -(Ξ΄b / ρ * Ξ± l) * Real.log (Ξ± l)) = + -(Ξ΄b / ρ) * βˆ‘ l, Ξ± l * Real.log (Ξ± l) by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring] + ring + have hright : + (βˆ‘ l, -(Ξ΄a / ρ * Ξ± l) * Real.log (Ξ΄a / ρ * Ξ± l)) = + -Ξ΄a * Real.log (Ξ΄a / ρ) - + (Ξ΄a / ρ) * βˆ‘ l, Ξ± l * Real.log (Ξ± l) := by + simp_rw [Real.log_mul (div_pos hΞ΄a hρ).ne' (hΞ± _).ne', mul_add, + Finset.sum_add_distrib] + rw [show (βˆ‘ l, -(Ξ΄a / ρ * Ξ± l) * Real.log (Ξ΄a / ρ)) = + -Ξ΄a * Real.log (Ξ΄a / ρ) by + calc + (βˆ‘ l, -(Ξ΄a / ρ * Ξ± l) * Real.log (Ξ΄a / ρ)) = + (-(Ξ΄a / ρ) * Real.log (Ξ΄a / ρ)) * βˆ‘ l, Ξ± l := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring + _ = -Ξ΄a * Real.log (Ξ΄a / ρ) := by + rw [hΞ±sum] + field_simp [hρ.ne']] + rw [show (βˆ‘ l, -(Ξ΄a / ρ * Ξ± l) * Real.log (Ξ± l)) = + -(Ξ΄a / ρ) * βˆ‘ l, Ξ± l * Real.log (Ξ± l) by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro l _ + ring] + ring + rw [shannonEntropy] + simp only [Fintype.sum_sum_type, Fintype.sum_unique, + capacityWitnessMass, Real.negMulLog_def] + rw [hleft, hright] + field_simp [hρ.ne'] + linear_combination + -(βˆ‘ l, Ξ± l * Real.log (Ξ± l)) * hΞ΄sum + +/-- Summed form of paper (56). -/ +theorem sum_alpha_log_pairTransfer_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} {Ο„ ρ : ℝ} (hΟ„ : 0 ≀ Ο„) + {p q : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) + (hq : IsInteriorProbabilityVector q) + (hρ : βˆ‘ l : OutsideColumn a b, (p l.1 + q l.1) = ρ) : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * + (βˆ‘ l : OutsideColumn a b, + (p l.1 + q l.1) * Real.log (p l.1 + q l.1)) ≀ + βˆ‘ l : OutsideColumn a b, + (p l.1 + q l.1) * + Real.log (transferU Ο„ p l.1 + transferU Ο„ q l.1) := by + have hΞ± : βˆ€ l : OutsideColumn a b, 0 < p l.1 + q l.1 := + fun l ↦ add_pos (hp.2 l.1).1 (hq.2 l.1).1 + have htwo : (0 : ℝ) < 2 := by norm_num + have hterm : βˆ€ l : OutsideColumn a b, + -Ο„ * Real.log 2 + (1 + Ο„) * Real.log (p l.1 + q l.1) ≀ + Real.log (transferU Ο„ p l.1 + transferU Ο„ q l.1) := by + intro l + have hlower := pairTransferSum_lower hΟ„ hp hq l.1 + have hlowerPos : 0 < (2 : ℝ) ^ (-Ο„) * + (p l.1 + q l.1) ^ (1 + Ο„) := + mul_pos (Real.rpow_pos_of_pos htwo _) (Real.rpow_pos_of_pos (hΞ± l) _) + have hlog := Real.log_le_log hlowerPos hlower + rw [Real.log_mul (Real.rpow_pos_of_pos htwo _).ne' + (Real.rpow_pos_of_pos (hΞ± l) _).ne', + Real.log_rpow htwo, Real.log_rpow (hΞ± l)] at hlog + linarith + calc + -Ο„ * ρ * Real.log 2 + (1 + Ο„) * + (βˆ‘ l : OutsideColumn a b, + (p l.1 + q l.1) * Real.log (p l.1 + q l.1)) = + βˆ‘ l : OutsideColumn a b, (p l.1 + q l.1) * + (-Ο„ * Real.log 2 + + (1 + Ο„) * Real.log (p l.1 + q l.1)) := by + rw [show (βˆ‘ l : OutsideColumn a b, (p l.1 + q l.1) * + (-Ο„ * Real.log 2 + + (1 + Ο„) * Real.log (p l.1 + q l.1))) = + (βˆ‘ l : OutsideColumn a b, (p l.1 + q l.1)) * + (-Ο„ * Real.log 2) + + (1 + Ο„) * βˆ‘ l : OutsideColumn a b, + (p l.1 + q l.1) * Real.log (p l.1 + q l.1) by + simp_rw [mul_add] + rw [Finset.sum_add_distrib, ← Finset.sum_mul, Finset.mul_sum] + apply congrArgβ‚‚ (Β· + Β·) rfl + apply Finset.sum_congr rfl + intro l _ + ring] + rw [hρ] + ring + _ ≀ βˆ‘ l : OutsideColumn a b, + (p l.1 + q l.1) * + Real.log (transferU Ο„ p l.1 + transferU Ο„ q l.1) := by + apply Finset.sum_le_sum + intro l _ + exact mul_le_mul_of_nonneg_left (hterm l) (hΞ± l).le + +/-- The quantitative lower bound used in paper (59) already holds for the +explicit sparse entropy certificate itself. Keeping this stronger form +visible is what permits the numerical algorithm to evaluate the witness +directly, without optimizing a capacity. -/ +theorem cleanWitness_capacity_theta_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {u v : ΞΉ β†’ ℝ} {w ρ Ξ΄a Ξ΄b Ο„ : ℝ} + {Ξ± : OutsideColumn a b β†’ ℝ} + (hw : 0 < w) (hρ : 0 < ρ) (hρ1 : ρ < 1) + (hΞ΄a : 0 < Ξ΄a) (hΞ΄b : 0 < Ξ΄b) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) + (hΞ± : βˆ€ l, 0 < Ξ± l) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hu : βˆ€ j, 0 < u j) (hv : βˆ€ j, 0 < v j) + (hua : w ≀ u a) (hub : w ≀ u b) + (hva : w ≀ v a) (hvb : w ≀ v b) + (houtside : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) ≀ + βˆ‘ l, Ξ± l * Real.log (u l.1 + v l.1)) : + (1 - ρ) * Real.log ((2 * w ^ 2) / (1 - ρ)) + + ρ * Real.log w - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - + Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + entropyCapacityCertificate (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessCoefficient u v a b) := by + let ΞΈ := capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± + have hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient u v a b e := + cleanWitnessCoefficient_positive hu hv a b + have hexpected := cleanWitness_expectedLogCoefficient_lower + hw hρ hρ1.le hΞ΄a.le hΞ΄b.le hΞ΄sum (fun l ↦ (hΞ± l).le) + hΞ±sum hu hv hua hub hva hvb + have hentropy := shannonEntropy_capacityWitnessMass + hρ hΞ΄a hΞ΄b hΞ΄sum hΞ± hΞ±sum + have hcertEq := + entropyCapacityCertificate_eq_expectedLogCoefficient_add_entropy + (ΞΈ := ΞΈ) hcoeff + have hratio : Real.log ((2 * w ^ 2) / (1 - ρ)) = + Real.log (2 * w ^ 2) - Real.log (1 - ρ) := by + rw [Real.log_div (mul_pos (by norm_num) (sq_pos_of_pos hw)).ne' + (sub_pos.mpr hρ1).ne'] + have hlower : + (1 - ρ) * Real.log ((2 * w ^ 2) / (1 - ρ)) + + ρ * Real.log w - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - + Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + entropyCapacityCertificate ΞΈ + (cleanWitnessCoefficient u v a b) := by + rw [hcertEq, hentropy, hratio] + dsimp only [ΞΈ] at hexpected ⊒ + linarith + simpa only [ΞΈ] using hlower + +/-- Paper (59), separated from its particular transfer-vector +instantiation. This theorem composes the explicit witness bound with the +one-sided entropy certificate for polynomial capacity. -/ +theorem cleanWitness_capacity_theta_bound_of_certificate + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {u v Ξ±full : ΞΉ β†’ ℝ} {w ρ Ξ΄a Ξ΄b Ο„ : ℝ} + {Ξ± : OutsideColumn a b β†’ ℝ} + (hw : 0 < w) (hρ : 0 < ρ) (hρ1 : ρ < 1) + (hΞ΄a : 0 < Ξ΄a) (hΞ΄b : 0 < Ξ΄b) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) + (hΞ± : βˆ€ l, 0 < Ξ± l) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hu : βˆ€ j, 0 < u j) (hv : βˆ€ j, 0 < v j) + (hua : w ≀ u a) (hub : w ≀ u b) + (hva : w ≀ v a) (hvb : w ≀ v b) + (hmoment : βˆ€ j, + exponentMoment (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessExponent a b) j = Ξ±full j) + (hcertUpper : + entropyCapacityCertificate (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessCoefficient u v a b) ≀ + Real.log (polynomialCapacity Ξ±full (pairPolynomial u v))) + (houtside : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) ≀ + βˆ‘ l, Ξ± l * Real.log (u l.1 + v l.1)) : + (1 - ρ) * Real.log ((2 * w ^ 2) / (1 - ρ)) + + ρ * Real.log w - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - + Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + Real.log (polynomialCapacity Ξ±full (pairPolynomial u v)) := by + exact (cleanWitness_capacity_theta_lower hab hw hρ hρ1 hΞ΄a hΞ΄b + hΞ΄sum hΞ± hΞ±sum hu hv hua hub hva hvb houtside).trans hcertUpper + +/-- The sparse-witness capacity is bounded by the capacity of the full pair +polynomial. This is the omitted subpolynomial step in paper Lemma 19. -/ +theorem cleanWitnessCapacity_le_pairPolynomialCapacity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) {u v Ξ± : ΞΉ β†’ ℝ} + (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) : + finitePolynomialCapacity (cleanWitnessCoefficient u v a b) + (cleanWitnessExponent a b) Ξ± ≀ + polynomialCapacity Ξ± (pairPolynomial u v) := by + exact finitePolynomialCapacity_le_polynomialCapacity_of_eval_le + (cleanWitnessCoefficient_nonnegative hu hv a b) + (fun z hz ↦ finitePolynomial_cleanWitness_le_pairPolynomial_eval + hab hu hv hz) + +/-- A feasible clean witness certifies the capacity of the full pair +polynomial, not merely the sparse polynomial supported on the witness. -/ +theorem cleanWitnessEntropyCertificate_le_log_pairPolynomialCapacity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) {u v Ξ± : ΞΉ β†’ ℝ} + {ΞΈ : CapacityWitnessEdge (OutsideColumn a b) β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΞΈsum : βˆ‘ e, ΞΈ e = 1) + (hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient u v a b e) + (hmoment : βˆ€ j, + exponentMoment ΞΈ (cleanWitnessExponent a b) j = Ξ± j) + (hu : βˆ€ j, 0 ≀ u j) (hv : βˆ€ j, 0 ≀ v j) : + entropyCapacityCertificate ΞΈ (cleanWitnessCoefficient u v a b) ≀ + Real.log (polynomialCapacity Ξ± (pairPolynomial u v)) := by + have hfinite := entropyCapacityCertificate_le_log_finitePolynomialCapacity + hΞΈ hΞΈsum hcoeff hmoment + have hexp := exp_entropyCapacityCertificate_le_finitePolynomialCapacity + hΞΈ hΞΈsum hcoeff hmoment + have hfinitePos : 0 < finitePolynomialCapacity + (cleanWitnessCoefficient u v a b) (cleanWitnessExponent a b) Ξ± := + (Real.exp_pos _).trans_le hexp + have hcap := cleanWitnessCapacity_le_pairPolynomialCapacity + hab hu hv (Ξ± := Ξ±) + exact hfinite.trans (Real.log_le_log hfinitePos hcap) + +/-- Paper (59) for the full pair polynomial. -/ +theorem cleanWitness_capacity_theta_bound + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {u v Ξ±full : ΞΉ β†’ ℝ} {w ρ Ξ΄a Ξ΄b Ο„ : ℝ} + {Ξ± : OutsideColumn a b β†’ ℝ} + (hw : 0 < w) (hρ : 0 < ρ) (hρ1 : ρ < 1) + (hΞ΄a : 0 < Ξ΄a) (hΞ΄b : 0 < Ξ΄b) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) + (hΞ± : βˆ€ l, 0 < Ξ± l) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hu : βˆ€ j, 0 < u j) (hv : βˆ€ j, 0 < v j) + (hua : w ≀ u a) (hub : w ≀ u b) + (hva : w ≀ v a) (hvb : w ≀ v b) + (hmoment : βˆ€ j, + exponentMoment (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessExponent a b) j = Ξ±full j) + (houtside : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) ≀ + βˆ‘ l, Ξ± l * Real.log (u l.1 + v l.1)) : + (1 - ρ) * Real.log ((2 * w ^ 2) / (1 - ρ)) + + ρ * Real.log w - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l, Ξ± l * Real.log (Ξ± l)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - + Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + Real.log (polynomialCapacity Ξ±full (pairPolynomial u v)) := by + have hΞΈnonneg : βˆ€ e, + 0 ≀ capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± e := + capacityWitness_nonnegative hρ hρ1.le hΞ΄a.le hΞ΄b.le + (fun l ↦ (hΞ± l).le) + have hΞΈsum : βˆ‘ e, capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± e = 1 := + capacityWitness_sum hρ hΞ΄sum hΞ±sum + have hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient u v a b e := + cleanWitnessCoefficient_positive hu hv a b + have hcert := + cleanWitnessEntropyCertificate_le_log_pairPolynomialCapacity hab + hΞΈnonneg hΞΈsum hcoeff hmoment + (fun j ↦ (hu j).le) (fun j ↦ (hv j).le) + exact cleanWitness_capacity_theta_bound_of_certificate hab hw hρ hρ1 + hΞ΄a hΞ΄b hΞ΄sum hΞ± hΞ±sum hu hv hua hub hva hvb hmoment hcert + houtside + +theorem cleanWitness_coreA_moment + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {ρ Ξ΄a Ξ΄b Ξ±a : ℝ} {Ξ± : OutsideColumn a b β†’ ℝ} + (hρ : 0 < ρ) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hΞ΄a : Ξ΄a + Ξ±a = 1) (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) : + exponentMoment (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessExponent a b) a = Ξ±a := by + rw [exponentMoment] + simp only [Fintype.sum_sum_type, Fintype.sum_unique, + cleanWitnessExponent, ite_eq_left (Or.inl rfl), Nat.cast_one, mul_one] + have hright : βˆ€ l : OutsideColumn a b, + ((if a = b ∨ a = l.1 then 1 else 0 : β„•) : ℝ) = 0 := by + intro l + simp [hab, l.ne_a.symm] + simp_rw [hright, mul_zero, Finset.sum_const_zero, add_zero] + simp only [true_or, or_true, if_true, Nat.cast_one, mul_one] + exact capacityWitness_coreA_marginal hρ hΞ±sum hΞ΄a hΞ΄sum + +theorem cleanWitness_coreB_moment + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {ρ Ξ΄a Ξ΄b Ξ±b : ℝ} {Ξ± : OutsideColumn a b β†’ ℝ} + (hρ : 0 < ρ) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hΞ΄b : Ξ΄b + Ξ±b = 1) (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) : + exponentMoment (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessExponent a b) b = Ξ±b := by + rw [exponentMoment] + simp only [Fintype.sum_sum_type, Fintype.sum_unique, + cleanWitnessExponent, ite_eq_left (Or.inr rfl), Nat.cast_one, mul_one] + have hleft : βˆ€ l : OutsideColumn a b, + ((if b = a ∨ b = l.1 then 1 else 0 : β„•) : ℝ) = 0 := by + intro l + simp [hab.symm, l.ne_b.symm] + simp_rw [hleft, mul_zero, Finset.sum_const_zero, zero_add] + simp only [true_or, or_true, if_true, Nat.cast_one, mul_one] + exact capacityWitness_coreB_marginal hρ hΞ±sum hΞ΄b hΞ΄sum + +theorem cleanWitness_outside_moment + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : OutsideColumn a b β†’ ℝ} + (hρ : 0 < ρ) (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) + (l : OutsideColumn a b) : + exponentMoment (capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ±) + (cleanWitnessExponent a b) l.1 = Ξ± l := by + rw [exponentMoment] + simp only [Fintype.sum_sum_type, Fintype.sum_unique, + cleanWitnessExponent] + have hcore : Β¬(l.1 = a ∨ l.1 = b) := by + exact fun h ↦ h.elim l.ne_a l.ne_b + rw [ite_eq_right hcore, Nat.cast_zero, mul_zero, zero_add] + have hleft : + (βˆ‘ x : OutsideColumn a b, + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inl x)) * + ((if l.1 = a ∨ l.1 = x.1 then 1 else 0 : β„•) : ℝ)) = + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inl l)) := by + let f : OutsideColumn a b β†’ ℝ := fun x ↦ + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inl x)) * + ((if l.1 = a ∨ l.1 = x.1 then 1 else 0 : β„•) : ℝ) + have hsingle : (βˆ‘ x, f x) = f l := Fintype.sum_eq_single l (by + intro x hxl + have hne : l.1 β‰  x.1 := by + intro heq + apply hxl + exact Subtype.ext heq.symm + have hcond : Β¬(l.1 = a ∨ l.1 = x.1) := + fun h ↦ h.elim l.ne_a hne + have hlx : l β‰  x := Ne.symm hxl + simp [f, hcond, l.ne_a, hlx]) + simpa [f, l.ne_a] using hsingle + have hright : + (βˆ‘ x : OutsideColumn a b, + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inr x)) * + ((if l.1 = b ∨ l.1 = x.1 then 1 else 0 : β„•) : ℝ)) = + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inr l)) := by + let f : OutsideColumn a b β†’ ℝ := fun x ↦ + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inr x)) * + ((if l.1 = b ∨ l.1 = x.1 then 1 else 0 : β„•) : ℝ) + have hsingle : (βˆ‘ x, f x) = f l := Fintype.sum_eq_single l (by + intro x hxl + have hne : l.1 β‰  x.1 := by + intro heq + apply hxl + exact Subtype.ext heq.symm + have hcond : Β¬(l.1 = b ∨ l.1 = x.1) := + fun h ↦ h.elim l.ne_b hne + have hlx : l β‰  x := Ne.symm hxl + simp [f, hcond, l.ne_b, hlx]) + simpa [f, l.ne_b] using hsingle + rw [hleft, hright] + exact capacityWitness_outside_marginal hρ hΞ΄sum l + +/-- The distribution in paper (52) has the claimed mean exponent vector. -/ +theorem cleanWitness_moment + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) + {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) + (hΞ±sum : βˆ‘ l : OutsideColumn a b, Ξ± l.1 = ρ) + (hΞ΄a : Ξ΄a + Ξ± a = 1) (hΞ΄b : Ξ΄b + Ξ± b = 1) + (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) : + βˆ€ j, + exponentMoment + (capacityWitnessMass ρ Ξ΄a Ξ΄b (fun l ↦ Ξ± l.1)) + (cleanWitnessExponent a b) j = Ξ± j := by + intro j + by_cases hja : j = a + Β· subst j + exact cleanWitness_coreA_moment hab hρ hΞ±sum hΞ΄a hΞ΄sum + by_cases hjb : j = b + Β· subst j + exact cleanWitness_coreB_moment hab hρ hΞ±sum hΞ΄b hΞ΄sum + Β· let l : OutsideColumn a b := ⟨j, by + simp [outsideColumnFinset, hja, hjb]⟩ + simpa [l] using cleanWitness_outside_moment + (Ξ± := fun l : OutsideColumn a b ↦ Ξ± l.1) hρ hΞ΄sum l + +theorem sum_outsideColumn_eq_outsideMassTwo + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) (a b : ΞΉ) : + (βˆ‘ l : OutsideColumn a b, p l.1) = outsideMassTwo p a b := by + change (βˆ‘ l : β†₯(outsideColumnFinset a b), p l.1) = + βˆ‘ j ∈ outsideColumnFinset a b, p j + exact Finset.sum_coe_sort (outsideColumnFinset a b) (fun j ↦ p j) + +/-- The paper's witness has mean `alpha_j = X_rj + X_sj` once its parameters +`rho`, `delta_a`, and `delta_b` are instantiated. -/ +theorem cleanWitness_pairAlpha_moment + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + {r s a b : ΞΉ} (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) : + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + βˆ€ j, + exponentMoment + (capacityWitnessMass ρ Ξ΄a Ξ΄b + (fun l : OutsideColumn a b ↦ Ξ± l.1)) + (cleanWitnessExponent a b) j = Ξ± j := by + dsimp only + apply cleanWitness_moment hab hρ + Β· exact sum_outsideColumn_eq_outsideMassTwo _ _ _ + Β· ring + Β· ring + Β· have hsplit := twoCore_add_outsideMassTwo_eq_sum + (pairAlpha X r s) hab + rw [sum_pairAlpha hX r s] at hsplit + linarith + +/-- Nonnegativity and normalization of the clean witness in the `rho > 0` +case. -/ +theorem cleanWitness_pairAlpha_isProbabilityVector + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + {r s a b : ΞΉ} (hrs : r β‰  s) (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b ≀ 1) : + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + IsProbabilityVector + (capacityWitnessMass ρ Ξ΄a Ξ΄b + (fun l : OutsideColumn a b ↦ Ξ± l.1)) := by + dsimp only + have hΞ΄a : 0 ≀ 1 - pairAlpha X r s a := + sub_nonneg.mpr (pairAlpha_le_one hX hrs a) + have hΞ΄b : 0 ≀ 1 - pairAlpha X r s b := + sub_nonneg.mpr (pairAlpha_le_one hX hrs b) + have hΞ± : βˆ€ l : OutsideColumn a b, 0 ≀ pairAlpha X r s l.1 := + fun l ↦ pairAlpha_nonneg hX r s l.1 + have hsplit := twoCore_add_outsideMassTwo_eq_sum + (pairAlpha X r s) hab + rw [sum_pairAlpha hX r s] at hsplit + have hΞ΄sum : (1 - pairAlpha X r s a) + + (1 - pairAlpha X r s b) = + outsideMassTwo (pairAlpha X r s) a b := by + linarith + constructor + Β· exact capacityWitness_nonnegative hρ hρ1 hΞ΄a hΞ΄b hΞ± + Β· exact capacityWitness_sum hρ hΞ΄sum + (sum_outsideColumn_eq_outsideMassTwo _ _ _) + +/-- The capacity portion of paper Lemma 19, through displayed equation (59), +for the actual transfer vectors and pair marginals. -/ +theorem pairTransfer_capacity_theta_bound + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {X : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} (hrs : r β‰  s) (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b < 1) : + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + let Ur := fun j ↦ transferU Ο„ (X r) j + let Us := fun j ↦ transferU Ο„ (X s) j + (1 - ρ) * Real.log ((2 * (Real.exp (-ΞΊ)) ^ 2) / (1 - ρ)) + + ρ * Real.log (Real.exp (-ΞΊ)) - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l : OutsideColumn a b, Ξ± l.1 * Real.log (Ξ± l.1)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + Real.log (polynomialCapacity Ξ± (pairPolynomial Ur Us)) := by + dsimp only + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + let Ur : ΞΉ β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : ΞΉ β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + have hcore := fourCoreTransfer_lower hΟ„ hXint hcost + have hΞ΄pos := pairAlpha_coreDeficit_pos hX hXint hrs hab hρ + have hΞ±pos : βˆ€ l : OutsideColumn a b, 0 < Ξ± l.1 := by + intro l + exact add_pos ((hXint r).2 l.1).1 ((hXint s).2 l.1).1 + have hΞ±sum : βˆ‘ l : OutsideColumn a b, Ξ± l.1 = ρ := + sum_outsideColumn_eq_outsideMassTwo Ξ± a b + have hΞ΄sum : Ξ΄a + Ξ΄b = ρ := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show βˆ‘ j, Ξ± j = 2 by + simpa only [Ξ±] using sum_pairAlpha hX r s] at hsplit + dsimp only [Ξ΄a, Ξ΄b, ρ] + linarith + have hmoment : βˆ€ j, + exponentMoment + (capacityWitnessMass ρ Ξ΄a Ξ΄b + (fun l : OutsideColumn a b ↦ Ξ± l.1)) + (cleanWitnessExponent a b) j = Ξ± j := by + simpa only [Ξ±, ρ, Ξ΄a, Ξ΄b] using + cleanWitness_pairAlpha_moment hX hab hρ + have houtside : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * + (βˆ‘ l : OutsideColumn a b, + Ξ± l.1 * Real.log (Ξ± l.1)) ≀ + βˆ‘ l : OutsideColumn a b, + Ξ± l.1 * Real.log (Ur l.1 + Us l.1) := by + exact sum_alpha_log_pairTransfer_lower (a := a) (b := b) + hΟ„ (hXint r) (hXint s) (by simpa only [Ξ±, ρ, pairAlpha] using hΞ±sum) + have hUr : βˆ€ j, 0 < Ur j := fun j ↦ transferU_pos (hXint r) j + have hUs : βˆ€ j, 0 < Us j := fun j ↦ transferU_pos (hXint s) j + apply cleanWitness_capacity_theta_bound hab (Real.exp_pos _) hρ hρ1 + hΞ΄pos.1 hΞ΄pos.2 hΞ΄sum hΞ±pos hΞ±sum hUr hUs + Β· exact hcore.1 + Β· exact hcore.2.1 + Β· exact hcore.2.2.1 + Β· exact hcore.2.2.2 + Β· exact hmoment + Β· exact houtside + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ClusterAlpha.lean b/LeanPool/BeyondBethe/BeyondBethe/ClusterAlpha.lean new file mode 100644 index 0000000000..ee07ee0ad8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ClusterAlpha.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ClusterFactors +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import Mathlib.Tactic + +/-! # Cluster Alpha -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The total `X`-mass which a row cluster sends to a column. This is the +vector `alpha` used when the stable coefficient inequality is applied to the +cluster polynomial and the column selector. -/ +noncomputable def clusterAlpha + {n : β„•} (X : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + C.Cluster Γ— Fin n β†’ ℝ := + fun v ↦ βˆ‘ k, X (C.rows ⟨v.1, k⟩) v.2 + +theorem clusterAlpha_nonnegative + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) (v : C.Cluster Γ— Fin n) : + 0 ≀ clusterAlpha X C v := by + rw [clusterAlpha] + exact Finset.sum_nonneg fun k _ ↦ hX.nonnegative (C.rows ⟨v.1, k⟩) v.2 + +theorem clusterAlpha_pos + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : βˆ€ i j, 0 < X i j) {c : C.Cluster} (hc : 0 < C.size c) + (j : Fin n) : + 0 < clusterAlpha X C (c, j) := by + rw [clusterAlpha] + letI : Nonempty (Fin (C.size c)) := ⟨⟨0, hc⟩⟩ + exact Finset.sum_pos + (fun k _ ↦ hX (C.rows ⟨c, k⟩) j) + Finset.univ_nonempty + +theorem clusterAlpha_row_sum + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) (c : C.Cluster) : + βˆ‘ j, clusterAlpha X C (c, j) = C.size c := by + change βˆ‘ j, βˆ‘ k, X (C.rows ⟨c, k⟩) j = C.size c + rw [Finset.sum_comm] + simp_rw [hX.row_sum] + simp + +theorem clusterAlpha_col_sum + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) (j : Fin n) : + βˆ‘ c, clusterAlpha X C (c, j) = 1 := by + change βˆ‘ c, βˆ‘ k, X (C.rows ⟨c, k⟩) j = 1 + rw [← Fintype.sum_sigma'] + calc + (βˆ‘ s : Ξ£ c, Fin (C.size c), X (C.rows s) j) = + βˆ‘ i, X i j := Equiv.sum_comp C.rows (fun i ↦ X i j) + _ = 1 := hX.col_sum j + +theorem clusterAlpha_le_one + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) (c : C.Cluster) (j : Fin n) : + clusterAlpha X C (c, j) ≀ 1 := by + let e : Fin (C.size c) β†’ (Ξ£ d, Fin (C.size d)) := fun k ↦ ⟨c, k⟩ + have he : Function.Injective e := by + intro k l h + exact eq_of_heq (Sigma.mk.inj_iff.mp h).2 + have hslice : + clusterAlpha X C (c, j) = + βˆ‘ s ∈ (Finset.univ.image e), X (C.rows s) j := by + rw [clusterAlpha, Finset.sum_image he.injOn] + rw [hslice, ← hX.col_sum j] + calc + (βˆ‘ s ∈ (Finset.univ.image e), X (C.rows s) j) ≀ + βˆ‘ s : Ξ£ d, Fin (C.size d), X (C.rows s) j := by + exact Finset.sum_le_sum_of_subset_of_nonneg + (Finset.subset_univ _) (fun s _ _ ↦ hX.nonnegative (C.rows s) j) + _ = βˆ‘ i, X i j := Equiv.sum_comp C.rows (fun i ↦ X i j) + +theorem clusterAlpha_total_sum + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) : + βˆ‘ v, clusterAlpha X C v = n := by + rw [Fintype.sum_prod_type] + simp_rw [clusterAlpha_row_sum C hX] + exact_mod_cast sum_clusterSizes_eq C + +theorem clusterAlpha_in_unit_interval + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : IsDoublyStochastic X) (v : C.Cluster Γ— Fin n) : + 0 ≀ clusterAlpha X C v ∧ clusterAlpha X C v ≀ 1 := by + exact ⟨clusterAlpha_nonnegative C hX v, + clusterAlpha_le_one C hX v.1 v.2⟩ + +theorem clusterAlpha_pos_of_singletonPairs + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hX : βˆ€ i j, 0 < X i j) (hclusters : IsSingletonPairClustering C) + (v : C.Cluster Γ— Fin n) : + 0 < clusterAlpha X C v := by + apply clusterAlpha_pos C hX (c := v.1) + rcases hclusters v.1 with h | h <;> omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ClusterCertificate.lean b/LeanPool/BeyondBethe/BeyondBethe/ClusterCertificate.lean new file mode 100644 index 0000000000..075f3b3e8d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ClusterCertificate.lean @@ -0,0 +1,371 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CertificateCapacity +public import LeanPool.BeyondBethe.BeyondBethe.ClusterAlpha +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import Mathlib.Tactic + +/-! # Cluster Certificate -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The part of the stable boundary factor which remains after the powers of +`alpha` cancel against the column-selector capacity. -/ +noncomputable def clusterComplementFactor + {Οƒ : Type*} [Fintype Οƒ] (Ξ± : Οƒ β†’ ℝ) : ℝ := + ∏ v, (1 - Ξ± v) ^ (1 - Ξ± v) + +theorem stableBoundaryFactor_nonnegative + {Οƒ : Type*} [Fintype Οƒ] {Ξ± : Οƒ β†’ ℝ} + (hΞ± : βˆ€ v, 0 ≀ Ξ± v ∧ Ξ± v ≀ 1) : + 0 ≀ stableBoundaryFactor Ξ± := by + rw [stableBoundaryFactor] + exact Finset.prod_nonneg fun v _ ↦ mul_nonneg + (Real.rpow_nonneg (hΞ± v).1 _) (Real.rpow_nonneg (sub_nonneg.mpr (hΞ± v).2) _) + +theorem selectorCapacityValue_pos + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + {Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ} (hΞ± : βˆ€ v, 0 < Ξ± v) : + 0 < selectorCapacityValue Ξ± := by + rw [selectorCapacityValue] + apply Finset.prod_pos + intro j _ + rw [linearCapacityValue] + exact Finset.prod_pos fun c _ ↦ + Real.rpow_pos_of_pos (div_pos (by norm_num) (hΞ± (c, j))) _ + +theorem boundaryTerm_mul_selectorTerm + {a : ℝ} (ha : 0 < a) : + (a ^ a * (1 - a) ^ (1 - a)) * (1 / a) ^ a = + (1 - a) ^ (1 - a) := by + rw [one_div, Real.inv_rpow (le_of_lt ha)] + have hp : 0 < a ^ a := Real.rpow_pos_of_pos ha _ + calc + (a ^ a * (1 - a) ^ (1 - a)) * (a ^ a)⁻¹ = + (a ^ a * (a ^ a)⁻¹) * (1 - a) ^ (1 - a) := by ring + _ = (1 - a) ^ (1 - a) := by rw [mul_inv_cancelβ‚€ hp.ne', one_mul] + +theorem stableBoundaryFactor_mul_selectorCapacityValue + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [Fintype ΞΉ] + {Ξ± : ΞΊ Γ— ΞΉ β†’ ℝ} (hΞ± : βˆ€ v, 0 < Ξ± v) : + stableBoundaryFactor Ξ± * selectorCapacityValue Ξ± = + clusterComplementFactor Ξ± := by + rw [stableBoundaryFactor, selectorCapacityValue, clusterComplementFactor] + simp only [linearCapacityValue, Fintype.prod_prod_type] + have hcomm : + (∏ j, ∏ c, (1 / Ξ± (c, j)) ^ Ξ± (c, j)) = + ∏ c, ∏ j, (1 / Ξ± (c, j)) ^ Ξ± (c, j) := + Finset.prod_comm + rw [hcomm] + rw [← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro c _ + rw [← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro j _ + exact boundaryTerm_mul_selectorTerm (hΞ± (c, j)) + +/-- The cluster form of the paired certificate: singleton and pair factors +are recovered below by specializing each local injection polynomial. -/ +noncomputable def clusterCertificateValue + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) : ℝ := + clusterComplementFactor Ξ± * clusterProductCapacityValue A C Ξ± + +/-- The factor contributed by one cluster before distinguishing singleton and +pair clusters. -/ +noncomputable def localClusterCertificate + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) (c : C.Cluster) : ℝ := + (∏ j, (1 - Ξ± (c, j)) ^ (1 - Ξ± (c, j))) * + polynomialCapacity (fun j ↦ Ξ± (c, j)) + (injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j)) + +theorem clusterCertificateValue_eq_prod_local + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) : + clusterCertificateValue A C Ξ± = + ∏ c, localClusterCertificate A C Ξ± c := by + rw [clusterCertificateValue, clusterComplementFactor, + clusterProductCapacityValue] + simp only [Fintype.prod_prod_type, localClusterCertificate, + ← Finset.prod_mul_distrib] + +/-- The unique row in a cluster whose size has been identified as one. -/ +noncomputable def singletonClusterRow + {n : β„•} (C : RowClustering n) (c : C.Cluster) (hc : C.size c = 1) : + Fin n := + C.rows ⟨c, (Fin.castOrderIso hc).symm 0⟩ + +/-- The two ordered rows in a cluster whose size has been identified as two. +The order is immaterial to the symmetric pair certificate. -/ +noncomputable def pairClusterRow + {n : β„•} (C : RowClustering n) (c : C.Cluster) (hc : C.size c = 2) : + Fin 2 β†’ Fin n := + fun k ↦ C.rows ⟨c, (Fin.castOrderIso hc).symm k⟩ + +theorem pairClusterRow_ne + {n : β„•} (C : RowClustering n) (c : C.Cluster) (hc : C.size c = 2) : + pairClusterRow C c hc 0 β‰  pairClusterRow C c hc 1 := by + intro h + have hs := C.rows.injective h + have hk : (0 : Fin 2) = 1 := by + apply (Fin.castOrderIso hc).symm.injective + exact eq_of_heq (Sigma.mk.inj_iff.mp hs).2 + norm_num at hk + +theorem clusterAlpha_eq_singleton + {n : β„•} (X : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) (hc : C.size c = 1) (j : Fin n) : + clusterAlpha X C (c, j) = X (singletonClusterRow C c hc) j := by + let e : Fin (C.size c) ≃ Fin 1 := (Fin.castOrderIso hc).toEquiv + change (βˆ‘ k : Fin (C.size c), X (C.rows ⟨c, k⟩) j) = _ + calc + (βˆ‘ k : Fin (C.size c), X (C.rows ⟨c, k⟩) j) = + βˆ‘ k : Fin 1, X (C.rows ⟨c, e.symm k⟩) j := + (Equiv.sum_comp e.symm + (fun k : Fin (C.size c) ↦ X (C.rows ⟨c, k⟩) j)).symm + _ = X (singletonClusterRow C c hc) j := by + simp [singletonClusterRow, e] + +theorem clusterAlpha_eq_pair + {n : β„•} (X : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) (hc : C.size c = 2) (j : Fin n) : + clusterAlpha X C (c, j) = + pairAlpha X (pairClusterRow C c hc 0) (pairClusterRow C c hc 1) j := by + let e : Fin (C.size c) ≃ Fin 2 := (Fin.castOrderIso hc).toEquiv + change (βˆ‘ k : Fin (C.size c), X (C.rows ⟨c, k⟩) j) = _ + calc + (βˆ‘ k : Fin (C.size c), X (C.rows ⟨c, k⟩) j) = + βˆ‘ k : Fin 2, X (C.rows ⟨c, e.symm k⟩) j := + (Equiv.sum_comp e.symm + (fun k : Fin (C.size c) ↦ X (C.rows ⟨c, k⟩) j)).symm + _ = pairAlpha X (pairClusterRow C c hc 0) + (pairClusterRow C c hc 1) j := by + simp [Fin.sum_univ_two, pairAlpha, pairClusterRow, e] + +theorem clusterInjectionPolynomial_eq_singleton + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) (hc : C.size c = 1) : + injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j) = + positiveLinearPolynomial (fun j ↦ A (singletonClusterRow C c hc) j) := by + let e : Fin (C.size c) ≃ Fin 1 := (Fin.castOrderIso hc).toEquiv + calc + injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j) = + injectionPolynomial (fun k : Fin 1 ↦ fun j ↦ + A (C.rows ⟨c, e.symm k⟩) j) := + injectionPolynomial_reindex_rows _ e + _ = positiveLinearPolynomial (fun j ↦ + A (singletonClusterRow C c hc) j) := by + rw [injectionPolynomial_fin_one] + rfl + +theorem clusterInjectionPolynomial_eq_pair + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) (hc : C.size c = 2) : + injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j) = + pairPolynomial (fun j ↦ A (pairClusterRow C c hc 0) j) + (fun j ↦ A (pairClusterRow C c hc 1) j) := by + let e : Fin (C.size c) ≃ Fin 2 := (Fin.castOrderIso hc).toEquiv + calc + injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j) = + injectionPolynomial (fun k : Fin 2 ↦ fun j ↦ + A (C.rows ⟨c, e.symm k⟩) j) := + injectionPolynomial_reindex_rows _ e + _ = pairPolynomial (fun j ↦ A (pairClusterRow C c hc 0) j) + (fun j ↦ A (pairClusterRow C c hc 1) j) := by + rw [injectionPolynomial_fin_two] + rfl + +/-- The product over columns of the singleton row Bethe factors. -/ +noncomputable def singletonProductValue + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (i : Fin n) : ℝ := + ∏ j, (A i j / X i j) ^ (X i j) * + (1 - X i j) ^ (1 - X i j) + +/-- The pair-polynomial capacity multiplied by the complementary-mass product for the two-row +exponents. -/ +noncomputable def pairCertificateValue + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (r s : Fin n) : ℝ := + (∏ j, (1 - pairAlpha X r s j) ^ (1 - pairAlpha X r s j)) * + polynomialCapacity (pairAlpha X r s) + (pairPolynomial (fun j ↦ A r j) (fun j ↦ A s j)) + +theorem localClusterCertificate_eq_singletonProduct + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : βˆ€ i j, 0 < A i j) (hX : IsDoublyStochastic X) + (hXpos : βˆ€ i j, 0 < X i j) + (c : C.Cluster) (hc : C.size c = 1) : + localClusterCertificate A C (clusterAlpha X C) c = + singletonProductValue A X (singletonClusterRow C c hc) := by + rw [localClusterCertificate] + simp_rw [clusterAlpha_eq_singleton X C c hc] + rw [clusterInjectionPolynomial_eq_singleton A C c hc, + ← linearCapacityValue_eq_capacity + (fun j ↦ hA (singletonClusterRow C c hc) j) + (fun j ↦ hXpos (singletonClusterRow C c hc) j) + (hX.row_sum (singletonClusterRow C c hc))] + rw [singletonProductValue, linearCapacityValue, + ← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro j _ + ring + +theorem localClusterCertificate_eq_pairCertificate + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) (hc : C.size c = 2) : + localClusterCertificate A C (clusterAlpha X C) c = + pairCertificateValue A X (pairClusterRow C c hc 0) + (pairClusterRow C c hc 1) := by + rw [localClusterCertificate, pairCertificateValue] + simp_rw [clusterAlpha_eq_pair X C c hc] + rw [clusterInjectionPolynomial_eq_pair A C c hc] + +theorem singletonProductValue_eq_singletonFactor + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (i : Fin n) : + singletonProductValue A X i = singletonFactor A X i := by + have hXlt : βˆ€ j, X i j < 1 := fun j ↦ + hX.entry_lt_one_of_positive hXpos (by + simpa only [Fintype.card_fin] using + (lt_of_lt_of_le (by norm_num : 1 < 2) hcard)) i j + rw [singletonProductValue, singletonFactor, betheRowObjective, + Real.exp_sum] + apply Finset.prod_congr rfl + intro j _ + rw [Real.rpow_def_of_pos (div_pos (hA i j) (hXpos i j)), + Real.rpow_def_of_pos (sub_pos.mpr (hXlt j)), ← Real.exp_add] + congr 1 + rw [Real.negMulLog, Real.log_div (hA i j).ne' (hXpos i j).ne'] + ring + +/-- The paper's factor attached to a singleton-or-pair cluster. A clustering +of this kind is equivalent to a matching together with harmless names and an +ordering of the two rows in each matched pair. -/ +noncomputable def paperClusterFactor + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (hclusters : IsSingletonPairClustering C) (c : C.Cluster) : ℝ := + if hc : C.size c = 1 then + singletonFactor A X (singletonClusterRow C c hc) + else + let hc2 : C.size c = 2 := (hclusters c).resolve_left hc + pairCertificateValue A X (pairClusterRow C c hc2 0) + (pairClusterRow C c hc2 1) + +theorem localClusterCertificate_eq_paperClusterFactor + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hclusters : IsSingletonPairClustering C) (c : C.Cluster) : + localClusterCertificate A C (clusterAlpha X C) c = + paperClusterFactor A X C hclusters c := by + rw [paperClusterFactor] + split + next hc => + exact (localClusterCertificate_eq_singletonProduct C hA hX hXpos c hc).trans + (singletonProductValue_eq_singletonFactor hcard hA hX hXpos _) + next hc => + let hc2 : C.size c = 2 := (hclusters c).resolve_left hc + exact localClusterCertificate_eq_pairCertificate A X C c hc2 + +/-- The polynomial heart of the paired lower certificate. All clustering, +stability, coefficient-pairing, capacity monotonicity, and cancellation steps +are internal. The theorem keeps the stable-coefficient statement as an +explicit argument for modularity; `SourceStableReindex` discharges it from +Mathlib in the final theorem. -/ +theorem clusterCertificateValue_le_permanent + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hclusters : IsSingletonPairClustering C) : + clusterCertificateValue A C (clusterAlpha X C) ≀ Matrix.permanent A := by + let Ξ± := clusterAlpha X C + have hΞ±pos : βˆ€ v, 0 < Ξ± v := + clusterAlpha_pos_of_singletonPairs C hXpos hclusters + have hΞ±unit : βˆ€ v, 0 ≀ Ξ± v ∧ Ξ± v ≀ 1 := + clusterAlpha_in_unit_interval C hX + have hΞ±sum : βˆ‘ v, Ξ± v = n := clusterAlpha_total_sum C hX + have hA0 : Matrix.Nonnegative A := fun i j ↦ le_of_lt (hA i j) + have hstable := singletonPairCluster_stableCoefficient_lower + stableCoefficient C hcard hA hclusters Ξ± hΞ±unit hΞ±sum + have hcluster := clusterProductCapacityValue_le_capacity C hA0 Ξ± + have hselector := selectorCapacityValue_le_capacity hΞ±pos + (clusterAlpha_col_sum C hX) + have hboundary0 : 0 ≀ stableBoundaryFactor Ξ± := + stableBoundaryFactor_nonnegative hΞ±unit + have hcluster0 : 0 ≀ clusterProductCapacityValue A C Ξ± := + clusterProductCapacityValue_nonneg C hA0 Ξ± + have hselector0 : 0 ≀ selectorCapacityValue Ξ± := + le_of_lt (selectorCapacityValue_pos hΞ±pos) + have hcapCluster0 : + 0 ≀ polynomialCapacity Ξ± (rowClusterProduct A C) := + polynomialCapacity_nonneg (rowClusterProduct_nonnegativeCoefficients C hA0) Ξ± + have hreplaceCluster : + stableBoundaryFactor Ξ± * clusterProductCapacityValue A C Ξ± ≀ + stableBoundaryFactor Ξ± * polynomialCapacity Ξ± (rowClusterProduct A C) := + mul_le_mul_of_nonneg_left hcluster hboundary0 + have hreplaceCluster' : + stableBoundaryFactor Ξ± * clusterProductCapacityValue A C Ξ± * + selectorCapacityValue Ξ± ≀ + stableBoundaryFactor Ξ± * polynomialCapacity Ξ± (rowClusterProduct A C) * + selectorCapacityValue Ξ± := + mul_le_mul_of_nonneg_right hreplaceCluster hselector0 + have hreplaceSelector : + stableBoundaryFactor Ξ± * polynomialCapacity Ξ± (rowClusterProduct A C) * + selectorCapacityValue Ξ± ≀ + stableBoundaryFactor Ξ± * polynomialCapacity Ξ± (rowClusterProduct A C) * + polynomialCapacity Ξ± (columnSelector C.Cluster (Fin n)) := by + apply mul_le_mul_of_nonneg_left hselector + exact mul_nonneg hboundary0 hcapCluster0 + have hraw : + stableBoundaryFactor Ξ± * clusterProductCapacityValue A C Ξ± * + selectorCapacityValue Ξ± ≀ Matrix.permanent A := + hreplaceCluster'.trans (hreplaceSelector.trans hstable) + rw [clusterCertificateValue] + calc + clusterComplementFactor Ξ± * clusterProductCapacityValue A C Ξ± = + stableBoundaryFactor Ξ± * clusterProductCapacityValue A C Ξ± * + selectorCapacityValue Ξ± := by + rw [← stableBoundaryFactor_mul_selectorCapacityValue hΞ±pos] + ring + _ ≀ Matrix.permanent A := hraw + +/-- Paper Theorem 5 in an equivalent cluster presentation of a row matching. +The product contains one Bethe singleton factor for every unmatched row and +one pair-capacity factor for every matched pair. -/ +theorem pairedLowerCertificate_for_clustering + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hclusters : IsSingletonPairClustering C) : + (∏ c, paperClusterFactor A X C hclusters c) ≀ Matrix.permanent A := by + calc + (∏ c, paperClusterFactor A X C hclusters c) = + ∏ c, localClusterCertificate A C (clusterAlpha X C) c := by + apply Finset.prod_congr rfl + intro c _ + exact (localClusterCertificate_eq_paperClusterFactor C hcard hA hX + hXpos hclusters c).symm + _ = clusterCertificateValue A C (clusterAlpha X C) := + (clusterCertificateValue_eq_prod_local A C (clusterAlpha X C)).symm + _ ≀ Matrix.permanent A := + clusterCertificateValue_le_permanent stableCoefficient C hcard hA + hX hXpos hclusters + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ClusterFactors.lean b/LeanPool/BeyondBethe/BeyondBethe/ClusterFactors.lean new file mode 100644 index 0000000000..fdc716f9e5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ClusterFactors.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ClusterProduct +public import LeanPool.BeyondBethe.BeyondBethe.PairStability +public import Mathlib.Data.Fin.Tuple.Embedding + +/-! # Cluster Factors -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +theorem injectionPolynomial_reindex_rows + {m m' n : β„•} (B : Fin m β†’ Fin n β†’ ℝ) (e : Fin m ≃ Fin m') : + injectionPolynomial B = + injectionPolynomial (fun k j ↦ B (e.symm k) j) := by + rw [injectionPolynomial, injectionPolynomial] + let E := Equiv.embeddingCongr e (Equiv.refl (Fin n)) + calc + (βˆ‘ f : Fin m β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B k (f k))) = + βˆ‘ f : Fin m β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (E f k) 1) + (∏ k, B (e.symm k) (E f k)) := by + apply Finset.sum_congr rfl + intro f _ + have hexp : (βˆ‘ k, Finsupp.single (E f k) 1) = + βˆ‘ k, Finsupp.single (f k) 1 := by + simpa [E] using Equiv.sum_comp e.symm + (fun k ↦ Finsupp.single (f k) 1) + have hweight : (∏ k, B (e.symm k) (E f k)) = + ∏ k, B k (f k) := by + simpa [E] using Equiv.prod_comp e.symm + (fun k ↦ B k (f k)) + rw [hexp, hweight] + _ = βˆ‘ f : Fin m' β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B (e.symm k) (f k)) := + Equiv.sum_comp E (fun f ↦ + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B (e.symm k) (f k))) + +theorem injectionPolynomial_fin_one + {n : β„•} (B : Fin 1 β†’ Fin n β†’ ℝ) : + injectionPolynomial B = positiveLinearPolynomial (B 0) := by + rw [injectionPolynomial, positiveLinearPolynomial] + let e := Function.Embedding.oneEmbeddingEquiv (one := Fin 1) (Ξ± := Fin n) + calc + (βˆ‘ f : Fin 1 β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B k (f k))) = + βˆ‘ f : Fin 1 β†ͺ Fin n, + monomial (Finsupp.single (e f) 1) (B 0 (e f)) := by + apply Finset.sum_congr rfl + intro f _ + simp [e, Function.Embedding.oneEmbeddingEquiv] + _ = βˆ‘ j : Fin n, monomial (Finsupp.single j 1) (B 0 j) := + Equiv.sum_comp e + (fun j ↦ monomial (Finsupp.single j 1) (B 0 j)) + +theorem injectionPolynomial_fin_two + {n : β„•} (B : Fin 2 β†’ Fin n β†’ ℝ) : + injectionPolynomial B = pairPolynomial (B 0) (B 1) := by + rw [injectionPolynomial, pairPolynomial] + let e := Function.Embedding.twoEmbeddingEquiv (Ξ± := Fin n) + calc + (βˆ‘ f : Fin 2 β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B k (f k))) = + βˆ‘ f : Fin 2 β†ͺ Fin n, + monomial + (Finsupp.single (f 0) 1 + Finsupp.single (f 1) 1) + (B 0 (f 0) * B 1 (f 1)) := by + apply Finset.sum_congr rfl + intro f _ + simp [Fin.sum_univ_two, Fin.prod_univ_two] + _ = βˆ‘ p : {(a, b) : Fin n Γ— Fin n | a β‰  b}, + monomial + (Finsupp.single p.1.1 1 + Finsupp.single p.1.2 1) + (B 0 p.1.1 * B 1 p.1.2) := + by + simpa [e, Function.Embedding.twoEmbeddingEquiv] using + Equiv.sum_comp e (fun p ↦ + monomial + (Finsupp.single p.1.1 1 + Finsupp.single p.1.2 1) + (B 0 p.1.1 * B 1 p.1.2)) + _ = βˆ‘ p ∈ (Finset.univ : Finset (Fin n)).offDiag, + monomial + (Finsupp.single p.1 1 + Finsupp.single p.2 1) + (B 0 p.1 * B 1 p.2) := by + symm + apply Finset.sum_subtype + intro p + simp + +theorem injectionPolynomial_fin_one_isRealStable + {n : β„•} [Nonempty (Fin n)] {B : Fin 1 β†’ Fin n β†’ ℝ} + (hB : βˆ€ k j, 0 < B k j) : + IsRealStable (injectionPolynomial B) := by + rw [injectionPolynomial_fin_one] + exact positiveLinearPolynomial_isRealStable (fun j ↦ hB 0 j) + +theorem injectionPolynomial_fin_two_isRealStable + {n : β„•} {B : Fin 2 β†’ Fin n β†’ ℝ} + (hcard : 2 ≀ n) (hB : βˆ€ k j, 0 < B k j) : + IsRealStable (injectionPolynomial B) := by + rw [injectionPolynomial_fin_two] + exact pairPolynomial_isRealStable_of_pos (by simpa using hcard) + (fun j ↦ hB 0 j) (fun j ↦ hB 1 j) + +theorem rowClusterPolynomial_isRealStable_of_size_one + {n : β„•} [Nonempty (Fin n)] + {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : βˆ€ i j, 0 < A i j) (c : C.Cluster) + (hc : C.size c = 1) : + IsRealStable (rowClusterPolynomial A C c) := by + rw [rowClusterPolynomial_eq_rename_injectionPolynomial] + apply IsRealStable.rename + let e : Fin (C.size c) ≃ Fin 1 := (Fin.castOrderIso hc).toEquiv + rw [injectionPolynomial_reindex_rows _ e] + exact injectionPolynomial_fin_one_isRealStable + (fun k j ↦ hA (C.rows ⟨c, e.symm k⟩) j) + +theorem rowClusterPolynomial_isRealStable_of_size_two + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) (c : C.Cluster) + (hc : C.size c = 2) : + IsRealStable (rowClusterPolynomial A C c) := by + rw [rowClusterPolynomial_eq_rename_injectionPolynomial] + apply IsRealStable.rename + let e : Fin (C.size c) ≃ Fin 2 := (Fin.castOrderIso hc).toEquiv + rw [injectionPolynomial_reindex_rows _ e] + exact injectionPolynomial_fin_two_isRealStable hcard + (fun k j ↦ hA (C.rows ⟨c, e.symm k⟩) j) + +/-- Every cluster contains either one row or two rows. -/ +def IsSingletonPairClustering + {n : β„•} (C : RowClustering n) : Prop := + βˆ€ c, C.size c = 1 ∨ C.size c = 2 + +theorem rowClusterProduct_isRealStable_of_singletonPairs + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hclusters : IsSingletonPairClustering C) : + IsRealStable (rowClusterProduct A C) := by + letI : Nonempty (Fin n) := Fintype.card_pos_iff.mp (by + simpa using (lt_of_lt_of_le (by norm_num : 0 < 2) hcard)) + apply rowClusterProduct_isRealStable_of_factors + intro c + rcases hclusters c with hc | hc + Β· exact rowClusterPolynomial_isRealStable_of_size_one C hA c hc + Β· exact rowClusterPolynomial_isRealStable_of_size_two C hcard hA c hc + +theorem singletonPairCluster_stableCoefficient_lower + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hcard : 2 ≀ n) (hA : βˆ€ i j, 0 < A i j) + (hclusters : IsSingletonPairClustering C) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) + (hΞ± : βˆ€ v, 0 ≀ Ξ± v ∧ Ξ± v ≀ 1) + (hΞ±sum : (βˆ‘ v, Ξ± v) = n) : + stableBoundaryFactor Ξ± * + polynomialCapacity Ξ± (rowClusterProduct A C) * + polynomialCapacity Ξ± (columnSelector C.Cluster (Fin n)) ≀ + Matrix.permanent A := by + letI : Nonempty (Fin n) := Fintype.card_pos_iff.mp (by + simpa using (lt_of_lt_of_le (by norm_num : 0 < 2) hcard)) + letI : Nonempty C.Cluster := + ⟨(C.rows.symm (Classical.choice inferInstance)).1⟩ + apply rowClusterProduct_stableCoefficient_lower stableCoefficient C + Β· intro i j + exact le_of_lt (hA i j) + Β· exact fun c ↦ by + rcases hclusters c with hc | hc + Β· exact rowClusterPolynomial_isRealStable_of_size_one C hA c hc + Β· exact rowClusterPolynomial_isRealStable_of_size_two C hcard hA c hc + Β· exact hΞ± + Β· exact hΞ±sum + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ClusterProduct.lean b/LeanPool/BeyondBethe/BeyondBethe/ClusterProduct.lean new file mode 100644 index 0000000000..44c5b34456 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ClusterProduct.lean @@ -0,0 +1,533 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate + +/-! # Cluster Product -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +theorem prod_monomial + {Οƒ ΞΉ : Type*} [DecidableEq ΞΉ] + (s : Finset ΞΉ) (e : ΞΉ β†’ Οƒ β†’β‚€ β„•) (w : ΞΉ β†’ ℝ) : + ∏ i ∈ s, monomial (e i) (w i) = + monomial (βˆ‘ i ∈ s, e i) (∏ i ∈ s, w i) := by + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => + simp [ha, ih, monomial_mul] + +/-- An independent injection of the rows of each cluster into the columns. +Choices belonging to different clusters are not required to have disjoint +images; the column selector enforces that condition later. -/ +abbrev ClusterChoice {n : β„•} (C : RowClustering n) := + (c : C.Cluster) β†’ Fin (C.size c) β†ͺ Fin n + +/-- Aggregate map from all row slots to columns. -/ +def clusterChoiceMap + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) : + (Ξ£ c, Fin (C.size c)) β†’ Fin n := + fun s ↦ f s.1 s.2 + +/-- A cluster choice compatible with the column selector uses every column +exactly once. -/ +def IsGlobalClusterChoice + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) : Prop := + Function.Bijective (clusterChoiceMap C f) + +/-- Cluster column choices whose combined assignment is a bijection. -/ +abbrev GlobalClusterChoice {n : β„•} (C : RowClustering n) := + {f : ClusterChoice C // IsGlobalClusterChoice C f} + +/-- A permutation (columns to rows) induces the column choice of every row +slot by applying the inverse permutation to its row. -/ +noncomputable def permutationClusterChoice + {n : β„•} (C : RowClustering n) (Οƒ : Equiv.Perm (Fin n)) : + ClusterChoice C := + fun c ↦ + { toFun := fun k ↦ Οƒ.symm (C.rows ⟨c, k⟩) + inj' := by + intro k k' h + have hs : (⟨c, k⟩ : Ξ£ c, Fin (C.size c)) = ⟨c, k'⟩ := + C.rows.injective (Οƒ.symm.injective h) + simpa using hs } + +@[simp] +theorem permutationClusterChoice_apply + {n : β„•} (C : RowClustering n) (Οƒ : Equiv.Perm (Fin n)) + (c : C.Cluster) (k : Fin (C.size c)) : + permutationClusterChoice C Οƒ c k = Οƒ.symm (C.rows ⟨c, k⟩) := rfl + +theorem permutationClusterChoice_global + {n : β„•} (C : RowClustering n) (Οƒ : Equiv.Perm (Fin n)) : + IsGlobalClusterChoice C (permutationClusterChoice C Οƒ) := by + change Function.Bijective (fun s ↦ Οƒ.symm (C.rows s)) + exact Οƒ.symm.bijective.comp C.rows.bijective + +/-- Global cluster choices are exactly permutations. -/ +noncomputable def permutationGlobalClusterChoiceEquiv + {n : β„•} (C : RowClustering n) : + Equiv.Perm (Fin n) ≃ GlobalClusterChoice C where + toFun Οƒ := ⟨permutationClusterChoice C Οƒ, + permutationClusterChoice_global C ΟƒβŸ© + invFun f := + (Equiv.ofBijective (clusterChoiceMap C f.1) f.2).symm.trans C.rows + left_inv Οƒ := by + apply Equiv.ext + intro j + let e := Equiv.ofBijective + (clusterChoiceMap C (permutationClusterChoice C Οƒ)) + (permutationClusterChoice_global C Οƒ) + change C.rows (e.symm j) = Οƒ j + apply Οƒ.symm.injective + rw [Οƒ.symm_apply_apply] + have he := e.apply_symm_apply j + change clusterChoiceMap C (permutationClusterChoice C Οƒ) (e.symm j) = j at he + exact he + right_inv f := by + apply Subtype.ext + funext c + apply Function.Embedding.ext + intro k + simp [clusterChoiceMap, permutationClusterChoice, Equiv.ofBijective_apply] + rfl + +noncomputable instance globalClusterChoiceFintype + {n : β„•} (C : RowClustering n) : Fintype (GlobalClusterChoice C) := + Fintype.ofEquiv (Equiv.Perm (Fin n)) + (permutationGlobalClusterChoiceEquiv C) + +/-- Exponent vector contributed by a family of independent cluster choices. -/ +noncomputable def clusterChoiceExponent + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) : + C.Cluster Γ— Fin n β†’β‚€ β„• := + βˆ‘ c, βˆ‘ k, Finsupp.single (c, f c k) 1 + +@[simp] +theorem clusterChoiceExponent_apply + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) + (c : C.Cluster) (j : Fin n) : + clusterChoiceExponent C f (c, j) = + ((Finset.univ : Finset (Fin (C.size c))).filter + (fun k ↦ f c k = j)).card := by + classical + simp [clusterChoiceExponent, Finsupp.single_apply] + rw [Finset.sum_eq_single c] + Β· congr 1 + ext k + simp + Β· intro b _ hbc + simp [hbc] + Β· simp + +/-- A cluster-choice monomial lies in the selector support exactly when the +aggregate choice is a bijection from row slots to columns. -/ +theorem exists_selectorExponent_eq_iff_global + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) : + (βˆƒ h : Fin n β†’ C.Cluster, + clusterChoiceExponent C f = selectorExponent h) ↔ + IsGlobalClusterChoice C f := by + classical + constructor + Β· rintro ⟨h, he⟩ + constructor + Β· rintro ⟨c, k⟩ ⟨d, l⟩ hsame + have hcpos : 0 < clusterChoiceExponent C f (c, f c k) := by + rw [clusterChoiceExponent_apply] + exact Finset.card_pos.mpr ⟨k, by simp⟩ + have hdpos : 0 < clusterChoiceExponent C f (d, f d l) := by + rw [clusterChoiceExponent_apply] + exact Finset.card_pos.mpr ⟨l, by simp⟩ + rw [he, selectorExponent_apply] at hcpos hdpos + have hc : c = h (f c k) := by + by_contra hne + simp [hne] at hcpos + have hd : d = h (f d l) := by + by_contra hne + simp [hne] at hdpos + have hcd : c = d := by + change f c k = f d l at hsame + rw [hc, hd, hsame] + subst d + have hkl : k = l := (f c).injective hsame + subst l + rfl + Β· intro j + have hone : clusterChoiceExponent C f (h j, j) = 1 := by + rw [he, selectorExponent_apply] + simp + rw [clusterChoiceExponent_apply] at hone + have hnonempty : + ((Finset.univ : Finset (Fin (C.size (h j)))).filter + (fun k ↦ f (h j) k = j)).Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro hempty + rw [hempty] at hone + simp at hone + obtain ⟨k, hk⟩ := hnonempty + exact ⟨⟨h j, k⟩, (Finset.mem_filter.mp hk).2⟩ + Β· intro hglobal + let e := Equiv.ofBijective (clusterChoiceMap C f) hglobal + refine ⟨fun j ↦ (e.symm j).1, ?_⟩ + ext v + rcases v with ⟨c, j⟩ + rw [clusterChoiceExponent_apply, selectorExponent_apply] + by_cases hc : c = (e.symm j).1 + Β· subst c + have hs : + ((Finset.univ : Finset (Fin (C.size (e.symm j).1))).filter + (fun k ↦ f (e.symm j).1 k = j)) = + {(e.symm j).2} := by + ext k + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_singleton] + constructor + Β· intro hk + have hmaps : clusterChoiceMap C f ⟨(e.symm j).1, k⟩ = + clusterChoiceMap C f (e.symm j) := by + change f (e.symm j).1 k = clusterChoiceMap C f (e.symm j) + rw [hk] + exact (e.apply_symm_apply j).symm + have hslots : (⟨(e.symm j).1, k⟩ : Ξ£ c, Fin (C.size c)) = e.symm j := + e.injective hmaps + have hslots' : + (⟨(e.symm j).1, k⟩ : Ξ£ c, Fin (C.size c)) = + ⟨(e.symm j).1, (e.symm j).2⟩ := + hslots.trans (Sigma.eta (e.symm j)).symm + exact eq_of_heq (Sigma.mk.inj_iff.mp hslots').2 + Β· intro hk + subst k + have he := e.apply_symm_apply j + change f (e.symm j).1 (e.symm j).2 = j at he + exact he + rw [hs] + simp + Β· have hs : + ((Finset.univ : Finset (Fin (C.size c))).filter + (fun k ↦ f c k = j)) = βˆ… := by + ext k + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + Β· intro hk + have hmaps : clusterChoiceMap C f ⟨c, k⟩ = + clusterChoiceMap C f (e.symm j) := by + change f c k = clusterChoiceMap C f (e.symm j) + rw [hk] + exact (e.apply_symm_apply j).symm + have hslots : (⟨c, k⟩ : Ξ£ c, Fin (C.size c)) = e.symm j := + e.injective hmaps + exact (hc (congrArg Sigma.fst hslots)).elim + Β· simp + rw [hs] + simp [hc] + +theorem sum_selector_matches_choice_of_global + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) (w : ℝ) + (hg : IsGlobalClusterChoice C f) : + (βˆ‘ h : Fin n β†’ C.Cluster, + if clusterChoiceExponent C f = selectorExponent h then w else 0) = w := by + classical + obtain ⟨h, he⟩ := (exists_selectorExponent_eq_iff_global C f).mpr hg + rw [Finset.sum_eq_single h] + Β· simp [he] + Β· intro h' _ hh' + have hne : clusterChoiceExponent C f β‰  selectorExponent h' := by + intro he' + apply hh' + exact (selectorExponent_injective (he.symm.trans he')).symm + simp [hne] + Β· simp + +theorem sum_selector_matches_choice_of_not_global + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) (w : ℝ) + (hg : Β¬IsGlobalClusterChoice C f) : + (βˆ‘ h : Fin n β†’ C.Cluster, + if clusterChoiceExponent C f = selectorExponent h then w else 0) = 0 := by + classical + apply Finset.sum_eq_zero + intro h _ + have hne : clusterChoiceExponent C f β‰  selectorExponent h := by + intro he + exact hg ((exists_selectorExponent_eq_iff_global C f).mp ⟨h, he⟩) + simp [hne] + +/-- Matrix weight contributed by a family of independent cluster choices. -/ +noncomputable def clusterChoiceWeight + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (f : ClusterChoice C) : ℝ := + ∏ c, ∏ k, A (C.rows ⟨c, k⟩) (f c k) + +theorem sum_clusterSizes_eq + {n : β„•} (C : RowClustering n) : + (βˆ‘ c, C.size c) = n := by + calc + (βˆ‘ c, C.size c) = βˆ‘ c, Fintype.card (Fin (C.size c)) := by simp + _ = Fintype.card (Ξ£ c, Fin (C.size c)) := Fintype.card_sigma.symm + _ = Fintype.card (Fin n) := Fintype.card_congr C.rows + _ = n := Fintype.card_fin n + +theorem clusterChoiceExponent_degree + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) : + Finsupp.degree (clusterChoiceExponent C f) = n := by + rw [clusterChoiceExponent, map_sum] + simp [map_sum, Finsupp.degree_single, sum_clusterSizes_eq C] + +theorem clusterChoiceExponent_le_one + {n : β„•} (C : RowClustering n) (f : ClusterChoice C) + (v : C.Cluster Γ— Fin n) : + clusterChoiceExponent C f v ≀ 1 := by + rcases v with ⟨c, j⟩ + rw [clusterChoiceExponent_apply] + apply Finset.card_le_one.mpr + intro k hk l hl + exact (f c).injective ((Finset.mem_filter.mp hk).2.trans + (Finset.mem_filter.mp hl).2.symm) + +theorem clusterChoiceWeight_permutation + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (Οƒ : Equiv.Perm (Fin n)) : + clusterChoiceWeight A C (permutationClusterChoice C Οƒ) = + ∏ j, A (Οƒ j) j := by + rw [clusterChoiceWeight] + calc + (∏ c, ∏ k, A (C.rows ⟨c, k⟩) + (permutationClusterChoice C Οƒ c k)) = + ∏ s : Ξ£ c, Fin (C.size c), + A (C.rows s) (Οƒ.symm (C.rows s)) := by + rw [Fintype.prod_sigma] + rfl + _ = ∏ i, A i (Οƒ.symm i) := + Equiv.prod_comp C.rows (fun i ↦ A i (Οƒ.symm i)) + _ = ∏ j, A (Οƒ j) j := by + symm + simpa using Equiv.prod_comp Οƒ (fun i ↦ A i (Οƒ.symm i)) + +theorem sum_globalClusterChoiceWeight_eq_permanent + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + (βˆ‘ f : GlobalClusterChoice C, clusterChoiceWeight A C f.1) = + Matrix.permanent A := by + rw [Matrix.permanent] + symm + calc + (βˆ‘ Οƒ : Equiv.Perm (Fin n), ∏ j, A (Οƒ j) j) = + βˆ‘ Οƒ : Equiv.Perm (Fin n), + clusterChoiceWeight A C + (permutationGlobalClusterChoiceEquiv C Οƒ).1 := by + apply Finset.sum_congr rfl + intro Οƒ _ + exact (clusterChoiceWeight_permutation A C Οƒ).symm + _ = βˆ‘ f : GlobalClusterChoice C, clusterChoiceWeight A C f.1 := + Equiv.sum_comp (permutationGlobalClusterChoiceEquiv C) + (fun f ↦ clusterChoiceWeight A C f.1) + +/-- The polynomial for one row cluster. Its monomials inject the rows in the +cluster into distinct columns. For clusters of sizes one and two these are, +respectively, the singleton linear form and the pair polynomial of the paper. -/ +noncomputable def rowClusterPolynomial + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) : MvPolynomial (C.Cluster Γ— Fin n) ℝ := + βˆ‘ f : Fin (C.size c) β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (c, f k) 1) + (∏ k, A (C.rows ⟨c, k⟩) (f k)) + +/-- The same injection polynomial before placing its variables in a named +cluster. -/ +noncomputable def injectionPolynomial + {m n : β„•} (B : Fin m β†’ Fin n β†’ ℝ) : MvPolynomial (Fin n) ℝ := + βˆ‘ f : Fin m β†ͺ Fin n, + monomial (βˆ‘ k, Finsupp.single (f k) 1) + (∏ k, B k (f k)) + +theorem injectionPolynomial_nonnegativeCoefficients + {m n : β„•} {B : Fin m β†’ Fin n β†’ ℝ} + (hB : βˆ€ k j, 0 ≀ B k j) : + HasNonnegativeCoefficients (injectionPolynomial B) := by + intro d + rw [injectionPolynomial, coeff_sum] + apply Finset.sum_nonneg + intro f _ + rw [coeff_monomial] + split + Β· exact Finset.prod_nonneg fun k _ ↦ hB k (f k) + Β· exact le_rfl + +theorem rowClusterPolynomial_eq_rename_injectionPolynomial + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) : + rowClusterPolynomial A C c = + MvPolynomial.rename (fun j : Fin n ↦ (c, j)) + (injectionPolynomial (fun k j ↦ A (C.rows ⟨c, k⟩) j)) := by + rw [rowClusterPolynomial, injectionPolynomial, map_sum] + apply Finset.sum_congr rfl + intro f _ + rw [rename_monomial] + have hexp : + Finsupp.mapDomain (fun j : Fin n ↦ (c, j)) + (βˆ‘ k, Finsupp.single (f k) 1) = + βˆ‘ k, Finsupp.single (c, f k) 1 := by + simpa only [Finsupp.mapDomain_single, + Finsupp.mapDomain.addMonoidHom_apply] using + map_sum (Finsupp.mapDomain.addMonoidHom + (fun j : Fin n ↦ (c, j))) + (fun k ↦ Finsupp.single (f k) 1) Finset.univ + rw [hexp] + +/-- The full cluster product `p` in paper equation (10). -/ +noncomputable def rowClusterProduct + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + MvPolynomial (C.Cluster Γ— Fin n) ℝ := + ∏ c, rowClusterPolynomial A C c + +/-- Expanding the product makes the independent choice made by every cluster +explicit. Collisions between different clusters remain present here. -/ +theorem rowClusterProduct_eq_sum_choices + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + rowClusterProduct A C = + βˆ‘ f : ClusterChoice C, + monomial (clusterChoiceExponent C f) (clusterChoiceWeight A C f) := by + simp only [rowClusterProduct, rowClusterPolynomial] + rw [Fintype.prod_sum] + apply Finset.sum_congr rfl + intro f _ + rw [clusterChoiceExponent, clusterChoiceWeight] + simpa using prod_monomial (Finset.univ : Finset C.Cluster) + (fun c ↦ βˆ‘ k, Finsupp.single (c, f c k) 1) + (fun c ↦ ∏ k, A (C.rows ⟨c, k⟩) (f c k)) + +theorem rowClusterPolynomial_isHomogeneous + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (c : C.Cluster) : + (rowClusterPolynomial A C c).IsHomogeneous (C.size c) := by + rw [rowClusterPolynomial] + apply MvPolynomial.IsHomogeneous.sum + intro f _ + apply isHomogeneous_monomial + rw [map_sum] + simp [Finsupp.degree_single] + +theorem rowClusterProduct_isHomogeneous + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + (rowClusterProduct A C).IsHomogeneous n := by + rw [rowClusterProduct] + have h := MvPolynomial.IsHomogeneous.prod Finset.univ + (rowClusterPolynomial A C) C.size + (fun c _ ↦ rowClusterPolynomial_isHomogeneous A C c) + simpa only [sum_clusterSizes_eq C] using h + +theorem rowClusterProduct_nonnegativeCoefficients + {n : β„•} {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + (hA : Matrix.Nonnegative A) : + HasNonnegativeCoefficients (rowClusterProduct A C) := by + intro d + rw [rowClusterProduct_eq_sum_choices, coeff_sum] + apply Finset.sum_nonneg + intro f _ + rw [coeff_monomial] + split + Β· exact Finset.prod_nonneg fun c _ ↦ + Finset.prod_nonneg fun k _ ↦ hA (C.rows ⟨c, k⟩) (f c k) + Β· exact le_rfl + +theorem rowClusterProduct_isMultiaffine + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + IsMultiaffine (rowClusterProduct A C) := by + intro v + rw [rowClusterProduct_eq_sum_choices] + refine (degreeOf_sum_le v _ _).trans (Finset.sup_le ?_) + intro f _ + by_cases hw : clusterChoiceWeight A C f = 0 + Β· simp [hw] + Β· rw [degreeOf_monomial_eq _ _ hw] + exact clusterChoiceExponent_le_one C f v + +theorem rowClusterProduct_isRealStable_of_factors + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + (hstable : βˆ€ c, IsRealStable (rowClusterPolynomial A C c)) : + IsRealStable (rowClusterProduct A C) := by + intro z hz + rw [rowClusterProduct, MvPolynomial.evalβ‚‚_prod] + apply Finset.prod_ne_zero_iff.mpr + intro c _ + exact hstable c z hz + +/- Paper equation (12), now for the actual product of cluster factors rather +than for its selector-compatible truncation. Independent cluster choices +that collide at a column disappear from the coefficient pairing; the +remaining choices are exactly permutations. -/ +theorem coefficientInnerProduct_rowClusterProduct_eq_permanent + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + coefficientInnerProduct (rowClusterProduct A C) + (columnSelector C.Cluster (Fin n)) = Matrix.permanent A := by + classical + rw [coefficientInnerProduct_columnSelector, + rowClusterProduct_eq_sum_choices] + simp_rw [coeff_sum, coeff_monomial] + rw [Finset.sum_comm] + calc + (βˆ‘ f : ClusterChoice C, βˆ‘ h : Fin n β†’ C.Cluster, + if clusterChoiceExponent C f = selectorExponent h then + clusterChoiceWeight A C f else 0) = + βˆ‘ f ∈ (Finset.univ : Finset (ClusterChoice C)).filter + (IsGlobalClusterChoice C), clusterChoiceWeight A C f := by + rw [Finset.sum_filter] + apply Finset.sum_congr rfl + intro f _ + by_cases hg : IsGlobalClusterChoice C f + Β· rw [ite_eq_left hg, + sum_selector_matches_choice_of_global C f _ hg] + Β· rw [ite_eq_right hg, + sum_selector_matches_choice_of_not_global C f _ hg] + _ = βˆ‘ f : GlobalClusterChoice C, clusterChoiceWeight A C f.1 := by + apply Finset.sum_subtype + intro f + simp + _ = Matrix.permanent A := sum_globalClusterChoiceWeight_eq_permanent A C + +/-- The stable-coefficient theorem applied to the actual cluster product and +column selector. All polynomial hypotheses and the permanent coefficient +identity are discharged internally. The coefficient inequality remains an +explicit argument here to keep this intermediate theorem modular; the final +theorem supplies its internal reconstruction from `SourceStableReindex`. -/ +theorem rowClusterProduct_stableCoefficient_lower + {n : β„•} [Nonempty (Fin n)] + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A : Matrix (Fin n) (Fin n) ℝ} (C : RowClustering n) + [Nonempty C.Cluster] + (hA : Matrix.Nonnegative A) + (hfactorStable : βˆ€ c, IsRealStable (rowClusterPolynomial A C c)) + (Ξ± : C.Cluster Γ— Fin n β†’ ℝ) + (hΞ± : βˆ€ v, 0 ≀ Ξ± v ∧ Ξ± v ≀ 1) + (hΞ±sum : (βˆ‘ v, Ξ± v) = n) : + stableBoundaryFactor Ξ± * + polynomialCapacity Ξ± (rowClusterProduct A C) * + polynomialCapacity Ξ± (columnSelector C.Cluster (Fin n)) ≀ + Matrix.permanent A := by + have hselectorHomogeneous : + (columnSelector C.Cluster (Fin n)).IsHomogeneous n := by + simpa only [Fintype.card_fin] using + columnSelector_isHomogeneous C.Cluster (Fin n) + have hpair := stableCoefficient (Οƒ := C.Cluster Γ— Fin n) + (rowClusterProduct A C) (columnSelector C.Cluster (Fin n)) n Ξ± + (rowClusterProduct_nonnegativeCoefficients C hA) + (columnSelector_nonnegativeCoefficients C.Cluster (Fin n)) + (rowClusterProduct_isMultiaffine A C) + (columnSelector_isMultiaffine C.Cluster (Fin n)) + (rowClusterProduct_isRealStable_of_factors A C hfactorStable) + (columnSelector_isRealStable C.Cluster (Fin n)) + (rowClusterProduct_isHomogeneous A C) + hselectorHomogeneous + hΞ± hΞ±sum + rwa [coefficientInnerProduct_rowClusterProduct_eq_permanent] at hpair + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Completion.lean b/LeanPool/BeyondBethe/BeyondBethe/Completion.lean new file mode 100644 index 0000000000..340093f848 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Completion.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import Mathlib.Analysis.SpecialFunctions.ExpDeriv +public import Mathlib.Analysis.SpecialFunctions.Pow.Real + +/-! # Completion -/ + +@[expose] public section + +namespace BeyondBethe + +/-- The improvement in the positive-matrix dichotomy (paper (46)). -/ +noncomputable def epsilonPlus (Ξ΄ ΞΎ Ξ³ : ℝ) : ℝ := + min (Ξ΄ - ΞΎ) (3 * Ξ³ / 8 - ΞΎ) + +theorem epsilonPlus_pos {Ξ΄ ΞΎ Ξ³ : ℝ} + (hΞ΄ : ΞΎ < Ξ΄) (hΞ³ : ΞΎ < 3 * Ξ³ / 8) : + 0 < epsilonPlus Ξ΄ ΞΎ Ξ³ := by + rw [epsilonPlus, lt_min_iff] + exact ⟨sub_pos.mpr hΞ΄, sub_pos.mpr hγ⟩ + +/-- The two cases in Proposition 20 combine to the exponent in (45). -/ +theorem positiveDichotomy_exponent + {n : β„•} {r Ξ΄ ΞΎ Ξ³ : ℝ} + (h : r ≀ (Real.log 2 / 2 - Ξ΄ + ΞΎ) * n ∨ + r ≀ (Real.log 2 / 2 + ΞΎ - 3 * Ξ³ / 8) * n) : + r ≀ (Real.log 2 / 2 - epsilonPlus Ξ΄ ΞΎ Ξ³) * n := by + rcases h with hfar | hnear + Β· refine hfar.trans (mul_le_mul_of_nonneg_right ?_ (Nat.cast_nonneg n)) + rw [epsilonPlus] + have hmin : min (Ξ΄ - ΞΎ) (3 * Ξ³ / 8 - ΞΎ) ≀ Ξ΄ - ΞΎ := min_le_left _ _ + linarith + Β· refine hnear.trans (mul_le_mul_of_nonneg_right ?_ (Nat.cast_nonneg n)) + rw [epsilonPlus] + have hmin : min (Ξ΄ - ΞΎ) (3 * Ξ³ / 8 - ΞΎ) ≀ 3 * Ξ³ / 8 - ΞΎ := min_le_right _ _ + linarith + +/-- Paper (65): in the far case, Bethe slack pays for the logarithmic gap; +the paired gain can only help. -/ +theorem farCase_logGap + {n : β„•} {logPermanent logBethe objective gain Ξ΄ ΞΎ : ℝ} + (hslack : Ξ΄ * n ≀ betheSlack n logBethe logPermanent) + (hobjective : logBethe - ΞΎ * n ≀ objective) + (hgain : 0 ≀ gain) : + logPermanent - (objective + gain) ≀ + (Real.log 2 / 2 - Ξ΄ + ΞΎ) * n := by + rw [betheSlack] at hslack + nlinarith + +/-- Paper (69): in the near case, the matching gain subtracts directly from +the upper half of the Bethe sandwich. -/ +theorem nearCase_logGap + {n : β„•} {logPermanent logBethe objective gain Ξ³ ΞΎ : ℝ} + (hupper : logPermanent ≀ logBethe + n * (Real.log 2 / 2)) + (hobjective : logBethe - ΞΎ * n ≀ objective) + (hgain : 3 * Ξ³ / 8 * n ≀ gain) : + logPermanent - (objective + gain) ≀ + (Real.log 2 / 2 + ΞΎ - 3 * Ξ³ / 8) * n := by + nlinarith + +/-- The proof's far/near split with the structural part of the near case +isolated in one explicit implication. -/ +theorem completionCaseDisjunction + {n : β„•} + {logPermanent logBethe objective gain Ξ΄ ΞΎ Ξ³ : ℝ} + (hobjective : logBethe - ΞΎ * n ≀ objective) + (hgainNonneg : 0 ≀ gain) + (hupper : logPermanent ≀ logBethe + n * (Real.log 2 / 2)) + (hnearGain : betheSlack n logBethe logPermanent < Ξ΄ * n β†’ + 3 * Ξ³ / 8 * n ≀ gain) : + logPermanent - (objective + gain) ≀ + (Real.log 2 / 2 - Ξ΄ + ΞΎ) * n ∨ + logPermanent - (objective + gain) ≀ + (Real.log 2 / 2 + ΞΎ - 3 * Ξ³ / 8) * n := by + by_cases hfar : Ξ΄ * n ≀ betheSlack n logBethe logPermanent + Β· exact Or.inl (farCase_logGap hfar hobjective hgainNonneg) + Β· exact Or.inr (nearCase_logGap hupper hobjective + (hnearGain (lt_of_not_ge hfar))) + +/-- Quantitative count used in the near case: the row and long-component +losses leave at least `59 n / 128` clean pairs. -/ +theorem cleanPair_count_ge_fiftyNine + {n bad long clean : ℝ} + (hbad : bad ≀ n / 128) (hlong : long ≀ n / 16) + (hclean : n - 2 * bad - long ≀ 2 * clean) : + 59 * n / 128 ≀ clean := by + linarith + +/-- After discarding at most `n/16` expensive pairs, the remaining disjoint +clean pairs number at least `3n/8`. -/ +theorem successfulCleanPair_count_ge_threeEighths + {n clean failed successful : ℝ} + (hn : 0 ≀ n) (hclean : 59 * n / 128 ≀ clean) + (hfailed : failed ≀ n / 16) + (hsuccess : clean - failed ≀ successful) : + 3 * n / 8 ≀ successful := by + linarith + +/-- Multiplying the successful-pair count by the uniform gain gives paper +(68). -/ +theorem matchingGain_ge_threeEighths + {n successful Ξ³ matchingGain : ℝ} + (hΞ³ : 0 ≀ Ξ³) (hsuccess : 3 * n / 8 ≀ successful) + (hmatching : successful * Ξ³ ≀ matchingGain) : + 3 * Ξ³ / 8 * n ≀ matchingGain := by + nlinarith + +/-- Rearrangement of the robust cycle-information inequality used in (66). +The displayed definition of `cycleError` is kept as a hypothesis so this +lemma remains the exact scalar accounting step. -/ +theorem longRow_count_le_cycleError + {n D N bad Ξ΄ rowError Ο‰ cycleError : ℝ} + (hn : 0 ≀ n) + (hlogD : D ≀ Ξ΄ * n) + (hbad : bad ≀ rowError * n) + (hrobust : Real.log 2 / 6 * N - + (1 + Real.log 2 / 2) * bad - n * Ο‰ ≀ D) + (hcycle : cycleError = 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * rowError + Ο‰)) : + N ≀ cycleError * n := by + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hscale : Real.log 2 / 6 * cycleError = + Ξ΄ + (1 + Real.log 2 / 2) * rowError + Ο‰ := by + rw [hcycle] + field_simp [hlog.ne'] + have hscaled : Real.log 2 / 6 * N ≀ + Real.log 2 / 6 * (cycleError * n) := by + nlinarith [mul_le_mul_of_nonneg_left hbad + (show 0 ≀ 1 + Real.log 2 / 2 by positivity)] + exact le_of_mul_le_mul_left hscaled + (div_pos hlog (by norm_num : (0 : ℝ) < 6)) + +/-- The Markov step for expensive clean pairs after (67), abstracted from +the graph indexing: cancel their common positive minimum cost. -/ +theorem failedPair_count_le_transferError + {failed transferError n minCost totalCost : ℝ} + (hmin : 0 < minCost) + (hfailed : failed * minCost ≀ totalCost) + (htotal : totalCost ≀ transferError * n * minCost) : + failed ≀ transferError * n := by + exact le_of_mul_le_mul_right (hfailed.trans htotal) hmin + +/-- Exponentiating the logarithmic bound uses exactly the base appearing in +paper Proposition 20. -/ +theorem exp_logTwoHalf_sub (Ξ΅ : ℝ) : + Real.exp (Real.log 2 / 2 - Ξ΅) = + Real.sqrt 2 * Real.exp (-Ξ΅) := by + rw [sub_eq_add_neg, Real.exp_add] + congr 1 + rw [← Real.exp_log (Real.sqrt_pos.2 (by norm_num : (0 : ℝ) < 2))] + congr 1 + rw [Real.log_sqrt (by norm_num : (0 : ℝ) ≀ 2)] + +theorem logGap_implies_positive_approximation + {n : β„•} {L per Ξ΅ : ℝ} + (hL : 0 < L) (hper : 0 < per) + (hlog : Real.log per - Real.log L ≀ + (Real.log 2 / 2 - Ξ΅) * n) : + per ≀ (Real.sqrt 2 * Real.exp (-Ξ΅)) ^ n * L := by + have hexp := Real.exp_le_exp.mpr hlog + have hleft : Real.exp (Real.log per - Real.log L) = per / L := by + rw [Real.exp_sub, Real.exp_log hper, Real.exp_log hL] + have hright : Real.exp ((Real.log 2 / 2 - Ξ΅) * n) = + (Real.sqrt 2 * Real.exp (-Ξ΅)) ^ n := by + rw [Real.exp_mul, Real.rpow_natCast, exp_logTwoHalf_sub] + rw [hleft, hright] at hexp + exact (div_le_iffβ‚€ hL).mp hexp + +/-- Exact scalar assembly of paper Proposition 20. The disjunction consists +of the far-slack and near-tight estimates proved in the two structural cases. -/ +theorem positiveDichotomy_approximation + {n : β„•} {L per Ξ΄ ΞΎ Ξ³ : ℝ} + (hL : 0 < L) (hper : 0 < per) + (hcases : + Real.log per - Real.log L ≀ + (Real.log 2 / 2 - Ξ΄ + ΞΎ) * n ∨ + Real.log per - Real.log L ≀ + (Real.log 2 / 2 + ΞΎ - 3 * Ξ³ / 8) * n) : + per ≀ + (Real.sqrt 2 * Real.exp (-epsilonPlus Ξ΄ ΞΎ Ξ³)) ^ n * L := by + apply logGap_implies_positive_approximation hL hper + exact positiveDichotomy_exponent hcases + +/-- Two-sided form of the positive-matrix conclusion, conditional on the +paired certificate lower bound and the two case estimates. -/ +theorem positiveDichotomy_twoSided + {n : β„•} {L per Ξ΄ ΞΎ Ξ³ : ℝ} + (hL : 0 < L) (hper : 0 < per) (hlower : L ≀ per) + (hcases : + Real.log per - Real.log L ≀ + (Real.log 2 / 2 - Ξ΄ + ΞΎ) * n ∨ + Real.log per - Real.log L ≀ + (Real.log 2 / 2 + ΞΎ - 3 * Ξ³ / 8) * n) : + L ≀ per ∧ + per ≀ (Real.sqrt 2 * Real.exp (-epsilonPlus Ξ΄ ΞΎ Ξ³)) ^ n * L := + ⟨hlower, positiveDichotomy_approximation hL hper hcases⟩ + +/-- Positive-matrix proposition with its remaining structural obligation +shown explicitly as `hnearGain`. This is the exact boundary between the +already checked analytic assembly and the good-row/cycle/transfer counting +argument. -/ +theorem positiveMatrix_twoSided_of_nearGain + {n : β„•} {L per logBethe objective gain Ξ΄ ΞΎ Ξ³ : ℝ} + (hL : 0 < L) (hper : 0 < per) (hlower : L ≀ per) + (hlogL : Real.log L = objective + gain) + (hobjective : logBethe - ΞΎ * n ≀ objective) + (hgainNonneg : 0 ≀ gain) + (hupper : Real.log per ≀ logBethe + n * (Real.log 2 / 2)) + (hnearGain : betheSlack n logBethe (Real.log per) < Ξ΄ * n β†’ + 3 * Ξ³ / 8 * n ≀ gain) : + L ≀ per ∧ + per ≀ (Real.sqrt 2 * Real.exp (-epsilonPlus Ξ΄ ΞΎ Ξ³)) ^ n * L := by + apply positiveDichotomy_twoSided hL hper hlower + rw [hlogL] + exact completionCaseDisjunction hobjective hgainNonneg hupper hnearGain + +/-- The numerical and smoothing losses in the appendix consume at most half +of the positive-matrix logarithmic improvement. -/ +theorem numerical_smoothing_loss + {Ξ΅ numericalLoss smoothingLoss : ℝ} + (hnum : numericalLoss ≀ Ξ΅ / 4) + (hsmooth : smoothingLoss ≀ Ξ΅ / 4) : + -Ξ΅ + numericalLoss + smoothingLoss ≀ -Ξ΅ / 2 := by + linarith + +/-- The purely numerical conclusion of Theorem 1, separated from its +bit-complexity assertion. -/ +def ApproximationGuarantee + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) (c : ℝ) : Prop := + 0 < c ∧ c < Real.sqrt 2 ∧ + βˆ€ n (A : Matrix (Fin n) (Fin n) β„š), + Matrix.Nonnegative A β†’ + ((alg n A : β„š) : ℝ) ≀ ((Matrix.permanent A : β„š) : ℝ) ∧ + ((Matrix.permanent A : β„š) : ℝ) ≀ c ^ n * ((alg n A : β„š) : ℝ) + +/-- The last scalar step in the paper: any positive logarithmic improvement +produces a base strictly below `sqrt 2`. -/ +theorem improvedBase_lt_sqrtTwo {Ξ΅ : ℝ} (hΞ΅ : 0 < Ξ΅) : + Real.sqrt 2 * Real.exp (-Ξ΅) < Real.sqrt 2 := by + have hsqrt : 0 < Real.sqrt 2 := Real.sqrt_pos.2 (by norm_num) + have hexp : Real.exp (-Ξ΅) < 1 := by + simpa only [Real.exp_zero] using Real.exp_lt_exp.mpr (neg_neg_of_pos hΞ΅) + nlinarith [mul_lt_mul_of_pos_left hexp hsqrt] + +/-- The final base (paper (59)). -/ +noncomputable def finalBase (Ξ΅ : ℝ) : ℝ := + Real.sqrt 2 * Real.exp (-Ξ΅ / 2) + +theorem finalBase_lt_sqrtTwo {Ξ΅ : ℝ} (hΞ΅ : 0 < Ξ΅) : + finalBase Ξ΅ < Real.sqrt 2 := by + rw [finalBase] + have hhalf : 0 < Ξ΅ / 2 := by linarith + simpa only [neg_div] using improvedBase_lt_sqrtTwo hhalf + +theorem finalBase_pos (Ξ΅ : ℝ) : 0 < finalBase Ξ΅ := by + exact mul_pos (Real.sqrt_pos.2 (by norm_num)) (Real.exp_pos _) + +/-- The base available before paying for smoothing and directed numerical +rounding. The certified computation is allowed to spend one quarter of the +positive-matrix improvement. -/ +noncomputable def preSmoothingBase (Ξ΅ : ℝ) : ℝ := + Real.sqrt 2 * Real.exp (-Ξ΅ + Ξ΅ / 4) + +theorem preSmoothingBase_pos (Ξ΅ : ℝ) : 0 < preSmoothingBase Ξ΅ := by + exact mul_pos (Real.sqrt_pos.2 (by norm_num)) (Real.exp_pos _) + +theorem preSmoothingBase_mul_exp_quarter (Ξ΅ : ℝ) : + preSmoothingBase Ξ΅ * Real.exp (Ξ΅ / 4) = finalBase Ξ΅ := by + rw [preSmoothingBase, finalBase] + rw [mul_assoc, ← Real.exp_add] + congr 1 + ring + +/-- The scalar completion of the smoothing argument. This theorem is the +exact non-algorithmic content of the last paragraph of the paper: a certified +positive-matrix lower bound that has spent at most one quarter of `Ξ΅` on +numerics can spend another quarter on smoothing and retain improvement +`Ξ΅ / 2`. -/ +theorem assemble_smoothing_and_numerics + {n : β„•} {per perSmooth lower Ο‡ Ξ΅ : ℝ} + (_hΞ΅ : 0 < Ξ΅) (hΟ‡ : 0 ≀ Ο‡) (hΟ‡small : Ο‡ ≀ Ξ΅ / 2) + (hlowerPos : 0 < lower) + (hsmoothLower : per ≀ perSmooth) + (hsmoothUpper : perSmooth ≀ (1 + Ο‡ * n / 2) * per) + (hcertLower : lower ≀ perSmooth) + (hcertUpper : perSmooth ≀ (preSmoothingBase Ξ΅) ^ n * lower) : + lower / (1 + Ο‡ * n / 2) ≀ per ∧ + per ≀ (finalBase Ξ΅) ^ n * (lower / (1 + Ο‡ * n / 2)) := by + have hn : 0 ≀ (n : ℝ) := Nat.cast_nonneg n + have hfactorPos : 0 < 1 + Ο‡ * n / 2 := by positivity + have hlower : lower / (1 + Ο‡ * n / 2) ≀ per := by + rw [div_le_iffβ‚€ hfactorPos] + simpa [mul_comm] using hcertLower.trans hsmoothUpper + have hfactorExp : + 1 + Ο‡ * n / 2 ≀ Real.exp (Ξ΅ / 4) ^ n := by + calc + 1 + Ο‡ * n / 2 ≀ Real.exp (Ο‡ * n / 2) := by + simpa [add_comm] using Real.add_one_le_exp (Ο‡ * n / 2) + _ ≀ Real.exp ((Ξ΅ / 4) * n) := by + apply Real.exp_le_exp.mpr + have hmul := mul_le_mul_of_nonneg_right hΟ‡small + (show 0 ≀ (n : ℝ) / 2 by positivity) + nlinarith + _ = Real.exp (Ξ΅ / 4) ^ n := by + rw [← Real.exp_nat_mul] + congr 1 + ring + have hbase : + (1 + Ο‡ * n / 2) * (preSmoothingBase Ξ΅) ^ n ≀ + (finalBase Ξ΅) ^ n := by + calc + (1 + Ο‡ * n / 2) * (preSmoothingBase Ξ΅) ^ n + ≀ Real.exp (Ξ΅ / 4) ^ n * (preSmoothingBase Ξ΅) ^ n := + mul_le_mul_of_nonneg_right hfactorExp + (pow_nonneg (preSmoothingBase_pos Ξ΅).le n) + _ = (finalBase Ξ΅) ^ n := by + rw [← mul_pow, mul_comm, preSmoothingBase_mul_exp_quarter] + have hper : per ≀ (preSmoothingBase Ξ΅) ^ n * lower := + hsmoothLower.trans hcertUpper + have hupper : + per ≀ (finalBase Ξ΅) ^ n * (lower / (1 + Ο‡ * n / 2)) := by + rw [show (finalBase Ξ΅) ^ n * (lower / (1 + Ο‡ * n / 2)) = + ((finalBase Ξ΅) ^ n * lower) / (1 + Ο‡ * n / 2) by ring] + rw [le_div_iffβ‚€ hfactorPos] + calc + per * (1 + Ο‡ * n / 2) + ≀ ((preSmoothingBase Ξ΅) ^ n * lower) * + (1 + Ο‡ * n / 2) := + mul_le_mul_of_nonneg_right hper hfactorPos.le + _ = ((1 + Ο‡ * n / 2) * (preSmoothingBase Ξ΅) ^ n) * lower := by ring + _ ≀ (finalBase Ξ΅) ^ n * lower := + mul_le_mul_of_nonneg_right hbase hlowerPos.le + exact ⟨hlower, hupper⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CoreEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/CoreEncoding.lean new file mode 100644 index 0000000000..afbfb04ac3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CoreEncoding.lean @@ -0,0 +1,464 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.Combinatorics.Hall.Basic +public import Mathlib.Data.Fin.Rev +public import Mathlib.GroupTheory.Perm.Cycle.Factors +public import Mathlib.Tactic + +/-! # Core Encoding -/ + +@[expose] public section + +namespace BeyondBethe + +open Equiv + +variable {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + +/-- Whether the assignment `Οƒ` uses one of the two prescribed matching edges +at row `i`. -/ +def UsesCoreEdge (f g Οƒ : Equiv.Perm Ξ±) (i : Ξ±) : Prop := + Οƒ i = f i ∨ Οƒ i = g i + +/-- The paper's core encoding for a two-regular bipartite multigraph written +as the union of two perfect matchings. `none` is the symbol `star`; an escaped +edge records its column exactly. -/ +noncomputable def twoMatchingEncoding (f g Οƒ : Equiv.Perm Ξ±) : Ξ± β†’ Option Ξ± := by + classical + exact fun i ↦ if UsesCoreEdge f g Οƒ i then none else some (Οƒ i) + +/-- The permutation of row vertices obtained by following an `f`-edge and +then returning along a `g`-edge. Its nontrivial cycles are precisely the +components containing at least two rows. -/ +def alternatingRowPerm (f g : Equiv.Perm Ξ±) : Equiv.Perm Ξ± := + f.trans g.symm + +@[simp] +theorem alternatingRowPerm_apply (f g : Equiv.Perm Ξ±) (i : Ξ±) : + alternatingRowPerm f g i = g.symm (f i) := rfl + +theorem same_twoMatchingEncoding_core_iff + {f g Οƒ Ο„ : Equiv.Perm Ξ±} + (henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„) + (i : Ξ±) : + UsesCoreEdge f g Οƒ i ↔ UsesCoreEdge f g Ο„ i := by + classical + have hi := congrFun henc i + constructor + Β· intro hΟƒ + by_contra hΟ„ + simpa [twoMatchingEncoding, hΟƒ, hΟ„] using hi + Β· intro hΟ„ + by_contra hΟƒ + simpa [twoMatchingEncoding, hΟƒ, hΟ„] using hi + +theorem same_twoMatchingEncoding_of_escape + {f g Οƒ Ο„ : Equiv.Perm Ξ±} + (henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„) + {i : Ξ±} (hΟƒ : Β¬ UsesCoreEdge f g Οƒ i) : + Οƒ i = Ο„ i := by + classical + have hi := congrFun henc i + have hΟ„ : Β¬ UsesCoreEdge f g Ο„ i := by + exact fun h ↦ hΟƒ ((same_twoMatchingEncoding_core_iff henc i).2 h) + simpa [twoMatchingEncoding, hΟƒ, hΟ„] using hi + +theorem alternatingRowPerm_fixed_iff + (f g : Equiv.Perm Ξ±) (i : Ξ±) : + alternatingRowPerm f g i = i ↔ f i = g i := by + constructor + Β· intro h + have hg := congrArg g h + simpa [alternatingRowPerm] using hg + Β· intro h + apply g.injective + simp [alternatingRowPerm, h] + +/-- One oriented disagreement propagates by one step around the alternating +cycle. This is the direct form of the paper's "paths have unique perfect +matchings" observation. -/ +theorem oriented_disagreement_step + {f g Οƒ Ο„ : Equiv.Perm Ξ±} + (henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„) + {i : Ξ±} (hΟƒi : Οƒ i = f i) (hΟ„i : Ο„ i = g i) + (hfg : f i β‰  g i) : + Οƒ (alternatingRowPerm f g i) = f (alternatingRowPerm f g i) ∧ + Ο„ (alternatingRowPerm f g i) = g (alternatingRowPerm f g i) := by + let j := alternatingRowPerm f g i + have hgj : g j = f i := by + simp [j, alternatingRowPerm] + have hji : j β‰  i := by + intro h + apply hfg + rw [← hgj, h] + let k := Ο„.symm (f i) + have hΟ„k : Ο„ k = f i := by simp [k] + have hki : k β‰  i := by + intro h + apply hfg + rw [← hΟ„k, h, hΟ„i] + have hΟƒk_ne : Οƒ k β‰  f i := by + intro h + exact hki (Οƒ.injective (h.trans hΟƒi.symm)) + have hΟ„core : UsesCoreEdge f g Ο„ k := by + by_contra hk + have hΟƒescape : Β¬ UsesCoreEdge f g Οƒ k := by + exact fun h ↦ hk ((same_twoMatchingEncoding_core_iff henc k).1 h) + have heq := same_twoMatchingEncoding_of_escape henc hΟƒescape + exact hΟƒk_ne (heq.trans hΟ„k) + have hΟ„k_g : Ο„ k = g k := by + rcases hΟ„core with hΟ„k_f | hΟ„k_g + Β· exact absurd (f.injective (hΟ„k_f.symm.trans hΟ„k)) hki + Β· exact hΟ„k_g + have hkj : k = j := by + apply g.injective + rw [← hΟ„k_g, hΟ„k, hgj] + have hΟ„j_g : Ο„ j = g j := by + rw [← hkj] + exact hΟ„k_g + have hΟƒcore : UsesCoreEdge f g Οƒ j := + (same_twoMatchingEncoding_core_iff henc j).2 (Or.inr hΟ„j_g) + have hΟƒj_g_ne : Οƒ j β‰  g j := by + intro h + apply hji + exact (Οƒ.injective (hΟƒi.trans (hgj.symm.trans h.symm))).symm + refine ⟨?_, hΟ„j_g⟩ + rcases hΟƒcore with h | h + Β· exact h + Β· exact absurd h hΟƒj_g_ne + +/-- A disagreement in either orientation propagates by one alternating step. -/ +theorem disagreement_step + {f g Οƒ Ο„ : Equiv.Perm Ξ±} + (henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„) + {i : Ξ±} (hne : Οƒ i β‰  Ο„ i) : + Οƒ (alternatingRowPerm f g i) β‰  Ο„ (alternatingRowPerm f g i) := by + have hΟƒcore : UsesCoreEdge f g Οƒ i := by + by_contra h + exact hne (same_twoMatchingEncoding_of_escape henc h) + have hΟ„core : UsesCoreEdge f g Ο„ i := + (same_twoMatchingEncoding_core_iff henc i).1 hΟƒcore + rcases hΟƒcore with hΟƒf | hΟƒg <;> rcases hΟ„core with hΟ„f | hΟ„g + Β· exact absurd (hΟƒf.trans hΟ„f.symm) hne + Β· obtain h := oriented_disagreement_step henc hΟƒf hΟ„g + (fun hfg ↦ hne (hΟƒf.trans (hfg.trans hΟ„g.symm))) + intro heq + have hstepFixed : alternatingRowPerm f g (alternatingRowPerm f g i) = + alternatingRowPerm f g i := + (alternatingRowPerm_fixed_iff f g _).2 (h.1.symm.trans (heq.trans h.2)) + have hiFixed : alternatingRowPerm f g i = i := by + exact (alternatingRowPerm f g).injective hstepFixed + have hfg0 : f i = g i := + (alternatingRowPerm_fixed_iff f g i).1 hiFixed + exact hne (hΟƒf.trans (hfg0.trans hΟ„g.symm)) + Β· obtain h := oriented_disagreement_step henc.symm hΟ„f hΟƒg + (fun hfg ↦ hne ((hΟƒg.trans hfg.symm).trans hΟ„f.symm)) + intro heq + have hstepFixed : alternatingRowPerm f g (alternatingRowPerm f g i) = + alternatingRowPerm f g i := + (alternatingRowPerm_fixed_iff f g _).2 (h.1.symm.trans (heq.symm.trans h.2)) + have hiFixed : alternatingRowPerm f g i = i := by + exact (alternatingRowPerm f g).injective hstepFixed + have hfg0 : f i = g i := + (alternatingRowPerm_fixed_iff f g i).1 hiFixed + exact hne (hΟƒg.trans (hfg0.symm.trans hΟ„f.symm)) + Β· exact absurd (hΟƒg.trans hΟ„g.symm) hne + +theorem disagreement_pow + {f g Οƒ Ο„ : Equiv.Perm Ξ±} + (henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„) + {i : Ξ±} (hne : Οƒ i β‰  Ο„ i) : + βˆ€ k : β„•, + Οƒ (((alternatingRowPerm f g) ^ k) i) β‰  + Ο„ (((alternatingRowPerm f g) ^ k) i) := by + intro k + induction k with + | zero => simpa using hne + | succ k ih => + simpa only [← Equiv.Perm.mul_apply, ← pow_succ'] using + disagreement_step henc ih + +/-- A chosen row in the support of a nontrivial alternating cycle. -/ +noncomputable def cycleRepresentative + (h : Equiv.Perm Ξ±) (c : h.cycleFactorsFinset) : Ξ± := + Classical.choose + ((Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.property).1.nonempty_support) + +theorem cycleRepresentative_mem + (h : Equiv.Perm Ξ±) (c : h.cycleFactorsFinset) : + cycleRepresentative h c ∈ (c : Equiv.Perm Ξ±).support := + Classical.choose_spec + ((Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.property).1.nonempty_support) + +/-- One Boolean choice for every nontrivial alternating cycle. -/ +noncomputable def cycleSignature + (f g Οƒ : Equiv.Perm Ξ±) : + (alternatingRowPerm f g).cycleFactorsFinset β†’ Bool := + fun c ↦ decide (Οƒ (cycleRepresentative (alternatingRowPerm f g) c) = + f (cycleRepresentative (alternatingRowPerm f g) c)) + +theorem cycleSignature_injective_on_encoding_fiber + {f g : Equiv.Perm Ξ±} {y : Ξ± β†’ Option Ξ±} : + Set.InjOn (cycleSignature f g) + {Οƒ | twoMatchingEncoding f g Οƒ = y} := by + intro Οƒ hΟƒ Ο„ hΟ„ hsig + have henc : twoMatchingEncoding f g Οƒ = twoMatchingEncoding f g Ο„ := + hΟƒ.trans hΟ„.symm + ext i + by_contra hne + let h := alternatingRowPerm f g + have hsupport : i ∈ h.support := by + rw [Equiv.Perm.mem_support] + intro hfix + have hfg : f i = g i := + (alternatingRowPerm_fixed_iff f g i).1 hfix + have hΟƒcore : UsesCoreEdge f g Οƒ i := by + by_contra hout + exact hne (same_twoMatchingEncoding_of_escape henc hout) + have hΟ„core : UsesCoreEdge f g Ο„ i := + (same_twoMatchingEncoding_core_iff henc i).1 hΟƒcore + rcases hΟƒcore with hΟƒf | hΟƒg <;> rcases hΟ„core with hΟ„f | hΟ„g <;> + apply hne <;> simp_all + let c : h.cycleFactorsFinset := + ⟨h.cycleOf i, Equiv.Perm.cycleOf_mem_cycleFactorsFinset_iff.mpr hsupport⟩ + have hirep : h.SameCycle i (cycleRepresentative h c) := by + apply (Equiv.Perm.sameCycle_iff_cycleOf_eq_of_mem_support hsupport + (Equiv.Perm.mem_cycleFactorsFinset_support_le c.property + (cycleRepresentative_mem h c))).2 + simpa [c] using + (Equiv.Perm.cycle_is_cycleOf (cycleRepresentative_mem h c) c.property) + obtain ⟨k, hk⟩ := hirep.exists_nat_pow_eq + have hneRep : + Οƒ (cycleRepresentative h c) β‰  Ο„ (cycleRepresentative h c) := by + rw [← hk] + exact disagreement_pow henc hne k + have hsigc := congrFun hsig c + change decide (Οƒ (cycleRepresentative h c) = f (cycleRepresentative h c)) = + decide (Ο„ (cycleRepresentative h c) = f (cycleRepresentative h c)) at hsigc + have hsigc' : + (Οƒ (cycleRepresentative h c) = f (cycleRepresentative h c)) ↔ + Ο„ (cycleRepresentative h c) = f (cycleRepresentative h c) := by + exact decide_eq_decide.mp hsigc + have hΟƒcore : UsesCoreEdge f g Οƒ (cycleRepresentative h c) := by + by_contra hout + exact hneRep (same_twoMatchingEncoding_of_escape henc hout) + have hΟ„core : UsesCoreEdge f g Ο„ (cycleRepresentative h c) := + (same_twoMatchingEncoding_core_iff henc _).1 hΟƒcore + rcases hΟƒcore with hΟƒf | hΟƒg <;> rcases hΟ„core with hΟ„f | hΟ„g + Β· exact hneRep (hΟƒf.trans hΟ„f.symm) + Β· exact hneRep (hΟƒf.trans (hsigc'.mp hΟƒf).symm) + Β· exact hneRep ((hsigc'.mpr hΟ„f).trans hΟ„f.symm) + Β· exact hneRep (hΟƒg.trans hΟ„g.symm) + +/-- Graph-specific fiber bound in paper Lemma 9. A completed two-regular +bipartite multigraph is written as the union of perfect matchings `f` and `g`; +its components with at least two rows are the nontrivial cycles of +`alternatingRowPerm f g`. -/ +theorem twoMatchingEncoding_fiber_card_le + (f g : Equiv.Perm Ξ±) (y : Ξ± β†’ Option Ξ±) : + (Finset.univ.filter fun Οƒ : Equiv.Perm Ξ± ↦ + twoMatchingEncoding f g Οƒ = y).card ≀ + 2 ^ (alternatingRowPerm f g).cycleFactorsFinset.card := by + let S := Finset.univ.filter fun Οƒ : Equiv.Perm Ξ± ↦ + twoMatchingEncoding f g Οƒ = y + let sigType := (alternatingRowPerm f g).cycleFactorsFinset β†’ Bool + let encode : β†₯S β†’ sigType := fun Οƒ ↦ cycleSignature f g Οƒ.1 + have hinj : Function.Injective encode := by + intro Οƒ Ο„ h + apply Subtype.ext + have hΟƒ : twoMatchingEncoding f g Οƒ.1 = y := by + have hp := Οƒ.property + dsimp only [S] at hp + exact (Finset.mem_filter.mp hp).2 + have hΟ„ : twoMatchingEncoding f g Ο„.1 = y := by + have hp := Ο„.property + dsimp only [S] at hp + exact (Finset.mem_filter.mp hp).2 + exact cycleSignature_injective_on_encoding_fiber hΟƒ hΟ„ h + calc + S.card = Fintype.card S := (Fintype.card_coe S).symm + _ ≀ Fintype.card sigType := Fintype.card_le_of_injective encode hinj + _ = 2 ^ (alternatingRowPerm f g).cycleFactorsFinset.card := by + simp [sigType, Fintype.card_fun] + +/-- A spanning two-regular bipartite multigraph. The two slots at each row +record its two incident edges, while `columnDegree` says that every column is +incident to exactly two edge slots. Parallel edges are represented by equal +values in the two row slots. -/ +structure TwoRegularBipartiteMultigraph (Ξ± : Type*) [Fintype Ξ±] + [DecidableEq Ξ±] where + /-- The target column of each of the two edge slots at a row vertex. -/ + edge : Ξ± β†’ Fin 2 β†’ Ξ± + columnDegree : βˆ€ j, + (βˆ‘ i, βˆ‘ k : Fin 2, if edge i k = j then 1 else 0) = 2 + +namespace TwoRegularBipartiteMultigraph + +variable (K : TwoRegularBipartiteMultigraph Ξ±) + +/-- Column neighbors of one row, with parallel edges ignored. -/ +noncomputable def neighbors (i : Ξ±) : Finset Ξ± := by + classical + exact Finset.univ.image (K.edge i) + +theorem mem_neighbors_iff (i j : Ξ±) : + j ∈ K.neighbors i ↔ βˆƒ k : Fin 2, K.edge i k = j := by + classical + simp [neighbors, eq_comm] + +private theorem localColumnCount_le_two (s : Finset Ξ±) (j : Ξ±) : + (βˆ‘ i ∈ s, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0) ≀ 2 := by + calc + (βˆ‘ i ∈ s, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0) ≀ + βˆ‘ i, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0 := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + intro i _ _ + exact Finset.sum_nonneg (fun k _ ↦ by positivity) + _ = 2 := K.columnDegree j + +private theorem localColumnCount_eq_zero_of_notMem + (s : Finset Ξ±) {j : Ξ±} (hj : j βˆ‰ s.biUnion K.neighbors) : + (βˆ‘ i ∈ s, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0) = 0 := by + apply Finset.sum_eq_zero + intro i hi + apply Finset.sum_eq_zero + intro k _ + have hne : K.edge i k β‰  j := by + intro h + apply hj + rw [Finset.mem_biUnion] + exact ⟨i, hi, (K.mem_neighbors_iff i j).2 ⟨k, h⟩⟩ + simp [hne] + +/-- The neighborhood family of a two-regular bipartite multigraph satisfies +Hall's condition. Multiplicities are essential in the proof: `2|S|` edge +slots leave `S`, while at most `2|N(S)|` slots enter its neighborhood. -/ +theorem hall_condition (s : Finset Ξ±) : + s.card ≀ (s.biUnion K.neighbors).card := by + let L : Ξ± β†’ β„• := fun j ↦ + βˆ‘ i ∈ s, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0 + have hpartition : 2 * s.card = βˆ‘ j, L j := by + dsimp [L] + calc + 2 * s.card = βˆ‘ i ∈ s, βˆ‘ _k : Fin 2, 1 := by simp [mul_comm] + _ = βˆ‘ i ∈ s, βˆ‘ k : Fin 2, βˆ‘ j, if K.edge i k = j then 1 else 0 := by + apply Finset.sum_congr rfl + intro i _ + apply Finset.sum_congr rfl + intro k _ + simp + _ = βˆ‘ i ∈ s, βˆ‘ j, βˆ‘ k : Fin 2, + if K.edge i k = j then 1 else 0 := by + apply Finset.sum_congr rfl + intro i _ + exact Finset.sum_comm + _ = βˆ‘ j, βˆ‘ i ∈ s, βˆ‘ k : Fin 2, + if K.edge i k = j then 1 else 0 := by + exact Finset.sum_comm + have hrestrict : + (βˆ‘ j, L j) = βˆ‘ j ∈ s.biUnion K.neighbors, L j := by + symm + apply Finset.sum_subset (Finset.subset_univ _) + intro j _ hj + exact K.localColumnCount_eq_zero_of_notMem s hj + have hbound : + (βˆ‘ j ∈ s.biUnion K.neighbors, L j) ≀ + βˆ‘ _j ∈ s.biUnion K.neighbors, 2 := by + apply Finset.sum_le_sum + intro j _ + exact K.localColumnCount_le_two s j + have htwice : 2 * s.card ≀ 2 * (s.biUnion K.neighbors).card := by + rw [hpartition, hrestrict] + simpa [mul_comm] using hbound + omega + +private theorem finTwo_eq_or_eq_rev (k chosen : Fin 2) : + k = chosen ∨ k = Fin.rev chosen := by + fin_cases k <;> fin_cases chosen <;> simp + +private theorem sum_finTwo_split (a : Fin 2 β†’ β„•) (chosen : Fin 2) : + (βˆ‘ k, a k) = a chosen + a (Fin.rev chosen) := by + fin_cases chosen <;> simp [Fin.sum_univ_two, add_comm] + +/-- Every spanning two-regular bipartite multigraph is the union of two +perfect matchings. This is the precise edge-coloring fact needed to pass +from the paper's stub completion to `twoMatchingEncoding`. -/ +theorem exists_twoMatching_decomposition : + βˆƒ f g : Equiv.Perm Ξ±, + (βˆ€ i, (βˆƒ k : Fin 2, K.edge i k = f i) ∧ + βˆƒ k : Fin 2, K.edge i k = g i) ∧ + βˆ€ i k, K.edge i k = f i ∨ K.edge i k = g i := by + classical + obtain ⟨p, hpInjective, hpEdge⟩ := + (Finset.all_card_le_biUnion_card_iff_exists_injective K.neighbors).1 + K.hall_condition + have hpBijective : Function.Bijective p := + (Fintype.bijective_iff_injective_and_card p).2 ⟨hpInjective, rfl⟩ + let f : Equiv.Perm Ξ± := Equiv.ofBijective p hpBijective + have hfEdge : βˆ€ i, βˆƒ k : Fin 2, K.edge i k = f i := by + intro i + exact (K.mem_neighbors_iff i (f i)).1 (hpEdge i) + let chosen : Ξ± β†’ Fin 2 := fun i ↦ Classical.choose (hfEdge i) + have hchosen : βˆ€ i, K.edge i (chosen i) = f i := fun i ↦ + Classical.choose_spec (hfEdge i) + let q : Ξ± β†’ Ξ± := fun i ↦ K.edge i (Fin.rev (chosen i)) + have hresidual : βˆ€ j, + (βˆ‘ i, if q i = j then 1 else 0) = 1 := by + intro j + have hsplit : + (βˆ‘ i, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0) = + (βˆ‘ i, if f i = j then 1 else 0) + + βˆ‘ i, if q i = j then 1 else 0 := by + calc + (βˆ‘ i, βˆ‘ k : Fin 2, if K.edge i k = j then 1 else 0) = + βˆ‘ i, ((if K.edge i (chosen i) = j then 1 else 0) + + if K.edge i (Fin.rev (chosen i)) = j then 1 else 0) := by + apply Finset.sum_congr rfl + intro i _ + exact sum_finTwo_split + (fun k ↦ if K.edge i k = j then 1 else 0) (chosen i) + _ = (βˆ‘ i, if f i = j then 1 else 0) + + βˆ‘ i, if q i = j then 1 else 0 := by + rw [Finset.sum_add_distrib] + simp only [hchosen, q] + have hchosenCount : (βˆ‘ i, if f i = j then 1 else 0) = 1 := by + simp_rw [f.apply_eq_iff_eq_symm_apply] + rw [Finset.sum_ite_eq' Finset.univ (f.symm j)] + simp + rw [K.columnDegree j, hchosenCount] at hsplit + omega + have hqInjective : Function.Injective q := by + intro i i' hii' + let fiber := Finset.univ.filter fun r ↦ q r = q i + have hcard : fiber.card = 1 := by + rw [Finset.card_filter] + exact hresidual (q i) + obtain ⟨a, ha⟩ := Finset.card_eq_one.mp hcard + have hi : i ∈ fiber := by simp [fiber] + have hi' : i' ∈ fiber := by simp [fiber, hii'] + have hia : i = a := by simpa [ha] using hi + have hi'a : i' = a := by simpa [ha] using hi' + exact hia.trans hi'a.symm + have hqBijective : Function.Bijective q := + (Fintype.bijective_iff_injective_and_card q).2 ⟨hqInjective, rfl⟩ + let g : Equiv.Perm Ξ± := Equiv.ofBijective q hqBijective + refine ⟨f, g, ?_, ?_⟩ + Β· intro i + exact ⟨hfEdge i, ⟨Fin.rev (chosen i), rfl⟩⟩ + Β· intro i k + rcases finTwo_eq_or_eq_rev k (chosen i) with hk | hk + Β· left + rw [hk, hchosen] + Β· right + exact hk β–Έ rfl + +end TwoRegularBipartiteMultigraph + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/CycleTransfer.lean b/LeanPool/BeyondBethe/BeyondBethe/CycleTransfer.lean new file mode 100644 index 0000000000..328c1f907a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/CycleTransfer.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RobustCycle +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.ExcursionTransfer +public import Mathlib.Tactic + +/-! # Cycle Transfer -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Columns outside the two core edges at a row. -/ +noncomputable def coreOutside + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (a b : ΞΉ) : Finset ΞΉ := + Finset.univ.filter fun j ↦ a β‰  j ∧ b β‰  j + +theorem massOn_coreOutside_of_ne + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + massOn (coreOutside a b) p = 1 - p a - p b := by + rw [massOn, coreOutside, Finset.sum_filter] + exact sum_away_from_two hp hab + +theorem massOn_coreOutside_same + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) (a : Fin n) : + massOn (coreOutside a a) p = 1 - p a := by + rw [massOn, coreOutside, Finset.sum_filter] + have haway := sum_ite_ne_eq_sum_sub p a + rw [hp.sum_eq_one] at haway + have hsame : (βˆ‘ j, if a β‰  j ∧ a β‰  j then p j else 0) = + βˆ‘ j, if j β‰  a then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp + Β· simp [hja, Ne.symm hja] + rw [hsame, haway] + +theorem coreOutside_comm + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] (a b : ΞΉ) : + coreOutside a b = coreOutside b a := by + ext j + simp only [coreOutside, Finset.mem_filter, Finset.mem_univ, true_and] + constructor + Β· rintro ⟨haj, hbj⟩ + exact ⟨hbj, haj⟩ + Β· rintro ⟨hbj, haj⟩ + exact ⟨haj, hbj⟩ + +/-- If two distinct coordinates both belong to another two-element core, +then the two cores, and hence their complements, agree. -/ +theorem coreOutside_eq_of_pair_membership + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b c d : ΞΉ} (hab : a β‰  b) + (ha : a = c ∨ a = d) (hb : b = c ∨ b = d) : + coreOutside c d = coreOutside a b := by + rcases ha with ha | ha <;> rcases hb with hb | hb + Β· exact False.elim (hab (ha.trans hb.symm)) + Β· rw [ha, hb] + Β· rw [ha, hb, coreOutside_comm] + Β· exact False.elim (hab (ha.trans hb.symm)) + +theorem sum_negMulLog_coreOutside + {n : β„•} (p : Fin n β†’ ℝ) (a b : Fin n) : + (βˆ‘ j ∈ coreOutside a b, Real.negMulLog (p j)) = + βˆ‘ j, if a β‰  j ∧ b β‰  j then Real.negMulLog (p j) else 0 := by + rw [coreOutside, Finset.sum_filter] + +/-- The row coordinate of the cycle encoding is exactly the coarsening used +in the excursion-transfer argument. -/ +theorem coreOutcome_entropy_eq_coarsenedRowEntropy + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + (a b : Fin n) : + shannonEntropy (pushforwardMass p (coreOutcome a b)) = + coarsenedRowEntropy (coreOutside a b) p := by + by_cases hab : a = b + Β· subst b + rw [coreOutcome_entropy_same p a, coarsenedRowEntropy, + scaledConditionalEntropyOn, binaryEntropy, + massOn_coreOutside_same hp.probability, + sum_negMulLog_coreOutside] + have hout := sum_ite_ne_eq_sum_sub + (fun j ↦ Real.negMulLog (p j)) a + have hsame : + (βˆ‘ j, if a β‰  j ∧ a β‰  j then Real.negMulLog (p j) else 0) = + βˆ‘ j, if j β‰  a then Real.negMulLog (p j) else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp + Β· simp [hja, Ne.symm hja] + rw [hsame, hout, shannonEntropy, Real.negMulLog_def] + ring + Β· rw [coreOutcome_entropy_eq_twoCoreCoarsenedEntropy p hab, + twoCoreCoarsenedEntropy, coarsenedRowEntropy, + scaledConditionalEntropyOn, binaryEntropy, + massOn_coreOutside_of_ne hp.probability hab, + sum_negMulLog_coreOutside] + have hmass : 1 - (1 - p a - p b) = p a + p b := by ring + rw [hmass, Real.negMulLog_def] + ring + +/-- Rowwise form of the preceding bridge for the actual completed graph. -/ +theorem coordinateEncoding_entropy_eq_coarsenedRowEntropy + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (f g : Equiv.Perm (Fin n)) (i : Fin n) : + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) = + coarsenedRowEntropy (coreOutside (f i) (g i)) (P i) := by + rw [coordinateEncoding_mass hmarg f g i] + exact coreOutcome_entropy_eq_coarsenedRowEntropy (hP i) (f i) (g i) + +theorem two_mul_cycleFactors_card_le + {n : β„•} (h : Equiv.Perm (Fin n)) : + 2 * h.cycleFactorsFinset.card ≀ n := by + have htwo : 2 * h.cycleFactorsFinset.card ≀ + βˆ‘ c : h.cycleFactorsFinset, + (c : Equiv.Perm (Fin n)).support.card := by + calc + 2 * h.cycleFactorsFinset.card = + βˆ‘ _c : h.cycleFactorsFinset, 2 := by simp [Nat.mul_comm] + _ ≀ βˆ‘ c : h.cycleFactorsFinset, + (c : Equiv.Perm (Fin n)).support.card := by + apply Finset.sum_le_sum + intro c _ + exact (Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.property).1.two_le_card_support + have hsupport : + (βˆ‘ c : h.cycleFactorsFinset, + (c : Equiv.Perm (Fin n)).support.card) ≀ n := by + have hle := sum_cycleSupport_inter_card_le h Finset.univ + simpa using hle + omega + +/-- Paper Lemma 9 in the exact coarsened-row form needed for equation (39). -/ +theorem twoMatching_entropy_le_halfBits_add_coarsenedRows + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hΞΌ : IsProbabilityVector ΞΌ) + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (f g : Equiv.Perm (Fin n)) : + shannonEntropy ΞΌ ≀ n * (Real.log 2 / 2) + + βˆ‘ i, coarsenedRowEntropy (coreOutside (f i) (g i)) (P i) := by + have hcore := twoMatching_coreEncoding_sum_coordinates hΞΌ f g + simp_rw [coordinateEncoding_entropy_eq_coarsenedRowEntropy + hmarg hP f g] at hcore + have hcountNat := two_mul_cycleFactors_card_le (alternatingRowPerm f g) + have hcount : + ((alternatingRowPerm f g).cycleFactorsFinset.card : ℝ) * + Real.log 2 ≀ n * (Real.log 2 / 2) := by + have hcountR : + 2 * ((alternatingRowPerm f g).cycleFactorsFinset.card : ℝ) ≀ n := by + exact_mod_cast hcountNat + have hlog : 0 ≀ Real.log 2 := Real.log_nonneg (by norm_num) + nlinarith [mul_le_mul_of_nonneg_right hcountR hlog] + linarith + +/-- End-to-end form of the excursion-transfer estimate for a completed +two-matching graph. This theorem closes the informal identification of a +good row's two heavy coordinates with its two graph edges: consequently the +mass outside the encoded core is at most `Ξ·`. -/ +theorem twoMatching_coreTransferCost_normalized_le + {n : β„•} (hn : 0 < n) + {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hΞΌ : IsProbabilityVector ΞΌ) + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ο„ B Ξ· : ℝ} (hΟ„ : 0 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hΞ· : Ξ· ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + (hglobal : matrixTransferCost P + (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + shannonEntropy ΞΌ - n * (Real.log 2 / 2)) : + coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + B / n + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * ((badRows Ξ· P).card : ℝ) / n := by + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp hn + have hencoding := twoMatching_entropy_le_halfBits_add_coarsenedRows + hΞΌ hmarg hP f g + have hbefore : matrixTransferCost P + (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + βˆ‘ i, coarsenedRowEntropy (coreOutside (f i) (g i)) (P i) := by + linarith + have hρ : βˆ€ i, + massOn (coreOutside (f i) (g i)) (P i) ∈ Set.Icc (0 : ℝ) 1 := by + intro i + constructor + Β· rw [massOn] + exact Finset.sum_nonneg fun j _ ↦ (hP i).probability.nonnegative j + Β· exact (massOn_le_sum_univ _ + (fun j ↦ (hP i).probability.nonnegative j)).trans_eq + (hP i).probability.sum_eq_one + have hgood : βˆ€ i ∈ goodRows Ξ· P, + massOn (coreOutside (f i) (g i)) (P i) ≀ Ξ· := by + intro i hi + have hi' : IsGoodRow Ξ· (P i) := by + simpa [goodRows] using hi + obtain ⟨a, b, hab, hdist⟩ := hi' + have hcore := goodRow_witness_mem_heavyCoordinates + (hP i).probability hab hdist + have ha := hheavy i a hcore.1 + have hb := hheavy i b hcore.2 + have houtside : coreOutside (f i) (g i) = coreOutside a b := + coreOutside_eq_of_pair_membership hab ha hb + rw [houtside, massOn_coreOutside_of_ne (hP i).probability hab] + rw [halfHalfL1Distance_eq (hP i).probability hab] at hdist + linarith [abs_nonneg (P i a - 1 / 2), abs_nonneg (P i b - 1 / 2)] + have hnormalized := coreTransferCost_normalized_le_for_transferU + (fun i ↦ coreOutside (f i) (g i)) (goodRows Ξ· P) + hΟ„ (fun i j ↦ (hP i).positive j) hXint hbefore hΞ· hρ hgood + have hbad : (Finset.univ \ goodRows Ξ· P) = badRows Ξ· P := by + ext i + simp [goodRows, badRows] + rw [hbad] at hnormalized + simpa [Fintype.card_fin] using hnormalized + +/-- The preceding transfer estimate with every probabilistic, slack, and +optimization quantity instantiated for the Gibbs distribution of a positive +matrix. Apart from the logarithmic KKT equations, all inputs to paper +Lemmas 16 and 17 are discharged here. -/ +theorem gibbs_twoMatching_coreTransferCost_normalized_le + {n : β„•} (hn : 0 < n) + (A : Matrix (Fin n) (Fin n) ℝ) (hA : Matrix.Positive A) + {Ο„ ΞΎ Ξ· : ℝ} (hΟ„ : 0 ≀ Ο„) + (hbudget : Ο„ * (n * Real.log n) ≀ ΞΎ * n) + (hΞ· : Ξ· ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (assignmentMarginal A i) β†’ + j = f i ∨ j = g i) + {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r c : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X r c) : + coreTransferCost (fun i ↦ coreOutside (f i) (g i)) + (assignmentMarginal A) (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + betheSlack n (betheLogValue A) (Real.log (Matrix.permanent A)) / n + + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * + ((badRows Ξ· (assignmentMarginal A)).card : ℝ) / n := by + let P := assignmentMarginal A + let ΞΌ := gibbsProbability A + let D := gibbsSequentialDivergence A + let E := betheSuboptimality (betheLogValue A) (betheObjective A P) + let S := betheSlack n (betheLogValue A) + (Real.log (Matrix.permanent A)) + have hper : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hPds : IsDoublyStochastic P := + assignmentMarginal_doublyStochastic A + (fun i j ↦ (hA i j).le) hper.ne' + have hPstrict : βˆ€ i, IsStrictProbabilityVector (P i) := + assignmentMarginal_strictProbabilityVector A hA + have hEΟ„ : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A P ≀ E + ΞΎ * n := by + exact regularizedDifference_le_betheSuboptimality_add_budget + hn hΟ„ hbudget hA hX hPds + have hregularizer : Ο„ * totalRowEntropy P ≀ ΞΎ * n := by + have hentropy : totalRowEntropy P ≀ n * Real.log n := by + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp hn + simpa using totalRowEntropy_le hPds + exact (mul_le_mul_of_nonneg_left hentropy hΟ„).trans hbudget + have hdivergence : D = -shannonEntropy ΞΌ + βˆ‘ i, rowScore (P i) := by + exact gibbsSequentialDivergence_eq_entropy A hA + have hseq : Real.log (Matrix.permanent A) = + betheObjective A P + (βˆ‘ i, rowCorrection (P i)) - D := by + exact gibbs_exact_sequential_identity A hA + have hslack : S = E + (βˆ‘ i, rowDeficit (P i)) + D := by + exact slack_decomposition_rowDeficit P hseq + have hglobal : matrixTransferCost P + (fun i j ↦ transferU Ο„ (X i) j) ≀ + S + 2 * ΞΎ * n + shannonEntropy ΞΌ - + n * (Real.log 2 / 2) := by + exact global_transfer_upper_of_logKKT_and_slack + hX hPds hXint hKKT hEΟ„ hregularizer hdivergence hslack + have hcore := twoMatching_coreTransferCost_normalized_le + hn (gibbsProbability_isProbabilityVector A hA) + (gibbs_hasAssignmentMarginals A) hPstrict hΟ„ hXint hΞ· f g hheavy + (B := S + 2 * ΞΎ * n) hglobal + have hnR : (n : ℝ) β‰  0 := by exact_mod_cast hn.ne' + dsimp only [P, ΞΌ, S] at hcore ⊒ + convert hcore using 1 <;> field_simp [hnR] <;> ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Cycles.lean b/LeanPool/BeyondBethe/BeyondBethe/Cycles.lean new file mode 100644 index 0000000000..1ee8a6bfe4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Cycles.lean @@ -0,0 +1,723 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RowStability +public import LeanPool.BeyondBethe.BeyondBethe.CoreEncoding +public import Mathlib.Analysis.Convex.SpecificFunctions.Basic +public import Mathlib.Tactic + +/-! # Cycles -/ + +@[expose] public section + +namespace BeyondBethe + +/-- The Riemann-sum error `e(a,x)` from paper (27). Lean's conventions +`a / 0 = 0` and `log 1 = 0` make the displayed formula agree with the paper's +boundary convention `e(a,0)=a`. -/ +noncomputable def suffixError (a x : ℝ) : ℝ := + a - x * Real.log (1 + a / x) + +/-- An antiderivative of `log` with its continuous value at zero. -/ +noncomputable def logIntegralPrimitive (x : ℝ) : ℝ := + x * Real.log x - x + +/-- Suffix score for a list written in the chosen order. -/ +noncomputable def listSuffixScore : List ℝ β†’ ℝ + | [] => 0 + | a :: l => a * Real.log (a + l.sum) + listSuffixScore l + +/-- The sum of the suffix-error term at each position of a list. -/ +noncomputable def listSuffixErrorSum : List ℝ β†’ ℝ + | [] => 0 + | a :: l => suffixError a l.sum + listSuffixErrorSum l + +theorem listSuffixScore_ofFn + {n : β„•} (f : Fin n β†’ ℝ) : + listSuffixScore (List.ofFn f) = + βˆ‘ t, f t * Real.log (βˆ‘ k, if t ≀ k then f k else 0) := by + induction n with + | zero => simp [listSuffixScore] + | succ n ih => + rw [List.ofFn_succ, listSuffixScore, Fin.sum_univ_succ, + ih (fun k ↦ f k.succ)] + congr 1 + Β· congr 2 + rw [List.sum_ofFn, Fin.sum_univ_succ] + simp + Β· apply Finset.sum_congr rfl + intro i _ + congr 2 + rw [Fin.sum_univ_succ] + simp + +/-- Reindexing bridge between the paper's ordered-list Riemann sum and the +permutation-indexed suffix score used in `rowT`. -/ +theorem listSuffixScore_ofFn_eq_ordered_score + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) : + listSuffixScore (List.ofFn (fun t ↦ p (Ο€ t))) = + βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) := by + calc + listSuffixScore (List.ofFn (fun t ↦ p (Ο€ t))) = + βˆ‘ t, p (Ο€ t) * Real.log + (βˆ‘ k, if t ≀ k then p (Ο€ k) else 0) := by + exact listSuffixScore_ofFn (fun t ↦ p (Ο€ t)) + _ = βˆ‘ t, p (Ο€ t) * Real.log (suffixMass p Ο€ (Ο€ t)) := by + apply Finset.sum_congr rfl + intro t _ + rw [← orderedSuffixWeight_eq_suffixMass + (fun _ j ↦ p j) Ο€ t] + rfl + _ = βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) := + Equiv.sum_comp Ο€ (fun j ↦ p j * Real.log (suffixMass p Ο€ j)) + +/-- One interval in the telescoping Riemann-sum calculation. -/ +theorem suffix_step_identity {a x : ℝ} (ha : 0 ≀ a) (hx : 0 ≀ x) : + a * Real.log (a + x) = + logIntegralPrimitive (a + x) - logIntegralPrimitive x + suffixError a x := by + by_cases hx0 : x = 0 + Β· subst x + simp [logIntegralPrimitive, suffixError] + Β· have hxpos : 0 < x := lt_of_le_of_ne hx (Ne.symm hx0) + have hsum : a + x β‰  0 := (add_pos_of_nonneg_of_pos ha hxpos).ne' + have hratio : 1 + a / x = (a + x) / x := by + field_simp + ring + simp only [suffixError, logIntegralPrimitive] + rw [hratio, Real.log_div hsum hx0] + ring + +/-- The error term is nonnegative, including at the boundary `x=0`. -/ +theorem suffixError_nonneg {a x : ℝ} (ha : 0 ≀ a) (hx : 0 ≀ x) : + 0 ≀ suffixError a x := by + by_cases hx0 : x = 0 + Β· subst x + simpa [suffixError] using ha + Β· have hxpos : 0 < x := lt_of_le_of_ne hx (Ne.symm hx0) + have harg : 0 < 1 + a / x := by positivity + have hlog := Real.log_le_sub_one_of_pos harg + have hmul := mul_le_mul_of_nonneg_left hlog hx + have hsimplify : x * ((1 + a / x) - 1) = a := by + field_simp + ring + rw [hsimplify] at hmul + rw [suffixError] + linarith + +/-- For fixed nonnegative `a`, the Riemann-sum error is nonincreasing in the +suffix mass, as asserted in paper Lemma 11. -/ +theorem suffixError_anti {a x y : ℝ} + (ha : 0 ≀ a) (hx : 0 ≀ x) (hxy : x ≀ y) : + suffixError a y ≀ suffixError a x := by + have hy : 0 ≀ y := hx.trans hxy + by_cases hy0 : y = 0 + Β· have hx0 : x = 0 := le_antisymm (hxy.trans_eq hy0) hx + simp [hx0, hy0] + have hypos : 0 < y := lt_of_le_of_ne hy (Ne.symm hy0) + by_cases hx0 : x = 0 + Β· subst x + have harg : 1 ≀ 1 + a / y := by + exact le_add_of_nonneg_right (div_nonneg ha hy) + have hlog : 0 ≀ Real.log (1 + a / y) := Real.log_nonneg harg + have hprod : 0 ≀ y * Real.log (1 + a / y) := mul_nonneg hy hlog + simp only [suffixError, zero_mul, div_zero, add_zero, Real.log_one, sub_zero] + linarith + Β· have hxpos : 0 < x := lt_of_le_of_ne hx (Ne.symm hx0) + let lam : ℝ := x / y + have hlam0 : 0 ≀ lam := div_nonneg hx hy + have hlam1 : lam ≀ 1 := (div_le_one hypos).2 hxy + have hfirst : 0 < 1 + a / x := by positivity + have hone : (1 : ℝ) ∈ Set.Ioi 0 := by norm_num + have hconc := strictConcaveOn_log_Ioi.concaveOn.2 + (show 1 + a / x ∈ Set.Ioi (0 : ℝ) from hfirst) + hone hlam0 (sub_nonneg.mpr hlam1) (by ring : lam + (1 - lam) = 1) + have hcombo : + lam * (1 + a / x) + (1 - lam) * (1 : ℝ) = 1 + a / y := by + dsimp [lam] + field_simp + ring + have hlogs : + lam * Real.log (1 + a / x) ≀ Real.log (1 + a / y) := by + simpa only [smul_eq_mul, Real.log_one, mul_zero, add_zero, hcombo] using hconc + have hmul := mul_le_mul_of_nonneg_left hlogs hy + have hlam_mul : y * (lam * Real.log (1 + a / x)) = + x * Real.log (1 + a / x) := by + dsimp [lam] + field_simp + rw [hlam_mul] at hmul + rw [suffixError, suffixError] + linarith + +/-- Finite telescoping form of the suffix Riemann-sum identity, before +normalizing the total mass to one. -/ +theorem listSuffixScore_identity (p : List ℝ) + (hp : βˆ€ x ∈ p, 0 ≀ x) : + listSuffixScore p = + logIntegralPrimitive p.sum + listSuffixErrorSum p := by + induction p with + | nil => simp [listSuffixScore, listSuffixErrorSum, logIntegralPrimitive] + | cons a p ih => + have ha : 0 ≀ a := hp a (by simp) + have hp' : βˆ€ x ∈ p, 0 ≀ x := by + intro x hx + exact hp x (by simp [hx]) + have hsum : 0 ≀ p.sum := List.sum_nonneg hp' + rw [listSuffixScore, listSuffixErrorSum, ih hp'] + rw [suffix_step_identity ha hsum] + simp only [List.sum_cons] + ring + +/-- Paper Lemma 11 in ordered-list form. -/ +theorem listSuffixScore_eq_neg_one_add_errors (p : List ℝ) + (hp : βˆ€ x ∈ p, 0 ≀ x) (hsum : p.sum = 1) : + listSuffixScore p = -1 + listSuffixErrorSum p := by + rw [listSuffixScore_identity p hp, hsum] + simp [logIntegralPrimitive] + +theorem listSuffixErrorSum_nonneg (p : List ℝ) + (hp : βˆ€ x ∈ p, 0 ≀ x) : + 0 ≀ listSuffixErrorSum p := by + induction p with + | nil => simp [listSuffixErrorSum] + | cons a p ih => + have ha : 0 ≀ a := hp a (by simp) + have hp' : βˆ€ x ∈ p, 0 ≀ x := by + intro x hx + exact hp x (by simp [hx]) + simp only [listSuffixErrorSum] + exact add_nonneg (suffixError_nonneg ha (List.sum_nonneg hp')) (ih hp') + +/-- The coarse consequence `T(p) β‰₯ -1` used for bad rows, stated for an +arbitrary fixed ordering. -/ +theorem listSuffixScore_ge_neg_one (p : List ℝ) + (hp : βˆ€ x ∈ p, 0 ≀ x) (hsum : p.sum = 1) : + -1 ≀ listSuffixScore p := by + rw [listSuffixScore_eq_neg_one_add_errors p hp hsum] + linarith [listSuffixErrorSum_nonneg p hp] + +theorem fixed_order_suffixScore_ge_neg_one + {n : β„•} {p : Fin n β†’ ℝ} + (hp : IsProbabilityVector p) (Ο€ : Equiv.Perm (Fin n)) : + -1 ≀ βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) := by + rw [← listSuffixScore_ofFn_eq_ordered_score] + apply listSuffixScore_ge_neg_one + Β· intro x hx + simp only [List.mem_ofFn] at hx + obtain ⟨t, rfl⟩ := hx + exact hp.nonnegative (Ο€ t) + Β· rw [List.sum_ofFn] + exact (Equiv.sum_comp Ο€ p).trans hp.sum_eq_one + +/-- The coarse part of paper Lemma 12: every row has suffix score at least +`-1`. -/ +theorem rowT_ge_neg_one + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) : + -1 ≀ rowT p := by + rw [rowT, ← uniformAverage_const + (Ξ± := Equiv.Perm (Fin n)) (-1)] + unfold uniformAverage + exact div_le_div_of_nonneg_right + (Finset.sum_le_sum fun Ο€ _ ↦ fixed_order_suffixScore_ge_neg_one hp Ο€) + (Nat.cast_nonneg _) + +theorem rowScore_ge_entropy_sub_one + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) : + shannonEntropy p - 1 ≀ rowScore p := by + rw [rowScore] + linarith [rowT_ge_neg_one hp] + +theorem fourthRoot_pow_four {d : ℝ} (hd : 0 ≀ d) : + fourthRoot d ^ 4 = d := by + rw [fourthRoot] + have hsqrt : 0 ≀ Real.sqrt d := Real.sqrt_nonneg d + calc + Real.sqrt (Real.sqrt d) ^ 4 = + (Real.sqrt (Real.sqrt d) ^ 2) ^ 2 := by ring + _ = (Real.sqrt d) ^ 2 := by rw [Real.sq_sqrt hsqrt] + _ = d := Real.sq_sqrt hd + +/-- A row is good when one of the half--half vectors is within the selected +`LΒΉ` threshold. -/ +def IsGoodRow {n : β„•} (eta : ℝ) (p : Fin n β†’ ℝ) : Prop := + βˆƒ a b : Fin n, a β‰  b ∧ halfHalfL1Distance p a b ≀ eta + +/-- The rows that fail the preceding structural test. -/ +noncomputable def badRows + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : Finset (Fin n) := by + classical + exact Finset.univ.filter fun i ↦ Β¬ IsGoodRow eta (P i) + +/-- Paper (22): a good row has two heavy coordinates and little mass outside +them. -/ +theorem goodRow_heavy_coordinates + {n : β„•} {eta : ℝ} {p : Fin n β†’ ℝ} + (hp : IsProbabilityVector p) (hgood : IsGoodRow eta p) : + βˆƒ a b : Fin n, a β‰  b ∧ + 1 / 2 - eta ≀ p a ∧ 1 / 2 - eta ≀ p b ∧ + 1 - p a - p b ≀ eta := by + obtain ⟨a, b, hab, hdist⟩ := hgood + have hsum : |p a - 1 / 2| + |p b - 1 / 2| + (1 - p a - p b) ≀ eta := by + simpa [halfHalfL1Distance_eq hp hab] using hdist + have htail : 0 ≀ 1 - p a - p b := by + rw [← sum_away_from_two hp hab] + exact Finset.sum_nonneg (fun j _ ↦ by + by_cases h : a β‰  j ∧ b β‰  j <;> simp [h, hp.nonnegative j]) + refine ⟨a, b, hab, ?_, ?_, ?_⟩ + Β· have habs := neg_le_abs (p a - 1 / 2) + have hbabs := abs_nonneg (p b - 1 / 2) + linarith + Β· have habs := neg_le_abs (p b - 1 / 2) + have haabs := abs_nonneg (p a - 1 / 2) + linarith + Β· have haabs := abs_nonneg (p a - 1 / 2) + have hbabs := abs_nonneg (p b - 1 / 2) + linarith + +/-- Heavy coordinates of one row, equivalently its neighbors in the heavy +bipartite graph. -/ +noncomputable def heavyCoordinates + {n : β„•} (eta : ℝ) (p : Fin n β†’ ℝ) : Finset (Fin n) := by + classical + exact Finset.univ.filter fun j ↦ 1 / 2 - eta ≀ p j + +/-- Paper's degree-at-most-two assertion for the heavy graph. -/ +theorem heavyCoordinates_card_le_two + {n : β„•} {eta : ℝ} {p : Fin n β†’ ℝ} + (hp : IsProbabilityVector p) (heta : eta ≀ 1 / 10) : + (heavyCoordinates eta p).card ≀ 2 := by + by_contra h + have hcardNat : 3 ≀ (heavyCoordinates eta p).card := by omega + have hcardReal : (3 : ℝ) ≀ (heavyCoordinates eta p).card := by + exact_mod_cast hcardNat + have hsumLower : + ((heavyCoordinates eta p).card : ℝ) * (1 / 2 - eta) ≀ + βˆ‘ j ∈ heavyCoordinates eta p, p j := by + calc + ((heavyCoordinates eta p).card : ℝ) * (1 / 2 - eta) = + βˆ‘ j ∈ heavyCoordinates eta p, (1 / 2 - eta) := by + rw [Finset.sum_const, nsmul_eq_mul] + _ ≀ βˆ‘ j ∈ heavyCoordinates eta p, p j := by + apply Finset.sum_le_sum + intro j hj + simpa [heavyCoordinates] using hj + have hsumUpper : (βˆ‘ j ∈ heavyCoordinates eta p, p j) ≀ 1 := by + rw [← hp.sum_eq_one] + exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + (fun j _ _ ↦ hp.nonnegative j) + have hfactor : (2 / 5 : ℝ) ≀ 1 / 2 - eta := by linarith + have hmul := mul_le_mul hcardReal hfactor (by norm_num) (by positivity) + nlinarith + +/-- A good row has exactly two heavy coordinates. -/ +theorem goodRow_has_exactly_two_heavyCoordinates + {n : β„•} {eta : ℝ} {p : Fin n β†’ ℝ} + (hp : IsProbabilityVector p) (heta : eta ≀ 1 / 10) + (hgood : IsGoodRow eta p) : + (heavyCoordinates eta p).card = 2 := by + obtain ⟨a, b, hab, ha, hb, _⟩ := goodRow_heavy_coordinates hp hgood + have haMem : a ∈ heavyCoordinates eta p := by + simpa [heavyCoordinates] using ha + have hbMem : b ∈ heavyCoordinates eta p := by + simpa [heavyCoordinates] using hb + have htwo : ({a, b} : Finset (Fin n)).card ≀ + (heavyCoordinates eta p).card := + Finset.card_le_card (by + intro j hj + simp only [Finset.mem_insert, Finset.mem_singleton] at hj + rcases hj with rfl | rfl + Β· exact haMem + Β· exact hbMem) + have habCard : ({a, b} : Finset (Fin n)).card = 2 := by simp [hab] + rw [habCard] at htwo + exact le_antisymm (heavyCoordinates_card_le_two hp heta) htwo + +/-- The rows whose entry in the given column is at least `1/2 - eta`. -/ +noncomputable def heavyRows + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (j : Fin n) : Finset (Fin n) := + heavyCoordinates eta (fun i ↦ P i j) + +/-- Both sides of the heavy bipartite graph have degree at most two. -/ +theorem heavy_graph_degree_bounds + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + (βˆ€ i, (heavyCoordinates eta (P i)).card ≀ 2) ∧ + βˆ€ j, (heavyRows eta P j).card ≀ 2 := by + constructor + Β· intro i + exact heavyCoordinates_card_le_two (hP.row_probability i) heta + Β· intro j + apply heavyCoordinates_card_le_two + Β· exact ⟨fun i ↦ hP.nonnegative i j, hP.col_sum j⟩ + Β· exact heta + +/-- Missing half-edges at row vertices of the heavy graph. -/ +abbrev RowStub + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) := + Ξ£ i : Fin n, Fin (2 - (heavyCoordinates eta (P i)).card) + +/-- Missing half-edges at column vertices of the heavy graph. -/ +abbrev ColumnStub + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) := + Ξ£ j : Fin n, Fin (2 - (heavyRows eta P j).card) + +/-- The two sides of the bipartite heavy graph have the same total degree. -/ +theorem sum_heavy_degrees + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : + (βˆ‘ i, (heavyCoordinates eta (P i)).card) = + βˆ‘ j, (heavyRows eta P j).card := by + classical + simp only [heavyCoordinates, heavyRows, Finset.card_filter] + rw [Finset.sum_comm] + +theorem stub_card_eq + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + Fintype.card (RowStub eta P) = Fintype.card (ColumnStub eta P) := by + have hdegree := sum_heavy_degrees eta P + have hbounds := heavy_graph_degree_bounds hP heta + have hrow : (βˆ‘ i, ((2 - (heavyCoordinates eta (P i)).card) + + (heavyCoordinates eta (P i)).card)) = βˆ‘ _i : Fin n, 2 := by + apply Finset.sum_congr rfl + intro i _ + exact Nat.sub_add_cancel (hbounds.1 i) + have hcol : (βˆ‘ j, ((2 - (heavyRows eta P j).card) + + (heavyRows eta P j).card)) = βˆ‘ _j : Fin n, 2 := by + apply Finset.sum_congr rfl + intro j _ + exact Nat.sub_add_cancel (hbounds.2 j) + rw [Finset.sum_add_distrib] at hrow hcol + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] at hrow hcol + simp only [RowStub, ColumnStub, Fintype.card_sigma, Fintype.card_fin] + omega + +/-- The formal content of "pair the row stubs arbitrarily with the column +stubs": such a pairing exists because the cardinalities agree. Each paired +stub is an added edge, with parallel edges allowed. -/ +noncomputable def completeHeavyGraphStubEquiv + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + RowStub eta P ≃ ColumnStub eta P := + Fintype.equivOfCardEq (stub_card_eq hP heta) + +/-- The two edge slots at a row, split into existing heavy edges and missing +stubs. -/ +noncomputable def heavyRowSlotEquiv + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) (i : Fin n) : + Fin 2 ≃ (heavyCoordinates eta (P i) : Type) βŠ• + Fin (2 - (heavyCoordinates eta (P i)).card) := by + apply Fintype.equivOfCardEq + simp only [Fintype.card_fin, Fintype.card_sum, Fintype.card_coe] + simpa [Nat.add_comm] using + (Nat.sub_add_cancel (heavy_graph_degree_bounds hP heta |>.1 i)).symm + +/-- The analogous two-slot decomposition at a column. -/ +noncomputable def heavyColumnSlotEquiv + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) (j : Fin n) : + Fin 2 ≃ (heavyRows eta P j : Type) βŠ• + Fin (2 - (heavyRows eta P j).card) := by + apply Fintype.equivOfCardEq + simp only [Fintype.card_fin, Fintype.card_sum, Fintype.card_coe] + simpa [Nat.add_comm] using + (Nat.sub_add_cancel (heavy_graph_degree_bounds hP heta |>.2 j)).symm + +/-- Reindex an existing heavy edge by its column rather than its row. -/ +noncomputable def heavyEdgeTranspose + {n : β„•} (eta : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : + (Ξ£ i, (heavyCoordinates eta (P i) : Type)) ≃ + Ξ£ j, (heavyRows eta P j : Type) where + toFun e := ⟨e.2.1, ⟨e.1, by + simpa [heavyRows, heavyCoordinates] using e.2.2⟩⟩ + invFun e := ⟨e.2.1, ⟨e.1, by + simpa [heavyRows, heavyCoordinates] using e.2.2⟩⟩ + left_inv e := by rcases e with ⟨i, j, h⟩; rfl + right_inv e := by rcases e with ⟨j, i, h⟩; rfl + +/-- The stub completion as an explicit bijection from row edge-slots to +column edge-slots. On existing heavy edges it transposes the endpoints; on +new edges it uses the arbitrary stub pairing. -/ +noncomputable def heavyCompletionSlotEquiv + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + (Ξ£ _i : Fin n, Fin 2) ≃ Ξ£ _j : Fin n, Fin 2 := + (Equiv.sigmaCongrRight fun i ↦ heavyRowSlotEquiv hP heta i) |>.trans + (Equiv.sigmaSumDistrib + (fun i ↦ (heavyCoordinates eta (P i) : Type)) + (fun i ↦ Fin (2 - (heavyCoordinates eta (P i)).card))) |>.trans + (Equiv.sumCongr (heavyEdgeTranspose eta P) + (completeHeavyGraphStubEquiv hP heta)) |>.trans + (Equiv.sigmaSumDistrib + (fun j ↦ (heavyRows eta P j : Type)) + (fun j ↦ Fin (2 - (heavyRows eta P j).card))).symm |>.trans + (Equiv.sigmaCongrRight fun j ↦ (heavyColumnSlotEquiv hP heta j).symm) + +/-- The completed heavy graph, now packaged as a spanning two-regular +bipartite multigraph. -/ +noncomputable def completedHeavyMultigraph + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + TwoRegularBipartiteMultigraph (Fin n) where + edge i k := (heavyCompletionSlotEquiv hP heta ⟨i, k⟩).1 + columnDegree j := by + let E := heavyCompletionSlotEquiv hP heta + calc + (βˆ‘ i, βˆ‘ k : Fin 2, + if (E ⟨i, k⟩).1 = j then 1 else 0) = + βˆ‘ e : Ξ£ _i : Fin n, Fin 2, + if (E e).1 = j then 1 else 0 := by + rw [Fintype.sum_sigma] + _ = βˆ‘ e : Ξ£ _j : Fin n, Fin 2, + if e.1 = j then 1 else 0 := + E.sum_comp (fun e ↦ if e.1 = j then 1 else 0) + _ = 2 := by + rw [Fintype.sum_sigma] + calc + (βˆ‘ x : Fin n, βˆ‘ _y : Fin 2, + if x = j then 1 else 0) = + βˆ‘ x : Fin n, if x = j then 2 else 0 := by + apply Finset.sum_congr rfl + intro x _ + by_cases hx : x = j <;> simp [hx] + _ = 2 := by + rw [Finset.sum_ite_eq' Finset.univ j] + simp + +/-- The stub completion retains every original heavy edge. -/ +theorem heavyEdge_mem_completedHeavyMultigraph + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) + {i j : Fin n} (hij : j ∈ heavyCoordinates eta (P i)) : + βˆƒ k : Fin 2, (completedHeavyMultigraph hP heta).edge i k = j := by + let k := (heavyRowSlotEquiv hP heta i).symm (Sum.inl ⟨j, hij⟩) + refine ⟨k, ?_⟩ + simp [completedHeavyMultigraph, heavyCompletionSlotEquiv, k] + rfl + +/-- The paper's completed heavy graph admits a two-perfect-matching +presentation, and every original heavy edge belongs to one of those +matchings. -/ +theorem exists_heavyCompletion_twoMatchings + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) : + βˆƒ f g : Equiv.Perm (Fin n), + βˆ€ i j, j ∈ heavyCoordinates eta (P i) β†’ + j = f i ∨ j = g i := by + let K := completedHeavyMultigraph hP heta + obtain ⟨f, g, _, hcover⟩ := K.exists_twoMatching_decomposition + refine ⟨f, g, ?_⟩ + intro i j hij + obtain ⟨k, hk⟩ := heavyEdge_mem_completedHeavyMultigraph hP heta hij + rcases hcover i k with h | h + Β· exact Or.inl (hk.symm.trans h) + Β· exact Or.inr (hk.symm.trans h) + +/-- Entropic core of paper Lemma 9. Once the graph argument proves that each +encoding fiber has at most `2^m` assignments, the desired one-bit-per-cycle +bound follows without any further probabilistic input. -/ +theorem coreEncoding_of_fiber_bound + {Ξ© Y : Type*} [Fintype Ξ©] [Fintype Y] + [DecidableEq Ξ©] [DecidableEq Y] + {ΞΌ : Ξ© β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) (encode : Ξ© β†’ Y) + (m : β„•) + (hfiber : βˆ€ y, (Finset.univ.filter fun x ↦ encode x = y).card ≀ 2 ^ m) : + shannonEntropy ΞΌ ≀ + shannonEntropy (pushforwardMass ΞΌ encode) + m * Real.log 2 := by + have h := entropy_le_pushforward_add_log_fiberBound hΞΌ encode (2 ^ m) + (Nat.one_le_pow m 2 (by norm_num)) hfiber + rw [Nat.cast_pow, Nat.cast_ofNat, Real.log_pow] at h + simpa [Nat.cast_ofNat] using h + +/-- Paper Lemma 9 for a completed two-regular bipartite multigraph presented +as the union of two perfect matchings. The nontrivial cycles of the +alternating row permutation are exactly the components with at least two +rows; doubled one-row components contribute no bit. -/ +theorem twoMatching_coreEncoding + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + {ΞΌ : Equiv.Perm Ξ± β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) + (f g : Equiv.Perm Ξ±) : + shannonEntropy ΞΌ ≀ + shannonEntropy + (pushforwardMass ΞΌ (twoMatchingEncoding f g)) + + (alternatingRowPerm f g).cycleFactorsFinset.card * Real.log 2 := by + apply coreEncoding_of_fiber_bound hΞΌ (twoMatchingEncoding f g) + (alternatingRowPerm f g).cycleFactorsFinset.card + exact twoMatchingEncoding_fiber_card_le f g + +/-- Core-encoding entropy bound for an actual stub completion of the paper's +heavy graph. The witnesses `f,g` contain every heavy edge, and the cycle +count is therefore the number of nontrivial components of this completed +two-matching presentation. -/ +theorem exists_heavyCompletion_coreEncoding + {n : β„•} {eta : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (heta : eta ≀ 1 / 10) + {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + βˆƒ f g : Equiv.Perm (Fin n), + (βˆ€ i j, j ∈ heavyCoordinates eta (P i) β†’ + j = f i ∨ j = g i) ∧ + shannonEntropy ΞΌ ≀ + shannonEntropy + (pushforwardMass ΞΌ (twoMatchingEncoding f g)) + + (alternatingRowPerm f g).cycleFactorsFinset.card * Real.log 2 := by + obtain ⟨f, g, hheavy⟩ := exists_heavyCompletion_twoMatchings hP heta + exact ⟨f, g, hheavy, twoMatching_coreEncoding hΞΌ f g⟩ + +/-- Contrapositive of explicit row stability: a bad row pays a definite +fourth-power deficit. -/ +theorem bad_row_deficit_lower + (hrow : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) {eta : ℝ} (heta : 0 ≀ eta) + {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + (hbad : Β¬ IsGoodRow eta p) : + (eta / 3074) ^ 4 < rowDeficit p := by + obtain ⟨a, b, hab, hdist⟩ := row_stability_explicit hrow hn p hp + have hetaDist : eta < halfHalfL1Distance p a b := by + by_contra h + exact hbad ⟨a, b, hab, le_of_not_gt h⟩ + have hroot : eta < 3074 * fourthRoot (rowDeficit p) := + hetaDist.trans_le hdist + have hd0 := hrow hn p hp.1 + have hbase : eta / 3074 < fourthRoot (rowDeficit p) := by + rw [div_lt_iffβ‚€ (by norm_num : (0 : ℝ) < 3074)] + simpa [mul_comm] using hroot + have hpow : (eta / 3074) ^ 4 < fourthRoot (rowDeficit p) ^ 4 := + pow_lt_pow_leftβ‚€ hbase (div_nonneg heta (by norm_num)) (by omega) + rw [fourthRoot_pow_four hd0] at hpow + exact hpow + +/-- Summed form of paper (21): bad rows consume the row-deficit part of the +Bethe slack. -/ +theorem badRow_count_mul_le_sum_deficit + (hrow : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) {eta : ℝ} (heta : 0 ≀ eta) + {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) : + ((badRows eta P).card : ℝ) * (eta / 3074) ^ 4 ≀ + βˆ‘ i, rowDeficit (P i) := by + calc + ((badRows eta P).card : ℝ) * (eta / 3074) ^ 4 = + βˆ‘ i ∈ badRows eta P, (eta / 3074) ^ 4 := by + rw [Finset.sum_const, nsmul_eq_mul] + _ ≀ βˆ‘ i ∈ badRows eta P, rowDeficit (P i) := by + apply Finset.sum_le_sum + intro i hi + have hbad : Β¬ IsGoodRow eta (P i) := by + simpa [badRows] using hi + exact (bad_row_deficit_lower hrow hn heta (hP i) hbad).le + _ ≀ βˆ‘ i, rowDeficit (P i) := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + intro i _ _ + exact hrow hn (P i) (hP i).1 + +theorem badRow_count_le_slack + (hrow : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) {eta Delta : ℝ} (heta : 0 < eta) + {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hsum : (βˆ‘ i, rowDeficit (P i)) ≀ Delta) : + ((badRows eta P).card : ℝ) ≀ Delta / (eta / 3074) ^ 4 := by + have hcost := badRow_count_mul_le_sum_deficit hrow hn heta.le hP + apply (le_div_iffβ‚€ (pow_pos (div_pos heta (by norm_num)) 4)).2 + exact hcost.trans hsum + +/-- Scalar assembly in paper Lemma 13. The two hypotheses are respectively +the entropy-score estimate (29) and the component accounting estimate (30). -/ +theorem robust_cycle_information_of_accounting + {D G components N bad n Ο‰ : ℝ} + (hΟ‰ : 0 ≀ Ο‰) (hG : G ≀ n) + (hscore : + G * (Real.log 2 / 2 - Ο‰) - bad - components * Real.log 2 ≀ D) + (haccount : N / 6 - bad / 2 ≀ G / 2 - components) : + Real.log 2 / 6 * N - + (1 + Real.log 2 / 2) * bad - n * Ο‰ ≀ D := by + have hlog : 0 ≀ Real.log 2 := Real.log_nonneg (by norm_num) + have haccount' := mul_le_mul_of_nonneg_left haccount hlog + have hΟ‰G := mul_le_mul_of_nonneg_right hG hΟ‰ + nlinarith + +/-- A component contributes one ambiguity bit exactly when it has at least +two rows. -/ +def nontrivialComponentCount (k : β„•) : β„• := + if 2 ≀ k then 1 else 0 + +/-- Good rows belonging to components with at least three rows. -/ +def longComponentGoodRows (k g : β„•) : β„• := + if 3 ≀ k then g else 0 + +/-- The component-by-component inequality behind paper (30). It includes +one-row doubled components explicitly: such a component must contain no good +row and contributes no ambiguity bit. -/ +theorem component_accounting + {C : Type*} [Fintype C] + (k g b : C β†’ β„•) + (hpos : βˆ€ c, 1 ≀ k c) + (hpartition : βˆ€ c, g c + b c = k c) + (hone : βˆ€ c, k c = 1 β†’ g c = 0) : + (βˆ‘ c, (g c : ℝ)) / 2 - + βˆ‘ c, (nontrivialComponentCount (k c) : ℝ) β‰₯ + (βˆ‘ c, (longComponentGoodRows (k c) (g c) : ℝ)) / 6 - + (βˆ‘ c, (b c : ℝ)) / 2 := by + have hpoint : βˆ€ c, + (longComponentGoodRows (k c) (g c) : ℝ) / 6 - (b c : ℝ) / 2 ≀ + (g c : ℝ) / 2 - (nontrivialComponentCount (k c) : ℝ) := by + intro c + have hpartR : (g c : ℝ) + b c = k c := by exact_mod_cast hpartition c + by_cases hk3 : 3 ≀ k c + Β· have hk2 : 2 ≀ k c := by omega + simp only [longComponentGoodRows, ite_eq_left hk3, + nontrivialComponentCount, ite_eq_left hk2, Nat.cast_one] + have hk3R : (3 : ℝ) ≀ k c := by exact_mod_cast hk3 + nlinarith + Β· have hklt : k c < 3 := by omega + have hkpos := hpos c + have hkcases : k c = 1 ∨ k c = 2 := by omega + rcases hkcases with hk1 | hk2eq + Β· have hgzero := hone c hk1 + simp [longComponentGoodRows, nontrivialComponentCount, hk1, hgzero] + positivity + Β· have hk2 : 2 ≀ k c := by omega + simp only [longComponentGoodRows, ite_eq_right hk3, + nontrivialComponentCount, ite_eq_left hk2, Nat.cast_zero, zero_div, + Nat.cast_one] + have hk2R : (k c : ℝ) = 2 := by exact_mod_cast hk2eq + nlinarith + calc + (βˆ‘ c, (longComponentGoodRows (k c) (g c) : ℝ)) / 6 - + (βˆ‘ c, (b c : ℝ)) / 2 = + βˆ‘ c, ((longComponentGoodRows (k c) (g c) : ℝ) / 6 - + (b c : ℝ) / 2) := by + rw [Finset.sum_sub_distrib, Finset.sum_div, Finset.sum_div] + _ ≀ βˆ‘ c, ((g c : ℝ) / 2 - + (nontrivialComponentCount (k c) : ℝ)) := + Finset.sum_le_sum fun c _ ↦ hpoint c + _ = (βˆ‘ c, (g c : ℝ)) / 2 - + βˆ‘ c, (nontrivialComponentCount (k c) : ℝ) := by + rw [Finset.sum_sub_distrib, Finset.sum_div] + +/-- Clean two-row components contain at least `n - 2b - N` good rows, +hence half as many disjoint clean pairs. -/ +theorem clean_pair_count + {cleanPairs n bad long : β„•} + (hrows : n - 2 * bad - long ≀ 2 * cleanPairs) : + ((n - 2 * bad - long : β„•) : ℝ) / 2 ≀ cleanPairs := by + apply (div_le_iffβ‚€ (by norm_num : (0 : ℝ) < 2)).2 + have hr : ((n - 2 * bad - long : β„•) : ℝ) ≀ ((2 * cleanPairs : β„•) : ℝ) := by + exact_mod_cast hrows + simpa [mul_comm] using hr + +/-- Markov-counting step used after (44): if every failed clean pair costs at +least `a`, total cost `R` permits at most `R/a` failures. -/ +theorem costly_pair_count + {failed : β„•} {a R : ℝ} (ha : 0 < a) + (hcost : (failed : ℝ) * a ≀ R) : + (failed : ℝ) ≀ R / a := by + exact (le_div_iffβ‚€ ha).2 hcost + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DirectedCertificateValue.lean b/LeanPool/BeyondBethe/BeyondBethe/DirectedCertificateValue.lean new file mode 100644 index 0000000000..24c933f48a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DirectedCertificateValue.lean @@ -0,0 +1,540 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableTransfer +public import LeanPool.BeyondBethe.BeyondBethe.DirectedPairCost +public import Mathlib.Tactic + +/-! # Directed Certificate Value -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Directed evaluation of the executable certificate + +At the nearby KKT matrix, the Bethe objective has a particularly simple +logarithmic form. It uses only the rational point, rational row and column +potentials, and logarithms of `X_ij` and `1-X_ij`; the irrational nearby +matrix never has to be materialized. +-/ + +/-- A directed rational approximation to `log(1-x) + Ο„*x*log x` using scheduled lower +logarithms. -/ +def directedNearbyCoordinateLower + (Ο„ x : β„š) (p : β„•) : β„š := + scheduledLogLower (1 - x) p + + Ο„ * x * scheduledLogLower x p + +/-- The row and column potential sums plus the directed coordinate contributions of the nearby +Bethe expression. -/ +def directedNearbyBetheLower {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (R C : Fin n β†’ β„š) (p : β„•) : β„š := + (βˆ‘ i, R i) + (βˆ‘ j, C j) + + βˆ‘ i, βˆ‘ j, directedNearbyCoordinateLower Ο„ (X i j) p + +theorem weighted_potentials_eq_sum + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) (R C : Fin n β†’ ℝ) : + (βˆ‘ i, βˆ‘ j, X i j * (R i + C j)) = + (βˆ‘ i, R i) + βˆ‘ j, C j := by + have hrow : (βˆ‘ i, βˆ‘ j, X i j * R i) = βˆ‘ i, R i := by + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_mul, hX.row_sum i, one_mul] + have hcol : (βˆ‘ i, βˆ‘ j, X i j * C j) = βˆ‘ j, C j := by + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + rw [← Finset.sum_mul, hX.col_sum j, one_mul] + simp_rw [mul_add, Finset.sum_add_distrib] + rw [hrow, hcol] + +theorem nearbyBetheObjective_eq_logExpression + {n : β„•} {Ο„ : β„š} {Xq : Matrix (Fin n) (Fin n) β„š} + (R C : Fin n β†’ β„š) + (hX : IsDoublyStochastic (fun i j ↦ ((Xq i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((Xq i j : β„š) : ℝ))) : + betheObjective + (nearbyKKTMatrix (Ο„ : ℝ) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ))) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) = + (βˆ‘ i, (R i : ℝ)) + (βˆ‘ j, (C j : ℝ)) + + βˆ‘ i, βˆ‘ j, + (Real.log ((1 - Xq i j : β„š) : ℝ) + + (Ο„ : ℝ) * (Xq i j : ℝ) * + Real.log (Xq i j : ℝ)) := by + let X : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((Xq i j : β„š) : ℝ) + let Rr : Fin n β†’ ℝ := fun i ↦ (R i : ℝ) + let Cr : Fin n β†’ ℝ := fun j ↦ (C j : ℝ) + have hpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hlt : βˆ€ i j, X i j < 1 := fun i j ↦ (hXint i).2 j |>.2 + have hpot := weighted_potentials_eq_sum hX Rr Cr + unfold betheObjective + change (βˆ‘ i, betheRowObjective + (nearbyKKTMatrix (Ο„ : ℝ) X Rr Cr) X i) = _ + simp_rw [betheRowObjective, Real.negMulLog_def] + simp_rw [log_nearbyKKTMatrix hpos hlt] + change (βˆ‘ i, βˆ‘ j, + (X i j * (Rr i + Cr j + (1 + (Ο„ : ℝ)) * Real.log (X i j) + + Real.log (1 - X i j)) + + (-X i j * Real.log (X i j)) + + (1 - X i j) * Real.log (1 - X i j))) = _ + have hcoordinate : βˆ€ i j, + X i j * (Rr i + Cr j + (1 + (Ο„ : ℝ)) * Real.log (X i j) + + Real.log (1 - X i j)) + + (-X i j * Real.log (X i j)) + + (1 - X i j) * Real.log (1 - X i j) = + X i j * (Rr i + Cr j) + + (Real.log (1 - X i j) + + (Ο„ : ℝ) * X i j * Real.log (X i j)) := by + intro i j + ring + simp_rw [hcoordinate, Finset.sum_add_distrib] + rw [hpot] + simp only [X, Rr, Cr] + push_cast + ring + +theorem scheduledLogLower_error {q : β„š} (hq : 0 < q) (p : β„•) : + Real.log (q : ℝ) ≀ + (scheduledLogLower q p : ℝ) + ((1 / 2 : β„š) ^ p : β„š) := by + have hupper := log_le_scheduledLogUpper hq p + have hwidthQ := scheduledLog_width_le hq p + have hwidth : + (scheduledLogUpper q p : ℝ) - + (scheduledLogLower q p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + exact_mod_cast hwidthQ + linarith + +theorem directedNearbyCoordinateLower_bounds + {Ο„ x : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hx0 : 0 < x) (hx1 : x < 1) (p : β„•) : + (directedNearbyCoordinateLower Ο„ x p : ℝ) ≀ + Real.log ((1 - x : β„š) : ℝ) + + (Ο„ : ℝ) * (x : ℝ) * Real.log (x : ℝ) ∧ + Real.log ((1 - x : β„š) : ℝ) + + (Ο„ : ℝ) * (x : ℝ) * Real.log (x : ℝ) ≀ + (directedNearbyCoordinateLower Ο„ x p : ℝ) + + 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + have hcx : 0 < 1 - x := sub_pos.mpr hx1 + have hloX := scheduledLogLower_le_log hx0 p + have hloC := scheduledLogLower_le_log hcx p + have herrX := scheduledLogLower_error hx0 p + have herrC := scheduledLogLower_error hcx p + norm_num only [Rat.cast_sub, Rat.cast_one] at hloC herrC + have hcoef0 : 0 ≀ (Ο„ : ℝ) * (x : ℝ) := by positivity + have hcoef1 : (Ο„ : ℝ) * (x : ℝ) ≀ 1 := by + have hΟ„r : (0 : ℝ) ≀ (Ο„ : ℝ) := by exact_mod_cast hΟ„0 + have hΟ„r1 : (Ο„ : ℝ) ≀ 1 := by exact_mod_cast hΟ„1 + have hxr : (0 : ℝ) ≀ (x : ℝ) := by exact_mod_cast hx0.le + have hxr1 : (x : ℝ) ≀ 1 := by exact_mod_cast hx1.le + nlinarith + rw [directedNearbyCoordinateLower] + push_cast + constructor + Β· exact add_le_add hloC (mul_le_mul_of_nonneg_left hloX hcoef0) + Β· have hscaled := mul_le_mul_of_nonneg_left herrX hcoef0 + have he : 0 ≀ ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) := by positivity + have hcoefError : + ((Ο„ : ℝ) * (x : ℝ)) * + ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) ≀ + ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) := + mul_le_of_le_one_left he hcoef1 + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at herrX herrC hscaled he hcoefError ⊒ + nlinarith + +theorem directedNearbyBetheLower_bounds + {n : β„•} {Ο„ : β„š} {Xq : Matrix (Fin n) (Fin n) β„š} + (R C : Fin n β†’ β„š) + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hX : IsDoublyStochastic (fun i j ↦ ((Xq i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((Xq i j : β„š) : ℝ))) (p : β„•) : + (directedNearbyBetheLower Ο„ Xq R C p : ℝ) ≀ + betheObjective + (nearbyKKTMatrix (Ο„ : ℝ) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ))) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) ∧ + betheObjective + (nearbyKKTMatrix (Ο„ : ℝ) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ))) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) ≀ + (directedNearbyBetheLower Ο„ Xq R C p : ℝ) + + 2 * (n : ℝ) ^ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + let exactCoordinate : Fin n β†’ Fin n β†’ ℝ := fun i j ↦ + Real.log ((1 - Xq i j : β„š) : ℝ) + + (Ο„ : ℝ) * (Xq i j : ℝ) * Real.log (Xq i j : ℝ) + let lowerCoordinate : Fin n β†’ Fin n β†’ ℝ := fun i j ↦ + (directedNearbyCoordinateLower Ο„ (Xq i j) p : ℝ) + have hcoord : βˆ€ i j, + lowerCoordinate i j ≀ exactCoordinate i j ∧ + exactCoordinate i j ≀ lowerCoordinate i j + + 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + intro i j + have hx0 : 0 < Xq i j := by + have h := (hXint i).2 j |>.1 + change 0 < ((Xq i j : β„š) : ℝ) at h + exact Rat.cast_pos.mp h + have hx1 : Xq i j < 1 := by + have h := (hXint i).2 j |>.2 + change ((Xq i j : β„š) : ℝ) < 1 at h + exact (Rat.cast_lt (K := ℝ)).mp (by simpa using! h) + exact directedNearbyCoordinateLower_bounds hΟ„0 hΟ„1 hx0 hx1 p + have hsumLower : (βˆ‘ i, βˆ‘ j, lowerCoordinate i j) ≀ + βˆ‘ i, βˆ‘ j, exactCoordinate i j := + Finset.sum_le_sum fun i _ ↦ Finset.sum_le_sum fun j _ ↦ (hcoord i j).1 + have hsumUpper : (βˆ‘ i, βˆ‘ j, exactCoordinate i j) ≀ + (βˆ‘ i, βˆ‘ j, lowerCoordinate i j) + + 2 * (n : ℝ) ^ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + calc + (βˆ‘ i, βˆ‘ j, exactCoordinate i j) ≀ + βˆ‘ i, βˆ‘ j, (lowerCoordinate i j + + 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ)) := + Finset.sum_le_sum fun i _ ↦ + Finset.sum_le_sum fun j _ ↦ (hcoord i j).2 + _ = (βˆ‘ i, βˆ‘ j, lowerCoordinate i j) + + 2 * (n : ℝ) ^ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + simp [Finset.sum_add_distrib] + ring + rw [nearbyBetheObjective_eq_logExpression R C hX hXint] + rw [directedNearbyBetheLower] + push_cast + have hsumLower' : + (βˆ‘ i, βˆ‘ j, (directedNearbyCoordinateLower Ο„ (Xq i j) p : ℝ)) ≀ + βˆ‘ i, βˆ‘ j, (Real.log ((1 - Xq i j : β„š) : ℝ) + + (Ο„ : ℝ) * (Xq i j : ℝ) * Real.log (Xq i j : ℝ)) := by + simpa only [lowerCoordinate, exactCoordinate] using! hsumLower + have hsumUpper' : + (βˆ‘ i, βˆ‘ j, (Real.log ((1 - Xq i j : β„š) : ℝ) + + (Ο„ : ℝ) * (Xq i j : ℝ) * Real.log (Xq i j : ℝ))) ≀ + (βˆ‘ i, βˆ‘ j, + (directedNearbyCoordinateLower Ο„ (Xq i j) p : ℝ)) + + 2 * (n : ℝ) ^ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + simpa only [lowerCoordinate, exactCoordinate] using! hsumUpper + norm_num only [Rat.cast_sub, Rat.cast_one, Rat.cast_pow, + Rat.cast_div, Rat.cast_ofNat] at hsumLower' hsumUpper' ⊒ + constructor <;> linarith + +/-- Fixed precision used for evaluating the final logarithmic certificate. +The additive constant is deliberately generous; it is independent of the +input and absorbs the tiny hard-coded structural scale. -/ +def directedCertificatePrecision (n : β„•) : β„• := n + 400 + +@[simp] theorem directedCertificatePrecision_eq_pairCostPrecision (n : β„•) : + directedCertificatePrecision n = directedPairCostPrecision n := by + rfl + +/-- The KKT error allowance, equal to one thirty-second of the certified improvement. -/ +def explicitKKTError : β„š := explicitCertifiedEpsilon / 32 + +/-- The logarithm evaluation loss allowance, equal to one thirty-second of the certified +improvement. -/ +def explicitLogEvaluationLoss : β„š := explicitCertifiedEpsilon / 32 + +/-- The exponential evaluation loss allowance, equal to one thirty-second of the certified +improvement. -/ +def explicitExpEvaluationLoss : β„š := explicitCertifiedEpsilon / 32 + +theorem explicitKKTError_pos : 0 < explicitKKTError := by + exact div_pos explicitCertifiedEpsilon_pos (by norm_num) + +theorem explicitLogEvaluationLoss_pos : 0 < explicitLogEvaluationLoss := by + exact div_pos explicitCertifiedEpsilon_pos (by norm_num) + +theorem explicitExpEvaluationLoss_pos : 0 < explicitExpEvaluationLoss := by + exact div_pos explicitCertifiedEpsilon_pos (by norm_num) + +theorem dyadic_399_le_logEvaluationLoss : + (1 / 2 : ℝ) ^ 399 ≀ (explicitLogEvaluationLoss : ℝ) := by + have hq : (1 / 2 : β„š) ^ 399 ≀ explicitLogEvaluationLoss := by + rw [explicitLogEvaluationLoss, explicitCertifiedEpsilon, + explicitCertifiedEpsilon_eq] + norm_num [explicitXi, explicitDelta, explicitEta, explicitRowRatio] + exact (pow_le_pow_of_le_one (by norm_num : 0 ≀ (1 / 2 : β„š)) + (by norm_num : (1 / 2 : β„š) ≀ 1) (show 240 ≀ 399 by omega)).trans (by norm_num) + have hcast : (((1 / 2 : β„š) ^ 399 : β„š) : ℝ) ≀ + (explicitLogEvaluationLoss : ℝ) := Rat.cast_le.mpr hq + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at hcast + exact hcast + +theorem directedCertificatePrecision_error + {n : β„•} (hn : 1 ≀ n) : + 2 * (n : ℝ) ^ 2 * + (((1 / 2 : β„š) ^ directedCertificatePrecision n : β„š) : ℝ) ≀ + (explicitLogEvaluationLoss : ℝ) * n := by + have hnat : n ≀ 2 ^ n := n.lt_two_pow_self.le + have hnatR : (n : ℝ) ≀ (2 : ℝ) ^ n := by exact_mod_cast hnat + have hpowpos : 0 < (2 : ℝ) ^ n := by positivity + have hratio : (n : ℝ) * (1 / 2 : ℝ) ^ n ≀ 1 := by + simp only [one_div, inv_pow] + rw [mul_inv_le_iffβ‚€ hpowpos] + simpa using! hnatR + have hconst := dyadic_399_le_logEvaluationLoss + rw [directedCertificatePrecision, pow_add] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, + Rat.cast_one, Rat.cast_ofNat] + have hnR : (0 : ℝ) ≀ n := by positivity + have hshift : 2 * (1 / 2 : ℝ) ^ 400 = (1 / 2 : ℝ) ^ 399 := by + rw [show 400 = 399 + 1 by omega, pow_succ] + ring + have hratioScaled : + (n : ℝ) * ((n : ℝ) * (1 / 2 : ℝ) ^ n) * + (1 / 2 : ℝ) ^ 399 ≀ + (n : ℝ) * 1 * (1 / 2 : ℝ) ^ 399 := by + exact mul_le_mul_of_nonneg_right + (mul_le_mul_of_nonneg_left hratio hnR) + (pow_nonneg (by norm_num) _) + calc + 2 * (n : ℝ) ^ 2 * + ((1 / 2 : ℝ) ^ n * (1 / 2 : ℝ) ^ 400) = + (n : ℝ) * + ((n : ℝ) * (1 / 2 : ℝ) ^ n) * + (1 / 2 : ℝ) ^ 399 := by + rw [← hshift] + ring + _ ≀ (n : ℝ) * 1 * (1 / 2 : ℝ) ^ 399 := hratioScaled + _ = (n : ℝ) * (1 / 2 : ℝ) ^ 399 := by ring + _ ≀ (n : ℝ) * (explicitLogEvaluationLoss : ℝ) := + mul_le_mul_of_nonneg_left hconst hnR + _ = (explicitLogEvaluationLoss : ℝ) * n := by ring + +/-- Rational lower endpoint for the complete nearby certificate logarithm. -/ +def explicitDirectedCertificateLog {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : β„š := + directedNearbyBetheLower (explicitRegularizationScale n) X R C + (directedCertificatePrecision n) + + explicitCertifiedMatchingGain X - explicitKKTError * n + +/-- Fully rational positive certificate computed from rational approximate-KKT +data. -/ +def explicitDirectedCertificateValue {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : β„š := + rationalExpLower (explicitDirectedCertificateLog X R C) + (explicitExpEvaluationLoss * n) + +theorem explicitDirectedCertificateLog_bounds + {n : β„•} (hn : 2 ≀ n) + {X : Matrix (Fin n) (Fin n) β„š} (R C : Fin n β†’ β„š) + (hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) : + (explicitDirectedCertificateLog X R C : ℝ) ≀ + executableNearbyCertificateLog (explicitKKTError : ℝ) X + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ)) ∧ + executableNearbyCertificateLog (explicitKKTError : ℝ) X + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ)) ≀ + (explicitDirectedCertificateLog X R C : ℝ) + + (explicitLogEvaluationLoss : ℝ) * n := by + have hΟ„0 : 0 ≀ explicitRegularizationScale n := + (explicitRegularizationScale_pos (show 0 < n by omega)).le + have hΟ„1 : explicitRegularizationScale n ≀ 1 := + explicitRegularizationScale_le_one (show 1 ≀ n by omega) + have hb := directedNearbyBetheLower_bounds R C hΟ„0 hΟ„1 hX hXint + (directedCertificatePrecision n) + have herr := directedCertificatePrecision_error (show 1 ≀ n by omega) + rw [explicitDirectedCertificateLog, executableNearbyCertificateLog] + norm_num only [Rat.cast_add, Rat.cast_sub, Rat.cast_mul, Rat.cast_natCast] + constructor <;> linarith + +theorem explicitDirectedCertificateValue_pos + {n : β„•} (hn : 1 ≀ n) + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + 0 < (explicitDirectedCertificateValue X R C : ℝ) := by + have hlossQ : 0 < explicitExpEvaluationLoss * n := + mul_pos explicitExpEvaluationLoss_pos (by exact_mod_cast hn) + have h := rationalExpLower_bounds + (s := explicitDirectedCertificateLog X R C) hlossQ + exact (Real.exp_pos _).trans_le h.1 + +/-- The fully rational certificate inherits the positive-matrix estimate. +All three numerical losses are explicit: approximate KKT transfer, directed +logarithms, and directed exponentiation. -/ +theorem explicitDirectedCertificate_twoSided + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {n : β„•} (hn : 2 ≀ n) + {A : Matrix (Fin n) (Fin n) ℝ} + {X : Matrix (Fin n) (Fin n) β„š} {R C : Fin n β†’ β„š} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (happrox : HasApproximateLogKKT (explicitKKTError : ℝ) + (explicitRegularizationScale n : ℝ) A + (fun i j ↦ ((X i j : β„š) : ℝ)) + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ))) : + (explicitDirectedCertificateValue X R C : ℝ) ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n * + (explicitDirectedCertificateValue X R C : ℝ) := by + let qlog : ℝ := (explicitDirectedCertificateLog X R C : ℝ) + let exactLog : ℝ := executableNearbyCertificateLog + (explicitKKTError : ℝ) X + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ)) + let qvalue : ℝ := (explicitDirectedCertificateValue X R C : ℝ) + let L : ℝ := executableNearbyCertificateValue + (explicitKKTError : ℝ) X + (fun i ↦ (R i : ℝ)) (fun j ↦ (C j : ℝ)) + have hlog := explicitDirectedCertificateLog_bounds hn R C hX hXint + have hlog' : qlog ≀ exactLog ∧ + exactLog ≀ qlog + (explicitLogEvaluationLoss : ℝ) * n := by + simpa only [qlog, exactLog] using! hlog + have hlossQ : 0 < explicitExpEvaluationLoss * n := + mul_pos explicitExpEvaluationLoss_pos (by exact_mod_cast (show 0 < n by omega)) + have hexpQ := rationalExpLower_bounds + (s := explicitDirectedCertificateLog X R C) hlossQ + have hexp : Real.exp + (qlog - (explicitExpEvaluationLoss : ℝ) * n) ≀ qvalue ∧ + qvalue ≀ Real.exp qlog := by + simpa only [qlog, qvalue, explicitDirectedCertificateValue, + Rat.cast_mul, Rat.cast_natCast] using! hexpQ + have htransfer := executableNearbyCertificate_twoSided + stableCoefficient hn hA hX hXint happrox + have htransfer' : L ≀ Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ)))) ^ n * L := by + simpa only [L, explicitCertifiedEpsilon] using! htransfer + have hL : L = Real.exp exactLog := by + rfl + constructor + Β· have hqL : qvalue ≀ L := by + rw [hL] + exact hexp.2.trans (Real.exp_le_exp.mpr hlog'.1) + exact hqL.trans htransfer'.1 + Β· have hLq : L ≀ + (Real.exp (explicitLogEvaluationLoss : ℝ) * + Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n * qvalue := by + rw [hL] + have hfirst : Real.exp exactLog ≀ + (Real.exp (explicitLogEvaluationLoss : ℝ)) ^ n * + Real.exp qlog := by + calc + Real.exp exactLog ≀ Real.exp + (qlog + (explicitLogEvaluationLoss : ℝ) * n) := + Real.exp_le_exp.mpr hlog'.2 + _ = (Real.exp (explicitLogEvaluationLoss : ℝ)) ^ n * + Real.exp qlog := by + rw [Real.exp_add] + rw [show (explicitLogEvaluationLoss : ℝ) * (n : ℝ) = + (n : ℝ) * (explicitLogEvaluationLoss : ℝ) by ring, + Real.exp_nat_mul] + ring + have hsecond : Real.exp qlog ≀ + (Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n * qvalue := by + have hfactor0 : 0 ≀ + (Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n := + pow_nonneg (Real.exp_pos _).le n + have hscaled := mul_le_mul_of_nonneg_left hexp.1 hfactor0 + have hid : (Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n * + Real.exp (qlog - (explicitExpEvaluationLoss : ℝ) * n) = + Real.exp qlog := by + rw [← Real.exp_nat_mul, ← Real.exp_add] + congr 1 + ring + rwa [hid] at hscaled + calc + Real.exp exactLog ≀ + (Real.exp (explicitLogEvaluationLoss : ℝ)) ^ n * + Real.exp qlog := hfirst + _ ≀ (Real.exp (explicitLogEvaluationLoss : ℝ)) ^ n * + ((Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n * qvalue) := + mul_le_mul_of_nonneg_left hsecond + (pow_nonneg (Real.exp_pos _).le n) + _ = (Real.exp (explicitLogEvaluationLoss : ℝ) * + Real.exp (explicitExpEvaluationLoss : ℝ)) ^ n * qvalue := by + rw [mul_pow] + ring + have hraw := htransfer'.2.trans + (mul_le_mul_of_nonneg_left hLq + (pow_nonneg (mul_nonneg (Real.sqrt_nonneg _) + (Real.exp_pos _).le) n)) + have hbase : + (Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ)))) * + (Real.exp (explicitLogEvaluationLoss : ℝ) * + Real.exp (explicitExpEvaluationLoss : ℝ)) ≀ + preSmoothingBase (explicitCertifiedEpsilon : ℝ) := by + rw [preSmoothingBase] + have hΞ΅0 : 0 < (explicitCertifiedEpsilon : ℝ) := by + exact_mod_cast explicitCertifiedEpsilon_pos + have hsqrt : 0 < Real.sqrt 2 := Real.sqrt_pos.2 (by norm_num) + have hexpMono : + Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ)) + + (explicitLogEvaluationLoss : ℝ) + + (explicitExpEvaluationLoss : ℝ)) ≀ + Real.exp (-(explicitCertifiedEpsilon : ℝ) + + (explicitCertifiedEpsilon : ℝ) / 4) := by + apply Real.exp_le_exp.mpr + norm_num [explicitKKTError, explicitLogEvaluationLoss, + explicitExpEvaluationLoss] + nlinarith + calc + Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ))) * + (Real.exp (explicitLogEvaluationLoss : ℝ) * + Real.exp (explicitExpEvaluationLoss : ℝ)) = + Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ)) + + (explicitLogEvaluationLoss : ℝ) + + (explicitExpEvaluationLoss : ℝ)) := by + rw [← Real.exp_add + (explicitLogEvaluationLoss : ℝ) + (explicitExpEvaluationLoss : ℝ)] + rw [show Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ))) * + Real.exp ((explicitLogEvaluationLoss : ℝ) + + (explicitExpEvaluationLoss : ℝ)) = + Real.sqrt 2 * + (Real.exp (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ))) * + Real.exp ((explicitLogEvaluationLoss : ℝ) + + (explicitExpEvaluationLoss : ℝ))) by ring] + rw [← Real.exp_add] + congr 2 + ring + _ ≀ Real.sqrt 2 * Real.exp + (-(explicitCertifiedEpsilon : ℝ) + + (explicitCertifiedEpsilon : ℝ) / 4) := + mul_le_mul_of_nonneg_left hexpMono hsqrt.le + have hbasePow := pow_le_pow_leftβ‚€ + (mul_nonneg (mul_nonneg (Real.sqrt_nonneg _) (Real.exp_pos _).le) + (mul_nonneg (Real.exp_pos _).le (Real.exp_pos _).le)) hbase n + calc + Matrix.permanent A ≀ + ((Real.sqrt 2 * Real.exp + (-((explicitCertifiedEpsilon : ℝ) - + 2 * (explicitKKTError : ℝ)))) * + (Real.exp (explicitLogEvaluationLoss : ℝ) * + Real.exp (explicitExpEvaluationLoss : ℝ))) ^ n * qvalue := by + simpa [mul_pow, mul_assoc] using! hraw + _ ≀ (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ n * qvalue := + mul_le_mul_of_nonneg_right hbasePow + (explicitDirectedCertificateValue_pos (show 1 ≀ n by omega) X R C).le + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DirectedElementary.lean b/LeanPool/BeyondBethe/BeyondBethe/DirectedElementary.lean new file mode 100644 index 0000000000..7381b5fe88 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DirectedElementary.lean @@ -0,0 +1,891 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import Mathlib.Analysis.SpecialFunctions.Log.Deriv +public import Mathlib.Data.Nat.Log +public import Mathlib.Data.Rat.Floor + +/-! # Directed Elementary -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The first `N` terms of twice the inverse-hyperbolic-tangent series, +computed exactly over the rationals. -/ +def rationalLogSeries (x : β„š) (N : β„•) : β„š := + 2 * βˆ‘ k ∈ Finset.range N, x ^ (2 * k + 1) / (2 * k + 1) + +/-- A rational upper bound for the omitted tail when `0 ≀ x < 1`. -/ +def rationalLogSeriesError (x : β„š) (N : β„•) : β„š := + 2 * (x ^ (2 * N + 1) / (1 - x ^ 2)) + +theorem cast_rationalLogSeries (x : β„š) (N : β„•) : + ((rationalLogSeries x N : β„š) : ℝ) = + 2 * βˆ‘ k ∈ Finset.range N, + (x : ℝ) ^ (2 * k + 1) / (2 * k + 1) := by + simp [rationalLogSeries] + +theorem cast_rationalLogSeriesError (x : β„š) (N : β„•) : + ((rationalLogSeriesError x N : β„š) : ℝ) = + 2 * ((x : ℝ) ^ (2 * N + 1) / (1 - (x : ℝ) ^ 2)) := by + simp [rationalLogSeriesError] + +/-- The range-reduction parameter taking `y ∈ [1,2]` to `x ∈ [0,1/3]`. -/ +def rationalLogUnitParameter (y : β„š) : β„š := (y - 1) / (y + 1) + +theorem rationalLogUnitParameter_nonneg {y : β„š} (hy : 1 ≀ y) : + 0 ≀ rationalLogUnitParameter y := by + exact div_nonneg (sub_nonneg.mpr hy) (by linarith) + +theorem rationalLogUnitParameter_lt_one {y : β„š} (hy : 1 ≀ y) : + rationalLogUnitParameter y < 1 := by + rw [rationalLogUnitParameter, div_lt_one (by linarith)] + linarith + +theorem rationalLogUnitParameter_le_third {y : β„š} + (hy1 : 1 ≀ y) (hy2 : y ≀ 2) : + rationalLogUnitParameter y ≀ 1 / 3 := by + rw [rationalLogUnitParameter, div_le_iffβ‚€ (by linarith)] + linarith + +theorem rationalLogUnitParameter_ratio {y : β„š} (hy : 1 ≀ y) : + (1 + rationalLogUnitParameter y) / + (1 - rationalLogUnitParameter y) = y := by + have hden : y + 1 β‰  0 := by linarith + rw [rationalLogUnitParameter] + field_simp [hden] + ring + +/-- Directed lower approximation to `log y` for a rational `y ∈ [1,2]`. -/ +def directedLogUnitLower (y : β„š) (N : β„•) : β„š := + rationalLogSeries (rationalLogUnitParameter y) N + +/-- Directed upper approximation to `log y` for a rational `y ∈ [1,2]`. -/ +def directedLogUnitUpper (y : β„š) (N : β„•) : β„š := + rationalLogSeries (rationalLogUnitParameter y) N + + rationalLogSeriesError (rationalLogUnitParameter y) N + +theorem directedLogUnitLower_le_log {y : β„š} (hy : 1 ≀ y) (N : β„•) : + ((directedLogUnitLower y N : β„š) : ℝ) ≀ Real.log (y : ℝ) := by + let x := rationalLogUnitParameter y + have hx0q : 0 ≀ x := rationalLogUnitParameter_nonneg hy + have hx1q : x < 1 := rationalLogUnitParameter_lt_one hy + have hx0 : 0 ≀ (x : ℝ) := by exact_mod_cast hx0q + have hx1 : (x : ℝ) < 1 := by exact_mod_cast hx1q + have h := Real.sum_range_le_log_div hx0 hx1 N + have hratioq := rationalLogUnitParameter_ratio hy + have hratio : (1 + (x : ℝ)) / (1 - (x : ℝ)) = (y : ℝ) := by + exact_mod_cast hratioq + rw [hratio] at h + rw [directedLogUnitLower, cast_rationalLogSeries] + dsimp only [x] at h ⊒ + linarith + +theorem log_le_directedLogUnitUpper {y : β„š} (hy : 1 ≀ y) (N : β„•) : + Real.log (y : ℝ) ≀ ((directedLogUnitUpper y N : β„š) : ℝ) := by + let x := rationalLogUnitParameter y + have hx0q : 0 ≀ x := rationalLogUnitParameter_nonneg hy + have hx1q : x < 1 := rationalLogUnitParameter_lt_one hy + have hx0 : 0 ≀ (x : ℝ) := by exact_mod_cast hx0q + have hx1 : (x : ℝ) < 1 := by exact_mod_cast hx1q + have h := Real.log_div_le_sum_range_add hx0 hx1 N + have hratioq := rationalLogUnitParameter_ratio hy + have hratio : (1 + (x : ℝ)) / (1 - (x : ℝ)) = (y : ℝ) := by + exact_mod_cast hratioq + rw [hratio] at h + rw [directedLogUnitUpper, Rat.cast_add, cast_rationalLogSeries, + cast_rationalLogSeriesError] + dsimp only [x] at h ⊒ + linarith + +theorem directedLogUnit_width {y : β„š} (N : β„•) : + directedLogUnitUpper y N - directedLogUnitLower y N = + rationalLogSeriesError (rationalLogUnitParameter y) N := by + simp [directedLogUnitUpper, directedLogUnitLower] + +/-- The dyadic scale obtained by comparing the leading binary positions of a +positive rational's numerator and denominator. -/ +def rationalBinaryScale (q : β„š) : β„š := + (2 : β„š) ^ Nat.log 2 q.num.natAbs / (2 : β„š) ^ Nat.log 2 q.den + +/-- The residual after dyadic range reduction. -/ +def rationalBinaryResidual (q : β„š) : β„š := q / rationalBinaryScale q + +theorem positive_rational_num_natAbs_ne_zero {q : β„š} (hq : 0 < q) : + q.num.natAbs β‰  0 := by + have hnum : 0 < q.num := Rat.num_pos.mpr hq + exact Int.natAbs_ne_zero.mpr hnum.ne' + +theorem rationalBinaryResidual_formula {q : β„š} (hq : 0 < q) : + rationalBinaryResidual q = + ((q.num.natAbs : β„š) * (2 : β„š) ^ Nat.log 2 q.den) / + ((q.den : β„š) * (2 : β„š) ^ Nat.log 2 q.num.natAbs) := by + have hnum : 0 < q.num := Rat.num_pos.mpr hq + have hnumabs : (q.num.natAbs : β„€) = q.num := + Int.natAbs_of_nonneg hnum.le + have hden : (q.den : β„š) β‰  0 := by positivity + have hpowNum : (2 : β„š) ^ Nat.log 2 q.num.natAbs β‰  0 := by positivity + have hpowDen : (2 : β„š) ^ Nat.log 2 q.den β‰  0 := by positivity + have hqrep : q = (q.num.natAbs : β„š) / (q.den : β„š) := by + calc + q = (q.num : β„š) / (q.den : β„š) := (Rat.num_div_den q).symm + _ = (q.num.natAbs : β„š) / (q.den : β„š) := by + congr 1 + change (q.num : β„š) = ((q.num.natAbs : β„€) : β„š) + rw [hnumabs] + rw [rationalBinaryResidual, rationalBinaryScale] + nth_rw 1 [hqrep] + field_simp [hden, hpowNum, hpowDen] + +theorem rationalBinaryResidual_gt_half {q : β„š} (hq : 0 < q) : + 1 / 2 < rationalBinaryResidual q := by + let a := q.num.natAbs + let b := q.den + let A : β„š := (2 : β„š) ^ Nat.log 2 a + let B : β„š := (2 : β„š) ^ Nat.log 2 b + have ha0 : a β‰  0 := positive_rational_num_natAbs_ne_zero hq + have hb0 : b β‰  0 := q.den_nz + have hA : A ≀ (a : β„š) := by + dsimp only [A] + exact_mod_cast Nat.pow_log_le_self 2 ha0 + have hB : B ≀ (b : β„š) := by + dsimp only [B] + exact_mod_cast Nat.pow_log_le_self 2 hb0 + have haUpper : (a : β„š) < 2 * A := by + have := Nat.lt_pow_succ_log_self (by norm_num : 1 < 2) a + dsimp only [A] + exact_mod_cast (by simpa [pow_succ, mul_comm] using this) + have hbUpper : (b : β„š) < 2 * B := by + have := Nat.lt_pow_succ_log_self (by norm_num : 1 < 2) b + dsimp only [B] + exact_mod_cast (by simpa [pow_succ, mul_comm] using this) + have hApos : 0 < A := by positivity + have hBpos : 0 < B := by positivity + have habpos : 0 < (b : β„š) * A := mul_pos (by positivity) hApos + have hprod : (b : β„š) * A < 2 * ((a : β„š) * B) := calc + (b : β„š) * A < (2 * B) * A := + mul_lt_mul_of_pos_right hbUpper hApos + _ ≀ (2 * B) * a := + mul_le_mul_of_nonneg_left hA (mul_nonneg (by norm_num) hBpos.le) + _ = 2 * (a * B) := by ring + rw [rationalBinaryResidual_formula hq] + change 1 / 2 < (a * B) / (b * A) + rw [div_lt_div_iffβ‚€ (by norm_num : (0 : β„š) < 2) habpos] + simpa [mul_assoc, mul_left_comm, mul_comm] using hprod + +theorem rationalBinaryResidual_lt_two {q : β„š} (hq : 0 < q) : + rationalBinaryResidual q < 2 := by + let a := q.num.natAbs + let b := q.den + let A : β„š := (2 : β„š) ^ Nat.log 2 a + let B : β„š := (2 : β„š) ^ Nat.log 2 b + have ha0 : a β‰  0 := positive_rational_num_natAbs_ne_zero hq + have hb0 : b β‰  0 := q.den_nz + have hA : A ≀ (a : β„š) := by + dsimp only [A] + exact_mod_cast Nat.pow_log_le_self 2 ha0 + have hB : B ≀ (b : β„š) := by + dsimp only [B] + exact_mod_cast Nat.pow_log_le_self 2 hb0 + have haUpper : (a : β„š) < 2 * A := by + have := Nat.lt_pow_succ_log_self (by norm_num : 1 < 2) a + dsimp only [A] + exact_mod_cast (by simpa [pow_succ, mul_comm] using this) + have hbUpper : (b : β„š) < 2 * B := by + have := Nat.lt_pow_succ_log_self (by norm_num : 1 < 2) b + dsimp only [B] + exact_mod_cast (by simpa [pow_succ, mul_comm] using this) + have hApos : 0 < A := by positivity + have hBpos : 0 < B := by positivity + have habpos : 0 < (b : β„š) * A := mul_pos (by positivity) hApos + have hprod : (a : β„š) * B < 2 * ((b : β„š) * A) := calc + (a : β„š) * B < (2 * A) * B := + mul_lt_mul_of_pos_right haUpper hBpos + _ ≀ (2 * A) * b := + mul_le_mul_of_nonneg_left hB (mul_nonneg (by norm_num) hApos.le) + _ = 2 * (b * A) := by ring + rw [rationalBinaryResidual_formula hq] + change (a * B) / (b * A) < 2 + rw [div_lt_iffβ‚€ habpos] + simpa using hprod + +theorem rationalBinaryResidual_pos {q : β„š} (hq : 0 < q) : + 0 < rationalBinaryResidual q := + (by norm_num : (0 : β„š) < 1 / 2).trans (rationalBinaryResidual_gt_half hq) + +/-- If the residual is below one, inversion moves it into the unit interval; +otherwise it is already there. -/ +def rationalLogUnit (q : β„š) : β„š := + if rationalBinaryResidual q < 1 then + (rationalBinaryResidual q)⁻¹ + else rationalBinaryResidual q + +theorem rationalLogUnit_bounds {q : β„š} (hq : 0 < q) : + 1 ≀ rationalLogUnit q ∧ rationalLogUnit q < 2 := by + have hr0 := rationalBinaryResidual_pos hq + have hrHalf := rationalBinaryResidual_gt_half hq + have hrTwo := rationalBinaryResidual_lt_two hq + rw [rationalLogUnit] + split_ifs with hr + Β· constructor + Β· exact (one_le_invβ‚€ hr0).2 hr.le + Β· have hinv := (inv_lt_invβ‚€ hr0 (by norm_num : (0 : β„š) < 1 / 2)).2 hrHalf + norm_num at hinv ⊒ + exact hinv + Β· exact ⟨le_of_not_gt hr, hrTwo⟩ + +/-- The signed leading-bit displacement between numerator and denominator. -/ +def rationalBinaryExponent (q : β„š) : β„€ := + (Nat.log 2 q.num.natAbs : β„€) - (Nat.log 2 q.den : β„€) + +theorem rationalBinaryScale_pos (q : β„š) : 0 < rationalBinaryScale q := by + unfold rationalBinaryScale + positivity + +theorem log_rationalBinaryScale (q : β„š) : + Real.log (rationalBinaryScale q : ℝ) = + (rationalBinaryExponent q : ℝ) * Real.log 2 := by + have hnum : ((2 : ℝ) ^ Nat.log 2 q.num.natAbs) β‰  0 := by positivity + have hden : ((2 : ℝ) ^ Nat.log 2 q.den) β‰  0 := by positivity + rw [rationalBinaryScale, Rat.cast_div, Rat.cast_pow, Rat.cast_pow, + Rat.cast_ofNat, Real.log_div hnum hden, Real.log_pow, Real.log_pow] + simp only [rationalBinaryExponent, Int.cast_sub, Int.cast_natCast] + ring + +theorem log_rational_eq_scale_add_residual {q : β„š} (hq : 0 < q) : + Real.log (q : ℝ) = + (rationalBinaryExponent q : ℝ) * Real.log 2 + + Real.log (rationalBinaryResidual q : ℝ) := by + have hsQ := rationalBinaryScale_pos q + have hrQ := rationalBinaryResidual_pos hq + have hs : 0 < (rationalBinaryScale q : ℝ) := by exact_mod_cast hsQ + have hr : 0 < (rationalBinaryResidual q : ℝ) := by exact_mod_cast hrQ + have hqeqQ : q = rationalBinaryScale q * rationalBinaryResidual q := by + rw [rationalBinaryResidual] + field_simp [(rationalBinaryScale_pos q).ne'] + have hqeq : (q : ℝ) = + (rationalBinaryScale q : ℝ) * (rationalBinaryResidual q : ℝ) := by + exact_mod_cast hqeqQ + rw [hqeq, Real.log_mul hs.ne' hr.ne', log_rationalBinaryScale] + +theorem log_residual_eq_signed_log_unit {q : β„š} (hq : 0 < q) : + Real.log (rationalBinaryResidual q : ℝ) = + if rationalBinaryResidual q < 1 then + -Real.log (rationalLogUnit q : ℝ) + else Real.log (rationalLogUnit q : ℝ) := by + have hrQ := rationalBinaryResidual_pos hq + have hr : (rationalBinaryResidual q : ℝ) β‰  0 := by + exact_mod_cast hrQ.ne' + rw [rationalLogUnit] + split_ifs with h + Β· simp [Rat.cast_inv, Real.log_inv] + Β· rfl + +/-- Directed multiplication by an integer: for a negative coefficient the +lower endpoint uses the upper approximation. -/ +def directedIntMulLower (k : β„€) (lo hi : β„š) : β„š := + if 0 ≀ k then (k : β„š) * lo else (k : β„š) * hi + +/-- Directed multiplication by an integer: for a negative coefficient the +upper endpoint uses the lower approximation. -/ +def directedIntMulUpper (k : β„€) (lo hi : β„š) : β„š := + if 0 ≀ k then (k : β„š) * hi else (k : β„š) * lo + +theorem directedIntMulLower_le {k : β„€} {lo hi : β„š} {x : ℝ} + (hlo : (lo : ℝ) ≀ x) (hhi : x ≀ (hi : ℝ)) : + ((directedIntMulLower k lo hi : β„š) : ℝ) ≀ (k : ℝ) * x := by + rw [directedIntMulLower] + split_ifs with hk + Β· push_cast + exact mul_le_mul_of_nonneg_left hlo (by exact_mod_cast hk) + Β· push_cast + exact mul_le_mul_of_nonpos_left hhi (by exact_mod_cast (le_of_not_ge hk)) + +theorem le_directedIntMulUpper {k : β„€} {lo hi : β„š} {x : ℝ} + (hlo : (lo : ℝ) ≀ x) (hhi : x ≀ (hi : ℝ)) : + (k : ℝ) * x ≀ ((directedIntMulUpper k lo hi : β„š) : ℝ) := by + rw [directedIntMulUpper] + split_ifs with hk + Β· push_cast + exact mul_le_mul_of_nonneg_left hhi (by exact_mod_cast hk) + Β· push_cast + exact mul_le_mul_of_nonpos_left hlo (by exact_mod_cast (le_of_not_ge hk)) + +/-- Rational lower bound on `log q` for every positive rational `q`. -/ +def directedLogLower (q : β„š) (N : β„•) : β„š := + let kPart := directedIntMulLower (rationalBinaryExponent q) + (directedLogUnitLower 2 N) (directedLogUnitUpper 2 N) + let y := rationalLogUnit q + kPart + if rationalBinaryResidual q < 1 then + -directedLogUnitUpper y N + else directedLogUnitLower y N + +/-- Rational upper bound on `log q` for every positive rational `q`. -/ +def directedLogUpper (q : β„š) (N : β„•) : β„š := + let kPart := directedIntMulUpper (rationalBinaryExponent q) + (directedLogUnitLower 2 N) (directedLogUnitUpper 2 N) + let y := rationalLogUnit q + kPart + if rationalBinaryResidual q < 1 then + -directedLogUnitLower y N + else directedLogUnitUpper y N + +theorem directedLogLower_le_log {q : β„š} (hq : 0 < q) (N : β„•) : + ((directedLogLower q N : β„š) : ℝ) ≀ Real.log (q : ℝ) := by + have htwoLo := directedLogUnitLower_le_log (y := (2 : β„š)) (by norm_num) N + have htwoHi := log_le_directedLogUnitUpper (y := (2 : β„š)) (by norm_num) N + have hk := directedIntMulLower_le + (k := rationalBinaryExponent q) htwoLo htwoHi + norm_num at hk + have hyBounds := rationalLogUnit_bounds hq + have hyLo := directedLogUnitLower_le_log hyBounds.1 N + have hyHi := log_le_directedLogUnitUpper hyBounds.1 N + rw [log_rational_eq_scale_add_residual hq, + log_residual_eq_signed_log_unit hq] + rw [directedLogLower] + split_ifs with hr + Β· push_cast + linarith + Β· push_cast + linarith + +theorem log_le_directedLogUpper {q : β„š} (hq : 0 < q) (N : β„•) : + Real.log (q : ℝ) ≀ ((directedLogUpper q N : β„š) : ℝ) := by + have htwoLo := directedLogUnitLower_le_log (y := (2 : β„š)) (by norm_num) N + have htwoHi := log_le_directedLogUnitUpper (y := (2 : β„š)) (by norm_num) N + have hk := le_directedIntMulUpper + (k := rationalBinaryExponent q) htwoLo htwoHi + norm_num at hk + have hyBounds := rationalLogUnit_bounds hq + have hyLo := directedLogUnitLower_le_log hyBounds.1 N + have hyHi := log_le_directedLogUnitUpper hyBounds.1 N + rw [log_rational_eq_scale_add_residual hq, + log_residual_eq_signed_log_unit hq] + rw [directedLogUpper] + split_ifs with hr + Β· push_cast + linarith + Β· push_cast + linarith + +theorem rationalLogSeriesError_nonneg {x : β„š} (hx0 : 0 ≀ x) (hx1 : x < 1) + (N : β„•) : 0 ≀ rationalLogSeriesError x N := by + rw [rationalLogSeriesError] + have hpow : x ^ 2 < 1 := pow_lt_oneβ‚€ hx0 hx1 (by norm_num) + have hden : 0 < 1 - x ^ 2 := by linarith + positivity + +theorem rationalLogSeriesError_le_geometric {x : β„š} + (hx0 : 0 ≀ x) (hx : x ≀ 1 / 3) (N : β„•) : + rationalLogSeriesError x N ≀ + 4 * (1 / 3 : β„š) ^ (2 * N + 1) := by + have hx1 : x < 1 := hx.trans_lt (by norm_num) + have hsq : x ^ 2 ≀ (1 / 3 : β„š) ^ 2 := + pow_le_pow_leftβ‚€ hx0 hx 2 + have hden : 0 < 1 - x ^ 2 := by nlinarith + have hcoef : 2 / (1 - x ^ 2) ≀ (4 : β„š) := by + rw [div_le_iffβ‚€ hden] + nlinarith + have hpow : x ^ (2 * N + 1) ≀ + (1 / 3 : β„š) ^ (2 * N + 1) := + pow_le_pow_leftβ‚€ hx0 hx _ + rw [rationalLogSeriesError] + calc + 2 * (x ^ (2 * N + 1) / (1 - x ^ 2)) = + x ^ (2 * N + 1) * (2 / (1 - x ^ 2)) := by ring + _ ≀ (1 / 3 : β„š) ^ (2 * N + 1) * (2 / (1 - x ^ 2)) := + mul_le_mul_of_nonneg_right hpow (div_nonneg (by norm_num) hden.le) + _ ≀ (1 / 3 : β„š) ^ (2 * N + 1) * 4 := + mul_le_mul_of_nonneg_left hcoef (by positivity) + _ = 4 * (1 / 3 : β„š) ^ (2 * N + 1) := by ring + +theorem four_mul_two_pow_le_three_pow (p : β„•) : + 4 * 2 ^ p ≀ 3 ^ (2 * p + 3) := by + induction p with + | zero => norm_num + | succ p ih => + calc + 4 * 2 ^ (p + 1) = 2 * (4 * 2 ^ p) := by ring + _ ≀ 2 * 3 ^ (2 * p + 3) := Nat.mul_le_mul_left 2 ih + _ ≀ 9 * 3 ^ (2 * p + 3) := by gcongr <;> norm_num + _ = 3 ^ (2 * (p + 1) + 3) := by + rw [show 2 * (p + 1) + 3 = (2 * p + 3) + 2 by omega, + pow_add] + ring + +theorem geometric_log_error_le_dyadic (p : β„•) : + 4 * (1 / 3 : β„š) ^ (2 * (p + 1) + 1) ≀ (1 / 2 : β„š) ^ p := by + have hnat := four_mul_two_pow_le_three_pow p + have hrat : (4 : β„š) * (2 : β„š) ^ p ≀ (3 : β„š) ^ (2 * p + 3) := by + exact_mod_cast hnat + rw [show 2 * (p + 1) + 1 = 2 * p + 3 by omega] + simp only [one_div, inv_pow] + rw [mul_inv_le_iffβ‚€ (by positivity : (0 : β„š) < 3 ^ (2 * p + 3))] + rw [mul_comm ((2 : β„š) ^ p)⁻¹] + rw [le_mul_inv_iffβ‚€ (by positivity : (0 : β„š) < 2 ^ p)] + simpa using hrat + +theorem directedLogUnit_width_le_dyadic {y : β„š} + (hy1 : 1 ≀ y) (hy2 : y ≀ 2) (p : β„•) : + directedLogUnitUpper y (p + 1) - directedLogUnitLower y (p + 1) ≀ + (1 / 2 : β„š) ^ p := by + rw [directedLogUnit_width] + exact (rationalLogSeriesError_le_geometric + (rationalLogUnitParameter_nonneg hy1) + (rationalLogUnitParameter_le_third hy1 hy2) (p + 1)).trans + (geometric_log_error_le_dyadic p) + +theorem directedIntMul_width (k : β„€) (lo hi : β„š) : + directedIntMulUpper k lo hi - directedIntMulLower k lo hi = + (k.natAbs : β„š) * (hi - lo) := by + cases k with + | ofNat n => simp [directedIntMulUpper, directedIntMulLower]; ring + | negSucc n => simp [directedIntMulUpper, directedIntMulLower]; ring + +theorem directedLog_width (q : β„š) (N : β„•) : + directedLogUpper q N - directedLogLower q N = + (rationalBinaryExponent q).natAbs * + (directedLogUnitUpper 2 N - directedLogUnitLower 2 N) + + (directedLogUnitUpper (rationalLogUnit q) N - + directedLogUnitLower (rationalLogUnit q) N) := by + rw [directedLogUpper, directedLogLower] + split_ifs <;> + rw [← directedIntMul_width] <;> + ring + +theorem nat_succ_mul_dyadic_succ_le_one (m : β„•) : + (m + 1 : β„š) * (1 / 2 : β„š) ^ (m + 1) ≀ 1 := by + have hn : m + 1 ≀ 2 ^ (m + 1) := (m + 1).lt_two_pow_self.le + have hq : (m + 1 : β„š) ≀ (2 : β„š) ^ (m + 1) := by exact_mod_cast hn + simp only [one_div, inv_pow] + rw [mul_inv_le_iffβ‚€ (by positivity : (0 : β„š) < 2 ^ (m + 1))] + simpa using hq + +theorem nat_succ_mul_shifted_dyadic_le (p m : β„•) : + (m + 1 : β„š) * (1 / 2 : β„š) ^ (p + m + 1) ≀ + (1 / 2 : β„š) ^ p := by + rw [show p + m + 1 = p + (m + 1) by omega, pow_add] + have h := nat_succ_mul_dyadic_succ_le_one m + calc + (m + 1 : β„š) * ((1 / 2 : β„š) ^ p * (1 / 2 : β„š) ^ (m + 1)) = + (1 / 2 : β„š) ^ p * + ((m + 1 : β„š) * (1 / 2 : β„š) ^ (m + 1)) := by ring + _ ≀ (1 / 2 : β„š) ^ p * 1 := + mul_le_mul_of_nonneg_left h (by positivity) + _ = (1 / 2 : β„š) ^ p := mul_one _ + +/-- A precision schedule compensating for the signed dyadic exponent. Its +number of series terms is linear in the requested precision and in the binary +length displacement of the input rational. -/ +def directedLogTerms (q : β„š) (p : β„•) : β„• := + p + (rationalBinaryExponent q).natAbs + 2 + +/-- The signed range-reduction exponent is at most twice the canonical input +length. This makes the series schedule polynomial in ordinary binary input +length rather than in the numerical magnitude of `q`. -/ +theorem rationalBinaryExponent_natAbs_le_two_bitLength + {q : β„š} (hq : 0 < q) : + (rationalBinaryExponent q).natAbs ≀ 2 * encodedBitLength β„š q := by + have hnum := numerator_natAbs_log_lt_rationalBitLength q + (positive_rational_num_natAbs_ne_zero hq) + have hden := denominator_log_lt_rationalBitLength q + have habs := Int.natAbs_sub_le + (Nat.log 2 q.num.natAbs : β„€) (Nat.log 2 q.den : β„€) + simp only [Int.natAbs_natCast] at habs + rw [rationalBinaryExponent] + omega + +theorem directedLogTerms_le_input_precision + {q : β„š} (hq : 0 < q) (p : β„•) : + directedLogTerms q p ≀ p + 2 * encodedBitLength β„š q + 2 := by + have h := rationalBinaryExponent_natAbs_le_two_bitLength hq + rw [directedLogTerms] + omega + +theorem directedLog_width_le_dyadic {q : β„š} (hq : 0 < q) (p : β„•) : + directedLogUpper q (directedLogTerms q p) - + directedLogLower q (directedLogTerms q p) ≀ + (1 / 2 : β„š) ^ p := by + let m := (rationalBinaryExponent q).natAbs + let precision := p + m + 1 + have hterms : directedLogTerms q p = precision + 1 := by + simp [directedLogTerms, precision, m] + have htwo := directedLogUnit_width_le_dyadic + (y := (2 : β„š)) (by norm_num) (by norm_num) precision + have hy := rationalLogUnit_bounds hq + have hunit := directedLogUnit_width_le_dyadic + hy.1 hy.2.le precision + rw [directedLog_width, hterms] + change (m : β„š) * + (directedLogUnitUpper 2 (precision + 1) - + directedLogUnitLower 2 (precision + 1)) + + (directedLogUnitUpper (rationalLogUnit q) (precision + 1) - + directedLogUnitLower (rationalLogUnit q) (precision + 1)) ≀ _ + calc + (m : β„š) * + (directedLogUnitUpper 2 (precision + 1) - + directedLogUnitLower 2 (precision + 1)) + + (directedLogUnitUpper (rationalLogUnit q) (precision + 1) - + directedLogUnitLower (rationalLogUnit q) (precision + 1)) ≀ + (m : β„š) * (1 / 2 : β„š) ^ precision + + (1 / 2 : β„š) ^ precision := by + gcongr + _ = (m + 1 : β„š) * (1 / 2 : β„š) ^ precision := by ring + _ ≀ (1 / 2 : β„š) ^ p := by + simpa only [precision] using nat_succ_mul_shifted_dyadic_le p m + +/-- The natural-number ceiling of a nonnegative rational. Unlike the raw +numerator, its numerical value depends on the magnitude of the rational and +not on the size of a possibly huge denominator. -/ +def rationalCeilNat (t : β„š) : β„• := Int.toNat ⌈tβŒ‰ + +theorem le_rationalCeilNat {t : β„š} (ht : 0 ≀ t) : + t ≀ rationalCeilNat t := by + have hceil : t ≀ ((⌈tβŒ‰ : β„€) : β„š) := Int.le_ceil t + have hnonneg : (0 : β„€) ≀ ⌈tβŒ‰ := Int.ceil_nonneg ht + rw [← Int.toNat_of_nonneg hnonneg] at hceil + exact hceil + +/-- Number of Bernoulli factors used for a one-sided exponential sandwich. +For nonnegative `t`, this is strictly larger than `2t`. The former version +used `t.num.natAbs`, which is exponential in the bit length for a bounded +rational with a large denominator; the ceiling is the correct magnitude +parameter. -/ +def rationalExpSandwichSteps (t : β„š) : β„• := 2 * rationalCeilNat t + 1 + +/-- A fully rational substitute for evaluating a negative exponential. -/ +def rationalExpSandwichFactor (t : β„š) : β„š := + let M := rationalExpSandwichSteps t + (1 - t / M) ^ M + +theorem nonnegative_rational_le_num_natAbs {t : β„š} (ht : 0 ≀ t) : + t ≀ (t.num.natAbs : β„š) := by + have hnum : 0 ≀ t.num := Rat.num_nonneg.mpr ht + have hnumabs : (t.num.natAbs : β„€) = t.num := Int.natAbs_of_nonneg hnum + have hden : (1 : β„š) ≀ t.den := by exact_mod_cast t.den_pos + calc + t = (t.num : β„š) / (t.den : β„š) := (Rat.num_div_den t).symm + _ = (t.num.natAbs : β„š) / (t.den : β„š) := by + congr 1 + change (t.num : β„š) = ((t.num.natAbs : β„€) : β„š) + rw [hnumabs] + _ ≀ (t.num.natAbs : β„š) := div_le_self (by positivity) hden + +theorem two_mul_lt_rationalExpSandwichSteps {t : β„š} (ht : 0 ≀ t) : + 2 * t < rationalExpSandwichSteps t := by + have hle := le_rationalCeilNat ht + rw [rationalExpSandwichSteps] + push_cast + linarith + +theorem rationalExpSandwich_argument_bounds {t : β„š} (ht : 0 ≀ t) : + 0 ≀ t / rationalExpSandwichSteps t ∧ + t / rationalExpSandwichSteps t < 1 / 2 := by + have hM : (0 : β„š) < rationalExpSandwichSteps t := by + have hMN : 0 < rationalExpSandwichSteps t := by + simp [rationalExpSandwichSteps] + exact_mod_cast hMN + constructor + Β· exact div_nonneg ht hM.le + Β· rw [div_lt_iffβ‚€ hM] + have := two_mul_lt_rationalExpSandwichSteps ht + linarith + +theorem log_one_sub_between_neg_two_mul_and_neg {x : ℝ} + (hx0 : 0 ≀ x) (hxhalf : x < 1 / 2) : + -2 * x ≀ Real.log (1 - x) ∧ Real.log (1 - x) ≀ -x := by + have hbase : 0 < 1 - x := by linarith + have hupper := Real.log_le_sub_one_of_pos hbase + have hlower0 := Real.one_sub_inv_le_log_of_pos hbase + have hratio : x / (1 - x) ≀ 2 * x := by + rw [div_le_iffβ‚€ hbase] + nlinarith + have hid : 1 - (1 - x)⁻¹ = -x / (1 - x) := by + field_simp [hbase.ne'] + ring + rw [hid] at hlower0 + have hneg : -x / (1 - x) = -(x / (1 - x)) := by ring + rw [hneg] at hlower0 + constructor <;> linarith + +/-- The rational Bernoulli factor lies between the two exponential losses +needed in the final certificate. Thus the implementation does not need a +separate transcendental exponential evaluator at this step. -/ +theorem rationalExpSandwichFactor_bounds {t : β„š} (ht : 0 ≀ t) : + Real.exp (-2 * (t : ℝ)) ≀ (rationalExpSandwichFactor t : ℝ) ∧ + (rationalExpSandwichFactor t : ℝ) ≀ Real.exp (-(t : ℝ)) := by + let M := rationalExpSandwichSteps t + let x : β„š := t / M + have hxQ := rationalExpSandwich_argument_bounds ht + have hx0Q : 0 ≀ x := by simpa [x, M] using hxQ.1 + have hxhalfQ : x < 1 / 2 := by simpa [x, M] using hxQ.2 + have hx0 : 0 ≀ (x : ℝ) := by exact_mod_cast hx0Q + have hxhalf' : (x : ℝ) < (((1 / 2 : β„š) : ℝ)) := by + exact_mod_cast hxhalfQ + have hxhalf : (x : ℝ) < 1 / 2 := by norm_num at hxhalf' ⊒; exact hxhalf' + have hbase : 0 < (1 : ℝ) - x := by linarith + have hlog := log_one_sub_between_neg_two_mul_and_neg hx0 hxhalf + have hMposQ : (0 : β„š) < M := by + have hMN : 0 < M := by simp [M, rationalExpSandwichSteps] + exact_mod_cast hMN + have hMpos : (0 : ℝ) < M := by exact_mod_cast hMposQ + have hMxQ : (M : β„š) * x = t := by + dsimp only [x] + field_simp [hMposQ.ne'] + have hMx : (M : ℝ) * (x : ℝ) = (t : ℝ) := by exact_mod_cast hMxQ + have hlogPow : Real.log (((1 : ℝ) - x) ^ M) = + (M : ℝ) * Real.log ((1 : ℝ) - x) := Real.log_pow _ _ + have hfactorPos : 0 < ((1 : ℝ) - x) ^ M := pow_pos hbase M + have hlowerLog : -2 * (t : ℝ) ≀ Real.log (((1 : ℝ) - x) ^ M) := by + rw [hlogPow] + have := mul_le_mul_of_nonneg_left hlog.1 hMpos.le + nlinarith + have hupperLog : Real.log (((1 : ℝ) - x) ^ M) ≀ -(t : ℝ) := by + rw [hlogPow] + have := mul_le_mul_of_nonneg_left hlog.2 hMpos.le + nlinarith + have hfactorCast : (rationalExpSandwichFactor t : ℝ) = + ((1 : ℝ) - x) ^ M := by + simp [rationalExpSandwichFactor, x, M] + rw [hfactorCast] + constructor + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hlowerLog + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hupperLog + +/-- A magnitude-sensitive step count for a relative logarithmic loss +`loss`. Its numerical size is `O(t + t^2/loss)` and is independent of the +denominator used to represent `t`. -/ +def rationalExpApproxSteps (t loss : β„š) : β„• := + 2 * rationalCeilNat (t + t ^ 2 / loss) + 1 + +/-- Directed rational lower approximation to `exp (-t)`. -/ +def rationalNegativeExpLower (t loss : β„š) : β„š := + let M := rationalExpApproxSteps t loss + (1 - t / M) ^ M + +theorem rationalExpApproxSteps_gt_two_mul + {t loss : β„š} (ht : 0 ≀ t) (hloss : 0 < loss) : + 2 * t < rationalExpApproxSteps t loss := by + have hu0 : 0 ≀ t + t ^ 2 / loss := by positivity + have hceil := le_rationalCeilNat hu0 + have htceil : t ≀ rationalCeilNat (t + t ^ 2 / loss) := by + have htu : t ≀ t + t ^ 2 / loss := + le_add_of_nonneg_right (div_nonneg (sq_nonneg t) hloss.le) + exact htu.trans hceil + rw [rationalExpApproxSteps] + push_cast + linarith + +theorem rationalExpApproxSteps_controls_error + {t loss : β„š} (ht : 0 ≀ t) (hloss : 0 < loss) : + 2 * t ^ 2 / rationalExpApproxSteps t loss ≀ loss := by + let u : β„š := t + t ^ 2 / loss + let M : β„š := rationalExpApproxSteps t loss + have hu0 : 0 ≀ u := by dsimp only [u]; positivity + have hceil := le_rationalCeilNat hu0 + have hMpos : 0 < M := by + dsimp only [M, rationalExpApproxSteps] + positivity + have hcontrol : 2 * (t ^ 2 / loss) ≀ M := by + have hsquare : t ^ 2 / loss ≀ u := by + dsimp only [u] + linarith + have htwo : 2 * u ≀ M := by + dsimp only [M, rationalExpApproxSteps] + push_cast + linarith + linarith + rw [div_le_iffβ‚€ hMpos] + have := mul_le_mul_of_nonneg_right hcontrol hloss.le + field_simp [hloss.ne'] at this ⊒ + nlinarith + +theorem log_one_sub_between_neg_add_two_sq_and_neg {x : ℝ} + (hx0 : 0 ≀ x) (hxhalf : x < 1 / 2) : + -x - 2 * x ^ 2 ≀ Real.log (1 - x) ∧ + Real.log (1 - x) ≀ -x := by + have hbase : 0 < 1 - x := by linarith + have hupper := Real.log_le_sub_one_of_pos hbase + have hlower0 := Real.one_sub_inv_le_log_of_pos hbase + have hratio : x / (1 - x) ≀ x + 2 * x ^ 2 := by + rw [div_le_iffβ‚€ hbase] + nlinarith + have hid : 1 - (1 - x)⁻¹ = -x / (1 - x) := by + field_simp [hbase.ne'] + ring + rw [hid] at hlower0 + have hneg0 := neg_le_neg hratio + have hneg : -x - 2 * x ^ 2 ≀ -x / (1 - x) := by + calc + -x - 2 * x ^ 2 = -(x + 2 * x ^ 2) := by ring + _ ≀ -(x / (1 - x)) := hneg0 + _ = -x / (1 - x) := by ring + exact ⟨hneg.trans hlower0, by linarith⟩ + +/-- The accurate negative-exponential routine has prescribed multiplicative +logarithmic loss. -/ +theorem rationalNegativeExpLower_bounds + {t loss : β„š} (ht : 0 ≀ t) (hloss : 0 < loss) : + Real.exp (-(t : ℝ) - (loss : ℝ)) ≀ + (rationalNegativeExpLower t loss : ℝ) ∧ + (rationalNegativeExpLower t loss : ℝ) ≀ + Real.exp (-(t : ℝ)) := by + let M := rationalExpApproxSteps t loss + let x : β„š := t / M + have hMposQ : (0 : β„š) < M := by + dsimp only [M, rationalExpApproxSteps] + positivity + have htwo := rationalExpApproxSteps_gt_two_mul ht hloss + have hx0Q : 0 ≀ x := div_nonneg ht hMposQ.le + have hxhalfQ : x < 1 / 2 := by + dsimp only [x] + rw [div_lt_iffβ‚€ hMposQ] + linarith + have hx0 : 0 ≀ (x : ℝ) := by exact_mod_cast hx0Q + have hxhalf' : (x : ℝ) < (((1 / 2 : β„š)) : ℝ) := by + exact_mod_cast hxhalfQ + have hxhalf : (x : ℝ) < 1 / 2 := by + norm_num at hxhalf' ⊒ + exact hxhalf' + have hbase : 0 < (1 : ℝ) - x := by linarith + have hlog := log_one_sub_between_neg_add_two_sq_and_neg hx0 hxhalf + have hMpos : (0 : ℝ) < M := by exact_mod_cast hMposQ + have hMxQ : (M : β„š) * x = t := by + dsimp only [x] + field_simp [hMposQ.ne'] + have hMx : (M : ℝ) * (x : ℝ) = (t : ℝ) := by + exact_mod_cast hMxQ + have herrQ := rationalExpApproxSteps_controls_error ht hloss + have herr : 2 * (t : ℝ) ^ 2 / (M : ℝ) ≀ (loss : ℝ) := by + exact_mod_cast herrQ + have hMxx : (M : ℝ) * (2 * (x : ℝ) ^ 2) = + 2 * (t : ℝ) ^ 2 / (M : ℝ) := by + have hMne : (M : ℝ) β‰  0 := hMpos.ne' + rw [show (x : ℝ) = (t : ℝ) / (M : ℝ) by + exact_mod_cast (rfl : x = t / M)] + field_simp [hMne] + have hlogPow : Real.log (((1 : ℝ) - x) ^ M) = + (M : ℝ) * Real.log ((1 : ℝ) - x) := Real.log_pow _ _ + have hfactorPos : 0 < ((1 : ℝ) - x) ^ M := pow_pos hbase M + have hlowerLog : -(t : ℝ) - (loss : ℝ) ≀ + Real.log (((1 : ℝ) - x) ^ M) := by + rw [hlogPow] + have hscaled := mul_le_mul_of_nonneg_left hlog.1 hMpos.le + nlinarith [hMx, hMxx, herr] + have hupperLog : Real.log (((1 : ℝ) - x) ^ M) ≀ -(t : ℝ) := by + rw [hlogPow] + have hscaled := mul_le_mul_of_nonneg_left hlog.2 hMpos.le + nlinarith + have hfactorCast : (rationalNegativeExpLower t loss : ℝ) = + ((1 : ℝ) - x) ^ M := by + simp [rationalNegativeExpLower, x, M] + rw [hfactorCast] + constructor + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hlowerLog + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hupperLog + +/-- Directed rational lower approximation to `exp t` for `t β‰₯ 0`. -/ +def rationalPositiveExpLower (t loss : β„š) : β„š := + let M := rationalExpApproxSteps t loss + (1 + t / M) ^ M + +theorem log_one_add_between_sub_sq_and_self {x : ℝ} (hx : 0 ≀ x) : + x - x ^ 2 ≀ Real.log (1 + x) ∧ Real.log (1 + x) ≀ x := by + have hbase : 0 < 1 + x := by linarith + have hlower0 := Real.one_sub_inv_le_log_of_pos hbase + have hupper0 := Real.log_le_sub_one_of_pos hbase + have hid : 1 - (1 + x)⁻¹ = x / (1 + x) := by + field_simp [hbase.ne'] + ring + rw [hid] at hlower0 + have hpoly : x - x ^ 2 ≀ x / (1 + x) := by + rw [le_div_iffβ‚€ hbase] + nlinarith [sq_nonneg x] + exact ⟨hpoly.trans hlower0, by linarith⟩ + +theorem rationalPositiveExpLower_bounds + {t loss : β„š} (ht : 0 ≀ t) (hloss : 0 < loss) : + Real.exp ((t : ℝ) - (loss : ℝ)) ≀ + (rationalPositiveExpLower t loss : ℝ) ∧ + (rationalPositiveExpLower t loss : ℝ) ≀ Real.exp (t : ℝ) := by + let M := rationalExpApproxSteps t loss + let x : β„š := t / M + have hMposQ : (0 : β„š) < M := by + dsimp only [M, rationalExpApproxSteps] + positivity + have hx0Q : 0 ≀ x := div_nonneg ht hMposQ.le + have hx0 : 0 ≀ (x : ℝ) := by exact_mod_cast hx0Q + have hbase : 0 < (1 : ℝ) + x := by positivity + have hlog := log_one_add_between_sub_sq_and_self hx0 + have hMpos : (0 : ℝ) < M := by exact_mod_cast hMposQ + have hMxQ : (M : β„š) * x = t := by + dsimp only [x] + field_simp [hMposQ.ne'] + have hMx : (M : ℝ) * (x : ℝ) = (t : ℝ) := by exact_mod_cast hMxQ + have herrQ := rationalExpApproxSteps_controls_error ht hloss + have herr : (t : ℝ) ^ 2 / (M : ℝ) ≀ (loss : ℝ) := by + have hcast : 2 * (t : ℝ) ^ 2 / (M : ℝ) ≀ (loss : ℝ) := by + exact_mod_cast herrQ + have hnonneg : 0 ≀ (t : ℝ) ^ 2 / (M : ℝ) := by positivity + have hid : 2 * (t : ℝ) ^ 2 / (M : ℝ) = + 2 * ((t : ℝ) ^ 2 / (M : ℝ)) := by ring + rw [hid] at hcast + linarith + have hMxx : (M : ℝ) * (x : ℝ) ^ 2 = + (t : ℝ) ^ 2 / (M : ℝ) := by + have hMne : (M : ℝ) β‰  0 := hMpos.ne' + rw [show (x : ℝ) = (t : ℝ) / (M : ℝ) by + exact_mod_cast (rfl : x = t / M)] + field_simp [hMne] + have hlogPow : Real.log (((1 : ℝ) + x) ^ M) = + (M : ℝ) * Real.log ((1 : ℝ) + x) := Real.log_pow _ _ + have hfactorPos : 0 < ((1 : ℝ) + x) ^ M := pow_pos hbase M + have hlowerLog : (t : ℝ) - (loss : ℝ) ≀ + Real.log (((1 : ℝ) + x) ^ M) := by + rw [hlogPow] + have hscaled := mul_le_mul_of_nonneg_left hlog.1 hMpos.le + nlinarith [hMx, hMxx, herr] + have hupperLog : Real.log (((1 : ℝ) + x) ^ M) ≀ (t : ℝ) := by + rw [hlogPow] + have hscaled := mul_le_mul_of_nonneg_left hlog.2 hMpos.le + nlinarith + have hfactorCast : (rationalPositiveExpLower t loss : ℝ) = + ((1 : ℝ) + x) ^ M := by + simp [rationalPositiveExpLower, x, M] + rw [hfactorCast] + constructor + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hlowerLog + Β· rw [← Real.exp_log hfactorPos] + exact Real.exp_le_exp.mpr hupperLog + +/-- Directed rational lower exponential at an arbitrary rational argument. -/ +def rationalExpLower (s loss : β„š) : β„š := + if 0 ≀ s then rationalPositiveExpLower s loss + else rationalNegativeExpLower (-s) loss + +theorem rationalExpLower_bounds {s loss : β„š} (hloss : 0 < loss) : + Real.exp ((s : ℝ) - (loss : ℝ)) ≀ + (rationalExpLower s loss : ℝ) ∧ + (rationalExpLower s loss : ℝ) ≀ Real.exp (s : ℝ) := by + rw [rationalExpLower] + split_ifs with hs + Β· exact rationalPositiveExpLower_bounds hs hloss + Β· have hneg : 0 ≀ -s := neg_nonneg.mpr (le_of_not_ge hs) + have h := rationalNegativeExpLower_bounds hneg hloss + norm_num only [Rat.cast_neg] at h ⊒ + convert h using 1 <;> ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DirectedOptimizerOracle.lean b/LeanPool/BeyondBethe/BeyondBethe/DirectedOptimizerOracle.lean new file mode 100644 index 0000000000..fda642f6dc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DirectedOptimizerOracle.lean @@ -0,0 +1,315 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DirectedPairCost +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.NumericalAffine +public import Mathlib.Tactic + +/-! # Directed Optimizer Oracle -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Directed rational values for the convex-optimization oracle + +The weak optimization algorithm uses the convex function obtained by +negating the regularized Bethe objective. This file gives rational lower and +upper endpoints for both a coordinate value and a coordinate of its gradient. +Every endpoint is executable and every error bound is stated in terms of the +prescribed dyadic precision. +-/ + +/-- Lower endpoint for one coordinate of the gradient of the negative +regularized Bethe objective. -/ +def directedNegativeGradientLower + (Ο„ a x : β„š) (p : β„•) : β„š := + -scheduledLogUpper a p + + (1 + Ο„) * scheduledLogLower x p + + scheduledLogLower (1 - x) p + (2 + Ο„) + +/-- Upper endpoint for one coordinate of the gradient of the negative +regularized Bethe objective. -/ +def directedNegativeGradientUpper + (Ο„ a x : β„š) (p : β„•) : β„š := + -scheduledLogLower a p + + (1 + Ο„) * scheduledLogUpper x p + + scheduledLogUpper (1 - x) p + (2 + Ο„) + +/-- The exact real coordinate of the negative gradient. -/ +noncomputable def negativeRegularizedBetheGradientCoordinate + (Ο„ a x : ℝ) : ℝ := + -Real.log a + (1 + Ο„) * Real.log x + + Real.log (1 - x) + (2 + Ο„) + +theorem negativeRegularizedBetheGradientCoordinate_eq_neg + {Ο„ a x : ℝ} : + negativeRegularizedBetheGradientCoordinate Ο„ a x = + -(Real.log a - (1 + Ο„) * Real.log x - + Real.log (1 - x) - (2 + Ο„)) := by + simp [negativeRegularizedBetheGradientCoordinate] + ring + +/-- A directed interval for the negative gradient has width at most four +dyadic units when `0 ≀ Ο„ ≀ 1`. -/ +theorem directedNegativeGradient_bounds + {Ο„ a x : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (ha : 0 < a) (hx0 : 0 < x) (hx1 : x < 1) (p : β„•) : + (directedNegativeGradientLower Ο„ a x p : ℝ) ≀ + negativeRegularizedBetheGradientCoordinate + (Ο„ : ℝ) (a : ℝ) (x : ℝ) ∧ + negativeRegularizedBetheGradientCoordinate + (Ο„ : ℝ) (a : ℝ) (x : ℝ) ≀ + (directedNegativeGradientUpper Ο„ a x p : ℝ) ∧ + (directedNegativeGradientUpper Ο„ a x p : ℝ) - + (directedNegativeGradientLower Ο„ a x p : ℝ) ≀ + 4 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + have hcx : 0 < 1 - x := sub_pos.mpr hx1 + have hAlo := scheduledLogLower_le_log ha p + have hAup := log_le_scheduledLogUpper ha p + have hXlo := scheduledLogLower_le_log hx0 p + have hXup := log_le_scheduledLogUpper hx0 p + have hClo := scheduledLogLower_le_log hcx p + have hCup := log_le_scheduledLogUpper hcx p + norm_num only [Rat.cast_sub, Rat.cast_one] at hClo hCup + have hAgapQ := scheduledLog_width_le ha p + have hXgapQ := scheduledLog_width_le hx0 p + have hCgapQ := scheduledLog_width_le hcx p + have hAgap : + (scheduledLogUpper a p : ℝ) - (scheduledLogLower a p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hAgapQ + have hXgap : + (scheduledLogUpper x p : ℝ) - (scheduledLogLower x p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hXgapQ + have hCgap : + (scheduledLogUpper (1 - x) p : ℝ) - + (scheduledLogLower (1 - x) p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hCgapQ + have hcoef0 : 0 ≀ (1 + Ο„ : ℝ) := by exact_mod_cast (by linarith : (0 : β„š) ≀ 1 + Ο„) + have hcoef2 : (1 + Ο„ : ℝ) ≀ 2 := by exact_mod_cast (by linarith : 1 + Ο„ ≀ (2 : β„š)) + have hscaledLower := mul_le_mul_of_nonneg_left hXlo hcoef0 + have hscaledUpper := mul_le_mul_of_nonneg_left hXup hcoef0 + have hdyadic : 0 ≀ ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) := by positivity + have hscaledGap : + (1 + (Ο„ : ℝ)) * + ((scheduledLogUpper x p : ℝ) - + (scheduledLogLower x p : ℝ)) ≀ + 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + calc + (1 + (Ο„ : ℝ)) * + ((scheduledLogUpper x p : ℝ) - + (scheduledLogLower x p : ℝ)) ≀ + (1 + (Ο„ : ℝ)) * + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := + mul_le_mul_of_nonneg_left hXgap hcoef0 + _ ≀ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := + mul_le_mul_of_nonneg_right hcoef2 hdyadic + constructor + Β· rw [directedNegativeGradientLower, + negativeRegularizedBetheGradientCoordinate] + push_cast + linarith + constructor + Β· rw [directedNegativeGradientUpper, + negativeRegularizedBetheGradientCoordinate] + push_cast + linarith + Β· rw [directedNegativeGradientUpper, directedNegativeGradientLower] + push_cast + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at hAgap hCgap hscaledGap hdyadic ⊒ + linarith + +/-- Lower endpoint for the negative of one regularized Bethe coordinate. -/ +def directedNegativeObjectiveCoordinateLower + (Ο„ a x : β„š) (p : β„•) : β„š := + -x * scheduledLogUpper a p + + (1 + Ο„) * x * scheduledLogLower x p - + (1 - x) * scheduledLogUpper (1 - x) p + +/-- Upper endpoint for the negative of one regularized Bethe coordinate. -/ +def directedNegativeObjectiveCoordinateUpper + (Ο„ a x : β„š) (p : β„•) : β„š := + -x * scheduledLogLower a p + + (1 + Ο„) * x * scheduledLogUpper x p - + (1 - x) * scheduledLogLower (1 - x) p + +/-- Exact negative coordinate value, written in logarithmic form on the +interior of the unit interval. -/ +noncomputable def negativeRegularizedBetheCoordinate + (Ο„ a x : ℝ) : ℝ := + -x * Real.log a + (1 + Ο„) * x * Real.log x - + (1 - x) * Real.log (1 - x) + +theorem negativeRegularizedBetheCoordinate_eq_neg + {Ο„ a x : ℝ} : + negativeRegularizedBetheCoordinate Ο„ a x = + -regularizedBetheCoordinate Ο„ a x := by + rw [negativeRegularizedBetheCoordinate, regularizedBetheCoordinate, + Real.negMulLog_def] + ring + +/-- A directed interval for a negative objective coordinate has width at most +three dyadic units. -/ +theorem directedNegativeObjectiveCoordinate_bounds + {Ο„ a x : β„š} (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (ha : 0 < a) (hx0 : 0 < x) (hx1 : x < 1) (p : β„•) : + (directedNegativeObjectiveCoordinateLower Ο„ a x p : ℝ) ≀ + negativeRegularizedBetheCoordinate (Ο„ : ℝ) (a : ℝ) (x : ℝ) ∧ + negativeRegularizedBetheCoordinate (Ο„ : ℝ) (a : ℝ) (x : ℝ) ≀ + (directedNegativeObjectiveCoordinateUpper Ο„ a x p : ℝ) ∧ + (directedNegativeObjectiveCoordinateUpper Ο„ a x p : ℝ) - + (directedNegativeObjectiveCoordinateLower Ο„ a x p : ℝ) ≀ + 3 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + have hcx : 0 < 1 - x := sub_pos.mpr hx1 + have hAlo := scheduledLogLower_le_log ha p + have hAup := log_le_scheduledLogUpper ha p + have hXlo := scheduledLogLower_le_log hx0 p + have hXup := log_le_scheduledLogUpper hx0 p + have hClo := scheduledLogLower_le_log hcx p + have hCup := log_le_scheduledLogUpper hcx p + norm_num only [Rat.cast_sub, Rat.cast_one] at hClo hCup + have hAgapQ := scheduledLog_width_le ha p + have hXgapQ := scheduledLog_width_le hx0 p + have hCgapQ := scheduledLog_width_le hcx p + have hAgap : + (scheduledLogUpper a p : ℝ) - (scheduledLogLower a p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hAgapQ + have hXgap : + (scheduledLogUpper x p : ℝ) - (scheduledLogLower x p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hXgapQ + have hCgap : + (scheduledLogUpper (1 - x) p : ℝ) - + (scheduledLogLower (1 - x) p : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by exact_mod_cast hCgapQ + have hx0r : 0 ≀ (x : ℝ) := by exact_mod_cast hx0.le + have hx1r : (x : ℝ) ≀ 1 := by exact_mod_cast hx1.le + have hcx0r : 0 ≀ (1 - x : ℝ) := by exact_mod_cast (sub_nonneg.mpr hx1.le) + have hcoef0 : 0 ≀ (1 + Ο„ : ℝ) := by exact_mod_cast (by linarith : (0 : β„š) ≀ 1 + Ο„) + have hcoef2 : (1 + Ο„ : ℝ) ≀ 2 := by exact_mod_cast (by linarith : 1 + Ο„ ≀ (2 : β„š)) + have hmiddle0 : 0 ≀ (1 + (Ο„ : ℝ)) * (x : ℝ) := mul_nonneg hcoef0 hx0r + have hmiddle2 : (1 + (Ο„ : ℝ)) * (x : ℝ) ≀ 2 := by nlinarith + have hdyadic : 0 ≀ ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) := by positivity + have hAweighted := mul_le_mul_of_nonneg_left hAgap hx0r + have hXweighted := mul_le_mul_of_nonneg_left hXgap hmiddle0 + have hCweighted := mul_le_mul_of_nonneg_left hCgap hcx0r + have hAweightBound : + (x : ℝ) * (((1 / 2 : β„š) ^ p : β„š) : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := + mul_le_of_le_one_left hdyadic hx1r + have hXweightBound : + ((1 + (Ο„ : ℝ)) * (x : ℝ)) * + (((1 / 2 : β„š) ^ p : β„š) : ℝ) ≀ + 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := + mul_le_mul_of_nonneg_right hmiddle2 hdyadic + have hCweightBound : + (1 - (x : ℝ)) * (((1 / 2 : β„š) ^ p : β„š) : ℝ) ≀ + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := + mul_le_of_le_one_left hdyadic (by linarith) + have hscaledXlo := mul_le_mul_of_nonneg_left hXlo hmiddle0 + have hscaledXup := mul_le_mul_of_nonneg_left hXup hmiddle0 + have hscaledAlo := mul_le_mul_of_nonneg_left hAlo hx0r + have hscaledAup := mul_le_mul_of_nonneg_left hAup hx0r + have hscaledClo := mul_le_mul_of_nonneg_left hClo hcx0r + have hscaledCup := mul_le_mul_of_nonneg_left hCup hcx0r + constructor + Β· rw [directedNegativeObjectiveCoordinateLower, + negativeRegularizedBetheCoordinate] + push_cast + linarith + constructor + Β· rw [directedNegativeObjectiveCoordinateUpper, + negativeRegularizedBetheCoordinate] + push_cast + linarith + Β· rw [directedNegativeObjectiveCoordinateUpper, + directedNegativeObjectiveCoordinateLower] + push_cast + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at hAweighted hXweighted hCweighted + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at hAweightBound hXweightBound hCweightBound hdyadic ⊒ + nlinarith + +/-- Rational lower endpoint for the complete negative objective. -/ +def directedNegativeObjectiveLower {n : β„•} + (Ο„ : β„š) (A X : Matrix (Fin n) (Fin n) β„š) (p : β„•) : β„š := + βˆ‘ i, βˆ‘ j, directedNegativeObjectiveCoordinateLower Ο„ (A i j) (X i j) p + +/-- Rational upper endpoint for the complete negative objective. -/ +def directedNegativeObjectiveUpper {n : β„•} + (Ο„ : β„š) (A X : Matrix (Fin n) (Fin n) β„š) (p : β„•) : β„š := + βˆ‘ i, βˆ‘ j, directedNegativeObjectiveCoordinateUpper Ο„ (A i j) (X i j) p + +/-- Summing the coordinate intervals yields an `3 nΒ² 2⁻ᡖ` interval for the +complete negative objective. -/ +theorem directedNegativeObjective_bounds + {n : β„•} {Ο„ : β„š} {A X : Matrix (Fin n) (Fin n) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hA : βˆ€ i j, 0 < A i j) + (hX0 : βˆ€ i j, 0 < X i j) (hX1 : βˆ€ i j, X i j < 1) (p : β„•) : + (directedNegativeObjectiveLower Ο„ A X p : ℝ) ≀ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (fun i j ↦ (X i j : ℝ)) ∧ + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (fun i j ↦ (X i j : ℝ)) ≀ + (directedNegativeObjectiveUpper Ο„ A X p : ℝ) ∧ + (directedNegativeObjectiveUpper Ο„ A X p : ℝ) - + (directedNegativeObjectiveLower Ο„ A X p : ℝ) ≀ + 3 * (n : ℝ) ^ 2 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + have hcoord := fun i j ↦ directedNegativeObjectiveCoordinate_bounds + hΟ„0 hΟ„1 (hA i j) (hX0 i j) (hX1 i j) p + rw [regularizedBetheObjective_eq_sum_coordinates (Ο„ : ℝ) + (fun i j => (A i j : ℝ)) (fun i j => (X i j : ℝ))] + have hexact : + -(βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate (Ο„ : ℝ) + (A i j : ℝ) (X i j : ℝ)) = + βˆ‘ i, βˆ‘ j, negativeRegularizedBetheCoordinate + (Ο„ : ℝ) (A i j : ℝ) (X i j : ℝ) := by + rw [← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro j _ + exact negativeRegularizedBetheCoordinate_eq_neg.symm + rw [hexact] + constructor + Β· rw [directedNegativeObjectiveLower] + push_cast + exact Finset.sum_le_sum fun i _ ↦ + Finset.sum_le_sum fun j _ ↦ (hcoord i j).1 + constructor + Β· rw [directedNegativeObjectiveUpper] + push_cast + exact Finset.sum_le_sum fun i _ ↦ + Finset.sum_le_sum fun j _ ↦ (hcoord i j).2.1 + Β· rw [directedNegativeObjectiveUpper, directedNegativeObjectiveLower] + push_cast + rw [← Finset.sum_sub_distrib] + calc + βˆ‘ i, ((βˆ‘ j, (directedNegativeObjectiveCoordinateUpper Ο„ + (A i j) (X i j) p : ℝ)) - + βˆ‘ j, (directedNegativeObjectiveCoordinateLower Ο„ + (A i j) (X i j) p : ℝ)) ≀ + βˆ‘ i, βˆ‘ j, 3 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + apply Finset.sum_le_sum + intro i _ + rw [← Finset.sum_sub_distrib] + exact Finset.sum_le_sum fun j _ ↦ (hcoord i j).2.2 + _ = 3 * (n : ℝ) ^ 2 * + (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + simp [Fintype.card_fin] + ring + _ = 3 * (n : ℝ) ^ 2 * (1 / 2 : ℝ) ^ p := by norm_num + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DirectedPairCost.lean b/LeanPool/BeyondBethe/BeyondBethe/DirectedPairCost.lean new file mode 100644 index 0000000000..8f87c9aa13 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DirectedPairCost.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import Mathlib.Tactic + +/-! # Directed Pair Cost -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Directed rational evaluation of the four-core transfer cost + +The algorithm does not need to approximate a pair capacity. It only needs a +one-sided test for the local transfer cost used by the clean-pair lemma. The +formula below evaluates every logarithm over `β„š` and is deliberately directed +upward: passing the rational test proves that the true real cost passes. +-/ + +/-- The precision-scheduled lower endpoint for a positive rational logarithm. -/ +def scheduledLogLower (q : β„š) (p : β„•) : β„š := + directedLogLower q (directedLogTerms q p) + +/-- The precision-scheduled upper endpoint for a positive rational logarithm. -/ +def scheduledLogUpper (q : β„š) (p : β„•) : β„š := + directedLogUpper q (directedLogTerms q p) + +theorem scheduledLogLower_le_log {q : β„š} (hq : 0 < q) (p : β„•) : + (scheduledLogLower q p : ℝ) ≀ Real.log (q : ℝ) := + directedLogLower_le_log hq _ + +theorem log_le_scheduledLogUpper {q : β„š} (hq : 0 < q) (p : β„•) : + Real.log (q : ℝ) ≀ (scheduledLogUpper q p : ℝ) := + log_le_directedLogUpper hq _ + +theorem scheduledLog_width_le {q : β„š} (hq : 0 < q) (p : β„•) : + scheduledLogUpper q p - scheduledLogLower q p ≀ (1 / 2 : β„š) ^ p := + directedLog_width_le_dyadic hq p + +/-- Directed upper endpoint for `log (1 / transferU Ο„ (X i) j)`. +The final sum is `log (complementProduct (X i))`. -/ +def directedTransferCostUpper {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (i j : Fin n) (p : β„•) : β„š := + -(1 + Ο„) * scheduledLogLower (X i j) p - + scheduledLogLower (1 - X i j) p + + βˆ‘ k, scheduledLogUpper (1 - X i k) p + +theorem transferCost_le_directedTransferCostUpper + {n : β„•} {Ο„ : β„š} {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„ : -1 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (i j : Fin n) (p : β„•) : + Real.log (1 / transferU (Ο„ : ℝ) + (fun k ↦ ((X i k : β„š) : ℝ)) j) ≀ + (directedTransferCostUpper Ο„ X i j p : ℝ) := by + have hxq : 0 < X i j := by + have h := (hXint i).2 j |>.1 + norm_num only [Rat.cast_pos] at h + exact h + have hcxq : 0 < 1 - X i j := by + have := (hXint i).2 j |>.2 + have hxltq : X i j < 1 := + (Rat.cast_lt (K := ℝ)).mp (by simpa using this) + linarith + have hlogx := scheduledLogLower_le_log hxq p + have hlogc := scheduledLogLower_le_log hcxq p + have hcoef : (0 : ℝ) ≀ 1 + (Ο„ : ℝ) := by exact_mod_cast (by linarith : (0 : β„š) ≀ 1 + Ο„) + have hfirst : -(1 + (Ο„ : ℝ)) * Real.log (X i j : ℝ) ≀ + -(1 + (Ο„ : ℝ)) * (scheduledLogLower (X i j) p : ℝ) := by + exact mul_le_mul_of_nonpos_left hlogx (neg_nonpos.mpr hcoef) + have hsecond : -Real.log ((1 - X i j : β„š) : ℝ) ≀ + -(scheduledLogLower (1 - X i j) p : ℝ) := neg_le_neg hlogc + have hsum : Real.log (complementProduct + (fun k ↦ ((X i k : β„š) : ℝ))) ≀ + βˆ‘ k, (scheduledLogUpper (1 - X i k) p : ℝ) := by + rw [complementProduct, Real.log_prod] + Β· exact Finset.sum_le_sum fun k _ ↦ by + have hckq : 0 < 1 - X i k := by + have := (hXint i).2 k |>.2 + have hxltq : X i k < 1 := + (Rat.cast_lt (K := ℝ)).mp (by simpa using this) + linarith + simpa using log_le_scheduledLogUpper hckq p + Β· intro k _ + exact (sub_pos.mpr ((hXint i).2 k |>.2)).ne' + rw [log_one_div_transferU (hXint i)] + rw [directedTransferCostUpper] + push_cast + norm_num only [Rat.cast_sub, Rat.cast_one] at hlogc hsecond ⊒ + linarith + +/-- The directed endpoint exceeds the true transfer cost by at most one +dyadic unit for each logarithm, with coefficient `1+Ο„` on the distinguished +coordinate. -/ +theorem directedTransferCostUpper_le_add_error + {n : β„•} {Ο„ : β„š} {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (i j : Fin n) (p : β„•) : + (directedTransferCostUpper Ο„ X i j p : ℝ) ≀ + Real.log (1 / transferU (Ο„ : ℝ) + (fun k ↦ ((X i k : β„š) : ℝ)) j) + + (n + 3 : ℝ) * ((1 / 2 : β„š) ^ p : β„š) := by + have hxq : 0 < X i j := by + have h := (hXint i).2 j |>.1 + norm_num only [Rat.cast_pos] at h + exact h + have hcxq : 0 < 1 - X i j := by + have := (hXint i).2 j |>.2 + have hxltq : X i j < 1 := + (Rat.cast_lt (K := ℝ)).mp (by simpa using this) + linarith + let e : β„š := (1 / 2 : β„š) ^ p + have hwidthx := scheduledLog_width_le hxq p + have hwidthc := scheduledLog_width_le hcxq p + have hxlo := scheduledLogLower_le_log hxq p + have hxhi := log_le_scheduledLogUpper hxq p + have hclo := scheduledLogLower_le_log hcxq p + have hchi := log_le_scheduledLogUpper hcxq p + have hxerr : Real.log (X i j : ℝ) ≀ + (scheduledLogLower (X i j) p : ℝ) + (e : ℝ) := by + have hw : ((scheduledLogUpper (X i j) p - + scheduledLogLower (X i j) p : β„š) : ℝ) ≀ (e : ℝ) := by + exact_mod_cast hwidthx + push_cast at hw + linarith + have hcerr : Real.log ((1 - X i j : β„š) : ℝ) ≀ + (scheduledLogLower (1 - X i j) p : ℝ) + (e : ℝ) := by + have hw : ((scheduledLogUpper (1 - X i j) p - + scheduledLogLower (1 - X i j) p : β„š) : ℝ) ≀ (e : ℝ) := by + exact_mod_cast hwidthc + push_cast at hw + linarith + have hsumUpper : + βˆ‘ k, (scheduledLogUpper (1 - X i k) p : ℝ) ≀ + Real.log (complementProduct (fun k ↦ ((X i k : β„š) : ℝ))) + + n * (e : ℝ) := by + rw [complementProduct, Real.log_prod] + Β· have hpoint : βˆ€ k : Fin n, + (scheduledLogUpper (1 - X i k) p : ℝ) ≀ + Real.log (((1 - X i k : β„š) : ℝ)) + (e : ℝ) := by + intro k + have hckq : 0 < 1 - X i k := by + have := (hXint i).2 k |>.2 + have hxltq : X i k < 1 := + (Rat.cast_lt (K := ℝ)).mp (by simpa using this) + linarith + have hw := scheduledLog_width_le hckq p + have hlo := scheduledLogLower_le_log hckq p + have hwR : ((scheduledLogUpper (1 - X i k) p - + scheduledLogLower (1 - X i k) p : β„š) : ℝ) ≀ (e : ℝ) := by + exact_mod_cast hw + push_cast at hwR + linarith + calc + βˆ‘ k, (scheduledLogUpper (1 - X i k) p : ℝ) ≀ + βˆ‘ k, (Real.log (((1 - X i k : β„š) : ℝ)) + (e : ℝ)) := + Finset.sum_le_sum fun k _ ↦ hpoint k + _ = (βˆ‘ k, Real.log (((1 - X i k : β„š) : ℝ))) + n * (e : ℝ) := by + simp [Finset.sum_add_distrib] + _ = (βˆ‘ k, Real.log (1 - (X i k : ℝ))) + n * (e : ℝ) := by + congr 2 + funext k + norm_num + Β· intro k _ + exact (sub_pos.mpr ((hXint i).2 k |>.2)).ne' + have hΟ„R0 : (0 : ℝ) ≀ (Ο„ : ℝ) := by exact_mod_cast hΟ„0 + have hΟ„R1 : (Ο„ : ℝ) ≀ 1 := by exact_mod_cast hΟ„1 + have hmul : -(1 + (Ο„ : ℝ)) * + (scheduledLogLower (X i j) p : ℝ) ≀ + -(1 + (Ο„ : ℝ)) * Real.log (X i j : ℝ) + + 2 * (e : ℝ) := by + have hm := mul_le_mul_of_nonneg_left hxerr + (show 0 ≀ 1 + (Ο„ : ℝ) by linarith) + nlinarith + have hnegc : -(scheduledLogLower (1 - X i j) p : ℝ) ≀ + -Real.log ((1 - X i j : β„š) : ℝ) + (e : ℝ) := by linarith + change (directedTransferCostUpper Ο„ X i j p : ℝ) ≀ + Real.log (1 / transferU (Ο„ : ℝ) + (fun k ↦ ((X i k : β„š) : ℝ)) j) + (n + 3 : ℝ) * (e : ℝ) + rw [log_one_div_transferU (hXint i)] + rw [directedTransferCostUpper] + push_cast + norm_num only [Rat.cast_sub, Rat.cast_one] at hcerr hnegc ⊒ + calc + -(1 + (Ο„ : ℝ)) * (scheduledLogLower (X i j) p : ℝ) - + (scheduledLogLower (1 - X i j) p : ℝ) + + βˆ‘ k, (scheduledLogUpper (1 - X i k) p : ℝ) ≀ + (-(1 + (Ο„ : ℝ)) * Real.log (X i j : ℝ) + + 2 * (e : ℝ)) + + (-Real.log (1 - (X i j : ℝ)) + + (e : ℝ)) + + (Real.log (complementProduct (fun k ↦ ((X i k : β„š) : ℝ))) + + n * (e : ℝ)) := by + linarith + _ = -(1 + (Ο„ : ℝ)) * Real.log (X i j : ℝ) - + Real.log (1 - (X i j : ℝ)) + + Real.log (complementProduct (fun k ↦ ((X i k : β„š) : ℝ))) + + (n + 3 : ℝ) * (e : ℝ) := by ring + +/-- Directed upper endpoint for the sum of the four core transfer costs. -/ +def directedFourCoreCostUpper {n : β„•} + (Ο„ : β„š) (X : Matrix (Fin n) (Fin n) β„š) + (r s a b : Fin n) (p : β„•) : β„š := + directedTransferCostUpper Ο„ X r a p + + directedTransferCostUpper Ο„ X r b p + + directedTransferCostUpper Ο„ X s a p + + directedTransferCostUpper Ο„ X s b p + +theorem fourCoreTransferCost_le_directedFourCoreCostUpper + {n : β„•} {Ο„ : β„š} {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„ : -1 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (r s a b : Fin n) (p : β„•) : + fourCoreTransferCost (Ο„ : ℝ) + (fun i j ↦ ((X i j : β„š) : ℝ)) r s a b ≀ + (directedFourCoreCostUpper Ο„ X r s a b p : ℝ) := by + unfold fourCoreTransferCost directedFourCoreCostUpper + push_cast + linarith [transferCost_le_directedTransferCostUpper hΟ„ hXint r a p, + transferCost_le_directedTransferCostUpper hΟ„ hXint r b p, + transferCost_le_directedTransferCostUpper hΟ„ hXint s a p, + transferCost_le_directedTransferCostUpper hΟ„ hXint s b p] + +theorem directedFourCoreCostUpper_le_add_error + {n : β„•} {Ο„ : β„š} {X : Matrix (Fin n) (Fin n) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ))) + (r s a b : Fin n) (p : β„•) : + (directedFourCoreCostUpper Ο„ X r s a b p : ℝ) ≀ + fourCoreTransferCost (Ο„ : ℝ) + (fun i j ↦ ((X i j : β„š) : ℝ)) r s a b + + 4 * (n + 3 : ℝ) * ((1 / 2 : β„š) ^ p : β„š) := by + have hra := directedTransferCostUpper_le_add_error hΟ„0 hΟ„1 hXint r a p + have hrb := directedTransferCostUpper_le_add_error hΟ„0 hΟ„1 hXint r b p + have hsa := directedTransferCostUpper_le_add_error hΟ„0 hΟ„1 hXint s a p + have hsb := directedTransferCostUpper_le_add_error hΟ„0 hΟ„1 hXint s b p + have hecast : ((((1 / 2 : β„š) ^ p : β„š)) : ℝ) = (1 / 2 : ℝ) ^ p := by + norm_num + unfold fourCoreTransferCost directedFourCoreCostUpper + push_cast + rw [← hecast] + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DyadicMagnitudePrecision.lean b/LeanPool/BeyondBethe/BeyondBethe/DyadicMagnitudePrecision.lean new file mode 100644 index 0000000000..a93ccac226 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DyadicMagnitudePrecision.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import Mathlib.Data.Nat.Size +public import Mathlib.Tactic + +/-! # Dyadic Magnitude Precision -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# A magnitude-sensitive dyadic precision + +Using the full encoding length of a rational as a dyadic precision is much +too conservative: the determinant of a dyadic `d`-by-`d` matrix can have a +denominator with `d p` bits even when its numerical magnitude is bounded +away from zero. Iterating that rule would multiply the stored precision by +the dimension. The definition below instead uses the *difference* between +the denominator and numerator bit lengths. It therefore measures +`logβ‚‚ (1 / q)`, up to an additive constant, rather than the cost of writing +the exact reduced fraction. +-/ + +/-- A total precision selector. On a positive rational it is, up to two +guard bits, the binary exponent needed to resolve its magnitude. -/ +def positiveDyadicPrecision (q : β„š) : β„• := + q.den.size + 2 - q.num.natAbs.size + +theorem positiveDyadicPrecision_add_num_size_ge (q : β„š) : + q.den.size + 2 ≀ + positiveDyadicPrecision q + q.num.natAbs.size := by + rw [positiveDyadicPrecision] + omega + +/-- The selected dyadic mesh is strictly below every positive input. -/ +theorem dyadicMesh_positiveDyadicPrecision_lt {q : β„š} (hq : 0 < q) : + dyadicMesh (positiveDyadicPrecision q) < q := by + let a := q.num.natAbs + let D := q.den.size + let N := a.size + let p := positiveDyadicPrecision q + have hnum : 0 < q.num := Rat.num_pos.mpr hq + have ha0 : 0 < a := by + dsimp only [a] + exact Int.natAbs_pos.mpr hnum.ne' + have hN0 : 0 < N := by + dsimp only [N] + exact Nat.size_pos.mpr ha0 + have haLower : 2 ^ (N - 1) ≀ a := by + rw [← Nat.lt_size] + dsimp only [N] + omega + have hdenUpper : q.den < 2 ^ D := by + dsimp only [D] + exact Nat.lt_size_self q.den + have hsum : D + 2 ≀ p + N := by + simpa only [D, N, p] using positiveDyadicPrecision_add_num_size_ge q + have hexp : 2 ^ (D + 1) ≀ 2 ^ (p + (N - 1)) := by + apply Nat.pow_le_pow_right (by norm_num : 0 < 2) + omega + have hmulLower : 2 ^ (p + (N - 1)) ≀ 2 ^ p * a := by + rw [pow_add] + exact Nat.mul_le_mul_left _ haLower + have hdenMul : q.den < 2 ^ p * a := by + calc + q.den < 2 ^ D := hdenUpper + _ < 2 ^ (D + 1) := by + rw [pow_succ] + have : 0 < 2 ^ D := by positivity + omega + _ ≀ 2 ^ (p + (N - 1)) := hexp + _ ≀ 2 ^ p * a := hmulLower + have hqrep : q = (a : β„š) / (q.den : β„š) := by + calc + q = (q.num : β„š) / (q.den : β„š) := (Rat.num_div_den q).symm + _ = (a : β„š) / (q.den : β„š) := by + congr 1 + have haz : (a : β„€) = q.num := by + dsimp only [a] + exact Int.natAbs_of_nonneg hnum.le + have hcast := congrArg (fun z : β„€ ↦ (z : β„š)) haz.symm + simpa using hcast + have hdenMulQ : (q.den : β„š) < (2 : β„š) ^ p * (a : β„š) := by + exact_mod_cast hdenMul + change 1 / (2 : β„š) ^ p < q + rw [hqrep] + have hpow : (0 : β„š) < (2 : β„š) ^ p := by positivity + have hden : (0 : β„š) < q.den := by positivity + rw [div_lt_div_iffβ‚€ hpow hden] + simpa [mul_comm, mul_left_comm, mul_assoc] using hdenMulQ + +/-- Conversely, any proved dyadic lower bound on a positive rational gives +a direct upper bound on the selected precision. This is the key estimate +that prevents precision from tracking irrelevant exact denominators. -/ +theorem positiveDyadicPrecision_le_of_dyadicMesh_le + {q : β„š} (hq : 0 < q) {P : β„•} + (hlower : dyadicMesh P ≀ q) : + positiveDyadicPrecision q ≀ P + 2 := by + let a := q.num.natAbs + let D := q.den.size + let N := a.size + have hnum : 0 < q.num := Rat.num_pos.mpr hq + have ha0 : 0 < a := by + dsimp only [a] + exact Int.natAbs_pos.mpr hnum.ne' + have hqrep : q = (a : β„š) / (q.den : β„š) := by + calc + q = (q.num : β„š) / (q.den : β„š) := (Rat.num_div_den q).symm + _ = (a : β„š) / (q.den : β„š) := by + congr 1 + have haz : (a : β„€) = q.num := by + dsimp only [a] + exact Int.natAbs_of_nonneg hnum.le + have hcast := congrArg (fun z : β„€ ↦ (z : β„š)) haz.symm + simpa using hcast + have hcrossQ : (q.den : β„š) ≀ (2 : β„š) ^ P * (a : β„š) := by + rw [dyadicMesh, hqrep] at hlower + have hpow : (0 : β„š) < (2 : β„š) ^ P := by positivity + have hden : (0 : β„š) < q.den := by positivity + rw [div_le_div_iffβ‚€ hpow hden] at hlower + simpa [mul_comm, mul_left_comm, mul_assoc] using hlower + have hcross : q.den ≀ 2 ^ P * a := by + exact_mod_cast hcrossQ + have haUpper : a < 2 ^ N := by + dsimp only [N] + exact Nat.lt_size_self a + have hdenUpper : q.den < 2 ^ (P + N) := by + calc + q.den ≀ 2 ^ P * a := hcross + _ < 2 ^ P * 2 ^ N := + Nat.mul_lt_mul_of_pos_left haUpper (by positivity) + _ = 2 ^ (P + N) := by rw [pow_add] + have hD : D ≀ P + N := by + dsimp only [D] + exact Nat.size_le.mpr hdenUpper + dsimp only [D, N, a] at hD + rw [positiveDyadicPrecision] + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/DyadicRounding.lean b/LeanPool/BeyondBethe/BeyondBethe/DyadicRounding.lean new file mode 100644 index 0000000000..204abe6ebb --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/DyadicRounding.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.BeyondBethe.RationalEllipsoid +public import Mathlib.Data.Rat.Floor +public import Mathlib.Tactic + +/-! # Dyadic Rounding -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Executable dyadic rounding + +The exact rational ellipsoid update is mathematically convenient, but its +reduced numerators and denominators need not have polynomial length after a +polynomial number of iterations. This file defines the rounding primitive +used by the bounded-bit implementation. It is deliberately just integer +floor followed by division by a power of two, so its output has an explicit +dyadic presentation and its error is proved directly from the floor axioms. +-/ + +/-- The mesh of the dyadic grid with `p` fractional bits. -/ +def dyadicMesh (p : β„•) : β„š := 1 / (2 : β„š) ^ p + +theorem dyadicMesh_pos (p : β„•) : 0 < dyadicMesh p := by + simp [dyadicMesh] + +theorem dyadicMesh_nonneg (p : β„•) : 0 ≀ dyadicMesh p := + (dyadicMesh_pos p).le + +theorem dyadicMesh_le_one (p : β„•) : dyadicMesh p ≀ 1 := by + rw [dyadicMesh, one_div] + exact inv_le_one_of_one_leβ‚€ (one_le_powβ‚€ (by norm_num : (1 : β„š) ≀ 2)) + +/-- Finer dyadic grids have smaller mesh. -/ +theorem dyadicMesh_antitone {p q : β„•} (hpq : p ≀ q) : + dyadicMesh q ≀ dyadicMesh p := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le hpq + rw [dyadicMesh, dyadicMesh] + exact one_div_le_one_div_of_le (by positivity : (0 : β„š) < (2 : β„š) ^ p) + (by + rw [pow_add] + simpa only [mul_one] using mul_le_mul_of_nonneg_left + (one_le_powβ‚€ (by norm_num : (1 : β„š) ≀ 2)) + (by positivity : (0 : β„š) ≀ (2 : β„š) ^ p)) + +theorem dyadicMesh_mul_pow_two (p : β„•) : + dyadicMesh p * (2 : β„š) ^ p = 1 := by + simp [dyadicMesh] + +/-- Round a rational down to the `2^-p` grid. This is executable integer +division, not a choice of a nearby rational. -/ +def dyadicFloor (p : β„•) (q : β„š) : β„š := + (Int.floor (q * (2 : β„š) ^ p) : β„š) / (2 : β„š) ^ p + +theorem dyadicFloor_eq_floor_mul_mesh (p : β„•) (q : β„š) : + dyadicFloor p q = (Int.floor (q * (2 : β„š) ^ p) : β„š) * dyadicMesh p := by + simp [dyadicFloor, dyadicMesh, div_eq_mul_inv] + +theorem dyadicFloor_mul_pow_two (p : β„•) (q : β„š) : + dyadicFloor p q * (2 : β„š) ^ p = + (Int.floor (q * (2 : β„š) ^ p) : β„š) := by + rw [dyadicFloor] + field_simp + +/-- Rounding down never increases the input. -/ +theorem dyadicFloor_le (p : β„•) (q : β„š) : dyadicFloor p q ≀ q := by + have hfloor : + ((Int.floor (q * (2 : β„š) ^ p) : β„€) : β„š) ≀ + q * (2 : β„š) ^ p := Int.floor_le _ + rw [dyadicFloor] + exact (div_le_iffβ‚€ (by positivity : (0 : β„š) < (2 : β„š) ^ p)).2 + (by simpa [mul_comm] using hfloor) + +/-- The one-sided rounding error is strictly smaller than one mesh. -/ +theorem lt_dyadicFloor_add_mesh (p : β„•) (q : β„š) : + q < dyadicFloor p q + dyadicMesh p := by + have hfloor : q * (2 : β„š) ^ p < + ((Int.floor (q * (2 : β„š) ^ p) : β„€) : β„š) + 1 := + Int.lt_floor_add_one _ + rw [dyadicFloor, dyadicMesh] + have hp : (0 : β„š) < (2 : β„š) ^ p := by positivity + rw [show + ((Int.floor (q * (2 : β„š) ^ p) : β„€) : β„š) / (2 : β„š) ^ p + + 1 / (2 : β„š) ^ p = + (((Int.floor (q * (2 : β„š) ^ p) : β„€) : β„š) + 1) / + (2 : β„š) ^ p by rw [add_div]] + exact (lt_div_iffβ‚€ hp).2 (by simpa [mul_comm] using hfloor) + +theorem dyadicFloor_error_nonneg (p : β„•) (q : β„š) : + 0 ≀ q - dyadicFloor p q := sub_nonneg.mpr (dyadicFloor_le p q) + +theorem dyadicFloor_error_lt (p : β„•) (q : β„š) : + q - dyadicFloor p q < dyadicMesh p := by + linarith [lt_dyadicFloor_add_mesh p q] + +/-- Absolute-error form used by vector and matrix estimates. -/ +theorem abs_dyadicFloor_sub_lt (p : β„•) (q : β„š) : + abs (dyadicFloor p q - q) < dyadicMesh p := by + rw [abs_of_nonpos (sub_nonpos.mpr (dyadicFloor_le p q))] + simpa only [neg_sub] using dyadicFloor_error_lt p q + +theorem abs_dyadicFloor_le (p : β„•) (q : β„š) : + abs (dyadicFloor p q) < abs q + dyadicMesh p := by + calc + abs (dyadicFloor p q) = + abs ((dyadicFloor p q - q) + q) := by ring_nf + _ ≀ abs (dyadicFloor p q - q) + abs q := abs_add_le _ _ + _ < dyadicMesh p + abs q := by + gcongr + exact abs_dyadicFloor_sub_lt p q + _ = abs q + dyadicMesh p := by ring + +/-- Coordinatewise dyadic rounding of a finite vector. -/ +def dyadicFloorVector {d : β„•} (p : β„•) (x : Fin d β†’ β„š) : Fin d β†’ β„š := + fun i ↦ dyadicFloor p (x i) + +/-- Coordinatewise dyadic rounding of a finite matrix. -/ +def dyadicFloorMatrix {m n : β„•} (p : β„•) + (A : Matrix (Fin m) (Fin n) β„š) : Matrix (Fin m) (Fin n) β„š := + fun i j ↦ dyadicFloor p (A i j) + +theorem dyadicFloorVector_error_l1_lt {d : β„•} (hd : 0 < d) (p : β„•) + (x : Fin d β†’ β„š) : + (βˆ‘ i, abs (dyadicFloorVector p x i - x i)) < d * dyadicMesh p := by + letI : Nonempty (Fin d) := Fin.pos_iff_nonempty.mp hd + rw [show (d : β„š) * dyadicMesh p = + βˆ‘ _i : Fin d, dyadicMesh p by simp] + apply Finset.sum_lt_sum + Β· intro i _ + exact (abs_dyadicFloor_sub_lt p (x i)).le + Β· let i : Fin d := ⟨0, hd⟩ + exact ⟨i, Finset.mem_univ i, abs_dyadicFloor_sub_lt p (x i)⟩ + +theorem dyadicFloorVector_error_normSq_lt {d : β„•} (hd : 0 < d) + (p : β„•) (x : Fin d β†’ β„š) : + finiteNormSq (fun i ↦ dyadicFloorVector p x i - x i) < + d * dyadicMesh p ^ 2 := by + letI : Nonempty (Fin d) := Fin.pos_iff_nonempty.mp hd + rw [finiteNormSq, finiteDot, + show (d : β„š) * dyadicMesh p ^ 2 = + βˆ‘ _i : Fin d, dyadicMesh p ^ 2 by simp] + have hentry : βˆ€ i : Fin d, + (dyadicFloorVector p x i - x i) * + (dyadicFloorVector p x i - x i) < dyadicMesh p ^ 2 := by + intro i + have habs : abs (dyadicFloorVector p x i - x i) < dyadicMesh p := by + simpa only [dyadicFloorVector] using abs_dyadicFloor_sub_lt p (x i) + have habs0 : 0 ≀ abs (dyadicFloorVector p x i - x i) := abs_nonneg _ + have hmesh := dyadicMesh_nonneg p + calc + (dyadicFloorVector p x i - x i) * + (dyadicFloorVector p x i - x i) = + abs (dyadicFloorVector p x i - x i) ^ 2 := by + rw [sq_abs, sq] + _ < dyadicMesh p ^ 2 := (sq_lt_sqβ‚€ habs0 hmesh).2 habs + apply Finset.sum_lt_sum + Β· intro i _ + exact (hentry i).le + Β· let i : Fin d := ⟨0, hd⟩ + exact ⟨i, Finset.mem_univ i, hentry i⟩ + +theorem dyadicFloorMatrix_entry_error_lt {m n : β„•} (p : β„•) + (A : Matrix (Fin m) (Fin n) β„š) (i : Fin m) (j : Fin n) : + abs (dyadicFloorMatrix p A i j - A i j) < dyadicMesh p := + abs_dyadicFloor_sub_lt p (A i j) + +theorem cast_dyadicFloorMatrix_entry_error_lt {m n : β„•} (p : β„•) + (A : Matrix (Fin m) (Fin n) β„š) (i : Fin m) (j : Fin n) : + abs (((dyadicFloorMatrix p A i j - A i j : β„š) : ℝ)) < + (dyadicMesh p : ℝ) := by + exact_mod_cast dyadicFloorMatrix_entry_error_lt p A i j + +theorem abs_cast_dyadicFloorMatrix_le {m n : β„•} (p : β„•) + (A : Matrix (Fin m) (Fin n) β„š) (i : Fin m) (j : Fin n) : + abs ((dyadicFloorMatrix p A i j : β„š) : ℝ) < + abs ((A i j : β„š) : ℝ) + (dyadicMesh p : ℝ) := by + exact_mod_cast abs_dyadicFloor_le p (A i j) + +/-- Every rounded value has a concrete integer-over-power-of-two +presentation. Later bit-complexity proofs use this presentation rather than +the implementation-dependent reduced numerator and denominator. -/ +theorem dyadicFloor_has_integer_presentation (p : β„•) (q : β„š) : + βˆƒ z : β„€, dyadicFloor p q = (z : β„š) / (2 : β„š) ^ p := by + exact ⟨Int.floor (q * (2 : β„š) ^ p), rfl⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Entropy.lean b/LeanPool/BeyondBethe/BeyondBethe/Entropy.lean new file mode 100644 index 0000000000..27c5ed310a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Entropy.lean @@ -0,0 +1,863 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Birkhoff +public import Mathlib.Analysis.Convex.Jensen +public import Mathlib.Analysis.MeanInequalities +public import Mathlib.Analysis.SpecialFunctions.Log.NegMulLog +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Data.Fintype.Perm +public import Mathlib.Tactic + +/-! # Entropy -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- A probability vector on a finite type. -/ +def IsProbabilityVector + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : Prop := + (βˆ€ i, 0 ≀ p i) ∧ βˆ‘ i, p i = 1 + +/-- A probability vector with full support. -/ +def IsStrictProbabilityVector + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : Prop := + IsProbabilityVector p ∧ βˆ€ i, 0 < p i + +theorem IsStrictProbabilityVector.probability + {ΞΉ : Type*} [Fintype ΞΉ] {p : ΞΉ β†’ ℝ} + (hp : IsStrictProbabilityVector p) : + IsProbabilityVector p := + hp.1 + +theorem IsStrictProbabilityVector.positive + {ΞΉ : Type*} [Fintype ΞΉ] {p : ΞΉ β†’ ℝ} + (hp : IsStrictProbabilityVector p) (i : ΞΉ) : + 0 < p i := + hp.2 i + +theorem IsProbabilityVector.nonnegative + {ΞΉ : Type*} [Fintype ΞΉ] {p : ΞΉ β†’ ℝ} + (hp : IsProbabilityVector p) (i : ΞΉ) : + 0 ≀ p i := + hp.1 i + +theorem IsProbabilityVector.sum_eq_one + {ΞΉ : Type*} [Fintype ΞΉ] {p : ΞΉ β†’ ℝ} + (hp : IsProbabilityVector p) : + βˆ‘ i, p i = 1 := + hp.2 + +theorem IsProbabilityVector.le_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) (i : ΞΉ) : + p i ≀ 1 := by + rw [← hp.sum_eq_one] + exact Finset.single_le_sum + (fun j _ ↦ hp.nonnegative j) (Finset.mem_univ i) + +theorem IsDoublyStochastic.row_probability + {n : Type*} [Fintype n] {X : Matrix n n ℝ} + (hX : IsDoublyStochastic X) (i : n) : + IsProbabilityVector (X i) := by + exact ⟨hX.nonnegative i, hX.row_sum i⟩ + +/-- Shannon entropy with the convention `0 log 0 = 0`. -/ +noncomputable def shannonEntropy + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i, Real.negMulLog (p i) + +theorem shannonEntropy_nonneg + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) : + 0 ≀ shannonEntropy p := by + apply Finset.sum_nonneg + intro i _ + exact Real.negMulLog_nonneg (hp.nonnegative i) (hp.le_one i) + +/-- Entropy is at most the logarithm of the support size. -/ +theorem shannonEntropy_le_log_card + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) : + shannonEntropy p ≀ Real.log (Fintype.card ΞΉ) := by + let N : ℝ := Fintype.card ΞΉ + have hN : 0 < N := by + dsimp [N] + exact_mod_cast Fintype.card_pos + have hweights : βˆ‘ _i : ΞΉ, (1 / N : ℝ) = 1 := by + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + dsimp [N] + field_simp + have hJ := Real.concaveOn_negMulLog.le_map_sum + (t := Finset.univ) (w := fun _i : ΞΉ ↦ 1 / N) (p := p) + (fun _ _ ↦ by positivity) hweights + (fun i _ ↦ hp.nonnegative i) + have havg : + (1 / N) * shannonEntropy p ≀ Real.negMulLog (1 / N) := by + simpa only [smul_eq_mul, shannonEntropy, ← Finset.mul_sum, + hp.sum_eq_one, mul_one] using hJ + have hmul := mul_le_mul_of_nonneg_left havg hN.le + have hleft : N * ((1 / N) * shannonEntropy p) = shannonEntropy p := by + field_simp + have hright : N * Real.negMulLog (1 / N) = Real.log N := by + rw [Real.negMulLog_def] + field_simp + simp [Real.log_inv] + rw [hleft, hright] at hmul + simpa [N] using hmul + +/-- Total row entropy of a doubly stochastic matrix. -/ +noncomputable def totalRowEntropy + {n : Type*} [Fintype n] (X : Matrix n n ℝ) : ℝ := + βˆ‘ i, shannonEntropy (X i) + +theorem totalRowEntropy_nonneg + {n : Type*} [Fintype n] [DecidableEq n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) : + 0 ≀ totalRowEntropy X := by + exact Finset.sum_nonneg fun i _ ↦ + shannonEntropy_nonneg (hX.row_probability i) + +theorem totalRowEntropy_le + {n : Type*} [Fintype n] [DecidableEq n] [Nonempty n] + {X : Matrix n n ℝ} (hX : IsDoublyStochastic X) : + totalRowEntropy X ≀ + Fintype.card n * Real.log (Fintype.card n) := by + rw [totalRowEntropy] + calc + βˆ‘ i, shannonEntropy (X i) + ≀ βˆ‘ _i : n, Real.log (Fintype.card n) := + Finset.sum_le_sum fun i _ ↦ + shannonEntropy_le_log_card (hX.row_probability i) + _ = Fintype.card n * Real.log (Fintype.card n) := by + simp [nsmul_eq_mul] + +/-- Binary entropy, again with the continuous boundary convention. -/ +noncomputable def binaryEntropy (t : ℝ) : ℝ := + Real.negMulLog t + Real.negMulLog (1 - t) + +theorem binaryEntropy_symm (t : ℝ) : + binaryEntropy (1 - t) = binaryEntropy t := by + rw [binaryEntropy, binaryEntropy] + ring_nf + +/-- Exact entropy loss when two positive atoms of masses `u` and `v` are +merged. This is the scalar identity used in paper (26). -/ +theorem entropy_loss_merge_two {u v : ℝ} (hu : 0 < u) (hv : 0 < v) : + Real.negMulLog u + Real.negMulLog v - Real.negMulLog (u + v) = + (u + v) * binaryEntropy (u / (u + v)) := by + have hs : u + v β‰  0 := (add_pos hu hv).ne' + have hratio : 1 - u / (u + v) = v / (u + v) := by + field_simp + ring + rw [binaryEntropy, hratio] + simp only [Real.negMulLog_def] + rw [Real.log_div hu.ne' hs, Real.log_div hv.ne' hs] + field_simp + ring + +/-- Finite log-sum inequality with strictly positive weights. This is the +one-sided, certificate-producing half of the entropy duality for capacity. -/ +theorem log_sum_inequality + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {ΞΈ w : ΞΉ β†’ ℝ} + (hΞΈ : βˆ€ i, 0 < ΞΈ i) (hΞΈsum : βˆ‘ i, ΞΈ i = 1) + (hw : βˆ€ i, 0 < w i) : + βˆ‘ i, ΞΈ i * Real.log (w i / ΞΈ i) ≀ Real.log (βˆ‘ i, w i) := by + let r : ΞΉ β†’ ℝ := fun i ↦ w i / ΞΈ i + have hr : βˆ€ i, 0 < r i := fun i ↦ div_pos (hw i) (hΞΈ i) + have hAM := Real.geom_mean_le_arith_mean_weighted + Finset.univ ΞΈ r + (fun i _ ↦ (hΞΈ i).le) hΞΈsum + (fun i _ ↦ (hr i).le) + have harith : βˆ‘ i, ΞΈ i * r i = βˆ‘ i, w i := by + apply Finset.sum_congr rfl + intro i _ + dsimp [r] + field_simp [(hΞΈ i).ne'] + rw [harith] at hAM + have hprod : 0 < ∏ i, (r i) ^ (ΞΈ i) := + Finset.prod_pos fun i _ ↦ Real.rpow_pos_of_pos (hr i) _ + have hlog := Real.log_le_log hprod hAM + rw [Real.log_prod (fun i _ ↦ (Real.rpow_pos_of_pos (hr i) _).ne')] at hlog + simp_rw [Real.log_rpow (hr _) ] at hlog + simpa [r] using hlog + +/-- Log-sum with zero weights allowed. Terms of weight zero use Lean's +continuous convention `0 * log 0 = 0`; the proof restricts to the positive +support before applying the strict version. -/ +theorem log_sum_inequality_nonnegative + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {ΞΈ w : ΞΉ β†’ ℝ} + (hΞΈ : βˆ€ i, 0 ≀ ΞΈ i) (hΞΈsum : βˆ‘ i, ΞΈ i = 1) + (hw : βˆ€ i, 0 < w i) : + βˆ‘ i, ΞΈ i * Real.log (w i / ΞΈ i) ≀ Real.log (βˆ‘ i, w i) := by + let s : Finset ΞΉ := Finset.univ.filter fun i ↦ 0 < ΞΈ i + have hs : s.Nonempty := by + by_contra hempty + have hzero : βˆ€ i, ΞΈ i = 0 := by + intro i + have hnot : Β¬0 < ΞΈ i := by + intro hi + exact hempty ⟨i, by simp [s, hi]⟩ + exact le_antisymm (le_of_not_gt hnot) (hΞΈ i) + have : (βˆ‘ i, ΞΈ i) = 0 := by simp [hzero] + linarith + letI : Nonempty s := ⟨⟨hs.choose, hs.choose_spec⟩⟩ + let ΞΈs : s β†’ ℝ := fun i ↦ ΞΈ i + let ws : s β†’ ℝ := fun i ↦ w i + have hΞΈs : βˆ€ i, 0 < ΞΈs i := by + intro i + exact (Finset.mem_filter.mp i.property).2 + have hΞΈsSum : βˆ‘ i, ΞΈs i = 1 := by + have hsupport : (βˆ‘ i ∈ s, ΞΈ i) = βˆ‘ i, ΞΈ i := by + apply Finset.sum_subset (Finset.subset_univ s) + intro i _ hi + have hnot : Β¬0 < ΞΈ i := by + intro hpos + exact hi (by simp [s, hpos]) + exact le_antisymm (le_of_not_gt hnot) (hΞΈ i) + calc + (βˆ‘ i : s, ΞΈs i) = βˆ‘ i ∈ s, ΞΈ i := by + simpa [ΞΈs] using Finset.sum_coe_sort s (fun i ↦ ΞΈ i) + _ = 1 := by rw [hsupport, hΞΈsum] + have hstrict := log_sum_inequality hΞΈs hΞΈsSum (fun i ↦ hw i) + have hleft : (βˆ‘ i : s, ΞΈs i * Real.log (ws i / ΞΈs i)) = + βˆ‘ i, ΞΈ i * Real.log (w i / ΞΈ i) := by + have hsupport : + (βˆ‘ i ∈ s, ΞΈ i * Real.log (w i / ΞΈ i)) = + βˆ‘ i, ΞΈ i * Real.log (w i / ΞΈ i) := by + apply Finset.sum_subset (Finset.subset_univ s) + intro i _ hi + have hnot : Β¬0 < ΞΈ i := by + intro hpos + exact hi (by simp [s, hpos]) + have hzero : ΞΈ i = 0 := le_antisymm (le_of_not_gt hnot) (hΞΈ i) + simp [hzero] + calc + (βˆ‘ i : s, ΞΈs i * Real.log (ws i / ΞΈs i)) = + βˆ‘ i ∈ s, ΞΈ i * Real.log (w i / ΞΈ i) := by + simpa [ΞΈs, ws] using Finset.sum_coe_sort s + (fun i ↦ ΞΈ i * Real.log (w i / ΞΈ i)) + _ = βˆ‘ i, ΞΈ i * Real.log (w i / ΞΈ i) := hsupport + have hrightSupport : (βˆ‘ i : s, ws i) = βˆ‘ i ∈ s, w i := by + simpa [ws] using Finset.sum_coe_sort s (fun i ↦ w i) + have hsupportPos : 0 < βˆ‘ i : s, ws i := + Finset.sum_pos (fun i _ ↦ hw i) Finset.univ_nonempty + have hallPos : 0 < βˆ‘ i, w i := + Finset.sum_pos (fun i _ ↦ hw i) (hs.mono (Finset.subset_univ s)) + have hsumLe : (βˆ‘ i : s, ws i) ≀ βˆ‘ i, w i := by + rw [hrightSupport] + exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ s) + (fun i _ _ ↦ (hw i).le) + rw [hleft] at hstrict + exact hstrict.trans (Real.log_le_log hsupportPos hsumLe) + +/-- Entropy bound for a nonnegative vector of total mass `ρ`. This is the +scaled form used for the outside mass in paper (60). -/ +theorem shannonEntropy_of_mass_le + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + {Ξ± : ΞΉ β†’ ℝ} {ρ : ℝ} + (hΞ± : βˆ€ i, 0 ≀ Ξ± i) (hρ : 0 < ρ) (hsum : βˆ‘ i, Ξ± i = ρ) : + shannonEntropy Ξ± ≀ ρ * Real.log (Fintype.card ΞΉ / ρ) := by + let q : ΞΉ β†’ ℝ := fun i ↦ Ξ± i / ρ + have hq : IsProbabilityVector q := by + constructor + Β· intro i + exact div_nonneg (hΞ± i) hρ.le + Β· dsimp [q] + rw [← Finset.sum_div, hsum, div_self hρ.ne'] + have hscale : shannonEntropy Ξ± = + ρ * shannonEntropy q - ρ * Real.log ρ := by + calc + shannonEntropy Ξ± = + βˆ‘ i, (ρ * Real.negMulLog (q i) - Ξ± i * Real.log ρ) := by + rw [shannonEntropy] + apply Finset.sum_congr rfl + intro i _ + by_cases hzero : Ξ± i = 0 + Β· simp [hzero, q] + Β· simp only [Real.negMulLog_def] + rw [Real.log_div hzero hρ.ne'] + dsimp [q] + field_simp + ring + _ = ρ * shannonEntropy q - (βˆ‘ i, Ξ± i) * Real.log ρ := by + rw [Finset.sum_sub_distrib, ← Finset.mul_sum, + ← Finset.sum_mul, shannonEntropy] + _ = ρ * shannonEntropy q - ρ * Real.log ρ := by rw [hsum] + have hentropy := shannonEntropy_le_log_card hq + have hmul := mul_le_mul_of_nonneg_left hentropy hρ.le + rw [hscale] + rw [Real.log_div (by exact_mod_cast Fintype.card_ne_zero) hρ.ne'] + linarith + +/-- Probability mass induced on the values of a deterministic map. -/ +noncomputable def pushforwardMass + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ²] + (ΞΌ : Ξ± β†’ ℝ) (f : Ξ± β†’ Ξ²) (y : Ξ²) : ℝ := + βˆ‘ x, if f x = y then ΞΌ x else 0 + +theorem pushforwardMass_isProbabilityVector + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ²] + (ΞΌ : Ξ± β†’ ℝ) (hΞΌ : IsProbabilityVector ΞΌ) (f : Ξ± β†’ Ξ²) : + IsProbabilityVector (pushforwardMass ΞΌ f) := by + classical + constructor + Β· intro y + exact Finset.sum_nonneg (fun x _ ↦ by + by_cases h : f x = y + Β· simp only [ite_eq_left h] + exact hΞΌ.nonnegative x + Β· simp only [ite_eq_right h] + exact le_rfl) + Β· simp only [pushforwardMass] + calc + (βˆ‘ y, βˆ‘ x, if f x = y then ΞΌ x else 0) = + βˆ‘ x, βˆ‘ y, if f x = y then ΞΌ x else 0 := Finset.sum_comm + _ = βˆ‘ x, ΞΌ x := by simp + _ = 1 := hΞΌ.sum_eq_one + +theorem pushforwardMass_comp + {Ξ± Ξ² Ξ³ : Type*} [Fintype Ξ±] [Fintype Ξ²] [Fintype Ξ³] + [DecidableEq Ξ²] [DecidableEq Ξ³] + (ΞΌ : Ξ± β†’ ℝ) (f : Ξ± β†’ Ξ²) (g : Ξ² β†’ Ξ³) (z : Ξ³) : + pushforwardMass (pushforwardMass ΞΌ f) g z = + pushforwardMass ΞΌ (g ∘ f) z := by + classical + calc + pushforwardMass (pushforwardMass ΞΌ f) g z = + βˆ‘ y, βˆ‘ x, if g y = z ∧ f x = y then ΞΌ x else 0 := by + unfold pushforwardMass + apply Finset.sum_congr rfl + intro y _ + by_cases hy : g y = z + Β· simp [hy] + Β· simp [hy] + _ = βˆ‘ x, βˆ‘ y, if g y = z ∧ f x = y then ΞΌ x else 0 := + Finset.sum_comm + _ = pushforwardMass ΞΌ (g ∘ f) z := by + unfold pushforwardMass + apply Finset.sum_congr rfl + intro x _ + by_cases hx : g (f x) = z + Β· simp only [Function.comp_apply, ite_eq_left hx] + rw [Finset.sum_eq_single (f x)] + Β· simp [hx] + Β· intro y _ hy + simp [Ne.symm hy] + Β· simp + Β· simp only [Function.comp_apply, ite_eq_right hx] + apply Finset.sum_eq_zero + intro y _ + by_cases hy : f x = y + Β· subst y + simp [hx] + Β· simp [hy] + +theorem pushforwardMass_equiv_apply + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ²] + (ΞΌ : Ξ± β†’ ℝ) (e : Ξ± ≃ Ξ²) (y : Ξ²) : + pushforwardMass ΞΌ e y = ΞΌ (e.symm y) := by + classical + unfold pushforwardMass + rw [Finset.sum_eq_single (e.symm y)] + Β· simp + Β· intro x _ hx + have hne : e x β‰  y := by + intro h + apply hx + exact e.injective (h.trans (e.apply_symm_apply y).symm) + simp [hne] + Β· simp + +theorem shannonEntropy_pushforward_equiv + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ²] + (ΞΌ : Ξ± β†’ ℝ) (e : Ξ± ≃ Ξ²) : + shannonEntropy (pushforwardMass ΞΌ e) = shannonEntropy ΞΌ := by + simp_rw [shannonEntropy, pushforwardMass_equiv_apply] + exact e.symm.sum_comp (fun x ↦ Real.negMulLog (ΞΌ x)) + +/-- The first marginal of a probability mass on a finite product. -/ +noncomputable def firstMarginal + {Ξ± Ξ² : Type*} [Fintype Ξ²] (ΞΌ : Ξ± Γ— Ξ² β†’ ℝ) (x : Ξ±) : ℝ := + βˆ‘ y, ΞΌ (x, y) + +/-- The second marginal of a probability mass on a finite product. -/ +noncomputable def secondMarginal + {Ξ± Ξ² : Type*} [Fintype Ξ±] (ΞΌ : Ξ± Γ— Ξ² β†’ ℝ) (y : Ξ²) : ℝ := + βˆ‘ x, ΞΌ (x, y) + +/-- Conditional second-coordinate mass. It is set to zero on a zero-mass +first-coordinate fiber, using Lean's division convention. -/ +noncomputable def conditionalSecond + {Ξ± Ξ² : Type*} [Fintype Ξ²] (ΞΌ : Ξ± Γ— Ξ² β†’ ℝ) (x : Ξ±) (y : Ξ²) : ℝ := + ΞΌ (x, y) / firstMarginal ΞΌ x + +theorem firstMarginal_isProbabilityVector + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + IsProbabilityVector (firstMarginal ΞΌ) := by + constructor + Β· intro x + exact Finset.sum_nonneg fun y _ ↦ hΞΌ.nonnegative (x, y) + Β· change (βˆ‘ x, βˆ‘ y, ΞΌ (x, y)) = 1 + rw [← Finset.sum_product] + exact hΞΌ.sum_eq_one + +theorem secondMarginal_isProbabilityVector + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + IsProbabilityVector (secondMarginal ΞΌ) := by + constructor + Β· intro y + exact Finset.sum_nonneg fun x _ ↦ hΞΌ.nonnegative (x, y) + Β· change (βˆ‘ y, βˆ‘ x, ΞΌ (x, y)) = 1 + rw [Finset.sum_comm, ← Finset.sum_product] + exact hΞΌ.sum_eq_one + +theorem firstMarginal_eq_pushforward_fst + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ±] + (ΞΌ : Ξ± Γ— Ξ² β†’ ℝ) : + firstMarginal ΞΌ = pushforwardMass ΞΌ Prod.fst := by + funext x + unfold firstMarginal pushforwardMass + rw [Fintype.sum_prod_type] + rw [Finset.sum_eq_single x] + Β· simp + Β· intro z _ hzx + simp [hzx] + Β· simp + +theorem secondMarginal_eq_pushforward_snd + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] [DecidableEq Ξ²] + (ΞΌ : Ξ± Γ— Ξ² β†’ ℝ) : + secondMarginal ΞΌ = pushforwardMass ΞΌ Prod.snd := by + funext y + unfold secondMarginal pushforwardMass + rw [Fintype.sum_prod_type, Finset.sum_comm] + rw [Finset.sum_eq_single y] + Β· simp + Β· intro z _ hzy + simp [hzy] + Β· simp + +theorem joint_eq_firstMarginal_mul_conditionalSecond + {Ξ± Ξ² : Type*} [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : βˆ€ z, 0 ≀ ΞΌ z) (x : Ξ±) (y : Ξ²) : + ΞΌ (x, y) = firstMarginal ΞΌ x * conditionalSecond ΞΌ x y := by + by_cases hx : firstMarginal ΞΌ x = 0 + Β· have hxy : ΞΌ (x, y) = 0 := by + have hle : ΞΌ (x, y) ≀ firstMarginal ΞΌ x := by + rw [firstMarginal] + exact Finset.single_le_sum (fun z _ ↦ hΞΌ (x, z)) (Finset.mem_univ y) + exact le_antisymm (hle.trans_eq hx) (hΞΌ (x, y)) + simp [conditionalSecond, hx, hxy] + Β· rw [conditionalSecond] + field_simp + +theorem sum_conditionalSecond + {Ξ± Ξ² : Type*} [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} {x : Ξ±} (hx : firstMarginal ΞΌ x β‰  0) : + βˆ‘ y, conditionalSecond ΞΌ x y = 1 := by + change (βˆ‘ y, ΞΌ (x, y) / firstMarginal ΞΌ x) = 1 + rw [← Finset.sum_div] + change firstMarginal ΞΌ x / firstMarginal ΞΌ x = 1 + exact div_self hx + +theorem weighted_conditionalSecond_sum + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : βˆ€ z, 0 ≀ ΞΌ z) (y : Ξ²) : + βˆ‘ x, firstMarginal ΞΌ x * conditionalSecond ΞΌ x y = + secondMarginal ΞΌ y := by + simp_rw [← joint_eq_firstMarginal_mul_conditionalSecond hΞΌ] + rfl + +theorem conditionalSecond_nonnegative + {Ξ± Ξ² : Type*} [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : βˆ€ z, 0 ≀ ΞΌ z) (x : Ξ±) (y : Ξ²) : + 0 ≀ conditionalSecond ΞΌ x y := by + exact div_nonneg (hΞΌ (x, y)) + (Finset.sum_nonneg fun z _ ↦ hΞΌ (x, z)) + +/-- Chain-rule decomposition of the entropy of a finite pair. The +conditional term is written with the zero-fiber convention used by +`conditionalSecond`. -/ +theorem jointEntropy_eq_first_add_conditional + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + shannonEntropy ΞΌ = + shannonEntropy (firstMarginal ΞΌ) + + βˆ‘ x, firstMarginal ΞΌ x * shannonEntropy (conditionalSecond ΞΌ x) := by + rw [shannonEntropy, Fintype.sum_prod_type] + calc + (βˆ‘ x, βˆ‘ y, Real.negMulLog (ΞΌ (x, y))) = + βˆ‘ x, (Real.negMulLog (firstMarginal ΞΌ x) + + firstMarginal ΞΌ x * shannonEntropy (conditionalSecond ΞΌ x)) := by + apply Finset.sum_congr rfl + intro x _ + have hfactor : βˆ€ y, ΞΌ (x, y) = + firstMarginal ΞΌ x * conditionalSecond ΞΌ x y := + joint_eq_firstMarginal_mul_conditionalSecond hΞΌ.nonnegative x + calc + (βˆ‘ y, Real.negMulLog (ΞΌ (x, y))) = + βˆ‘ y, Real.negMulLog + (firstMarginal ΞΌ x * conditionalSecond ΞΌ x y) := by + apply Finset.sum_congr rfl + intro y _ + rw [hfactor y] + _ = βˆ‘ y, (conditionalSecond ΞΌ x y * + Real.negMulLog (firstMarginal ΞΌ x) + + firstMarginal ΞΌ x * Real.negMulLog (conditionalSecond ΞΌ x y)) := by + apply Finset.sum_congr rfl + intro y _ + exact Real.negMulLog_mul _ _ + _ = (βˆ‘ y, conditionalSecond ΞΌ x y) * + Real.negMulLog (firstMarginal ΞΌ x) + + firstMarginal ΞΌ x * + βˆ‘ y, Real.negMulLog (conditionalSecond ΞΌ x y) := by + rw [Finset.sum_add_distrib, ← Finset.sum_mul, ← Finset.mul_sum] + _ = Real.negMulLog (firstMarginal ΞΌ x) + + firstMarginal ΞΌ x * shannonEntropy (conditionalSecond ΞΌ x) := by + by_cases hx : firstMarginal ΞΌ x = 0 + Β· simp [hx, shannonEntropy] + Β· rw [sum_conditionalSecond hx, one_mul, shannonEntropy] + _ = shannonEntropy (firstMarginal ΞΌ) + + βˆ‘ x, firstMarginal ΞΌ x * shannonEntropy (conditionalSecond ΞΌ x) := by + rw [Finset.sum_add_distrib, shannonEntropy] + +/-- Concavity of `-x log x` bounds the averaged conditional entropy by the +entropy of the second marginal. -/ +theorem conditionalEntropy_le_secondMarginalEntropy + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + (βˆ‘ x, firstMarginal ΞΌ x * shannonEntropy (conditionalSecond ΞΌ x)) ≀ + shannonEntropy (secondMarginal ΞΌ) := by + simp_rw [shannonEntropy, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_le_sum + intro y _ + have hfirst := firstMarginal_isProbabilityVector hΞΌ + have hJ := Real.concaveOn_negMulLog.le_map_sum + (t := Finset.univ) (w := firstMarginal ΞΌ) + (p := fun x ↦ conditionalSecond ΞΌ x y) + (fun x _ ↦ hfirst.nonnegative x) hfirst.sum_eq_one + (fun x _ ↦ conditionalSecond_nonnegative hΞΌ.nonnegative x y) + simpa only [smul_eq_mul, weighted_conditionalSecond_sum hΞΌ.nonnegative y] using hJ + +/-- Subadditivity of Shannon entropy for a finite pair. -/ +theorem jointEntropy_le_sum_marginals + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + {ΞΌ : Ξ± Γ— Ξ² β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + shannonEntropy ΞΌ ≀ + shannonEntropy (firstMarginal ΞΌ) + + shannonEntropy (secondMarginal ΞΌ) := by + rw [jointEntropy_eq_first_add_conditional hΞΌ] + linarith [conditionalEntropy_le_secondMarginalEntropy hΞΌ] + +/-- Subadditivity for a finite vector, in exactly the form used to pass from +the entropy of the paper's joint core encoding to the sum of its rowwise +entropies. -/ +theorem functionEntropy_le_sum_coordinateEntropies + {Ξ² : Type*} [Fintype Ξ²] [DecidableEq Ξ²] : + βˆ€ {n : β„•} {ΞΌ : (Fin n β†’ Ξ²) β†’ ℝ}, IsProbabilityVector ΞΌ β†’ + shannonEntropy ΞΌ ≀ + βˆ‘ i, shannonEntropy (pushforwardMass ΞΌ fun y ↦ y i) := by + intro n + induction n with + | zero => + intro ΞΌ hΞΌ + have hupper := shannonEntropy_le_log_card hΞΌ + simpa using hupper + | succ n ih => + intro ΞΌ hΞΌ + let e : (Fin (n + 1) β†’ Ξ²) ≃ Ξ² Γ— (Fin n β†’ Ξ²) := + (Fin.consEquiv (fun _ : Fin (n + 1) ↦ Ξ²)).symm + let ΞΌ' : (Ξ² Γ— (Fin n β†’ Ξ²)) β†’ ℝ := pushforwardMass ΞΌ e + have hΞΌ' : IsProbabilityVector ΞΌ' := + pushforwardMass_isProbabilityVector ΞΌ hΞΌ e + have hpair := jointEntropy_le_sum_marginals hΞΌ' + have htailProb : IsProbabilityVector (secondMarginal ΞΌ') := + secondMarginal_isProbabilityVector hΞΌ' + have htail := ih htailProb + have hhead : firstMarginal ΞΌ' = + pushforwardMass ΞΌ (fun y ↦ y 0) := by + rw [firstMarginal_eq_pushforward_fst] + funext y + rw [pushforwardMass_comp] + congr 1 + have htailDist : secondMarginal ΞΌ' = + pushforwardMass ΞΌ (fun y ↦ Fin.tail y) := by + rw [secondMarginal_eq_pushforward_snd] + funext y + rw [pushforwardMass_comp] + congr 1 + have hcoord (i : Fin n) : + pushforwardMass (secondMarginal ΞΌ') (fun y ↦ y i) = + pushforwardMass ΞΌ (fun y ↦ y i.succ) := by + rw [htailDist] + funext y + rw [pushforwardMass_comp] + congr 1 + calc + shannonEntropy ΞΌ = shannonEntropy ΞΌ' := by + exact (shannonEntropy_pushforward_equiv ΞΌ e).symm + _ ≀ shannonEntropy (firstMarginal ΞΌ') + + shannonEntropy (secondMarginal ΞΌ') := hpair + _ ≀ shannonEntropy (pushforwardMass ΞΌ fun y ↦ y 0) + + βˆ‘ i, shannonEntropy + (pushforwardMass (secondMarginal ΞΌ') fun y ↦ y i) := by + rw [hhead] + linarith + _ = βˆ‘ i, shannonEntropy (pushforwardMass ΞΌ fun y ↦ y i) := by + simp_rw [hcoord] + rw [Fin.sum_univ_succ] + +theorem entropy_on_finset_of_mass_le + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (s : Finset Ξ±) (hs : s.Nonempty) {ΞΌ : Ξ± β†’ ℝ} {ρ : ℝ} + (hΞΌ : βˆ€ x, 0 ≀ ΞΌ x) (hρ : 0 < ρ) + (hsum : βˆ‘ x ∈ s, ΞΌ x = ρ) : + (βˆ‘ x ∈ s, Real.negMulLog (ΞΌ x)) ≀ + ρ * Real.log ((s.card : ℝ) / ρ) := by + let q : s β†’ ℝ := fun x ↦ ΞΌ x + letI : Nonempty s := ⟨⟨hs.choose, hs.choose_spec⟩⟩ + have hqsum : βˆ‘ x, q x = ρ := by + calc + βˆ‘ x, q x = βˆ‘ x ∈ s.attach, ΞΌ x := by rfl + _ = βˆ‘ x ∈ s, ΞΌ x := Finset.sum_attach s ΞΌ + _ = ρ := hsum + have hbound := shannonEntropy_of_mass_le + (Ξ± := q) (ρ := ρ) (fun x ↦ hΞΌ x) hρ hqsum + have hcard : Fintype.card s = s.card := Fintype.card_coe s + rw [shannonEntropy, hcard] at hbound + change (βˆ‘ x ∈ s.attach, Real.negMulLog (ΞΌ x)) ≀ _ at hbound + rw [← Finset.sum_attach s (fun x ↦ Real.negMulLog (ΞΌ x))] + exact hbound + +/-- Entropy within one fiber of a deterministic map is bounded by the fiber +mass times the logarithm of the maximum fiber size. -/ +theorem fiber_entropy_bound + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + [DecidableEq Ξ±] [DecidableEq Ξ²] + {ΞΌ : Ξ± β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) (f : Ξ± β†’ Ξ²) + (K : β„•) (hK : 1 ≀ K) + (hfiber : βˆ€ y, (Finset.univ.filter fun x ↦ f x = y).card ≀ K) + (y : Ξ²) : + (βˆ‘ x ∈ Finset.univ.filter (fun x ↦ f x = y), + Real.negMulLog (ΞΌ x)) ≀ + Real.negMulLog (pushforwardMass ΞΌ f y) + + pushforwardMass ΞΌ f y * Real.log K := by + let s := Finset.univ.filter fun x ↦ f x = y + change (βˆ‘ x ∈ s, Real.negMulLog (ΞΌ x)) ≀ _ + have hqnonneg := (pushforwardMass_isProbabilityVector ΞΌ hΞΌ f).nonnegative y + by_cases hqzero : pushforwardMass ΞΌ f y = 0 + Β· have hsumzero : βˆ‘ x ∈ s, ΞΌ x = 0 := by + rw [Finset.sum_filter] + simpa [s, pushforwardMass] using hqzero + have htermzero : βˆ€ x ∈ s, ΞΌ x = 0 := by + exact Finset.sum_eq_zero_iff_of_nonneg + (fun x _ ↦ hΞΌ.nonnegative x) |>.mp hsumzero + simp only [hqzero, Real.negMulLog_zero, zero_mul, add_zero] + exact (Finset.sum_eq_zero (fun x hx ↦ by + rw [htermzero x hx, Real.negMulLog_zero])).le + Β· have hqpos : 0 < pushforwardMass ΞΌ f y := + lt_of_le_of_ne hqnonneg (Ne.symm hqzero) + have hs : s.Nonempty := by + by_contra hempty + have hzero : βˆ‘ x ∈ s, ΞΌ x = 0 := by + rw [Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + have : pushforwardMass ΞΌ f y = 0 := by + rw [← hzero] + unfold pushforwardMass + rw [← Finset.sum_filter] + exact hqzero this + have hsum : βˆ‘ x ∈ s, ΞΌ x = pushforwardMass ΞΌ f y := by + rw [Finset.sum_filter] + simp [s, pushforwardMass] + have hscaled := entropy_on_finset_of_mass_le s hs + hΞΌ.nonnegative hqpos hsum + have hcardpos : (0 : ℝ) < s.card := by + exact_mod_cast hs.card_pos + have hKpos : (0 : ℝ) < K := by + exact_mod_cast (lt_of_lt_of_le Nat.zero_lt_one hK) + have hcardle : (s.card : ℝ) ≀ K := by exact_mod_cast hfiber y + have hlogle : Real.log (s.card : ℝ) ≀ Real.log K := + Real.log_le_log hcardpos hcardle + have hmul := mul_le_mul_of_nonneg_left hlogle hqpos.le + rw [Real.log_div hcardpos.ne' hqpos.ne'] at hscaled + simp only [Real.negMulLog_def] + have hrewrite : + pushforwardMass ΞΌ f y * + (Real.log (s.card : ℝ) - Real.log (pushforwardMass ΞΌ f y)) = + -pushforwardMass ΞΌ f y * Real.log (pushforwardMass ΞΌ f y) + + pushforwardMass ΞΌ f y * Real.log (s.card : ℝ) := by ring + rw [hrewrite] at hscaled + exact hscaled.trans (by + simpa [add_comm] using + add_le_add_left hmul + (-pushforwardMass ΞΌ f y * Real.log (pushforwardMass ΞΌ f y))) + +/-- Generic finite-fiber encoding inequality. This is the entropy-theoretic +part of paper Lemma 9, independent of the cycle combinatorics used to bound +the fibers. -/ +theorem entropy_le_pushforward_add_log_fiberBound + {Ξ± Ξ² : Type*} [Fintype Ξ±] [Fintype Ξ²] + [DecidableEq Ξ±] [DecidableEq Ξ²] + {ΞΌ : Ξ± β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) (f : Ξ± β†’ Ξ²) + (K : β„•) (hK : 1 ≀ K) + (hfiber : βˆ€ y, (Finset.univ.filter fun x ↦ f x = y).card ≀ K) : + shannonEntropy ΞΌ ≀ + shannonEntropy (pushforwardMass ΞΌ f) + Real.log K := by + have hpoint := fun y ↦ fiber_entropy_bound hΞΌ f K hK hfiber y + have hsum : + (βˆ‘ y, βˆ‘ x ∈ Finset.univ.filter (fun x ↦ f x = y), + Real.negMulLog (ΞΌ x)) ≀ + βˆ‘ y, (Real.negMulLog (pushforwardMass ΞΌ f y) + + pushforwardMass ΞΌ f y * Real.log K) := by + exact Finset.sum_le_sum (fun y _ ↦ hpoint y) + have hpartition : shannonEntropy ΞΌ = + βˆ‘ y, βˆ‘ x ∈ Finset.univ.filter (fun x ↦ f x = y), + Real.negMulLog (ΞΌ x) := by + rw [shannonEntropy] + calc + (βˆ‘ x, Real.negMulLog (ΞΌ x)) = + βˆ‘ x, βˆ‘ y, if f x = y then Real.negMulLog (ΞΌ x) else 0 := by + apply Finset.sum_congr rfl + intro x _ + simp + _ = βˆ‘ y, βˆ‘ x, if f x = y then Real.negMulLog (ΞΌ x) else 0 := + Finset.sum_comm + _ = βˆ‘ y, βˆ‘ x ∈ Finset.univ.filter (fun x ↦ f x = y), + Real.negMulLog (ΞΌ x) := by + apply Finset.sum_congr rfl + intro y _ + rw [Finset.sum_filter] + have hright : + (βˆ‘ y, (Real.negMulLog (pushforwardMass ΞΌ f y) + + pushforwardMass ΞΌ f y * Real.log K)) = + shannonEntropy (pushforwardMass ΞΌ f) + Real.log K := by + rw [Finset.sum_add_distrib, shannonEntropy, ← Finset.sum_mul, + (pushforwardMass_isProbabilityVector ΞΌ hΞΌ f).sum_eq_one, one_mul] + rw [hpartition, ← hright] + exact hsum + +/-- Kullback--Leibler divergence on a finite type. -/ +noncomputable def finiteKL + {ΞΉ : Type*} [Fintype ΞΉ] (p q : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i, p i * Real.log (p i / q i) + +theorem finiteKL_nonneg + {ΞΉ : Type*} [Fintype ΞΉ] + {p q : ΞΉ β†’ ℝ} + (hp : IsProbabilityVector p) (hq : IsProbabilityVector q) + (hppos : βˆ€ i, 0 < p i) (hqpos : βˆ€ i, 0 < q i) : + 0 ≀ finiteKL p q := by + have hterm : βˆ€ i, + p i * Real.log (q i / p i) ≀ q i - p i := by + intro i + have hratio : 0 < q i / p i := div_pos (hqpos i) (hppos i) + have hlog := Real.log_le_sub_one_of_pos hratio + have hmul := mul_le_mul_of_nonneg_left hlog (hp.nonnegative i) + have hsimplify : p i * (q i / p i - 1) = q i - p i := by + field_simp [(hppos i).ne'] + rw [hsimplify] at hmul + exact hmul + have hsum : (βˆ‘ i, p i * Real.log (q i / p i)) ≀ + βˆ‘ i, (q i - p i) := + Finset.sum_le_sum fun i _ ↦ hterm i + rw [Finset.sum_sub_distrib, hq.sum_eq_one, hp.sum_eq_one, sub_self] at hsum + have hrewrite : finiteKL p q = -βˆ‘ i, p i * Real.log (q i / p i) := by + rw [finiteKL, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [Real.log_div (hppos i).ne' (hqpos i).ne', + Real.log_div (hqpos i).ne' (hppos i).ne'] + ring + rw [hrewrite] + linarith + +theorem finiteKL_eq_neg_entropy_sub + {ΞΉ : Type*} [Fintype ΞΉ] + {p q : ΞΉ β†’ ℝ} (hppos : βˆ€ i, 0 < p i) (hqpos : βˆ€ i, 0 < q i) : + finiteKL p q = + -shannonEntropy p - βˆ‘ i, p i * Real.log (q i) := by + rw [finiteKL, shannonEntropy, ← Finset.sum_neg_distrib, + ← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [Real.negMulLog_def, + Real.log_div (hppos i).ne' (hqpos i).ne'] + ring + +/-- Uniform average of a real-valued function on a finite type. -/ +noncomputable def uniformAverage + {ΞΉ : Type*} [Fintype ΞΉ] (f : ΞΉ β†’ ℝ) : ℝ := + (βˆ‘ i, f i) / Fintype.card ΞΉ + +/-- Suffix mass seen by coordinate `j` in the ordering `Ο€`. An ordering is a +permutation whose value at a position is the coordinate occupying it. -/ +noncomputable def suffixMass {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) (j : Fin m) : ℝ := + βˆ‘ k, if Ο€.symm j ≀ Ο€.symm k then p k else 0 + +theorem le_suffixMass {m : β„•} {p : Fin m β†’ ℝ} + (hp : IsProbabilityVector p) (Ο€ : Equiv.Perm (Fin m)) (j : Fin m) : + p j ≀ suffixMass p Ο€ j := by + rw [suffixMass] + have hterm : + p j = if Ο€.symm j ≀ Ο€.symm j then p j else 0 := by simp + rw [hterm] + exact Finset.single_le_sum + (f := fun k ↦ if Ο€.symm j ≀ Ο€.symm k then p k else 0) + (fun k _ ↦ by + by_cases h : Ο€.symm j ≀ Ο€.symm k + Β· simpa [h] using hp.nonnegative k + Β· simp [h]) + (Finset.mem_univ j) + +theorem suffixMass_le_one {m : β„•} {p : Fin m β†’ ℝ} + (hp : IsProbabilityVector p) (Ο€ : Equiv.Perm (Fin m)) (j : Fin m) : + suffixMass p Ο€ j ≀ 1 := by + rw [suffixMass, ← hp.sum_eq_one] + apply Finset.sum_le_sum + intro k _ + split_ifs + Β· rfl + Β· exact hp.nonnegative k + +theorem suffixMass_pos {m : β„•} {p : Fin m β†’ ℝ} + (hp : IsProbabilityVector p) {j : Fin m} (hj : 0 < p j) + (Ο€ : Equiv.Perm (Fin m)) : + 0 < suffixMass p Ο€ j := + hj.trans_le (le_suffixMass hp Ο€ j) + +/-- The averaged suffix score `T(p)` from paper (13). -/ +noncomputable def rowT {m : β„•} (p : Fin m β†’ ℝ) : ℝ := + uniformAverage fun Ο€ : Equiv.Perm (Fin m) ↦ + βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) + +/-- The one-row correction `g(p)` from paper (14). -/ +noncomputable def rowCorrection {m : β„•} (p : Fin m β†’ ℝ) : ℝ := + rowT p - βˆ‘ j, (1 - p j) * Real.log (1 - p j) + +/-- Deficit from the sharp one-row inequality, paper (15). -/ +noncomputable def rowDeficit {m : β„•} (p : Fin m β†’ ℝ) : ℝ := + Real.log 2 / 2 - rowCorrection p + +/-- Exact source-level interface for the sharp one-row theorem of +Anari--Rezaei. It is a proposition passed as an argument, not a Lean axiom. -/ +def AnariRezaeiRowInequality : Prop := + βˆ€ {m : β„•}, 2 ≀ m β†’ βˆ€ p : Fin m β†’ ℝ, + IsProbabilityVector p β†’ 0 ≀ rowDeficit p + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExcursionTransfer.lean b/LeanPool/BeyondBethe/BeyondBethe/ExcursionTransfer.lean new file mode 100644 index 0000000000..01ed39a8fb --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExcursionTransfer.lean @@ -0,0 +1,382 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import Mathlib.Analysis.SpecialFunctions.BinaryEntropy +public import Mathlib.Tactic + +/-! # Excursion Transfer -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Mass of a vector on a designated set of outside coordinates. -/ +noncomputable def massOn + {ΞΉ : Type*} (s : Finset ΞΉ) (p : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i ∈ s, p i + +/-- The conditional-entropy term `rho H(p/rho)` written without division, +with its continuous value at `rho = 0`. -/ +noncomputable def scaledConditionalEntropyOn + {ΞΉ : Type*} (s : Finset ΞΉ) (p : ΞΉ β†’ ℝ) : ℝ := + (βˆ‘ i ∈ s, Real.negMulLog (p i)) + + massOn s p * Real.log (massOn s p) + +/-- Transfer cost accumulated on a designated coordinate set. -/ +noncomputable def transferCostOn + {ΞΉ : Type*} (s : Finset ΞΉ) (p u : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i ∈ s, p i * Real.log (1 / u i) + +theorem massOn_pos_of_nonempty + {ΞΉ : Type*} {s : Finset ΞΉ} {p : ΞΉ β†’ ℝ} + (hs : s.Nonempty) (hp : βˆ€ i, 0 < p i) : + 0 < massOn s p := by + rw [massOn] + exact Finset.sum_pos (fun i _ ↦ hp i) hs + +/-- Exact entropy/KL decomposition behind paper (40). -/ +theorem transferCostOn_eq_entropy_add_KL + {ΞΉ : Type*} [DecidableEq ΞΉ] + {s : Finset ΞΉ} (hs : s.Nonempty) + {p u : ΞΉ β†’ ℝ} (hp : βˆ€ i, 0 < p i) (hu : βˆ€ i, 0 < u i) : + let ρ := massOn s p + let W := massOn s u + let pO : s β†’ ℝ := fun i ↦ p i / ρ + let uO : s β†’ ℝ := fun i ↦ u i / W + transferCostOn s p u = + scaledConditionalEntropyOn s p + ρ * finiteKL pO uO - ρ * Real.log W := by + dsimp only + have hρ : 0 < massOn s p := massOn_pos_of_nonempty hs hp + have hW : 0 < massOn s u := massOn_pos_of_nonempty hs hu + rw [transferCostOn, scaledConditionalEntropyOn, finiteKL, + Finset.mul_sum] + have hsub : + (βˆ‘ i : s, massOn s p * + ((p i / massOn s p) * + Real.log ((p i / massOn s p) / (u i / massOn s u)))) = + βˆ‘ i ∈ s, massOn s p * + ((p i / massOn s p) * + Real.log ((p i / massOn s p) / (u i / massOn s u))) := + by + simpa using Finset.sum_coe_sort s (fun i ↦ massOn s p * + ((p i / massOn s p) * + Real.log ((p i / massOn s p) / (u i / massOn s u)))) + rw [hsub] + have hρlog : massOn s p * Real.log (massOn s p) = + βˆ‘ i ∈ s, p i * Real.log (massOn s p) := by + rw [massOn, Finset.sum_mul] + have hWlog : massOn s p * Real.log (massOn s u) = + βˆ‘ i ∈ s, p i * Real.log (massOn s u) := by + rw [massOn, Finset.sum_mul] + rw [hρlog, hWlog, ← Finset.sum_add_distrib, + ← Finset.sum_add_distrib, ← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro i hi + have hpρ : p i / massOn s p β‰  0 := (div_pos (hp i) hρ).ne' + have huW : u i / massOn s u β‰  0 := (div_pos (hu i) hW).ne' + rw [Real.negMulLog_def, + Real.log_div one_ne_zero (hu i).ne', Real.log_one, + Real.log_div hpρ huW, + Real.log_div (hp i).ne' hρ.ne', + Real.log_div (hu i).ne' hW.ne'] + field_simp [hρ.ne', hW.ne', (hp i).ne', (hu i).ne'] + ring + +theorem normalizedOutside_isProbabilityVector + {ΞΉ : Type*} [DecidableEq ΞΉ] + {s : Finset ΞΉ} (hs : s.Nonempty) + {p : ΞΉ β†’ ℝ} (hp : βˆ€ i, 0 < p i) : + IsProbabilityVector (fun i : s ↦ p i / massOn s p) := by + have hρ : 0 < massOn s p := massOn_pos_of_nonempty hs hp + constructor + Β· intro i + exact div_nonneg (hp i).le hρ.le + Β· calc + (βˆ‘ i : s, p i / massOn s p) = + βˆ‘ i ∈ s, p i / massOn s p := by + simpa using Finset.sum_coe_sort s + (fun i ↦ p i / massOn s p) + _ = 1 := by + rw [← Finset.sum_div] + exact div_self (by simpa only [massOn] using hρ.ne') + +/-- Paper tail-transfer inequality (41), before substituting the entropy of +the coarsened row. The theorem includes the empty-set/zero-mass case. -/ +theorem scaledConditionalEntropyOn_sub_mass_le_transferCostOn + {ΞΉ : Type*} [DecidableEq ΞΉ] + (s : Finset ΞΉ) {p u : ΞΉ β†’ ℝ} + (hp : βˆ€ i, 0 < p i) (hu : βˆ€ i, 0 < u i) + (hUsum : massOn s u ≀ Real.exp 1) : + scaledConditionalEntropyOn s p - massOn s p ≀ + transferCostOn s p u := by + by_cases hs : s.Nonempty + Β· have hρ : 0 < massOn s p := massOn_pos_of_nonempty hs hp + have hW : 0 < massOn s u := massOn_pos_of_nonempty hs hu + let pO : s β†’ ℝ := fun i ↦ p i / massOn s p + let uO : s β†’ ℝ := fun i ↦ u i / massOn s u + have hpO : IsProbabilityVector pO := + normalizedOutside_isProbabilityVector hs hp + have huO : IsProbabilityVector uO := + normalizedOutside_isProbabilityVector hs hu + have hpOpos : βˆ€ i, 0 < pO i := fun i ↦ div_pos (hp i) hρ + have huOpos : βˆ€ i, 0 < uO i := fun i ↦ div_pos (hu i) hW + have hKL : 0 ≀ finiteKL pO uO := + finiteKL_nonneg hpO huO hpOpos huOpos + have hlogW : Real.log (massOn s u) ≀ 1 := by + have hlog := Real.log_le_log hW hUsum + simpa using hlog + rw [transferCostOn_eq_entropy_add_KL hs hp hu] + dsimp only [pO, uO] at hKL + nlinarith [mul_nonneg hρ.le hKL, + mul_le_mul_of_nonneg_left hlogW hρ.le] + Β· rw [Finset.not_nonempty_iff_eq_empty.mp hs] + simp [scaledConditionalEntropyOn, massOn, transferCostOn] + +/-- Entropy of the coarsening which merges the complement of a core set into +one atom, expressed as binary entropy plus conditional outside entropy. -/ +noncomputable def coarsenedRowEntropy + {ΞΉ : Type*} (outside : Finset ΞΉ) (p : ΞΉ β†’ ℝ) : ℝ := + binaryEntropy (massOn outside p) + scaledConditionalEntropyOn outside p + +theorem coarsenedRowEntropy_sub_binary_sub_mass_le_transferCostOn + {ΞΉ : Type*} [DecidableEq ΞΉ] + (outside : Finset ΞΉ) {p u : ΞΉ β†’ ℝ} + (hp : βˆ€ i, 0 < p i) (hu : βˆ€ i, 0 < u i) + (hUsum : massOn outside u ≀ Real.exp 1) : + coarsenedRowEntropy outside p - binaryEntropy (massOn outside p) - + massOn outside p ≀ transferCostOn outside p u := by + rw [coarsenedRowEntropy] + convert scaledConditionalEntropyOn_sub_mass_le_transferCostOn outside hp hu hUsum using 1 <;> + ring + +theorem binaryEntropy_eq_binEntropy (ρ : ℝ) : + binaryEntropy ρ = Real.binEntropy ρ := by + rw [binaryEntropy, Real.binEntropy_eq_negMulLog_add_negMulLog_one_sub] + +/-- The total rowwise transfer cost over all matrix coordinates. -/ +noncomputable def matrixTransferCost + {ΞΉ : Type*} [Fintype ΞΉ] + (P U : Matrix ΞΉ ΞΉ ℝ) : ℝ := + βˆ‘ i, transferCostOn Finset.univ (P i) (U i) + +/-- The total transfer cost over the designated outside coordinates in each row. -/ +noncomputable def outsideTransferCost + {ΞΉ : Type*} [Fintype ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) (P U : Matrix ΞΉ ΞΉ ℝ) : ℝ := + βˆ‘ i, transferCostOn (outside i) (P i) (U i) + +/-- The total transfer cost over the complements of the designated outside coordinates. -/ +noncomputable def coreTransferCost + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) (P U : Matrix ΞΉ ΞΉ ℝ) : ℝ := + βˆ‘ i, transferCostOn (Finset.univ \ outside i) (P i) (U i) + +/-- Equation (39) from the global transfer upper bound and the cycle-encoding +entropy estimate. This is the exact bridge between paper Lemmas 13, 16, and +17. -/ +theorem transfer_before_tail_of_global_and_encoding + {n : β„•} {P U : Matrix (Fin n) (Fin n) ℝ} + (outside : Fin n β†’ Finset (Fin n)) + {slack ΞΎ gibbsEntropy : ℝ} + (hglobal : matrixTransferCost P U ≀ + slack + 2 * ΞΎ * n + gibbsEntropy - n * (Real.log 2 / 2)) + (hencoding : gibbsEntropy ≀ + n * (Real.log 2 / 2) + + βˆ‘ i, coarsenedRowEntropy (outside i) (P i)) : + matrixTransferCost P U ≀ + slack + 2 * ΞΎ * n + + βˆ‘ i, coarsenedRowEntropy (outside i) (P i) := by + linarith + +theorem matrixTransferCost_eq_core_add_outside + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) (P U : Matrix ΞΉ ΞΉ ℝ) : + matrixTransferCost P U = + coreTransferCost outside P U + outsideTransferCost outside P U := by + rw [matrixTransferCost, coreTransferCost, outsideTransferCost, + ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [transferCostOn, transferCostOn, transferCostOn] + exact (Finset.sum_sdiff (Finset.subset_univ (outside i))).symm + +theorem massOn_le_sum_univ + {ΞΉ : Type*} [Fintype ΞΉ] + (s : Finset ΞΉ) {u : ΞΉ β†’ ℝ} (hu : βˆ€ i, 0 ≀ u i) : + massOn s u ≀ βˆ‘ i, u i := by + rw [massOn] + exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + (fun i _ _ ↦ hu i) + +/-- Paper Lemma 17, first inequality, in its graph-independent form. The +encoding supplies `coarsenedRowEntropy`; this theorem performs the complete +excursion-entropy cancellation. -/ +theorem coreTransferCost_le_of_entropy_bound + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) {P U : Matrix ΞΉ ΞΉ ℝ} {B : ℝ} + (hPpos : βˆ€ i j, 0 < P i j) (hUpos : βˆ€ i j, 0 < U i j) + (hUrow : βˆ€ i, βˆ‘ j, U i j ≀ Real.exp 1) + (hbefore : matrixTransferCost P U ≀ + B + βˆ‘ i, coarsenedRowEntropy (outside i) (P i)) : + coreTransferCost outside P U ≀ + B + βˆ‘ i, (binaryEntropy (massOn (outside i) (P i)) + + massOn (outside i) (P i)) := by + have htailRow : βˆ€ i, + coarsenedRowEntropy (outside i) (P i) - + (binaryEntropy (massOn (outside i) (P i)) + + massOn (outside i) (P i)) ≀ + transferCostOn (outside i) (P i) (U i) := by + intro i + have hUsum : massOn (outside i) (U i) ≀ Real.exp 1 := + (massOn_le_sum_univ (outside i) (fun j ↦ (hUpos i j).le)).trans + (hUrow i) + have htail := coarsenedRowEntropy_sub_binary_sub_mass_le_transferCostOn + (outside i) (hPpos i) (hUpos i) hUsum + linarith + have htailSum : + (βˆ‘ i, (coarsenedRowEntropy (outside i) (P i) - + (binaryEntropy (massOn (outside i) (P i)) + + massOn (outside i) (P i)))) ≀ + outsideTransferCost outside P U := by + rw [outsideTransferCost] + exact Finset.sum_le_sum (fun i _ ↦ htailRow i) + have hpartition := matrixTransferCost_eq_core_add_outside outside P U + simp only [Finset.sum_sub_distrib] at htailSum + linarith + +/-- The graph-independent cancellation specialized to the transfer matrix +`U` from paper (37). Thus the only remaining input from the cycle encoding +is the entropy bound `hbefore`. -/ +theorem coreTransferCost_le_for_transferU + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) {P X : Matrix ΞΉ ΞΉ ℝ} {Ο„ B : ℝ} + (hΟ„ : 0 ≀ Ο„) (hPpos : βˆ€ i j, 0 < P i j) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hbefore : matrixTransferCost P (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + βˆ‘ i, coarsenedRowEntropy (outside i) (P i)) : + coreTransferCost outside P (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + βˆ‘ i, (binaryEntropy (massOn (outside i) (P i)) + + massOn (outside i) (P i)) := by + apply coreTransferCost_le_of_entropy_bound outside hPpos + (fun i j ↦ transferU_pos (hXint i) j) + (fun i ↦ sum_transferU_le_exp_one hΟ„ (hXint i)) hbefore + +theorem binaryEntropy_nonneg_of_mem_Icc + {ρ : ℝ} (hρ : ρ ∈ Set.Icc (0 : ℝ) 1) : + 0 ≀ binaryEntropy ρ := by + rw [binaryEntropy_eq_binEntropy] + exact Real.binEntropy_nonneg hρ.1 hρ.2 + +theorem binaryEntropy_mono_to_half + {ρ Ξ· : ℝ} (hρ : ρ ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) + (hΞ· : Ξ· ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) (hρη : ρ ≀ Ξ·) : + binaryEntropy ρ ≀ binaryEntropy Ξ· := by + rw [binaryEntropy_eq_binEntropy, binaryEntropy_eq_binEntropy] + exact Real.binEntropy_strictMonoOn.monotoneOn hρ hΞ· hρη + +/-- The good-row/bad-row aggregation in the second conclusion of paper +Lemma 17. We deliberately retain the paper's slightly loose bad-row term: +every row receives the good-row allowance, and each bad row receives an +additional `1 + log 2`. -/ +theorem sum_binaryEntropy_add_mass_le_good_bad + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (good : Finset ΞΉ) (ρ : ΞΉ β†’ ℝ) {Ξ· : ℝ} + (hΞ· : Ξ· ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) + (hρ : βˆ€ i, ρ i ∈ Set.Icc (0 : ℝ) 1) + (hgood : βˆ€ i ∈ good, ρ i ≀ Ξ·) : + βˆ‘ i, (binaryEntropy (ρ i) + ρ i) ≀ + (Fintype.card ΞΉ : ℝ) * (binaryEntropy Ξ· + Ξ·) + + (1 + Real.log 2) * (Finset.card (Finset.univ \ good) : ℝ) := by + have hΞ·one : Ξ· ∈ Set.Icc (0 : ℝ) 1 := by + constructor + Β· exact hΞ·.1 + Β· exact hΞ·.2.trans (by norm_num) + have hbase : 0 ≀ binaryEntropy Ξ· + Ξ· := + add_nonneg (binaryEntropy_nonneg_of_mem_Icc hΞ·one) hΞ·.1 + have hgoodSum : + (βˆ‘ i ∈ good, (binaryEntropy (ρ i) + ρ i)) ≀ + (Finset.card good : ℝ) * (binaryEntropy Ξ· + Ξ·) := by + calc + (βˆ‘ i ∈ good, (binaryEntropy (ρ i) + ρ i)) ≀ + βˆ‘ _i ∈ good, (binaryEntropy Ξ· + Ξ·) := by + apply Finset.sum_le_sum + intro i hi + have hρhalf : ρ i ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹ := + ⟨(hρ i).1, (hgood i hi).trans hΞ·.2⟩ + exact add_le_add + (binaryEntropy_mono_to_half hρhalf hΞ· (hgood i hi)) + (hgood i hi) + _ = (Finset.card good : ℝ) * (binaryEntropy Ξ· + Ξ·) := by + simp + ring + have hbadSum : + (βˆ‘ i ∈ (Finset.univ \ good), + (binaryEntropy (ρ i) + ρ i)) ≀ + (Finset.card (Finset.univ \ good) : ℝ) * + (Real.log 2 + 1) := by + calc + (βˆ‘ i ∈ (Finset.univ \ good), + (binaryEntropy (ρ i) + ρ i)) ≀ + βˆ‘ _i ∈ (Finset.univ \ good), (Real.log 2 + 1) := by + apply Finset.sum_le_sum + intro i _ + rw [binaryEntropy_eq_binEntropy] + exact add_le_add Real.binEntropy_le_log_two (hρ i).2 + _ = (Finset.card (Finset.univ \ good) : ℝ) * + (Real.log 2 + 1) := by + simp + ring + have hgoodCard : (Finset.card good : ℝ) ≀ Fintype.card ΞΉ := by + exact_mod_cast Finset.card_le_card (Finset.subset_univ good) + have hgoodBound : + (Finset.card good : ℝ) * (binaryEntropy Ξ· + Ξ·) ≀ + (Fintype.card ΞΉ : ℝ) * (binaryEntropy Ξ· + Ξ·) := + mul_le_mul_of_nonneg_right hgoodCard hbase + rw [← Finset.sum_sdiff (Finset.subset_univ good)] + linarith + +/-- Both conclusions of paper Lemma 17, specialized to the paper's transfer +matrix and normalized by the number of rows. The cycle encoding appears only +through `hbefore`, and the good-row geometry only through `hgood`. -/ +theorem coreTransferCost_normalized_le_for_transferU + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + (outside : ΞΉ β†’ Finset ΞΉ) (good : Finset ΞΉ) + {P X : Matrix ΞΉ ΞΉ ℝ} {Ο„ B Ξ· : ℝ} + (hΟ„ : 0 ≀ Ο„) (hPpos : βˆ€ i j, 0 < P i j) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hbefore : matrixTransferCost P (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + βˆ‘ i, coarsenedRowEntropy (outside i) (P i)) + (hΞ· : Ξ· ∈ Set.Icc (0 : ℝ) (2 : ℝ)⁻¹) + (hρ : βˆ€ i, massOn (outside i) (P i) ∈ Set.Icc (0 : ℝ) 1) + (hgood : βˆ€ i ∈ good, massOn (outside i) (P i) ≀ Ξ·) : + coreTransferCost outside P (fun i j ↦ transferU Ο„ (X i) j) / + (Fintype.card ΞΉ : ℝ) ≀ + B / (Fintype.card ΞΉ : ℝ) + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Finset.card (Finset.univ \ good) : ℝ) / + (Fintype.card ΞΉ : ℝ) := by + have hcore := coreTransferCost_le_for_transferU outside hΟ„ hPpos hXint hbefore + have hsum := sum_binaryEntropy_add_mass_le_good_bad good + (fun i ↦ massOn (outside i) (P i)) hΞ· hρ hgood + have hn : 0 < (Fintype.card ΞΉ : ℝ) := by + exact_mod_cast Fintype.card_pos + apply (div_le_iffβ‚€ hn).2 + calc + coreTransferCost outside P (fun i j ↦ transferU Ο„ (X i) j) ≀ + B + (Fintype.card ΞΉ : ℝ) * (binaryEntropy Ξ· + Ξ·) + + (1 + Real.log 2) * (Finset.card (Finset.univ \ good) : ℝ) := by + linarith + _ = (B / (Fintype.card ΞΉ : ℝ) + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Finset.card (Finset.univ \ good) : ℝ) / + (Fintype.card ΞΉ : ℝ)) * (Fintype.card ΞΉ : ℝ) := by + field_simp [hn.ne'] + ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificate.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificate.lean new file mode 100644 index 0000000000..44ef9d11b2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificate.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import Mathlib.Tactic + +/-! # Executable Certificate -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The executable structural certificate + +The regularized optimizer is represented by a rational doubly stochastic +matrix. Pair eligibility is decided by directed rational logarithm bounds, +and a deterministic maximal row matching collects the accepted fixed gains. +This file proves the complete positive-matrix dichotomy for that concrete +certificate; no pair-capacity optimizer or maximum-weight matching remains. +-/ + +/-- The hard-coded rational regularization scale in dimension `n`. -/ +def explicitRegularizationScale (n : β„•) : β„š := + explicitXi / (4 * n) + +theorem cast_explicitRegularizationScale (n : β„•) : + ((explicitRegularizationScale n : β„š) : ℝ) = + (explicitXi : ℝ) / (4 * (n : ℝ)) := by + simp [explicitRegularizationScale] + +theorem explicitRegularizationScale_pos {n : β„•} (hn : 0 < n) : + 0 < explicitRegularizationScale n := by + rw [explicitRegularizationScale] + exact div_pos explicitXi_pos (by positivity) + +theorem explicitGamma_pos : 0 < explicitGamma := by + norm_num [explicitGamma] + +theorem explicitRegularizationScale_le_one {n : β„•} (hn : 1 ≀ n) : + explicitRegularizationScale n ≀ 1 := by + have hxi : explicitXi ≀ 1 := by + norm_num [explicitXi, explicitDelta, explicitEta, explicitRowRatio] + rw [explicitRegularizationScale, div_le_one (by positivity)] + have hdenNat : 1 ≀ 4 * n := by omega + have hden : (1 : β„š) ≀ 4 * n := by exact_mod_cast hdenNat + exact hxi.trans hden + +/-- The fixed-gain row-pair weights used by the algorithm. -/ +def explicitCertifiedRowWeight {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : RowPair n β†’ β„š := + certifiedConstantRowWeight (explicitRegularizationScale n) X + explicitKappa explicitGamma (directedPairCostPrecision n) + +/-- The rational gain collected by the deterministic greedy matching. -/ +def explicitCertifiedMatchingGain {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : β„š := + greedyCertifiedMatchingGain (explicitCertifiedRowWeight X) explicitGamma + +theorem explicitCertifiedMatchingGain_nonneg {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + 0 ≀ explicitCertifiedMatchingGain X := by + rw [explicitCertifiedMatchingGain, greedyCertifiedMatchingGain] + exact Finset.sum_nonneg fun q _ ↦ + certifiedConstantRowWeight_nonneg _ _ _ _ _ q explicitGamma_pos.le + +/-- The complete structural certificate for a rational exact KKT point. +The structural clean-cycle test uses `0.9 * explicitKappa`; the executable +directed test uses `explicitKappa`, and their gap absorbs all logarithm +rounding error. -/ +theorem explicitCertified_certificate_of_logKKT + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {n : β„•} (hn : 2 ≀ n) + {A : Matrix (Fin n) (Fin n) ℝ} + {Xq : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic (fun i j ↦ ((Xq i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((Xq i j : β„š) : ℝ))) + {R C : Fin n β†’ ℝ} + (hKKT : HasLogKKT (explicitRegularizationScale n : ℝ) A + (fun i j ↦ ((Xq i j : β„š) : ℝ)) R C) : + Real.exp (betheObjective A (fun i j ↦ ((Xq i j : β„š) : ℝ)) + + (explicitCertifiedMatchingGain Xq : ℝ)) ≀ + Matrix.permanent A ∧ + Real.log (Matrix.permanent A) - + (betheObjective A (fun i j ↦ ((Xq i j : β„š) : ℝ)) + + (explicitCertifiedMatchingGain Xq : ℝ)) ≀ + (Real.log 2 / 2 - + ((rationalEpsilonPlus explicitCertifiedCompletionScales : β„š) : ℝ)) * n := by + let X : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((Xq i j : β„š) : ℝ) + let Ο„q : β„š := explicitRegularizationScale n + let gain : ℝ := (explicitCertifiedMatchingGain Xq : ℝ) + let Ξ· : ℝ := (explicitEta : ℝ) + let Ξ΄ : ℝ := (explicitDelta : ℝ) + let ΞΎ : ℝ := (explicitXi : ℝ) + have hnpos : 0 < n := by omega + have hnreal : (1 : ℝ) ≀ n := by exact_mod_cast (show 1 ≀ n by omega) + have hlogn : Real.log n ≀ (n : ℝ) * Real.log 2 := + log_natCast_le_natCast_mul_log_two (show 1 ≀ n by omega) + have hΞΎ : 0 < ΞΎ := by + simpa only [ΞΎ] using! (show (0 : ℝ) < (explicitXi : ℝ) by + exact_mod_cast explicitXi_pos) + have hΟ„scale : (Ο„q : ℝ) = ΞΎ / (4 * (n : ℝ)) := by + exact cast_explicitRegularizationScale n + have hΟ„0q : 0 ≀ Ο„q := (explicitRegularizationScale_pos hnpos).le + have hΟ„1q : Ο„q ≀ 1 := + explicitRegularizationScale_le_one (show 1 ≀ n by omega) + have hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„q : ℝ) A Y ≀ + regularizedBetheObjective (Ο„q : ℝ) A X := by + exact regularizedBetheObjective_le_of_logKKT + (by simpa only [Fintype.card_fin] using! (show 1 < n by omega)) + (by exact_mod_cast hΟ„0q) hX hXint hKKT + have hobjective : + Real.log (bethePermanent A) - ΞΎ * n ≀ betheObjective A X := by + have hbudget := regularization_budget_of_paper_scale + (show (0 : ℝ) < n by positivity) hlogn hΞΎ hΟ„scale + have hvalue := betheLogValue_le_regularizedMaximizer + (show 1 < n by omega) (by exact_mod_cast hΟ„0q) hA hX hmax + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlogBethe : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + rw [hlogBethe] + linarith + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlogBethe : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + have hupper : Real.log (Matrix.permanent A) ≀ + Real.log (bethePermanent A) + n * (Real.log 2 / 2) := by + rw [hlogBethe] + exact log_permanent_le_betheLogValue_add_log_two_half hn A hA + let w : RowPair n β†’ β„š := explicitCertifiedRowWeight Xq + have hlower : βˆ€ q ∈ greedyThresholdRowMatching w explicitGamma, + (w q : ℝ) ≀ Real.log (pairGain A X + (rowPairRow q 0) (rowPairRow q 1)) := by + intro q hq + have hmaximal := greedyThresholdRowMatching_isMaximal w explicitGamma + have hthreshold : explicitGamma ≀ w q := by + have hmem := hmaximal.subset hq + simpa only [List.mem_toFinset, mem_thresholdRowPairsList_iff] using! hmem + have hw : w q = explicitGamma := by + exact certifiedConstantRowWeight_eq_gamma_of_threshold + Ο„q Xq explicitKappa explicitGamma (directedPairCostPrecision n) q + explicitGamma_pos hthreshold + have heligible : HasCertifiedCorePair Ο„q Xq explicitKappa + (directedPairCostPrecision n) q := by + exact (certifiedConstantRowWeight_eq_gamma_iff + Ο„q Xq explicitKappa explicitGamma (directedPairCostPrecision n) q + explicitGamma_pos.ne').1 hw + rw [hw] + exact certifiedConstantRowWeight_le_log_pairGain + explicit_cleanPairGain_constants hnreal hlogn hΞΎ + (by + have hq := explicitCertifiedCompletionScales.ΞΎ_le_source + have hr : ((explicitXi : β„š) : ℝ) ≀ + ((explicitXiSource : β„š) : ℝ) := by + exact_mod_cast hq + simpa only [ΞΎ] using! hr) + hΟ„scale hA hX hXint hKKT (by norm_num) (by norm_num) + (directedPairCostPrecision n) q heligible + have hcertificate : Real.exp (betheObjective A X + gain) ≀ + Matrix.permanent A := by + exact exp_betheObjective_add_greedyCertifiedMatchingGain_le_permanent + stableCoefficient w explicitGamma_pos hlower hn hA hX + (fun i j ↦ (hXint i).2 j |>.1) + have hnearGain : betheSlack n (Real.log (bethePermanent A)) + (Real.log (Matrix.permanent A)) < Ξ΄ * n β†’ + 3 * (explicitCertifiedGamma : ℝ) / 8 * n ≀ gain := by + intro hnear + rw [hlogBethe] at hnear + have h := nearCase_greedyCertifiedMatchingGain_ge_threeSixteenths + anariRezaeiRowInequality hn + (by exact_mod_cast explicitCertifiedStructuralKappa_pos) + hnreal hlogn hΞΎ hΟ„scale hΟ„0q hΟ„1q explicitGamma_pos.le + (by exact_mod_cast explicitEta_pos) + explicitCertifiedCompletionScales.Ξ·_le_tenth + explicitCertifiedCompletionScales.row_small + explicitCertifiedCompletionScales.cycle_small + explicitCertifiedCompletionScales.transfer_small + hA hX hXint hKKT hnear (directedPairCostPrecision n) + (explicitCertifiedCostMargin n) + change 3 * (explicitCertifiedGamma : ℝ) / 8 * n ≀ + (explicitCertifiedMatchingGain Xq : ℝ) + norm_num [explicitCertifiedGamma, explicitGamma] at h ⊒ + exact h + have hcases := completionCaseDisjunction + (logPermanent := Real.log (Matrix.permanent A)) + (logBethe := Real.log (bethePermanent A)) + (objective := betheObjective A X) (gain := gain) + (Ξ΄ := Ξ΄) (ΞΎ := ΞΎ) (Ξ³ := (explicitCertifiedGamma : ℝ)) + hobjective (by + change 0 ≀ (explicitCertifiedMatchingGain Xq : ℝ) + exact_mod_cast explicitCertifiedMatchingGain_nonneg Xq) + hupper hnearGain + have hgap := positiveDichotomy_exponent hcases + have hΞ΅cast := cast_rationalEpsilonPlus explicitCertifiedCompletionScales + constructor + Β· simpa only [X, gain] using! hcertificate + Β· simpa only [X, gain, Ξ·, Ξ΄, ΞΎ, hΞ΅cast] using! hgap + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificateMagnitude.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificateMagnitude.lean new file mode 100644 index 0000000000..158f9cccb4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutableCertificateMagnitude.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer + +/-! +# Certificate magnitude for the row-major executable optimizer +-/ + +@[expose] public section + +namespace BeyondBethe + +theorem executableOptimizerCertificateLog_abs_le + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + abs ((explicitDirectedCertificateLog + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B) : β„š) : ℝ) ≀ + explicitCertificateMagnitudeBudget B := by + let X := executableScannedBetheOptimizerMatrix (m := m + 1) B + let R := executableScannedBetheOptimizerRowPotential (m := m + 1) B + let C := executableScannedBetheOptimizerColumnPotential (m := m + 1) B + have hpoint := executableScannedBetheOptimizerPoint_spec (m := m + 1) + (by omega) B hBpos hBupper + have hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ)) := by + simpa only [X] using hpoint.2.1 + have hXlo : βˆ€ i j, (explicitOptimizerFloor B : ℝ) ≀ (X i j : ℝ) := by + simpa only [X] using hpoint.2.2.1 + have hfloor : 0 < (explicitOptimizerFloor B : ℝ) := + Rat.cast_pos.mpr (explicitOptimizerFloor_pos B) + have hXpos : βˆ€ i j, 0 < (X i j : ℝ) := fun i j ↦ + hfloor.trans_le (hXlo i j) + have happrox := executableScannedBetheOptimizer_hasApproximateLogKKT + (m := m + 1) (by omega) B hBpos hBupper + simpa only [X, R, C] using + certificateLog_abs_le_of_feasibleApproximateKKT + m B X R C hBpos hBupper hX hXpos + (by simpa only [X, R, C] using happrox) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutableInterior.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutableInterior.lean new file mode 100644 index 0000000000..98b6d4ff91 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutableInterior.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalInterior +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import Mathlib.Tactic + +/-! # Executable Interior -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Executable interior floor from binary input size + +The analytic interior estimate is converted here into a rational dyadic floor +whose exponent is computed directly from the matrix encoding, the dimension, +and the rational regularization parameter. +-/ + +/-- The interior-bound quantity `n*(n*B+2*n^2)/Ο„ + n^3`. -/ +def numericalInteriorK0 (n B : β„•) (Ο„ : β„š) : β„š := + n * (n * B + 2 * n ^ 2) / Ο„ + n ^ 3 + +/-- The ceiling of twice the numerical interior-bound quantity. -/ +def numericalInteriorExponent (n B : β„•) (Ο„ : β„š) : β„• := + rationalCeilNat (2 * numericalInteriorK0 n B Ο„) + +/-- The dyadic interior floor with exponent given by the numerical interior bound. -/ +def numericalInteriorFloor (n B : β„•) (Ο„ : β„š) : β„š := + (1 / 2 : β„š) ^ numericalInteriorExponent n B Ο„ + +theorem numericalInteriorK0_nonneg + {n B : β„•} {Ο„ : β„š} (hΟ„ : 0 < Ο„) : + 0 ≀ numericalInteriorK0 n B Ο„ := by + rw [numericalInteriorK0] + positivity + +theorem numericalInteriorFloor_pos (n B : β„•) (Ο„ : β„š) : + 0 < numericalInteriorFloor n B Ο„ := by + rw [numericalInteriorFloor] + positivity + +theorem numericalInteriorExponent_dominates + {n B : β„•} {Ο„ : β„š} (hΟ„ : 0 < Ο„) : + 2 * numericalInteriorK0 n B Ο„ ≀ + numericalInteriorExponent n B Ο„ := by + exact le_rationalCeilNat (mul_nonneg (by norm_num) + (numericalInteriorK0_nonneg hΟ„)) + +theorem log_inv_dyadic_cast (B : β„•) : + Real.log (1 / ((((1 / 2 : β„š) ^ B : β„š)) : ℝ)) = + (B : ℝ) * Real.log 2 := by + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] + rw [show (1 / ((1 / 2 : ℝ) ^ B)) = (2 : ℝ) ^ B by + simp only [one_div, inv_pow, inv_inv]] + rw [Real.log_pow] + +theorem numericalObjectiveRange_dyadic_le + {n B : β„•} (hn : 1 ≀ n) : + numericalObjectiveRange n + ((((1 / 2 : β„š) ^ B : β„š)) : ℝ) ≀ + (n : ℝ) * B + 2 * (n : ℝ) ^ 2 := by + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hlogn0 := log_natCast_le_natCast_mul_log_two hn + have hlogn : Real.log n ≀ (n : ℝ) := by + have hnreal : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hloginv := log_inv_dyadic_cast B + rw [numericalObjectiveRange, hloginv] + have hnreal : (1 : ℝ) ≀ n := by exact_mod_cast hn + have hBreal : 0 ≀ (B : ℝ) := by positivity + have hBlog : (B : ℝ) * Real.log 2 ≀ B := by + simpa using mul_le_mul_of_nonneg_left hlog2 hBreal + have hn0 : 0 ≀ (n : ℝ) := by positivity + have htermB := mul_le_mul_of_nonneg_left hBlog hn0 + have htermn := mul_le_mul_of_nonneg_left hlogn hn0 + have hnle : (n : ℝ) ≀ (n : ℝ) ^ 2 := by nlinarith + linarith + +theorem numericalInteriorK0_bounds_analytic + {n B : β„•} (hn : 1 ≀ n) {Ο„ : β„š} (hΟ„ : 0 < Ο„) : + (n : ℝ) * numericalObjectiveRange n + ((((1 / 2 : β„š) ^ B : β„š)) : ℝ) / (Ο„ : ℝ) + + (n : ℝ) ^ 2 * Real.log n ≀ + (numericalInteriorK0 n B Ο„ : ℝ) := by + have hrange := numericalObjectiveRange_dyadic_le (B := B) hn + have hΟ„r : 0 < (Ο„ : ℝ) := by exact_mod_cast hΟ„ + have hnlog := log_natCast_le_natCast_mul_log_two hn + have hlog2 : Real.log 2 ≀ 1 := by + have h := Real.log_le_sub_one_of_pos (x := (2 : ℝ)) (by norm_num) + norm_num at h + exact h + have hlogn : Real.log n ≀ (n : ℝ) := by + have hnreal : 0 ≀ (n : ℝ) := by positivity + nlinarith + have hn0 : 0 ≀ (n : ℝ) := by positivity + have hscaled := (div_le_div_iff_of_pos_right hΟ„r).2 + (mul_le_mul_of_nonneg_left hrange hn0) + have hlogterm := mul_le_mul_of_nonneg_left hlogn + (sq_nonneg (n : ℝ)) + rw [numericalInteriorK0] + push_cast + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] at hscaled + nlinarith + +theorem numericalInteriorK0_le_exponent_mul_log_two + {n B : β„•} {Ο„ : β„š} (hΟ„ : 0 < Ο„) : + (numericalInteriorK0 n B Ο„ : ℝ) ≀ + (numericalInteriorExponent n B Ο„ : ℝ) * Real.log 2 := by + have hq := numericalInteriorExponent_dominates (n := n) (B := B) hΟ„ + have hqR : 2 * (numericalInteriorK0 n B Ο„ : ℝ) ≀ + (numericalInteriorExponent n B Ο„ : ℝ) := by + exact_mod_cast hq + have hlog : (1 / 2 : ℝ) ≀ Real.log 2 := by + have h := Real.one_sub_inv_le_log_of_pos (by norm_num : (0 : ℝ) < 2) + norm_num at h ⊒ + exact h + have hK0 := numericalInteriorK0_nonneg (n := n) (B := B) hΟ„ + have hqnonneg : 0 ≀ (numericalInteriorExponent n B Ο„ : ℝ) := by positivity + nlinarith + +theorem lower_bound_of_log_inv_le_exponent + {x : ℝ} (hx : 0 < x) {q : β„•} + (hlog : Real.log (1 / x) ≀ (q : ℝ) * Real.log 2) : + ((1 / 2 : β„š) ^ q : β„š) ≀ x := by + have hinvpos : 0 < 1 / x := one_div_pos.mpr hx + have hpowpos : 0 < (2 : ℝ) ^ q := pow_pos (by norm_num) q + have hlogpow : Real.log ((2 : ℝ) ^ q) = (q : ℝ) * Real.log 2 := by + rw [Real.log_pow] + have hinv : 1 / x ≀ (2 : ℝ) ^ q := by + rw [← Real.log_le_log_iff hinvpos hpowpos, hlogpow] + exact hlog + have hone : 1 ≀ (2 : ℝ) ^ q * x := by + exact (div_le_iffβ‚€ hx).mp hinv + have hfloor : 1 / (2 : ℝ) ^ q ≀ x := by + exact (div_le_iffβ‚€ hpowpos).2 (by simpa [mul_comm] using hone) + norm_num only [Rat.cast_pow, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] + simpa only [one_div, inv_pow] using hfloor + +/-- The exact regularized optimizer lies in the executable dyadic floor +body. -/ +theorem regularizedOptimizer_meets_executable_floor + {n : β„•} (hn : 1 < n) {Ο„ : β„š} (hΟ„ : 0 < Ο„) + {Aq : Matrix (Fin n) (Fin n) β„š} + (hAq : βˆ€ i j, 0 < Aq i j) (hAupper : βˆ€ i j, Aq i j ≀ 1) + {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (Aq i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (Aq i j : ℝ)) X) : + βˆ€ i j, + (numericalInteriorFloor n (rationalMatrixEntryBitBound Aq) Ο„ : ℝ) ≀ + X i j ∧ + (numericalInteriorFloor n (rationalMatrixEntryBitBound Aq) Ο„ : ℝ) ≀ + 1 - X i j := by + let B := rationalMatrixEntryBitBound Aq + let m : β„š := (1 / 2 : β„š) ^ B + have hmQ : 0 < m := by positivity + have hm : 0 < (m : ℝ) := by exact_mod_cast hmQ + have hAlower : βˆ€ i j, (m : ℝ) ≀ (Aq i j : ℝ) := by + intro i j + exact_mod_cast (matrix_dyadic_bitBound_lt_entry hAq i j).le + have hApos : Matrix.Positive (fun i j ↦ (Aq i j : ℝ)) := by + intro i j + change 0 < ((Aq i j : β„š) : ℝ) + exact Rat.cast_pos.mpr (hAq i j) + have hAupR : βˆ€ i j, (Aq i j : ℝ) ≀ 1 := by + intro i j + exact_mod_cast hAupper i j + have hΟ„R : 0 < (Ο„ : ℝ) := by exact_mod_cast hΟ„ + have hanalytic := numericalInteriorK0_bounds_analytic + (B := B) (show 1 ≀ n by omega) hΟ„ + have hexponent := numericalInteriorK0_le_exponent_mul_log_two + (n := n) (B := B) hΟ„ + intro i j + have hentry := regularizedBetheMaximizer_log_inv_entry_le + hn hΟ„R hm hApos hAlower hAupR hX hmax i j + have hcomp := regularizedBetheMaximizer_log_inv_one_sub_entry_le + hn hΟ„R hm hApos hAlower hAupR hX hmax i j + have hXint := regularizedBetheMaximizer_interior hn hΟ„R hApos hX hmax + have hbudget : + (n : ℝ) * numericalObjectiveRange n (m : ℝ) / (Ο„ : ℝ) + + (n : ℝ) ^ 2 * Real.log n ≀ + (numericalInteriorExponent n B Ο„ : ℝ) * Real.log 2 := + hanalytic.trans hexponent + have hfloorEntry := lower_bound_of_log_inv_le_exponent + ((hXint i).2 j |>.1) (hentry.trans hbudget) + have hfloorComp := lower_bound_of_log_inv_le_exponent + (sub_pos.mpr ((hXint i).2 j |>.2)) (hcomp.trans hbudget) + simpa only [m, B, numericalInteriorFloor] using + And.intro hfloorEntry hfloorComp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutablePositiveRoutine.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutablePositiveRoutine.lean new file mode 100644 index 0000000000..729f17b649 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutablePositiveRoutine.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import Mathlib.Tactic + +/-! +# The executable positive-matrix routine + +This is the mathematical function computed by the row-major finite-word +optimizer. Its proof uses the optimizer's proved feasibility and objective +gap, and therefore does not identify its tie-breaking choices with those of +the earlier semantic bisection runner. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- The executable positive-input approximation: exact in dimensions zero and one, otherwise a +scaled certificate from the scanned Bethe optimizer. -/ +def executablePositiveAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + | 0, A => Matrix.permanent A + | 1, A => Matrix.permanent A + | m + 2, A => + let B := normalizedRationalMatrix A + let X := executableScannedBetheOptimizerMatrix (m := m + 1) B + let R := executableScannedBetheOptimizerRowPotential (m := m + 1) B + let C := executableScannedBetheOptimizerColumnPotential (m := m + 1) B + rationalNormalizationScale A ^ (m + 2) * + explicitDirectedCertificateValue X R C + +@[simp] theorem executablePositiveAlgorithm_succ_succ + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) : + executablePositiveAlgorithm (m + 2) A = + rationalNormalizationScale A ^ (m + 2) * + explicitDirectedCertificateValue + (executableScannedBetheOptimizerMatrix (m := m + 1) + (normalizedRationalMatrix A)) + (executableScannedBetheOptimizerRowPotential (m := m + 1) + (normalizedRationalMatrix A)) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) + (normalizedRationalMatrix A)) := by + rfl + +theorem executablePositiveAlgorithm_succ_succ_spec + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hA : Matrix.Positive (fun i j ↦ (A i j : ℝ))) : + 0 < (executablePositiveAlgorithm (m + 2) A : ℝ) ∧ + (executablePositiveAlgorithm (m + 2) A : ℝ) ≀ + ((Matrix.permanent A : β„š) : ℝ) ∧ + ((Matrix.permanent A : β„š) : ℝ) ≀ + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ (m + 2) * + (executablePositiveAlgorithm (m + 2) A : ℝ) := by + let B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š := + normalizedRationalMatrix A + let X := executableScannedBetheOptimizerMatrix (m := m + 1) B + let R := executableScannedBetheOptimizerRowPotential (m := m + 1) B + let C := executableScannedBetheOptimizerColumnPotential (m := m + 1) B + let L : β„š := explicitDirectedCertificateValue X R C + have hAq : βˆ€ i j, 0 < A i j := by + intro i j + exact positive_rational_of_positive_cast (hA i j) + have hAnonneg : Matrix.Nonnegative A := fun i j ↦ (hAq i j).le + have hBpos : βˆ€ i j, 0 < B i j := by + intro i j + change 0 < normalizedRationalMatrix A i j + rw [normalizedRationalMatrix] + exact div_pos (hAq i j) (rationalNormalizationScale_pos hAnonneg) + have hBupper : βˆ€ i j, B i j ≀ 1 := by + intro i j + exact normalizedRationalMatrix_le_one hAnonneg i j + have hpoint := executableScannedBetheOptimizerPoint_spec (m := m + 1) + (by omega) B hBpos hBupper + have hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ)) := by + simpa only [X] using hpoint.2.1 + have hXlo : βˆ€ i j, (explicitOptimizerFloor B : ℝ) ≀ (X i j : ℝ) := by + simpa only [X] using hpoint.2.2.1 + have hdelta : 0 < (explicitOptimizerFloor B : ℝ) := + Rat.cast_pos.mpr (explicitOptimizerFloor_pos B) + have hXpos : βˆ€ i j, 0 < (X i j : ℝ) := by + intro i j + exact hdelta.trans_le (hXlo i j) + have hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ)) := by + intro i + refine ⟨hX.row_probability i, fun j ↦ ⟨hXpos i j, ?_⟩⟩ + exact hX.entry_lt_one_of_positive hXpos (by simp) i j + have happrox := executableScannedBetheOptimizer_hasApproximateLogKKT + (m := m + 1) (by omega) B hBpos hBupper + have hBR : Matrix.Positive (fun i j ↦ (B i j : ℝ)) := by + intro i j + exact Rat.cast_pos.mpr (hBpos i j) + have hcert := explicitDirectedCertificate_twoSided + anariOveisGharanStableCoefficient (n := m + 2) (by omega) + hBR hX hXint (by simpa only [X, R, C, B] using happrox) + have hLpos : 0 < (L : ℝ) := by + simpa only [L] using explicitDirectedCertificateValue_pos + (n := m + 2) (by omega) X R C + have hscale : 0 < (rationalNormalizationScale A : ℝ) := by + exact_mod_cast rationalNormalizationScale_pos hAnonneg + have hper := cast_permanent_eq_scale_pow_mul_normalized A hAnonneg + have hout : + (executablePositiveAlgorithm (m + 2) A : ℝ) = + (rationalNormalizationScale A : ℝ) ^ (m + 2) * (L : ℝ) := by + simp only [executablePositiveAlgorithm_succ_succ, B, X, R, C, L, + Rat.cast_mul, Rat.cast_pow] + have hcert' : (L : ℝ) ≀ Matrix.permanent (fun i j ↦ (B i j : ℝ)) ∧ + Matrix.permanent (fun i j ↦ (B i j : ℝ)) ≀ + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ (m + 2) * + (L : ℝ) := by + simpa only [L, X, R, C] using hcert + rw [hout] + refine ⟨mul_pos (pow_pos hscale _) hLpos, ?_, ?_⟩ + Β· rw [hper] + exact mul_le_mul_of_nonneg_left hcert'.1 (pow_nonneg hscale.le _) + Β· rw [hper] + have hmul := mul_le_mul_of_nonneg_left hcert'.2 + (pow_nonneg hscale.le (m + 2)) + nlinarith + +/-- The executable positive-input algorithm bundled with positivity and the two permanent +approximation bounds. -/ +def executableCertifiedPositiveRoutine : + CertifiedPositiveRoutine (explicitCertifiedEpsilon : ℝ) where + alg := executablePositiveAlgorithm + positiveOutput := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (executablePositiveAlgorithm_succ_succ_spec m A hA).1 + lower := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (executablePositiveAlgorithm_succ_succ_spec m A hA).2.1 + upper := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (executablePositiveAlgorithm_succ_succ_spec m A hA).2.2 + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutableScannedBetheOptimizer.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutableScannedBetheOptimizer.lean new file mode 100644 index 0000000000..e82e095edf --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutableScannedBetheOptimizer.lean @@ -0,0 +1,347 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSemantics +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import Mathlib.Tactic + +/-! +# Correctness of the executable row-major Bethe optimizer + +The finite-word optimizer uses the concrete unreduced dyadic floor emitted by +the scale machine and the row-major separation oracle. This file defines its +mathematical output, proves the same objective-gap specification as the +paper-level optimizer, and derives the approximate logarithmic KKT equations +without identifying its tie-breaking choices with those of any other runner. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw-rational coordinate floor for the scanned optimizer, determined by the dimension and +entry bit bound. -/ +def executableScannedBetheOptimizerFloor {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : RawRat := + rawExplicitOptimizerFloor (m + 1) (rationalMatrixEntryBitBound A) + +/-- Initialize scanned Bethe bisection with the explicit regularization, precision, floor, +mixing weight, and inner radius. -/ +def executableScannedBetheOptimizerInitialState {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + BetheBisectionState (m * m + 1) := + initialScannedBetheBisectionState + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (explicitOptimizerMix A) (explicitOptimizerInnerRadius A) + +/-- Run scanned Bethe bisection for the prescribed explicit number of iterations. -/ +def executableScannedBetheOptimizerState {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + BetheBisectionState (m * m + 1) := + runScannedBetheBisection + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (explicitOptimizerInnerRadius A) + (explicitOptimizerBisectionSteps A) + (executableScannedBetheOptimizerInitialState A) + +/-- The default branch makes the rational algorithm total. Correctness below +proves that it is never used on positive normalized inputs. -/ +def executableScannedBetheOptimizerPoint {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Fin (m * m + 1) β†’ β„š := + (executableScannedBetheOptimizerState A).witness.getD 0 + +/-- Recover the affine matrix from the epigraph base coordinates of the scanned optimizer point. -/ +def executableScannedBetheOptimizerMatrix {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + betheAffineMatrixQ (epigraphBase (executableScannedBetheOptimizerPoint A)) + +/-- The directed lower negative-gradient matrix evaluated at the scanned optimizer matrix. -/ +def executableScannedBetheOptimizerGradient {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + directedNegativeGradientLowerMatrix + (explicitRegularizationScale (m + 1)) A + (executableScannedBetheOptimizerMatrix A) + (explicitOptimizerPrecision A) + +/-- The row potential obtained from the negative first-column gradient entry and the +regularization offset. -/ +def executableScannedBetheOptimizerRowPotential {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : Fin (m + 1) β†’ β„š := + fun i ↦ -executableScannedBetheOptimizerGradient A i 0 + + (2 + explicitRegularizationScale (m + 1)) + +/-- The column potential obtained from the negative first-row gradient difference relative to +column zero. -/ +def executableScannedBetheOptimizerColumnPotential {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : Fin (m + 1) β†’ β„š := + fun j ↦ -(executableScannedBetheOptimizerGradient A 0 j - + executableScannedBetheOptimizerGradient A 0 0) + +@[simp] theorem executableScannedBetheOptimizerFloor_value {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + (executableScannedBetheOptimizerFloor A).value = + explicitOptimizerFloor A := by + exact (rawExplicitOptimizerScales_value A).1 + +theorem executableScannedBetheOptimizerPoint_spec {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + BetheEpigraphOracleAccepted (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) (explicitOptimizerFloor A) + (executableScannedBetheOptimizerState A).high + (executableScannedBetheOptimizerPoint A) ∧ + IsDoublyStochastic + (fun i j ↦ ((executableScannedBetheOptimizerMatrix A i j : β„š) : ℝ)) ∧ + (βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ + (executableScannedBetheOptimizerMatrix A i j : ℝ)) ∧ + βˆƒ X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ, + IsDoublyStochastic X ∧ + (βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X) ∧ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ + ((executableScannedBetheOptimizerMatrix A i j : β„š) : ℝ)) ≀ + (explicitOptimizerGap A : ℝ) := by + let tau : β„š := explicitRegularizationScale (m + 1) + let delta := executableScannedBetheOptimizerFloor A + obtain ⟨X, hX, hmax⟩ := exists_regularizedBetheMaximizer + (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + have htau0 : 0 < tau := explicitRegularizationScale_pos (by omega) + have htau1 : tau ≀ 1 := explicitRegularizationScale_le_one (by omega) + have hdelta : 0 < delta.value := by + change 0 < (executableScannedBetheOptimizerFloor A).value + rw [executableScannedBetheOptimizerFloor_value] + exact explicitOptimizerFloor_pos A + have hfloor : delta.value ≀ (1 - explicitOptimizerMix A) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) tau := by + change (executableScannedBetheOptimizerFloor A).value ≀ + (1 - explicitOptimizerMix A) * + numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) tau + rw [executableScannedBetheOptimizerFloor_value] + simpa only [tau] using explicitOptimizerFloor_le_smoothedFloor A + have hrun := runScannedBetheBisection_objective_gap hm htau0 htau1 + hApos hAupper hX hmax + (explicitOptimizerMix_pos A) (explicitOptimizerMix_le_one A) + hdelta (explicitOptimizerInnerRadius_pos A) + (explicitOptimizerInnerRadius_spike A) hfloor + (explicitOptimizerPrecision A) (explicitOptimizerBisectionSteps A) + have hrun' : βˆƒ q : Fin (m * m + 1) β†’ β„š, + (executableScannedBetheOptimizerState A).witness = some q ∧ + BetheEpigraphOracleAccepted tau A (explicitOptimizerPrecision A) + delta.value (executableScannedBetheOptimizerState A).high q ∧ + IsDoublyStochastic (acceptedBetheMatrix q) ∧ + (βˆ€ i j, (delta.value : ℝ) ≀ acceptedBetheMatrix q i j) ∧ + regularizedBetheObjective (tau : ℝ) (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + (acceptedBetheMatrix q) ≀ + (betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) : ℝ) + + (explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A : β„š) + + (betheObjectiveEvaluationError m + (explicitOptimizerPrecision A) : ℝ) := by + simpa only [tau, delta, executableScannedBetheOptimizerState, + executableScannedBetheOptimizerInitialState, + explicitOptimizerInitialWidth] using hrun + obtain ⟨q, hq, haccepted, hqDS, hqfloor, hqgap⟩ := hrun' + have hpoint : executableScannedBetheOptimizerPoint A = q := by + rw [executableScannedBetheOptimizerPoint, hq] + rfl + have hmatrixCast : + (fun i j ↦ + ((executableScannedBetheOptimizerMatrix A i j : β„š) : ℝ)) = + acceptedBetheMatrix q := by + ext i j + rw [executableScannedBetheOptimizerMatrix, hpoint] + exact cast_betheAffineMatrixQ (epigraphBase q) i j + have htotalQ := explicitOptimizerTotalObjectiveError_lt A + have htotal : + (betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) : ℝ) + + (explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A : β„š) + + (betheObjectiveEvaluationError m + (explicitOptimizerPrecision A) : ℝ) < + (explicitOptimizerGap A : ℝ) := by + exact_mod_cast htotalQ + refine ⟨?_, ?_, ?_, X, hX, hmax, ?_⟩ + Β· simpa only [tau, delta, + executableScannedBetheOptimizerFloor_value, hpoint] using haccepted + Β· simpa only [hmatrixCast] using hqDS + Β· intro i j + change (explicitOptimizerFloor A : ℝ) ≀ + (fun a b ↦ + ((executableScannedBetheOptimizerMatrix A a b : β„š) : ℝ)) i j + rw [hmatrixCast] + simpa only [delta, executableScannedBetheOptimizerFloor_value] using + hqfloor i j + Β· rw [hmatrixCast] + exact hqgap.trans htotal.le + +theorem executableScannedBetheOptimizer_hasApproximateLogKKT + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + HasApproximateLogKKT (explicitKKTError : ℝ) + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ + ((executableScannedBetheOptimizerMatrix A i j : β„š) : ℝ)) + (fun i ↦ (executableScannedBetheOptimizerRowPotential A i : ℝ)) + (fun j ↦ + (executableScannedBetheOptimizerColumnPotential A j : ℝ)) := by + obtain ⟨_, hY, hYlo, X, hX, hmax, hgap⟩ := + executableScannedBetheOptimizerPoint_spec hm A hApos hAupper + simpa only [executableScannedBetheOptimizerGradient, + executableScannedBetheOptimizerRowPotential, + executableScannedBetheOptimizerColumnPotential] using + hasApproximateLogKKT_of_explicitOptimizerSpec hm A hApos hAupper + (executableScannedBetheOptimizerMatrix A) hY hYlo X hX hmax hgap + +/-! ## Exact agreement with the finite-word bisection output -/ + +theorem executableScannedBetheOptimizerState_indexAgrees {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + ScannedOptimizerIndexAgrees A + (executableScannedBetheOptimizerState A) + (runScannedOptimizerIndex A (explicitOptimizerBisectionSteps A) 0 0) + (explicitOptimizerBisectionSteps A) := by + simpa only [executableScannedBetheOptimizerState, + executableScannedBetheOptimizerInitialState, + executableScannedBetheOptimizerFloor, Nat.zero_add] using + runScannedOptimizerIndex_agrees A + (initialScannedOptimizerIndexAgrees A) + (explicitOptimizerBisectionSteps A) + +theorem executableScannedBetheOptimizer_witness_eq_some + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + (executableScannedBetheOptimizerState A).witness = + some (executableScannedBetheOptimizerPoint A) := by + let tau : β„š := explicitRegularizationScale (m + 1) + obtain ⟨X, hX, hmax⟩ := exists_regularizedBetheMaximizer + (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + have htau0 : 0 < tau := explicitRegularizationScale_pos (by omega) + have htau1 : tau ≀ 1 := explicitRegularizationScale_le_one (by omega) + have hdelta : 0 < (executableScannedBetheOptimizerFloor A).value := by + rw [executableScannedBetheOptimizerFloor_value] + exact explicitOptimizerFloor_pos A + have hfloor : (executableScannedBetheOptimizerFloor A).value ≀ + (1 - explicitOptimizerMix A) * + numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) tau := by + rw [executableScannedBetheOptimizerFloor_value] + simpa only [tau] using explicitOptimizerFloor_le_smoothedFloor A + have hsome0 := + initialScannedBetheBisectionState_has_witness_of_optimizer + hm htau0 htau1 hApos hAupper hX hmax + (explicitOptimizerMix_pos A) (explicitOptimizerMix_le_one A) + hdelta (explicitOptimizerInnerRadius_pos A) + (explicitOptimizerInnerRadius_spike A) hfloor + (explicitOptimizerPrecision A) + have hsome := runScannedBetheBisection_preserves_some + tau A (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (explicitOptimizerInnerRadius A) hsome0 + (explicitOptimizerBisectionSteps A) + obtain ⟨q, hq⟩ := hsome + have hq' : (executableScannedBetheOptimizerState A).witness = some q := by + simpa only [tau, executableScannedBetheOptimizerState, + executableScannedBetheOptimizerInitialState] using hq + rw [executableScannedBetheOptimizerPoint, hq'] + rfl + +theorem executableScannedBetheOptimizer_finalFeasibilityResult + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (rawRatOfRat (executableScannedBetheOptimizerState A).high) + (explicitOptimizerInnerRadius A) = + .accepted (executableScannedBetheOptimizerPoint A) := by + have hvalid0 := initialScannedBetheBisectionState_witnessValid + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (explicitOptimizerMix A) (explicitOptimizerInnerRadius A) + have hvalidN := runScannedBetheBisection_witnessValid + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (executableScannedBetheOptimizerFloor A) + (explicitOptimizerInnerRadius A) hvalid0 + (explicitOptimizerBisectionSteps A) + exact (hvalidN (executableScannedBetheOptimizerPoint A) (by + simpa only [executableScannedBetheOptimizerState, + executableScannedBetheOptimizerInitialState] using + executableScannedBetheOptimizer_witness_eq_some + hm A hApos hAupper)).1 + +@[simp] theorem machineExplicitBetheOptimizerFeasibilityResultCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExplicitBetheOptimizerFeasibilityResultCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalFeasibilityResultBinaryCode + (.accepted (executableScannedBetheOptimizerPoint A)) := by + let N := explicitOptimizerBisectionSteps A + let k := runScannedOptimizerIndex A N 0 0 + have hagree := executableScannedBetheOptimizerState_indexAgrees A + have hhigh : (executableScannedBetheOptimizerState A).high = + optimizerDyadicThreshold A (k + 1) N := by + simpa only [N, k] using hagree.2 + rw [machineExplicitBetheOptimizerFeasibilityResultCode, + machineOptimizerBisectionFinalState_encode hm A hApos, + machineOptimizerBisectionHighRawCode_encode] + rw [← hhigh] + change machineExplicitBetheThresholdFeasibilityCode + (optimizerFeasibilityCallCode A + (rawRatOfRat (executableScannedBetheOptimizerState A).high)) = _ + rw [machineExplicitBetheThresholdFeasibilityCode_encode hm A hApos] + apply congrArg rationalFeasibilityResultBinaryCode + simpa only [executableScannedBetheOptimizerFloor] using + executableScannedBetheOptimizer_finalFeasibilityResult + hm A hApos hAupper + +@[simp] theorem machineExplicitBetheOptimizerPointCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExplicitBetheOptimizerPointCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalFiniteVectorCode (executableScannedBetheOptimizerPoint A) := by + rw [machineExplicitBetheOptimizerPointCode, + machineExplicitBetheOptimizerFeasibilityResultCode_encode + hm A hApos hAupper] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExecutableTransfer.lean b/LeanPool/BeyondBethe/BeyondBethe/ExecutableTransfer.lean new file mode 100644 index 0000000000..79be2bf801 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExecutableTransfer.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby + +/-! # Executable Transfer -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Transfer of the executable certificate + +An approximate logarithmic KKT point defines a nearby matrix for which the +rational point is an exact optimizer. The executable fixed-gain matching is +computed from that same rational point, so it transfers without any numerical +pair-gain approximation. +-/ + +/-- Logarithm of the executable lower certificate before its final directed +exponential evaluation. -/ +noncomputable def executableNearbyCertificateLog + {n : β„•} (error : ℝ) + (Xq : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ ℝ) : ℝ := + let X : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((Xq i j : β„š) : ℝ) + let A' := nearbyKKTMatrix (explicitRegularizationScale n : ℝ) X R C + betheObjective A' X + (explicitCertifiedMatchingGain Xq : ℝ) - error * n + +/-- Exponentiate the logarithmic nearby-certificate value for the rational matrix and supplied +potentials. -/ +noncomputable def executableNearbyCertificateValue + {n : β„•} (error : ℝ) + (Xq : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ ℝ) : ℝ := + Real.exp (executableNearbyCertificateLog error Xq R C) + +theorem executableNearbyCertificateValue_pos + {n : β„•} (error : ℝ) + (Xq : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ ℝ) : + 0 < executableNearbyCertificateValue error Xq R C := + Real.exp_pos _ + +/-- Approximate KKT residual `error` costs exactly `2 * error` in the +logarithmic exponent: once in comparing permanents and once in shifting the +certificate downward to preserve its lower-bound direction. -/ +theorem executableNearbyCertificate_twoSided + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {n : β„•} (hn : 2 ≀ n) + {A : Matrix (Fin n) (Fin n) ℝ} + {Xq : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic + (fun i j ↦ ((Xq i j : β„š) : ℝ))) + (hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((Xq i j : β„š) : ℝ))) + {error : ℝ} {R C : Fin n β†’ ℝ} + (happrox : HasApproximateLogKKT error + (explicitRegularizationScale n : ℝ) A + (fun i j ↦ ((Xq i j : β„š) : ℝ)) R C) : + executableNearbyCertificateValue error Xq R C ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.sqrt 2 * Real.exp + (-(((rationalEpsilonPlus + explicitCertifiedCompletionScales : β„š) : ℝ) - + 2 * error))) ^ n * + executableNearbyCertificateValue error Xq R C := by + let X : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((Xq i j : β„š) : ℝ) + let Ο„ : ℝ := (explicitRegularizationScale n : ℝ) + let A' := nearbyKKTMatrix Ο„ X R C + let F := betheObjective A' X + (explicitCertifiedMatchingGain Xq : ℝ) + let L := executableNearbyCertificateValue error Xq R C + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hXlt : βˆ€ i j, X i j < 1 := fun i j ↦ (hXint i).2 j |>.2 + have hA' : Matrix.Positive A' := nearbyKKTMatrix_positive hXpos hXlt + have hstruct := explicitCertified_certificate_of_logKKT + stableCoefficient hn hA' hX hXint + (nearbyKKTMatrix_hasLogKKT hXpos hXlt) + have hcompare := approximateLogKKT_permanent_comparison + hA (by simpa only [Ο„, X] using happrox) hXpos hXlt + have hcompare' : + (Real.exp (-error)) ^ n * Matrix.permanent A' ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.exp error) ^ n * Matrix.permanent A' := by + simpa only [A', Ο„, X, Fintype.card_fin] using hcompare + have hstructLower : Real.exp F ≀ Matrix.permanent A' := by + simpa only [F, A', X] using hstruct.1 + have hstructGap : Real.log (Matrix.permanent A') - F ≀ + (Real.log 2 / 2 - + ((rationalEpsilonPlus explicitCertifiedCompletionScales : β„š) : ℝ)) * n := by + simpa only [F, A', X] using hstruct.2 + have hperA : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hperA' : 0 < Matrix.permanent A' := permanent_pos_of_positive A' hA' + have hL : L = Real.exp (F - error * n) := by + simp only [L, executableNearbyCertificateValue, + executableNearbyCertificateLog, A', F, Ο„, X] + have hfactor : Real.exp (F - error * n) = + (Real.exp (-error)) ^ n * Real.exp F := by + calc + Real.exp (F - error * n) = + Real.exp F * Real.exp (-(error * n)) := by + rw [sub_eq_add_neg, Real.exp_add] + _ = Real.exp F * Real.exp ((n : ℝ) * (-error)) := by + congr 2 + ring + _ = Real.exp F * (Real.exp (-error)) ^ n := by + rw [Real.exp_nat_mul] + _ = (Real.exp (-error)) ^ n * Real.exp F := by ring + constructor + Β· change L ≀ Matrix.permanent A + rw [hL, hfactor] + exact (mul_le_mul_of_nonneg_left hstructLower + (pow_nonneg (Real.exp_pos (-error)).le n)).trans hcompare'.1 + Β· have hscalePos : 0 < (Real.exp error) ^ n * Matrix.permanent A' := + mul_pos (pow_pos (Real.exp_pos _) n) hperA' + have hlogCompare : Real.log (Matrix.permanent A) ≀ + Real.log ((Real.exp error) ^ n * Matrix.permanent A') := + Real.strictMonoOn_log.monotoneOn hperA hscalePos hcompare'.2 + have hlogScale : + Real.log ((Real.exp error) ^ n * Matrix.permanent A') = + error * n + Real.log (Matrix.permanent A') := by + rw [Real.log_mul (pow_ne_zero n (Real.exp_ne_zero error)) hperA'.ne', + Real.log_pow, Real.log_exp] + ring + have hgap : Real.log (Matrix.permanent A) - Real.log L ≀ + (Real.log 2 / 2 - + (((rationalEpsilonPlus + explicitCertifiedCompletionScales : β„š) : ℝ) - + 2 * error)) * n := by + rw [hlogScale] at hlogCompare + rw [hL, Real.log_exp] + nlinarith [hstructGap] + change Matrix.permanent A ≀ + (Real.sqrt 2 * Real.exp + (-(((rationalEpsilonPlus + explicitCertifiedCompletionScales : β„š) : ℝ) - + 2 * error))) ^ n * L + exact logGap_implies_positive_approximation + (by rw [hL]; exact Real.exp_pos _) hperA hgap + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheOptimizer.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheOptimizer.lean new file mode 100644 index 0000000000..f2822cae79 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheOptimizer.lean @@ -0,0 +1,362 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitOptimizerScales +public import Mathlib.Tactic + +/-! # Explicit Bethe Optimizer -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The concrete rational regularized-Bethe optimizer + +This file fixes every parameter of the rational threshold oracle and +bisection. The exact real maximizer below appears only in correctness +proofs; the state and returned point are executable rational data. +-/ + +/-- Initialize Bethe bisection with the explicit regularization and optimizer scale parameters. -/ +def explicitBetheOptimizerInitialState {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + BetheBisectionState (m * m + 1) := + initialBetheBisectionState (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) (explicitOptimizerFloor A) + (explicitOptimizerMix A) (explicitOptimizerInnerRadius A) + +/-- Run Bethe bisection for the explicit iteration budget from its prescribed initial state. -/ +def explicitBetheOptimizerState {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + BetheBisectionState (m * m + 1) := + runBetheBisection (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) (explicitOptimizerFloor A) + (explicitOptimizerInnerRadius A) (explicitOptimizerBisectionSteps A) + (explicitBetheOptimizerInitialState A) + +/-- The default branch is unreachable on positive normalized inputs, but +keeps the algorithm total on every rational matrix. -/ +def explicitBetheOptimizerPoint {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Fin (m * m + 1) β†’ β„š := + (explicitBetheOptimizerState A).witness.getD 0 + +/-- Recover the affine matrix from the epigraph base coordinates of the explicit optimizer +point. -/ +def explicitBetheOptimizerMatrix {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + betheAffineMatrixQ (epigraphBase (explicitBetheOptimizerPoint A)) + +/-- The directed lower negative-gradient matrix evaluated at the explicit optimizer matrix. -/ +def explicitBetheOptimizerGradient {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + Matrix (Fin (m + 1)) (Fin (m + 1)) β„š := + directedNegativeGradientLowerMatrix + (explicitRegularizationScale (m + 1)) A + (explicitBetheOptimizerMatrix A) (explicitOptimizerPrecision A) + +/-- Rational row potentials obtained by anchoring the directed negative +gradient at the first column. -/ +def explicitBetheOptimizerRowPotential {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : Fin (m + 1) β†’ β„š := + fun i ↦ -explicitBetheOptimizerGradient A i 0 + + (2 + explicitRegularizationScale (m + 1)) + +/-- Rational column potentials, normalized to vanish at the first column. -/ +def explicitBetheOptimizerColumnPotential {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : Fin (m + 1) β†’ β„š := + fun j ↦ -(explicitBetheOptimizerGradient A 0 j - + explicitBetheOptimizerGradient A 0 0) + +theorem HasApproximateLogKKT.mono + {ΞΉ : Type*} [Fintype ΞΉ] {Ξ΅ Ξ΅' Ο„ : ℝ} + {A X : Matrix ΞΉ ΞΉ ℝ} {R C : ΞΉ β†’ ℝ} + (h : HasApproximateLogKKT Ξ΅ Ο„ A X R C) (hΞ΅ : Ξ΅ ≀ Ξ΅') : + HasApproximateLogKKT Ξ΅' Ο„ A X R C := by + intro i j + exact (h i j).trans hΞ΅ + +theorem explicitBetheOptimizerPoint_spec {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + BetheEpigraphOracleAccepted (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) (explicitOptimizerFloor A) + (explicitBetheOptimizerState A).high + (explicitBetheOptimizerPoint A) ∧ + IsDoublyStochastic + (fun i j ↦ ((explicitBetheOptimizerMatrix A i j : β„š) : ℝ)) ∧ + (βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ + (explicitBetheOptimizerMatrix A i j : ℝ)) ∧ + βˆƒ X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ, + IsDoublyStochastic X ∧ + (βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X) ∧ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ ((explicitBetheOptimizerMatrix A i j : β„š) : ℝ)) ≀ + (explicitOptimizerGap A : ℝ) := by + let Ο„ : β„š := explicitRegularizationScale (m + 1) + obtain ⟨X, hX, hmax⟩ := exists_regularizedBetheMaximizer + (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + have hΟ„0 : 0 < Ο„ := explicitRegularizationScale_pos (by omega) + have hΟ„1 : Ο„ ≀ 1 := explicitRegularizationScale_le_one (by omega) + have hrun := runBetheBisection_objective_gap hm hΟ„0 hΟ„1 hApos hAupper + hX hmax (explicitOptimizerMix_pos A) (explicitOptimizerMix_le_one A) + (explicitOptimizerFloor_pos A) (explicitOptimizerInnerRadius_pos A) + (explicitOptimizerInnerRadius_spike A) + (explicitOptimizerFloor_le_smoothedFloor A) + (explicitOptimizerPrecision A) (explicitOptimizerBisectionSteps A) + have hrun' : βˆƒ q : Fin (m * m + 1) β†’ β„š, + (explicitBetheOptimizerState A).witness = some q ∧ + BetheEpigraphOracleAccepted Ο„ A (explicitOptimizerPrecision A) + (explicitOptimizerFloor A) (explicitBetheOptimizerState A).high q ∧ + IsDoublyStochastic (acceptedBetheMatrix q) ∧ + (βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ acceptedBetheMatrix q i j) ∧ + regularizedBetheObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (acceptedBetheMatrix q) ≀ + (betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) : ℝ) + + (explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A : β„š) + + (betheObjectiveEvaluationError m + (explicitOptimizerPrecision A) : ℝ) := by + simpa only [Ο„, explicitBetheOptimizerState, + explicitBetheOptimizerInitialState, explicitOptimizerInitialWidth] + using hrun + obtain ⟨q, hq, haccepted, hqDS, hqfloor, hqgap⟩ := hrun' + have hpoint : explicitBetheOptimizerPoint A = q := by + rw [explicitBetheOptimizerPoint, hq] + rfl + have hmatrixCast : + (fun i j ↦ ((explicitBetheOptimizerMatrix A i j : β„š) : ℝ)) = + acceptedBetheMatrix q := by + ext i j + rw [explicitBetheOptimizerMatrix, hpoint] + exact cast_betheAffineMatrixQ (epigraphBase q) i j + have htotalQ := explicitOptimizerTotalObjectiveError_lt A + have htotal : + (betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) : ℝ) + + (explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A : β„š) + + (betheObjectiveEvaluationError m + (explicitOptimizerPrecision A) : ℝ) < + (explicitOptimizerGap A : ℝ) := by + exact_mod_cast htotalQ + refine ⟨?_, ?_, ?_, X, hX, hmax, ?_⟩ + Β· simpa only [Ο„, hpoint] using haccepted + Β· simpa only [hmatrixCast] using hqDS + Β· intro i j + change (explicitOptimizerFloor A : ℝ) ≀ + (fun a b ↦ ((explicitBetheOptimizerMatrix A a b : β„š) : ℝ)) i j + rw [hmatrixCast] + exact hqfloor i j + Β· rw [hmatrixCast] + exact hqgap.trans htotal.le + +/-- Any rational matrix satisfying the concrete optimizer's feasibility and +objective-gap specification yields the same anchored approximate logarithmic +KKT certificate. This formulation separates the analytic argument from the +tie-breaking rule used by the executable separation oracle. -/ +theorem hasApproximateLogKKT_of_explicitOptimizerSpec {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + (Xq : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hY : IsDoublyStochastic (fun i j ↦ ((Xq i j : β„š) : ℝ))) + (hYlo : βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ (Xq i j : ℝ)) + (X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + (hgap : regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) ≀ + (explicitOptimizerGap A : ℝ)) : + HasApproximateLogKKT (explicitKKTError : ℝ) + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ ((Xq i j : β„š) : ℝ)) + (fun i ↦ (-directedNegativeGradientLowerMatrix + (explicitRegularizationScale (m + 1)) A Xq + (explicitOptimizerPrecision A) i 0 + + (2 + explicitRegularizationScale (m + 1)) : β„š)) + (fun j ↦ (-(directedNegativeGradientLowerMatrix + (explicitRegularizationScale (m + 1)) A Xq + (explicitOptimizerPrecision A) 0 j - + directedNegativeGradientLowerMatrix + (explicitRegularizationScale (m + 1)) A Xq + (explicitOptimizerPrecision A) 0 0) : β„š)) := by + let Ο„q : β„š := explicitRegularizationScale (m + 1) + let Y : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ := + fun i j ↦ (Xq i j : ℝ) + let Gq := directedNegativeGradientLowerMatrix Ο„q A Xq + (explicitOptimizerPrecision A) + let G : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ := + fun i j ↦ (Gq i j : ℝ) + have hΟ„0q : 0 < Ο„q := explicitRegularizationScale_pos (by omega) + have hΟ„1q : Ο„q ≀ 1 := explicitRegularizationScale_le_one (by omega) + have hΟ„0 : 0 < (Ο„q : ℝ) := Rat.cast_pos.mpr hΟ„0q + have hΟ„1 : (Ο„q : ℝ) ≀ 1 := by exact_mod_cast hΟ„1q + have hΞ΄q : 0 < explicitOptimizerFloor A := explicitOptimizerFloor_pos A + have hΞ΄ : 0 < (explicitOptimizerFloor A : ℝ) := Rat.cast_pos.mpr hΞ΄q + have hρ : 0 ≀ (explicitOptimizerRho A : ℝ) := by + exact_mod_cast (explicitOptimizerRho_pos A).le + have hY' : IsDoublyStochastic Y := by simpa only [Y] using hY + have hYlo' : βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ Y i j := by + simpa only [Y] using hYlo + have hYpos : βˆ€ i j, 0 < Y i j := by + intro i j + exact hΞ΄.trans_le (hYlo' i j) + have hYcomp : βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ 1 - Y i j := by + exact one_sub_entry_ge_of_common_floor (by simp; omega) hY' hYlo' + have hYlt : βˆ€ i j, Y i j < 1 := + hY'.entry_lt_one_of_positive hYpos (by simp; omega) + let Ξ΄0q : β„š := numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) Ο„q + have hΞ΄le : explicitOptimizerFloor A ≀ Ξ΄0q := by + rw [explicitOptimizerFloor] + have hΞ΄0 : 0 < Ξ΄0q := numericalInteriorFloor_pos _ _ _ + dsimp only [Ξ΄0q, Ο„q] at hΞ΄0 ⊒ + linarith + have hoptimizerFloor : βˆ€ i j, + (Ξ΄0q : ℝ) ≀ X i j ∧ (Ξ΄0q : ℝ) ≀ 1 - X i j := by + exact regularizedOptimizer_meets_executable_floor (n := m + 1) + (by omega) hΟ„0q hApos hAupper hX hmax + have hΞ΄leR : (explicitOptimizerFloor A : ℝ) ≀ (Ξ΄0q : ℝ) := by + exact_mod_cast hΞ΄le + have hXlo : βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ X i j := by + intro i j + exact hΞ΄leR.trans (hoptimizerFloor i j).1 + have hXcomp : βˆ€ i j, (explicitOptimizerFloor A : ℝ) ≀ 1 - X i j := by + intro i j + exact hΞ΄leR.trans (hoptimizerFloor i j).2 + have hAposR : Matrix.Positive (fun i j ↦ (A i j : ℝ)) := by + intro i j + exact Rat.cast_pos.mpr (hApos i j) + have hXint : βˆ€ i, IsInteriorProbabilityVector (X i) := + regularizedBetheMaximizer_interior (by omega) hΟ„0 hAposR hX hmax + have hXqpos : βˆ€ i j, 0 < Xq i j := by + intro i j + exact Rat.cast_pos.mp (by simpa only [Y] using hYpos i j) + have hXqlt : βˆ€ i j, Xq i j < 1 := by + intro i j + have hij : (Xq i j : ℝ) < (1 : ℝ) := by + simpa only [Y] using hYlt i j + exact_mod_cast hij + let evaluationError : ℝ := + (4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A : β„š) + have heval : βˆ€ i j, + abs (-regularizedBetheGradient (Ο„q : ℝ) + (fun a b ↦ (A a b : ℝ)) Y i j - G i j) ≀ evaluationError := by + intro i j + have hb := directedNegativeGradient_bounds hΟ„0q.le hΟ„1q + (hApos i j) (hXqpos i j) (hXqlt i j) + (explicitOptimizerPrecision A) + have hexact : + negativeRegularizedBetheGradientCoordinate (Ο„q : ℝ) + (A i j : ℝ) (Xq i j : ℝ) = + -regularizedBetheGradient (Ο„q : ℝ) + (fun a b ↦ (A a b : ℝ)) Y i j := by + rw [negativeRegularizedBetheGradientCoordinate_eq_neg] + simp only [regularizedBetheGradient, Y] + have hlower : + (Gq i j : ℝ) ≀ + -regularizedBetheGradient (Ο„q : ℝ) + (fun a b ↦ (A a b : ℝ)) Y i j := by + rw [← hexact] + simpa only [Gq, directedNegativeGradientLowerMatrix, Ο„q] using hb.1 + have hupper : + -regularizedBetheGradient (Ο„q : ℝ) + (fun a b ↦ (A a b : ℝ)) Y i j ≀ + (directedNegativeGradientUpper Ο„q (A i j) (Xq i j) + (explicitOptimizerPrecision A) : ℝ) := by + rw [← hexact] + exact hb.2.1 + have hwidth : + (directedNegativeGradientUpper Ο„q (A i j) (Xq i j) + (explicitOptimizerPrecision A) : ℝ) - (Gq i j : ℝ) ≀ + evaluationError := by + simpa only [Gq, directedNegativeGradientLowerMatrix, Ο„q, evaluationError, + Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] using hb.2.2 + change abs (-regularizedBetheGradient (Ο„q : ℝ) + (fun a b ↦ (A a b : ℝ)) Y i j - (Gq i j : ℝ)) ≀ evaluationError + rw [abs_of_nonneg (sub_nonneg.mpr hlower)] + linarith + have hscale : + 4 * (explicitOptimizerGap A : ℝ) ≀ + (Ο„q : ℝ) * (explicitOptimizerRho A : ℝ) ^ 2 := by + have hscaleQ := explicitOptimizerGap_scale A + exact (by exact_mod_cast hscaleQ : + 4 * (explicitOptimizerGap A : ℝ) = + (Ο„q : ℝ) * (explicitOptimizerRho A : ℝ) ^ 2).le + have hsmall := approximateLogKKT_of_objective_gap + (ΞΉ := Fin (m + 1)) (by simp; omega) + hΟ„0 hΟ„1 hρ hΞ΄ hscale hX hY' hmax + (by simpa only [Ο„q, Y] using hgap) hXint hXlo hYlo' + hXcomp hYcomp heval (0 : Fin (m + 1)) (0 : Fin (m + 1)) + have hbudgetQ := explicitOptimizerKKTError_le A + have hbudget : + evaluationError + 4 * + (evaluationError + 3 * (explicitOptimizerRho A : ℝ) / + (explicitOptimizerFloor A : ℝ)) ≀ + (explicitKKTError : ℝ) := by + have hbudgetR := (Rat.cast_le (K := ℝ)).mpr hbudgetQ + norm_num only [Rat.cast_add, Rat.cast_mul, Rat.cast_div, Rat.cast_pow, + Rat.cast_one, Rat.cast_ofNat] at hbudgetR + dsimp only [evaluationError] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] + exact hbudgetR + have hlarge := hsmall.mono hbudget + simpa only [Ο„q, Y, Gq, G, evaluationError, + anchoredRowPotential, + anchoredColumnPotential, Rat.cast_neg, Rat.cast_add, Rat.cast_sub, + Rat.cast_ofNat] using hlarge + +/-- The concrete rational matrix and anchored rational potentials satisfy the +fixed approximate logarithmic KKT equations. -/ +theorem explicitBetheOptimizer_hasApproximateLogKKT {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + HasApproximateLogKKT (explicitKKTError : ℝ) + (explicitRegularizationScale (m + 1) : ℝ) + (fun i j ↦ (A i j : ℝ)) + (fun i j ↦ ((explicitBetheOptimizerMatrix A i j : β„š) : ℝ)) + (fun i ↦ (explicitBetheOptimizerRowPotential A i : ℝ)) + (fun j ↦ (explicitBetheOptimizerColumnPotential A j : ℝ)) := by + obtain ⟨_, hY, hYlo, X, hX, hmax, hgap⟩ := + explicitBetheOptimizerPoint_spec hm A hApos hAupper + simpa only [explicitBetheOptimizerGradient, + explicitBetheOptimizerRowPotential, + explicitBetheOptimizerColumnPotential] using + hasApproximateLogKKT_of_explicitOptimizerSpec hm A hApos hAupper + (explicitBetheOptimizerMatrix A) hY hYlo X hX hmax hgap + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheThresholdFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheThresholdFeasibility.lean new file mode 100644 index 0000000000..7798908b96 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBetheThresholdFeasibility.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScheduledFeasibility +public import Mathlib.Tactic + +/-! # Explicit Bethe Threshold Feasibility -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Bethe threshold feasibility with the explicit ball schedule + +This is the threshold runner implemented by the finite-word optimizer. It +uses the same rational oracle and iteration budget as +`runBetheThresholdFeasibility`, but its rounding precision is computed from +the two explicit zero-ball exponents rather than a matrix LCM. +-/ + +/-- Run the explicit ball-based feasibility routine on the bounded Bethe epigraph oracle at the +given threshold. -/ +def runExplicitBetheThresholdFeasibility {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper r : β„š) : + RationalFeasibilityResult (m * m + 1) := + let R := betheEpigraphOuterRadius m upper r + runExplicitBallRationalFeasibility + (betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) + (betheThresholdFeasibilityBudget m upper r) R + +theorem runExplicitBetheThresholdFeasibility_acceptsOnly {m : β„•} + (Ο„ : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (Ξ΄ upper r : β„š) {q : Fin (m * m + 1) β†’ β„š} + (hrun : runExplicitBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = + .accepted q) : + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q := by + exact runExplicitBallRationalFeasibility_acceptsOnly + (betheBoundedEpigraphOracle_acceptsOnly Ο„ A p Ξ΄ upper) + (by simpa only [runExplicitBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun) + +theorem runExplicitBetheThresholdFeasibility_accepts_of_slack + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ upper r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (hslack : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper : ℝ)) + (p : β„•) : + βˆƒ q : Fin (m * m + 1) β†’ β„š, + runExplicitBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = + .accepted q ∧ + BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper q := by + let Ξ΄0 : β„š := numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) Ο„ + have hoptimizerFloor : βˆ€ i j, (Ξ΄0 : ℝ) ≀ X i j := by + intro i j + exact (regularizedOptimizer_meets_executable_floor + (n := m + 1) (by omega) hΟ„0 hApos hAupper hX hmax i j).1 + have hcross := BetheEpigraphTarget_smoothed_inner_cross hm hΟ„0.le hΟ„1 + hApos hAupper hX hoptimizerFloor + (Rat.cast_pos.mpr hmix0) (by exact_mod_cast hmix1) + (Rat.cast_nonneg.mpr hr.le) (by + have hs := (Rat.cast_le (K := ℝ)).mpr hspike + norm_num only [Rat.cast_div, Rat.cast_one, Rat.cast_natCast] at hs + simpa using hs) + (Ξ΄ := (Ξ΄ : ℝ)) (upper := (upper : ℝ)) (by + exact_mod_cast hfloor) hslack + let ycenter := squareMatrixToVector (smoothedUniformAffineBase X (mix : ℝ)) + let zcenter := epigraphPoint ycenter ((upper : ℝ) - (r : ℝ)) + have hcross' : + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ) + (fun i ↦ zcenter i + if i = k then (r : ℝ) else 0)) ∧ + (βˆ€ k, BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ) + (fun i ↦ zcenter i - if i = k then (r : ℝ) else 0)) := by + simpa only [ycenter, zcenter] using hcross + have houter := BetheEpigraphTarget_inner_cross_outer_zero hm + (Rat.cast_nonneg.mpr hΞ΄.le) (Rat.cast_nonneg.mpr hr.le) ycenter + hcross'.1 hcross'.2 + have hR : 0 < betheEpigraphOuterRadius m upper r := + betheEpigraphOuterRadius_pos m hr.le + obtain ⟨q, hrun, hgood⟩ := + runExplicitBallRationalFeasibility_ball_accepts + (d := m * m + 1) (by omega) + (Target := BetheEpigraphTarget (Ο„ : ℝ) (fun i j ↦ (A i j : ℝ)) + (Ξ΄ : ℝ) (upper : ℝ)) + (Good := BetheEpigraphOracleAccepted Ο„ A p Ξ΄ upper) + (oracle := betheBoundedEpigraphOracle Ο„ A p Ξ΄ upper) + (betheBoundedEpigraphOracle_valid hm hΟ„0.le hΟ„1 hApos hΞ΄ p upper) + (betheBoundedEpigraphOracle_acceptsOnly Ο„ A p Ξ΄ upper) + hR hr hcross'.1 hcross'.2 + (by + intro k + have hk := houter.1 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + (by + intro k + have hk := houter.2 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + refine ⟨q, ?_, hgood⟩ + simpa only [runExplicitBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun + +theorem runExplicitBetheThresholdFeasibility_exhausted_lt_optimum_add_slack + {m : β„•} (hm : 0 < m) {Ο„ : β„š} (hΟ„0 : 0 < Ο„) (hΟ„1 : Ο„ ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix Ξ΄ upper r : β„š} (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hΞ΄ : 0 < Ξ΄) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : Ξ΄ ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) Ο„) + (p : β„•) {E : RationalEllipsoidState (m * m + 1)} + (hrun : runExplicitBetheThresholdFeasibility Ο„ A p Ξ΄ upper r = + .exhausted E) : + (upper : ℝ) < + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) := by + by_contra hnot + have hslack : + -regularizedBetheObjective (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper : ℝ) := not_lt.mp hnot + obtain ⟨q, haccepted, _⟩ := + runExplicitBetheThresholdFeasibility_accepts_of_slack + hm hΟ„0 hΟ„1 hApos hAupper hX hmax hmix0 hmix1 hΞ΄ hr + hspike hfloor hslack p + rw [hrun] at haccepted + contradiction + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBounds.lean new file mode 100644 index 0000000000..dcf752ae0d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitBounds.lean @@ -0,0 +1,745 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CleanConstants +public import LeanPool.BeyondBethe.BeyondBethe.NumericalWitness +public import LeanPool.BeyondBethe.BeyondBethe.GoodRowScore +public import LeanPool.BeyondBethe.BeyondBethe.DirectedElementary +public import Mathlib.Analysis.Complex.ExponentialBounds +public import Mathlib.Tactic + +/-! # Explicit Bounds -/ + +@[expose] public section + +open scoped Topology + +namespace BeyondBethe + +/-! +# Explicit analytic bounds for the structural constants + +The qualitative proof originally selected its absolute constants from +continuity neighborhoods. This file develops quantitative estimates instead. +They will be used to replace every such choice by fixed rational data. +-/ + +/-- The entropy singularity at zero has an explicit square-root modulus. -/ +theorem abs_negMulLog_lt_two_sqrt_abs {x : ℝ} (hx : abs x ≀ 1) : + abs (Real.negMulLog x) ≀ 2 * Real.sqrt (abs x) := by + by_cases hx0 : x = 0 + Β· subst x + simp + have hax : 0 < abs x := abs_pos.mpr hx0 + have hseries := Real.abs_log_mul_self_rpow_lt (abs x) (1 / 2 : ℝ) + hax hx (by norm_num) + rw [← Real.sqrt_eq_rpow] at hseries + have hsqrt : 0 ≀ Real.sqrt (abs x) := Real.sqrt_nonneg _ + have hsquare : Real.sqrt (abs x) * Real.sqrt (abs x) = abs x := by + nlinarith [Real.sq_sqrt (abs_nonneg x)] + have hfactor : + abs (Real.negMulLog x) = + Real.sqrt (abs x) * abs (Real.log (abs x) * Real.sqrt (abs x)) := by + calc + abs (Real.negMulLog x) = abs x * abs (Real.log x) := by + simp [Real.negMulLog_def] + _ = abs x * abs (Real.log (abs x)) := by rw [Real.log_abs] + _ = Real.sqrt (abs x) * + abs (Real.log (abs x) * Real.sqrt (abs x)) := by + rw [abs_mul, abs_of_nonneg hsqrt] + calc + abs x * abs (Real.log (abs x)) = + (Real.sqrt (abs x) * Real.sqrt (abs x)) * + abs (Real.log (abs x)) := by rw [hsquare] + _ = Real.sqrt (abs x) * + (abs (Real.log (abs x)) * Real.sqrt (abs x)) := by ring + rw [hfactor] + have htwo : abs (Real.log (abs x) * Real.sqrt (abs x)) < 2 := by + norm_num at hseries ⊒ + exact hseries + exact (mul_le_mul_of_nonneg_left htwo.le hsqrt).trans_eq (by ring) + +/-- On a positive interval bounded away from zero, logarithm has the expected +elementary Lipschitz bound. -/ +theorem abs_log_sub_log_le_div {a x y : ℝ} + (ha : 0 < a) (hax : a ≀ x) (hay : a ≀ y) : + abs (Real.log x - Real.log y) ≀ abs (x - y) / a := by + have hx : 0 < x := ha.trans_le hax + have hy : 0 < y := ha.trans_le hay + rcases le_total x y with hxy | hyx + Β· have hlogxy : Real.log x ≀ Real.log y := + Real.strictMonoOn_log.monotoneOn hx hy hxy + rw [abs_of_nonpos (sub_nonpos.mpr hlogxy), abs_of_nonpos (sub_nonpos.mpr hxy)] + rw [neg_sub, neg_sub, ← Real.log_div hy.ne' hx.ne'] + calc + Real.log (y / x) ≀ y / x - 1 := + Real.log_le_sub_one_of_pos (div_pos hy hx) + _ = (y - x) / x := by field_simp + _ ≀ (y - x) / a := by + exact div_le_div_of_nonneg_left (sub_nonneg.mpr hxy) ha hax + Β· have hlogyx : Real.log y ≀ Real.log x := + Real.strictMonoOn_log.monotoneOn hy hx hyx + rw [abs_of_nonneg (sub_nonneg.mpr hlogyx), abs_of_nonneg (sub_nonneg.mpr hyx)] + rw [← Real.log_div hx.ne' hy.ne'] + calc + Real.log (x / y) ≀ x / y - 1 := + Real.log_le_sub_one_of_pos (div_pos hx hy) + _ = (x - y) / y := by field_simp + _ ≀ (x - y) / a := by + exact div_le_div_of_nonneg_left (sub_nonneg.mpr hyx) ha hay + +/-- A coarse numerical log bound on the fixed interval used by the good-row +argument. Its slack is intentional: only an absolute modulus is needed. -/ +theorem abs_log_le_two_of_mem {x : ℝ} + (hxlo : (3 / 10 : ℝ) ≀ x) (hxhi : x ≀ 3 / 2) : + abs (Real.log x) ≀ 2 := by + have hx : 0 < x := (by norm_num : (0 : ℝ) < 3 / 10).trans_le hxlo + have he : Real.exp (-2) < (1 / 4 : ℝ) := by + rw [show (-2 : ℝ) = -1 + -1 by ring, Real.exp_add] + have h := Real.exp_neg_one_lt_half + have hp := Real.exp_pos (-1) + nlinarith + have hlow : -2 < Real.log x := by + rw [← Real.exp_lt_exp, Real.exp_log hx] + exact (he.trans_le (show (1 / 4 : ℝ) ≀ 3 / 10 by norm_num)).trans_le hxlo + have hupp : Real.log x ≀ 1 / 2 := by + exact (Real.log_le_sub_one_of_pos hx).trans (by linarith) + exact abs_le.mpr ⟨by linarith, by linarith⟩ + +/-- `negMulLog` is explicitly Lipschitz on `[3/10,6/5]`. -/ +theorem abs_negMulLog_sub_le_six_mul {x y : ℝ} + (hxlo : (3 / 10 : ℝ) ≀ x) (hxhi : x ≀ 6 / 5) + (hylo : (3 / 10 : ℝ) ≀ y) (hyhi : y ≀ 6 / 5) : + abs (Real.negMulLog x - Real.negMulLog y) ≀ 6 * abs (x - y) := by + have hlogx := abs_log_le_two_of_mem hxlo (hxhi.trans (by norm_num)) + have hlogdiff := abs_log_sub_log_le_div + (a := (3 / 10 : ℝ)) (by norm_num) hxlo hylo + have hy0 : 0 ≀ y := (by norm_num : (0 : ℝ) ≀ 3 / 10).trans hylo + rw [Real.negMulLog_def] + have hid : + -x * Real.log x - -y * Real.log y = + -(x - y) * Real.log x - y * (Real.log x - Real.log y) := by ring + rw [hid] + calc + abs (-(x - y) * Real.log x - y * (Real.log x - Real.log y)) ≀ + abs (-(x - y) * Real.log x) + + abs (y * (Real.log x - Real.log y)) := abs_sub _ _ + _ = abs (x - y) * abs (Real.log x) + + y * abs (Real.log x - Real.log y) := by + rw [abs_mul, abs_neg, abs_mul, abs_of_nonneg hy0] + _ ≀ abs (x - y) * 2 + y * (abs (x - y) / (3 / 10 : ℝ)) := by + gcongr + _ ≀ 6 * abs (x - y) := by + have hd : 0 ≀ abs (x - y) := abs_nonneg _ + have hycoef : (10 / 3 : ℝ) * y ≀ 4 := by nlinarith + have hterm : y * (abs (x - y) / (3 / 10 : ℝ)) ≀ + 4 * abs (x - y) := by + calc + y * (abs (x - y) / (3 / 10 : ℝ)) = + ((10 / 3 : ℝ) * y) * abs (x - y) := by ring + _ ≀ 4 * abs (x - y) := + mul_le_mul_of_nonneg_right hycoef hd + linarith + +/-- A product-log estimate on the same fixed interval. -/ +theorem abs_mul_log_sub_mul_log_le + {x y s t : ℝ} + (hx : abs x ≀ 6 / 5) (hy : abs y ≀ 6 / 5) + (hslo : (3 / 10 : ℝ) ≀ s) (hshi : s ≀ 3 / 2) + (htlo : (3 / 10 : ℝ) ≀ t) (hthi : t ≀ 3 / 2) : + abs (x * Real.log s - y * Real.log t) ≀ + 2 * abs (x - y) + 4 * abs (s - t) := by + have hlogs := abs_log_le_two_of_mem hslo hshi + have hlogdiff := abs_log_sub_log_le_div + (a := (3 / 10 : ℝ)) (by norm_num) hslo htlo + have hid : x * Real.log s - y * Real.log t = + (x - y) * Real.log s + y * (Real.log s - Real.log t) := by ring + rw [hid] + calc + abs ((x - y) * Real.log s + y * (Real.log s - Real.log t)) ≀ + abs ((x - y) * Real.log s) + + abs (y * (Real.log s - Real.log t)) := abs_add_le _ _ + _ = abs (x - y) * abs (Real.log s) + + abs y * abs (Real.log s - Real.log t) := by rw [abs_mul, abs_mul] + _ ≀ abs (x - y) * 2 + + (6 / 5 : ℝ) * (abs (s - t) / (3 / 10 : ℝ)) := by gcongr + _ = 2 * abs (x - y) + 4 * abs (s - t) := by ring + +/-- Binary entropy is explicitly Lipschitz on `[3/10,7/10]`. -/ +theorem abs_binaryEntropy_sub_half_le {p : ℝ} + (hp0 : (3 / 10 : ℝ) ≀ p) (hp1 : p ≀ 7 / 10) : + abs (binaryEntropy p - Real.log 2) ≀ 12 * abs (p - 1 / 2) := by + have h1p0 : (3 / 10 : ℝ) ≀ 1 - p := by linarith + have h1p1 : 1 - p ≀ 7 / 10 := by linarith + have hp := abs_negMulLog_sub_le_six_mul hp0 (hp1.trans (by norm_num)) + (show (3 / 10 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 6 / 5 by norm_num) + have h1p := abs_negMulLog_sub_le_six_mul h1p0 (h1p1.trans (by norm_num)) + (show (3 / 10 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 6 / 5 by norm_num) + rw [binaryEntropy, Real.negMulLog_def] + have hloghalf : Real.log (1 / 2 : ℝ) = -Real.log 2 := by + rw [show (1 / 2 : ℝ) = (2 : ℝ)⁻¹ by norm_num, Real.log_inv] + have hcenter : + -((1 / 2 : ℝ) * Real.log (1 / 2 : ℝ)) + + -((1 / 2 : ℝ) * Real.log (1 / 2 : ℝ)) = Real.log 2 := by + rw [hloghalf] + ring + rw [← hcenter] + have hid : + (-p * Real.log p + -(1 - p) * Real.log (1 - p)) - + (-((1 / 2 : ℝ) * Real.log (1 / 2 : ℝ)) + + -((1 / 2 : ℝ) * Real.log (1 / 2 : ℝ))) = + (Real.negMulLog p - Real.negMulLog (1 / 2 : ℝ)) + + (Real.negMulLog (1 - p) - Real.negMulLog (1 / 2 : ℝ)) := by + simp only [Real.negMulLog_def] + ring + rw [hid] + calc + abs ((Real.negMulLog p - Real.negMulLog (1 / 2 : ℝ)) + + (Real.negMulLog (1 - p) - Real.negMulLog (1 / 2 : ℝ))) ≀ + abs (Real.negMulLog p - Real.negMulLog (1 / 2 : ℝ)) + + abs (Real.negMulLog (1 - p) - Real.negMulLog (1 / 2 : ℝ)) := + abs_add_le _ _ + _ ≀ 6 * abs (p - 1 / 2) + + 6 * abs ((1 - p) - 1 / 2) := add_le_add hp h1p + _ = 12 * abs (p - 1 / 2) := by + congr 1 + rw [show (1 - p) - 1 / 2 = -(p - 1 / 2) by ring, abs_neg] + ring + +/-- The suffix error with a small suffix mass has an explicit square-root +modulus around `(1/2,0)`. -/ +theorem abs_continuousSuffixError_near_zero + {u q r : ℝ} (hr0 : 0 ≀ r) (hr1 : r ≀ 1 / 10) + (hu : abs (u - 1 / 2) ≀ r) (hq : abs q ≀ r) : + abs (continuousSuffixError u q - + continuousSuffixError (1 / 2) 0) ≀ + 11 * r + 2 * Real.sqrt r := by + have hu' := abs_le.mp hu + have hq' := abs_le.mp hq + have hu0 : (2 / 5 : ℝ) ≀ u := by linarith + have hu1 : u ≀ 3 / 5 := by linarith + have hq0 : -(1 / 10 : ℝ) ≀ q := by linarith + have hq1 : q ≀ 1 / 10 := by linarith + have hs0 : (3 / 10 : ℝ) ≀ u + q := by linarith + have hs1 : u + q ≀ 7 / 10 := by linarith + have hqabs : abs q ≀ 6 / 5 := hq.trans (hr1.trans (by norm_num)) + have hprod := abs_mul_log_sub_mul_log_le + hqabs (by norm_num : abs (0 : ℝ) ≀ 6 / 5) + hs0 (hs1.trans (by norm_num)) + (show (3 / 10 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 3 / 2 by norm_num) + have hsdev : abs ((u + q) - 1 / 2) ≀ 2 * r := by + calc + abs ((u + q) - 1 / 2) = abs ((u - 1 / 2) + q) := by ring + _ ≀ abs (u - 1 / 2) + abs q := abs_add_le _ _ + _ ≀ r + r := add_le_add hu hq + _ = 2 * r := by ring + have hprod' : abs (q * Real.log (u + q) - + 0 * Real.log (1 / 2)) ≀ 10 * r := by + calc + abs (q * Real.log (u + q) - 0 * Real.log (1 / 2)) ≀ + 2 * abs (q - 0) + 4 * abs ((u + q) - 1 / 2) := hprod + _ ≀ 2 * r + 4 * (2 * r) := by gcongr <;> simpa using hq + _ = 10 * r := by ring + have hnml := abs_negMulLog_lt_two_sqrt_abs + (x := q) (hq.trans (hr1.trans (by norm_num))) + have hsqrt : Real.sqrt (abs q) ≀ Real.sqrt r := + Real.sqrt_le_sqrt hq + have hnml' : abs (Real.negMulLog q - Real.negMulLog 0) ≀ + 2 * Real.sqrt r := by + simpa using hnml.trans (mul_le_mul_of_nonneg_left hsqrt (by norm_num)) + simp only [continuousSuffixError] + have hid : + (u - q * Real.log (u + q) - Real.negMulLog q) - + ((1 / 2 : ℝ) - 0 * Real.log (1 / 2 + 0) - Real.negMulLog 0) = + (u - 1 / 2) - + (q * Real.log (u + q) - 0 * Real.log (1 / 2)) - + (Real.negMulLog q - Real.negMulLog 0) := by ring + rw [hid] + calc + abs ((u - 1 / 2) - + (q * Real.log (u + q) - 0 * Real.log (1 / 2)) - + (Real.negMulLog q - Real.negMulLog 0)) ≀ + abs (u - 1 / 2) + + abs (q * Real.log (u + q) - 0 * Real.log (1 / 2)) + + abs (Real.negMulLog q - Real.negMulLog 0) := by + calc + abs (((u - 1 / 2) - + (q * Real.log (u + q) - 0 * Real.log (1 / 2))) - + (Real.negMulLog q - Real.negMulLog 0)) ≀ + abs ((u - 1 / 2) - + (q * Real.log (u + q) - 0 * Real.log (1 / 2))) + + abs (Real.negMulLog q - Real.negMulLog 0) := abs_sub _ _ + _ ≀ (abs (u - 1 / 2) + + abs (q * Real.log (u + q) - 0 * Real.log (1 / 2))) + + abs (Real.negMulLog q - Real.negMulLog 0) := + add_le_add (abs_sub _ _) le_rfl + _ ≀ r + 10 * r + 2 * Real.sqrt r := + add_le_add (add_le_add hu hprod') hnml' + _ = 11 * r + 2 * Real.sqrt r := by ring + +/-- The nonsingular suffix terms are uniformly Lipschitz around +`(1/2,1/2)`. -/ +theorem abs_continuousSuffixError_near_half + {u v q r : ℝ} (hr0 : 0 ≀ r) (hr1 : r ≀ 1 / 10) + (hu : abs (u - 1 / 2) ≀ r) + (hv : abs (v - 1 / 2) ≀ r) (hq : abs q ≀ r) : + abs (continuousSuffixError u (v + q) - + continuousSuffixError (1 / 2) (1 / 2)) ≀ 29 * r := by + have hu' := abs_le.mp hu + have hv' := abs_le.mp hv + have hq' := abs_le.mp hq + have hxdev : abs ((v + q) - 1 / 2) ≀ 2 * r := by + calc + abs ((v + q) - 1 / 2) = abs ((v - 1 / 2) + q) := by ring + _ ≀ abs (v - 1 / 2) + abs q := abs_add_le _ _ + _ ≀ r + r := add_le_add hv hq + _ = 2 * r := by ring + have hsdev : abs ((u + (v + q)) - 1) ≀ 3 * r := by + calc + abs ((u + (v + q)) - 1) = + abs ((u - 1 / 2) + (v - 1 / 2) + q) := by ring + _ ≀ abs ((u - 1 / 2) + (v - 1 / 2)) + abs q := abs_add_le _ _ + _ ≀ (abs (u - 1 / 2) + abs (v - 1 / 2)) + abs q := by + gcongr + exact abs_add_le _ _ + _ ≀ (r + r) + r := by gcongr + _ = 3 * r := by ring + have hx0 : (3 / 10 : ℝ) ≀ v + q := by linarith + have hx1 : v + q ≀ 7 / 10 := by linarith + have hs0 : (7 / 10 : ℝ) ≀ u + (v + q) := by linarith + have hs1 : u + (v + q) ≀ 13 / 10 := by linarith + have hprod := abs_mul_log_sub_mul_log_le + (show abs (v + q) ≀ 6 / 5 by rw [abs_le]; constructor <;> linarith) + (by norm_num : abs (1 / 2 : ℝ) ≀ 6 / 5) + (show (3 / 10 : ℝ) ≀ u + (v + q) from hs0.trans' (by norm_num)) + (show u + (v + q) ≀ (3 / 2 : ℝ) from hs1.trans (by norm_num)) + (show (3 / 10 : ℝ) ≀ 1 by norm_num) + (show (1 : ℝ) ≀ 3 / 2 by norm_num) + have hprod' : + abs ((v + q) * Real.log (u + (v + q)) - + (1 / 2) * Real.log 1) ≀ 16 * r := by + calc + abs ((v + q) * Real.log (u + (v + q)) - + (1 / 2) * Real.log 1) ≀ + 2 * abs ((v + q) - 1 / 2) + + 4 * abs ((u + (v + q)) - 1) := hprod + _ ≀ 2 * (2 * r) + 4 * (3 * r) := by gcongr + _ = 16 * r := by ring + have hnml := abs_negMulLog_sub_le_six_mul hx0 + (hx1.trans (by norm_num)) + (show (3 / 10 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 6 / 5 by norm_num) + have hnml' : + abs (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) ≀ + 12 * r := by + calc + abs (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) ≀ + 6 * abs ((v + q) - 1 / 2) := hnml + _ ≀ 6 * (2 * r) := mul_le_mul_of_nonneg_left hxdev (by norm_num) + _ = 12 * r := by ring + simp only [continuousSuffixError] + have hid : + (u - (v + q) * Real.log (u + (v + q)) - Real.negMulLog (v + q)) - + ((1 / 2 : ℝ) - (1 / 2) * Real.log ((1 / 2) + (1 / 2)) - + Real.negMulLog (1 / 2)) = + (u - 1 / 2) - + ((v + q) * Real.log (u + (v + q)) - (1 / 2) * Real.log 1) - + (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) := by ring + rw [hid] + calc + abs ((u - 1 / 2) - + ((v + q) * Real.log (u + (v + q)) - (1 / 2) * Real.log 1) - + (Real.negMulLog (v + q) - Real.negMulLog (1 / 2))) ≀ + abs (u - 1 / 2) + + abs ((v + q) * Real.log (u + (v + q)) - (1 / 2) * Real.log 1) + + abs (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) := by + calc + abs (((u - 1 / 2) - + ((v + q) * Real.log (u + (v + q)) - + (1 / 2) * Real.log 1)) - + (Real.negMulLog (v + q) - Real.negMulLog (1 / 2))) ≀ + abs ((u - 1 / 2) - + ((v + q) * Real.log (u + (v + q)) - + (1 / 2) * Real.log 1)) + + abs (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) := + abs_sub _ _ + _ ≀ (abs (u - 1 / 2) + + abs ((v + q) * Real.log (u + (v + q)) - + (1 / 2) * Real.log 1)) + + abs (Real.negMulLog (v + q) - Real.negMulLog (1 / 2)) := + add_le_add (abs_sub _ _) le_rfl + _ ≀ r + 16 * r + 12 * r := add_le_add (add_le_add hu hprod') hnml' + _ = 29 * r := by ring + +/-- An explicit modulus for the complete three-variable good-row expression. +The constant `70` is deliberately loose; having a transparent computable +bound is more important than optimizing this one-time structural constant. -/ +theorem abs_continuousGoodRowPsi_sub_center_le + {u v q r : ℝ} (hr0 : 0 ≀ r) (hr1 : r ≀ 1 / 10) + (hu : abs (u - 1 / 2) ≀ r) + (hv : abs (v - 1 / 2) ≀ r) (hq : abs q ≀ r) : + abs (continuousGoodRowPsi u v q - + continuousGoodRowPsi (1 / 2) (1 / 2) 0) ≀ + 70 * Real.sqrt r := by + have hu' := abs_le.mp hu + have hv' := abs_le.mp hv + have hq' := abs_le.mp hq + have hden0 : 9 / 10 ≀ 1 - q := by linarith + have hden1 : 1 - q ≀ 11 / 10 := by linarith + have hdenpos : 0 < 1 - q := (by norm_num : (0 : ℝ) < 9 / 10).trans_le hden0 + let p : ℝ := u / (1 - q) + have hpdev : abs (p - 1 / 2) ≀ 2 * r := by + have hnum : abs ((u - 1 / 2) + q / 2) ≀ 3 * r / 2 := by + calc + abs ((u - 1 / 2) + q / 2) ≀ + abs (u - 1 / 2) + abs (q / 2) := abs_add_le _ _ + _ = abs (u - 1 / 2) + abs q / 2 := by + rw [abs_div, show abs (2 : ℝ) = 2 by norm_num] + _ ≀ r + r / 2 := by gcongr + _ = 3 * r / 2 := by ring + have hid : p - 1 / 2 = ((u - 1 / 2) + q / 2) / (1 - q) := by + dsimp only [p] + field_simp + ring + rw [hid, abs_div, abs_of_pos hdenpos] + rw [div_le_iffβ‚€ hdenpos] + calc + abs ((u - 1 / 2) + q / 2) ≀ 3 * r / 2 := hnum + _ ≀ 2 * r * (1 - q) := by + have : (9 / 10 : ℝ) ≀ 1 - q := hden0 + nlinarith + have hp0 : (3 / 10 : ℝ) ≀ p := by + have := (abs_le.mp hpdev).1 + linarith + have hp1 : p ≀ 7 / 10 := by + have := (abs_le.mp hpdev).2 + linarith + have hH := abs_binaryEntropy_sub_half_le hp0 hp1 + have hH' : abs (Real.binEntropy p - Real.log 2) ≀ 24 * r := by + rw [← binaryEntropy_eq_realBinEntropy] + exact hH.trans (by + calc + 12 * abs (p - 1 / 2) ≀ 12 * (2 * r) := + mul_le_mul_of_nonneg_left hpdev (by norm_num) + _ = 24 * r := by ring) + have hlog2pos : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hlog2one : abs (Real.log 2) ≀ 1 := by + rw [abs_of_pos hlog2pos] + exact Real.log_two_lt_d9.le.trans (by norm_num) + have hdenabs : abs (1 - q) ≀ 11 / 10 := by + rw [abs_of_pos hdenpos] + exact hden1 + have hmain : + abs ((1 - q) * Real.binEntropy p - Real.log 2) ≀ 28 * r := by + have hid : (1 - q) * Real.binEntropy p - Real.log 2 = + (1 - q) * (Real.binEntropy p - Real.log 2) - q * Real.log 2 := by ring + rw [hid] + calc + abs ((1 - q) * (Real.binEntropy p - Real.log 2) - q * Real.log 2) ≀ + abs ((1 - q) * (Real.binEntropy p - Real.log 2)) + + abs (q * Real.log 2) := abs_sub _ _ + _ = abs (1 - q) * abs (Real.binEntropy p - Real.log 2) + + abs q * abs (Real.log 2) := by rw [abs_mul, abs_mul] + _ ≀ (11 / 10 : ℝ) * (24 * r) + r * 1 := by gcongr + _ ≀ 28 * r := by nlinarith + have hU0 := abs_continuousSuffixError_near_zero hr0 hr1 hu hq + have hV0 := abs_continuousSuffixError_near_zero hr0 hr1 hv hq + have hUV := abs_continuousSuffixError_near_half hr0 hr1 hu hv hq + have hVU := abs_continuousSuffixError_near_half hr0 hr1 hv hu hq + let dU0 := continuousSuffixError u q - continuousSuffixError (1 / 2) 0 + let dUV := continuousSuffixError u (v + q) - + continuousSuffixError (1 / 2) (1 / 2) + let dV0 := continuousSuffixError v q - continuousSuffixError (1 / 2) 0 + let dVU := continuousSuffixError v (u + q) - + continuousSuffixError (1 / 2) (1 / 2) + have hsum : abs (dU0 + dUV + dV0 + dVU) ≀ + (11 * r + 2 * Real.sqrt r) + 29 * r + + (11 * r + 2 * Real.sqrt r) + 29 * r := by + calc + abs (dU0 + dUV + dV0 + dVU) ≀ + abs (dU0 + dUV + dV0) + abs dVU := abs_add_le _ _ + _ ≀ (abs (dU0 + dUV) + abs dV0) + abs dVU := + add_le_add (abs_add_le _ _) le_rfl + _ ≀ (abs dU0 + abs dUV + abs dV0) + abs dVU := + add_le_add (add_le_add (abs_add_le _ _) le_rfl) le_rfl + _ = abs dU0 + abs dUV + abs dV0 + abs dVU := by ring + _ ≀ (11 * r + 2 * Real.sqrt r) + 29 * r + + (11 * r + 2 * Real.sqrt r) + 29 * r := by + dsimp only [dU0, dUV, dV0, dVU] + gcongr + have hbin : Real.binEntropy (1 / 2 : ℝ) = Real.log 2 := by + rw [show (1 / 2 : ℝ) = 2⁻¹ by norm_num, Real.binEntropy_two_inv] + have hid : + continuousGoodRowPsi u v q - + continuousGoodRowPsi (1 / 2) (1 / 2) 0 = + ((1 - q) * Real.binEntropy p - Real.log 2) + + (1 / 2) * (dU0 + dUV + dV0 + dVU) := by + dsimp only [p, dU0, dUV, dV0, dVU] + simp only [continuousGoodRowPsi, sub_zero, div_one, add_zero, one_mul] + rw [hbin] + ring + rw [hid] + have hsqrt0 : 0 ≀ Real.sqrt r := Real.sqrt_nonneg _ + have hrleone : r ≀ 1 := hr1.trans (by norm_num) + have hrle : r ≀ Real.sqrt r := by + rw [Real.le_sqrt hr0 hr0] + nlinarith + calc + abs (((1 - q) * Real.binEntropy p - Real.log 2) + + (1 / 2) * (dU0 + dUV + dV0 + dVU)) ≀ + abs ((1 - q) * Real.binEntropy p - Real.log 2) + + abs ((1 / 2) * (dU0 + dUV + dV0 + dVU)) := abs_add_le _ _ + _ = abs ((1 - q) * Real.binEntropy p - Real.log 2) + + (1 / 2) * abs (dU0 + dUV + dV0 + dVU) := by + rw [abs_mul, abs_of_nonneg (by norm_num : (0 : ℝ) ≀ 1 / 2)] + _ ≀ 28 * r + (1 / 2) * + ((11 * r + 2 * Real.sqrt r) + 29 * r + + (11 * r + 2 * Real.sqrt r) + 29 * r) := by gcongr + _ = 68 * r + 2 * Real.sqrt r := by ring + _ ≀ 70 * Real.sqrt r := by nlinarith + +/-- The compact supremum used by the structural proof is bounded by the +explicit modulus above. -/ +theorem goodRowOmega_le_seventy_sqrt_radius (Ξ· : ℝ) : + goodRowOmega Ξ· ≀ 70 * Real.sqrt (goodRowRadius Ξ·) := by + unfold goodRowOmega + apply csSup_le ((goodRowBall_nonempty Ξ·).image goodRowDeviation) + intro y hy + obtain ⟨z, hz, rfl⟩ := hy + have hz' := hz + rw [Metric.mem_closedBall, Prod.dist_eq, max_le_iff, + Prod.dist_eq, max_le_iff, Real.dist_eq, Real.dist_eq, + Real.dist_eq] at hz' + rcases hz' with ⟨hu, hv, hq⟩ + simp only [goodRowCenter, Prod.fst, Prod.snd, sub_zero] at hu hv hq + have hbound := abs_continuousGoodRowPsi_sub_center_le + (goodRowRadius_nonneg Ξ·) (goodRowRadius_le_tenth Ξ·) hu hv hq + have hc : continuousGoodRowPsi (1 / 2) (1 / 2) 0 = Real.log 2 / 2 := by + simpa [goodRowCenter] using continuousGoodRowPsi_center + rw [goodRowDeviation, ← hc, abs_sub_comm] + exact hbound + +theorem goodRowOmega_le_seventy_sqrt + {Ξ· : ℝ} (hΞ·0 : 0 ≀ Ξ·) (hΞ·1 : Ξ· ≀ 1 / 10) : + goodRowOmega Ξ· ≀ 70 * Real.sqrt Ξ· := by + simpa [goodRowRadius_eq hΞ·0 hΞ·1] using + goodRowOmega_le_seventy_sqrt_radius Ξ· + +/-- An exact algebraic form of the clean core on its natural domain. -/ +theorem cleanCoreFunction_eq_expanded + {ΞΊ ρ : ℝ} (hρ : ρ < 1) : + cleanCoreFunction ΞΊ ρ = + Real.log 2 - ρ * Real.log 2 - 2 * ΞΊ + ρ * ΞΊ - + (1 - ρ) * Real.log (1 - ρ) - Real.negMulLog ρ - ρ := by + have hden : 0 < 1 - ρ := sub_pos.mpr hρ + have hexp : Real.exp (-ΞΊ) β‰  0 := (Real.exp_pos _).ne' + rw [cleanCoreFunction, Real.log_div (mul_ne_zero (by norm_num) (pow_ne_zero 2 hexp)) + hden.ne', Real.log_mul (by norm_num : (2 : ℝ) β‰  0) (pow_ne_zero 2 hexp), + Real.log_pow, Real.log_exp] + ring + +/-- A simple lower bound for the clean core. -/ +theorem cleanCoreFunction_lower + {ΞΊ ρ : ℝ} (hΞΊ : 0 ≀ ΞΊ) (hρ0 : 0 ≀ ρ) (hρ1 : ρ < 1) : + Real.log 2 - ρ * Real.log 2 - 2 * ΞΊ - Real.negMulLog ρ - ρ ≀ + cleanCoreFunction ΞΊ ρ := by + rw [cleanCoreFunction_eq_expanded hρ1] + have hκρ : 0 ≀ ρ * ΞΊ := mul_nonneg hρ0 hΞΊ + have hlog : Real.log (1 - ρ) ≀ 0 := + Real.log_nonpos (sub_nonneg.mpr hρ1.le) (by linarith) + have hden : 0 ≀ 1 - ρ := sub_nonneg.mpr hρ1.le + have hterm : 0 ≀ -(1 - ρ) * Real.log (1 - ρ) := + mul_nonneg_of_nonpos_of_nonpos (neg_nonpos.mpr hden) hlog + linarith + +/-- The fixed local-cost threshold used by the executable proof. -/ +def explicitKappa : β„š := 1 / 1000 + +theorem explicitKappa_pos : 0 < explicitKappa := by + norm_num [explicitKappa] + +theorem leakageEnvelope_explicitKappa_le : + leakageEnvelope (explicitKappa : ℝ) ≀ 1 / 250 := by + have hkabs : abs ((explicitKappa : β„š) : ℝ) ≀ 1 := by + norm_num [explicitKappa] + have hexp := Real.abs_exp_sub_one_le hkabs + have hnonneg : 0 ≀ Real.exp ((explicitKappa : β„š) : ℝ) - 1 := by + rw [sub_nonneg, ← Real.exp_zero] + exact Real.exp_le_exp.mpr (by norm_num [explicitKappa]) + rw [abs_of_nonneg hnonneg] at hexp + rw [leakageEnvelope] + norm_num [explicitKappa] at hexp ⊒ + linarith + +theorem explicitKappa_cleanCore + {ρ : ℝ} (hρ0 : 0 ≀ ρ) + (hρbar : ρ ≀ leakageEnvelope (explicitKappa : ℝ)) : + Real.log 2 / 2 < cleanCoreFunction (explicitKappa : ℝ) ρ := by + have hρ250 : ρ ≀ 1 / 250 := + hρbar.trans leakageEnvelope_explicitKappa_le + have hρ1 : ρ < 1 := hρ250.trans_lt (by norm_num) + have hρabs : abs ρ ≀ 1 := by + rw [abs_of_nonneg hρ0] + exact hρ250.trans (by norm_num) + have hnmlabs := abs_negMulLog_lt_two_sqrt_abs hρabs + have hnml : Real.negMulLog ρ ≀ 2 / 15 := by + calc + Real.negMulLog ρ ≀ abs (Real.negMulLog ρ) := le_abs_self _ + _ ≀ 2 * Real.sqrt ρ := by simpa [abs_of_nonneg hρ0] using hnmlabs + _ ≀ 2 * (1 / 15 : ℝ) := by + gcongr + rw [Real.sqrt_le_iff] + constructor + Β· norm_num + Β· nlinarith + _ = 2 / 15 := by ring + have hcore := cleanCoreFunction_lower + (ΞΊ := ((explicitKappa : β„š) : ℝ)) (ρ := ρ) + (by norm_num [explicitKappa]) hρ0 hρ1 + have hloglo := Real.log_two_gt_d9 + have hloghi := Real.log_two_lt_d9 + have hcore' : + Real.log 2 - ρ * Real.log 2 - 1 / 500 - Real.negMulLog ρ - ρ ≀ + cleanCoreFunction (explicitKappa : ℝ) ρ := by + convert hcore using 1 <;> norm_num [explicitKappa] + have hρlog : ρ * Real.log 2 ≀ (1 / 250 : ℝ) * 0.6931471808 := by + calc + ρ * Real.log 2 ≀ (1 / 250 : ℝ) * Real.log 2 := + mul_le_mul_of_nonneg_right hρ250 (Real.log_pos (by norm_num)).le + _ ≀ (1 / 250 : ℝ) * 0.6931471808 := + mul_le_mul_of_nonneg_left hloghi.le (by norm_num) + have hhalf : Real.log 2 / 2 < 1 / 2 := by + linarith + have hlower : (1 / 2 : ℝ) < + Real.log 2 - ρ * Real.log 2 - 1 / 500 - Real.negMulLog ρ - ρ := by + nlinarith + exact hhalf.trans (hlower.trans_le hcore') + +/-- The clean-pair constants are fixed data, rather than values selected from +an unspecified continuity neighborhood. -/ +def explicitXiSource : β„š := 1 / 100 + +/-- The fixed rational structural gain parameter `1/4`. -/ +def explicitGamma : β„š := 1 / 4 + +theorem explicit_cleanPairGain_constants : + CleanPairGainGuarantee (explicitKappa : ℝ) + (explicitXiSource : ℝ) (explicitGamma : ℝ) := by + intro n ell ΞΎ Ο„ A X rscale cscale hell hlogn hΞΎ hΞΎβ‚€ hΟ„ + hApos hX hXint hrscale hcscale hKKT r s a b hrs hab hcost + have hellpos : 0 < ell := lt_of_lt_of_le (by norm_num) hell + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + let ρ := outsideMassTwo (pairAlpha X r s) a b + have hρnonneg : 0 ≀ ρ := by + dsimp only [ρ, outsideMassTwo] + exact Finset.sum_nonneg fun j _ ↦ pairAlpha_nonneg hX r s j + have hΞΊposR : 0 < ((explicitKappa : β„š) : ℝ) := by + exact_mod_cast explicitKappa_pos + by_cases hρzero : ρ = 0 + Β· have hbarNonneg : 0 ≀ leakageEnvelope ((explicitKappa : β„š) : ℝ) := by + rw [leakageEnvelope] + have hexp : 1 ≀ Real.exp ((explicitKappa : β„š) : ℝ) := by + rw [← Real.exp_zero] + exact Real.exp_le_exp.mpr hΞΊposR.le + linarith + have hcoreZero := explicitKappa_cleanCore (ρ := 0) le_rfl hbarNonneg + have hcoreLog : Real.log 2 / 2 < + Real.log (2 * (Real.exp (-((explicitKappa : β„š) : ℝ))) ^ 2) := by + simpa [cleanCoreFunction] using hcoreZero + have hgain := log_pairGain_ge_core_of_zeroLeakage + hΟ„pos.le hApos hX hXint hrscale hcscale hKKT hrs hab hcost + (by simpa only [ρ] using hρzero) + have hgamma : ((explicitGamma : β„š) : ℝ) < Real.log 2 / 2 := by + have := Real.log_two_gt_d9 + norm_num [explicitGamma] at * + linarith + exact le_of_lt (hgamma.trans (hcoreLog.trans_le hgain)) + Β· have hρpos : 0 < ρ := lt_of_le_of_ne hρnonneg (Ne.symm hρzero) + have hρbar : ρ ≀ leakageEnvelope ((explicitKappa : β„š) : ℝ) := by + dsimp only [ρ, leakageEnvelope] + exact pairOutsideMass_le_exp hΟ„pos.le hΞΊposR.le hXint hab hcost + have hρsmall : ρ < 1 / 10 := + (hρbar.trans leakageEnvelope_explicitKappa_le).trans_lt (by norm_num) + have hρone : ρ < 1 := hρsmall.trans (by norm_num) + have hcoreRho := explicitKappa_cleanCore hρnonneg hρbar + have hentropy := outsideEntropyBracket_lt_four_scale hX hρpos + hρsmall hell hlogn + have hclean := cleanGainLowerBound_gt_of_core_and_entropy + hΞΎ hellpos hΟ„ hcoreRho hentropy + have hgain := log_pairGain_ge_cleanGainLowerBound_of_positiveLeakage + hΟ„pos.le hApos hX hXint hrscale hcscale hKKT hrs hab hcost + hρpos hρone + have hgamma : ((explicitGamma : β„š) : ℝ) < + Real.log 2 / 2 - ΞΎ := by + have hlog := Real.log_two_gt_d9 + have hΞΎbound : ΞΎ ≀ 1 / 100 := by + simpa [explicitXiSource] using hΞΎβ‚€ + norm_num [explicitGamma] at * + linarith + exact le_of_lt (hgamma.trans (hclean.trans_le hgain)) + +/-- The same hard-coded constants lower-bound the explicit finite witness +itself. Thus the clean-pair analysis needs no per-pair capacity optimizer. -/ +theorem explicit_cleanPairWitnessGain_constants : + ExplicitPairWitnessGainGuarantee (explicitKappa : ℝ) + (explicitXiSource : ℝ) (explicitGamma : ℝ) := by + intro n ell ΞΎ Ο„ X hell hlogn hΞΎ hΞΎβ‚€ hΟ„ hX hXint + r s a b hrs hab hcost + have hellpos : 0 < ell := lt_of_lt_of_le (by norm_num) hell + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + let ρ := outsideMassTwo (pairAlpha X r s) a b + have hρnonneg : 0 ≀ ρ := by + dsimp only [ρ, outsideMassTwo] + exact Finset.sum_nonneg fun j _ ↦ pairAlpha_nonneg hX r s j + have hΞΊposR : 0 < ((explicitKappa : β„š) : ℝ) := by + exact_mod_cast explicitKappa_pos + by_cases hρzero : ρ = 0 + Β· have hbarNonneg : 0 ≀ leakageEnvelope ((explicitKappa : β„š) : ℝ) := by + rw [leakageEnvelope] + have hexp : 1 ≀ Real.exp ((explicitKappa : β„š) : ℝ) := by + rw [← Real.exp_zero] + exact Real.exp_le_exp.mpr hΞΊposR.le + linarith + have hcoreZero := explicitKappa_cleanCore (ρ := 0) le_rfl hbarNonneg + have hcoreLog : Real.log 2 / 2 < + Real.log (2 * (Real.exp (-((explicitKappa : β„š) : ℝ))) ^ 2) := by + simpa [cleanCoreFunction] using hcoreZero + have hgain := coreLowerBound_le_explicitPairWitnessLogGain_of_zeroLeakage + hΟ„pos.le hX hXint hrs hab hcost (by simpa only [ρ] using hρzero) + have hgamma : ((explicitGamma : β„š) : ℝ) < Real.log 2 / 2 := by + have := Real.log_two_gt_d9 + norm_num [explicitGamma] at * + linarith + exact le_of_lt (hgamma.trans (hcoreLog.trans_le hgain)) + Β· have hρpos : 0 < ρ := lt_of_le_of_ne hρnonneg (Ne.symm hρzero) + have hρbar : ρ ≀ leakageEnvelope ((explicitKappa : β„š) : ℝ) := by + dsimp only [ρ, leakageEnvelope] + exact pairOutsideMass_le_exp hΟ„pos.le hΞΊposR.le hXint hab hcost + have hρsmall : ρ < 1 / 10 := + (hρbar.trans leakageEnvelope_explicitKappa_le).trans_lt (by norm_num) + have hρone : ρ < 1 := hρsmall.trans (by norm_num) + have hcoreRho := explicitKappa_cleanCore hρnonneg hρbar + have hentropy := outsideEntropyBracket_lt_four_scale hX hρpos + hρsmall hell hlogn + have hclean := cleanGainLowerBound_gt_of_core_and_entropy + hΞΎ hellpos hΟ„ hcoreRho hentropy + have hgain := cleanGainLowerBound_le_explicitPairWitnessLogGain + hΟ„pos.le hX hXint hrs hab hcost hρpos hρone + have hgamma : ((explicitGamma : β„š) : ℝ) < + Real.log 2 / 2 - ΞΎ := by + have hlog := Real.log_two_gt_d9 + have hΞΎbound : ΞΎ ≀ 1 / 100 := by + simpa [explicitXiSource] using hΞΎβ‚€ + norm_num [explicitGamma] at * + linarith + exact le_of_lt (hgamma.trans (hclean.trans_le hgain)) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitOptimizerScales.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitOptimizerScales.lean new file mode 100644 index 0000000000..e6b32fd685 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitOptimizerScales.lean @@ -0,0 +1,454 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheBisection +public import LeanPool.BeyondBethe.BeyondBethe.DirectedCertificateValue +public import Mathlib.Tactic + +/-! # Explicit Optimizer Scales -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Explicit dyadic scales for the numerical optimizer + +All parameters are rational functions of the normalized positive input and +the fixed structural error budget. Their deliberately generous slack keeps +the later objective-to-KKT calculation transparent. +-/ + +/-- Half the numerical interior floor at the matrix dimension, entry bit bound, and +regularization scale. -/ +def explicitOptimizerFloor {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) + (explicitRegularizationScale (m + 1)) / 2 + +/-- The optimizer distance scale: the coordinate floor times the KKT error allowance, divided by +48. -/ +def explicitOptimizerRho {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + explicitOptimizerFloor A * explicitKKTError / 48 + +/-- The optimizer objective gap: one quarter of the regularization scale times the squared +distance scale. -/ +def explicitOptimizerGap {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + explicitRegularizationScale (m + 1) * explicitOptimizerRho A ^ 2 / 4 + +/-- The mixing weight capped at one half and scaled by the objective gap and regularized +objective range. -/ +def explicitOptimizerMix {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + min (1 / 2) + (explicitOptimizerGap A / + (4 * (rationalRegularizedObjectiveRange A + 1))) + +/-- The optimizer inner radius, equal to the mixing weight divided by twice the matrix +dimension. -/ +def explicitOptimizerInnerRadius {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + explicitOptimizerMix A / (2 * (m + 1)) + +/-- The evaluation precision budget from the encoded gap and KKT allowance, with +dimension-dependent slack. -/ +def explicitOptimizerPrecision {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„• := + encodedBitLength β„š (explicitOptimizerGap A) + + encodedBitLength β„š explicitKKTError + 2 * (m + 1) + 10 + +/-- The width of the explicit initial Bethe bisection interval. -/ +def explicitOptimizerInitialWidth {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„š := + betheBisectionInitialHigh A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) - + betheNegativeObjectiveLower m + +/-- The bisection iteration count from the encoded initial width and target gap, with three +extra steps. -/ +def explicitOptimizerBisectionSteps {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : β„• := + encodedBitLength β„š (explicitOptimizerInitialWidth A) + + encodedBitLength β„š (explicitOptimizerGap A) + 3 + +theorem explicitOptimizerFloor_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerFloor A := by + rw [explicitOptimizerFloor] + exact div_pos (numericalInteriorFloor_pos _ _ _) (by norm_num) + +theorem explicitOptimizerRho_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerRho A := by + rw [explicitOptimizerRho] + exact div_pos + (mul_pos (explicitOptimizerFloor_pos A) explicitKKTError_pos) + (by norm_num) + +theorem explicitOptimizerGap_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerGap A := by + rw [explicitOptimizerGap] + exact div_pos + (mul_pos (explicitRegularizationScale_pos (by omega)) + (sq_pos_of_pos (explicitOptimizerRho_pos A))) (by norm_num) + +theorem explicitOptimizerMix_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerMix A := by + rw [explicitOptimizerMix, lt_min_iff] + exact ⟨by norm_num, div_pos (explicitOptimizerGap_pos A) (by + have h := rationalRegularizedObjectiveRange_nonneg A + positivity)⟩ + +theorem explicitOptimizerMix_le_half {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerMix A ≀ 1 / 2 := by + rw [explicitOptimizerMix] + exact min_le_left _ _ + +theorem explicitOptimizerMix_le_one {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerMix A ≀ 1 := + (explicitOptimizerMix_le_half A).trans (by norm_num) + +theorem explicitOptimizerInnerRadius_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerInnerRadius A := by + rw [explicitOptimizerInnerRadius] + exact div_pos (explicitOptimizerMix_pos A) (by positivity) + +theorem explicitOptimizerFloor_le_smoothedFloor {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerFloor A ≀ + (1 - explicitOptimizerMix A) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) + (explicitRegularizationScale (m + 1)) := by + let Ξ΄0 := numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) (explicitRegularizationScale (m + 1)) + have hΞ΄0 : 0 ≀ Ξ΄0 := + (numericalInteriorFloor_pos _ _ _).le + have hmix := explicitOptimizerMix_le_half A + rw [explicitOptimizerFloor] + nlinarith + +theorem explicitOptimizerInnerRadius_div_mix {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerInnerRadius A / explicitOptimizerMix A = + 1 / (2 * (m + 1) : β„š) := by + rw [explicitOptimizerInnerRadius] + field_simp [(explicitOptimizerMix_pos A).ne'] + +theorem explicitOptimizerInnerRadius_spike {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerInnerRadius A / explicitOptimizerMix A ≀ + 1 / (m + 1 : β„š) := by + rw [explicitOptimizerInnerRadius_div_mix] + have hn : (0 : β„š) < m + 1 := by positivity + exact one_div_le_one_div_of_le hn (by nlinarith) + +theorem explicitOptimizerRho_ratio {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 12 * explicitOptimizerRho A / explicitOptimizerFloor A = + explicitKKTError / 4 := by + rw [explicitOptimizerRho] + field_simp [(explicitOptimizerFloor_pos A).ne'] + ring + +theorem explicitOptimizerGap_scale {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 4 * explicitOptimizerGap A = + explicitRegularizationScale (m + 1) * explicitOptimizerRho A ^ 2 := by + rw [explicitOptimizerGap] + ring + +/-- The barycentric smoothing and inner-radius terms consume at most one +quarter of the objective-gap budget. -/ +theorem explicitOptimizerSmoothingSlack_le {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) ≀ + explicitOptimizerGap A / 4 := by + let range := rationalRegularizedObjectiveRange A + let mix := explicitOptimizerMix A + have hrange : 0 ≀ range := rationalRegularizedObjectiveRange_nonneg A + have hmix0 : 0 ≀ mix := (explicitOptimizerMix_pos A).le + have hmixBound : mix ≀ explicitOptimizerGap A / + (4 * (range + 1)) := by + dsimp only [mix, range] + rw [explicitOptimizerMix] + exact min_le_right _ _ + have hn : (1 : β„š) ≀ m + 1 := by exact_mod_cast (show 1 ≀ m + 1 by omega) + have hradius : 2 * explicitOptimizerInnerRadius A ≀ mix := by + rw [explicitOptimizerInnerRadius] + have hden : (0 : β„š) < 2 * (m + 1) := by positivity + rw [div_eq_mul_inv] + have hinv : (2 * (m + 1) : β„š)⁻¹ ≀ 1 / 2 := by + rw [inv_le_commβ‚€ (by positivity) (by norm_num)] + nlinarith + nlinarith + have hcombine : mix * range + 2 * explicitOptimizerInnerRadius A ≀ + mix * (range + 1) := by + nlinarith + have hdenpos : 0 < 4 * (range + 1) := by positivity + have hscaled := mul_le_mul_of_nonneg_right hmixBound (by + positivity : (0 : β„š) ≀ range + 1) + have hcancel : explicitOptimizerGap A / (4 * (range + 1)) * + (range + 1) = explicitOptimizerGap A / 4 := by + field_simp [show range + 1 β‰  0 by positivity] + rw [hcancel] at hscaled + rw [betheSmoothingSlack] + simpa only [mix, range] using hcombine.trans hscaled + +theorem explicitOptimizerInitialWidth_pos {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 0 < explicitOptimizerInitialWidth A := by + rw [explicitOptimizerInitialWidth, betheBisectionInitialHigh, + betheNegativeObjectiveUpper, betheNegativeObjectiveLower] + have hslack : 0 < betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) := by + rw [betheSmoothingSlack] + exact add_pos_of_nonneg_of_pos + (mul_nonneg (explicitOptimizerMix_pos A).le + (rationalRegularizedObjectiveRange_nonneg A)) + (mul_pos (by norm_num) (explicitOptimizerInnerRadius_pos A)) + have hB : (0 : β„š) ≀ rationalMatrixEntryBitBound A := by positivity + have hn : (0 : β„š) < m + 1 := by positivity + push_cast + nlinarith + +/-- The precision exponent contains enough dyadic shift to absorb the +dimension factor in objective evaluation. -/ +theorem explicitOptimizerPrecision_scaled_lt_gap {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + (2 : β„š) ^ (2 * (m + 1) + 10) * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A < + explicitOptimizerGap A := by + let Lg := encodedBitLength β„š (explicitOptimizerGap A) + let Le := encodedBitLength β„š explicitKKTError + let K := 2 * (m + 1) + 10 + have hgap := dyadic_encodedBitLength_lt_positive_rational + (explicitOptimizerGap_pos A) + have he : (1 / 2 : β„š) ^ Le ≀ 1 := by + exact pow_le_oneβ‚€ (by norm_num) (by norm_num) + have hcancel : (2 : β„š) ^ K * (1 / 2 : β„š) ^ K = 1 := by + rw [← mul_pow] + norm_num + have hsplit : (1 / 2 : β„š) ^ (Lg + Le + K) = + (1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K := by + rw [pow_add, pow_add] + calc + (2 : β„š) ^ (2 * (m + 1) + 10) * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A = + (1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le := by + rw [show 2 * (m + 1) + 10 = K by rfl] + rw [show explicitOptimizerPrecision A = Lg + Le + K by + simp only [explicitOptimizerPrecision, Lg, Le, K]; omega] + rw [hsplit] + rw [show + (2 : β„š) ^ K * + ((1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K) = + ((1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le) * + ((2 : β„š) ^ K * (1 / 2 : β„š) ^ K) by ring, + hcancel, mul_one] + _ ≀ (1 / 2 : β„š) ^ Lg := + mul_le_of_le_one_right (by positivity) he + _ < explicitOptimizerGap A := by simpa only [Lg] using hgap + +/-- Independently, the same precision exponent absorbs the fixed KKT error +scale. -/ +theorem explicitOptimizerPrecision_scaled_lt_kktError {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + (2 : β„š) ^ 10 * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A < + explicitKKTError := by + let Lg := encodedBitLength β„š (explicitOptimizerGap A) + let Le := encodedBitLength β„š explicitKKTError + let K := 2 * (m + 1) + have herr := dyadic_encodedBitLength_lt_positive_rational + explicitKKTError_pos + have hg : (1 / 2 : β„š) ^ Lg ≀ 1 := + pow_le_oneβ‚€ (by norm_num) (by norm_num) + have hk : (1 / 2 : β„š) ^ K ≀ 1 := + pow_le_oneβ‚€ (by norm_num) (by norm_num) + have hcancel : (2 : β„š) ^ 10 * (1 / 2 : β„š) ^ 10 = 1 := by + rw [← mul_pow] + norm_num + have hsplit : (1 / 2 : β„š) ^ (Lg + Le + K + 10) = + ((1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K) * (1 / 2 : β„š) ^ 10 := by + rw [pow_add, pow_add, pow_add] + calc + (2 : β„š) ^ 10 * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A = + (1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K := by + rw [show explicitOptimizerPrecision A = Lg + Le + K + 10 by + simp only [explicitOptimizerPrecision, Lg, Le, K]] + rw [hsplit] + rw [show (2 : β„š) ^ 10 * + (((1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K) * (1 / 2 : β„š) ^ 10) = + ((1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K) * + ((2 : β„š) ^ 10 * (1 / 2 : β„š) ^ 10) by ring, + hcancel, mul_one] + _ ≀ (1 / 2 : β„š) ^ Le := by + have hnonneg : 0 ≀ (1 / 2 : β„š) ^ Le := by positivity + calc + (1 / 2 : β„š) ^ Lg * (1 / 2 : β„š) ^ Le * + (1 / 2 : β„š) ^ K ≀ + 1 * (1 / 2 : β„š) ^ Le * 1 := by gcongr + _ = (1 / 2 : β„š) ^ Le := by ring + _ < explicitKKTError := by simpa only [Le] using herr + +theorem explicitOptimizerGradientEvaluationError_le {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A ≀ + explicitKKTError / 256 := by + have hscaled := explicitOptimizerPrecision_scaled_lt_kktError A + norm_num at hscaled + linarith + +/-- The full one-sided objective-evaluation loss uses at most one quarter of +the objective-gap budget. -/ +theorem explicitOptimizerObjectiveEvaluationError_lt {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + betheObjectiveEvaluationError m (explicitOptimizerPrecision A) < + explicitOptimizerGap A / 4 := by + let n := m + 1 + let coeff : β„• := 16 * m ^ 2 + 3 * n ^ 2 + have hmn : m ≀ n := by omega + have hnpow : n ≀ 2 ^ n := n.lt_two_pow_self.le + have hn2 : n ^ 2 ≀ 2 ^ (2 * n) := by + calc + n ^ 2 ≀ (2 ^ n) ^ 2 := Nat.pow_le_pow_left hnpow 2 + _ = 2 ^ (2 * n) := by + rw [← pow_mul] + congr 1 + omega + have hcoeff : 4 * coeff ≀ 2 ^ (2 * n + 10) := by + calc + 4 * coeff ≀ 76 * n ^ 2 := by + dsimp only [coeff, n] + nlinarith + _ ≀ 76 * 2 ^ (2 * n) := Nat.mul_le_mul_left 76 hn2 + _ ≀ 1024 * 2 ^ (2 * n) := Nat.mul_le_mul_right _ (by norm_num) + _ = 2 ^ (2 * n + 10) := by + rw [pow_add] + norm_num + ring + have hcoeffQ : (4 : β„š) * coeff ≀ + (2 : β„š) ^ (2 * (m + 1) + 10) := by + exact_mod_cast hcoeff + have hdyadic : 0 ≀ + (1 / 2 : β„š) ^ explicitOptimizerPrecision A := by positivity + have hscaled := mul_le_mul_of_nonneg_right hcoeffQ hdyadic + have hgap := explicitOptimizerPrecision_scaled_lt_gap A + have hfour : 4 * betheObjectiveEvaluationError m + (explicitOptimizerPrecision A) < explicitOptimizerGap A := by + rw [betheObjectiveEvaluationError] + have hform : + 4 * (16 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A * + (m * m) + + 3 * (m + 1) ^ 2 * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A) = + (4 : β„š) * coeff * + (1 / 2 : β„š) ^ explicitOptimizerPrecision A := by + dsimp only [coeff, n] + push_cast + ring + rw [hform] + exact hscaled.trans_lt hgap + linarith + +/-- The encoded-length bisection depth leaves less than one eighth of the +objective-gap budget. -/ +theorem explicitOptimizerBisectionWidth_lt {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A < + explicitOptimizerGap A / 8 := by + let W := explicitOptimizerInitialWidth A + let g := explicitOptimizerGap A + let LW := encodedBitLength β„š W + let Lg := encodedBitLength β„š g + have hW := positive_rational_lt_two_pow_encodedBitLength + (explicitOptimizerInitialWidth_pos A) + have hg := dyadic_encodedBitLength_lt_positive_rational + (explicitOptimizerGap_pos A) + have hdyadic : 0 < (1 / 2 : β„š) ^ (Lg + 3) := by positivity + have hdirect : W / 2 ^ (LW + Lg + 3) < + (1 / 2 : β„š) ^ Lg / 8 := by + have hcancelLW : (2 : β„š) ^ LW * (1 / 2 : β„š) ^ LW = 1 := by + rw [← mul_pow] + norm_num + calc + W / 2 ^ (LW + Lg + 3) = + W * (1 / 2 : β„š) ^ (LW + Lg + 3) := by + simp [div_eq_mul_inv, one_div, inv_pow] + _ < (2 : β„š) ^ LW * + (1 / 2 : β„š) ^ (LW + Lg + 3) := by + exact mul_lt_mul_of_pos_right hW (by positivity) + _ = (1 / 2 : β„š) ^ Lg / 8 := by + rw [show LW + Lg + 3 = LW + (Lg + 3) by omega, pow_add] + rw [show (2 : β„š) ^ LW * + ((1 / 2 : β„š) ^ LW * (1 / 2 : β„š) ^ (Lg + 3)) = + ((2 : β„š) ^ LW * (1 / 2 : β„š) ^ LW) * + (1 / 2 : β„š) ^ (Lg + 3) by ring, + hcancelLW, one_mul] + rw [pow_add] + norm_num + ring + rw [explicitOptimizerBisectionSteps] + simpa only [W, g, LW, Lg] using hdirect.trans + (div_lt_div_of_pos_right hg (by norm_num)) + +/-- Summing all three objective losses still stays below the chosen strong +concavity budget. -/ +theorem explicitOptimizerTotalObjectiveError_lt {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + betheSmoothingSlack A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) + + explicitOptimizerInitialWidth A / + 2 ^ explicitOptimizerBisectionSteps A + + betheObjectiveEvaluationError m (explicitOptimizerPrecision A) < + explicitOptimizerGap A := by + have hs := explicitOptimizerSmoothingSlack_le A + have hw := explicitOptimizerBisectionWidth_lt A + have he := explicitOptimizerObjectiveEvaluationError_lt A + have hg := explicitOptimizerGap_pos A + linarith + +/-- The gradient-evaluation and objective-proximity losses fit inside the +fixed approximate-KKT allowance. -/ +theorem explicitOptimizerKKTError_le {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + 4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A + + 4 * (4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A + + 3 * explicitOptimizerRho A / explicitOptimizerFloor A) ≀ + explicitKKTError := by + have he := explicitOptimizerGradientEvaluationError_le A + have hratio := explicitOptimizerRho_ratio A + have hΞ΅ := explicitKKTError_pos + calc + 4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A + + 4 * (4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A + + 3 * explicitOptimizerRho A / explicitOptimizerFloor A) = + 5 * (4 * (1 / 2 : β„š) ^ explicitOptimizerPrecision A) + + 12 * explicitOptimizerRho A / explicitOptimizerFloor A := by ring + _ ≀ 5 * (explicitKKTError / 256) + explicitKKTError / 4 := by + rw [hratio] + gcongr + _ ≀ explicitKKTError := by nlinarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitPositiveRoutine.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitPositiveRoutine.lean new file mode 100644 index 0000000000..f6ae6d0348 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitPositiveRoutine.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import Mathlib.Tactic + +/-! # Explicit Positive Routine -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The concrete positive-matrix routine + +The routine normalizes its positive rational input, runs the explicit +regularized-Bethe optimizer, evaluates the directed rational certificate, +and restores the degree-`n` normalization factor. +-/ + +/-- The explicit positive-input approximation: exact in dimensions zero and one, otherwise a +normalization-scaled Bethe certificate. -/ +def explicitPositiveAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + | 0, A => Matrix.permanent A + | 1, A => Matrix.permanent A + | m + 2, A => + let B := normalizedRationalMatrix A + let X := explicitBetheOptimizerMatrix (m := m + 1) B + let R := explicitBetheOptimizerRowPotential (m := m + 1) B + let C := explicitBetheOptimizerColumnPotential (m := m + 1) B + rationalNormalizationScale A ^ (m + 2) * + explicitDirectedCertificateValue X R C + +@[simp] theorem explicitPositiveAlgorithm_succ_succ + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) : + explicitPositiveAlgorithm (m + 2) A = + rationalNormalizationScale A ^ (m + 2) * + explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerRowPotential (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerColumnPotential (m := m + 1) + (normalizedRationalMatrix A)) := by + rfl + +theorem positive_rational_of_positive_cast {q : β„š} (hq : 0 < (q : ℝ)) : + 0 < q := Rat.cast_pos.mp hq + +theorem explicitPositiveAlgorithm_succ_succ_spec + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hA : Matrix.Positive (fun i j ↦ (A i j : ℝ))) : + 0 < (explicitPositiveAlgorithm (m + 2) A : ℝ) ∧ + (explicitPositiveAlgorithm (m + 2) A : ℝ) ≀ + ((Matrix.permanent A : β„š) : ℝ) ∧ + ((Matrix.permanent A : β„š) : ℝ) ≀ + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ (m + 2) * + (explicitPositiveAlgorithm (m + 2) A : ℝ) := by + let B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š := + normalizedRationalMatrix A + let X := explicitBetheOptimizerMatrix (m := m + 1) B + let R := explicitBetheOptimizerRowPotential (m := m + 1) B + let C := explicitBetheOptimizerColumnPotential (m := m + 1) B + let L : β„š := explicitDirectedCertificateValue X R C + have hAq : βˆ€ i j, 0 < A i j := by + intro i j + exact positive_rational_of_positive_cast (hA i j) + have hAnonneg : Matrix.Nonnegative A := fun i j ↦ (hAq i j).le + have hBpos : βˆ€ i j, 0 < B i j := by + intro i j + change 0 < normalizedRationalMatrix A i j + rw [normalizedRationalMatrix] + exact div_pos (hAq i j) (rationalNormalizationScale_pos hAnonneg) + have hBupper : βˆ€ i j, B i j ≀ 1 := by + intro i j + exact normalizedRationalMatrix_le_one hAnonneg i j + have hpoint := explicitBetheOptimizerPoint_spec (m := m + 1) + (by omega) B hBpos hBupper + have hX : IsDoublyStochastic (fun i j ↦ ((X i j : β„š) : ℝ)) := by + simpa only [X] using hpoint.2.1 + have hXlo : βˆ€ i j, (explicitOptimizerFloor B : ℝ) ≀ (X i j : ℝ) := by + simpa only [X] using hpoint.2.2.1 + have hΞ΄ : 0 < (explicitOptimizerFloor B : ℝ) := + Rat.cast_pos.mpr (explicitOptimizerFloor_pos B) + have hXpos : βˆ€ i j, 0 < (X i j : ℝ) := by + intro i j + exact hΞ΄.trans_le (hXlo i j) + have hXint : βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((X i j : β„š) : ℝ)) := by + intro i + refine ⟨hX.row_probability i, fun j ↦ ⟨hXpos i j, ?_⟩⟩ + exact hX.entry_lt_one_of_positive hXpos (by simp) i j + have happrox := explicitBetheOptimizer_hasApproximateLogKKT + (m := m + 1) (by omega) B hBpos hBupper + have hBR : Matrix.Positive (fun i j ↦ (B i j : ℝ)) := by + intro i j + exact Rat.cast_pos.mpr (hBpos i j) + have hcert := explicitDirectedCertificate_twoSided + anariOveisGharanStableCoefficient (n := m + 2) (by omega) + hBR hX hXint (by simpa only [X, R, C, B] using happrox) + have hLpos : 0 < (L : ℝ) := by + simpa only [L] using explicitDirectedCertificateValue_pos + (n := m + 2) (by omega) X R C + have hscale : 0 < (rationalNormalizationScale A : ℝ) := by + exact_mod_cast rationalNormalizationScale_pos hAnonneg + have hper := cast_permanent_eq_scale_pow_mul_normalized A hAnonneg + have hout : + (explicitPositiveAlgorithm (m + 2) A : ℝ) = + (rationalNormalizationScale A : ℝ) ^ (m + 2) * (L : ℝ) := by + simp only [explicitPositiveAlgorithm_succ_succ, B, X, R, C, L, + Rat.cast_mul, Rat.cast_pow] + have hcert' : (L : ℝ) ≀ Matrix.permanent (fun i j ↦ (B i j : ℝ)) ∧ + Matrix.permanent (fun i j ↦ (B i j : ℝ)) ≀ + (preSmoothingBase (explicitCertifiedEpsilon : ℝ)) ^ (m + 2) * + (L : ℝ) := by + simpa only [L, X, R, C] using hcert + rw [hout] + refine ⟨mul_pos (pow_pos hscale _) hLpos, ?_, ?_⟩ + Β· rw [hper] + exact mul_le_mul_of_nonneg_left hcert'.1 (pow_nonneg hscale.le _) + Β· rw [hper] + have hmul := mul_le_mul_of_nonneg_left hcert'.2 + (pow_nonneg hscale.le (m + 2)) + nlinarith + +/-- Unconditional certified routine for positive rational matrices. -/ +def explicitCertifiedPositiveRoutine : + CertifiedPositiveRoutine (explicitCertifiedEpsilon : ℝ) where + alg := explicitPositiveAlgorithm + positiveOutput := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (explicitPositiveAlgorithm_succ_succ_spec m A hA).1 + lower := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (explicitPositiveAlgorithm_succ_succ_spec m A hA).2.1 + upper := by + intro n hn A hA + cases n with + | zero => omega + | succ n => + cases n with + | zero => omega + | succ m => + exact (explicitPositiveAlgorithm_succ_succ_spec m A hA).2.2 + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitScales.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitScales.lean new file mode 100644 index 0000000000..aaf3f5df2e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitScales.lean @@ -0,0 +1,418 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBounds +public import LeanPool.BeyondBethe.BeyondBethe.CertifiedPairWeights +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import Mathlib.Tactic + +/-! # Explicit Scales -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Hard-coded rational structural scales + +This file replaces the remaining density and continuity choices in the +structural proof by one fixed tuple of rationals. +-/ + +/-- The fixed rational heavy-coordinate tolerance `10^(-12)`. -/ +def explicitEta : β„š := 1 / 10 ^ 12 + +/-- The fixed row-error ratio `1/200000`. -/ +def explicitRowRatio : β„š := 1 / 200000 + +/-- The completion scale `(explicitEta/3074)^4 * explicitRowRatio`. -/ +def explicitDelta : β„š := + (explicitEta / 3074) ^ 4 * explicitRowRatio + +/-- The transfer tolerance, equal to one hundredth of the completion scale. -/ +def explicitXi : β„š := explicitDelta / 100 + +/-- The greedy threshold matching retains one quarter of the structural +matching gain: one half from directed thresholding and one half from +maximal-versus-maximum cardinality. -/ +def explicitGreedyGamma : β„š := explicitGamma / 4 + +/-- The structural clean-cycle threshold leaves a fixed gap below the cost +threshold used by the directed rational certificate. -/ +def explicitCertifiedStructuralKappa : β„š := 9 * explicitKappa / 10 + +/-- A maximal matching loses only a factor two because every accepted edge +receives the exact same certified gain. -/ +def explicitCertifiedGamma : β„š := explicitGamma / 2 + +theorem explicitEta_pos : 0 < explicitEta := by + norm_num [explicitEta] + +theorem explicitRowRatio_pos : 0 < explicitRowRatio := by + norm_num [explicitRowRatio] + +theorem explicitDelta_pos : 0 < explicitDelta := by + rw [explicitDelta] + exact mul_pos (pow_pos (div_pos explicitEta_pos (by norm_num)) _) explicitRowRatio_pos + +theorem explicitXi_pos : 0 < explicitXi := by + rw [explicitXi] + exact div_pos explicitDelta_pos (by norm_num) + +theorem explicitCertifiedStructuralKappa_pos : + 0 < explicitCertifiedStructuralKappa := by + norm_num [explicitCertifiedStructuralKappa, explicitKappa] + +theorem explicitCertifiedGamma_pos : 0 < explicitCertifiedGamma := by + norm_num [explicitCertifiedGamma, explicitGamma] + +theorem sqrt_explicitEta : + Real.sqrt ((explicitEta : β„š) : ℝ) = 1 / 10 ^ 6 := by + have heq : (((explicitEta : β„š) : ℝ)) = (1 / 10 ^ 6 : ℝ) ^ 2 := by + norm_num [explicitEta] + rw [heq, Real.sqrt_sq (by positivity)] + +theorem explicitEta_entropy_bound : + binaryEntropy ((explicitEta : β„š) : ℝ) + (explicitEta : ℝ) ≀ + 3 / 10 ^ 6 := by + let Ξ· : ℝ := (explicitEta : β„š) + have hΞ·0 : 0 ≀ Ξ· := by + change 0 ≀ ((explicitEta : β„š) : ℝ) + exact_mod_cast explicitEta_pos.le + have hΞ·1 : Ξ· ≀ 1 := by norm_num [Ξ·, explicitEta] + have hnmlΞ·abs := abs_negMulLog_lt_two_sqrt_abs + (x := Ξ·) (by simpa [abs_of_nonneg hΞ·0] using hΞ·1) + have hnmlΞ· : Real.negMulLog Ξ· ≀ 2 * Real.sqrt Ξ· := + (le_abs_self _).trans (by simpa [abs_of_nonneg hΞ·0] using hnmlΞ·abs) + have hnmlone : Real.negMulLog (1 - Ξ·) ≀ Ξ· := by + have := Real.negMulLog_le_one_sub_self (sub_nonneg.mpr hΞ·1) + linarith + rw [binaryEntropy, Real.negMulLog_def] + change Real.negMulLog Ξ· + Real.negMulLog (1 - Ξ·) + Ξ· ≀ 3 / 10 ^ 6 + rw [show Real.sqrt Ξ· = 1 / 10 ^ 6 by + simpa only [Ξ·] using sqrt_explicitEta] at hnmlΞ· + norm_num [Ξ·, explicitEta] at * + linarith + +theorem explicitOmega_bound : + goodRowOmega ((explicitEta : β„š) : ℝ) ≀ 70 / 10 ^ 6 := by + have h := goodRowOmega_le_seventy_sqrt + (Ξ· := ((explicitEta : β„š) : ℝ)) + (by exact_mod_cast explicitEta_pos.le) (by norm_num [explicitEta]) + rw [sqrt_explicitEta] at h + norm_num at h ⊒ + exact h + +theorem explicitDelta_ratio : + ((explicitDelta : β„š) : ℝ) / + (((explicitEta : β„š) : ℝ) / 3074) ^ 4 = + (explicitRowRatio : ℝ) := by + have hbase : (((explicitEta : β„š) : ℝ) / 3074) ^ 4 β‰  0 := by + exact pow_ne_zero _ (div_ne_zero (by exact_mod_cast explicitEta_pos.ne') (by norm_num)) + rw [explicitDelta] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_ofNat] + exact mul_div_cancel_leftβ‚€ _ hbase + +theorem explicitDelta_le_rowRatio : + ((explicitDelta : β„š) : ℝ) ≀ (explicitRowRatio : ℝ) := by + have heta : (((explicitEta : β„š) : ℝ) / 3074) ^ 4 ≀ 1 := by + have hbase : (0 : ℝ) ≀ ((explicitEta : β„š) : ℝ) / 3074 := by + exact div_nonneg (by exact_mod_cast explicitEta_pos.le) (by norm_num) + have hbase1 : ((explicitEta : β„š) : ℝ) / 3074 ≀ 1 := by + norm_num [explicitEta] + exact pow_le_oneβ‚€ hbase hbase1 + rw [explicitDelta] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_ofNat] + exact mul_le_of_le_one_left (by exact_mod_cast explicitRowRatio_pos.le) heta + +/-- The explicit rational completion parameters bundled with their row, cycle, transfer, and +gain bounds. -/ +def explicit_completionScales : + RationalCompletionScales explicitKappa explicitXiSource explicitGamma := by + have hlog0 : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hlog1 : Real.log 2 ≀ 1 := Real.log_two_lt_d9.le.trans (by norm_num) + have hcoef : 6 / Real.log 2 ≀ 10 := by + rw [div_le_iffβ‚€ hlog0] + have := Real.log_two_gt_d9 + norm_num at * + linarith + have hΞ΄r := explicitDelta_le_rowRatio + have hΟ‰ := explicitOmega_bound + have hΞ·H := explicitEta_entropy_bound + have hr : ((explicitRowRatio : β„š) : ℝ) = 1 / 200000 := by + norm_num [explicitRowRatio] + have hΞ΄small : ((explicitDelta : β„š) : ℝ) ≀ 1 / 200000 := by + rw [← hr] + exact hΞ΄r + have hΞΎΞ΄ : explicitXi < explicitDelta := by + rw [explicitXi] + have := explicitDelta_pos + norm_num at * + exact div_lt_self this (by norm_num) + refine { + Ξ· := explicitEta + Ξ΄ := explicitDelta + ΞΎ := explicitXi + Ξ·_pos := explicitEta_pos + Ξ·_le_tenth := by norm_num [explicitEta] + Ξ΄_pos := explicitDelta_pos + ΞΎ_pos := explicitXi_pos + ΞΎ_le_source := by + have hΞ΄cast : ((explicitDelta : β„š) : ℝ) < 1 := + hΞ΄small.trans_lt (by norm_num) + have hΞ΄ : explicitDelta < 1 := by exact_mod_cast hΞ΄cast + rw [explicitXi, explicitXiSource] + exact (div_lt_div_of_pos_right hΞ΄ (by norm_num)).le + row_small := by + rw [explicitDelta_ratio] + norm_num [explicitRowRatio] + cycle_small := by + rw [explicitDelta_ratio] + have hmid : (1 + Real.log 2 / 2) * + ((explicitRowRatio : β„š) : ℝ) ≀ + (3 / 2 : ℝ) * (1 / 200000) := by + rw [hr] + apply mul_le_mul_of_nonneg_right _ (by norm_num) + linarith + have hsum : + ((explicitDelta : β„š) : ℝ) + + (1 + Real.log 2 / 2) * (explicitRowRatio : ℝ) + + goodRowOmega ((explicitEta : β„š) : ℝ) ≀ + (1 / 200000 : ℝ) + (3 / 2) * (1 / 200000) + 70 / 10 ^ 6 := + add_le_add (add_le_add hΞ΄small hmid) hΟ‰ + have hsum0 : 0 ≀ + ((explicitDelta : β„š) : ℝ) + + (1 + Real.log 2 / 2) * (explicitRowRatio : ℝ) + + goodRowOmega ((explicitEta : β„š) : ℝ) := by + exact add_nonneg + (add_nonneg (by exact_mod_cast explicitDelta_pos.le) + (mul_nonneg (by positivity) + (by exact_mod_cast explicitRowRatio_pos.le))) + (goodRowOmega_nonneg _) + calc + 6 / Real.log 2 * + (((explicitDelta : β„š) : ℝ) + + (1 + Real.log 2 / 2) * (explicitRowRatio : ℝ) + + goodRowOmega ((explicitEta : β„š) : ℝ)) ≀ + 10 * ((1 / 200000 : ℝ) + + (3 / 2) * (1 / 200000) + 70 / 10 ^ 6) := by + exact mul_le_mul hcoef hsum hsum0 (by positivity) + _ ≀ 1 / 16 := by norm_num + transfer_small := by + rw [explicitDelta_ratio] + have hxi : 2 * ((explicitXi : β„š) : ℝ) ≀ 1 / 200000 := by + have hcast : ((explicitXi : β„š) : ℝ) < ((explicitDelta : β„š) : ℝ) := by + exact_mod_cast hΞΎΞ΄ + have hΞ΄0 : 0 ≀ ((explicitDelta : β„š) : ℝ) := by + exact_mod_cast explicitDelta_pos.le + rw [explicitXi] + norm_num only [Rat.cast_div, Rat.cast_ofNat] + nlinarith + have hleft : + ((explicitDelta : β„š) : ℝ) + 2 * ((explicitXi : β„š) : ℝ) + + binaryEntropy ((explicitEta : β„š) : ℝ) + + ((explicitEta : β„š) : ℝ) + + (1 + Real.log 2) * ((explicitRowRatio : β„š) : ℝ) ≀ + 23 / 10 ^ 6 := by + calc + _ ≀ (1 / 200000 : ℝ) + 1 / 200000 + 3 / 10 ^ 6 + + 2 * (1 / 200000) := by + have hlast : (1 + Real.log 2) * + ((explicitRowRatio : β„š) : ℝ) ≀ 2 * (1 / 200000 : ℝ) := by + rw [hr] + gcongr + linarith + linarith + _ = 23 / 10 ^ 6 := by norm_num + have hright : (1 / 40000 : ℝ) ≀ + (1 / 16) * ((1 / 2 - ((explicitEta : β„š) : ℝ)) * + ((explicitKappa : β„š) : ℝ)) := by + norm_num [explicitEta, explicitKappa] + exact (hleft.trans (by norm_num : (23 / 10 ^ 6 : ℝ) ≀ 1 / 40000)).trans hright + ΞΎ_lt_Ξ΄ := hΞΎΞ΄ + ΞΎ_lt_gain := by + have hΞ΄smallQ : explicitDelta ≀ 1 / 200000 := by + have hcast : ((explicitDelta : β„š) : ℝ) ≀ (((1 / 200000 : β„š)) : ℝ) := by + simpa using hΞ΄small + exact_mod_cast hcast + rw [explicitGamma] + calc + explicitXi < explicitDelta := hΞΎΞ΄ + _ ≀ 1 / 200000 := hΞ΄smallQ + _ < 3 * (1 / 4) / 8 := by norm_num } + +/-- Numerical upper bound on the left side of the transfer-smallness +condition. It is recorded separately so the same analytic estimate can be +used with the slightly smaller structural cost threshold. -/ +theorem explicitTransferExpression_le : + ((explicitDelta : β„š) : ℝ) + 2 * ((explicitXi : β„š) : ℝ) + + binaryEntropy ((explicitEta : β„š) : ℝ) + + ((explicitEta : β„š) : ℝ) + + (1 + Real.log 2) * + (((explicitDelta : β„š) : ℝ) / + (((explicitEta : β„š) : ℝ) / 3074) ^ 4) ≀ + 23 / 10 ^ 6 := by + rw [explicitDelta_ratio] + have hlog1 : Real.log 2 ≀ 1 := Real.log_two_lt_d9.le.trans (by norm_num) + have hΞ΄small := explicitDelta_le_rowRatio + have hΞ·H := explicitEta_entropy_bound + have hr : ((explicitRowRatio : β„š) : ℝ) = 1 / 200000 := by + norm_num [explicitRowRatio] + have hΞ΄ : ((explicitDelta : β„š) : ℝ) ≀ 1 / 200000 := by + rw [← hr] + exact hΞ΄small + have hxi : 2 * ((explicitXi : β„š) : ℝ) ≀ 1 / 200000 := by + rw [explicitXi] + norm_num only [Rat.cast_div, Rat.cast_ofNat] + have hΞ΄0 : 0 ≀ ((explicitDelta : β„š) : ℝ) := by + exact_mod_cast explicitDelta_pos.le + nlinarith + have hlast : (1 + Real.log 2) * + ((explicitRowRatio : β„š) : ℝ) ≀ 2 * (1 / 200000 : ℝ) := by + rw [hr] + gcongr + linarith + linarith + +/-- Completion scales for the actual executable certificate. The clean +cycle analysis uses `0.9 ΞΊ`, the directed test uses `ΞΊ`, and the greedy +matching retains half of the uniform gain. -/ +def explicitCertifiedCompletionScales : + RationalCompletionScales explicitCertifiedStructuralKappa + explicitXiSource explicitCertifiedGamma := by + refine { explicit_completionScales with + transfer_small := ?_ + ΞΎ_lt_gain := ?_ } + Β· have hleft := explicitTransferExpression_le + have hright : (23 / 10 ^ 6 : ℝ) ≀ + (1 / 16) * + ((1 / 2 - ((explicitEta : β„š) : ℝ)) * + ((explicitCertifiedStructuralKappa : β„š) : ℝ)) := by + norm_num [explicitEta, explicitCertifiedStructuralKappa, explicitKappa] + exact hleft.trans hright + Β· have hΞ΄small : explicitDelta ≀ 1 / 200000 := by + have hcast := explicitDelta_le_rowRatio + have hr : ((explicitRowRatio : β„š) : ℝ) = 1 / 200000 := by + norm_num [explicitRowRatio] + rw [hr] at hcast + have hcast' : ((explicitDelta : β„š) : ℝ) ≀ + (((1 / 200000 : β„š)) : ℝ) := by + norm_num only [Rat.cast_div, Rat.cast_ofNat] + exact hcast + exact Rat.cast_le.mp hcast' + change explicitXi < 3 * explicitCertifiedGamma / 8 + rw [explicitXi, explicitCertifiedGamma, explicitGamma] + calc + explicitDelta / 100 < explicitDelta := by + exact div_lt_self explicitDelta_pos (by norm_num) + _ ≀ 1 / 200000 := hΞ΄small + _ < 3 * ((1 / 4) / 2) / 8 := by norm_num + +theorem explicitCertifiedCostMargin (n : β„•) : + 4 * (n + 3 : ℝ) * + ((1 / 2 : β„š) ^ directedPairCostPrecision n : β„š) ≀ + (explicitKappa : ℝ) - + (explicitCertifiedStructuralKappa : ℝ) := by + have h := directedPairCostPrecision_error_le n + norm_num [explicitKappa, explicitCertifiedStructuralKappa] at h ⊒ + exact h + +/-- The far case is the active branch of the explicit improvement: the +near-case gain margin is vastly larger than the chosen slack scale. -/ +theorem explicitCertifiedEpsilon_eq : + rationalEpsilonPlus explicitCertifiedCompletionScales = + explicitDelta - explicitXi := by + rw [rationalEpsilonPlus] + change min (explicitDelta - explicitXi) + (3 * explicitCertifiedGamma / 8 - explicitXi) = + explicitDelta - explicitXi + rw [min_eq_left] + have hΞ΄small : explicitDelta ≀ 1 / 200000 := by + have hcast := explicitDelta_le_rowRatio + have hr : ((explicitRowRatio : β„š) : ℝ) = 1 / 200000 := by + norm_num [explicitRowRatio] + rw [hr] at hcast + have hcast' : ((explicitDelta : β„š) : ℝ) ≀ + (((1 / 200000 : β„š)) : ℝ) := by + norm_num only [Rat.cast_div, Rat.cast_ofNat] + exact hcast + exact Rat.cast_le.mp hcast' + have hmain : explicitDelta ≀ 3 * explicitCertifiedGamma / 8 := by + exact hΞ΄small.trans (by + norm_num [explicitCertifiedGamma, explicitGamma]) + linarith + +/-- The rational certified improvement extracted from the explicit certified completion scales. -/ +def explicitCertifiedEpsilon : β„š := + rationalEpsilonPlus explicitCertifiedCompletionScales + +theorem explicitCertifiedEpsilon_pos : 0 < explicitCertifiedEpsilon := by + exact rationalEpsilonPlus_pos explicitCertifiedCompletionScales + +/-- The explicit structural parameters together with the clean-pair gain and completion-scale +proofs. -/ +def explicitStructuralScales : RationalStructuralScales where + ΞΊβ‚€ := explicitKappa + ΞΎβ‚€ := explicitXiSource + Ξ³β‚€ := explicitGamma + ΞΊβ‚€_pos := explicitKappa_pos + ΞΎβ‚€_pos := by norm_num [explicitXiSource] + Ξ³β‚€_pos := by norm_num [explicitGamma] + cleanGain := explicit_cleanPairGain_constants + completion := explicit_completionScales + +theorem cleanPairGainGuarantee_mono_gamma + {ΞΊ ΞΎ Ξ³ Ξ³' : ℝ} (h : CleanPairGainGuarantee ΞΊ ΞΎ Ξ³) + (hΞ³ : Ξ³' ≀ Ξ³) : CleanPairGainGuarantee ΞΊ ΞΎ Ξ³' := by + intro n ell ΞΎ' Ο„ A X rscale cscale hell hlog hΞΎ hΞΎsource hΟ„ hA hX + hXint hr hc hKKT r s a b hrs hab hcost + exact hΞ³.trans (h hell hlog hΞΎ hΞΎsource hΟ„ hA hX hXint hr hc hKKT + hrs hab hcost) + +theorem explicitGreedyGamma_pos : 0 < explicitGreedyGamma := by + norm_num [explicitGreedyGamma, explicitGamma] + +/-- The explicit completion parameters equipped with the stronger gain comparison needed for +greedy completion. -/ +def explicitGreedyCompletionScales : + RationalCompletionScales explicitKappa explicitXiSource + explicitGreedyGamma := + { explicit_completionScales with + ΞΎ_lt_gain := by + have hΞ΄small : explicitDelta ≀ 1 / 200000 := by + have h := explicitDelta_le_rowRatio + have hr : ((explicitRowRatio : β„š) : ℝ) = 1 / 200000 := by + norm_num [explicitRowRatio] + rw [hr] at h + have h' : ((explicitDelta : β„š) : ℝ) ≀ (((1 / 200000 : β„š)) : ℝ) := by + simpa using h + exact_mod_cast h' + change explicitXi < 3 * explicitGreedyGamma / 8 + rw [explicitXi, explicitGreedyGamma, explicitGamma] + calc + explicitDelta / 100 < explicitDelta := by + exact div_lt_self explicitDelta_pos (by norm_num) + _ ≀ 1 / 200000 := hΞ΄small + _ < 3 * ((1 / 4) / 4) / 8 := by norm_num } + +/-- Structural data weakened exactly by the constant-factor loss of the +greedy implementation. All analytic inequalities and hard-coded scales are +unchanged. -/ +def explicitGreedyStructuralScales : RationalStructuralScales where + ΞΊβ‚€ := explicitKappa + ΞΎβ‚€ := explicitXiSource + Ξ³β‚€ := explicitGreedyGamma + ΞΊβ‚€_pos := explicitKappa_pos + ΞΎβ‚€_pos := by norm_num [explicitXiSource] + Ξ³β‚€_pos := explicitGreedyGamma_pos + cleanGain := cleanPairGainGuarantee_mono_gamma + explicit_cleanPairGain_constants (by + norm_num [explicitGreedyGamma, explicitGamma]) + completion := explicitGreedyCompletionScales + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ExplicitScheduledFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/ExplicitScheduledFeasibility.lean new file mode 100644 index 0000000000..b2d8a69ccd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ExplicitScheduledFeasibility.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledFeasibility +public import Mathlib.Tactic + +/-! # Explicit Scheduled Feasibility -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# An explicit schedule for a zero-centered rational ball + +Every Bethe feasibility call starts from a zero-centered diagonal ball. For +that special initial state there is no reason to compute a matrix common +denominator. The canonical bit length of the radius gives both a dyadic +lower bound on the initial determinant and a dyadic upper bound on the exact +initial state magnitude. This file packages those two exponents into the +fixed-precision feasibility runner used by the finite-word implementation. +-/ + +/-- The initial determinant exponent budget: dimension times the encoded radius length. -/ +def explicitBallInitialDetExponent (d : β„•) (R : β„š) : β„• := + encodedBitLength β„š R * d + +/-- The initial ball magnitude bound `2 + d*R`. -/ +def explicitBallInitialMagnitudeBound (d : β„•) (R : β„š) : β„š := + 2 + d * R + +/-- The encoded bit length of the initial ball magnitude bound. -/ +def explicitBallInitialMagnitudeExponent (d : β„•) (R : β„š) : β„• := + encodedBitLength β„š (explicitBallInitialMagnitudeBound d R) + +/-- The rounded-ellipsoid precision schedule determined by the initial ball and iteration +budget. -/ +def explicitBallFeasibilityPrecision (d budget : β„•) (R : β„š) : β„• := + roundedEllipsoidPrecisionSchedule d + (explicitBallInitialDetExponent d R) + (explicitBallInitialMagnitudeExponent d R) budget + +/-- Run fixed-precision rational feasibility from the radius-`R` ball centered at zero. -/ +def runExplicitBallRationalFeasibility {d : β„•} + (oracle : RationalCentralOracle d) (budget : β„•) (R : β„š) : + RationalFeasibilityResult d := + runFixedPrecisionRationalFeasibility + (explicitBallFeasibilityPrecision d budget R) oracle budget + (rationalBallEllipsoid d 0 R) + +theorem explicitBallInitialDetExponent_lower {d : β„•} {R : β„š} + (hR : 0 < R) : + dyadicMesh (explicitBallInitialDetExponent d R) ≀ R ^ d := by + let L := encodedBitLength β„š R + have hlower : dyadicMesh L < R := by + rw [dyadicMesh_eq_half_pow] + simpa only [L] using dyadic_encodedBitLength_lt_positive_rational hR + have hlower' : dyadicMesh L ≀ R := hlower.le + have hpow : dyadicMesh L ^ d ≀ R ^ d := + pow_le_pow_leftβ‚€ (dyadicMesh_nonneg L) hlower' d + rw [explicitBallInitialDetExponent, dyadicMesh_eq_half_pow] + rw [show encodedBitLength β„š R * d = L * d by rfl, pow_mul] + simpa only [dyadicMesh_eq_half_pow] using hpow + +theorem rationalStateAbsBound_zero_ball {d : β„•} {R : β„š} + (hR : 0 ≀ R) : + rationalStateAbsBound (rationalBallEllipsoid d 0 R) = + explicitBallInitialMagnitudeBound d R := by + classical + rw [rationalStateAbsBound, rationalCenterAbsBound, + rationalMatrixAbsBound, explicitBallInitialMagnitudeBound] + simp only [rationalBallEllipsoid, Pi.zero_apply, abs_zero, + Finset.sum_const_zero, zero_add] + have hinner (i : Fin d) : + (βˆ‘ j : Fin d, abs (if i = j then R else 0)) = R := by + calc + (βˆ‘ j : Fin d, abs (if i = j then R else 0)) = + βˆ‘ j : Fin d, if i = j then R else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hij : i = j <;> simp [hij, abs_of_nonneg hR] + _ = R := by + simpa using Fintype.sum_ite_eq i (fun _ : Fin d ↦ R) + have hsum : + (βˆ‘ i : Fin d, βˆ‘ j : Fin d, abs (if i = j then R else 0)) = + βˆ‘ _i : Fin d, R := by + apply Finset.sum_congr rfl + intro i _ + exact hinner i + rw [hsum] + simp + ring + +theorem explicitBallInitialMagnitudeExponent_upper {d : β„•} {R : β„š} + (hR : 0 < R) : + rationalStateAbsBound (rationalBallEllipsoid d 0 R) ≀ + (2 : β„š) ^ explicitBallInitialMagnitudeExponent d R := by + rw [rationalStateAbsBound_zero_ball hR.le] + have hbound : 0 < explicitBallInitialMagnitudeBound d R := by + rw [explicitBallInitialMagnitudeBound] + positivity + exact (positive_rational_lt_two_pow_encodedBitLength hbound).le + +theorem explicitBallInitialInvariant {d : β„•} {R : β„š} + (hR : 0 < R) : + ScheduledEllipsoidInvariant d + (explicitBallInitialDetExponent d R) + (explicitBallInitialMagnitudeExponent d R) 0 + (rationalBallEllipsoid d 0 R) := by + refine ⟨?_, ?_, ?_⟩ + Β· rw [det_rationalBallEllipsoid] + exact pow_ne_zero d hR.ne' + Β· rw [det_rationalBallEllipsoid, abs_of_pos (pow_pos hR d)] + simpa using explicitBallInitialDetExponent_lower hR + Β· simpa using explicitBallInitialMagnitudeExponent_upper hR + +theorem runExplicitBallRationalFeasibility_acceptsOnly {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} {oracle : RationalCentralOracle d} + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {budget : β„•} {R : β„š} {x : Fin d β†’ β„š} + (hrun : runExplicitBallRationalFeasibility oracle budget R = + .accepted x) : Good x := by + exact runFixedPrecisionRationalFeasibility_acceptsOnly haccept + (by simpa only [runExplicitBallRationalFeasibility] using hrun) + +theorem runExplicitBallRationalFeasibility_not_exhausted_of_inner_cross + {d M : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + {R : β„š} (hR : 0 < R) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hdyadic : d.factorial * (R : ℝ) ^ d * + (1 / 2 : ℝ) ^ M < r ^ d) + (hTargetPlus : βˆ€ k, Target + (fun i ↦ z i + if i = k then r else 0)) + (hTargetMinus : βˆ€ k, Target + (fun i ↦ z i - if i = k then r else 0)) + (hEplus : βˆ€ k, RationalEllipsoidContains + (rationalBallEllipsoid d 0 R) + (fun i ↦ z i + if i = k then r else 0)) + (hEminus : βˆ€ k, RationalEllipsoidContains + (rationalBallEllipsoid d 0 R) + (fun i ↦ z i - if i = k then r else 0)) + (E' : RationalEllipsoidState d) : + runExplicitBallRationalFeasibility oracle (32 * d ^ 3 * M) R β‰  + .exhausted E' := by + intro hrun + let L := explicitBallInitialDetExponent d R + let K := explicitBallInitialMagnitudeExponent d R + let T := 32 * d ^ 3 * M + let E := rationalBallEllipsoid d 0 R + have hInv : ScheduledEllipsoidInvariant d L K 0 E := by + simpa only [L, K, E] using explicitBallInitialInvariant hR + have hrun' : runFixedPrecisionRationalFeasibility + (roundedEllipsoidPrecisionSchedule d L K T) oracle T E = + .exhausted E' := by + simpa only [runExplicitBallRationalFeasibility, + explicitBallFeasibilityPrecision, L, K, T, E] using hrun + have hplus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i + if i = k then r else 0) := by + intro k + exact runFixedPrecisionRationalFeasibility_preserves_target_of_exhausted + hd hvalid hInv (by omega) hrun' (hTargetPlus k) (hEplus k) + have hminus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i - if i = k then r else 0) := by + intro k + exact runFixedPrecisionRationalFeasibility_preserves_target_of_exhausted + hd hvalid hInv (by omega) hrun' (hTargetMinus k) (hEminus k) + have hlower := rationalEllipsoid_storedDet_lower_of_ball_endpoints + E' hr (fun k ↦ hplus k) (fun k ↦ hminus k) + have hupper := runFixedPrecisionRationalFeasibility_det_upper_of_exhausted + hd hvalid hInv (by omega) hrun' + have hfactor := roundedContractionFactor_pow_budget_le_half_pow + (d := d) (M := M) hd + have hdetUpper : abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 / 2 : ℝ) ^ M * (R : ℝ) ^ d := by + rw [show abs ((Matrix.det E.basis : β„š) : ℝ) = (R : ℝ) ^ d by + dsimp only [E] + rw [det_rationalBallEllipsoid, Rat.cast_pow, + abs_of_pos (pow_pos (Rat.cast_pos.mpr hR) d)]] at hupper + exact hupper.trans + (mul_le_mul_of_nonneg_right hfactor (by positivity)) + have hsandwich : r ^ d ≀ + d.factorial * (R : ℝ) ^ d * (1 / 2 : ℝ) ^ M := by + calc + r ^ d ≀ d.factorial * + abs ((Matrix.det E'.basis : β„š) : ℝ) := hlower + _ ≀ d.factorial * ((1 / 2 : ℝ) ^ M * (R : ℝ) ^ d) := + mul_le_mul_of_nonneg_left hdetUpper (Nat.cast_nonneg _) + _ = d.factorial * (R : ℝ) ^ d * (1 / 2 : ℝ) ^ M := by ring + exact (not_lt_of_ge hsandwich) hdyadic + +theorem runExplicitBallRationalFeasibility_ball_accepts + {d : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {Good : (Fin d β†’ β„š) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {R r : β„š} (hR : 0 < R) (hr : 0 < r) + {z : Fin d β†’ ℝ} + (hTargetPlus : βˆ€ k, Target + (fun i ↦ z i + if i = k then (r : ℝ) else 0)) + (hTargetMinus : βˆ€ k, Target + (fun i ↦ z i - if i = k then (r : ℝ) else 0)) + (houterPlus : βˆ€ k, finiteNormSq + (fun i ↦ z i + if i = k then (r : ℝ) else 0) ≀ (R : ℝ) ^ 2) + (houterMinus : βˆ€ k, finiteNormSq + (fun i ↦ z i - if i = k then (r : ℝ) else 0) ≀ (R : ℝ) ^ 2) : + let M := rationalBallDyadicExponent d R r + let budget := 32 * d ^ 3 * M + βˆƒ x : Fin d β†’ β„š, + runExplicitBallRationalFeasibility oracle budget R = .accepted x ∧ + Good x := by + dsimp only + let M := rationalBallDyadicExponent d R r + let budget := 32 * d ^ 3 * M + let result := runExplicitBallRationalFeasibility oracle budget R + cases hresult : result with + | accepted x => + refine ⟨x, ?_, ?_⟩ + Β· simpa only [result, budget, M] using hresult + Β· exact runExplicitBallRationalFeasibility_acceptsOnly haccept + (by simpa only [result, budget, M] using hresult) + | exhausted E' => + exfalso + apply runExplicitBallRationalFeasibility_not_exhausted_of_inner_cross + hd hvalid hR (hr := Rat.cast_nonneg.mpr hr.le) + (by + have hbudget := rationalBallEllipsoid_dyadic_budget + hd (0 : Fin d β†’ β„š) hR hr + rw [det_rationalBallEllipsoid, Rat.cast_pow, + abs_of_pos (pow_pos (Rat.cast_pos.mpr hR) d)] at hbudget + simpa only [M] using hbudget) + hTargetPlus hTargetMinus + Β· intro k + apply rationalBallEllipsoid_contains 0 hR + simpa using houterPlus k + Β· intro k + apply rationalBallEllipsoid_contains 0 hR + simpa using houterMinus k + Β· simpa only [result, budget, M] using hresult + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/FinalAssembly.lean b/LeanPool/BeyondBethe/BeyondBethe/FinalAssembly.lean new file mode 100644 index 0000000000..47f6ab8bb0 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/FinalAssembly.lean @@ -0,0 +1,517 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.BeyondBethe.Smoothing +public import LeanPool.BeyondBethe.BeyondBethe.KuhnMatching + +/-! # Final Assembly -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- A rational scaling factor that is positive on every nonnegative matrix +and dominates each entry. Using `1 + sum A` avoids a special case for the +largest entry while retaining polynomial bit complexity. -/ +def rationalNormalizationScale {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : β„š := + 1 + βˆ‘ i, βˆ‘ j, A i j + +/-- Entrywise normalization used before smoothing. -/ +def normalizedRationalMatrix {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : Matrix (Fin n) (Fin n) β„š := + fun i j ↦ A i j / rationalNormalizationScale A + +/-- The factor assigned to one matrix coordinate when forming the support +floor. -/ +def rationalSupportFactor {n : β„•} + (B : Matrix (Fin n) (Fin n) β„š) (p : Fin n Γ— Fin n) : β„š := + if B p.1 p.2 = 0 then 1 else B p.1 p.2 + +/-- A rational lower bound for every nonzero entry of a normalized matrix. +Zero entries contribute the neutral factor. -/ +def rationalSupportFloor {n : β„•} + (B : Matrix (Fin n) (Fin n) β„š) : β„š := + ∏ p ∈ (Finset.univ.product Finset.univ), + rationalSupportFactor B p + +/-- The paper's rational smoothing level, applied after normalization. -/ +def rationalSmoothingDelta {n : β„•} + (B : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) : β„š := + min (1 / (2 * n)) + (Ο‡ * rationalSupportFloor B ^ n / (4 * Nat.factorial n)) + +/-- The canonical positive rational perturbation used by the final +algorithm. -/ +def smoothedRationalMatrix {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) : + Matrix (Fin n) (Fin n) β„š := + let B := normalizedRationalMatrix A + let Ξ΄ := rationalSmoothingDelta B Ο‡ + fun i j ↦ B i j + Ξ΄ + +/-- What the certified finite-precision routine must provide on positive +rational matrices. Its numerical loss is exactly the allowance in Lemma 24 +of the paper. -/ +structure CertifiedPositiveRoutine (Ξ΅ : ℝ) where + /-- The rational matrix algorithm whose positive-input permanent bounds are certified by the + remaining fields. -/ + alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + positiveOutput : βˆ€ {n : β„•}, 2 ≀ n β†’ + βˆ€ A : Matrix (Fin n) (Fin n) β„š, + Matrix.Positive (fun i j ↦ (A i j : ℝ)) β†’ + 0 < ((alg n A : β„š) : ℝ) + lower : βˆ€ {n : β„•}, 2 ≀ n β†’ + βˆ€ A : Matrix (Fin n) (Fin n) β„š, + Matrix.Positive (fun i j ↦ (A i j : ℝ)) β†’ + ((alg n A : β„š) : ℝ) ≀ ((Matrix.permanent A : β„š) : ℝ) + upper : βˆ€ {n : β„•}, 2 ≀ n β†’ + βˆ€ A : Matrix (Fin n) (Fin n) β„š, + Matrix.Positive (fun i j ↦ (A i j : ℝ)) β†’ + ((Matrix.permanent A : β„š) : ℝ) ≀ + (preSmoothingBase Ξ΅) ^ n * ((alg n A : β„š) : ℝ) + +/-- Executable entrywise nonnegativity test. The outer algorithm uses this +guard to remain a polynomial-time total function on all rational matrices, +including inputs outside the approximation theorem's domain. -/ +def rationalMatrixNonnegativeDecision {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : Bool := by + letI : βˆ€ i j : Fin n, Decidable (0 ≀ A i j) := fun i j => inferInstance + letI : βˆ€ i : Fin n, Decidable (βˆ€ j : Fin n, 0 ≀ A i j) := + fun i => Fintype.decidableForallFintype + exact @decide (βˆ€ i : Fin n, βˆ€ j : Fin n, 0 ≀ A i j) + Fintype.decidableForallFintype + +theorem rationalMatrixNonnegativeDecision_eq_true_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + rationalMatrixNonnegativeDecision A = true ↔ Matrix.Nonnegative A := by + simp [rationalMatrixNonnegativeDecision, Matrix.Nonnegative] + +/-- Rational wrapper around the positive-matrix routine. Matrices of order +zero or one are evaluated exactly; a matrix with no support matching returns +zero; otherwise we normalize, smooth, call the positive routine, and undo the +normalization and smoothing factor. -/ +def completedAlgorithm + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) (Ο‡ : β„š) : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š := by + exact fun n A ↦ + if rationalMatrixNonnegativeDecision A then + if n < 2 then Matrix.permanent A + else if kuhnSupportMatchingDecision A then + let scale := rationalNormalizationScale A + let lowerSmooth := routine.alg n (smoothedRationalMatrix A Ο‡) + scale ^ n * lowerSmooth / (1 + Ο‡ * n / 2) + else 0 + else 0 + +theorem rationalNormalizationScale_pos + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) : + 0 < rationalNormalizationScale A := by + have hsum : 0 ≀ βˆ‘ i, βˆ‘ j, A i j := + Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ hA i j + simp only [rationalNormalizationScale] + linarith + +theorem entry_le_rationalNormalizationScale + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) (i j : Fin n) : + A i j ≀ rationalNormalizationScale A := by + have hrow : A i j ≀ βˆ‘ k, A i k := + Finset.single_le_sum (fun k _ ↦ hA i k) (Finset.mem_univ j) + have htotal : (βˆ‘ k, A i k) ≀ βˆ‘ r, βˆ‘ k, A r k := + Finset.single_le_sum + (fun r _ ↦ Finset.sum_nonneg fun k _ ↦ hA r k) + (Finset.mem_univ i) + simp only [rationalNormalizationScale] + linarith + +theorem normalizedRationalMatrix_nonnegative + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) : + Matrix.Nonnegative (normalizedRationalMatrix A) := by + intro i j + exact div_nonneg (hA i j) (rationalNormalizationScale_pos hA).le + +theorem normalizedRationalMatrix_le_one + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) (i j : Fin n) : + normalizedRationalMatrix A i j ≀ 1 := by + rw [normalizedRationalMatrix, div_le_one + (rationalNormalizationScale_pos hA)] + exact entry_le_rationalNormalizationScale hA i j + +theorem normalizedRationalMatrix_ne_zero_iff + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) (i j : Fin n) : + normalizedRationalMatrix A i j β‰  0 ↔ A i j β‰  0 := by + rw [normalizedRationalMatrix, div_ne_zero_iff] + simp [ne_of_gt (rationalNormalizationScale_pos hA)] + +theorem normalizedRationalMatrix_hasPerfectMatching + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) + (hmatch : Matrix.HasPerfectMatching A) : + Matrix.HasPerfectMatching (normalizedRationalMatrix A) := by + obtain βŸ¨Οƒ, hΟƒβŸ© := hmatch + exact βŸ¨Οƒ, fun i ↦ (normalizedRationalMatrix_ne_zero_iff hA _ _).2 (hΟƒ i)⟩ + +theorem rationalSupportFactor_pos + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB : Matrix.Nonnegative B) (p : Fin n Γ— Fin n) : + 0 < rationalSupportFactor B p := by + rw [rationalSupportFactor] + split_ifs with hp + Β· norm_num + Β· exact lt_of_le_of_ne (hB p.1 p.2) (Ne.symm hp) + +theorem rationalSupportFactor_le_one + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB1 : βˆ€ i j, B i j ≀ 1) (p : Fin n Γ— Fin n) : + rationalSupportFactor B p ≀ 1 := by + rw [rationalSupportFactor] + split_ifs + Β· rfl + Β· exact hB1 p.1 p.2 + +theorem finset_prod_le_factor + {Ξ± : Type*} [DecidableEq Ξ±] + {s : Finset Ξ±} {f : Ξ± β†’ β„š} {p : Ξ±} + (hp : p ∈ s) (hpos : βˆ€ q ∈ s, 0 ≀ f q) + (hone : βˆ€ q ∈ s, f q ≀ 1) : + ∏ q ∈ s, f q ≀ f p := by + rw [← Finset.prod_erase_mul s f hp] + have herase : ∏ q ∈ s.erase p, f q ≀ 1 := + Finset.prod_le_oneβ‚€ + (fun q hq ↦ hpos q (Finset.mem_of_mem_erase hq)) + (fun q hq ↦ hone q (Finset.mem_of_mem_erase hq)) + exact (mul_le_mul_of_nonneg_right herase (hpos p hp)).trans_eq (one_mul _) + +theorem rationalSupportFloor_pos + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB : Matrix.Nonnegative B) : + 0 < rationalSupportFloor B := by + rw [rationalSupportFloor] + exact Finset.prod_pos fun p _ ↦ rationalSupportFactor_pos hB p + +theorem rationalSupportFloor_le_entry + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB : Matrix.Nonnegative B) (hB1 : βˆ€ i j, B i j ≀ 1) + (i j : Fin n) (hij : B i j β‰  0) : + rationalSupportFloor B ≀ B i j := by + let s : Finset (Fin n Γ— Fin n) := Finset.univ.product Finset.univ + have hp : (i, j) ∈ s := by simp [s] + have hprod := finset_prod_le_factor hp + (fun p _ ↦ (rationalSupportFactor_pos hB p).le) + (fun p _ ↦ rationalSupportFactor_le_one hB1 p) + simpa [rationalSupportFloor, rationalSupportFactor, hij, s] using hprod + +theorem cast_rationalNormalizationScale + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + ((rationalNormalizationScale A : β„š) : ℝ) = + 1 + βˆ‘ i, βˆ‘ j, (A i j : ℝ) := by + simp [rationalNormalizationScale] + +theorem cast_normalizedRationalMatrix + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : + ((normalizedRationalMatrix A i j : β„š) : ℝ) = + (A i j : ℝ) / (1 + βˆ‘ r, βˆ‘ k, (A r k : ℝ)) := by + simp [normalizedRationalMatrix, cast_rationalNormalizationScale] + +theorem cast_rationalSupportFloor + {n : β„•} (B : Matrix (Fin n) (Fin n) β„š) : + ((rationalSupportFloor B : β„š) : ℝ) = + ∏ p ∈ (Finset.univ.product Finset.univ), + if B p.1 p.2 = 0 then 1 else (B p.1 p.2 : ℝ) := by + classical + rw [rationalSupportFloor] + push_cast + apply Finset.prod_congr rfl + intro p _hp + by_cases h : B p.1 p.2 = 0 <;> + simp [rationalSupportFactor, h] + +theorem cast_rationalSmoothingDelta + {n : β„•} (B : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) : + ((rationalSmoothingDelta B Ο‡ : β„š) : ℝ) = + smoothingDelta n (rationalSupportFloor B : ℝ) (Ο‡ : ℝ) := by + simp [rationalSmoothingDelta, smoothingDelta] + +theorem cast_smoothedRationalMatrix + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) + (i j : Fin n) : + ((smoothedRationalMatrix A Ο‡ i j : β„š) : ℝ) = + (normalizedRationalMatrix A i j : ℝ) + + smoothingDelta n (rationalSupportFloor (normalizedRationalMatrix A) : ℝ) + (Ο‡ : ℝ) := by + simp [smoothedRationalMatrix, cast_rationalSmoothingDelta] + +theorem cast_normalizedRationalMatrix_nonnegative + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) : + Matrix.Nonnegative + (fun i j ↦ ((normalizedRationalMatrix A i j : β„š) : ℝ)) := by + intro i j + change 0 ≀ ((normalizedRationalMatrix A i j : β„š) : ℝ) + exact_mod_cast normalizedRationalMatrix_nonnegative hA i j + +theorem cast_normalizedRationalMatrix_le_one + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) (i j : Fin n) : + ((normalizedRationalMatrix A i j : β„š) : ℝ) ≀ 1 := by + exact_mod_cast normalizedRationalMatrix_le_one hA i j + +theorem cast_rationalSupportFloor_pos + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB : Matrix.Nonnegative B) : + 0 < ((rationalSupportFloor B : β„š) : ℝ) := by + exact_mod_cast rationalSupportFloor_pos hB + +theorem cast_rationalSupportFloor_le_entry + {n : β„•} {B : Matrix (Fin n) (Fin n) β„š} + (hB : Matrix.Nonnegative B) (hB1 : βˆ€ i j, B i j ≀ 1) + (i j : Fin n) + (hij : ((B i j : β„š) : ℝ) β‰  0) : + ((rationalSupportFloor B : β„š) : ℝ) ≀ (B i j : ℝ) := by + have hijq : B i j β‰  0 := by exact_mod_cast hij + exact_mod_cast rationalSupportFloor_le_entry hB hB1 i j hijq + +theorem cast_normalizedRationalMatrix_hasPerfectMatching + {n : β„•} {A : Matrix (Fin n) (Fin n) β„š} + (hA : Matrix.Nonnegative A) + (hmatch : Matrix.HasPerfectMatching A) : + Matrix.HasPerfectMatching + (fun i j ↦ ((normalizedRationalMatrix A i j : β„š) : ℝ)) := by + obtain βŸ¨Οƒ, hΟƒβŸ© := normalizedRationalMatrix_hasPerfectMatching hA hmatch + refine βŸ¨Οƒ, ?_⟩ + intro i + change ((normalizedRationalMatrix A (Οƒ i) i : β„š) : ℝ) β‰  0 + exact_mod_cast hΟƒ i + +/-- The explicit rational perturbation satisfies the real smoothing lemma. +This closes the zero-entry reduction independently of numerical convex +optimization. -/ +theorem canonical_smoothing_comparison + {n : β„•} (hn : 0 < n) + (A : Matrix (Fin n) (Fin n) β„š) (hA : Matrix.Nonnegative A) + (hmatch : Matrix.HasPerfectMatching A) + (Ο‡ : β„š) (hΟ‡ : 0 < (Ο‡ : ℝ)) : + let B : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((normalizedRationalMatrix A i j : β„š) : ℝ) + let Atilde : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((smoothedRationalMatrix A Ο‡ i j : β„š) : ℝ) + Matrix.permanent B ≀ Matrix.permanent Atilde ∧ + Matrix.permanent Atilde ≀ + (1 + (Ο‡ : ℝ) * n / 2) * Matrix.permanent B := by + dsimp only + let Bq := normalizedRationalMatrix A + let m : ℝ := (rationalSupportFloor Bq : β„š) + have hBq0 : Matrix.Nonnegative Bq := normalizedRationalMatrix_nonnegative hA + have hBq1 : βˆ€ i j, Bq i j ≀ 1 := normalizedRationalMatrix_le_one hA + have hm : 0 < m := cast_rationalSupportFloor_pos hBq0 + have hcomparison := smoothing_comparison_explicit + (fun i j ↦ ((Bq i j : β„š) : ℝ)) + (m := m) (Ο‡ := (Ο‡ : ℝ)) (by simpa using hn) hm hΟ‡ + (cast_normalizedRationalMatrix_nonnegative hA) + (cast_normalizedRationalMatrix_le_one hA) + (fun i j hij ↦ cast_rationalSupportFloor_le_entry hBq0 hBq1 i j hij) + (cast_normalizedRationalMatrix_hasPerfectMatching hA hmatch) + simpa [Bq, m, cast_smoothedRationalMatrix] using hcomparison + +theorem cast_smoothedRationalMatrix_positive + {n : β„•} (hn : 0 < n) + (A : Matrix (Fin n) (Fin n) β„š) (hA : Matrix.Nonnegative A) + (Ο‡ : β„š) (hΟ‡ : 0 < (Ο‡ : ℝ)) : + Matrix.Positive + (fun i j ↦ ((smoothedRationalMatrix A Ο‡ i j : β„š) : ℝ)) := by + let Bq := normalizedRationalMatrix A + have hBq0 : Matrix.Nonnegative Bq := normalizedRationalMatrix_nonnegative hA + have hm : 0 < ((rationalSupportFloor Bq : β„š) : ℝ) := + cast_rationalSupportFloor_pos hBq0 + have hΞ΄ : 0 < smoothingDelta n + ((rationalSupportFloor Bq : β„š) : ℝ) (Ο‡ : ℝ) := + smoothingDelta_pos hn hm hΟ‡ + intro i j + change 0 < ((smoothedRationalMatrix A Ο‡ i j : β„š) : ℝ) + rw [cast_smoothedRationalMatrix] + exact add_pos_of_nonneg_of_pos + (cast_normalizedRationalMatrix_nonnegative hA i j) hΞ΄ + +theorem cast_permanent_eq_scale_pow_mul_normalized + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (hA : Matrix.Nonnegative A) : + ((Matrix.permanent A : β„š) : ℝ) = + ((rationalNormalizationScale A : β„š) : ℝ) ^ n * + Matrix.permanent + (fun i j ↦ ((normalizedRationalMatrix A i j : β„š) : ℝ)) := by + let scale : ℝ := (rationalNormalizationScale A : β„š) + let B : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ ((normalizedRationalMatrix A i j : β„š) : ℝ) + have hscale : 0 < scale := by + dsimp only [scale] + exact_mod_cast rationalNormalizationScale_pos hA + have hmatrix : (fun i j ↦ ((A i j : β„š) : ℝ)) = scale β€’ B := by + ext i j + change (A i j : ℝ) = scale * B i j + dsimp only [B, scale] + rw [cast_normalizedRationalMatrix] + rw [cast_rationalNormalizationScale] + have hden : 1 + βˆ‘ r, βˆ‘ k, (A r k : ℝ) β‰  0 := by + simpa [scale, cast_rationalNormalizationScale] using hscale.ne' + field_simp [hden] + rw [Matrix.cast_permanent_rat, hmatrix, Matrix.permanent_scale_real] + simp [scale, B] + +theorem cast_completedAlgorithm_of_large_matching + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) (Ο‡ : β„š) + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (hA : Matrix.Nonnegative A) + (hmatch : Matrix.HasPerfectMatching A) : + (((completedAlgorithm routine Ο‡ n A : β„š) : ℝ)) = + ((rationalNormalizationScale A : β„š) : ℝ) ^ n * + ((routine.alg n (smoothedRationalMatrix A Ο‡) : β„š) : ℝ) / + (1 + (Ο‡ : ℝ) * n / 2) := by + have hnot : Β¬n < 2 := not_lt.mpr hn + have hdecision : kuhnSupportMatchingDecision A = true := + (kuhnSupportMatchingDecision_eq_true_iff A).2 hmatch + have hnonnegative : rationalMatrixNonnegativeDecision A = true := + (rationalMatrixNonnegativeDecision_eq_true_iff A).2 hA + simp [completedAlgorithm, hnonnegative, hnot, hdecision] + +/-- The explicit rational wrapper inherits the desired two-sided estimate on +the support-matching branch. -/ +theorem completedAlgorithm_guarantee_of_matching + {Ξ΅ : ℝ} (hΞ΅ : 0 < Ξ΅) + (routine : CertifiedPositiveRoutine Ξ΅) (Ο‡ : β„š) + (hΟ‡ : 0 < (Ο‡ : ℝ)) (hΟ‡small : (Ο‡ : ℝ) ≀ Ξ΅ / 2) + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (hA : Matrix.Nonnegative A) + (hmatch : Matrix.HasPerfectMatching A) : + ((completedAlgorithm routine Ο‡ n A : β„š) : ℝ) ≀ + ((Matrix.permanent A : β„š) : ℝ) ∧ + ((Matrix.permanent A : β„š) : ℝ) ≀ + (finalBase Ξ΅) ^ n * + ((completedAlgorithm routine Ο‡ n A : β„š) : ℝ) := by + let Bq := normalizedRationalMatrix A + let Aq := smoothedRationalMatrix A Ο‡ + let lower : ℝ := (routine.alg n Aq : β„š) + have hnpos : 0 < n := by omega + have hAqpos : Matrix.Positive (fun i j ↦ ((Aq i j : β„š) : ℝ)) := by + simpa only [Aq] using cast_smoothedRationalMatrix_positive hnpos A hA Ο‡ hΟ‡ + have hlowerPos : 0 < lower := routine.positiveOutput hn Aq hAqpos + have hcertLower : lower ≀ Matrix.permanent + (fun i j ↦ ((Aq i j : β„š) : ℝ)) := by + rw [← Matrix.cast_permanent_rat] + exact routine.lower hn Aq hAqpos + have hcertUpper : Matrix.permanent + (fun i j ↦ ((Aq i j : β„š) : ℝ)) ≀ + (preSmoothingBase Ξ΅) ^ n * lower := by + rw [← Matrix.cast_permanent_rat] + exact routine.upper hn Aq hAqpos + obtain ⟨hsmoothLower, hsmoothUpper⟩ := + canonical_smoothing_comparison hnpos A hA hmatch Ο‡ hΟ‡ + have hassembly := assemble_smoothing_and_numerics hΞ΅ hΟ‡.le hΟ‡small + hlowerPos hsmoothLower hsmoothUpper hcertLower hcertUpper + have hscale : 0 < ((rationalNormalizationScale A : β„š) : ℝ) := by + exact_mod_cast rationalNormalizationScale_pos hA + have houtput := cast_completedAlgorithm_of_large_matching routine Ο‡ hn A hA hmatch + have hper := cast_permanent_eq_scale_pow_mul_normalized A hA + constructor + Β· rw [houtput, hper] + have hmul := mul_le_mul_of_nonneg_left hassembly.1 + (pow_nonneg hscale.le n) + simpa [lower, Aq, div_eq_mul_inv, mul_assoc] using hmul + Β· rw [houtput, hper] + have hmul := mul_le_mul_of_nonneg_left hassembly.2 + (pow_nonneg hscale.le n) + simpa [lower, Aq, div_eq_mul_inv, mul_assoc, mul_left_comm, mul_comm] using hmul + +theorem exactPositiveCertificate_mono + {Ξ΅ Ξ΅' : ℝ} (hΞ΅ : Ξ΅' ≀ Ξ΅) + (hcert : ExactPositiveCertificate Ξ΅) : + ExactPositiveCertificate Ξ΅' := by + intro n hn A hA + obtain ⟨X, hX, hlower, hgap⟩ := hcert hn A hA + refine ⟨X, hX, hlower, hgap.trans ?_⟩ + exact mul_le_mul_of_nonneg_right (by linarith) (Nat.cast_nonneg n) + +theorem one_lt_finalBase_of_le_log_two_half + {Ξ΅ : ℝ} (hΞ΅ : 0 < Ξ΅) (hbound : Ξ΅ ≀ Real.log 2 / 2) : + 1 < finalBase Ξ΅ := by + have hsqrt : 0 < Real.sqrt 2 := Real.sqrt_pos.2 (by norm_num) + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + rw [finalBase, ← Real.exp_log hsqrt, ← Real.exp_add, + Real.log_sqrt (by norm_num : (0 : ℝ) ≀ 2), Real.one_lt_exp_iff] + nlinarith + +theorem cast_permanent_nonnegative + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (hA : Matrix.Nonnegative A) : + 0 ≀ ((Matrix.permanent A : β„š) : ℝ) := by + rw [Matrix.cast_permanent_rat] + apply Matrix.permanent_nonneg_real + intro i j + change 0 ≀ ((A i j : β„š) : ℝ) + exact_mod_cast hA i j + +/-- All nonnumerical branches of Theorem 1: exact treatment of orders zero +and one, the zero-support case, normalization, smoothing, and rescaling. -/ +theorem completedAlgorithm_guarantee + {Ξ΅ : ℝ} (hΞ΅ : 0 < Ξ΅) (hΞ΅bound : Ξ΅ ≀ Real.log 2 / 2) + (routine : CertifiedPositiveRoutine Ξ΅) (Ο‡ : β„š) + (hΟ‡ : 0 < (Ο‡ : ℝ)) (hΟ‡small : (Ο‡ : ℝ) ≀ Ξ΅ / 2) : + βˆ€ n (A : Matrix (Fin n) (Fin n) β„š), + Matrix.Nonnegative A β†’ + ((completedAlgorithm routine Ο‡ n A : β„š) : ℝ) ≀ + ((Matrix.permanent A : β„š) : ℝ) ∧ + ((Matrix.permanent A : β„š) : ℝ) ≀ + (finalBase Ξ΅) ^ n * + ((completedAlgorithm routine Ο‡ n A : β„š) : ℝ) := by + intro n A hA + have hnonnegative : rationalMatrixNonnegativeDecision A = true := + (rationalMatrixNonnegativeDecision_eq_true_iff A).2 hA + by_cases hn : n < 2 + Β· have hout : completedAlgorithm routine Ο‡ n A = Matrix.permanent A := by + simp [completedAlgorithm, hnonnegative, hn] + rw [hout] + refine ⟨le_rfl, ?_⟩ + have hbase : 1 ≀ finalBase Ξ΅ := + (one_lt_finalBase_of_le_log_two_half hΞ΅ hΞ΅bound).le + have hpow : 1 ≀ (finalBase Ξ΅) ^ n := one_le_powβ‚€ hbase + simpa using mul_le_mul_of_nonneg_right hpow + (cast_permanent_nonnegative A hA) + Β· have hnlarge : 2 ≀ n := by omega + by_cases hmatch : Matrix.HasPerfectMatching A + Β· exact completedAlgorithm_guarantee_of_matching hΞ΅ routine Ο‡ hΟ‡ + hΟ‡small hnlarge A hA hmatch + Β· have hper : Matrix.permanent A = 0 := + Matrix.permanent_eq_zero_of_noPerfectMatching A hmatch + have hdecision : kuhnSupportMatchingDecision A = false := + (kuhnSupportMatchingDecision_eq_false_iff A).2 hmatch + simp [completedAlgorithm, hnonnegative, hn, hdecision, hper] + +/-- The smoothing budget is a fixed rational function of the requested +improvement and is therefore explicit algorithmic data. -/ +def canonicalSmoothingParameter (Ξ΅ : β„š) : β„š := Ξ΅ / 4 + +theorem canonicalSmoothingParameter_pos {Ξ΅ : β„š} (hΞ΅ : 0 < Ξ΅) : + 0 < (canonicalSmoothingParameter Ξ΅ : ℝ) := by + rw [canonicalSmoothingParameter] + exact_mod_cast div_pos hΞ΅ (by norm_num : (0 : β„š) < 4) + +theorem canonicalSmoothingParameter_le_half {Ξ΅ : β„š} (hΞ΅ : 0 < Ξ΅) : + (canonicalSmoothingParameter Ξ΅ : ℝ) ≀ (Ξ΅ : ℝ) / 2 := by + norm_num [canonicalSmoothingParameter] + have hΞ΅real : 0 ≀ (Ξ΅ : ℝ) := by exact_mod_cast hΞ΅.le + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Gain.lean b/LeanPool/BeyondBethe/BeyondBethe/Gain.lean new file mode 100644 index 0000000000..26490db56a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Gain.lean @@ -0,0 +1,440 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Capacity +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import Mathlib.Analysis.Convex.SpecificFunctions.Basic +public import Mathlib.Tactic + +/-! # Gain -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The row factor `ΞΆ_i` from paper (47). -/ +noncomputable def rowZeta + {ΞΉ : Type*} [Fintype ΞΉ] (Ο„ : ℝ) (p : ΞΉ β†’ ℝ) : ℝ := + ∏ j, (p j) ^ (Ο„ * p j) + +theorem rowZeta_pos + {ΞΉ : Type*} [Fintype ΞΉ] + {Ο„ : ℝ} {p : ΞΉ β†’ ℝ} (hp : βˆ€ j, 0 < p j) : + 0 < rowZeta Ο„ p := by + rw [rowZeta] + exact Finset.prod_pos fun j _ ↦ Real.rpow_pos_of_pos (hp j) _ + +theorem rowZeta_le_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {p : ΞΉ β†’ ℝ} + (hp : IsProbabilityVector p) : + rowZeta Ο„ p ≀ 1 := by + rw [rowZeta] + apply Finset.prod_le_oneβ‚€ + Β· intro j _ + exact Real.rpow_nonneg (hp.nonnegative j) _ + Β· intro j _ + exact Real.rpow_le_one (hp.nonnegative j) (hp.le_one j) + (mul_nonneg hΟ„ (hp.nonnegative j)) + +/-- The total coordinate mass outside the two distinguished columns. -/ +noncomputable def outsideMassTwo + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) (a b : ΞΉ) : ℝ := + βˆ‘ j ∈ (Finset.univ.erase a).erase b, p j + +theorem outsideMassTwo_comm + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) (a b : ΞΉ) : + outsideMassTwo p a b = outsideMassTwo p b a := by + rw [outsideMassTwo, outsideMassTwo] + congr 1 + ext j + simp only [Finset.mem_erase, Finset.mem_univ, and_true] + tauto + +theorem twoCore_add_outsideMassTwo + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) + {a b : ΞΉ} (hab : a β‰  b) : + p a + p b + outsideMassTwo p a b = 1 := by + have ha : a ∈ (Finset.univ : Finset ΞΉ) := Finset.mem_univ a + have hb : b ∈ (Finset.univ.erase a) := by simp [hab.symm] + have htotal := hp.sum_eq_one + rw [← Finset.sum_erase_add _ _ ha] at htotal + rw [← Finset.sum_erase_add _ _ hb] at htotal + rw [outsideMassTwo] + linarith + +theorem twoCore_add_outsideMassTwo_eq_sum + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) {a b : ΞΉ} (hab : a β‰  b) : + p a + p b + outsideMassTwo p a b = βˆ‘ j, p j := by + have ha : a ∈ (Finset.univ : Finset ΞΉ) := Finset.mem_univ a + have hb : b ∈ (Finset.univ.erase a) := by simp [hab.symm] + rw [← Finset.sum_erase_add _ _ ha, ← Finset.sum_erase_add _ _ hb, + outsideMassTwo] + ring + +theorem outsideMassTwo_nonneg + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) (a b : ΞΉ) : + 0 ≀ outsideMassTwo p a b := by + rw [outsideMassTwo] + exact Finset.sum_nonneg fun j _ ↦ hp.nonnegative j + +theorem productExcept_eq_twoCore + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) {a b : ΞΉ} (hab : a β‰  b) : + productExcept p a = (1 - p b) * + ∏ j ∈ (Finset.univ.erase a).erase b, (1 - p j) := by + rw [productExcept] + exact (Finset.mul_prod_erase (Finset.univ.erase a) (fun j ↦ 1 - p j) + (by simp [hab.symm])).symm + +/-- The two upper bounds (45)--(46) used in the leakage argument. -/ +theorem transferU_le_twoCore_ratio + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {p : ΞΉ β†’ ℝ} + (hp : IsInteriorProbabilityVector p) {a b : ΞΉ} (hab : a β‰  b) : + transferU Ο„ p a ≀ + p a / (p a + outsideMassTwo p a b * p b) := by + let s : Finset ΞΉ := (Finset.univ.erase a).erase b + let t := outsideMassTwo p a b + have ht : 0 ≀ t := outsideMassTwo_nonneg hp.1 a b + have hsum := twoCore_add_outsideMassTwo hp.1 hab + have houtsideSum : βˆ‘ j ∈ s, p j = t := rfl + have hprodOutside : 1 - t ≀ ∏ j ∈ s, (1 - p j) := by + apply one_sub_sum_le_prod_one_sub s p + Β· intro j _ + exact hp.1.nonnegative j + Β· rw [houtsideSum] + linarith [hp.1.nonnegative a, hp.1.nonnegative b] + have hbcomp : 0 < 1 - p b := sub_pos.mpr (hp.2 b).2 + have hdenIdentity : + (1 - p b) * (1 - t) = p a + t * p b := by + linarith + have hdenLower : p a + t * p b ≀ productExcept p a := by + rw [productExcept_eq_twoCore p hab, ← hdenIdentity] + exact mul_le_mul_of_nonneg_left hprodOutside hbcomp.le + have hdenPos : 0 < p a + t * p b := + add_pos_of_pos_of_nonneg (hp.2 a).1 (mul_nonneg ht (hp.1.nonnegative b)) + have hnum : (p a) ^ (1 + Ο„) ≀ p a := by + have h := Real.rpow_le_rpow_of_exponent_ge' + (hp.1.nonnegative a) (hp.2 a).2.le (by norm_num : (0 : ℝ) ≀ 1) + (by linarith : (1 : ℝ) ≀ 1 + Ο„) + simpa using h + rw [transferU] + exact div_le_divβ‚€ (hp.1.nonnegative a) hnum hdenPos hdenLower + +/-- Scalar form of the leakage argument in paper (49)--(51). -/ +theorem leakage_le_inv_sub_one + {u xa xb t Ua Ub : ℝ} + (hu : 0 < u) (hu1 : u ≀ 1) + (hxa : 0 < xa) (hxb : 0 < xb) (ht : 0 ≀ t) + (hUa : u ≀ Ua) (hUb : u ≀ Ub) + (hUaUpper : Ua ≀ xa / (xa + t * xb)) + (hUbUpper : Ub ≀ xb / (xb + t * xa)) : + t ≀ u⁻¹ - 1 := by + have hdena : 0 < xa + t * xb := add_pos_of_pos_of_nonneg hxa (mul_nonneg ht hxb.le) + have hdenb : 0 < xb + t * xa := add_pos_of_pos_of_nonneg hxb (mul_nonneg ht hxa.le) + have ha := (hUa.trans hUaUpper) + have hb := (hUb.trans hUbUpper) + rw [le_div_iffβ‚€ hdena] at ha + rw [le_div_iffβ‚€ hdenb] at hb + have ha' : u * t * xb ≀ (1 - u) * xa := by nlinarith + have hb' : u * t * xa ≀ (1 - u) * xb := by nlinarith + have hleft0 : 0 ≀ u * t * xb := by positivity + have hright0 : 0 ≀ (1 - u) * xa := + mul_nonneg (sub_nonneg.mpr hu1) hxa.le + have hmul := mul_le_mul ha' hb' (by positivity) hright0 + have hsq : (u * t) ^ 2 ≀ (1 - u) ^ 2 := by + have hxy : 0 < xa * xb := mul_pos hxa hxb + apply le_of_mul_le_mul_right _ hxy + calc + (u * t) ^ 2 * (xa * xb) = + (u * t * xb) * (u * t * xa) := by ring + _ ≀ ((1 - u) * xa) * ((1 - u) * xb) := hmul + _ = (1 - u) ^ 2 * (xa * xb) := by ring + have hut : 0 ≀ u * t := mul_nonneg hu.le ht + have hone : 0 ≀ 1 - u := sub_nonneg.mpr hu1 + have hutle : u * t ≀ 1 - u := by nlinarith + calc + t ≀ (1 - u) / u := (le_div_iffβ‚€ hu).2 (by simpa [mul_comm] using hutle) + _ = u⁻¹ - 1 := by field_simp + +/-- Paper (47): two large core transfer coordinates force small mass outside +the two core columns. -/ +theorem outsideMassTwo_le_inv_sub_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ u : ℝ} (hΟ„ : 0 ≀ Ο„) (hu : 0 < u) (hu1 : u ≀ 1) + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) + {a b : ΞΉ} (hab : a β‰  b) + (hUa : u ≀ transferU Ο„ p a) (hUb : u ≀ transferU Ο„ p b) : + outsideMassTwo p a b ≀ u⁻¹ - 1 := by + apply leakage_le_inv_sub_one hu hu1 (hp.2 a).1 (hp.2 b).1 + (outsideMassTwo_nonneg hp.1 a b) hUa hUb + Β· exact transferU_le_twoCore_ratio hΟ„ hp hab + Β· have h := transferU_le_twoCore_ratio hΟ„ hp hab.symm + rw [outsideMassTwo_comm p b a] at h + simpa [mul_comm] using h + +theorem log_one_div_nonneg_of_pos_le_one + {u : ℝ} (hu : 0 < u) (hu1 : u ≀ 1) : + 0 ≀ Real.log (1 / u) := by + apply Real.log_nonneg + exact (le_div_iffβ‚€ hu).2 (by simpa using hu1) + +theorem exp_neg_le_of_log_one_div_le + {u ΞΊ : ℝ} (hu : 0 < u) + (hcost : Real.log (1 / u) ≀ ΞΊ) : + Real.exp (-ΞΊ) ≀ u := by + have hlog : -ΞΊ ≀ Real.log u := by + rw [one_div, Real.log_inv] at hcost + linarith + have hexp := Real.exp_le_exp.mpr hlog + rw [Real.exp_log hu] at hexp + exact hexp + +/-- The sum of the four logarithmic transfer costs at the two distinguished rows and columns. -/ +noncomputable def fourCoreTransferCost + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (Ο„ : ℝ) (X : Matrix ΞΉ ΞΉ ℝ) (r s a b : ΞΉ) : ℝ := + Real.log (1 / transferU Ο„ (X r) a) + + Real.log (1 / transferU Ο„ (X r) b) + + Real.log (1 / transferU Ο„ (X s) a) + + Real.log (1 / transferU Ο„ (X s) b) + +theorem fourCoreTransfer_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {X : Matrix ΞΉ ΞΉ ℝ} (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) : + Real.exp (-ΞΊ) ≀ transferU Ο„ (X r) a ∧ + Real.exp (-ΞΊ) ≀ transferU Ο„ (X r) b ∧ + Real.exp (-ΞΊ) ≀ transferU Ο„ (X s) a ∧ + Real.exp (-ΞΊ) ≀ transferU Ο„ (X s) b := by + have hpos : βˆ€ i j, 0 < transferU Ο„ (X i) j := + fun i j ↦ transferU_pos (hXint i) j + have hle : βˆ€ i j, transferU Ο„ (X i) j ≀ 1 := + fun i j ↦ transferU_le_one hΟ„ (hXint i) j + have hnonneg : βˆ€ i j, + 0 ≀ Real.log (1 / transferU Ο„ (X i) j) := + fun i j ↦ log_one_div_nonneg_of_pos_le_one (hpos i j) (hle i j) + rw [fourCoreTransferCost] at hcost + constructor + Β· apply exp_neg_le_of_log_one_div_le (hpos r a) + linarith [hnonneg r b, hnonneg s a, hnonneg s b] + constructor + Β· apply exp_neg_le_of_log_one_div_le (hpos r b) + linarith [hnonneg r a, hnonneg s a, hnonneg s b] + constructor + Β· apply exp_neg_le_of_log_one_div_le (hpos s a) + linarith [hnonneg r a, hnonneg r b, hnonneg s b] + Β· apply exp_neg_le_of_log_one_div_le (hpos s b) + linarith [hnonneg r a, hnonneg r b, hnonneg s a] + +theorem outsideMassTwo_pairAlpha + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (X : Matrix ΞΉ ΞΉ ℝ) (r s a b : ΞΉ) : + outsideMassTwo (pairAlpha X r s) a b = + outsideMassTwo (X r) a b + outsideMassTwo (X s) a b := by + rw [outsideMassTwo, outsideMassTwo, outsideMassTwo] + simp_rw [pairAlpha, Finset.sum_add_distrib] + +/-- Paper (48): a small four-entry transfer cost forces small two-row +leakage. -/ +theorem pairOutsideMass_le_exp + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) (hΞΊ : 0 ≀ ΞΊ) + {X : Matrix ΞΉ ΞΉ ℝ} (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : ΞΉ} (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) : + outsideMassTwo (pairAlpha X r s) a b ≀ + 2 * (Real.exp ΞΊ - 1) := by + have hcore := fourCoreTransfer_lower hΟ„ hXint hcost + have hu : 0 < Real.exp (-ΞΊ) := Real.exp_pos _ + have hu1 : Real.exp (-ΞΊ) ≀ 1 := by + rw [← Real.exp_zero] + exact Real.exp_le_exp.mpr (by linarith) + have hr := outsideMassTwo_le_inv_sub_one hΟ„ hu hu1 (hXint r) + hab hcore.1 hcore.2.1 + have hs := outsideMassTwo_le_inv_sub_one hΟ„ hu hu1 (hXint s) + hab hcore.2.2.1 hcore.2.2.2 + rw [outsideMassTwo_pairAlpha] + rw [show (Real.exp (-ΞΊ))⁻¹ = Real.exp ΞΊ by + rw [Real.exp_neg, inv_inv]] at hr hs + linarith + +theorem productExcept_le_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) (j : ΞΉ) : + productExcept p j ≀ 1 := by + rw [productExcept] + apply Finset.prod_le_oneβ‚€ + Β· intro k _ + exact sub_nonneg.mpr (hp.le_one k) + Β· intro k _ + linarith [hp.nonnegative k] + +/-- The denominator in `U_ij` is at most one, giving the first inequality in +paper (56). -/ +theorem coordinate_rpow_le_transferU + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + (p j) ^ (1 + Ο„) ≀ transferU Ο„ p j := by + have hdenPos := productExcept_pos hp j + rw [transferU, le_div_iffβ‚€ hdenPos] + exact mul_le_of_le_one_right (Real.rpow_nonneg (hp.1.nonnegative j) _) + (productExcept_le_one hp.1 j) + +/-- The three kinds of two-column sets used by the capacity witness in paper +(53): the core set, a set using `a` and an outside column, or a set using `b` +and an outside column. -/ +abbrev CapacityWitnessEdge (ΞΉ : Type*) := Unit βŠ• (ΞΉ βŠ• ΞΉ) + +/-- The capacity-witness edge masses: `1-ρ` on the central edge, and the scaled outside masses +on the two side families. -/ +noncomputable def capacityWitnessMass + {ΞΉ : Type*} (ρ Ξ΄a Ξ΄b : ℝ) (Ξ± : ΞΉ β†’ ℝ) : + CapacityWitnessEdge ΞΉ β†’ ℝ + | Sum.inl _ => 1 - ρ + | Sum.inr (Sum.inl l) => Ξ΄b / ρ * Ξ± l + | Sum.inr (Sum.inr l) => Ξ΄a / ρ * Ξ± l + +theorem capacityWitness_sum + {ΞΉ : Type*} [Fintype ΞΉ] + {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hΞ΄ : Ξ΄a + Ξ΄b = ρ) + (hΞ±sum : βˆ‘ l, Ξ± l = ρ) : + βˆ‘ e, capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± e = 1 := by + simp only [capacityWitnessMass, Fintype.sum_sum_type, Fintype.sum_unique] + rw [← Finset.mul_sum, ← Finset.mul_sum, hΞ±sum] + field_simp + linarith + +theorem capacityWitness_nonnegative + {ΞΉ : Type*} [Fintype ΞΉ] + {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hρ1 : ρ ≀ 1) + (hΞ΄a : 0 ≀ Ξ΄a) (hΞ΄b : 0 ≀ Ξ΄b) + (hΞ± : βˆ€ l, 0 ≀ Ξ± l) : + βˆ€ e, 0 ≀ capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± e := by + intro e + rcases e with _ | e + Β· simp [capacityWitnessMass, sub_nonneg.mpr hρ1] + Β· rcases e with l | l + Β· exact mul_nonneg (div_nonneg hΞ΄b hρ.le) (hΞ± l) + Β· exact mul_nonneg (div_nonneg hΞ΄a hρ.le) (hΞ± l) + +/-- The witness has the prescribed marginal on every outside column. -/ +theorem capacityWitness_outside_marginal + {ΞΉ : Type*} {ρ Ξ΄a Ξ΄b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hΞ΄ : Ξ΄a + Ξ΄b = ρ) (l : ΞΉ) : + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inl l)) + + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inr l)) = Ξ± l := by + simp only [capacityWitnessMass] + field_simp + rw [add_comm Ξ΄b Ξ΄a, hΞ΄] + ring + +/-- The witness has the prescribed marginal on core column `a`. -/ +theorem capacityWitness_coreA_marginal + {ΞΉ : Type*} [Fintype ΞΉ] + {ρ Ξ΄a Ξ΄b Ξ±a : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hΞ΄a : Ξ΄a + Ξ±a = 1) (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) : + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inl ()) + + βˆ‘ l, capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inl l)) = Ξ±a := by + simp only [capacityWitnessMass, ← Finset.mul_sum, hΞ±sum] + field_simp + nlinarith + +/-- The witness has the prescribed marginal on core column `b`. -/ +theorem capacityWitness_coreB_marginal + {ΞΉ : Type*} [Fintype ΞΉ] + {ρ Ξ΄a Ξ΄b Ξ±b : ℝ} {Ξ± : ΞΉ β†’ ℝ} + (hρ : 0 < ρ) (hΞ±sum : βˆ‘ l, Ξ± l = ρ) + (hΞ΄b : Ξ΄b + Ξ±b = 1) (hΞ΄sum : Ξ΄a + Ξ΄b = ρ) : + capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inl ()) + + βˆ‘ l, capacityWitnessMass ρ Ξ΄a Ξ΄b Ξ± (Sum.inr (Sum.inr l)) = Ξ±b := by + simp only [capacityWitnessMass, ← Finset.mul_sum, hΞ±sum] + field_simp + nlinarith + +/-- Convexity estimate used in paper (56). -/ +theorem two_neg_tau_mul_add_rpow_le + {x y Ο„ : ℝ} (hx : 0 ≀ x) (hy : 0 ≀ y) (hΟ„ : 0 ≀ Ο„) : + (2 : ℝ) ^ (-Ο„) * (x + y) ^ (1 + Ο„) ≀ + x ^ (1 + Ο„) + y ^ (1 + Ο„) := by + have hconv := (convexOn_rpow (by linarith : (1 : ℝ) ≀ 1 + Ο„)).2 + (show x ∈ Set.Ici (0 : ℝ) from hx) + (show y ∈ Set.Ici (0 : ℝ) from hy) + (by norm_num : (0 : ℝ) ≀ 1 / 2) + (by norm_num : (0 : ℝ) ≀ 1 / 2) + (by norm_num : (1 / 2 : ℝ) + 1 / 2 = 1) + have hjensen : + ((x + y) / 2) ^ (1 + Ο„) ≀ + (x ^ (1 + Ο„) + y ^ (1 + Ο„)) / 2 := by + change + ((1 / 2 : ℝ) * x + (1 / 2 : ℝ) * y) ^ (1 + Ο„) ≀ + (1 / 2 : ℝ) * x ^ (1 + Ο„) + (1 / 2 : ℝ) * y ^ (1 + Ο„) at hconv + convert hconv using 1 <;> ring_nf + have hscaled := mul_le_mul_of_nonneg_left hjensen (by norm_num : (0 : ℝ) ≀ 2) + have hleft : + 2 * ((x + y) / 2) ^ (1 + Ο„) = + (2 : ℝ) ^ (-Ο„) * (x + y) ^ (1 + Ο„) := by + rw [Real.div_rpow (add_nonneg hx hy) (by norm_num : (0 : ℝ) ≀ 2)] + rw [Real.rpow_add (by norm_num : (0 : ℝ) < 2), Real.rpow_one] + rw [Real.rpow_neg (by norm_num : (0 : ℝ) ≀ 2)] + field_simp [(Real.rpow_pos_of_pos (by norm_num : (0 : ℝ) < 2) Ο„).ne'] + rw [hleft] at hscaled + nlinarith + +/-- Paper (56), including both the denominator estimate and the convexity +step. -/ +theorem pairTransferSum_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) + {p q : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) + (hq : IsInteriorProbabilityVector q) (j : ΞΉ) : + (2 : ℝ) ^ (-Ο„) * (p j + q j) ^ (1 + Ο„) ≀ + transferU Ο„ p j + transferU Ο„ q j := by + exact (two_neg_tau_mul_add_rpow_le + (hp.1.nonnegative j) (hq.1.nonnegative j) hΟ„).trans + (add_le_add (coordinate_rpow_le_transferU hp j) + (coordinate_rpow_le_transferU hq j)) + +/-- Exact cancellation of the two core deficit terms in paper (59)--(61). -/ +theorem core_entropy_cancellation + {Ξ΄a Ξ΄b ρ : ℝ} (hΞ΄a : 0 < Ξ΄a) (hΞ΄b : 0 < Ξ΄b) + (hρ : 0 < ρ) (hsum : Ξ΄a + Ξ΄b = ρ) : + Ξ΄a * Real.log Ξ΄a + Ξ΄b * Real.log Ξ΄b - + Ξ΄a * Real.log (Ξ΄a / ρ) - Ξ΄b * Real.log (Ξ΄b / ρ) = + ρ * Real.log ρ := by + rw [Real.log_div hΞ΄a.ne' hρ.ne', Real.log_div hΞ΄b.ne' hρ.ne'] + rw [← hsum] + ring + +/-- Elementary outside-coordinate bound used below paper (61). -/ +theorem neg_alpha_le_one_sub_mul_log + {Ξ± : ℝ} (hΞ±1 : Ξ± < 1) : + -Ξ± ≀ (1 - Ξ±) * Real.log (1 - Ξ±) := by + have hpos : 0 < 1 - Ξ± := sub_pos.mpr hΞ±1 + have hlog := Real.one_sub_inv_le_log_of_pos hpos + have hmul := mul_le_mul_of_nonneg_left hlog hpos.le + have hsimplify : (1 - Ξ±) * (1 - (1 - Ξ±)⁻¹) = -Ξ± := by + field_simp + ring + rw [hsimplify] at hmul + exact hmul + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Gibbs.lean b/LeanPool/BeyondBethe/BeyondBethe/Gibbs.lean new file mode 100644 index 0000000000..3cbeb21493 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Gibbs.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.Tactic + +/-! # Gibbs -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Weight of a permutation in the permanent expansion. Mathlib's permanent +uses columns as the domain of the permutation and rows as its image. -/ +noncomputable def permutationWeight + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (Οƒ : Equiv.Perm n) : ℝ := + ∏ j, A (Οƒ j) j + +theorem sum_permutationWeight_eq_permanent + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) : + βˆ‘ Οƒ : Equiv.Perm n, permutationWeight A Οƒ = Matrix.permanent A := by + rfl + +/-- The unnormalized Gibbs marginal that row `i` is matched to column `j`. -/ +noncomputable def marginalNumerator + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (i j : n) : ℝ := + βˆ‘ Οƒ : Equiv.Perm n, if Οƒ j = i then permutationWeight A Οƒ else 0 + +/-- Assignment marginals of the Gibbs law. -/ +noncomputable def assignmentMarginal + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (i j : n) : ℝ := + marginalNumerator A i j / Matrix.permanent A + +theorem sum_marginalNumerator_col + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (j : n) : + βˆ‘ i, marginalNumerator A i j = Matrix.permanent A := by + classical + simp_rw [marginalNumerator] + rw [Finset.sum_comm] + calc + (βˆ‘ Οƒ : Equiv.Perm n, + βˆ‘ i : n, if Οƒ j = i then permutationWeight A Οƒ else 0) + = βˆ‘ Οƒ : Equiv.Perm n, permutationWeight A Οƒ := by + apply Finset.sum_congr rfl + intro Οƒ _ + simp + _ = Matrix.permanent A := sum_permutationWeight_eq_permanent A + +theorem sum_marginalNumerator_row + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (i : n) : + βˆ‘ j, marginalNumerator A i j = Matrix.permanent A := by + classical + simp_rw [marginalNumerator] + rw [Finset.sum_comm] + calc + (βˆ‘ Οƒ : Equiv.Perm n, + βˆ‘ j : n, if Οƒ j = i then permutationWeight A Οƒ else 0) + = βˆ‘ Οƒ : Equiv.Perm n, permutationWeight A Οƒ := by + apply Finset.sum_congr rfl + intro Οƒ _ + rw [Finset.sum_eq_single (Οƒ.symm i)] + Β· simp + Β· intro j _ hj + have hne : Οƒ j β‰  i := by + intro hji + apply hj + simpa using congrArg Οƒ.symm hji + simp [hne] + Β· simp + _ = Matrix.permanent A := sum_permutationWeight_eq_permanent A + +theorem assignmentMarginal_nonneg + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Matrix.Nonnegative A) + (i j : n) : + 0 ≀ assignmentMarginal A i j := by + unfold assignmentMarginal marginalNumerator + exact div_nonneg + (Finset.sum_nonneg fun Οƒ _ ↦ by + split_ifs + Β· exact Finset.prod_nonneg fun k _ ↦ hA (Οƒ k) k + Β· rfl) + (Matrix.permanent_nonneg_real A hA) + +theorem assignmentMarginal_row_sum + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hper : Matrix.permanent A β‰  0) (i : n) : + βˆ‘ j, assignmentMarginal A i j = 1 := by + simp_rw [assignmentMarginal] + rw [← Finset.sum_div, sum_marginalNumerator_row] + exact div_self hper + +theorem assignmentMarginal_col_sum + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hper : Matrix.permanent A β‰  0) (j : n) : + βˆ‘ i, assignmentMarginal A i j = 1 := by + simp_rw [assignmentMarginal] + rw [← Finset.sum_div, sum_marginalNumerator_col] + exact div_self hper + +theorem assignmentMarginal_doublyStochastic + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Matrix.Nonnegative A) + (hper : Matrix.permanent A β‰  0) : + IsDoublyStochastic (assignmentMarginal A) := by + exact ⟨assignmentMarginal_nonneg A hA, + assignmentMarginal_row_sum A hper, + assignmentMarginal_col_sum A hper⟩ + +/-- Gibbs probability of a permutation. -/ +noncomputable def gibbsProbability + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (Οƒ : Equiv.Perm n) : ℝ := + permutationWeight A Οƒ / Matrix.permanent A + +theorem permutationWeight_pos + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) + (Οƒ : Equiv.Perm n) : + 0 < permutationWeight A Οƒ := by + rw [permutationWeight] + exact Finset.prod_pos fun j _ ↦ hA (Οƒ j) j + +theorem permanent_pos_of_positive + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) : + 0 < Matrix.permanent A := by + rw [← sum_permutationWeight_eq_permanent A] + exact Finset.sum_pos (fun Οƒ _ ↦ permutationWeight_pos A hA Οƒ) + ⟨Equiv.refl n, Finset.mem_univ _⟩ + +theorem assignmentMarginal_pos + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) + (i j : n) : + 0 < assignmentMarginal A i j := by + have hper := permanent_pos_of_positive A hA + apply div_pos _ hper + rw [marginalNumerator] + apply Finset.sum_pos' + Β· intro Οƒ _ + split_ifs + Β· exact (permutationWeight_pos A hA Οƒ).le + Β· rfl + Β· refine ⟨Equiv.swap j i, Finset.mem_univ _, ?_⟩ + simp only [Equiv.swap_apply_left, ite_eq_left] + exact permutationWeight_pos A hA (Equiv.swap j i) + +theorem assignmentMarginal_strictProbabilityVector + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) (i : n) : + IsStrictProbabilityVector (assignmentMarginal A i) := by + have hper := permanent_pos_of_positive A hA + exact ⟨ + (assignmentMarginal_doublyStochastic A + (fun r c ↦ (hA r c).le) hper.ne').row_probability i, + assignmentMarginal_pos A hA i⟩ + +theorem gibbsProbability_pos + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) + (Οƒ : Equiv.Perm n) : + 0 < gibbsProbability A Οƒ := by + exact div_pos (permutationWeight_pos A hA Οƒ) + (permanent_pos_of_positive A hA) + +theorem gibbsProbability_isProbabilityVector + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) : + IsProbabilityVector (gibbsProbability A) := by + constructor + Β· intro Οƒ + exact (gibbsProbability_pos A hA Οƒ).le + Β· simp_rw [gibbsProbability] + rw [← Finset.sum_div, + sum_permutationWeight_eq_permanent, + div_self (permanent_pos_of_positive A hA).ne'] + +theorem assignmentMarginal_eq_gibbs_sum + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (i j : n) : + assignmentMarginal A i j = + βˆ‘ Οƒ : Equiv.Perm n, + if Οƒ j = i then gibbsProbability A Οƒ else 0 := by + unfold assignmentMarginal marginalNumerator gibbsProbability + rw [Finset.sum_div] + apply Finset.sum_congr rfl + intro Οƒ _ + split_ifs <;> simp + +/-- Expectation under a column marginal, written either over rows or over +permutations. -/ +theorem assignmentMarginal_expectation_col + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (f : n β†’ ℝ) (j : n) : + βˆ‘ i, assignmentMarginal A i j * f i = + βˆ‘ Οƒ : Equiv.Perm n, gibbsProbability A Οƒ * f (Οƒ j) := by + classical + simp_rw [assignmentMarginal_eq_gibbs_sum] + simp_rw [Finset.sum_mul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro Οƒ _ + rw [Finset.sum_eq_single (Οƒ j)] + Β· simp + Β· intro i _ hi + have hne : Οƒ j β‰  i := Ne.symm hi + simp [hne] + Β· simp + +theorem log_permutationWeight + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) + (Οƒ : Equiv.Perm n) : + Real.log (permutationWeight A Οƒ) = + βˆ‘ j, Real.log (A (Οƒ j) j) := by + rw [permutationWeight, Real.log_prod] + intro j _ + exact (hA (Οƒ j) j).ne' + +/-- Entropy identity for the Gibbs law, used in paper Lemma 10. -/ +theorem gibbsEntropy_identity + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : βˆ€ i j, 0 < A i j) : + shannonEntropy (gibbsProbability A) = + Real.log (Matrix.permanent A) - + βˆ‘ i, βˆ‘ j, assignmentMarginal A i j * Real.log (A i j) := by + have hper : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hΞΌsum := (gibbsProbability_isProbabilityVector A hA).sum_eq_one + have hentry : βˆ€ Οƒ : Equiv.Perm n, + Real.negMulLog (gibbsProbability A Οƒ) = + gibbsProbability A Οƒ * Real.log (Matrix.permanent A) - + gibbsProbability A Οƒ * Real.log (permutationWeight A Οƒ) := by + intro Οƒ + have hw := permutationWeight_pos A hA Οƒ + simp only [Real.negMulLog_def] + rw [gibbsProbability, Real.log_div hw.ne' hper.ne'] + ring + rw [shannonEntropy] + simp_rw [hentry] + rw [Finset.sum_sub_distrib, ← Finset.sum_mul, hΞΌsum, one_mul] + simp_rw [log_permutationWeight A hA, Finset.mul_sum] + apply congrArg (fun x ↦ Real.log (Matrix.permanent A) - x) + calc + βˆ‘ Οƒ, βˆ‘ j, gibbsProbability A Οƒ * Real.log (A (Οƒ j) j) = + βˆ‘ j, βˆ‘ Οƒ, gibbsProbability A Οƒ * Real.log (A (Οƒ j) j) := + Finset.sum_comm + _ = βˆ‘ j, βˆ‘ i, assignmentMarginal A i j * Real.log (A i j) := by + apply Finset.sum_congr rfl + intro j _ + exact (assignmentMarginal_expectation_col A + (fun i ↦ Real.log (A i j)) j).symm + _ = βˆ‘ i, βˆ‘ j, assignmentMarginal A i j * Real.log (A i j) := + Finset.sum_comm + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/GoodRowScore.lean b/LeanPool/BeyondBethe/BeyondBethe/GoodRowScore.lean new file mode 100644 index 0000000000..f4027f7ffd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/GoodRowScore.lean @@ -0,0 +1,783 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Cycles +public import Mathlib.Analysis.SpecialFunctions.BinaryEntropy +public import Mathlib.Tactic + +/-! # Good Row Score -/ + +@[expose] public section + +open scoped BigOperators Topology +open Filter + +namespace BeyondBethe + +/-- A genuinely continuous formula for the suffix error near every point +`(a,x)` with `a+x != 0`. On the nonnegative quadrant it agrees with +`suffixError`; the rewrite removes the apparent singularity at `x=0`. -/ +noncomputable def continuousSuffixError (a x : ℝ) : ℝ := + a - x * Real.log (a + x) - Real.negMulLog x + +theorem suffixError_eq_continuousSuffixError + {a x : ℝ} (ha : 0 ≀ a) (hx : 0 ≀ x) : + suffixError a x = continuousSuffixError a x := by + by_cases hx0 : x = 0 + Β· subst x + simp [suffixError, continuousSuffixError] + Β· have hxpos : 0 < x := lt_of_le_of_ne hx (Ne.symm hx0) + have hsum : a + x β‰  0 := (add_pos_of_nonneg_of_pos ha hxpos).ne' + have hratio : 1 + a / x = (a + x) / x := by + field_simp + ring + rw [suffixError, continuousSuffixError, hratio, + Real.log_div hsum hx0, Real.negMulLog_def] + ring + +theorem continuousAt_continuousSuffixError + {a x : ℝ} (hsum : a + x β‰  0) : + ContinuousAt + (fun z : ℝ Γ— ℝ ↦ continuousSuffixError z.1 z.2) (a, x) := by + unfold continuousSuffixError + fun_prop + +/-- The paper's assertion that `e(a,x)` is continuous is a statement on the +nonnegative quadrant. This is the exact domain-qualified version. -/ +theorem continuousWithinAt_suffixError_nonnegative + {a x : ℝ} (ha : 0 ≀ a) (hx : 0 ≀ x) (hsum : a + x β‰  0) : + ContinuousWithinAt + (fun z : ℝ Γ— ℝ ↦ suffixError z.1 z.2) + (Set.Ici 0 Γ—Λ’ Set.Ici 0) (a, x) := by + apply (continuousAt_continuousSuffixError hsum).continuousWithinAt.congr_of_mem + Β· intro z hz + exact suffixError_eq_continuousSuffixError hz.1 hz.2 + Β· exact ⟨ha, hx⟩ + +theorem binaryEntropy_eq_realBinEntropy (t : ℝ) : + binaryEntropy t = Real.binEntropy t := by + rw [binaryEntropy, Real.binEntropy_eq_negMulLog_add_negMulLog_one_sub] + +theorem continuous_binaryEntropy : Continuous binaryEntropy := by + apply Continuous.congr Real.binEntropy_continuous + exact fun t ↦ (binaryEntropy_eq_realBinEntropy t).symm + +/-- The scalar lower bound `Psi` in paper (28). -/ +noncomputable def goodRowPsi (u v q : ℝ) : ℝ := + (1 - q) * binaryEntropy (u / (1 - q)) - 1 + + (1 / 2) * + (suffixError u q + suffixError u (v + q) + + suffixError v q + suffixError v (u + q)) + +/-- A continuous local representative of `goodRowPsi`. -/ +noncomputable def continuousGoodRowPsi (u v q : ℝ) : ℝ := + (1 - q) * Real.binEntropy (u / (1 - q)) - 1 + + (1 / 2) * + (continuousSuffixError u q + continuousSuffixError u (v + q) + + continuousSuffixError v q + continuousSuffixError v (u + q)) + +theorem goodRowPsi_eq_continuousGoodRowPsi + {u v q : ℝ} (hu : 0 ≀ u) (hv : 0 ≀ v) (hq : 0 ≀ q) : + goodRowPsi u v q = continuousGoodRowPsi u v q := by + rw [goodRowPsi, continuousGoodRowPsi, binaryEntropy_eq_realBinEntropy, + suffixError_eq_continuousSuffixError hu hq, + suffixError_eq_continuousSuffixError hu (add_nonneg hv hq), + suffixError_eq_continuousSuffixError hv hq, + suffixError_eq_continuousSuffixError hv (add_nonneg hu hq)] + +theorem continuousAt_continuousGoodRowPsi_half_half_zero : + ContinuousAt + (fun z : ℝ Γ— (ℝ Γ— ℝ) ↦ + continuousGoodRowPsi z.1 z.2.1 z.2.2) + (1 / 2, (1 / 2, 0)) := by + unfold continuousGoodRowPsi continuousSuffixError + fun_prop (disch := norm_num) + +/-- Exact domain-qualified continuity statement used in the compactness +argument for paper Lemma 12. -/ +theorem continuousWithinAt_goodRowPsi_half_half_zero : + ContinuousWithinAt + (fun z : ℝ Γ— (ℝ Γ— ℝ) ↦ goodRowPsi z.1 z.2.1 z.2.2) + (Set.Ici 0 Γ—Λ’ (Set.Ici 0 Γ—Λ’ Set.Ici 0)) + (1 / 2, (1 / 2, 0)) := by + apply continuousAt_continuousGoodRowPsi_half_half_zero.continuousWithinAt.congr_of_mem + Β· intro z hz + exact goodRowPsi_eq_continuousGoodRowPsi hz.1 hz.2.1 hz.2.2 + Β· norm_num + +/-- The half--half row produces exactly half a bit of score after paying for +the one ambiguity bit of its core component. -/ +theorem goodRowPsi_half_half_zero : + goodRowPsi (1 / 2) (1 / 2) 0 = Real.log 2 / 2 := by + rw [goodRowPsi, binaryEntropy_eq_realBinEntropy] + norm_num [suffixError] + rw [show (1 / 2 : ℝ) = 2⁻¹ by norm_num, Real.binEntropy_two_inv] + ring + +/-- Relative order of two coordinates in an ordering. -/ +def CoordinateBefore {n : β„•} (a b : Fin n) (Ο€ : Equiv.Perm (Fin n)) : Prop := + Ο€.symm a < Ο€.symm b + +instance instDecidableCoordinateBefore + {n : β„•} (a b : Fin n) (Ο€ : Equiv.Perm (Fin n)) : + Decidable (CoordinateBefore a b Ο€) := by + unfold CoordinateBefore + infer_instance + +/-- The probability that coordinate `a` precedes `b` in a uniformly chosen permutation. -/ +noncomputable def coordinateBeforeProbability + {n : β„•} (a b : Fin n) : ℝ := + uniformAverage fun Ο€ : Equiv.Perm (Fin n) ↦ + if CoordinateBefore a b Ο€ then 1 else 0 + +theorem coordinateBefore_trans_swap + {n : β„•} (a b : Fin n) (Ο€ : Equiv.Perm (Fin n)) : + CoordinateBefore a b (Ο€.trans (Equiv.swap a b)) ↔ + CoordinateBefore b a Ο€ := by + simp [CoordinateBefore, Equiv.trans_apply, Equiv.swap_apply_def] + +theorem coordinateBeforeProbability_symm + {n : β„•} (a b : Fin n) : + coordinateBeforeProbability a b = coordinateBeforeProbability b a := by + let f : Equiv.Perm (Fin n) β†’ ℝ := fun Ο€ ↦ + if CoordinateBefore a b Ο€ then 1 else 0 + calc + coordinateBeforeProbability a b = uniformAverage f := rfl + _ = uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + f (Ο€.trans (Equiv.swap a b))) := + (uniformAverage_perm_trans f (Equiv.swap a b)).symm + _ = coordinateBeforeProbability b a := by + apply congrArg uniformAverage + funext Ο€ + exact if_congr (coordinateBefore_trans_swap a b Ο€) rfl rfl + +theorem coordinateBeforeProbability_add_reverse + {n : β„•} {a b : Fin n} (hab : a β‰  b) : + coordinateBeforeProbability a b + coordinateBeforeProbability b a = 1 := by + rw [coordinateBeforeProbability, coordinateBeforeProbability, + ← uniformAverage_add] + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + (if CoordinateBefore a b Ο€ then (1 : ℝ) else 0) + + if CoordinateBefore b a Ο€ then 1 else 0) = + uniformAverage (fun _ : Equiv.Perm (Fin n) ↦ (1 : ℝ)) := by + apply congrArg uniformAverage + funext Ο€ + have hne : Ο€.symm a β‰  Ο€.symm b := Ο€.symm.injective.ne hab + rcases lt_or_gt_of_ne hne with h | h <;> + simp [CoordinateBefore, h, not_lt_of_ge h.le] + _ = 1 := uniformAverage_const 1 + +theorem coordinateBeforeProbability_eq_half + {n : β„•} {a b : Fin n} (hab : a β‰  b) : + coordinateBeforeProbability a b = 1 / 2 := by + have hsymm := coordinateBeforeProbability_symm a b + have hsum := coordinateBeforeProbability_add_reverse hab + linarith + +theorem strictRightMass_nonneg + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + (Ο€ : Equiv.Perm (Fin n)) (a : Fin n) : + 0 ≀ strictRightMass p Ο€ a := by + unfold strictRightMass + exact Finset.sum_nonneg fun j _ ↦ by + split_ifs <;> simp_all [hp.nonnegative j] + +theorem strictRightMass_le_one_sub + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + (Ο€ : Equiv.Perm (Fin n)) (a : Fin n) : + strictRightMass p Ο€ a ≀ 1 - p a := by + have hleft : 0 ≀ strictLeftMass p Ο€ a := by + unfold strictLeftMass + exact Finset.sum_nonneg fun j _ ↦ by + split_ifs <;> simp_all [hp.nonnegative j] + linarith [strictLeftMass_add_strictRightMass hp Ο€ a] + +/-- If `b` lies before `a`, the mass after `a` can contain only coordinates +outside the pair `{a,b}`. -/ +theorem strictRightMass_le_outside_of_before + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {Ο€ : Equiv.Perm (Fin n)} {a b : Fin n} (hab : a β‰  b) + (hbefore : CoordinateBefore b a Ο€) : + strictRightMass p Ο€ a ≀ 1 - p a - p b := by + rw [← sum_away_from_two hp hab] + unfold strictRightMass + apply Finset.sum_le_sum + intro j _ + by_cases haj : a = j + Β· subst j + simp + by_cases hbj : b = j + Β· subst j + have hnot : ¬π.symm a < Ο€.symm b := + not_lt_of_ge hbefore.le + simp [hnot] + Β· by_cases horder : Ο€.symm a < Ο€.symm j + Β· simp [haj, hbj, horder, hp.nonnegative j] + Β· simp [haj, hbj, horder, hp.nonnegative j] + +theorem uniformAverage_mono + {Ξ± : Type*} [Fintype Ξ±] {f g : Ξ± β†’ ℝ} + (hfg : βˆ€ x, f x ≀ g x) : + uniformAverage f ≀ uniformAverage g := by + unfold uniformAverage + exact div_le_div_of_nonneg_right + (Finset.sum_le_sum fun x _ ↦ hfg x) (Nat.cast_nonneg _) + +theorem uniformAverage_ite_const + {Ξ± : Type*} [Fintype Ξ±] [Nonempty Ξ±] + (P : Ξ± β†’ Prop) [DecidablePred P] (a b : ℝ) : + uniformAverage (fun x ↦ if P x then a else b) = + b + (a - b) * uniformAverage (fun x ↦ if P x then 1 else 0) := by + calc + uniformAverage (fun x ↦ if P x then a else b) = + uniformAverage (fun x ↦ + b + (a - b) * if P x then (1 : ℝ) else 0) := by + apply congrArg uniformAverage + funext x + by_cases hx : P x <;> simp [hx] + _ = uniformAverage (fun _ : Ξ± ↦ b) + + uniformAverage (fun x ↦ + (a - b) * if P x then (1 : ℝ) else 0) := + uniformAverage_add _ _ + _ = b + (a - b) * uniformAverage + (fun x ↦ if P x then (1 : ℝ) else 0) := by + rw [uniformAverage_const, uniformAverage_const_mul] + +theorem listSuffixErrorSum_ofFn + {n : β„•} (f : Fin n β†’ ℝ) : + listSuffixErrorSum (List.ofFn f) = + βˆ‘ t, suffixError (f t) (βˆ‘ k, if t < k then f k else 0) := by + induction n with + | zero => simp [listSuffixErrorSum] + | succ n ih => + rw [List.ofFn_succ, listSuffixErrorSum, Fin.sum_univ_succ, + ih (fun k ↦ f k.succ)] + congr 1 + Β· congr 1 + rw [List.sum_ofFn, Fin.sum_univ_succ] + simp + Β· apply Finset.sum_congr rfl + intro t _ + congr 1 + rw [Fin.sum_univ_succ] + simp + +theorem orderedStrictRightMass_eq + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (t : Fin n) : + (βˆ‘ k, if t < k then p (Ο€ k) else 0) = + strictRightMass p Ο€ (Ο€ t) := by + unfold strictRightMass + calc + (βˆ‘ k, if t < k then p (Ο€ k) else 0) = + βˆ‘ k, if Ο€.symm (Ο€ t) < Ο€.symm (Ο€ k) then p (Ο€ k) else 0 := by + simp + _ = βˆ‘ j, if Ο€.symm (Ο€ t) < Ο€.symm j then p j else 0 := + Equiv.sum_comp Ο€ + (fun j ↦ if Ο€.symm (Ο€ t) < Ο€.symm j then p j else 0) + +theorem listSuffixErrorSum_ofFn_eq_ordered_errors + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) : + listSuffixErrorSum (List.ofFn (fun t ↦ p (Ο€ t))) = + βˆ‘ j, suffixError (p j) (strictRightMass p Ο€ j) := by + rw [listSuffixErrorSum_ofFn] + calc + (βˆ‘ t, suffixError (p (Ο€ t)) + (βˆ‘ k, if t < k then p (Ο€ k) else 0)) = + βˆ‘ t, suffixError (p (Ο€ t)) (strictRightMass p Ο€ (Ο€ t)) := by + apply Finset.sum_congr rfl + intro t _ + rw [orderedStrictRightMass_eq] + _ = βˆ‘ j, suffixError (p j) (strictRightMass p Ο€ j) := + Equiv.sum_comp Ο€ (fun j ↦ suffixError (p j) (strictRightMass p Ο€ j)) + +theorem fixed_order_suffixScore_eq_neg_one_add_errors + {n : β„•} {p : Fin n β†’ ℝ} + (hp : IsProbabilityVector p) (Ο€ : Equiv.Perm (Fin n)) : + (βˆ‘ j, p j * Real.log (suffixMass p Ο€ j)) = + -1 + βˆ‘ j, suffixError (p j) (strictRightMass p Ο€ j) := by + rw [← listSuffixScore_ofFn_eq_ordered_score, + ← listSuffixErrorSum_ofFn_eq_ordered_errors] + apply listSuffixScore_eq_neg_one_add_errors + Β· intro x hx + simp only [List.mem_ofFn] at hx + obtain ⟨t, rfl⟩ := hx + exact hp.nonnegative (Ο€ t) + Β· rw [List.sum_ofFn] + exact (Equiv.sum_comp Ο€ p).trans hp.sum_eq_one + +theorem rowT_ge_core_errors + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + -1 + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + suffixError (p a) (strictRightMass p Ο€ a) + + suffixError (p b) (strictRightMass p Ο€ b)) ≀ rowT p := by + rw [rowT] + calc + -1 + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + suffixError (p a) (strictRightMass p Ο€ a) + + suffixError (p b) (strictRightMass p Ο€ b)) ≀ + -1 + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ j, suffixError (p j) (strictRightMass p Ο€ j)) := by + gcongr + apply uniformAverage_mono + intro Ο€ + calc + suffixError (p a) (strictRightMass p Ο€ a) + + suffixError (p b) (strictRightMass p Ο€ b) = + βˆ‘ j ∈ ({a, b} : Finset (Fin n)), + suffixError (p j) (strictRightMass p Ο€ j) := by + rw [Finset.sum_pair hab] + _ ≀ βˆ‘ j, suffixError (p j) (strictRightMass p Ο€ j) := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + intro j _ _ + exact suffixError_nonneg (hp.nonnegative j) + (strictRightMass_nonneg hp Ο€ j) + _ = uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ j, p j * Real.log (suffixMass p Ο€ j)) := by + rw [← uniformAverage_const + (Ξ± := Equiv.Perm (Fin n)) (-1), ← uniformAverage_add] + apply congrArg uniformAverage + funext Ο€ + exact (fixed_order_suffixScore_eq_neg_one_add_errors hp Ο€).symm + +/-- Each core coordinate sees only outside mass when the other core +coordinate precedes it, an event of probability exactly one half. -/ +theorem average_suffixError_core_lower + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + (1 / 2) * + (suffixError (p a) (1 - p a - p b) + + suffixError (p a) (p b + (1 - p a - p b))) ≀ + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + suffixError (p a) (strictRightMass p Ο€ a)) := by + let q : ℝ := 1 - p a - p b + have hq : 0 ≀ q := by + change 0 ≀ 1 - p a - p b + rw [← sum_away_from_two hp hab] + exact Finset.sum_nonneg fun j _ ↦ by + by_cases h : a β‰  j ∧ b β‰  j <;> simp [h, hp.nonnegative j] + have hpoint : βˆ€ Ο€ : Equiv.Perm (Fin n), + (if CoordinateBefore b a Ο€ then suffixError (p a) q + else suffixError (p a) (p b + q)) ≀ + suffixError (p a) (strictRightMass p Ο€ a) := by + intro Ο€ + have hright0 := strictRightMass_nonneg hp Ο€ a + by_cases hbefore : CoordinateBefore b a Ο€ + Β· rw [ite_eq_left hbefore] + exact suffixError_anti (hp.nonnegative a) hright0 + (strictRightMass_le_outside_of_before hp hab hbefore) + Β· rw [ite_eq_right hbefore] + have hright := strictRightMass_le_one_sub hp Ο€ a + have hmass : p b + q = 1 - p a := by + dsimp [q] + ring + rw [hmass] + exact suffixError_anti (hp.nonnegative a) hright0 hright + calc + (1 / 2) * + (suffixError (p a) (1 - p a - p b) + + suffixError (p a) (p b + (1 - p a - p b))) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if CoordinateBefore b a Ο€ then suffixError (p a) q + else suffixError (p a) (p b + q)) := by + rw [uniformAverage_ite_const] + change _ = _ + _ * coordinateBeforeProbability b a + rw [coordinateBeforeProbability_eq_half (Ne.symm hab)] + dsimp [q] + ring + _ ≀ uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + suffixError (p a) (strictRightMass p Ο€ a)) := + uniformAverage_mono hpoint + +/-- Averaged two-core suffix-error estimate in paper (28), separated from +the entropy coarsening identity. -/ +theorem rowT_ge_two_core_suffix_bound + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + -1 + (1 / 2) * + (suffixError (p a) (1 - p a - p b) + + suffixError (p a) (p b + (1 - p a - p b)) + + suffixError (p b) (1 - p a - p b) + + suffixError (p b) (p a + (1 - p a - p b))) ≀ + rowT p := by + have ha := average_suffixError_core_lower hp hab + have hb0 := average_suffixError_core_lower hp (Ne.symm hab) + have hb : (1 / 2) * + (suffixError (p b) (1 - p a - p b) + + suffixError (p b) (p a + (1 - p a - p b))) ≀ + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + suffixError (p b) (strictRightMass p Ο€ b)) := by + convert hb0 using 1 <;> ring + have hcore := rowT_ge_core_errors hp hab + rw [uniformAverage_add] at hcore + nlinarith + +/-- Entropy after merging the two core outcomes into one atom while leaving +every outside outcome distinct. -/ +noncomputable def twoCoreCoarsenedEntropy + {n : β„•} (p : Fin n β†’ ℝ) (a b : Fin n) : ℝ := + Real.negMulLog (p a + p b) + + βˆ‘ j, if a β‰  j ∧ b β‰  j then Real.negMulLog (p j) else 0 + +theorem sum_eq_two_add_away + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (f : ΞΉ β†’ ℝ) {a b : ΞΉ} (hab : a β‰  b) : + (βˆ‘ j, f j) = f a + f b + + βˆ‘ j, if a β‰  j ∧ b β‰  j then f j else 0 := by + calc + (βˆ‘ j, f j) = + βˆ‘ j, ((if j = a then f j else 0) + + (if j = b then f j else 0) + + (if a β‰  j ∧ b β‰  j then f j else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp [hab] + Β· by_cases hjb : j = b + Β· subst j + simp [hja] + Β· simp [hja, hjb, Ne.symm hja, Ne.symm hjb] + _ = f a + f b + + βˆ‘ j, if a β‰  j ∧ b β‰  j then f j else 0 := by + simp_rw [Finset.sum_add_distrib] + simp + +theorem entropy_sub_twoCoreCoarsenedEntropy + {n : β„•} (p : Fin n β†’ ℝ) {a b : Fin n} (hab : a β‰  b) : + shannonEntropy p - twoCoreCoarsenedEntropy p a b = + Real.negMulLog (p a) + Real.negMulLog (p b) - + Real.negMulLog (p a + p b) := by + rw [shannonEntropy, twoCoreCoarsenedEntropy, + sum_eq_two_add_away (fun j ↦ Real.negMulLog (p j)) hab] + ring + +/-- Exact entropy loss from the paper's two-core coarsening, in the +`(u,v,q)` coordinates used to define `Psi`. -/ +theorem entropy_sub_twoCoreCoarsenedEntropy_eq + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + shannonEntropy p - twoCoreCoarsenedEntropy p a b = + (1 - (1 - p a - p b)) * + binaryEntropy (p a / (1 - (1 - p a - p b))) := by + rw [entropy_sub_twoCoreCoarsenedEntropy p hab, + entropy_loss_merge_two (hp.positive a) (hp.positive b)] + ring_nf + +/-- Paper inequality (28), now including both the entropy-coarsening identity +and the exact permutation-pairing argument for the suffix score. -/ +theorem rowScore_sub_twoCoreCoarsenedEntropy_ge_Psi + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + goodRowPsi (p a) (p b) (1 - p a - p b) ≀ + rowScore p - twoCoreCoarsenedEntropy p a b := by + have hentropy := entropy_sub_twoCoreCoarsenedEntropy_eq hp hab + have hsuffix := rowT_ge_two_core_suffix_bound hp.probability hab + rw [rowScore, goodRowPsi] + linarith [hentropy] + +/-- The three real coordinates on which the continuous good-row score is evaluated. -/ +abbrev GoodRowTriple := ℝ Γ— (ℝ Γ— ℝ) + +/-- The reference good-row triple `(1/2, 1/2, 0)`. -/ +noncomputable def goodRowCenter : GoodRowTriple := (1 / 2, (1 / 2, 0)) + +/-- Clamp the radius to the interval on which the paper uses the good-row +estimate. This makes the modulus defined on all real inputs without changing +it on `[0,1/10]`. -/ +noncomputable def goodRowRadius (Ξ· : ℝ) : ℝ := max 0 (min Ξ· (1 / 10)) + +theorem goodRowRadius_nonneg (Ξ· : ℝ) : 0 ≀ goodRowRadius Ξ· := by + simp [goodRowRadius] + +theorem goodRowRadius_le_tenth (Ξ· : ℝ) : goodRowRadius Ξ· ≀ 1 / 10 := by + rw [goodRowRadius, max_le_iff] + constructor + Β· norm_num + Β· exact min_le_right _ _ + +theorem goodRowRadius_le_abs (Ξ· : ℝ) : goodRowRadius Ξ· ≀ |Ξ·| := by + by_cases hΞ· : 0 ≀ Ξ· + Β· rw [abs_of_nonneg hΞ·, goodRowRadius, max_le_iff] + exact ⟨hΞ·, min_le_left _ _⟩ + Β· have hΞ·' : Ξ· ≀ 0 := le_of_not_ge hΞ· + have hmin : min Ξ· (1 / 10) ≀ 0 := (min_le_left _ _).trans hΞ·' + rw [goodRowRadius, max_eq_left hmin] + exact abs_nonneg Ξ· + +theorem goodRowRadius_eq { Ξ· : ℝ } (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) : + goodRowRadius Ξ· = Ξ· := by + unfold goodRowRadius + rw [min_eq_left hη₁, max_eq_right hΞ·β‚€] + +theorem monotone_goodRowRadius : Monotone goodRowRadius := by + intro Ξ· ΞΈ hΞ·ΞΈ + exact max_le_max le_rfl (min_le_min hΞ·ΞΈ le_rfl) + +theorem goodRowTriple_bounds_of_mem_closedBall + {z : GoodRowTriple} + (hz : z ∈ Metric.closedBall goodRowCenter (1 / 10)) : + 2 / 5 ≀ z.1 ∧ z.1 ≀ 3 / 5 ∧ + 2 / 5 ≀ z.2.1 ∧ z.2.1 ≀ 3 / 5 ∧ + -(1 / 10) ≀ z.2.2 ∧ z.2.2 ≀ 1 / 10 := by + rw [Metric.mem_closedBall, Prod.dist_eq, max_le_iff, + Prod.dist_eq, max_le_iff, Real.dist_eq, Real.dist_eq, + Real.dist_eq] at hz + rcases hz with ⟨hu, hv, hq⟩ + have hu' := abs_le.mp hu + have hv' := abs_le.mp hv + have hq' := abs_le.mp hq + dsimp [goodRowCenter] at hu' hv' hq' + norm_num at hu' hv' hq' ⊒ + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ <;> + linarith [hu'.1, hu'.2, hv'.1, hv'.2, hq'.1, hq'.2] + +theorem continuousOn_continuousGoodRowPsi_closedBall : + ContinuousOn + (fun z : GoodRowTriple ↦ continuousGoodRowPsi z.1 z.2.1 z.2.2) + (Metric.closedBall goodRowCenter (1 / 10)) := by + intro z hz + have hb := goodRowTriple_bounds_of_mem_closedBall hz + have hden : 1 - z.2.2 β‰  0 := by + have : 0 < 1 - z.2.2 := by linarith [hb.2.2.2.2.2] + exact this.ne' + have huq : z.1 + z.2.2 β‰  0 := by + have : 0 < z.1 + z.2.2 := by linarith [hb.1, hb.2.2.2.2.1] + exact this.ne' + have hvq : z.2.1 + z.2.2 β‰  0 := by + have : 0 < z.2.1 + z.2.2 := by linarith [hb.2.2.1, hb.2.2.2.2.1] + exact this.ne' + have huvq : z.1 + (z.2.1 + z.2.2) β‰  0 := by + have : 0 < z.1 + (z.2.1 + z.2.2) := by + linarith [hb.1, hb.2.2.1, hb.2.2.2.2.1] + exact this.ne' + have hvuq : z.2.1 + (z.1 + z.2.2) β‰  0 := by + have : 0 < z.2.1 + (z.1 + z.2.2) := by + linarith [hb.1, hb.2.2.1, hb.2.2.2.2.1] + exact this.ne' + let S := Metric.closedBall goodRowCenter (1 / 10) + have hu : ContinuousAt (fun w : GoodRowTriple ↦ w.1) z := continuousAt_fst + have htail : ContinuousAt (fun w : GoodRowTriple ↦ w.2) z := continuousAt_snd + have hv : ContinuousAt (fun w : GoodRowTriple ↦ w.2.1) z := + continuousAt_fst.comp' htail + have hq : ContinuousAt (fun w : GoodRowTriple ↦ w.2.2) z := + continuousAt_snd.comp' htail + have hdenC : ContinuousAt (fun w : GoodRowTriple ↦ 1 - w.2.2) z := + continuousAt_const.sub hq + have hentropy : ContinuousAt (fun w : GoodRowTriple ↦ + (1 - w.2.2) * Real.binEntropy (w.1 / (1 - w.2.2)) - 1) z := + (hdenC.mul (Real.binEntropy_continuous.continuousAt.comp' + (hu.div hdenC hden))).sub continuousAt_const + have hsUQ : ContinuousAt (fun w : GoodRowTriple ↦ + continuousSuffixError w.1 w.2.2) z := + ContinuousAt.comp' (f := fun w : GoodRowTriple ↦ (w.1, w.2.2)) + (continuousAt_continuousSuffixError huq) (hu.prodMk hq) + have hvqC : ContinuousAt (fun w : GoodRowTriple ↦ w.2.1 + w.2.2) z := + hv.add hq + have hsUVQ : ContinuousAt (fun w : GoodRowTriple ↦ + continuousSuffixError w.1 (w.2.1 + w.2.2)) z := + ContinuousAt.comp' + (f := fun w : GoodRowTriple ↦ (w.1, w.2.1 + w.2.2)) + (continuousAt_continuousSuffixError huvq) (hu.prodMk hvqC) + have hsVQ : ContinuousAt (fun w : GoodRowTriple ↦ + continuousSuffixError w.2.1 w.2.2) z := + ContinuousAt.comp' (f := fun w : GoodRowTriple ↦ (w.2.1, w.2.2)) + (continuousAt_continuousSuffixError hvq) (hv.prodMk hq) + have huqC : ContinuousAt (fun w : GoodRowTriple ↦ w.1 + w.2.2) z := + hu.add hq + have hsVUQ : ContinuousAt (fun w : GoodRowTriple ↦ + continuousSuffixError w.2.1 (w.1 + w.2.2)) z := + ContinuousAt.comp' + (f := fun w : GoodRowTriple ↦ (w.2.1, w.1 + w.2.2)) + (continuousAt_continuousSuffixError hvuq) (hv.prodMk huqC) + have hhalf : ContinuousAt (fun _w : GoodRowTriple ↦ (1 / 2 : ℝ)) z := + continuousAt_const + have htotal : ContinuousAt (fun w : GoodRowTriple ↦ + (1 - w.2.2) * Real.binEntropy (w.1 / (1 - w.2.2)) - 1 + + (1 / 2) * + (continuousSuffixError w.1 w.2.2 + + continuousSuffixError w.1 (w.2.1 + w.2.2) + + continuousSuffixError w.2.1 w.2.2 + + continuousSuffixError w.2.1 (w.1 + w.2.2))) z := + hentropy.add (hhalf.mul (((hsUQ.add hsUVQ).add hsVQ).add hsVUQ)) + simpa only [continuousGoodRowPsi] using htotal.continuousWithinAt + +/-- The absolute deviation of the continuous good-row score from `log(2)/2`. -/ +noncomputable def goodRowDeviation (z : GoodRowTriple) : ℝ := + |Real.log 2 / 2 - continuousGoodRowPsi z.1 z.2.1 z.2.2| + +theorem continuousGoodRowPsi_center : + continuousGoodRowPsi goodRowCenter.1 goodRowCenter.2.1 goodRowCenter.2.2 = + Real.log 2 / 2 := by + rw [← goodRowPsi_eq_continuousGoodRowPsi + (by norm_num [goodRowCenter]) (by norm_num [goodRowCenter]) + (by norm_num [goodRowCenter])] + simpa [goodRowCenter] using goodRowPsi_half_half_zero + +theorem goodRowDeviation_center : goodRowDeviation goodRowCenter = 0 := by + rw [goodRowDeviation, continuousGoodRowPsi_center] + simp + +theorem continuousAt_goodRowDeviation_center : + ContinuousAt goodRowDeviation goodRowCenter := by + unfold goodRowDeviation + apply ContinuousAt.abs + apply continuousAt_const.sub + simpa [goodRowCenter] using + continuousAt_continuousGoodRowPsi_half_half_zero + +theorem continuousOn_goodRowDeviation_closedBall : + ContinuousOn goodRowDeviation + (Metric.closedBall goodRowCenter (1 / 10)) := by + unfold goodRowDeviation + exact (continuousOn_const.sub + continuousOn_continuousGoodRowPsi_closedBall).abs + +theorem goodRowBall_subset_tenth (Ξ· : ℝ) : + Metric.closedBall goodRowCenter (goodRowRadius Ξ·) βŠ† + Metric.closedBall goodRowCenter (1 / 10) := + Metric.closedBall_subset_closedBall (goodRowRadius_le_tenth Ξ·) + +theorem goodRowDeviation_image_bddAbove (Ξ· : ℝ) : + BddAbove (goodRowDeviation '' + Metric.closedBall goodRowCenter (goodRowRadius Ξ·)) := by + have hbig : BddAbove (goodRowDeviation '' + Metric.closedBall goodRowCenter (1 / 10)) := + (isCompact_closedBall goodRowCenter (1 / 10)).bddAbove_image + continuousOn_goodRowDeviation_closedBall + exact hbig.mono (Set.image_mono (goodRowBall_subset_tenth Ξ·)) + +theorem goodRowBall_nonempty (Ξ· : ℝ) : + (Metric.closedBall goodRowCenter (goodRowRadius Ξ·)).Nonempty := by + exact ⟨goodRowCenter, by + rw [Metric.mem_closedBall, dist_self] + exact goodRowRadius_nonneg η⟩ + +/-- A monotone modulus for the compactness step in paper Lemma 12. We use +absolute deviation rather than only its positive part; this is slightly +stronger and gives the same score bound. -/ +noncomputable def goodRowOmega (Ξ· : ℝ) : ℝ := + sSup (goodRowDeviation '' + Metric.closedBall goodRowCenter (goodRowRadius Ξ·)) + +theorem goodRowOmega_nonneg (Ξ· : ℝ) : 0 ≀ goodRowOmega Ξ· := by + rw [goodRowOmega, ← goodRowDeviation_center] + apply le_csSup (goodRowDeviation_image_bddAbove Ξ·) + exact ⟨goodRowCenter, by + rw [Metric.mem_closedBall, dist_self] + exact goodRowRadius_nonneg Ξ·, rfl⟩ + +theorem monotone_goodRowOmega : Monotone goodRowOmega := by + intro Ξ· ΞΈ hΞ·ΞΈ + unfold goodRowOmega + apply csSup_le_csSup (goodRowDeviation_image_bddAbove ΞΈ) + ((goodRowBall_nonempty Ξ·).image goodRowDeviation) + exact Set.image_mono (Metric.closedBall_subset_closedBall + (monotone_goodRowRadius hΞ·ΞΈ)) + +theorem goodRowDeviation_le_omega + {Ξ· : ℝ} {z : GoodRowTriple} + (hz : z ∈ Metric.closedBall goodRowCenter (goodRowRadius Ξ·)) : + goodRowDeviation z ≀ goodRowOmega Ξ· := by + apply le_csSup (goodRowDeviation_image_bddAbove Ξ·) + exact ⟨z, hz, rfl⟩ + +theorem goodRowPsi_ge_half_log_sub_omega + {Ξ· u v q : ℝ} (hu : 0 ≀ u) (hv : 0 ≀ v) (hq : 0 ≀ q) + (hz : (u, (v, q)) ∈ + Metric.closedBall goodRowCenter (goodRowRadius Ξ·)) : + Real.log 2 / 2 - goodRowOmega Ξ· ≀ goodRowPsi u v q := by + have hdev := goodRowDeviation_le_omega hz + rw [goodRowDeviation, ← goodRowPsi_eq_continuousGoodRowPsi hu hv hq] at hdev + exact le_of_sub_nonneg (by + have := le_trans (le_abs_self (Real.log 2 / 2 - goodRowPsi u v q)) hdev + linarith) + +/-- The compact-ball modulus tends to zero as its radius shrinks. -/ +theorem tendsto_goodRowOmega_zero : + Tendsto goodRowOmega (nhds 0) (nhds 0) := by + rw [Metric.tendsto_nhds_nhds] + intro Ξ΅ hΞ΅ + obtain ⟨δ, hΞ΄, hcont⟩ := + (Metric.continuousAt_iff.mp continuousAt_goodRowDeviation_center) + (Ξ΅ / 2) (half_pos hΞ΅) + refine ⟨δ, hΞ΄, ?_⟩ + intro Ξ· hΞ· + have hΟ‰le : goodRowOmega Ξ· ≀ Ξ΅ / 2 := by + unfold goodRowOmega + apply csSup_le ((goodRowBall_nonempty Ξ·).image goodRowDeviation) + intro y hy + obtain ⟨z, hz, rfl⟩ := hy + have hzdist : dist z goodRowCenter < Ξ΄ := by + have hzle : dist z goodRowCenter ≀ goodRowRadius Ξ· := + Metric.mem_closedBall.mp hz + have hrabs := goodRowRadius_le_abs Ξ· + have habs : |Ξ·| = dist Ξ· 0 := by rw [Real.dist_eq, sub_zero] + have habslt : |Ξ·| < Ξ΄ := by rw [habs]; exact hΞ· + exact hzle.trans_lt (hrabs.trans_lt habslt) + have hsmall := hcont hzdist + rw [goodRowDeviation_center, Real.dist_eq, sub_zero] at hsmall + have hdev0 : 0 ≀ goodRowDeviation z := by + unfold goodRowDeviation + exact abs_nonneg _ + rw [abs_of_nonneg hdev0] at hsmall + exact hsmall.le + rw [Real.dist_eq, sub_zero, abs_of_nonneg (goodRowOmega_nonneg Ξ·)] + exact hΟ‰le.trans_lt (half_lt_self hΞ΅) + +/-- Paper Lemma 12. A row within `Ξ·` in `LΒΉ` of a half--half vector admits +two core coordinates such that its averaged sequential score exceeds the +entropy of the corresponding two-core coarsening by +`(log 2)/2 - goodRowOmega Ξ·`. The modulus is monotone and tends to zero by +`monotone_goodRowOmega` and `tendsto_goodRowOmega_zero`. -/ +theorem goodRow_score + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) + (hgood : IsGoodRow Ξ· p) : + βˆƒ a b : Fin n, a β‰  b ∧ + halfHalfL1Distance p a b ≀ Ξ· ∧ + Real.log 2 / 2 - goodRowOmega Ξ· ≀ + rowScore p - twoCoreCoarsenedEntropy p a b := by + obtain ⟨a, b, hab, hdist⟩ := hgood + let q := 1 - p a - p b + have hqβ‚€ : 0 ≀ q := by + have hsum : 0 ≀ + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_nonneg + intro j _ + split_ifs + Β· exact hp.probability.nonnegative j + Β· exact le_rfl + rw [sum_away_from_two hp.probability hab] at hsum + exact hsum + have hdist' : |p a - 1 / 2| + |p b - 1 / 2| + q ≀ Ξ· := by + rw [halfHalfL1Distance_eq hp.probability hab] at hdist + exact hdist + have haΞ· : |p a - 1 / 2| ≀ Ξ· := by + linarith [abs_nonneg (p b - 1 / 2)] + have hbΞ· : |p b - 1 / 2| ≀ Ξ· := by + linarith [abs_nonneg (p a - 1 / 2)] + have hqΞ· : q ≀ Ξ· := by + linarith [abs_nonneg (p a - 1 / 2), abs_nonneg (p b - 1 / 2)] + have hz : (p a, (p b, q)) ∈ + Metric.closedBall goodRowCenter (goodRowRadius Ξ·) := by + rw [Metric.mem_closedBall, goodRowRadius_eq hΞ·β‚€ hη₁, + Prod.dist_eq, Prod.dist_eq, max_le_iff, max_le_iff] + dsimp [goodRowCenter] + constructor + Β· simpa [Real.dist_eq] using haΞ· + constructor + Β· simpa [Real.dist_eq] using hbΞ· + Β· simpa [Real.dist_eq, abs_of_nonneg hqβ‚€] using hqΞ· + refine ⟨a, b, hab, hdist, ?_⟩ + exact (goodRowPsi_ge_half_log_sub_omega + (hp.probability.nonnegative a) (hp.probability.nonnegative b) hqβ‚€ hz).trans + (rowScore_sub_twoCoreCoarsenedEntropy_ge_Psi hp hab) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/GreedyRowMatching.lean b/LeanPool/BeyondBethe/BeyondBethe/GreedyRowMatching.lean new file mode 100644 index 0000000000..7b814c4ca1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/GreedyRowMatching.lean @@ -0,0 +1,389 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NearCase +public import LeanPool.BeyondBethe.BeyondBethe.NumericalWitness +public import Mathlib.Algebra.Order.BigOperators.Group.Finset + +/-! # Greedy Row Matching -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Greedy row matchings + +The algorithmic certificate does not need an exact maximum-weight matching. +After retaining all row pairs whose directed lower gain exceeds a fixed +threshold, it is enough to construct any maximal matching in that graph. +The elementary cardinality lemma below shows that such a matching has at +least half as many edges as every other matching in the retained graph. +-/ + +/-- Every successful clean factor already has a large explicit finite-witness +value. No optimized pair capacity and no input-matrix data enter this fact. -/ +theorem successfulCleanCycle_explicitWitnessGain + {n : β„•} {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· : ℝ} + (hgain : ExplicitPairWitnessGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + {P X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) + (hc : c ∈ successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g) : + Ξ³β‚€ ≀ explicitPairWitnessLogGain Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := by + have hcost : fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) ≀ ΞΊβ‚€ := by + have hnot : Β¬ ΞΊβ‚€ < fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := by + simpa [successfulCleanCycles, failedCleanCycles] using hc + exact le_of_not_gt hnot + have hcols := cleanCycle_core_columns c + exact hgain hell hlogn hΞΎ hΞΎβ‚€ hΟ„scale hX hXint + hcols.1 hcols.2.1 hcost + +/-- `M` is a maximal matching relative to the available row pairs `E`. +The last field is the useful certificate form of maximality: every available +edge meets an edge already selected by `M`. -/ +structure IsMaximalRowMatching {n : β„•} + (E M : Finset (RowPair n)) : Prop where + subset : M βŠ† E + matching : IsRowMatching M + covered : βˆ€ q ∈ E, βˆƒ r ∈ M, Β¬Disjoint q.1 r.1 + +/-- The vertices covered by a row matching. -/ +def rowMatchingVertices {n : β„•} (M : Finset (RowPair n)) : Finset (Fin n) := + M.biUnion fun q ↦ q.1 + +theorem rowMatchingVertices_card_le_two_mul {n : β„•} + (M : Finset (RowPair n)) : + (rowMatchingVertices M).card ≀ 2 * M.card := by + rw [show 2 * M.card = M.card * 2 by omega] + exact Finset.card_biUnion_le_card_mul M (fun q ↦ q.1) 2 + (fun q _ ↦ q.2.le) + +/-- A maximal matching is a factor-two approximation to maximum cardinality. +This proof uses only the fact that the competing edges are disjoint: choose, +for each competing edge, a covered endpoint. Those choices are injective, +and the selected matching covers at most two vertices per edge. -/ +theorem card_le_two_mul_of_maximalRowMatching {n : β„•} + {E M S : Finset (RowPair n)} + (hM : IsMaximalRowMatching E M) + (hS : IsRowMatching S) (hSE : S βŠ† E) : + S.card ≀ 2 * M.card := by + classical + let V := rowMatchingVertices M + have hinter : βˆ€ q : S, βˆƒ v : Fin n, v ∈ q.1.1 ∧ v ∈ V := by + intro q + obtain ⟨r, hrM, hqr⟩ := hM.covered q.1 (hSE q.2) + obtain ⟨v, hvq, hvr⟩ := Finset.not_disjoint_iff.mp hqr + refine ⟨v, hvq, ?_⟩ + exact Finset.mem_biUnion.mpr ⟨r, hrM, hvr⟩ + let chosen : S β†’ Fin n := fun q ↦ (hinter q).choose + have hchosen_mem_edge (q : S) : chosen q ∈ q.1.1 := + (hinter q).choose_spec.1 + have hchosen_mem_V (q : S) : chosen q ∈ V := + (hinter q).choose_spec.2 + let intoV : S β†’ V := fun q ↦ ⟨chosen q, hchosen_mem_V q⟩ + have hinjective : Function.Injective intoV := by + intro q q' heq + apply Subtype.ext + by_contra hqq' + have hdisj : Disjoint q.1.1 q'.1.1 := + hS q.2 q'.2 hqq' + have hval : chosen q = chosen q' := congrArg Subtype.val heq + exact (Finset.disjoint_left.mp hdisj) + (hchosen_mem_edge q) (hval β–Έ hchosen_mem_edge q') + calc + S.card ≀ V.card := Finset.card_le_card_of_injective hinjective + _ ≀ 2 * M.card := rowMatchingVertices_card_le_two_mul M + +/-- Greedily scan a list of available row pairs. An edge is inserted exactly +when it is disjoint from all edges selected later in the list. (Thus the +recursion fixes a deterministic reverse-list scan.) -/ +def greedyRowMatchingList {n : β„•} : + List (RowPair n) β†’ Finset (RowPair n) + | [] => βˆ… + | q :: qs => + let M := greedyRowMatchingList qs + if βˆ€ r ∈ M, Disjoint q.1 r.1 then insert q M else M + +theorem greedyRowMatchingList_isMaximal {n : β„•} + (edges : List (RowPair n)) : + IsMaximalRowMatching edges.toFinset (greedyRowMatchingList edges) := by + induction edges with + | nil => + refine ⟨by simp [greedyRowMatchingList], by simp [greedyRowMatchingList, + IsRowMatching], ?_⟩ + simp + | cons q qs ih => + rw [greedyRowMatchingList] + split_ifs with hdisj + Β· refine ⟨?_, ?_, ?_⟩ + Β· intro r hr + simp only [List.toFinset_cons, Finset.mem_insert] at hr ⊒ + exact hr.elim Or.inl (fun hrM ↦ Or.inr (ih.subset hrM)) + Β· rw [IsRowMatching, Finset.coe_insert] + exact ih.matching.insert fun r hr _ ↦ hdisj r hr + Β· intro e he + simp only [List.toFinset_cons, Finset.mem_insert] at he + rcases he with heq | he + Β· have hecard := e.2 + have hepos : 0 < e.1.card := by omega + obtain ⟨v, hv⟩ := Finset.card_pos.mp hepos + exact ⟨e, by simpa [heq], + Finset.not_disjoint_iff.mpr ⟨v, hv, hv⟩⟩ + Β· obtain ⟨r, hr, her⟩ := ih.covered e he + exact ⟨r, Finset.mem_insert_of_mem hr, her⟩ + Β· refine ⟨?_, ih.matching, ?_⟩ + Β· exact ih.subset.trans (by simp) + Β· intro e he + simp only [List.toFinset_cons, Finset.mem_insert] at he + rcases he with heq | he + Β· subst e + push Not at hdisj + exact hdisj + Β· exact ih.covered e he + +/-- Gain form of the cardinality lemma. If every selected edge has gain at +least `a`, a maximal matching collects at least one half of `a` times the +cardinality of any competing matching in the threshold graph. -/ +theorem half_card_mul_le_sum_of_maximalRowMatching {n : β„•} + {E M S : Finset (RowPair n)} (w : RowPair n β†’ ℝ) {a : ℝ} + (ha : 0 ≀ a) (hM : IsMaximalRowMatching E M) + (hS : IsRowMatching S) (hSE : S βŠ† E) + (hweight : βˆ€ q ∈ M, a ≀ w q) : + ((S.card : ℝ) * a) / 2 ≀ βˆ‘ q ∈ M, w q := by + have hcard : (S.card : ℝ) ≀ 2 * M.card := by + exact_mod_cast card_le_two_mul_of_maximalRowMatching hM hS hSE + have hcardGain : ((S.card : ℝ) * a) / 2 ≀ (M.card : ℝ) * a := by + have := mul_le_mul_of_nonneg_right hcard ha + norm_num at this ⊒ + linarith + refine hcardGain.trans ?_ + calc + (M.card : ℝ) * a = βˆ‘ _q ∈ M, a := by simp + _ ≀ βˆ‘ q ∈ M, w q := Finset.sum_le_sum hweight + +/-- The unordered row pair associated with two rows in increasing order. -/ +def rowPairOfLT {n : β„•} (i j : Fin n) (hij : i < j) : RowPair n := + ⟨{i, j}, by simp [ne_of_lt hij]⟩ + +@[simp] theorem rowPairRow_rowPairOfLT_zero {n : β„•} + (i j : Fin n) (hij : i < j) : + rowPairRow (rowPairOfLT i j hij) 0 = i := by + let q := rowPairOfLT i j hij + have hzero := rowPairRow_mem q 0 + have hone := rowPairRow_mem q 1 + have hlt : rowPairRow q 0 < rowPairRow q 1 := by + exact (q.1.orderIsoOfFin q.2).lt_iff_lt.mpr (by decide) + dsimp only [q] at hlt + change rowPairRow (rowPairOfLT i j hij) 0 ∈ ({i, j} : Finset (Fin n)) at hzero + change rowPairRow (rowPairOfLT i j hij) 1 ∈ ({i, j} : Finset (Fin n)) at hone + simp only [Finset.mem_insert, Finset.mem_singleton] at hzero hone + rcases hzero with hzero | hzero + Β· exact hzero + Β· rcases hone with hone | hone + Β· rw [hzero, hone] at hlt + exact False.elim ((not_lt_of_ge hij.le) hlt) + Β· rw [hzero, hone] at hlt + exact False.elim ((lt_irrefl j) hlt) + +@[simp] theorem rowPairRow_rowPairOfLT_one {n : β„•} + (i j : Fin n) (hij : i < j) : + rowPairRow (rowPairOfLT i j hij) 1 = j := by + let q := rowPairOfLT i j hij + have hzero := rowPairRow_mem q 0 + have hone := rowPairRow_mem q 1 + have hlt : rowPairRow q 0 < rowPairRow q 1 := by + exact (q.1.orderIsoOfFin q.2).lt_iff_lt.mpr (by decide) + dsimp only [q] at hlt + change rowPairRow (rowPairOfLT i j hij) 0 ∈ ({i, j} : Finset (Fin n)) at hzero + change rowPairRow (rowPairOfLT i j hij) 1 ∈ ({i, j} : Finset (Fin n)) at hone + simp only [Finset.mem_insert, Finset.mem_singleton] at hzero hone + rcases hone with hone | hone + Β· rcases hzero with hzero | hzero + Β· rw [hzero, hone] at hlt + exact False.elim ((lt_irrefl i) hlt) + Β· rw [hzero, hone] at hlt + exact False.elim ((not_lt_of_ge hij.le) hlt) + Β· exact hone + +/-- Explicit lexicographic enumeration of every unordered row pair. Unlike +`Finset.toList`, this definition carries no classical choice and is executable. -/ +def allRowPairsList (n : β„•) : List (RowPair n) := + (List.finRange n).flatMap fun i ↦ + (List.finRange n).filterMap fun j ↦ + if hij : i < j then some (rowPairOfLT i j hij) else none + +theorem rowPairOfLT_mem_allRowPairsList {n : β„•} + (i j : Fin n) (hij : i < j) : + rowPairOfLT i j hij ∈ allRowPairsList n := by + rw [allRowPairsList, List.mem_flatMap] + refine ⟨i, List.mem_finRange i, ?_⟩ + rw [List.mem_filterMap] + refine ⟨j, List.mem_finRange j, ?_⟩ + simp [hij] + +theorem mem_allRowPairsList {n : β„•} (q : RowPair n) : + q ∈ allRowPairsList n := by + obtain ⟨i, j, hij, hq⟩ := Finset.card_eq_two.mp q.2 + rcases lt_or_gt_of_ne hij with hlt | hgt + Β· have hmem := rowPairOfLT_mem_allRowPairsList i j hlt + have heq : q = rowPairOfLT i j hlt := by + apply Subtype.ext + simpa [rowPairOfLT] using hq + rwa [heq] + Β· have hmem := rowPairOfLT_mem_allRowPairsList j i hgt + have heq : q = rowPairOfLT j i hgt := by + apply Subtype.ext + simpa [rowPairOfLT, Finset.pair_comm] using hq + rwa [heq] + +/-- Retain exactly the row pairs whose rational certified weight reaches the +given rational threshold. -/ +def thresholdRowPairsList {n : β„•} (w : RowPair n β†’ β„š) (a : β„š) : + List (RowPair n) := + (allRowPairsList n).filter fun q ↦ decide (a ≀ w q) + +theorem mem_thresholdRowPairsList_iff {n : β„•} + (w : RowPair n β†’ β„š) (a : β„š) (q : RowPair n) : + q ∈ thresholdRowPairsList w a ↔ a ≀ w q := by + simp [thresholdRowPairsList, mem_allRowPairsList] + +/-- Executable threshold-and-greedy row matching. -/ +def greedyThresholdRowMatching {n : β„•} + (w : RowPair n β†’ β„š) (a : β„š) : Finset (RowPair n) := + greedyRowMatchingList (thresholdRowPairsList w a) + +theorem greedyThresholdRowMatching_isMaximal {n : β„•} + (w : RowPair n β†’ β„š) (a : β„š) : + IsMaximalRowMatching + (thresholdRowPairsList w a).toFinset + (greedyThresholdRowMatching w a) := by + exact greedyRowMatchingList_isMaximal _ + +theorem greedyThresholdRowMatching_weight {n : β„•} + (w : RowPair n β†’ β„š) {a : β„š} + {S : Finset (RowPair n)} (ha : 0 ≀ a) + (hS : IsRowMatching S) (hqualifies : βˆ€ q ∈ S, a ≀ w q) : + ((S.card : ℝ) * (a : ℝ)) / 2 ≀ + βˆ‘ q ∈ greedyThresholdRowMatching w a, (w q : ℝ) := by + let E := (thresholdRowPairsList w a).toFinset + let M := greedyThresholdRowMatching w a + have hmax : IsMaximalRowMatching E M := + greedyThresholdRowMatching_isMaximal w a + have hSE : S βŠ† E := by + intro q hq + simp only [E, List.mem_toFinset, mem_thresholdRowPairsList_iff] + exact hqualifies q hq + have hweight : βˆ€ q ∈ M, (a : ℝ) ≀ (w q : ℝ) := by + intro q hq + have hqE := hmax.subset hq + have hqrat : a ≀ w q := by + simpa only [E, List.mem_toFinset, mem_thresholdRowPairsList_iff] using hqE + exact_mod_cast hqrat + exact half_card_mul_le_sum_of_maximalRowMatching + (fun q ↦ (w q : ℝ)) (by exact_mod_cast ha) hmax hS hSE hweight + +/-- Rational gain collected by the executable threshold matching. -/ +def greedyCertifiedMatchingGain {n : β„•} + (w : RowPair n β†’ β„š) (a : β„š) : β„š := + βˆ‘ q ∈ greedyThresholdRowMatching w a, w q + +theorem cast_greedyCertifiedMatchingGain {n : β„•} + (w : RowPair n β†’ β„š) (a : β„š) : + (greedyCertifiedMatchingGain w a : ℝ) = + βˆ‘ q ∈ greedyThresholdRowMatching w a, (w q : ℝ) := by + simp [greedyCertifiedMatchingGain] + +theorem greedyCertifiedMatchingGain_structural_lower {n : β„•} + (w : RowPair n β†’ β„š) {a : β„š} + {S : Finset (RowPair n)} (ha : 0 ≀ a) + (hS : IsRowMatching S) (hqualifies : βˆ€ q ∈ S, a ≀ w q) : + ((S.card : ℝ) * (a : ℝ)) / 2 ≀ + (greedyCertifiedMatchingGain w a : ℝ) := by + rw [cast_greedyCertifiedMatchingGain] + exact greedyThresholdRowMatching_weight w ha hS hqualifies + +/-- The threshold-greedy routine captures half of the certified gain carried +by the disjoint successful clean pairs. This is the exact replacement for +the maximum-weight-matching domination used in the nonalgorithmic proof. -/ +theorem greedyCertifiedMatchingGain_ge_successfulCleanCycles + {n : β„•} {ΞΊ Ο„ Ξ· : ℝ} {P X : Matrix (Fin n) (Fin n) ℝ} + (f g : Equiv.Perm (Fin n)) (w : RowPair n β†’ β„š) {a : β„š} + (ha : 0 ≀ a) + (hqualifies : βˆ€ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + a ≀ w (cleanCycleRowPair c)) : + (((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) * (a : ℝ)) / 2 ≀ + (greedyCertifiedMatchingGain w a : ℝ) := by + let S := successfulRowPairs ΞΊ Ο„ Ξ· P X f g + have hS : IsRowMatching S := successfulRowPairs_isRowMatching ΞΊ Ο„ Ξ· P X f g + have hSq : βˆ€ q ∈ S, a ≀ w q := by + intro q hq + obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hq + exact hqualifies c hc + have hcard : S.card = (successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card := by + exact Finset.card_image_iff.mpr cleanCycleRowPair_injective.injOn + have h := greedyCertifiedMatchingGain_structural_lower w ha hS hSq + rwa [hcard] at h + +/-- Every directed lower estimate selected by the greedy routine remains a +valid permanent certificate. Exact maximum-weight matching is unnecessary: +the paired certificate applies to the selected matching itself, and +monotonicity of `exp` permits replacing its true gain by any rational lower +sum. -/ +theorem exp_betheObjective_add_greedyCertifiedMatchingGain_le_permanent + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} + (w : RowPair n β†’ β„š) {a : β„š} (ha : 0 < a) + (hlower : βˆ€ q ∈ greedyThresholdRowMatching w a, (w q : ℝ) ≀ + Real.log (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) : + Real.exp (betheObjective A X + + (greedyCertifiedMatchingGain w a : ℝ)) ≀ + Matrix.permanent A := by + let M := greedyThresholdRowMatching w a + have hmax : IsMaximalRowMatching + (thresholdRowPairsList w a).toFinset M := + greedyThresholdRowMatching_isMaximal w a + have hselected : βˆ€ q ∈ M, a ≀ w q := by + intro q hq + have hqE := hmax.subset hq + simpa only [List.mem_toFinset, mem_thresholdRowPairsList_iff] using hqE + have hpositive : βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) := by + intro q hq + have hcast : (a : ℝ) ≀ (w q : ℝ) := by + exact_mod_cast hselected q hq + have hareal : 0 < (a : ℝ) := by exact_mod_cast ha + exact hareal.trans_le (hcast.trans (hlower q hq)) + have hsum : (greedyCertifiedMatchingGain w a : ℝ) ≀ + rowMatchingWeight A X M := by + rw [cast_greedyCertifiedMatchingGain, rowMatchingWeight] + exact Finset.sum_le_sum fun q hq ↦ by + rw [rowPairWeight, max_eq_right (le_of_lt (hpositive q hq))] + exact hlower q hq + have hexp : Real.exp (betheObjective A X + + (greedyCertifiedMatchingGain w a : ℝ)) ≀ + Real.exp (betheObjective A X + rowMatchingWeight A X M) := by + exact Real.exp_le_exp.mpr (by linarith) + exact hexp.trans + (exp_betheObjective_add_rowMatchingWeight_le_permanent + stableCoefficient hmax.matching hcard hA hX hXpos hpositive) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/KuhnMatching.lean b/LeanPool/BeyondBethe/BeyondBethe/KuhnMatching.lean new file mode 100644 index 0000000000..87f8fd639c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/KuhnMatching.lean @@ -0,0 +1,945 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import Mathlib.Data.List.FinRange +public import Mathlib.Tactic + +/-! # Kuhn Matching -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Executable augmenting-path matching + +This file implements the polynomial augmenting-path algorithm for the +positive support of a square rational matrix. A state maps each column to +its currently matched row. Failed recursive searches return the enlarged +set of visited columns, so a single root search examines each column at most +once; this detail is essential for the polynomial bound. +-/ + +/-- A table assigning each column either a matched row or no match. -/ +abbrev ColumnMate (n : β„•) := Fin n β†’ Option (Fin n) + +/-- The column-mate table with every column unmatched. -/ +def emptyColumnMate (n : β„•) : ColumnMate n := fun _ ↦ none + +/-- A column-to-row table represents a partial matching in the positive +support of `A`. -/ +structure IsSupportColumnMate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) : Prop where + support : βˆ€ {col row}, mate col = some row β†’ A row col β‰  0 + injective : βˆ€ {col col' row}, + mate col = some row β†’ mate col' = some row β†’ col = col' + +/-- No column in the mate table is assigned to the given row. -/ +def RowUnmatched {n : β„•} (mate : ColumnMate n) (row : Fin n) : Prop := + βˆ€ col, mate col β‰  some row + +/-- Some column in the mate table is assigned to the given row. -/ +def MatchesRow {n : β„•} (mate : ColumnMate n) (row : Fin n) : Prop := + βˆƒ col, mate col = some row + +theorem rowUnmatched_iff_not_matchesRow {n : β„•} + (mate : ColumnMate n) (row : Fin n) : + RowUnmatched mate row ↔ Β¬MatchesRow mate row := by + simp [RowUnmatched, MatchesRow] + +theorem emptyColumnMate_support (n : β„•) + (A : Matrix (Fin n) (Fin n) β„š) : + IsSupportColumnMate A (emptyColumnMate n) := by + constructor <;> simp [emptyColumnMate] + +theorem rowUnmatched_emptyColumnMate (n : β„•) (row : Fin n) : + RowUnmatched (emptyColumnMate n) row := by + simp [RowUnmatched, emptyColumnMate] + +theorem IsSupportColumnMate.update_none {n : β„•} + {A : Matrix (Fin n) (Fin n) β„š} {mate : ColumnMate n} + (h : IsSupportColumnMate A mate) (col : Fin n) : + IsSupportColumnMate A (Function.update mate col none) := by + constructor + Β· intro j row hj + by_cases hcol : j = col + Β· subst j + simp at hj + Β· simp [Function.update, hcol] at hj + exact h.support hj + Β· intro j j' row hj hj' + by_cases hjc : j = col + Β· subst j + simp at hj + Β· simp [Function.update, hjc] at hj + by_cases hjc' : j' = col + Β· subst j' + simp at hj' + Β· simp [Function.update, hjc'] at hj' + exact h.injective hj hj' + +theorem IsSupportColumnMate.update_some {n : β„•} + {A : Matrix (Fin n) (Fin n) β„š} {mate : ColumnMate n} + (h : IsSupportColumnMate A mate) {col row : Fin n} + (hrow : RowUnmatched mate row) (hedge : A row col β‰  0) : + IsSupportColumnMate A (Function.update mate col (some row)) := by + constructor + Β· intro j r hj + by_cases hcol : j = col + Β· subst j + simp at hj + subst r + exact hedge + Β· simp [Function.update, hcol] at hj + exact h.support hj + Β· intro j j' r hj hj' + by_cases hjc : j = col + Β· subst j + simp at hj + subst r + by_cases hjc' : j' = col + Β· exact hjc'.symm + Β· simp [Function.update, hjc'] at hj' + exact (hrow j' hj').elim + Β· simp [Function.update, hjc] at hj + by_cases hjc' : j' = col + Β· subst j' + simp at hj' + subst r + exact (hrow j hj).elim + Β· simp [Function.update, hjc'] at hj' + exact h.injective hj hj' + +theorem matchesRow_update_none_iff {n : β„•} + {mate : ColumnMate n} {col oldRow row : Fin n} + (hinj : βˆ€ {j j' r}, + mate j = some r β†’ mate j' = some r β†’ j = j') + (hmate : mate col = some oldRow) : + MatchesRow (Function.update mate col none) row ↔ + MatchesRow mate row ∧ row β‰  oldRow := by + constructor + Β· rintro ⟨j, hj⟩ + have hjne : j β‰  col := by + intro h + subst j + simp at hj + have hjold : mate j = some row := by + simpa [Function.update, hjne] using hj + refine ⟨⟨j, hjold⟩, ?_⟩ + intro hrow + subst row + exact hjne (hinj hjold hmate) + Β· rintro ⟨⟨j, hj⟩, hrow⟩ + refine ⟨j, ?_⟩ + have hjne : j β‰  col := by + intro h + subst j + rw [hmate] at hj + exact hrow (Option.some.inj hj).symm + simpa [Function.update, hjne] using hj + +theorem rowUnmatched_update_none_of_mate {n : β„•} + {A : Matrix (Fin n) (Fin n) β„š} {mate : ColumnMate n} + (h : IsSupportColumnMate A mate) {col oldRow : Fin n} + (hmate : mate col = some oldRow) : + RowUnmatched (Function.update mate col none) oldRow := by + rw [rowUnmatched_iff_not_matchesRow, matchesRow_update_none_iff h.injective hmate] + simp + +theorem matchesRow_update_some_iff {n : β„•} + {mate : ColumnMate n} {col newRow row : Fin n} + (hcol : mate col = none) : + MatchesRow (Function.update mate col (some newRow)) row ↔ + MatchesRow mate row ∨ row = newRow := by + constructor + Β· rintro ⟨j, hj⟩ + by_cases h : j = col + Β· subst j + simp at hj + exact Or.inr hj.symm + Β· left + exact ⟨j, by simpa [Function.update, h] using hj⟩ + Β· rintro (⟨j, hj⟩ | rfl) + Β· have h : j β‰  col := by + intro heq + subst j + rw [hcol] at hj + contradiction + exact ⟨j, by simpa [Function.update, h] using hj⟩ + Β· exact ⟨col, by simp⟩ + +/-- Result of one augmenting-path search. `mate? = some m` records success; +either way, `seen` contains every column examined by the search. -/ +structure KuhnSearchResult (n : β„•) where + /-- The updated mate table on successful augmentation, or `none` when the search fails. -/ + mate? : Option (ColumnMate n) + /-- The set of columns visited by the search, retained even when augmentation fails. -/ + seen : Finset (Fin n) + +/-- Depth-first augmenting-path search with a shared visited-column set. +The first natural-number argument bounds alternating-path depth; the column +list is the part of the current row that remains to be scanned. A failed +recursive call threads its enlarged visited set into the rest of the scan. +The lexicographic recursion makes both sources of progress explicit. -/ +def kuhnSearch {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + (fuel : β„•) β†’ List (Fin n) β†’ Fin n β†’ Finset (Fin n) β†’ + ColumnMate n β†’ KuhnSearchResult n + | 0, _remaining, _row, seen, _mate => ⟨none, seen⟩ + | _fuel + 1, [], _row, seen, _mate => ⟨none, seen⟩ + | fuel + 1, col :: remaining, row, seen, mate => + if hskip : col ∈ seen ∨ A row col = 0 then + kuhnSearch A (fuel + 1) remaining row seen mate + else + let seen' := insert col seen + match hmate : mate col with + | none => ⟨some (Function.update mate col (some row)), seen'⟩ + | some oldRow => + let mateWithoutOld := Function.update mate col none + let recursive := + kuhnSearch A fuel (List.finRange n) oldRow seen' mateWithoutOld + match recursive.mate? with + | some mate' => + ⟨some (Function.update mate' col (some row)), recursive.seen⟩ + | none => + kuhnSearch A (fuel + 1) remaining row recursive.seen mate +termination_by fuel remaining _row _seen _mate => (fuel, remaining.length) + +/-- Number of column inspections made by `kuhnSearch`. Recursive work is +charged only on the branch actually taken by the executable search. -/ +def kuhnSearchWork {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + (fuel : β„•) β†’ List (Fin n) β†’ Fin n β†’ Finset (Fin n) β†’ ColumnMate n β†’ β„• + | 0, _remaining, _row, _seen, _mate => 0 + | _fuel + 1, [], _row, _seen, _mate => 0 + | fuel + 1, col :: remaining, row, seen, mate => + if col ∈ seen ∨ A row col = 0 then + 1 + kuhnSearchWork A (fuel + 1) remaining row seen mate + else + let seen' := insert col seen + match mate col with + | none => 1 + | some oldRow => + let mateWithoutOld := Function.update mate col none + let recursive := + kuhnSearch A fuel (List.finRange n) oldRow seen' mateWithoutOld + let recursiveWork := + kuhnSearchWork A fuel (List.finRange n) oldRow seen' mateWithoutOld + match recursive.mate? with + | some _ => 1 + recursiveWork + | none => 1 + recursiveWork + + kuhnSearchWork A (fuel + 1) remaining row recursive.seen mate +termination_by fuel remaining _row _seen _mate => (fuel, remaining.length) + +/-- Search all columns from scratch for an augmenting path rooted at `row`. -/ +def kuhnAugment {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (fuel : β„•) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) : KuhnSearchResult n := + kuhnSearch A fuel (List.finRange n) row seen mate + +theorem kuhnSearch_seen_mono {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) : + seen βŠ† (kuhnSearch A fuel remaining row seen mate).seen := by + fun_induction kuhnSearch <;> simp_all [Finset.subset_iff] <;> aesop + +/-- Amortized work bound. Scanning the current suffix is charged directly; +each newly visited column pays for at most one fresh full row scan. -/ +theorem kuhnSearchWork_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) : + kuhnSearchWork A fuel remaining row seen mate ≀ + remaining.length + (n + 1) * + ((kuhnSearch A fuel remaining row seen mate).seen.card - seen.card) := by + fun_induction kuhnSearchWork with + | case1 => + rw [kuhnSearch.eq_def] + simp + | case2 => + rw [kuhnSearch.eq_def] + simp + | case3 fuel col remaining row seen mate hskip ih => + rw [kuhnSearch.eq_def] + dsimp only + rw [dif_pos hskip] + simp only [List.length_cons] + omega + | case4 fuel col remaining row seen mate hskip hmate => + rw [kuhnSearch.eq_def] + dsimp only + rw [dite_eq_right hskip, hmate] + simp only [List.length_cons] + have hnot : col βˆ‰ seen := by aesop + rw [Finset.card_insert_of_notMem hnot] + omega + | case5 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive recursiveWork mateRec hrec ih => + rw [kuhnSearch.eq_def] + dsimp only + rw [dite_eq_right hskip, hmate] + simp + rw [show (kuhnSearch A fuel (List.finRange n) oldRow + (insert col seen) (Function.update mate col none)).mate? = some mateRec by + simpa [recursive] using hrec] + change 1 + recursiveWork ≀ remaining.length + 1 + + (n + 1) * (recursive.seen.card - seen.card) + have hnot : col βˆ‰ seen := by aesop + have hcardInsert : seen'.card = seen.card + 1 := by + simpa [seen'] using Finset.card_insert_of_notMem hnot + have hsubset : seen' βŠ† recursive.seen := by + simpa [recursive] using kuhnSearch_seen_mono A fuel + (List.finRange n) oldRow seen' mateWithoutOld + have hcard : seen'.card ≀ recursive.seen.card := + Finset.card_le_card hsubset + have hih : recursiveWork ≀ + n + (n + 1) * (recursive.seen.card - seen'.card) := by + simpa [recursiveWork, recursive] using ih + have hsubEq : recursive.seen.card - seen.card = + (recursive.seen.card - seen'.card) + 1 := by + omega + rw [hsubEq, Nat.mul_add] + omega + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive recursiveWork hrec ihRec ihContinue => + rw [kuhnSearch.eq_def] + dsimp only + rw [dite_eq_right hskip, hmate] + simp + rw [show (kuhnSearch A fuel (List.finRange n) oldRow + (insert col seen) (Function.update mate col none)).mate? = none by + simpa [recursive] using hrec] + change 1 + recursiveWork + + kuhnSearchWork A (fuel + 1) remaining row recursive.seen mate ≀ + remaining.length + 1 + (n + 1) * + ((kuhnSearch A (fuel + 1) remaining row recursive.seen mate).seen.card - + seen.card) + have hnot : col βˆ‰ seen := by aesop + have hcardInsert : seen'.card = seen.card + 1 := by + simpa [seen'] using Finset.card_insert_of_notMem hnot + have hsubsetRec : seen' βŠ† recursive.seen := by + simpa [recursive] using kuhnSearch_seen_mono A fuel + (List.finRange n) oldRow seen' mateWithoutOld + have hcardRec : seen'.card ≀ recursive.seen.card := + Finset.card_le_card hsubsetRec + have hsubsetFinal : recursive.seen βŠ† + (kuhnSearch A (fuel + 1) remaining row recursive.seen mate).seen := + kuhnSearch_seen_mono A (fuel + 1) remaining row recursive.seen mate + have hcardFinal : recursive.seen.card ≀ + (kuhnSearch A (fuel + 1) remaining row recursive.seen mate).seen.card := + Finset.card_le_card hsubsetFinal + have hihRec : recursiveWork ≀ + n + (n + 1) * (recursive.seen.card - seen'.card) := by + simpa [recursiveWork, recursive] using ihRec + let finalCard := + (kuhnSearch A (fuel + 1) remaining row recursive.seen mate).seen.card + have hihContinue : + kuhnSearchWork A (fuel + 1) remaining row recursive.seen mate ≀ + remaining.length + (n + 1) * + (finalCard - recursive.seen.card) := by + simpa [finalCard] using ihContinue + clear ihContinue + have hsplitOne : recursive.seen.card - seen.card = + (recursive.seen.card - seen'.card) + 1 := by + omega + have hsplitAll : finalCard - seen.card = + (finalCard - recursive.seen.card) + + (recursive.seen.card - seen.card) := by + dsimp only [finalCard] + omega + change 1 + recursiveWork + + kuhnSearchWork A (fuel + 1) remaining row recursive.seen mate ≀ + remaining.length + 1 + (n + 1) * (finalCard - seen.card) + rw [hsplitAll, hsplitOne, Nat.mul_add, Nat.mul_add] + omega + +/-- The work count for an augmenting-path search over the full ordered column list. -/ +def kuhnAugmentWork {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (fuel : β„•) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) : β„• := + kuhnSearchWork A fuel (List.finRange n) row seen mate + +/-- One augmentation makes at most `n + (n+1)n` column inspections. -/ +theorem kuhnAugmentWork_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (row : Fin n) (mate : ColumnMate n) : + kuhnAugmentWork A fuel row βˆ… mate ≀ n + (n + 1) * n := by + have hwork := kuhnSearchWork_le A fuel (List.finRange n) row βˆ… mate + have hcard := Finset.card_le_univ + (kuhnSearch A fuel (List.finRange n) row βˆ… mate).seen + simp only [Fintype.card_fin] at hcard + simp only [List.length_finRange, Finset.card_empty, Nat.sub_zero] at hwork + exact hwork.trans + (Nat.add_le_add_left (Nat.mul_le_mul_left (n + 1) hcard) n) + +/-- A search never changes a column that was already marked as visited when +the search began. -/ +theorem kuhnSearch_preserves_seen {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row c : Fin n) + (seen : Finset (Fin n)) (mate mate' : ColumnMate n) + (hc : c ∈ seen) + (hresult : (kuhnSearch A fuel remaining row seen mate).mate? = some mate') : + mate' c = mate c := by + fun_induction kuhnSearch generalizing c mate' with + | case1 => simp_all + | case2 => simp_all + | case3 => simp_all + | case4 fuel col remaining row seen mate hskip seen' hmate => + have hnot : col βˆ‰ seen := by + intro hmem + exact hskip (Or.inl hmem) + have hcne : c β‰  col := by + intro heq + subst c + exact hnot hc + change some (Function.update mate col (some row)) = some mate' at hresult + injection hresult with heq + subst mate' + simp [Function.update, hcne] + | case5 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive mateRec hrec ih => + have hnot : col βˆ‰ seen := by + intro hmem + exact hskip (Or.inl hmem) + have hcne : c β‰  col := by + intro heq + subst c + exact hnot hc + change some (Function.update mateRec col (some row)) = some mate' at hresult + injection hresult with heq + subst mate' + calc + Function.update mateRec col (some row) c = mateRec c := by + simp [Function.update, hcne] + _ = Function.update mate col none c := + ih c mateRec (by simp [seen', hc]) hrec + _ = mate c := by simp [Function.update, hcne] + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive hrec ihRec ihRec' ihContinue => + apply ihContinue c mate' ?_ hresult + apply kuhnSearch_seen_mono A fuel (List.finRange n) oldRow seen' + mateWithoutOld + simp [seen', hc] + +/-- On success, augmenting adds exactly the root row to the set of matched +rows, and it preserves the support and injectivity invariants. -/ +theorem kuhnSearch_success {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate mate' : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : RowUnmatched mate row) + (hresult : (kuhnSearch A fuel remaining row seen mate).mate? = some mate') : + IsSupportColumnMate A mate' ∧ + βˆ€ r, MatchesRow mate' r ↔ MatchesRow mate r ∨ r = row := by + fun_induction kuhnSearch generalizing mate' with + | case1 => simp_all + | case2 => simp_all + | case3 fuel col remaining row seen mate hskip ih => + exact ih mate' hsupport hunmatched hresult + | case4 fuel col remaining row seen mate hskip seen' hmate => + change some (Function.update mate col (some row)) = some mate' at hresult + injection hresult with heq + subst mate' + have hedge : A row col β‰  0 := by aesop + exact ⟨hsupport.update_some hunmatched hedge, + fun r ↦ matchesRow_update_some_iff hmate⟩ + | case5 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive mateRec hrec ih => + have hcleared : IsSupportColumnMate A mateWithoutOld := by + simpa [mateWithoutOld] using hsupport.update_none col + have holdUnmatched : RowUnmatched mateWithoutOld oldRow := by + simpa [mateWithoutOld] using + rowUnmatched_update_none_of_mate hsupport hmate + have hrecResult : + (kuhnSearch A fuel (List.finRange n) oldRow seen' mateWithoutOld).mate? = + some mateRec := by + simpa [recursive] using hrec + obtain ⟨hrecSupport, hrecRows⟩ := + ih mateRec hcleared holdUnmatched hrecResult + have hcolSeen : col ∈ seen' := by simp [seen'] + have hrecCol : mateRec col = none := by + calc + mateRec col = mateWithoutOld col := + kuhnSearch_preserves_seen A fuel (List.finRange n) oldRow col seen' + mateWithoutOld mateRec hcolSeen hrecResult + _ = none := by simp [mateWithoutOld] + have hrowNe : row β‰  oldRow := by + intro heq + subst oldRow + exact hunmatched col hmate + have hrootUnmatched : RowUnmatched mateRec row := by + rw [rowUnmatched_iff_not_matchesRow] + intro hroot + rw [hrecRows row] at hroot + rcases hroot with hroot | hroot + Β· rw [matchesRow_update_none_iff hsupport.injective hmate] at hroot + exact (rowUnmatched_iff_not_matchesRow mate row).mp hunmatched hroot.1 + Β· exact hrowNe hroot + have hedge : A row col β‰  0 := by aesop + change some (Function.update mateRec col (some row)) = some mate' at hresult + injection hresult with heq + subst mate' + constructor + Β· exact hrecSupport.update_some hrootUnmatched hedge + Β· intro r + rw [matchesRow_update_some_iff hrecCol, hrecRows, + matchesRow_update_none_iff hsupport.injective hmate] + constructor + Β· rintro ((⟨hr, hrne⟩ | rfl) | rfl) + Β· exact Or.inl hr + Β· exact Or.inl ⟨col, hmate⟩ + Β· exact Or.inr rfl + Β· rintro (hr | rfl) + Β· by_cases hrold : r = oldRow + Β· exact Or.inl (Or.inr hrold) + Β· exact Or.inl (Or.inl ⟨hr, hrold⟩) + Β· exact Or.inr rfl + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive hrec ihRec ihRec' ihContinue => + exact ihContinue mate' hsupport hunmatched hresult + +/-- Every nonzero support neighbor of the row lies in the specified column set. -/ +def AllSupportNeighborsIn {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (row : Fin n) + (cols : Finset (Fin n)) : Prop := + βˆ€ col, A row col β‰  0 β†’ col ∈ cols + +/-- A failed search has explored every remaining support edge of its root. +Every newly explored column was occupied, and the old row at that column has +all of its support neighbors in the final explored set. -/ +structure KuhnFailureCertificate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) + (row : Fin n) (initialSeen finalSeen : Finset (Fin n)) + (remaining : List (Fin n)) : Prop where + seen_subset : initialSeen βŠ† finalSeen + scanned : βˆ€ col, col ∈ remaining β†’ A row col β‰  0 β†’ col ∈ finalSeen + occupied_closed : βˆ€ col, col ∈ finalSeen β†’ col βˆ‰ initialSeen β†’ + βˆƒ oldRow, mate col = some oldRow ∧ AllSupportNeighborsIn A oldRow finalSeen + +/-- The precise failure certificate returned by the executable search. The +strict fuel-plus-visited inequality is preserved by every recursive descent; +at zero fuel it contradicts the fact that there are only `n` columns. -/ +theorem kuhnSearch_failure_certificate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) + (hroom : n < fuel + seen.card) + (hresult : (kuhnSearch A fuel remaining row seen mate).mate? = none) : + KuhnFailureCertificate A mate row seen + (kuhnSearch A fuel remaining row seen mate).seen remaining := by + fun_induction kuhnSearch with + | case1 remaining row seen mate => + have hcard := Finset.card_le_univ seen + simp [Fintype.card_fin] at hcard + omega + | case2 => + constructor + Β· exact fun _ h ↦ h + Β· simp + Β· intro col hmem hnot + exact (hnot hmem).elim + | case3 fuel col remaining row seen mate hskip ih => + have cert := ih hroom hresult + refine ⟨cert.seen_subset, ?_, cert.occupied_closed⟩ + intro c hc hedge + rcases (List.mem_cons.mp hc) with rfl | hc + Β· rcases hskip with hseen | hzero + Β· exact cert.seen_subset hseen + Β· exact (hedge hzero).elim + Β· exact cert.scanned c hc hedge + | case4 => simp_all + | case5 => simp_all + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive hrec ihRec ihRec' ihContinue => + have hnotSeen : col βˆ‰ seen := by aesop + have hseenCard : seen'.card = seen.card + 1 := by + simpa [seen'] using Finset.card_insert_of_notMem hnotSeen + have hroomRec : n < fuel + seen'.card := by omega + have certRec := ihRec' hroomRec hrec + have hcardMono : seen'.card ≀ recursive.seen.card := by + apply Finset.card_le_card + simpa [recursive] using certRec.seen_subset + have hroomContinue : n < (fuel + 1) + recursive.seen.card := by + omega + have certContinue := ihContinue hroomContinue hresult + have hrecSubset : recursive.seen βŠ† + (kuhnSearch A (fuel + 1) remaining row recursive.seen mate).seen := + certContinue.seen_subset + refine ⟨?_, ?_, ?_⟩ + Β· intro c hc + apply hrecSubset + apply certRec.seen_subset + simp [hc] + Β· intro c hc hedge + rcases (List.mem_cons.mp hc) with rfl | hc + Β· apply hrecSubset + exact certRec.seen_subset (by simp) + Β· exact certContinue.scanned c hc hedge + Β· intro c hcout hcnot + by_cases hcinRec : c ∈ recursive.seen + Β· by_cases hccol : c = col + Β· subst c + refine ⟨oldRow, hmate, ?_⟩ + intro d hd + apply hrecSubset + exact certRec.scanned d (List.mem_finRange d) hd + Β· have hcnotSeen' : c βˆ‰ seen' := by + simp only [seen', Finset.mem_insert, not_or] + exact ⟨hccol, hcnot⟩ + obtain ⟨r, hrmate, hrclosed⟩ := + certRec.occupied_closed c hcinRec hcnotSeen' + refine ⟨r, ?_, ?_⟩ + Β· simpa [mateWithoutOld, Function.update, hccol] using hrmate + Β· intro d hd + exact hrecSubset (hrclosed d hd) + Β· exact certContinue.occupied_closed c hcout hcinRec + +/-- If a full search from an unmatched row fails, its alternating-closure +certificate contradicts any perfect matching. The contradiction is a finite +pigeonhole argument: the root together with the old rows at the explored +columns would inject into the explored columns. -/ +theorem noPerfectMatching_of_kuhnAugment_failure {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (row : Fin n) + (mate : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : RowUnmatched mate row) + (hfail : (kuhnAugment A (n + 1) row βˆ… mate).mate? = none) : + Β¬Matrix.HasPerfectMatching A := by + classical + intro hperfect + obtain βŸ¨Οƒ, hΟƒβŸ© := hperfect + have hroom : n < (n + 1) + (βˆ… : Finset (Fin n)).card := by simp + have cert := kuhnSearch_failure_certificate A (n + 1) + (List.finRange n) row βˆ… mate hroom (by simpa [kuhnAugment] using hfail) + let finalSeen : Finset (Fin n) := + (kuhnSearch A (n + 1) (List.finRange n) row βˆ… mate).seen + let SeenColumn := {c : Fin n // c ∈ finalSeen} + have occupied (c : SeenColumn) : + βˆƒ oldRow, mate c.1 = some oldRow ∧ + AllSupportNeighborsIn A oldRow finalSeen := by + apply cert.occupied_closed c.1 + Β· exact c.2 + Β· simp + let oldRow : SeenColumn β†’ Fin n := fun c ↦ Classical.choose (occupied c) + have oldRow_mate (c : SeenColumn) : mate c.1 = some (oldRow c) := by + exact (Classical.choose_spec (occupied c)).1 + have oldRow_closed (c : SeenColumn) : + AllSupportNeighborsIn A (oldRow c) finalSeen := by + exact (Classical.choose_spec (occupied c)).2 + let sourceRow : Option SeenColumn β†’ Fin n + | none => row + | some c => oldRow c + have sourceRow_injective : Function.Injective sourceRow := by + intro x y hxy + cases x with + | none => + cases y with + | none => rfl + | some c => + exfalso + have hr : row = oldRow c := by simpa [sourceRow] using hxy + apply hunmatched c.1 + simpa [hr] using oldRow_mate c + | some c => + cases y with + | none => + exfalso + have hr : oldRow c = row := by simpa [sourceRow] using hxy + apply hunmatched c.1 + simpa [← hr] using oldRow_mate c + | some d => + apply congrArg some + apply Subtype.ext + apply hsupport.injective (oldRow_mate c) + have hr : oldRow c = oldRow d := by simpa [sourceRow] using hxy + simpa [← hr] using oldRow_mate d + have target_mem (x : Option SeenColumn) : + Οƒ.symm (sourceRow x) ∈ finalSeen := by + cases x with + | none => + apply cert.scanned (Οƒ.symm row) (List.mem_finRange _) + simpa [sourceRow] using hΟƒ (Οƒ.symm row) + | some c => + apply oldRow_closed c (Οƒ.symm (oldRow c)) + simpa using hΟƒ (Οƒ.symm (oldRow c)) + let targetColumn : Option SeenColumn β†’ SeenColumn := fun x ↦ + βŸ¨Οƒ.symm (sourceRow x), target_mem x⟩ + have targetColumn_injective : Function.Injective targetColumn := by + intro x y hxy + apply sourceRow_injective + apply Οƒ.symm.injective + exact congrArg Subtype.val hxy + have hcard := Fintype.card_le_of_injective targetColumn targetColumn_injective + simp only [Fintype.card_option] at hcard + omega + +theorem kuhnAugment_succeeds_of_hasPerfectMatching {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (row : Fin n) + (mate : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : RowUnmatched mate row) + (hperfect : Matrix.HasPerfectMatching A) : + βˆƒ mate', (kuhnAugment A (n + 1) row βˆ… mate).mate? = some mate' := by + cases hresult : (kuhnAugment A (n + 1) row βˆ… mate).mate? with + | none => + exact (noPerfectMatching_of_kuhnAugment_failure A row mate hsupport + hunmatched hresult hperfect).elim + | some mate' => exact ⟨mate', rfl⟩ + +theorem kuhnAugment_success {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (row : Fin n) + (mate mate' : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : RowUnmatched mate row) + (hresult : (kuhnAugment A (n + 1) row βˆ… mate).mate? = some mate') : + IsSupportColumnMate A mate' ∧ + βˆ€ r, MatchesRow mate' r ↔ MatchesRow mate r ∨ r = row := by + exact kuhnSearch_success A (n + 1) (List.finRange n) row βˆ… mate mate' + hsupport hunmatched (by simpa [kuhnAugment] using hresult) + +/-- Insert the listed rows one at a time, augmenting whenever possible. -/ +def kuhnBuild {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + List (Fin n) β†’ ColumnMate n β†’ ColumnMate n + | [], mate => mate + | row :: rows, mate => + let result := kuhnAugment A (n + 1) row βˆ… mate + kuhnBuild A rows (result.mate?.getD mate) + +/-- The cumulative augmenting-search work for the row list, retaining the previous mate table +when a search fails. -/ +def kuhnBuildWork {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + List (Fin n) β†’ ColumnMate n β†’ β„• + | [], _mate => 0 + | row :: rows, mate => + let result := kuhnAugment A (n + 1) row βˆ… mate + kuhnAugmentWork A (n + 1) row βˆ… mate + + kuhnBuildWork A rows (result.mate?.getD mate) + +/-- The row-building phase has a cubic coordinate-inspection bound. -/ +theorem kuhnBuildWork_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) : + kuhnBuildWork A rows mate ≀ rows.length * (n + (n + 1) * n) := by + induction rows generalizing mate with + | nil => simp [kuhnBuildWork] + | cons row rows ih => + rw [kuhnBuildWork] + calc + kuhnAugmentWork A (n + 1) row βˆ… mate + + kuhnBuildWork A rows + ((kuhnAugment A (n + 1) row βˆ… mate).mate?.getD mate) ≀ + (n + (n + 1) * n) + rows.length * (n + (n + 1) * n) := + Nat.add_le_add (kuhnAugmentWork_le A (n + 1) row mate) (ih _) + _ = (row :: rows).length * (n + (n + 1) * n) := by + simp [Nat.add_mul, Nat.add_comm] + +/-- If a perfect matching exists, inserting a duplicate-free list of +initially unmatched rows succeeds at every step and adds exactly those rows. -/ +theorem kuhnBuild_of_hasPerfectMatching {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) + (hperfect : Matrix.HasPerfectMatching A) + (hnodup : rows.Nodup) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : βˆ€ r, r ∈ rows β†’ RowUnmatched mate r) : + IsSupportColumnMate A (kuhnBuild A rows mate) ∧ + βˆ€ r, MatchesRow (kuhnBuild A rows mate) r ↔ + MatchesRow mate r ∨ r ∈ rows := by + induction rows generalizing mate with + | nil => + simp [kuhnBuild, hsupport] + | cons row rows ih => + have hrowUnmatched : RowUnmatched mate row := + hunmatched row (by simp) + obtain ⟨mateOne, haugment⟩ := + kuhnAugment_succeeds_of_hasPerfectMatching A row mate hsupport + hrowUnmatched hperfect + obtain ⟨hsupportOne, hrowsOne⟩ := + kuhnAugment_success A row mate mateOne hsupport hrowUnmatched haugment + have htailNodup : rows.Nodup := hnodup.tail + have hheadNotMem : row βˆ‰ rows := (List.nodup_cons.mp hnodup).1 + have htailUnmatched : βˆ€ r, r ∈ rows β†’ RowUnmatched mateOne r := by + intro r hr + rw [rowUnmatched_iff_not_matchesRow] + intro hmatched + rw [hrowsOne r] at hmatched + rcases hmatched with hmatched | heq + Β· exact (rowUnmatched_iff_not_matchesRow mate r).mp + (hunmatched r (by simp [hr])) hmatched + Β· subst r + exact hheadNotMem hr + obtain ⟨hfinalSupport, hfinalRows⟩ := + ih mateOne htailNodup hsupportOne htailUnmatched + have hget : + ((kuhnAugment A (n + 1) row βˆ… mate).mate?.getD mate) = mateOne := by + rw [haugment] + rfl + have hbuild : kuhnBuild A (row :: rows) mate = + kuhnBuild A rows mateOne := by + simp only [kuhnBuild] + rw [hget] + rw [hbuild] + refine ⟨hfinalSupport, ?_⟩ + intro r + rw [hfinalRows r, hrowsOne r] + simp only [List.mem_cons] + tauto + +/-- Support and injectivity are preserved even when some augmenting searches +fail. -/ +theorem kuhnBuild_support {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) + (hnodup : rows.Nodup) + (hsupport : IsSupportColumnMate A mate) + (hunmatched : βˆ€ r, r ∈ rows β†’ RowUnmatched mate r) : + IsSupportColumnMate A (kuhnBuild A rows mate) := by + induction rows generalizing mate with + | nil => simpa [kuhnBuild] using hsupport + | cons row rows ih => + have hrowUnmatched : RowUnmatched mate row := + hunmatched row (by simp) + cases hresult : (kuhnAugment A (n + 1) row βˆ… mate).mate? with + | none => + have htailUnmatched : βˆ€ r, r ∈ rows β†’ RowUnmatched mate r := by + intro r hr + exact hunmatched r (by simp [hr]) + simpa [kuhnBuild, hresult] using + ih mate hnodup.tail hsupport htailUnmatched + | some mateOne => + obtain ⟨hsupportOne, hrowsOne⟩ := + kuhnAugment_success A row mate mateOne hsupport hrowUnmatched hresult + have hheadNotMem : row βˆ‰ rows := (List.nodup_cons.mp hnodup).1 + have htailUnmatched : βˆ€ r, r ∈ rows β†’ RowUnmatched mateOne r := by + intro r hr + rw [rowUnmatched_iff_not_matchesRow] + intro hmatched + rw [hrowsOne r] at hmatched + rcases hmatched with hmatched | heq + Β· exact (rowUnmatched_iff_not_matchesRow mate r).mp + (hunmatched r (by simp [hr])) hmatched + Β· subst r + exact hheadNotMem hr + simpa [kuhnBuild, hresult] using + ih mateOne hnodup.tail hsupportOne htailUnmatched + +/-- The mate table produced by inserting all rows in order, starting from the empty matching. -/ +def kuhnColumnMate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : ColumnMate n := + kuhnBuild A (List.finRange n) (emptyColumnMate n) + +/-- Decide whether any column is matched to the given row. -/ +def matchedRowDecision {n : β„•} (mate : ColumnMate n) (row : Fin n) : Bool := + (List.finRange n).any fun col ↦ mate col == some row + +theorem matchedRowDecision_eq_true_iff {n : β„•} + (mate : ColumnMate n) (row : Fin n) : + matchedRowDecision mate row = true ↔ MatchesRow mate row := by + simp [matchedRowDecision, MatchesRow] + +/-- The executable support-perfect-matching decision. -/ +def kuhnSupportMatchingDecision {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : Bool := + (List.finRange n).all fun row ↦ matchedRowDecision (kuhnColumnMate A) row + +/-- Coordinate inspections in matching construction plus the final `n` by +`n` row-coverage check. -/ +def kuhnSupportMatchingWork {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : β„• := + kuhnBuildWork A (List.finRange n) (emptyColumnMate n) + n * n + +theorem kuhnSupportMatchingWork_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnSupportMatchingWork A ≀ + n * (n + (n + 1) * n) + n * n := by + exact Nat.add_le_add_right + (by simpa using kuhnBuildWork_le A (List.finRange n) (emptyColumnMate n)) _ + +theorem kuhnColumnMate_support {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + IsSupportColumnMate A (kuhnColumnMate A) := by + apply kuhnBuild_support A (List.finRange n) (emptyColumnMate n) + Β· exact List.nodup_finRange n + Β· exact emptyColumnMate_support n A + Β· intro row _ + exact rowUnmatched_emptyColumnMate n row + +theorem hasPerfectMatching_of_all_rows_matched {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hallRows : βˆ€ row, MatchesRow mate row) : + Matrix.HasPerfectMatching A := by + classical + let colOfRow : Fin n β†’ Fin n := fun row ↦ Classical.choose (hallRows row) + have colOfRow_spec (row : Fin n) : mate (colOfRow row) = some row := + Classical.choose_spec (hallRows row) + have colOfRow_injective : Function.Injective colOfRow := by + intro r s hrs + have hr := colOfRow_spec r + have hs := colOfRow_spec s + rw [hrs] at hr + rw [hr] at hs + exact Option.some.inj hs + have colOfRow_bijective : Function.Bijective colOfRow := + (Fintype.bijective_iff_injective_and_card colOfRow).2 + ⟨colOfRow_injective, rfl⟩ + let e : Fin n ≃ Fin n := Equiv.ofBijective colOfRow colOfRow_bijective + refine ⟨e.symm, ?_⟩ + intro col + have heq : colOfRow (e.symm col) = col := e.apply_symm_apply col + apply hsupport.support + calc + mate col = mate (colOfRow (e.symm col)) := congrArg mate heq.symm + _ = some (e.symm col) := colOfRow_spec (e.symm col) + +theorem kuhnColumnMate_all_rows_of_hasPerfectMatching {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) + (hperfect : Matrix.HasPerfectMatching A) : + βˆ€ row, MatchesRow (kuhnColumnMate A) row := by + obtain ⟨_, hrows⟩ := kuhnBuild_of_hasPerfectMatching A + (List.finRange n) (emptyColumnMate n) hperfect + (List.nodup_finRange n) (emptyColumnMate_support n A) + (fun row _ ↦ rowUnmatched_emptyColumnMate n row) + intro row + simpa [kuhnColumnMate] using + (hrows row).2 (Or.inr (List.mem_finRange row)) + +theorem kuhnSupportMatchingDecision_eq_true_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnSupportMatchingDecision A = true ↔ Matrix.HasPerfectMatching A := by + constructor + Β· intro hdecision + apply hasPerfectMatching_of_all_rows_matched A (kuhnColumnMate A) + (kuhnColumnMate_support A) + intro row + have hrow := (List.all_eq_true.mp hdecision) row (List.mem_finRange row) + exact (matchedRowDecision_eq_true_iff _ _).mp hrow + Β· intro hperfect + apply List.all_eq_true.mpr + intro row _ + exact (matchedRowDecision_eq_true_iff _ _).mpr + (kuhnColumnMate_all_rows_of_hasPerfectMatching A hperfect row) + +theorem kuhnSupportMatchingDecision_eq_false_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnSupportMatchingDecision A = false ↔ Β¬Matrix.HasPerfectMatching A := by + rw [← kuhnSupportMatchingDecision_eq_true_iff] + exact Bool.eq_false_iff + +theorem emptyColumnMate_apply (n : β„•) (j : Fin n) : + emptyColumnMate n j = none := rfl + +theorem kuhnAugment_zero {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) : + kuhnAugment A 0 row seen mate = ⟨none, seen⟩ := by + simp [kuhnAugment, kuhnSearch] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/KuhnSmallStep.lean b/LeanPool/BeyondBethe/BeyondBethe/KuhnSmallStep.lean new file mode 100644 index 0000000000..6c2e427c80 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/KuhnSmallStep.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.KuhnMatching +public import Mathlib.Tactic + +/-! +# A small-step evaluator for the Kuhn matching algorithm + +The recursive search in `KuhnMatching` is convenient for its mathematical +correctness proof. A Turing-machine implementation needs an explicit call +stack. This file gives that stack machine, proves that it returns exactly the +same result as `kuhnSearch`, and charges every transition to the already proved +coordinate-inspection counter. + +There is no encoding or complexity-class claim in this file. Its purpose is +to isolate the semantic compiler-correctness argument from the subsequent +finite-word implementation. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- The information needed after a recursive alternating-path search returns. +On success the saved edge is installed. On failure the parent row resumes at +its saved column suffix with its original mate table. -/ +structure KuhnSearchFrame (n : β„•) where + /-- The parent search fuel restored if the recursive search fails. -/ + fuel : β„• + /-- The remaining parent columns to scan after a failed recursive search. -/ + remaining : List (Fin n) + /-- The parent row whose saved edge is installed after a successful recursive search. -/ + row : Fin n + /-- The original parent mate table restored after a failed recursive search. -/ + mate : ColumnMate n + /-- The saved column matched to the parent row after a successful recursive search. -/ + column : Fin n + +/-- The outer frame remembers the rows not yet inserted and the mate table to +retain if the current root search fails. -/ +structure KuhnBuildFrame (n : β„•) where + /-- The rows still to insert after the current root search returns. -/ + rows : List (Fin n) + /-- The mate table retained if the current root search fails. -/ + fallback : ColumnMate n + +inductive KuhnFrame (n : β„•) + | search : KuhnSearchFrame n β†’ KuhnFrame n + | build : KuhnBuildFrame n β†’ KuhnFrame n + +/-- A call state, a returned search result, or the final mate table. -/ +inductive KuhnEvalState (n : β„•) + | call (fuel : β„•) (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) + (stack : List (KuhnFrame n)) + | ret (result : KuhnSearchResult n) (stack : List (KuhnFrame n)) + | done (mate : ColumnMate n) + +/-- One transition of the explicit-stack evaluator. -/ +def kuhnEvalStep {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + KuhnEvalState n β†’ KuhnEvalState n + | .done mate => .done mate + | .call 0 _remaining _row seen _mate stack => + .ret ⟨none, seen⟩ stack + | .call (_fuel + 1) [] _row seen _mate stack => + .ret ⟨none, seen⟩ stack + | .call (fuel + 1) (col :: remaining) row seen mate stack => + if col ∈ seen ∨ A row col = 0 then + .call (fuel + 1) remaining row seen mate stack + else + let seen' := insert col seen + match mate col with + | none => + .ret ⟨some (Function.update mate col (some row)), seen'⟩ stack + | some oldRow => + let frame : KuhnSearchFrame n := + ⟨fuel + 1, remaining, row, mate, col⟩ + .call fuel (List.finRange n) oldRow seen' + (Function.update mate col none) (.search frame :: stack) + | .ret result [] => .ret result [] + | .ret result (.search frame :: stack) => + match result.mate? with + | some mate' => + .ret + ⟨some (Function.update mate' frame.column (some frame.row)), + result.seen⟩ stack + | none => + .call frame.fuel frame.remaining frame.row result.seen + frame.mate stack + | .ret result (.build frame :: stack) => + let mate := result.mate?.getD frame.fallback + match frame.rows with + | [] => .done mate + | row :: rows => + .call (n + 1) (List.finRange n) row βˆ… mate + (.build ⟨rows, mate⟩ :: stack) + +/-- Exact number of small steps used to evaluate one recursive search call and +return its result without consuming the pre-existing continuation stack. -/ +def kuhnSearchSteps {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + (fuel : β„•) β†’ List (Fin n) β†’ Fin n β†’ Finset (Fin n) β†’ + ColumnMate n β†’ β„• + | 0, _remaining, _row, _seen, _mate => 1 + | _fuel + 1, [], _row, _seen, _mate => 1 + | fuel + 1, col :: remaining, row, seen, mate => + if col ∈ seen ∨ A row col = 0 then + 1 + kuhnSearchSteps A (fuel + 1) remaining row seen mate + else + let seen' := insert col seen + match mate col with + | none => 1 + | some oldRow => + let mateWithoutOld := Function.update mate col none + let recursive := + kuhnSearch A fuel (List.finRange n) oldRow seen' mateWithoutOld + let recursiveSteps := + kuhnSearchSteps A fuel (List.finRange n) oldRow seen' + mateWithoutOld + match recursive.mate? with + | some _ => 2 + recursiveSteps + | none => 2 + recursiveSteps + + kuhnSearchSteps A (fuel + 1) remaining row recursive.seen mate +termination_by fuel remaining _row _seen _mate => (fuel, remaining.length) + +/-- The stack evaluator is a semantics-preserving compilation of one +`kuhnSearch` call. -/ +theorem kuhnEvalStep_iterate_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) + (stack : List (KuhnFrame n)) : + (kuhnEvalStep A)^[kuhnSearchSteps A fuel remaining row seen mate] + (.call fuel remaining row seen mate stack) = + .ret (kuhnSearch A fuel remaining row seen mate) stack := by + fun_induction kuhnSearch generalizing stack with + | case1 => + simp [kuhnSearchSteps, Function.iterate_one, kuhnEvalStep.eq_def, + kuhnSearch] + | case2 => + simp [kuhnSearchSteps, Function.iterate_one, kuhnEvalStep.eq_def, + kuhnSearch] + | case3 fuel col remaining row seen mate hskip ih => + rw [kuhnSearchSteps] + simp only [hskip, ↓reduceIte] + rw [show 1 + kuhnSearchSteps A (fuel + 1) remaining row seen mate = + kuhnSearchSteps A (fuel + 1) remaining row seen mate + 1 by omega, + Function.iterate_succ_apply, kuhnEvalStep.eq_def] + simp only [hskip, ↓reduceIte] + simpa [kuhnSearch, hskip] using ih stack + | case4 fuel col remaining row seen mate hskip seen' hmate => + rw [kuhnSearchSteps] + simp only [hskip, ↓reduceIte, hmate] + simp [Function.iterate_one, kuhnEvalStep.eq_def, hskip, hmate, seen'] + | case5 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive mateRec hrec ih => + rw [kuhnSearchSteps] + simp only [hskip, ↓reduceIte, hmate] + rw [show recursive.mate? = some mateRec by exact hrec] + simp only + let frame : KuhnSearchFrame n := + ⟨fuel + 1, remaining, row, mate, col⟩ + let steps := kuhnSearchSteps A fuel (List.finRange n) oldRow seen' + mateWithoutOld + change (kuhnEvalStep A)^[2 + steps] + (.call (fuel + 1) (col :: remaining) row seen mate stack) = + .ret ⟨some (Function.update mateRec col (some row)), recursive.seen⟩ + stack + calc + (kuhnEvalStep A)^[2 + steps] + (.call (fuel + 1) (col :: remaining) row seen mate stack) = + kuhnEvalStep A + ((kuhnEvalStep A)^[steps] + (kuhnEvalStep A + (.call (fuel + 1) (col :: remaining) row seen mate stack))) := by + rw [show 2 + steps = 1 + steps + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one] + _ = kuhnEvalStep A + ((kuhnEvalStep A)^[steps] + (.call fuel (List.finRange n) oldRow seen' mateWithoutOld + (.search frame :: stack))) := by + simp [kuhnEvalStep.eq_def, hskip, hmate, seen', + mateWithoutOld, frame] + _ = kuhnEvalStep A (.ret recursive (.search frame :: stack)) := by + rw [show (kuhnEvalStep A)^[steps] + (.call fuel (List.finRange n) oldRow seen' mateWithoutOld + (.search frame :: stack)) = + .ret recursive (.search frame :: stack) by + simpa [steps, recursive] using + ih (.search frame :: stack)] + _ = .ret + ⟨some (Function.update mateRec col (some row)), recursive.seen⟩ + stack := by + simp [kuhnEvalStep.eq_def, frame, hrec] + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive hrec ihRec ihRec' ihContinue => + rw [kuhnSearchSteps] + simp only [hskip, ↓reduceIte, hmate] + rw [show recursive.mate? = none by exact hrec] + simp only + let frame : KuhnSearchFrame n := + ⟨fuel + 1, remaining, row, mate, col⟩ + let recursiveSteps := kuhnSearchSteps A fuel (List.finRange n) oldRow + seen' mateWithoutOld + let continueSteps := kuhnSearchSteps A (fuel + 1) remaining row + recursive.seen mate + change (kuhnEvalStep A)^[2 + recursiveSteps + continueSteps] + (.call (fuel + 1) (col :: remaining) row seen mate stack) = + .ret (kuhnSearch A (fuel + 1) remaining row recursive.seen mate) stack + calc + (kuhnEvalStep A)^[2 + recursiveSteps + continueSteps] + (.call (fuel + 1) (col :: remaining) row seen mate stack) = + (kuhnEvalStep A)^[continueSteps] + (kuhnEvalStep A + ((kuhnEvalStep A)^[recursiveSteps] + (kuhnEvalStep A + (.call (fuel + 1) (col :: remaining) row seen mate + stack)))) := by + rw [show 2 + recursiveSteps + continueSteps = + continueSteps + 1 + recursiveSteps + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_add_apply, Function.iterate_one] + _ = (kuhnEvalStep A)^[continueSteps] + (kuhnEvalStep A + ((kuhnEvalStep A)^[recursiveSteps] + (.call fuel (List.finRange n) oldRow seen' mateWithoutOld + (.search frame :: stack)))) := by + simp [kuhnEvalStep.eq_def, hskip, hmate, seen', + mateWithoutOld, frame] + _ = (kuhnEvalStep A)^[continueSteps] + (kuhnEvalStep A (.ret recursive (.search frame :: stack))) := by + rw [show (kuhnEvalStep A)^[recursiveSteps] + (.call fuel (List.finRange n) oldRow seen' mateWithoutOld + (.search frame :: stack)) = + .ret recursive (.search frame :: stack) by + simpa [recursiveSteps, recursive] using + ihRec' (.search frame :: stack)] + _ = (kuhnEvalStep A)^[continueSteps] + (.call (fuel + 1) remaining row recursive.seen mate stack) := by + simp [kuhnEvalStep.eq_def, frame, hrec] + _ = .ret (kuhnSearch A (fuel + 1) remaining row recursive.seen mate) + stack := by + simpa [continueSteps] using ihContinue stack + +/-- Each evaluator transition is charged to at most three coordinate +inspections, with one terminal transition left over. -/ +theorem kuhnSearchSteps_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) + (seen : Finset (Fin n)) (mate : ColumnMate n) : + kuhnSearchSteps A fuel remaining row seen mate ≀ + 3 * kuhnSearchWork A fuel remaining row seen mate + 1 := by + fun_induction kuhnSearchSteps with + | case1 => simp [kuhnSearchWork] + | case2 => simp [kuhnSearchWork] + | case3 fuel col remaining row seen mate hskip ih => + simp only [kuhnSearchWork, hskip, ↓reduceIte] + omega + | case4 fuel col remaining row seen mate hskip hmate => + simp [kuhnSearchWork, hskip, hmate] + | case5 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive recursiveSteps mateRec hrec ih => + simp only [kuhnSearchWork, hskip, ↓reduceIte, hmate] + rw [show recursive.mate? = some mateRec by exact hrec] + change 2 + recursiveSteps ≀ + 3 * (1 + kuhnSearchWork A fuel (List.finRange n) oldRow seen' + mateWithoutOld) + 1 + omega + | case6 fuel col remaining row seen mate hskip seen' oldRow hmate + mateWithoutOld recursive recursiveSteps hrec ihRec ihContinue => + simp only [kuhnSearchWork, hskip, ↓reduceIte, hmate] + rw [show recursive.mate? = none by exact hrec] + change 2 + recursiveSteps + + kuhnSearchSteps A (fuel + 1) remaining row recursive.seen mate ≀ + 3 * (1 + kuhnSearchWork A fuel (List.finRange n) oldRow seen' + mateWithoutOld + + kuhnSearchWork A (fuel + 1) remaining row recursive.seen mate) + 1 + omega + +/-- Start (or finish) the explicit evaluator on a remaining row list. -/ +def kuhnBuildEvalState {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (rows : List (Fin n)) (mate : ColumnMate n) : KuhnEvalState n := + match rows with + | [] => .done mate + | row :: rows => + .call (n + 1) (List.finRange n) row βˆ… mate + [.build ⟨rows, mate⟩] + +/-- Exact number of transitions used by the explicit evaluator for the row +building phase. -/ +def kuhnBuildSteps {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + List (Fin n) β†’ ColumnMate n β†’ β„• + | [], _mate => 0 + | row :: rows, mate => + let result := kuhnAugment A (n + 1) row βˆ… mate + kuhnSearchSteps A (n + 1) (List.finRange n) row βˆ… mate + 1 + + kuhnBuildSteps A rows (result.mate?.getD mate) + +@[simp] theorem kuhnEvalStep_return_build {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (fallback : ColumnMate n) (result : KuhnSearchResult n) : + kuhnEvalStep A + (.ret result [.build ⟨rows, fallback⟩]) = + kuhnBuildEvalState A rows (result.mate?.getD fallback) := by + cases rows <;> rfl + +/-- The complete small-step evaluator returns exactly `kuhnBuild`. -/ +theorem kuhnBuildEvalState_iterate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) : + (kuhnEvalStep A)^[kuhnBuildSteps A rows mate] + (kuhnBuildEvalState A rows mate) = + .done (kuhnBuild A rows mate) := by + induction rows generalizing mate with + | nil => simp [kuhnBuildSteps, kuhnBuildEvalState, kuhnBuild] + | cons row rows ih => + let result := kuhnAugment A (n + 1) row βˆ… mate + let oneSteps := + kuhnSearchSteps A (n + 1) (List.finRange n) row βˆ… mate + let nextMate := result.mate?.getD mate + rw [kuhnBuildSteps] + change (kuhnEvalStep A)^[oneSteps + 1 + kuhnBuildSteps A rows nextMate] + (KuhnEvalState.call (n + 1) (List.finRange n) row βˆ… mate + [.build ⟨rows, mate⟩]) = _ + rw [show oneSteps + 1 + kuhnBuildSteps A rows nextMate = + kuhnBuildSteps A rows nextMate + 1 + oneSteps by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one] + rw [kuhnEvalStep_iterate_call] + change (kuhnEvalStep A)^[kuhnBuildSteps A rows nextMate] + (kuhnEvalStep A (.ret result [.build ⟨rows, mate⟩])) = _ + rw [kuhnEvalStep_return_build, ih] + simp [kuhnBuild, result, nextMate] + +/-- The whole build uses a cubic number of explicit-stack transitions. -/ +theorem kuhnBuildSteps_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) : + kuhnBuildSteps A rows mate ≀ + 3 * kuhnBuildWork A rows mate + 2 * rows.length := by + induction rows generalizing mate with + | nil => simp [kuhnBuildSteps, kuhnBuildWork] + | cons row rows ih => + let result := kuhnAugment A (n + 1) row βˆ… mate + have hone := kuhnSearchSteps_le A (n + 1) (List.finRange n) + row βˆ… mate + have htail := ih (result.mate?.getD mate) + change kuhnSearchSteps A (n + 1) (List.finRange n) row βˆ… mate + 1 + + kuhnBuildSteps A rows (result.mate?.getD mate) ≀ + 3 * (kuhnSearchWork A (n + 1) (List.finRange n) row βˆ… mate + + kuhnBuildWork A rows (result.mate?.getD mate)) + + 2 * (rows.length + 1) + omega + +/-- Starting from the empty mate table and all rows, the evaluator returns the +same column mate used by the proved support-matching decision. -/ +theorem kuhnFullBuildEvalState_iterate {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (kuhnEvalStep A)^[kuhnBuildSteps A (List.finRange n) + (emptyColumnMate n)] + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) = + .done (kuhnColumnMate A) := by + simpa [kuhnColumnMate] using + kuhnBuildEvalState_iterate A (List.finRange n) (emptyColumnMate n) + +theorem kuhnFullBuildSteps_le {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnBuildSteps A (List.finRange n) (emptyColumnMate n) ≀ + 3 * (n * (n + (n + 1) * n)) + 2 * n := by + calc + kuhnBuildSteps A (List.finRange n) (emptyColumnMate n) ≀ + 3 * kuhnBuildWork A (List.finRange n) (emptyColumnMate n) + + 2 * (List.finRange n).length := + kuhnBuildSteps_le A _ _ + _ ≀ 3 * (n * (n + (n + 1) * n)) + 2 * n := by + simp only [List.length_finRange] + have hwork := kuhnBuildWork_le A (List.finRange n) + (emptyColumnMate n) + simp only [List.length_finRange] at hwork + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineEntry.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineEntry.lean new file mode 100644 index 0000000000..412ad2be1e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineEntry.lean @@ -0,0 +1,557 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineLineSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowPairDisjoint +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary + +/-! +# Exact finite-word entries of the Birkhoff affine recovery + +From a flattened `m`-by-`m` rational block, the recovered matrix of order +`m+1` has four kinds of entries: a stored upper-left coordinate, one minus a +row sum, one minus a column sum, and the total sum minus `m-1`. This file +assembles those four cases as one uniform polynomial-time word machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the unary dimension ruler from an affine-entry input word. -/ +def machineBetheAffineEntryDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the row, column, and vector payload following the affine-entry dimension. -/ +def machineBetheAffineEntryRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary row index from an affine-entry input word. -/ +def machineBetheAffineEntryRow (word : List Bool) : List Bool := + machinePairFirst (machineBetheAffineEntryRest word) + +/-- Extract the unary column index from an affine-entry input word. -/ +def machineBetheAffineEntryColumn (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineBetheAffineEntryRest word)) + +/-- Extract the encoded affine-coordinate vector from an affine-entry input word. -/ +def machineBetheAffineEntryVector (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machineBetheAffineEntryRest word)) + +/-- Compare the row ruler with the dimension ruler to detect the last matrix row. -/ +def machineBetheAffineEntryLastRowBit (word : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineBetheAffineEntryRow word) + (machineBetheAffineEntryDimension word) + +/-- Compare the column ruler with the dimension ruler to detect the last matrix column. -/ +def machineBetheAffineEntryLastColumnBit (word : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineBetheAffineEntryColumn word) + (machineBetheAffineEntryDimension word) + +/-- Package the affine-entry data as a row-mode flattened-entry request. -/ +def machineBetheAffineEntryFlatInput (word : List Bool) : List Bool := + pair [true] + (pair (machineBetheAffineEntryDimension word) + (pair (machineBetheAffineEntryRow word) + (pair (machineBetheAffineEntryColumn word) + (machineBetheAffineEntryVector word)))) + +/-- Evaluate an entry in the upper-left free block of the affine matrix. -/ +def machineBetheAffineEntryUpperLeft (word : List Bool) : List Bool := + machineBetheFlatEntryRawCode (machineBetheAffineEntryFlatInput word) + +/-- Package a row-sum request for the free affine-coordinate block. -/ +def machineBetheAffineEntryRowSumInput (word : List Bool) : List Bool := + pair [true] + (pair (machineBetheAffineEntryDimension word) + (pair (machineBetheAffineEntryRow word) + (machineBetheAffineEntryVector word))) + +/-- Package a column-sum request for the free affine-coordinate block. -/ +def machineBetheAffineEntryColumnSumInput (word : List Bool) : List Bool := + pair [false] + (pair (machineBetheAffineEntryDimension word) + (pair (machineBetheAffineEntryColumn word) + (machineBetheAffineEntryVector word))) + +/-- Compute the encoded raw-rational sum of the selected free-block row. -/ +def machineBetheAffineEntryRowSum (word : List Bool) : List Bool := + machineBetheLineSumRawCode (machineBetheAffineEntryRowSumInput word) + +/-- Compute the encoded raw-rational sum of the selected free-block column. -/ +def machineBetheAffineEntryColumnSum (word : List Bool) : List Bool := + machineBetheLineSumRawCode (machineBetheAffineEntryColumnSumInput word) + +/-- Subtract the second encoded raw rational from the first by negation and addition. -/ +def machineRawRatSubCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machinePairFirst word) + (machineRawRatNegCode (machinePairSecond word))) + +/-- Compute a last-column entry as one minus the corresponding free-block row sum. -/ +def machineBetheAffineEntryLastColumn (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (rawRatBinaryCode RawRat.one) + (machineBetheAffineEntryRowSum word)) + +/-- Compute a last-row entry as one minus the corresponding free-block column sum. -/ +def machineBetheAffineEntryLastRow (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (rawRatBinaryCode RawRat.one) + (machineBetheAffineEntryColumnSum word)) + +/-- Compute the encoded raw-rational sum of all free affine coordinates. -/ +def machineBetheAffineEntryTotal (word : List Bool) : List Bool := + machineRationalVectorRawSumCode (machineBetheAffineEntryVector word) + +/-- Convert the unary affine dimension ruler to its binary length. -/ +def machineBetheAffineEntryDimensionBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheAffineEntryDimension word) + +/-- Encode the affine dimension minus one as a signed integer. -/ +def machineBetheAffineEntryDimensionMinusOneInteger + (word : List Bool) : List Bool := + machineIntegerAddCode + (pair (machineNaturalIntegerCode + (machineBetheAffineEntryDimensionBits word)) + (integerBinaryCode (-1))) + +/-- Encode the affine dimension minus one as a raw rational with denominator one. -/ +def machineBetheAffineEntryDimensionMinusOneRaw + (word : List Bool) : List Bool := + pair (machineBetheAffineEntryDimensionMinusOneInteger word) + (1 : β„•).bits + +/-- Compute the corner entry as the total free-coordinate sum minus `(m-1)`. -/ +def machineBetheAffineEntryCorner (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (machineBetheAffineEntryTotal word) + (machineBetheAffineEntryDimensionMinusOneRaw word)) + +/-- Select the free-block, last-row, last-column, or corner formula for an affine matrix entry. -/ +def machineBetheAffineEntryRawCode (word : List Bool) : List Bool := + machineIfHead (machineBetheAffineEntryLastRowBit word) + (machineIfHead (machineBetheAffineEntryLastColumnBit word) + (machineBetheAffineEntryCorner word) + (machineBetheAffineEntryLastRow word)) + (machineIfHead (machineBetheAffineEntryLastColumnBit word) + (machineBetheAffineEntryLastColumn word) + (machineBetheAffineEntryUpperLeft word)) + +theorem machineBetheAffineEntryDimension_mem_FP : + machineBetheAffineEntryDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheAffineEntryRest_mem_FP : + machineBetheAffineEntryRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheAffineEntryRow_mem_FP : + machineBetheAffineEntryRow ∈ FP := by + simpa only [machineBetheAffineEntryRow] using! + machineCompose_mem_FP machineBetheAffineEntryRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheAffineEntryColumn_mem_FP : + machineBetheAffineEntryColumn ∈ FP := by + have htail := machineCompose_mem_FP machineBetheAffineEntryRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheAffineEntryColumn] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheAffineEntryVector_mem_FP : + machineBetheAffineEntryVector ∈ FP := by + have htail := machineCompose_mem_FP machineBetheAffineEntryRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheAffineEntryVector] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineBetheAffineEntryLastRowBit_mem_FP : + machineBetheAffineEntryLastRowBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + machineBetheAffineEntryRow_mem_FP machineBetheAffineEntryDimension_mem_FP + +theorem machineBetheAffineEntryLastColumnBit_mem_FP : + machineBetheAffineEntryLastColumnBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + machineBetheAffineEntryColumn_mem_FP + machineBetheAffineEntryDimension_mem_FP + +theorem machineBetheAffineEntryFlatInput_mem_FP : + machineBetheAffineEntryFlatInput ∈ FP := by + exact machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineBetheAffineEntryDimension_mem_FP + (machinePair_mem_FP machineBetheAffineEntryRow_mem_FP + (machinePair_mem_FP machineBetheAffineEntryColumn_mem_FP + machineBetheAffineEntryVector_mem_FP))) + +theorem machineBetheAffineEntryUpperLeft_mem_FP : + machineBetheAffineEntryUpperLeft ∈ FP := by + simpa only [machineBetheAffineEntryUpperLeft] using! + machineCompose_mem_FP machineBetheAffineEntryFlatInput_mem_FP + machineBetheFlatEntryRawCode_mem_FP + +theorem machineBetheAffineEntryRowSumInput_mem_FP : + machineBetheAffineEntryRowSumInput ∈ FP := by + exact machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineBetheAffineEntryDimension_mem_FP + (machinePair_mem_FP machineBetheAffineEntryRow_mem_FP + machineBetheAffineEntryVector_mem_FP)) + +theorem machineBetheAffineEntryColumnSumInput_mem_FP : + machineBetheAffineEntryColumnSumInput ∈ FP := by + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP machineBetheAffineEntryDimension_mem_FP + (machinePair_mem_FP machineBetheAffineEntryColumn_mem_FP + machineBetheAffineEntryVector_mem_FP)) + +theorem machineBetheAffineEntryRowSum_mem_FP : + machineBetheAffineEntryRowSum ∈ FP := by + simpa only [machineBetheAffineEntryRowSum] using! + machineCompose_mem_FP machineBetheAffineEntryRowSumInput_mem_FP + machineBetheLineSumRawCode_mem_FP + +theorem machineBetheAffineEntryColumnSum_mem_FP : + machineBetheAffineEntryColumnSum ∈ FP := by + simpa only [machineBetheAffineEntryColumnSum] using! + machineCompose_mem_FP machineBetheAffineEntryColumnSumInput_mem_FP + machineBetheLineSumRawCode_mem_FP + +theorem machineRawRatSubCode_mem_FP : machineRawRatSubCode ∈ FP := by + have hneg := machineCompose_mem_FP machinePairSecond_mem_FP + machineRawRatNegCode_mem_FP + have hinput := machinePair_mem_FP machinePairFirst_mem_FP hneg + simpa only [machineRawRatSubCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineBetheAffineEntryLastColumn_mem_FP : + machineBetheAffineEntryLastColumn ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineBetheAffineEntryRowSum_mem_FP + simpa only [machineBetheAffineEntryLastColumn] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineBetheAffineEntryLastRow_mem_FP : + machineBetheAffineEntryLastRow ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineBetheAffineEntryColumnSum_mem_FP + simpa only [machineBetheAffineEntryLastRow] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineBetheAffineEntryTotal_mem_FP : + machineBetheAffineEntryTotal ∈ FP := by + simpa only [machineBetheAffineEntryTotal] using! + machineCompose_mem_FP machineBetheAffineEntryVector_mem_FP + machineRationalVectorRawSumCode_mem_FP + +theorem machineBetheAffineEntryDimensionBits_mem_FP : + machineBetheAffineEntryDimensionBits ∈ FP := by + simpa only [machineBetheAffineEntryDimensionBits] using! + machineCompose_mem_FP machineBetheAffineEntryDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheAffineEntryDimensionMinusOneInteger_mem_FP : + machineBetheAffineEntryDimensionMinusOneInteger ∈ FP := by + have hnat := machineCompose_mem_FP + machineBetheAffineEntryDimensionBits_mem_FP + machineNaturalIntegerCode_mem_FP + have hinput := machinePair_mem_FP hnat + (machineConst_mem_FP (integerBinaryCode (-1))) + simpa only [machineBetheAffineEntryDimensionMinusOneInteger] using! + machineCompose_mem_FP hinput machineIntegerAddCode_mem_FP + +theorem machineBetheAffineEntryDimensionMinusOneRaw_mem_FP : + machineBetheAffineEntryDimensionMinusOneRaw ∈ FP := by + exact machinePair_mem_FP + machineBetheAffineEntryDimensionMinusOneInteger_mem_FP + (machineConst_mem_FP (1 : β„•).bits) + +theorem machineBetheAffineEntryCorner_mem_FP : + machineBetheAffineEntryCorner ∈ FP := by + have hinput := machinePair_mem_FP machineBetheAffineEntryTotal_mem_FP + machineBetheAffineEntryDimensionMinusOneRaw_mem_FP + simpa only [machineBetheAffineEntryCorner] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineBetheAffineEntryRawCode_mem_FP : + machineBetheAffineEntryRawCode ∈ FP := by + have hlastRow := machineIfHead_mem_FP + machineBetheAffineEntryLastColumnBit_mem_FP + machineBetheAffineEntryCorner_mem_FP + machineBetheAffineEntryLastRow_mem_FP + have hnotLastRow := machineIfHead_mem_FP + machineBetheAffineEntryLastColumnBit_mem_FP + machineBetheAffineEntryLastColumn_mem_FP + machineBetheAffineEntryUpperLeft_mem_FP + exact machineIfHead_mem_FP machineBetheAffineEntryLastRowBit_mem_FP + hlastRow hnotLastRow + +/-! ## Exact semantics -/ + +/-- The canonical affine-entry input word containing unary dimension and indices and the encoded +rational vector. -/ +def machineBetheAffineEntryCanonicalWord {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : List Bool := + pair (List.replicate m true) + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) (rationalFiniteVectorCode y))) + +/-- The raw rational representing the integer `m-1`. -/ +def rawBetheDimensionMinusOne (m : β„•) : RawRat := + ⟨(m : β„€) - 1, 1, by norm_num⟩ + +/-- The raw-rational affine matrix entry, completing the border from row sums, column sums, and +the total free-coordinate sum. -/ +def rawBetheAffineEntry {m : β„•} (y : Fin (m * m) β†’ β„š) + (i j : Fin (m + 1)) : RawRat := + Fin.lastCases + (Fin.lastCases + ((rawRatListSum RawRat.zero (List.ofFn y)).sub + (rawBetheDimensionMinusOne m)) + (fun j ↦ RawRat.one.sub (rawBetheAffineLineSum false j y)) j) + (fun i ↦ Fin.lastCases + (RawRat.one.sub (rawBetheAffineLineSum true i y)) + (fun j ↦ rawRatOfRat (y (finProdFinEquiv (i, j)))) j) i + +@[simp] theorem machineUnaryRulersEqualBit_replicate (a b : β„•) : + machineUnaryRulersEqualBit (List.replicate a true) + (List.replicate b true) = [decide (a = b)] := by + rw [machineUnaryRulersEqualBit] + simp only [machineLengthBits_encode, List.length_replicate, + machineBinaryNatEqBit_pair_natBits] + +@[simp] theorem rawBetheDimensionMinusOne_value (m : β„•) : + (rawBetheDimensionMinusOne m).value = (m : β„š) - 1 := by + simp [rawBetheDimensionMinusOne, RawRat.value] + +@[simp] theorem machineBetheAffineEntryLastRowBit_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryLastRowBit + (machineBetheAffineEntryCanonicalWord i j y) = + [decide (i = Fin.last m)] := by + rw [machineBetheAffineEntryLastRowBit] + simp only [machineBetheAffineEntryRow, machineBetheAffineEntryDimension, + machineBetheAffineEntryRest, machineBetheAffineEntryCanonicalWord, + machinePairFirst_pair, machinePairSecond_pair, + machineUnaryRulersEqualBit_replicate] + by_cases hi : i = Fin.last m + Β· subst i + simp + Β· have hval : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + simp [hi, hval] + +@[simp] theorem machineBetheAffineEntryLastColumnBit_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryLastColumnBit + (machineBetheAffineEntryCanonicalWord i j y) = + [decide (j = Fin.last m)] := by + rw [machineBetheAffineEntryLastColumnBit] + simp only [machineBetheAffineEntryColumn, + machineBetheAffineEntryDimension, + machineBetheAffineEntryRest, machineBetheAffineEntryCanonicalWord, + machinePairFirst_pair, machinePairSecond_pair, + machineUnaryRulersEqualBit_replicate] + by_cases hj : j = Fin.last m + Β· subst j + simp + Β· have hval : j.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + simp [hj, hval] + +@[simp] theorem machineRawRatSubCode_encode (q r : RawRat) : + machineRawRatSubCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rawRatBinaryCode (q.sub r) := by + rw [machineRawRatSubCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineRawRatNegCode_encode, machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineBetheAffineEntryDimensionMinusOneRaw_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryDimensionMinusOneRaw + (machineBetheAffineEntryCanonicalWord i j y) = + rawRatBinaryCode (rawBetheDimensionMinusOne m) := by + rw [machineBetheAffineEntryDimensionMinusOneRaw, + machineBetheAffineEntryDimensionMinusOneInteger, + machineBetheAffineEntryDimensionBits, + machineBetheAffineEntryDimension, + machineBetheAffineEntryCanonicalWord] + simp only [machinePairFirst_pair, machineLengthBits_encode, + List.length_replicate, machineNaturalIntegerCode_natBits, + machineIntegerAddCode_encode] + rfl + +@[simp] theorem machineBetheAffineEntryDimension_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryDimension + (machineBetheAffineEntryCanonicalWord i j y) = + List.replicate m true := by + simp [machineBetheAffineEntryDimension, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineBetheAffineEntryRow_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryRow + (machineBetheAffineEntryCanonicalWord i j y) = + List.replicate i.1 true := by + simp [machineBetheAffineEntryRow, machineBetheAffineEntryRest, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineBetheAffineEntryColumn_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryColumn + (machineBetheAffineEntryCanonicalWord i j y) = + List.replicate j.1 true := by + simp [machineBetheAffineEntryColumn, machineBetheAffineEntryRest, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineBetheAffineEntryVector_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryVector + (machineBetheAffineEntryCanonicalWord i j y) = + rationalFiniteVectorCode y := by + simp [machineBetheAffineEntryVector, machineBetheAffineEntryRest, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineBetheAffineEntryFlatInput_encode {m : β„•} + (i j : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryFlatInput + (machineBetheAffineEntryCanonicalWord i.castSucc j.castSucc y) = + betheFlatIndexCanonicalWord true i j y := by + simp [machineBetheAffineEntryFlatInput, betheFlatIndexCanonicalWord] + +@[simp] theorem machineBetheAffineEntryRowSumInput_encode {m : β„•} + (i : Fin m) (j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryRowSumInput + (machineBetheAffineEntryCanonicalWord i.castSucc j y) = + machineBetheLineSumCanonicalWord true i y := by + simp [machineBetheAffineEntryRowSumInput, + machineBetheLineSumCanonicalWord] + +@[simp] theorem machineBetheAffineEntryColumnSumInput_encode {m : β„•} + (i : Fin (m + 1)) (j : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryColumnSumInput + (machineBetheAffineEntryCanonicalWord i j.castSucc y) = + machineBetheLineSumCanonicalWord false j y := by + simp [machineBetheAffineEntryColumnSumInput, + machineBetheLineSumCanonicalWord] + +@[simp] theorem machineBetheAffineEntryTotal_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryTotal + (machineBetheAffineEntryCanonicalWord i j y) = + rawRatBinaryCode (rawRatListSum RawRat.zero (List.ofFn y)) := by + rw [machineBetheAffineEntryTotal, + machineBetheAffineEntryVector_encode] + simpa only [rationalFiniteVectorCode, rationalVectorBinaryCode] using! + machineRationalVectorRawSumCode_encode y + +@[simp] theorem machineBetheAffineEntryCorner_encode {m : β„•} + (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryCorner + (machineBetheAffineEntryCanonicalWord + (Fin.last m) (Fin.last m) y) = + rawRatBinaryCode + ((rawRatListSum RawRat.zero (List.ofFn y)).sub + (rawBetheDimensionMinusOne m)) := by + rw [machineBetheAffineEntryCorner] + rw [machineBetheAffineEntryTotal_encode, + machineBetheAffineEntryDimensionMinusOneRaw_encode, + machineRawRatSubCode_encode] + +@[simp] theorem machineBetheAffineEntryLastRow_encode {m : β„•} + (j : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryLastRow + (machineBetheAffineEntryCanonicalWord + (Fin.last m) j.castSucc y) = + rawRatBinaryCode + (RawRat.one.sub (rawBetheAffineLineSum false j y)) := by + rw [machineBetheAffineEntryLastRow] + rw [machineBetheAffineEntryColumnSum, + machineBetheAffineEntryColumnSumInput_encode, + machineBetheLineSumRawCode_encode, + machineRawRatSubCode_encode] + +@[simp] theorem machineBetheAffineEntryLastColumn_encode {m : β„•} + (i : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryLastColumn + (machineBetheAffineEntryCanonicalWord + i.castSucc (Fin.last m) y) = + rawRatBinaryCode + (RawRat.one.sub (rawBetheAffineLineSum true i y)) := by + rw [machineBetheAffineEntryLastColumn] + rw [machineBetheAffineEntryRowSum, + machineBetheAffineEntryRowSumInput_encode, + machineBetheLineSumRawCode_encode, + machineRawRatSubCode_encode] + +@[simp] theorem machineBetheAffineEntryUpperLeft_encode {m : β„•} + (i j : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryUpperLeft + (machineBetheAffineEntryCanonicalWord i.castSucc j.castSucc y) = + rawRatBinaryCode (rawRatOfRat (y (finProdFinEquiv (i, j)))) := by + rw [machineBetheAffineEntryUpperLeft] + rw [machineBetheAffineEntryFlatInput_encode, + machineBetheFlatEntryRawCode_encode] + simp + +@[simp] theorem machineBetheAffineEntryRawCode_encode {m : β„•} + (i j : Fin (m + 1)) (y : Fin (m * m) β†’ β„š) : + machineBetheAffineEntryRawCode + (machineBetheAffineEntryCanonicalWord i j y) = + rawRatBinaryCode (rawBetheAffineEntry y i j) := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp [machineBetheAffineEntryRawCode, rawBetheAffineEntry] + Β· have hj : j.castSucc β‰  Fin.last m := Fin.castSucc_ne_last j + simp [machineBetheAffineEntryRawCode, rawBetheAffineEntry, hj] + Β· have hi : i.castSucc β‰  Fin.last m := Fin.castSucc_ne_last i + simp [machineBetheAffineEntryRawCode, rawBetheAffineEntry, hi] + Β· have hi : i.castSucc β‰  Fin.last m := Fin.castSucc_ne_last i + have hj : j.castSucc β‰  Fin.last m := Fin.castSucc_ne_last j + simp [machineBetheAffineEntryRawCode, rawBetheAffineEntry, hi, hj] + +theorem rawBetheAffineEntry_value {m : β„•} (y : Fin (m * m) β†’ β„š) + (i j : Fin (m + 1)) : + (rawBetheAffineEntry y i j).value = betheAffineMatrixQ y i j := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last] + rw [betheAffineMatrixQ, + birkhoffAffineMap_last_last, RawRat.value_sub, + rawBetheDimensionMinusOne_value] + have hsum := sum_squareMatrixToVector (vectorToSquareMatrix y) + simp only [squareMatrixToVector_vectorToSquareMatrix] at hsum + rw [rawRatListSum_ofFn_value, hsum] + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last, + Fin.lastCases_castSucc] + rw [betheAffineMatrixQ, + birkhoffAffineMap_last_castSucc, RawRat.value_sub, + RawRat.value_one, rawBetheAffineLineSum_value] + simp [vectorToSquareMatrix] + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last, + Fin.lastCases_castSucc] + rw [betheAffineMatrixQ, + birkhoffAffineMap_castSucc_last, RawRat.value_sub, + RawRat.value_one, rawBetheAffineLineSum_value] + simp [vectorToSquareMatrix] + Β· simp [rawBetheAffineEntry, Fin.lastCases_castSucc, + betheAffineMatrixQ, + vectorToSquareMatrix, rawRatOfRat_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineLineSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineLineSum.lean new file mode 100644 index 0000000000..9d59fb1d77 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheAffineLineSum.lean @@ -0,0 +1,1067 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraph +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalTransposeMulVector + +/-! +# Finite-word row and column sums for Birkhoff affine coordinates + +The Bethe epigraph stores only the upper-left `m`-by-`m` affine block as a +flat rational vector. This file supplies the first reusable machine needed +by the separation oracle: exact row and column sums of that block. A Boolean +tag selects a row (`true`) or a column (`false`). Every index manipulated by +the machine is unary and is obtained from verified binary multiplication and +addition under the complete input word as a guard. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## A verified flattened-coordinate lookup -/ + +/-- Extract the row-versus-column mode word from a flattened-index request. -/ +def machineBetheFlatIndexMode (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the payload following the flattened-index mode word. -/ +def machineBetheFlatIndexRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary dimension ruler from a flattened-index request. -/ +def machineBetheFlatIndexDimension (word : List Bool) : List Bool := + machinePairFirst (machineBetheFlatIndexRest word) + +/-- Extract the unary fixed row or column index from a flattened-index request. -/ +def machineBetheFlatIndexFixed (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineBetheFlatIndexRest word)) + +/-- Extract the unary varying index from a flattened-index request. -/ +def machineBetheFlatIndexCurrent (word : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machineBetheFlatIndexRest word))) + +/-- Extract the encoded rational vector carried by a flattened-index request. -/ +def machineBetheFlatIndexVector (word : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machineBetheFlatIndexRest word))) + +/-- Convert the flattened-index dimension ruler to binary. -/ +def machineBetheFlatIndexDimensionBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheFlatIndexDimension word) + +/-- Convert the fixed-index ruler to binary. -/ +def machineBetheFlatIndexFixedBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheFlatIndexFixed word) + +/-- Convert the varying-index ruler to binary. -/ +def machineBetheFlatIndexCurrentBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheFlatIndexCurrent word) + +/-- Compute the binary row-mode offset `fixed * dimension + current`. -/ +def machineBetheFlatIndexRowBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair + (machineBinaryMulBits + (pair (machineBetheFlatIndexFixedBits word) + (machineBetheFlatIndexDimensionBits word))) + (machineBetheFlatIndexCurrentBits word)) + +/-- Compute the binary column-mode offset `current * dimension + fixed`. -/ +def machineBetheFlatIndexColumnBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair + (machineBinaryMulBits + (pair (machineBetheFlatIndexCurrentBits word) + (machineBetheFlatIndexDimensionBits word))) + (machineBetheFlatIndexFixedBits word)) + +/-- Select the binary flattened offset according to the row-versus-column mode. -/ +def machineBetheFlatIndexBits (word : List Bool) : List Bool := + machineIfHead (machineBetheFlatIndexMode word) + (machineBetheFlatIndexRowBits word) + (machineBetheFlatIndexColumnBits word) + +/-- Convert the flattened binary index to a unary ruler bounded by the input word. -/ +def machineBetheFlatIndexRuler (word : List Bool) : List Bool := + machineBoundedUnary (pair word (machineBetheFlatIndexBits word)) + +/-- Return the selected canonical rational entry. Canonical rational-entry +codes and `RawRat` codes coincide, so the result may be fed directly to the +unreduced rational arithmetic machines. -/ +def machineBetheFlatEntryRawCode (word : List Bool) : List Bool := + machineListIndex + (pair (machineBetheFlatIndexRuler word) + (machineBetheFlatIndexVector word)) + +theorem machineBetheFlatIndexMode_mem_FP : + machineBetheFlatIndexMode ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFlatIndexRest_mem_FP : + machineBetheFlatIndexRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFlatIndexDimension_mem_FP : + machineBetheFlatIndexDimension ∈ FP := by + simpa only [machineBetheFlatIndexDimension] using! + machineCompose_mem_FP machineBetheFlatIndexRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFlatIndexFixed_mem_FP : + machineBetheFlatIndexFixed ∈ FP := by + have htail := machineCompose_mem_FP machineBetheFlatIndexRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheFlatIndexFixed] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheFlatIndexCurrent_mem_FP : + machineBetheFlatIndexCurrent ∈ FP := by + have htail₁ := machineCompose_mem_FP machineBetheFlatIndexRest_mem_FP + machinePairSecond_mem_FP + have htailβ‚‚ := machineCompose_mem_FP htail₁ machinePairSecond_mem_FP + simpa only [machineBetheFlatIndexCurrent] using! + machineCompose_mem_FP htailβ‚‚ machinePairFirst_mem_FP + +theorem machineBetheFlatIndexVector_mem_FP : + machineBetheFlatIndexVector ∈ FP := by + have htail₁ := machineCompose_mem_FP machineBetheFlatIndexRest_mem_FP + machinePairSecond_mem_FP + have htailβ‚‚ := machineCompose_mem_FP htail₁ machinePairSecond_mem_FP + simpa only [machineBetheFlatIndexVector] using! + machineCompose_mem_FP htailβ‚‚ machinePairSecond_mem_FP + +theorem machineBetheFlatIndexDimensionBits_mem_FP : + machineBetheFlatIndexDimensionBits ∈ FP := by + simpa only [machineBetheFlatIndexDimensionBits] using! + machineCompose_mem_FP machineBetheFlatIndexDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheFlatIndexFixedBits_mem_FP : + machineBetheFlatIndexFixedBits ∈ FP := by + simpa only [machineBetheFlatIndexFixedBits] using! + machineCompose_mem_FP machineBetheFlatIndexFixed_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheFlatIndexCurrentBits_mem_FP : + machineBetheFlatIndexCurrentBits ∈ FP := by + simpa only [machineBetheFlatIndexCurrentBits] using! + machineCompose_mem_FP machineBetheFlatIndexCurrent_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheFlatIndexRowBits_mem_FP : + machineBetheFlatIndexRowBits ∈ FP := by + have hmulInput := machinePair_mem_FP + machineBetheFlatIndexFixedBits_mem_FP + machineBetheFlatIndexDimensionBits_mem_FP + have hmul := machineCompose_mem_FP hmulInput + machineBinaryMulBits_mem_FP + have haddInput := machinePair_mem_FP hmul + machineBetheFlatIndexCurrentBits_mem_FP + simpa only [machineBetheFlatIndexRowBits] using! + machineCompose_mem_FP haddInput machineBinaryAddBits_mem_FP + +theorem machineBetheFlatIndexColumnBits_mem_FP : + machineBetheFlatIndexColumnBits ∈ FP := by + have hmulInput := machinePair_mem_FP + machineBetheFlatIndexCurrentBits_mem_FP + machineBetheFlatIndexDimensionBits_mem_FP + have hmul := machineCompose_mem_FP hmulInput + machineBinaryMulBits_mem_FP + have haddInput := machinePair_mem_FP hmul + machineBetheFlatIndexFixedBits_mem_FP + simpa only [machineBetheFlatIndexColumnBits] using! + machineCompose_mem_FP haddInput machineBinaryAddBits_mem_FP + +theorem machineBetheFlatIndexBits_mem_FP : + machineBetheFlatIndexBits ∈ FP := by + exact machineIfHead_mem_FP machineBetheFlatIndexMode_mem_FP + machineBetheFlatIndexRowBits_mem_FP + machineBetheFlatIndexColumnBits_mem_FP + +theorem machineBetheFlatIndexRuler_mem_FP : + machineBetheFlatIndexRuler ∈ FP := by + have hinput := machinePair_mem_FP id_mem_FP + machineBetheFlatIndexBits_mem_FP + simpa only [machineBetheFlatIndexRuler] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineBetheFlatEntryRawCode_mem_FP : + machineBetheFlatEntryRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineBetheFlatIndexRuler_mem_FP + machineBetheFlatIndexVector_mem_FP + simpa only [machineBetheFlatEntryRawCode] using! + machineCompose_mem_FP hinput machineListIndex_mem_FP + +/-- The canonical flattened-index request with mode, unary indices, and rational-vector payload. -/ +def betheFlatIndexCanonicalWord {m : β„•} (rowMode : Bool) + (fixed current : Fin m) (y : Fin (m * m) β†’ β„š) : List Bool := + pair [rowMode] + (pair (List.replicate m true) + (pair (List.replicate fixed.1 true) + (pair (List.replicate current.1 true) + (rationalFiniteVectorCode y)))) + +@[simp] theorem machineBetheFlatIndexRowBits_encode {m : β„•} + (fixed current : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheFlatIndexRowBits + (betheFlatIndexCanonicalWord true fixed current y) = + (fixed.1 * m + current.1).bits := by + simp [machineBetheFlatIndexRowBits, machineBetheFlatIndexFixedBits, + machineBetheFlatIndexCurrentBits, machineBetheFlatIndexDimensionBits, + machineBetheFlatIndexFixed, machineBetheFlatIndexCurrent, + machineBetheFlatIndexDimension, machineBetheFlatIndexRest, + betheFlatIndexCanonicalWord, machineBinaryMulBits_pair_natBits, + machineBinaryAddBits_pair_natBits] + +@[simp] theorem machineBetheFlatIndexColumnBits_encode {m : β„•} + (fixed current : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheFlatIndexColumnBits + (betheFlatIndexCanonicalWord false fixed current y) = + (current.1 * m + fixed.1).bits := by + simp [machineBetheFlatIndexColumnBits, machineBetheFlatIndexFixedBits, + machineBetheFlatIndexCurrentBits, machineBetheFlatIndexDimensionBits, + machineBetheFlatIndexFixed, machineBetheFlatIndexCurrent, + machineBetheFlatIndexDimension, machineBetheFlatIndexRest, + betheFlatIndexCanonicalWord, machineBinaryMulBits_pair_natBits, + machineBinaryAddBits_pair_natBits] + +theorem bethe_flat_index_lt_word_length {m : β„•} (rowMode : Bool) + (fixed current : Fin m) (y : Fin (m * m) β†’ β„š) : + (if rowMode then fixed.1 * m + current.1 + else current.1 * m + fixed.1) ≀ + (betheFlatIndexCanonicalWord rowMode fixed current y).length := by + have hidx : (if rowMode then fixed.1 * m + current.1 + else current.1 * m + fixed.1) < m * m := by + cases rowMode with + | false => + simp only [Bool.false_eq_true, ite_false] + calc + current.1 * m + fixed.1 < current.1 * m + m := + Nat.add_lt_add_left fixed.isLt _ + _ = (current.1 + 1) * m := (Nat.succ_mul current.1 m).symm + _ ≀ m * m := Nat.mul_le_mul_right m + (Nat.succ_le_iff.mpr current.isLt) + | true => + simp only [if_true] + calc + fixed.1 * m + current.1 < fixed.1 * m + m := + Nat.add_lt_add_left current.isLt _ + _ = (fixed.1 + 1) * m := (Nat.succ_mul fixed.1 m).symm + _ ≀ m * m := Nat.mul_le_mul_right m + (Nat.succ_le_iff.mpr fixed.isLt) + have hvector : m * m ≀ (rationalFiniteVectorCode y).length := by + simpa only [rationalFiniteVectorCode, List.length_ofFn] using! + list_length_le_binaryListCode_length rationalEntryBinaryCode + (List.ofFn y) + have hcode : (rationalFiniteVectorCode y).length ≀ + (betheFlatIndexCanonicalWord rowMode fixed current y).length := by + simp [betheFlatIndexCanonicalWord] + omega + exact hidx.le.trans (hvector.trans hcode) + +@[simp] theorem machineBetheFlatIndexRuler_encode {m : β„•} + (rowMode : Bool) (fixed current : Fin m) + (y : Fin (m * m) β†’ β„š) : + machineBetheFlatIndexRuler + (betheFlatIndexCanonicalWord rowMode fixed current y) = + List.replicate + (if rowMode then fixed.1 * m + current.1 + else current.1 * m + fixed.1) true := by + rw [machineBetheFlatIndexRuler] + cases rowMode with + | false => + simp only [machineBetheFlatIndexBits, machineBetheFlatIndexMode, + betheFlatIndexCanonicalWord, machinePairFirst_pair, + machineIfHead_false, Bool.false_eq_true, ite_false] + change machineBoundedUnary + (pair (betheFlatIndexCanonicalWord false fixed current y) + (machineBetheFlatIndexColumnBits + (betheFlatIndexCanonicalWord false fixed current y))) = _ + rw [machineBetheFlatIndexColumnBits_encode] + rw [machineBoundedUnary_encode_of_le] + exact bethe_flat_index_lt_word_length false fixed current y + | true => + simp only [machineBetheFlatIndexBits, machineBetheFlatIndexMode, + betheFlatIndexCanonicalWord, machinePairFirst_pair, + machineIfHead_true, if_true] + change machineBoundedUnary + (pair (betheFlatIndexCanonicalWord true fixed current y) + (machineBetheFlatIndexRowBits + (betheFlatIndexCanonicalWord true fixed current y))) = _ + rw [machineBetheFlatIndexRowBits_encode] + rw [machineBoundedUnary_encode_of_le] + exact bethe_flat_index_lt_word_length true fixed current y + +@[simp] theorem machineBetheFlatIndexVector_encode {m : β„•} + (rowMode : Bool) (fixed current : Fin m) + (y : Fin (m * m) β†’ β„š) : + machineBetheFlatIndexVector + (betheFlatIndexCanonicalWord rowMode fixed current y) = + rationalFiniteVectorCode y := by + simp [machineBetheFlatIndexVector, machineBetheFlatIndexRest, + betheFlatIndexCanonicalWord] + +@[simp] theorem machineBetheFlatEntryRawCode_encode {m : β„•} + (rowMode : Bool) (fixed current : Fin m) + (y : Fin (m * m) β†’ β„š) : + machineBetheFlatEntryRawCode + (betheFlatIndexCanonicalWord rowMode fixed current y) = + rawRatBinaryCode + (rawRatOfRat + (if rowMode then y (finProdFinEquiv (fixed, current)) + else y (finProdFinEquiv (current, fixed)))) := by + rw [machineBetheFlatEntryRawCode, + machineBetheFlatIndexRuler_encode, + machineBetheFlatIndexVector_encode] + cases rowMode with + | false => + simp only [Bool.false_eq_true, ite_false, rationalFiniteVectorCode] + have hk : current.1 * m + fixed.1 < (List.ofFn y).length := by + simp only [List.length_ofFn] + calc + current.1 * m + fixed.1 < current.1 * m + m := + Nat.add_lt_add_left fixed.isLt _ + _ = (current.1 + 1) * m := (Nat.succ_mul current.1 m).symm + _ ≀ m * m := Nat.mul_le_mul_right m + (Nat.succ_le_iff.mpr current.isLt) + rw [machineListIndex_binaryListCode rationalEntryBinaryCode + (List.ofFn y) (current.1 * m + fixed.1) hk, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [List.getElem_ofFn] + apply congrArg y + apply Fin.ext + simp only [finProdFinEquiv, Equiv.coe_fn_mk] + rw [Nat.mul_comm current.1 m] + omega + | true => + simp only [if_true, rationalFiniteVectorCode] + have hk : fixed.1 * m + current.1 < (List.ofFn y).length := by + simp only [List.length_ofFn] + calc + fixed.1 * m + current.1 < fixed.1 * m + m := + Nat.add_lt_add_left current.isLt _ + _ = (fixed.1 + 1) * m := (Nat.succ_mul fixed.1 m).symm + _ ≀ m * m := Nat.mul_le_mul_right m + (Nat.succ_le_iff.mpr fixed.isLt) + rw [machineListIndex_binaryListCode rationalEntryBinaryCode + (List.ofFn y) (fixed.1 * m + current.1) hk, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [List.getElem_ofFn] + apply congrArg y + apply Fin.ext + simp only [finProdFinEquiv, Equiv.coe_fn_mk] + rw [Nat.mul_comm fixed.1 m] + omega + +/-! ## A bounded exact line-sum iteration -/ + +/-- Extract the row-versus-column mode from a line-sum request. -/ +def machineBetheLineSumMode (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the payload following the line-sum mode word. -/ +def machineBetheLineSumRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary dimension ruler from a line-sum request. -/ +def machineBetheLineSumDimension (word : List Bool) : List Bool := + machinePairFirst (machineBetheLineSumRest word) + +/-- Extract the unary fixed row or column index from a line-sum request. -/ +def machineBetheLineSumFixed (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineBetheLineSumRest word)) + +/-- Extract the encoded rational vector from a line-sum request. -/ +def machineBetheLineSumVector (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machineBetheLineSumRest word)) + +/-- Encode the remaining count, current index, accumulator, payload, and bound of a line-sum +state. -/ +def machineBetheLineSumPack (remaining current acc payload bound : List Bool) : + List Bool := + pair remaining (pair current (pair acc (pair payload bound))) + +/-- Extract the remaining-iteration ruler from a line-sum state. -/ +def machineBetheLineSumRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the current-index ruler from a line-sum state. -/ +def machineBetheLineSumCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the encoded raw-rational accumulator from a line-sum state. -/ +def machineBetheLineSumAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extract the original line-sum request retained in the state. -/ +def machineBetheLineSumPayload (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extract the word whose length bounds the line-sum accumulator. -/ +def machineBetheLineSumBound (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Build the flattened-entry request for the current position in the line-sum scan. -/ +def machineBetheLineSumEntryInput (state : List Bool) : List Bool := + let payload := machineBetheLineSumPayload state + pair (machineBetheLineSumMode payload) + (pair (machineBetheLineSumDimension payload) + (pair (machineBetheLineSumFixed payload) + (pair (machineBetheLineSumCurrent state) + (machineBetheLineSumVector payload)))) + +/-- Evaluate the encoded raw-rational entry at the current scan position. -/ +def machineBetheLineSumEntry (state : List Bool) : List Bool := + machineBetheFlatEntryRawCode (machineBetheLineSumEntryInput state) + +/-- Add the current entry to the encoded line-sum accumulator. -/ +def machineBetheLineSumCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineBetheLineSumAccumulator state) + (machineBetheLineSumEntry state)) + +/-- Truncate the candidate accumulator code to the stored bound length. -/ +def machineBetheLineSumNextAccumulator (state : List Bool) : List Bool := + (machineBetheLineSumCandidate state).take + (machineBetheLineSumBound state).length + +/-- Consume one remaining position, advance the unary index, and store the bounded updated sum. -/ +def machineBetheLineSumAdvance (state : List Bool) : List Bool := + machineBetheLineSumPack + (machineBetheLineSumRemaining state).tail + (true :: machineBetheLineSumCurrent state) + (machineBetheLineSumNextAccumulator state) + (machineBetheLineSumPayload state) + (machineBetheLineSumBound state) + +/-- Leave a completed line-sum state unchanged, otherwise advance one position. -/ +def machineBetheLineSumStep (state : List Bool) : List Bool := + machineIfEmpty (machineBetheLineSumRemaining state) state + (machineBetheLineSumAdvance state) + +/-- Construct the line-sum bound word by applying the multiplication-width construction twice. -/ +def machineBetheLineSumInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth word) + +/-- Initialize the line-sum scan at index zero with a zero accumulator and the full dimension +ruler. -/ +def machineBetheLineSumInit (word : List Bool) : List Bool := + machineBetheLineSumPack (machineBetheLineSumDimension word) [] + (rawRatBinaryCode RawRat.zero) word + (machineBetheLineSumInputBound word) + +/-- The packed width witness formed from five copies of the line-sum input bound word. -/ +def machineBetheLineSumWidth (word : List Bool) : List Bool := + let bound := machineBetheLineSumInputBound word + machineBetheLineSumPack bound bound bound bound bound + +/-- Iterate the line-sum transition as many times as the dimension ruler length. -/ +def machineBetheLineSumFinalState (word : List Bool) : List Bool := + (machineBetheLineSumStep)^[(machineBetheLineSumDimension word).length] + (machineBetheLineSumInit word) + +/-- Extract the raw-rational sum code from the final line-sum state. -/ +def machineBetheLineSumRawCode (word : List Bool) : List Bool := + machineBetheLineSumAccumulator (machineBetheLineSumFinalState word) + +theorem machineBetheLineSumMode_mem_FP : machineBetheLineSumMode ∈ FP := + machinePairFirst_mem_FP + +theorem machineBetheLineSumRest_mem_FP : machineBetheLineSumRest ∈ FP := + machinePairSecond_mem_FP + +theorem machineBetheLineSumDimension_mem_FP : + machineBetheLineSumDimension ∈ FP := by + simpa only [machineBetheLineSumDimension] using! + machineCompose_mem_FP machineBetheLineSumRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheLineSumFixed_mem_FP : + machineBetheLineSumFixed ∈ FP := by + have htail := machineCompose_mem_FP machineBetheLineSumRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheLineSumFixed] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheLineSumVector_mem_FP : + machineBetheLineSumVector ∈ FP := by + have htail := machineCompose_mem_FP machineBetheLineSumRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheLineSumVector] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineBetheLineSumRemaining_mem_FP : + machineBetheLineSumRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheLineSumCurrent_mem_FP : + machineBetheLineSumCurrent ∈ FP := by + simpa only [machineBetheLineSumCurrent] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBetheLineSumAccumulator_mem_FP : + machineBetheLineSumAccumulator ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheLineSumAccumulator] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheLineSumPayload_mem_FP : + machineBetheLineSumPayload ∈ FP := by + have htail₁ := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailβ‚‚ := machineCompose_mem_FP htail₁ machinePairSecond_mem_FP + simpa only [machineBetheLineSumPayload] using! + machineCompose_mem_FP htailβ‚‚ machinePairFirst_mem_FP + +theorem machineBetheLineSumBound_mem_FP : + machineBetheLineSumBound ∈ FP := by + have htail₁ := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailβ‚‚ := machineCompose_mem_FP htail₁ machinePairSecond_mem_FP + simpa only [machineBetheLineSumBound] using! + machineCompose_mem_FP htailβ‚‚ machinePairSecond_mem_FP + +theorem machineBetheLineSumEntryInput_mem_FP : + machineBetheLineSumEntryInput ∈ FP := by + have hmode := machineCompose_mem_FP machineBetheLineSumPayload_mem_FP + machineBetheLineSumMode_mem_FP + have hdim := machineCompose_mem_FP machineBetheLineSumPayload_mem_FP + machineBetheLineSumDimension_mem_FP + have hfixed := machineCompose_mem_FP machineBetheLineSumPayload_mem_FP + machineBetheLineSumFixed_mem_FP + have hvector := machineCompose_mem_FP machineBetheLineSumPayload_mem_FP + machineBetheLineSumVector_mem_FP + exact machinePair_mem_FP hmode + (machinePair_mem_FP hdim + (machinePair_mem_FP hfixed + (machinePair_mem_FP machineBetheLineSumCurrent_mem_FP hvector))) + +theorem machineBetheLineSumEntry_mem_FP : machineBetheLineSumEntry ∈ FP := by + simpa only [machineBetheLineSumEntry] using! + machineCompose_mem_FP machineBetheLineSumEntryInput_mem_FP + machineBetheFlatEntryRawCode_mem_FP + +theorem machineBetheLineSumCandidate_mem_FP : + machineBetheLineSumCandidate ∈ FP := by + have hinput := machinePair_mem_FP machineBetheLineSumAccumulator_mem_FP + machineBetheLineSumEntry_mem_FP + simpa only [machineBetheLineSumCandidate] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineBetheLineSumNextAccumulator_mem_FP : + machineBetheLineSumNextAccumulator ∈ FP := by + simpa only [machineBetheLineSumNextAccumulator] using! + machineTake_mem_FP machineBetheLineSumBound_mem_FP + machineBetheLineSumCandidate_mem_FP + +theorem machineBetheLineSumAdvance_mem_FP : + machineBetheLineSumAdvance ∈ FP := by + have hremaining := machineCompose_mem_FP + machineBetheLineSumRemaining_mem_FP machineTail_mem_FP + have hcurrent := machineCompose_mem_FP machineBetheLineSumCurrent_mem_FP + (machinePrepend_mem_FP true) + exact machinePair_mem_FP hremaining + (machinePair_mem_FP hcurrent + (machinePair_mem_FP machineBetheLineSumNextAccumulator_mem_FP + (machinePair_mem_FP machineBetheLineSumPayload_mem_FP + machineBetheLineSumBound_mem_FP))) + +theorem machineBetheLineSumStep_mem_FP : machineBetheLineSumStep ∈ FP := by + exact machineIfEmpty_mem_FP machineBetheLineSumRemaining_mem_FP + id_mem_FP machineBetheLineSumAdvance_mem_FP + +theorem machineBetheLineSumInputBound_mem_FP : + machineBetheLineSumInputBound ∈ FP := by + simpa only [machineBetheLineSumInputBound] using! + machineCompose_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineBetheLineSumInit_mem_FP : machineBetheLineSumInit ∈ FP := by + exact machinePair_mem_FP machineBetheLineSumDimension_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP + (rawRatBinaryCode RawRat.zero)) + (machinePair_mem_FP id_mem_FP + machineBetheLineSumInputBound_mem_FP))) + +theorem machineBetheLineSumWidth_mem_FP : machineBetheLineSumWidth ∈ FP := by + have h := machineBetheLineSumInputBound_mem_FP + exact machinePair_mem_FP h + (machinePair_mem_FP h (machinePair_mem_FP h (machinePair_mem_FP h h))) + +@[simp] theorem machineBetheLineSumRemaining_pack (a b c d e) : + machineBetheLineSumRemaining (machineBetheLineSumPack a b c d e) = a := by + simp [machineBetheLineSumRemaining, machineBetheLineSumPack] + +@[simp] theorem machineBetheLineSumCurrent_pack (a b c d e) : + machineBetheLineSumCurrent (machineBetheLineSumPack a b c d e) = b := by + simp [machineBetheLineSumCurrent, machineBetheLineSumPack] + +@[simp] theorem machineBetheLineSumAccumulator_pack (a b c d e) : + machineBetheLineSumAccumulator (machineBetheLineSumPack a b c d e) = c := by + simp [machineBetheLineSumAccumulator, machineBetheLineSumPack] + +@[simp] theorem machineBetheLineSumPayload_pack (a b c d e) : + machineBetheLineSumPayload (machineBetheLineSumPack a b c d e) = d := by + simp [machineBetheLineSumPayload, machineBetheLineSumPack] + +@[simp] theorem machineBetheLineSumBound_pack (a b c d e) : + machineBetheLineSumBound (machineBetheLineSumPack a b c d e) = e := by + simp [machineBetheLineSumBound, machineBetheLineSumPack] + +/-- The line-sum state invariant: canonical packing, bounded counters and payloads, and the +fixed input bound. -/ +def MachineBetheLineSumStateBound (word state : List Bool) : Prop := + let B := (machineBetheLineSumInputBound word).length + state = machineBetheLineSumPack + (machineBetheLineSumRemaining state) + (machineBetheLineSumCurrent state) + (machineBetheLineSumAccumulator state) + (machineBetheLineSumPayload state) + (machineBetheLineSumBound state) ∧ + (machineBetheLineSumRemaining state).length + + (machineBetheLineSumCurrent state).length ≀ B ∧ + (machineBetheLineSumAccumulator state).length ≀ B ∧ + (machineBetheLineSumPayload state).length ≀ B ∧ + machineBetheLineSumBound state = machineBetheLineSumInputBound word + +theorem machineBetheLineSum_word_le_bound (word : List Bool) : + word.length ≀ (machineBetheLineSumInputBound word).length := by + simp only [machineBetheLineSumInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineBetheLineSumInit_bound (word : List Bool) : + MachineBetheLineSumStateBound word (machineBetheLineSumInit word) := by + dsimp only [MachineBetheLineSumStateBound] + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + Β· simp only [machineBetheLineSumInit, + machineBetheLineSumRemaining_pack, + machineBetheLineSumCurrent_pack, + machineBetheLineSumAccumulator_pack, + machineBetheLineSumPayload_pack, + machineBetheLineSumBound_pack] + Β· simp only [machineBetheLineSumInit, + machineBetheLineSumRemaining_pack, + machineBetheLineSumCurrent_pack, List.length_nil, Nat.add_zero] + exact (machinePairFirst_length_le (machineBetheLineSumRest word)).trans + ((machinePairSecond_length_le word).trans + (machineBetheLineSum_word_le_bound word)) + Β· simp only [machineBetheLineSumInit, + machineBetheLineSumAccumulator_pack] + exact (rawRatBinaryCode_length_le_width RawRat.zero).trans + (by + simp only [rawRatWidth_zero, machineBetheLineSumInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append] + nlinarith [sq_nonneg (word.length + 16)]) + Β· simpa only [machineBetheLineSumInit, + machineBetheLineSumPayload_pack] using! + machineBetheLineSum_word_le_bound word + Β· simp only [machineBetheLineSumInit, machineBetheLineSumBound_pack] + +theorem machineBetheLineSumStep_bound {word state : List Bool} + (hs : MachineBetheLineSumStateBound word state) : + MachineBetheLineSumStateBound word (machineBetheLineSumStep state) := by + dsimp only [MachineBetheLineSumStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hindices, hacc, hpayload, hbound⟩ + by_cases hempty : machineBetheLineSumRemaining state = [] + Β· rw [machineBetheLineSumStep, hempty, machineIfEmpty_nil] + exact ⟨hdecomp, hindices, hacc, hpayload, hbound⟩ + Β· cases hremaining : machineBetheLineSumRemaining state with + | nil => exact False.elim (hempty hremaining) + | cons bit tail => + rw [machineBetheLineSumStep, hremaining, machineIfEmpty_cons, + machineBetheLineSumAdvance] + simp only [machineBetheLineSumRemaining_pack, + machineBetheLineSumCurrent_pack, + machineBetheLineSumAccumulator_pack, + machineBetheLineSumPayload_pack, machineBetheLineSumBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· have hsame : + (machineBetheLineSumRemaining state).tail.length + + (true :: machineBetheLineSumCurrent state).length = + (machineBetheLineSumRemaining state).length + + (machineBetheLineSumCurrent state).length := by + rw [hremaining] + simp only [List.tail_cons, List.length_cons] + omega + rw [hsame] + exact hindices + Β· rw [machineBetheLineSumNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineBetheLineSumIterate_bound (word : List Bool) : βˆ€ k, + MachineBetheLineSumStateBound word + ((machineBetheLineSumStep)^[k] (machineBetheLineSumInit word)) := by + intro k + induction k with + | zero => exact machineBetheLineSumInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineBetheLineSumStep_bound ih + +theorem machineBetheLineSumIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineBetheLineSumDimension word).length) : + ((machineBetheLineSumStep)^[iterations] + (machineBetheLineSumInit word)).length ≀ + (machineBetheLineSumWidth word).length := by + rcases machineBetheLineSumIterate_bound word iterations with + ⟨hdecomp, hindices, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineBetheLineSumPack, machineBetheLineSumWidth, pair_length] + omega + +theorem machineBetheLineSumFinalState_mem_FP : + machineBetheLineSumFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineBetheLineSumStep_mem_FP + machineBetheLineSumInit_mem_FP machineBetheLineSumDimension_mem_FP + machineBetheLineSumWidth_mem_FP + machineBetheLineSumIterate_length_le_width + +theorem machineBetheLineSumRawCode_mem_FP : + machineBetheLineSumRawCode ∈ FP := by + simpa only [machineBetheLineSumRawCode] using! + machineCompose_mem_FP machineBetheLineSumFinalState_mem_FP + machineBetheLineSumAccumulator_mem_FP + +/-! ## Exactness and absence of truncation on canonical inputs -/ + +/-- The canonical line-sum request encoding the mode, dimension, fixed index, and rational +vector. -/ +def machineBetheLineSumCanonicalWord {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : List Bool := + pair [rowMode] + (pair (List.replicate m true) + (pair (List.replicate fixed.1 true) + (rationalFiniteVectorCode y))) + +/-- List the free affine-coordinate values along the selected row or column. -/ +def betheAffineLineValues {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : List β„š := + List.ofFn fun current : Fin m ↦ + if rowMode then y (finProdFinEquiv (fixed, current)) + else y (finProdFinEquiv (current, fixed)) + +/-- Sum the selected affine-coordinate row or column with raw-rational arithmetic. -/ +def rawBetheAffineLineSum {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : RawRat := + rawRatListSum RawRat.zero (betheAffineLineValues rowMode fixed y) + +@[simp] theorem betheAffineLineValues_length {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + (betheAffineLineValues rowMode fixed y).length = m := by + simp [betheAffineLineValues] + +theorem betheLineSum_dimension_le_word {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + m ≀ (machineBetheLineSumCanonicalWord rowMode fixed y).length := by + simp [machineBetheLineSumCanonicalWord] + omega + +theorem betheLineSum_vector_code_le_word {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + (rationalFiniteVectorCode y).length ≀ + (machineBetheLineSumCanonicalWord rowMode fixed y).length := by + simp [machineBetheLineSumCanonicalWord] + omega + +theorem betheAffineLineValue_cost_le_word {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) + {q : β„š} (hq : q ∈ betheAffineLineValues rowMode fixed y) : + rawRatWidth (rawRatOfRat q) + 1 ≀ + (machineBetheLineSumCanonicalWord rowMode fixed y).length + 1 := by + obtain ⟨current, rfl⟩ := List.mem_ofFn.mp hq + let z : β„š := if rowMode then y (finProdFinEquiv (fixed, current)) + else y (finProdFinEquiv (current, fixed)) + have hzmem : z ∈ List.ofFn y := by + cases rowMode with + | false => + simp only [z, Bool.false_eq_true, ite_false] + exact (List.mem_ofFn).2 ⟨finProdFinEquiv (current, fixed), rfl⟩ + | true => + simp only [z, if_true] + exact (List.mem_ofFn).2 ⟨finProdFinEquiv (fixed, current), rfl⟩ + have hentry := binaryListCode_element_length_le + rationalEntryBinaryCode hzmem + have hentry' : (rationalEntryBinaryCode z).length ≀ + (rationalFiniteVectorCode y).length := by + simpa only [rationalFiniteVectorCode] using! hentry + have hraw := rawRatWidth_le_binaryCode_length (rawRatOfRat z) + rw [rawRatBinaryCode_rawRatOfRat] at hraw + have hword := betheLineSum_vector_code_le_word rowMode fixed y + change rawRatWidth (rawRatOfRat z) + 1 ≀ _ + omega + +theorem rawRatListCost_betheLine_take_le {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) (k : β„•) : + rawRatListCost ((betheAffineLineValues rowMode fixed y).take k) ≀ + (machineBetheLineSumCanonicalWord rowMode fixed y).length * + ((machineBetheLineSumCanonicalWord rowMode fixed y).length + 1) := by + let values := betheAffineLineValues rowMode fixed y + let W := (machineBetheLineSumCanonicalWord rowMode fixed y).length + have heach : βˆ€ q ∈ values.take k, + rawRatWidth (rawRatOfRat q) + 1 ≀ W + 1 := by + intro q hq + exact betheAffineLineValue_cost_le_word rowMode fixed y + (List.mem_of_mem_take hq) + have hsum := List.sum_le_card_nsmul + ((values.take k).map fun q ↦ rawRatWidth (rawRatOfRat q) + 1) + (W + 1) (by + intro cost hcost + rw [List.mem_map] at hcost + obtain ⟨q, hq, rfl⟩ := hcost + exact heach q hq) + have hlength : (values.take k).length ≀ W := by + have htake : (values.take k).length ≀ values.length := by + rw [List.length_take] + exact Nat.min_le_right _ _ + exact htake.trans + (by simpa only [values, betheAffineLineValues_length, W] using! + betheLineSum_dimension_le_word rowMode fixed y) + have hlengthMap : + ((values.take k).map + fun q ↦ rawRatWidth (rawRatOfRat q) + 1).length ≀ W := by + simpa only [List.length_map] using! hlength + simp only [rawRatListCost] + exact hsum.trans (Nat.mul_le_mul_right (W + 1) hlengthMap) + +theorem rawBetheAffineLinePrefix_code_le_bound {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) (k : β„•) : + (rawRatBinaryCode + (rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take k))).length ≀ + (machineBetheLineSumInputBound + (machineBetheLineSumCanonicalWord rowMode fixed y)).length := by + let word := machineBetheLineSumCanonicalWord rowMode fixed y + let W := word.length + let segment := (betheAffineLineValues rowMode fixed y).take k + have hwidth := rawRatWidth_listSum_le RawRat.zero segment + have hcost := rawRatListCost_betheLine_take_le rowMode fixed y k + have hraw := rawRatBinaryCode_length_le_width + (rawRatListSum RawRat.zero segment) + have hwidth' : rawRatWidth (rawRatListSum RawRat.zero segment) ≀ + 1 + W * (W + 1) := by + simp only [rawRatWidth_zero] at hwidth + simpa only [word, W, segment] using! hwidth.trans + (Nat.add_le_add_left hcost 1) + apply hraw.trans + apply (Nat.add_le_add_left (Nat.mul_le_mul_left 3 hwidth') 4).trans + have hfirst : 4 + 3 * (1 + W * (W + 1)) ≀ + 4 * (16 + W) ^ 2 := by nlinarith + have hsecond : 4 * (16 + W) ^ 2 ≀ + (16 + (16 + W) ^ 2) ^ 2 := by + nlinarith [sq_nonneg ((16 + W) ^ 2)] + apply hfirst.trans hsecond |>.trans_eq + simp only [machineBetheLineSumInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append, word, W, pow_two] + +theorem rawRatListSum_append (acc : RawRat) : βˆ€ xs ys : List β„š, + rawRatListSum acc (xs ++ ys) = + rawRatListSum (rawRatListSum acc xs) ys := by + intro xs ys + induction xs generalizing acc with + | nil => rfl + | cons q qs ih => + simp only [List.cons_append, rawRatListSum] + exact ih (acc.add (rawRatOfRat q)) + +theorem rawBetheAffineLinePrefix_succ {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) (k : β„•) (hk : k < m) : + rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take (k + 1)) = + (rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take k)).add + (rawRatOfRat + (if rowMode then + y (finProdFinEquiv (fixed, ⟨k, hk⟩)) + else y (finProdFinEquiv (⟨k, hk⟩, fixed)))) := by + let values := betheAffineLineValues rowMode fixed y + have hk' : k < values.length := by simpa only [values, + betheAffineLineValues_length] using! hk + have htake : values.take (k + 1) = + values.take k ++ [values[k]] := by + simpa only [List.concat_eq_append] using! (List.take_concat_get hk').symm + rw [show (betheAffineLineValues rowMode fixed y).take (k + 1) = + values.take (k + 1) by rfl, htake, rawRatListSum_append] + simp only [rawRatListSum, List.getElem_ofFn, values, + betheAffineLineValues] + +/-- The semantic scan state after `k` positions, with the prefix sum and corresponding unary +counters. -/ +def machineBetheLineSumSemanticState {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) (k : β„•) : List Bool := + let word := machineBetheLineSumCanonicalWord rowMode fixed y + machineBetheLineSumPack (List.replicate (m - k) true) + (List.replicate k true) + (rawRatBinaryCode + (rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take k))) + word (machineBetheLineSumInputBound word) + +@[simp] theorem machineBetheLineSumMode_canonical {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumMode + (machineBetheLineSumCanonicalWord rowMode fixed y) = [rowMode] := by + simp [machineBetheLineSumMode, machineBetheLineSumCanonicalWord] + +@[simp] theorem machineBetheLineSumDimension_canonical {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumDimension + (machineBetheLineSumCanonicalWord rowMode fixed y) = + List.replicate m true := by + simp [machineBetheLineSumDimension, machineBetheLineSumRest, + machineBetheLineSumCanonicalWord] + +@[simp] theorem machineBetheLineSumFixed_canonical {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumFixed + (machineBetheLineSumCanonicalWord rowMode fixed y) = + List.replicate fixed.1 true := by + simp [machineBetheLineSumFixed, machineBetheLineSumRest, + machineBetheLineSumCanonicalWord] + +@[simp] theorem machineBetheLineSumVector_canonical {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumVector + (machineBetheLineSumCanonicalWord rowMode fixed y) = + rationalFiniteVectorCode y := by + simp [machineBetheLineSumVector, machineBetheLineSumRest, + machineBetheLineSumCanonicalWord] + +theorem machineBetheLineSumInit_semantics {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumInit + (machineBetheLineSumCanonicalWord rowMode fixed y) = + machineBetheLineSumSemanticState rowMode fixed y 0 := by + simp [machineBetheLineSumInit, machineBetheLineSumSemanticState, + rawRatListSum] + +theorem machineBetheLineSumEntryInput_semantics {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) + (k : β„•) (hk : k < m) : + machineBetheLineSumEntryInput + (machineBetheLineSumSemanticState rowMode fixed y k) = + betheFlatIndexCanonicalWord rowMode fixed ⟨k, hk⟩ y := by + simp [machineBetheLineSumEntryInput, machineBetheLineSumSemanticState, + betheFlatIndexCanonicalWord] + +theorem machineBetheLineSumStep_semantics {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) + (k : β„•) (hk : k < m) : + machineBetheLineSumStep + (machineBetheLineSumSemanticState rowMode fixed y k) = + machineBetheLineSumSemanticState rowMode fixed y (k + 1) := by + let word := machineBetheLineSumCanonicalWord rowMode fixed y + let segment := rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take k) + let term := rawRatOfRat + (if rowMode then y (finProdFinEquiv (fixed, ⟨k, hk⟩)) + else y (finProdFinEquiv (⟨k, hk⟩, fixed))) + have hremaining : List.replicate (m - k) true = + true :: List.replicate (m - (k + 1)) true := by + have hsub : m - k = (m - (k + 1)) + 1 := by omega + rw [hsub, List.replicate_succ] + have hentryInput := machineBetheLineSumEntryInput_semantics + rowMode fixed y k hk + have hentry : machineBetheLineSumEntry + (machineBetheLineSumSemanticState rowMode fixed y k) = + rawRatBinaryCode term := by + rw [machineBetheLineSumEntry, hentryInput, + machineBetheFlatEntryRawCode_encode] + have hentryPack : machineBetheLineSumEntry + (machineBetheLineSumPack + (true :: List.replicate (m - (k + 1)) true) + (List.replicate k true) (rawRatBinaryCode segment) word + (machineBetheLineSumInputBound word)) = + rawRatBinaryCode term := by + rw [← hremaining] + simpa only [machineBetheLineSumSemanticState, word, segment] using! hentry + have hprefix := rawBetheAffineLinePrefix_succ rowMode fixed y k hk + have hcode : (rawRatBinaryCode (segment.add term)).length ≀ + (machineBetheLineSumInputBound word).length := by + rw [show segment.add term = rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take (k + 1)) by + exact hprefix.symm] + exact rawBetheAffineLinePrefix_code_le_bound rowMode fixed y (k + 1) + rw [machineBetheLineSumStep, machineBetheLineSumSemanticState, + hremaining] + simp only [machineBetheLineSumRemaining_pack, machineIfEmpty_cons, + machineBetheLineSumAdvance, List.tail_cons, + machineBetheLineSumCurrent_pack, + machineBetheLineSumAccumulator_pack, + machineBetheLineSumPayload_pack, machineBetheLineSumBound_pack, + machineBetheLineSumNextAccumulator, + machineBetheLineSumCandidate] + change machineBetheLineSumPack + (List.replicate (m - (k + 1)) true) + (true :: List.replicate k true) + ((machineRawRatAddCode + (pair (rawRatBinaryCode segment) + (machineBetheLineSumEntry + (machineBetheLineSumPack + (true :: List.replicate (m - (k + 1)) true) + (List.replicate k true) (rawRatBinaryCode segment) word + (machineBetheLineSumInputBound word))))).take + (machineBetheLineSumInputBound word).length) + word (machineBetheLineSumInputBound word) = + machineBetheLineSumSemanticState rowMode fixed y (k + 1) + rw [hentryPack, machineRawRatAddCode_encode] + rw [(List.take_eq_self_iff _).mpr hcode] + rw [show segment.add term = rawRatListSum RawRat.zero + ((betheAffineLineValues rowMode fixed y).take (k + 1)) by + exact hprefix.symm] + simp only [machineBetheLineSumSemanticState, word, + List.replicate_succ] + +theorem machineBetheLineSumIterate_semantics {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : βˆ€ k ≀ m, + (machineBetheLineSumStep)^[k] + (machineBetheLineSumInit + (machineBetheLineSumCanonicalWord rowMode fixed y)) = + machineBetheLineSumSemanticState rowMode fixed y k := by + intro k hk + induction k with + | zero => exact machineBetheLineSumInit_semantics rowMode fixed y + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineBetheLineSumStep_semantics rowMode fixed y k (by omega) + +@[simp] theorem machineBetheLineSumRawCode_encode {m : β„•} + (rowMode : Bool) (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + machineBetheLineSumRawCode + (machineBetheLineSumCanonicalWord rowMode fixed y) = + rawRatBinaryCode (rawBetheAffineLineSum rowMode fixed y) := by + have hstate := congrArg machineBetheLineSumAccumulator + (machineBetheLineSumIterate_semantics rowMode fixed y m le_rfl) + have htake : (betheAffineLineValues rowMode fixed y).take m = + betheAffineLineValues rowMode fixed y := by + apply List.take_of_length_le + simp + simpa [machineBetheLineSumRawCode, machineBetheLineSumFinalState, + machineBetheLineSumDimension_canonical, + machineBetheLineSumSemanticState, rawBetheAffineLineSum, htake] using! hstate + +theorem rawBetheAffineLineSum_value {m : β„•} (rowMode : Bool) + (fixed : Fin m) (y : Fin (m * m) β†’ β„š) : + (rawBetheAffineLineSum rowMode fixed y).value = + if rowMode then βˆ‘ j : Fin m, y (finProdFinEquiv (fixed, j)) + else βˆ‘ i : Fin m, y (finProdFinEquiv (i, fixed)) := by + rw [rawBetheAffineLineSum, rawRatListSum_value, + RawRat.value_zero, zero_add] + cases rowMode <;> simp [betheAffineLineValues, List.sum_ofFn] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheEpigraphOracle.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheEpigraphOracle.lean new file mode 100644 index 0000000000..0c680880f3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheEpigraphOracle.lean @@ -0,0 +1,1067 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedEpigraphNormal +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightCap +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerInteriorScale +public import LeanPool.BeyondBethe.BeyondBethe.BetheEpigraphFeasibility + +/-! +# A finite-word oracle for the bounded Bethe epigraph + +The input contains the unary reduced dimension and precision, the rational +regularization parameter, floor and height cap, the input matrix, and a +rational ellipsoid state. The machine performs the three oracle branches in +their mathematical order: an exact floor scan, the exact height-cap test, and +the directed nonlinear objective test. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Public input layout and accessors -/ + +/-- Input layout: +`pair mUnary (pair pUnary (pair tauRaw (pair deltaRaw + (pair upperRaw (pair matrixCode ellipsoidCode)))))`. -/ +def machineBetheOracleDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the oracle input payload following the dimension word. -/ +def machineBetheOracleRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the precision ruler from a Bethe oracle input word. -/ +def machineBetheOraclePrecision (word : List Bool) : List Bool := + machinePairFirst (machineBetheOracleRest word) + +/-- Extract the oracle payload following the precision ruler. -/ +def machineBetheOracleAfterPrecision (word : List Bool) : List Bool := + machinePairSecond (machineBetheOracleRest word) + +/-- Extract the encoded regularization parameter from a Bethe oracle input word. -/ +def machineBetheOracleTau (word : List Bool) : List Bool := + machinePairFirst (machineBetheOracleAfterPrecision word) + +/-- Extract the oracle payload following the regularization parameter. -/ +def machineBetheOracleAfterTau (word : List Bool) : List Bool := + machinePairSecond (machineBetheOracleAfterPrecision word) + +/-- Extract the encoded affine-coordinate floor from a Bethe oracle input word. -/ +def machineBetheOracleDelta (word : List Bool) : List Bool := + machinePairFirst (machineBetheOracleAfterTau word) + +/-- Extract the oracle payload following the coordinate floor. -/ +def machineBetheOracleAfterDelta (word : List Bool) : List Bool := + machinePairSecond (machineBetheOracleAfterTau word) + +/-- Extract the encoded epigraph height cap from a Bethe oracle input word. -/ +def machineBetheOracleUpper (word : List Bool) : List Bool := + machinePairFirst (machineBetheOracleAfterDelta word) + +/-- Extract the matrix and ellipsoid payload following the height cap. -/ +def machineBetheOracleAfterUpper (word : List Bool) : List Bool := + machinePairSecond (machineBetheOracleAfterDelta word) + +/-- Extract the encoded rational matrix from a Bethe oracle input word. -/ +def machineBetheOracleMatrix (word : List Bool) : List Bool := + machinePairFirst (machineBetheOracleAfterUpper word) + +/-- Extract the encoded rational ellipsoid state from a Bethe oracle input word. -/ +def machineBetheOracleEllipsoid (word : List Bool) : List Bool := + machinePairSecond (machineBetheOracleAfterUpper word) + +/-- Extract the encoded center vector of the oracle ellipsoid. -/ +def machineBetheOracleCenter (word : List Bool) : List Bool := + machineRationalEllipsoidCenterWord (machineBetheOracleEllipsoid word) + +/-- Remove the final epigraph-height coordinate from the encoded center vector. -/ +def machineBetheOracleBase (word : List Bool) : List Bool := + machineBinaryListInit (machineBetheOracleCenter word) + +theorem machineBetheOracleDimension_mem_FP : + machineBetheOracleDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheOracleRest_mem_FP : + machineBetheOracleRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheOraclePrecision_mem_FP : + machineBetheOraclePrecision ∈ FP := by + simpa only [machineBetheOraclePrecision] using! + machineCompose_mem_FP machineBetheOracleRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheOracleAfterPrecision_mem_FP : + machineBetheOracleAfterPrecision ∈ FP := by + simpa only [machineBetheOracleAfterPrecision] using! + machineCompose_mem_FP machineBetheOracleRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheOracleTau_mem_FP : machineBetheOracleTau ∈ FP := by + simpa only [machineBetheOracleTau] using! + machineCompose_mem_FP machineBetheOracleAfterPrecision_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheOracleAfterTau_mem_FP : + machineBetheOracleAfterTau ∈ FP := by + simpa only [machineBetheOracleAfterTau] using! + machineCompose_mem_FP machineBetheOracleAfterPrecision_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheOracleDelta_mem_FP : machineBetheOracleDelta ∈ FP := by + simpa only [machineBetheOracleDelta] using! + machineCompose_mem_FP machineBetheOracleAfterTau_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheOracleAfterDelta_mem_FP : + machineBetheOracleAfterDelta ∈ FP := by + simpa only [machineBetheOracleAfterDelta] using! + machineCompose_mem_FP machineBetheOracleAfterTau_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheOracleUpper_mem_FP : machineBetheOracleUpper ∈ FP := by + simpa only [machineBetheOracleUpper] using! + machineCompose_mem_FP machineBetheOracleAfterDelta_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheOracleAfterUpper_mem_FP : + machineBetheOracleAfterUpper ∈ FP := by + simpa only [machineBetheOracleAfterUpper] using! + machineCompose_mem_FP machineBetheOracleAfterDelta_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheOracleMatrix_mem_FP : machineBetheOracleMatrix ∈ FP := by + simpa only [machineBetheOracleMatrix] using! + machineCompose_mem_FP machineBetheOracleAfterUpper_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheOracleEllipsoid_mem_FP : + machineBetheOracleEllipsoid ∈ FP := by + simpa only [machineBetheOracleEllipsoid] using! + machineCompose_mem_FP machineBetheOracleAfterUpper_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheOracleCenter_mem_FP : machineBetheOracleCenter ∈ FP := by + simpa only [machineBetheOracleCenter] using! + machineCompose_mem_FP machineBetheOracleEllipsoid_mem_FP + machineRationalEllipsoidCenterWord_mem_FP + +theorem machineBetheOracleBase_mem_FP : machineBetheOracleBase ∈ FP := by + simpa only [machineBetheOracleBase] using! + machineCompose_mem_FP machineBetheOracleCenter_mem_FP + machineBinaryListInit_mem_FP + +/-! ## Derived dimension and the three branch tests -/ + +/-- Convert the oracle dimension ruler to binary. -/ +def machineBetheOracleDimensionBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheOracleDimension word) + +/-- Compute the squared dimension, the number of free affine coordinates, in binary. -/ +def machineBetheOracleBaseDimensionBits (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineBetheOracleDimensionBits word) + (machineBetheOracleDimensionBits word)) + +/-- Convert the free-coordinate count to a unary ruler bounded by the base-coordinate word. -/ +def machineBetheOracleBaseDimensionUnary (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineBetheOracleBase word) + (machineBetheOracleBaseDimensionBits word)) + +/-- Encode the number of free affine coordinates as a raw rational with denominator one. -/ +def machineBetheOracleBaseDimensionRawCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode + (machineBetheOracleBaseDimensionBits word)) [true] + +/-- Package the dimension, floor, and center base coordinates for the floor-violation scan. -/ +def machineBetheOracleFloorScanInput (word : List Bool) : List Bool := + pair (machineBetheOracleDimension word) + (pair (machineBetheOracleDelta word) (machineBetheOracleBase word)) + +/-- Run the affine-coordinate floor scan on the oracle center. -/ +def machineBetheOracleFloorScanResult (word : List Bool) : List Bool := + machineBetheFloorScanResultCode (machineBetheOracleFloorScanInput word) + +/-- Extract the bit reporting whether the floor scan found a violation. -/ +def machineBetheOracleFloorFoundBit (word : List Bool) : List Bool := + machineHeadBit (machinePairFirst (machineBetheOracleFloorScanResult word)) + +/-- Extract the reported row ruler from the floor-scan result. -/ +def machineBetheOracleFloorRow (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineBetheOracleFloorScanResult word)) + +/-- Extract the reported column ruler from the floor-scan result. -/ +def machineBetheOracleFloorColumn (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machineBetheOracleFloorScanResult word)) + +/-- Package the base dimension, height cap, and center for the height-cap test. -/ +def machineBetheOracleHeightInput (word : List Bool) : List Bool := + pair (machineBetheOracleBaseDimensionUnary word) + (pair (machineBetheOracleUpper word) (machineBetheOracleCenter word)) + +/-- Test whether the center epigraph height violates the prescribed cap. -/ +def machineBetheOracleHeightViolationBit (word : List Bool) : List Bool := + machineBetheHeightCapViolationBit (machineBetheOracleHeightInput word) + +/-- Extract the center epigraph height as a raw-rational code. -/ +def machineBetheOracleHeightRawCode (word : List Bool) : List Bool := + machineBetheHeightCapEntryCode (machineBetheOracleHeightInput word) + +/-- The raw-rational constant sixteen used in the oracle error margin. -/ +def rawBetheOracleSixteen : RawRat := RawRat.ofNat 16 + +/-- Compute the raw-rational code of one half raised to the oracle precision. -/ +def machineBetheOracleHalfPowerRawCode (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineBetheOraclePrecision word) + (rawRatBinaryCode rawOptimizerHalf)) + +/-- Compute the raw-rational error scale `16 * (1/2)^p`. -/ +def machineBetheOracleScaledErrorRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawBetheOracleSixteen) + (machineBetheOracleHalfPowerRawCode word)) + +/-- Multiply the directed error scale by the number of free affine coordinates. -/ +def machineBetheOracleMarginRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineBetheOracleScaledErrorRawCode word) + (machineBetheOracleBaseDimensionRawCode word)) + +/-- Package dimension, precision, regularization, matrix, and base coordinates for objective +evaluation. -/ +def machineBetheOracleObjectiveInput (word : List Bool) : List Bool := + pair (machineBetheOracleDimension word) + (pair (machineBetheOraclePrecision word) + (pair (machineBetheOracleTau word) + (pair (machineBetheOracleMatrix word) (machineBetheOracleBase word)))) + +/-- Evaluate the directed lower negative-objective sum at the oracle center base coordinates. -/ +def machineBetheOracleLowerRawCode (word : List Bool) : List Bool := + machineDirectedNegativeObjectiveSumRawCode + (machineBetheOracleObjectiveInput word) + +/-- Add the evaluation margin to the center epigraph height. -/ +def machineBetheOracleHeightPlusMarginRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineBetheOracleHeightRawCode word) + (machineBetheOracleMarginRawCode word)) + +/-- Detect when the directed lower objective exceeds the center height plus the evaluation +margin. -/ +def machineBetheOracleNonlinearViolationBit + (word : List Bool) : List Bool := + machineNotBit + (machineRawRatLeBit + (pair (machineBetheOracleLowerRawCode word) + (machineBetheOracleHeightPlusMarginRawCode word))) + +theorem machineBetheOracleDimensionBits_mem_FP : + machineBetheOracleDimensionBits ∈ FP := by + simpa only [machineBetheOracleDimensionBits] using! + machineCompose_mem_FP machineBetheOracleDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheOracleBaseDimensionBits_mem_FP : + machineBetheOracleBaseDimensionBits ∈ FP := by + have hpair := machinePair_mem_FP machineBetheOracleDimensionBits_mem_FP + machineBetheOracleDimensionBits_mem_FP + simpa only [machineBetheOracleBaseDimensionBits] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineBetheOracleBaseDimensionUnary_mem_FP : + machineBetheOracleBaseDimensionUnary ∈ FP := by + have hpair := machinePair_mem_FP machineBetheOracleBase_mem_FP + machineBetheOracleBaseDimensionBits_mem_FP + simpa only [machineBetheOracleBaseDimensionUnary] using! + machineCompose_mem_FP hpair machineBoundedUnary_mem_FP + +theorem machineBetheOracleBaseDimensionRawCode_mem_FP : + machineBetheOracleBaseDimensionRawCode ∈ FP := by + have hnum := machineCompose_mem_FP + machineBetheOracleBaseDimensionBits_mem_FP + machineNaturalIntegerCode_mem_FP + exact machinePair_mem_FP hnum (machineConst_mem_FP [true]) + +theorem machineBetheOracleFloorScanInput_mem_FP : + machineBetheOracleFloorScanInput ∈ FP := + machinePair_mem_FP machineBetheOracleDimension_mem_FP + (machinePair_mem_FP machineBetheOracleDelta_mem_FP + machineBetheOracleBase_mem_FP) + +theorem machineBetheOracleFloorScanResult_mem_FP : + machineBetheOracleFloorScanResult ∈ FP := by + simpa only [machineBetheOracleFloorScanResult] using! + machineCompose_mem_FP machineBetheOracleFloorScanInput_mem_FP + machineBetheFloorScanResultCode_mem_FP + +theorem machineBetheOracleFloorFoundBit_mem_FP : + machineBetheOracleFloorFoundBit ∈ FP := by + have htag := machineCompose_mem_FP machineBetheOracleFloorScanResult_mem_FP + machinePairFirst_mem_FP + simpa only [machineBetheOracleFloorFoundBit] using! + machineCompose_mem_FP htag machineHeadBit_mem_FP + +theorem machineBetheOracleFloorRow_mem_FP : + machineBetheOracleFloorRow ∈ FP := by + have hpayload := machineCompose_mem_FP + machineBetheOracleFloorScanResult_mem_FP machinePairSecond_mem_FP + simpa only [machineBetheOracleFloorRow] using! + machineCompose_mem_FP hpayload machinePairFirst_mem_FP + +theorem machineBetheOracleFloorColumn_mem_FP : + machineBetheOracleFloorColumn ∈ FP := by + have hpayload := machineCompose_mem_FP + machineBetheOracleFloorScanResult_mem_FP machinePairSecond_mem_FP + simpa only [machineBetheOracleFloorColumn] using! + machineCompose_mem_FP hpayload machinePairSecond_mem_FP + +theorem machineBetheOracleHeightInput_mem_FP : + machineBetheOracleHeightInput ∈ FP := + machinePair_mem_FP machineBetheOracleBaseDimensionUnary_mem_FP + (machinePair_mem_FP machineBetheOracleUpper_mem_FP + machineBetheOracleCenter_mem_FP) + +theorem machineBetheOracleHeightViolationBit_mem_FP : + machineBetheOracleHeightViolationBit ∈ FP := by + simpa only [machineBetheOracleHeightViolationBit] using! + machineCompose_mem_FP machineBetheOracleHeightInput_mem_FP + machineBetheHeightCapViolationBit_mem_FP + +theorem machineBetheOracleHeightRawCode_mem_FP : + machineBetheOracleHeightRawCode ∈ FP := by + simpa only [machineBetheOracleHeightRawCode] using! + machineCompose_mem_FP machineBetheOracleHeightInput_mem_FP + machineBetheHeightCapEntryCode_mem_FP + +theorem machineBetheOracleHalfPowerRawCode_mem_FP : + machineBetheOracleHalfPowerRawCode ∈ FP := by + have hpair := machinePair_mem_FP machineBetheOraclePrecision_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerHalf)) + simpa only [machineBetheOracleHalfPowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatPowerCode_mem_FP + +theorem machineBetheOracleScaledErrorRawCode_mem_FP : + machineBetheOracleScaledErrorRawCode ∈ FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawBetheOracleSixteen)) + machineBetheOracleHalfPowerRawCode_mem_FP + simpa only [machineBetheOracleScaledErrorRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineBetheOracleMarginRawCode_mem_FP : + machineBetheOracleMarginRawCode ∈ FP := by + have hpair := machinePair_mem_FP + machineBetheOracleScaledErrorRawCode_mem_FP + machineBetheOracleBaseDimensionRawCode_mem_FP + simpa only [machineBetheOracleMarginRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineBetheOracleObjectiveInput_mem_FP : + machineBetheOracleObjectiveInput ∈ FP := + machinePair_mem_FP machineBetheOracleDimension_mem_FP + (machinePair_mem_FP machineBetheOraclePrecision_mem_FP + (machinePair_mem_FP machineBetheOracleTau_mem_FP + (machinePair_mem_FP machineBetheOracleMatrix_mem_FP + machineBetheOracleBase_mem_FP))) + +theorem machineBetheOracleLowerRawCode_mem_FP : + machineBetheOracleLowerRawCode ∈ FP := by + simpa only [machineBetheOracleLowerRawCode] using! + machineCompose_mem_FP machineBetheOracleObjectiveInput_mem_FP + machineDirectedNegativeObjectiveSumRawCode_mem_FP + +theorem machineBetheOracleHeightPlusMarginRawCode_mem_FP : + machineBetheOracleHeightPlusMarginRawCode ∈ FP := by + have hpair := machinePair_mem_FP machineBetheOracleHeightRawCode_mem_FP + machineBetheOracleMarginRawCode_mem_FP + simpa only [machineBetheOracleHeightPlusMarginRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineBetheOracleNonlinearViolationBit_mem_FP : + machineBetheOracleNonlinearViolationBit ∈ FP := by + have hpair := machinePair_mem_FP machineBetheOracleLowerRawCode_mem_FP + machineBetheOracleHeightPlusMarginRawCode_mem_FP + have hle := machineCompose_mem_FP hpair machineRawRatLeBit_mem_FP + simpa only [machineBetheOracleNonlinearViolationBit] using! + machineNotBit_mem_FP hle + +/-! ## Cut construction and final response -/ + +/-- Package the dimension and violating entry indices for a floor-cut normal. -/ +def machineBetheOracleFloorNormalInput (word : List Bool) : List Bool := + pair (machineBetheOracleDimension word) + (pair (machineBetheOracleFloorRow word) + (machineBetheOracleFloorColumn word)) + +/-- Encode a cutting response with the normal for the detected floor violation. -/ +def machineBetheOracleFloorResponse (word : List Bool) : List Bool := + pair [true] + (machineBetheFloorCutVectorCode (machineBetheOracleFloorNormalInput word)) + +/-- Encode a cutting response with the epigraph height-cap normal. -/ +def machineBetheOracleHeightResponse (word : List Bool) : List Bool := + pair [true] + (machineBetheHeightNormalVectorCode (machineBetheOracleDimension word)) + +/-- Encode a cutting response with the directed nonlinear epigraph normal. -/ +def machineBetheOracleNonlinearResponse (word : List Bool) : List Bool := + pair [true] + (machineDirectedEpigraphNormalVectorCode + (machineBetheOracleObjectiveInput word)) + +/-- The encoded acceptance response, carrying no cut vector. -/ +def machineBetheOracleAcceptResponse (_word : List Bool) : List Bool := + pair [false] [] + +/-- Choose the floor, height-cap, or nonlinear cut in that order, accepting when none is +required. -/ +def machineBetheEpigraphOracleResponseCode (word : List Bool) : List Bool := + machineIfHead (machineBetheOracleFloorFoundBit word) + (machineBetheOracleFloorResponse word) + (machineIfHead (machineBetheOracleHeightViolationBit word) + (machineBetheOracleHeightResponse word) + (machineIfHead (machineBetheOracleNonlinearViolationBit word) + (machineBetheOracleNonlinearResponse word) + (machineBetheOracleAcceptResponse word))) + +theorem machineBetheOracleFloorNormalInput_mem_FP : + machineBetheOracleFloorNormalInput ∈ FP := + machinePair_mem_FP machineBetheOracleDimension_mem_FP + (machinePair_mem_FP machineBetheOracleFloorRow_mem_FP + machineBetheOracleFloorColumn_mem_FP) + +theorem machineBetheOracleFloorResponse_mem_FP : + machineBetheOracleFloorResponse ∈ FP := by + have hnormal := machineCompose_mem_FP + machineBetheOracleFloorNormalInput_mem_FP + machineBetheFloorCutVectorCode_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true]) hnormal + +theorem machineBetheOracleHeightResponse_mem_FP : + machineBetheOracleHeightResponse ∈ FP := by + have hnormal := machineCompose_mem_FP machineBetheOracleDimension_mem_FP + machineBetheHeightNormalVectorCode_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true]) hnormal + +theorem machineBetheOracleNonlinearResponse_mem_FP : + machineBetheOracleNonlinearResponse ∈ FP := by + have hnormal := machineCompose_mem_FP machineBetheOracleObjectiveInput_mem_FP + machineDirectedEpigraphNormalVectorCode_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true]) hnormal + +theorem machineBetheOracleAcceptResponse_mem_FP : + machineBetheOracleAcceptResponse ∈ FP := + machineConst_mem_FP (pair [false] []) + +theorem machineBetheEpigraphOracleResponseCode_mem_FP : + machineBetheEpigraphOracleResponseCode ∈ FP := by + have hnonlinear := machineIfHead_mem_FP + machineBetheOracleNonlinearViolationBit_mem_FP + machineBetheOracleNonlinearResponse_mem_FP + machineBetheOracleAcceptResponse_mem_FP + have hheight := machineIfHead_mem_FP + machineBetheOracleHeightViolationBit_mem_FP + machineBetheOracleHeightResponse_mem_FP hnonlinear + simpa only [machineBetheEpigraphOracleResponseCode] using! + machineIfHead_mem_FP machineBetheOracleFloorFoundBit_mem_FP + machineBetheOracleFloorResponse_mem_FP hheight + +/-! ## Canonical semantics -/ + +/-- The canonical Bethe oracle input word containing its scalar parameters, matrix, and +ellipsoid state. -/ +def machineBetheOracleCanonicalWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : List Bool := + pair (List.replicate m true) + (pair (List.replicate p true) + (pair (rawRatBinaryCode (rawRatOfRat tau)) + (pair (rawRatBinaryCode delta) + (pair (rawRatBinaryCode upper) + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) + (rationalEllipsoidStateBinaryCode E)))))) + +theorem ofFn_epigraph_center_split {d : β„•} + (q : Fin (d + 1) β†’ β„š) : + List.ofFn q = List.ofFn (epigraphBase q) ++ [epigraphHeight q] := by + rw [List.ofFn_succ', List.concat_eq_append] + congr 2 + +@[simp] theorem machineBetheOracleDimension_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleDimension + (machineBetheOracleCanonicalWord tau A p delta upper E) = + List.replicate m true := by + simp [machineBetheOracleDimension, machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOraclePrecision_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOraclePrecision + (machineBetheOracleCanonicalWord tau A p delta upper E) = + List.replicate p true := by + simp [machineBetheOraclePrecision, machineBetheOracleRest, + machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleTau_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleTau + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode (rawRatOfRat tau) := by + simp [machineBetheOracleTau, machineBetheOracleAfterPrecision, + machineBetheOracleRest, machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleDelta_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleDelta + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode delta := by + simp [machineBetheOracleDelta, machineBetheOracleAfterTau, + machineBetheOracleAfterPrecision, machineBetheOracleRest, + machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleUpper_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleUpper + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode upper := by + simp [machineBetheOracleUpper, machineBetheOracleAfterDelta, + machineBetheOracleAfterTau, machineBetheOracleAfterPrecision, + machineBetheOracleRest, machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleMatrix_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleMatrix + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ := by + simp [machineBetheOracleMatrix, machineBetheOracleAfterUpper, + machineBetheOracleAfterDelta, machineBetheOracleAfterTau, + machineBetheOracleAfterPrecision, machineBetheOracleRest, + machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleEllipsoid_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleEllipsoid + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalEllipsoidStateBinaryCode E := by + simp [machineBetheOracleEllipsoid, machineBetheOracleAfterUpper, + machineBetheOracleAfterDelta, machineBetheOracleAfterTau, + machineBetheOracleAfterPrecision, machineBetheOracleRest, + machineBetheOracleCanonicalWord] + +@[simp] theorem machineBetheOracleCenter_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleCenter + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalFiniteVectorCode E.center := by + rw [machineBetheOracleCenter, machineBetheOracleEllipsoid_encode, + machineRationalEllipsoidCenterWord_encode] + +@[simp] theorem machineBetheOracleBase_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleBase + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalFiniteVectorCode (epigraphBase E.center) := by + rw [machineBetheOracleBase, machineBetheOracleCenter_encode, + rationalFiniteVectorCode, ofFn_epigraph_center_split, + machineBinaryListInit_encode] + rfl + +@[simp] theorem machineBetheOracleBaseDimensionBits_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleBaseDimensionBits + (machineBetheOracleCanonicalWord tau A p delta upper E) = + (m * m).bits := by + rw [machineBetheOracleBaseDimensionBits, + machineBetheOracleDimensionBits, machineBetheOracleDimension_encode, + machineLengthBits_encode, List.length_replicate, + machineBinaryMulBits_pair_natBits] + +theorem betheOracle_baseDimension_le_baseCodeLength {m : β„•} + (q : Fin (m * m) β†’ β„š) : + m * m ≀ (rationalFiniteVectorCode q).length := by + simpa only [rationalFiniteVectorCode, List.length_ofFn] using! + binaryListCode_listLength_le rationalEntryBinaryCode (List.ofFn q) + +@[simp] theorem machineBetheOracleBaseDimensionUnary_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleBaseDimensionUnary + (machineBetheOracleCanonicalWord tau A p delta upper E) = + List.replicate (m * m) true := by + rw [machineBetheOracleBaseDimensionUnary, + machineBetheOracleBase_encode, + machineBetheOracleBaseDimensionBits_encode] + exact machineBoundedUnary_encode_of_le _ _ + (betheOracle_baseDimension_le_baseCodeLength (epigraphBase E.center)) + +@[simp] theorem machineBetheOracleBaseDimensionRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleBaseDimensionRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode (RawRat.ofNat (m * m)) := by + rw [machineBetheOracleBaseDimensionRawCode, + machineBetheOracleBaseDimensionBits_encode, + machineNaturalIntegerCode_natBits] + simp [rawRatBinaryCode, RawRat.ofNat] + +@[simp] theorem machineBetheOracleFloorScanInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorScanInput + (machineBetheOracleCanonicalWord tau A p delta upper E) = + machineBetheFloorScanCanonicalWord delta (epigraphBase E.center) := by + simp [machineBetheOracleFloorScanInput, + machineBetheFloorScanCanonicalWord] + +@[simp] theorem machineBetheOracleFloorScanResult_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorScanResult + (machineBetheOracleCanonicalWord tau A p delta upper E) = + betheFloorScanSemanticResultCode + (finalBetheFloorScanSemanticState delta (epigraphBase E.center)) := by + rw [machineBetheOracleFloorScanResult, + machineBetheOracleFloorScanInput_encode, + machineBetheFloorScanResultCode_encode] + +@[simp] theorem machineBetheOracleFloorFoundBit_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorFoundBit + (machineBetheOracleCanonicalWord tau A p delta upper E) = + [(finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).found] := by + rw [machineBetheOracleFloorFoundBit, + machineBetheOracleFloorScanResult_encode] + simp [betheFloorScanSemanticResultCode] + +@[simp] theorem machineBetheOracleFloorRow_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorRow + (machineBetheOracleCanonicalWord tau A p delta upper E) = + List.replicate + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).row.1 true := by + rw [machineBetheOracleFloorRow, + machineBetheOracleFloorScanResult_encode] + simp [betheFloorScanSemanticResultCode] + +@[simp] theorem machineBetheOracleFloorColumn_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorColumn + (machineBetheOracleCanonicalWord tau A p delta upper E) = + List.replicate + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).column.1 true := by + rw [machineBetheOracleFloorColumn, + machineBetheOracleFloorScanResult_encode] + simp [betheFloorScanSemanticResultCode] + +@[simp] theorem machineBetheOracleHeightInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHeightInput + (machineBetheOracleCanonicalWord tau A p delta upper E) = + machineBetheHeightCapCanonicalWord upper E.center := by + simp [machineBetheOracleHeightInput, + machineBetheHeightCapCanonicalWord] + +@[simp] theorem machineBetheOracleHeightViolationBit_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHeightViolationBit + (machineBetheOracleCanonicalWord tau A p delta upper E) = + [decide (upper.value < epigraphHeight E.center)] := by + rw [machineBetheOracleHeightViolationBit, + machineBetheOracleHeightInput_encode, + machineBetheHeightCapViolationBit_encode] + rfl + +@[simp] theorem machineBetheOracleHeightRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHeightRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode (rawRatOfRat (epigraphHeight E.center)) := by + rw [machineBetheOracleHeightRawCode, + machineBetheOracleHeightInput_encode, + machineBetheHeightCapEntryCode_encode] + rfl + +/-- The raw-rational oracle margin `16 * (1/2)^p * m^2`. -/ +def rawBetheOracleMargin (m p : β„•) : RawRat := + (rawBetheOracleSixteen.mul (rawOptimizerHalf.pow p)).mul + (RawRat.ofNat (m * m)) + +@[simp] theorem machineBetheOracleHalfPowerRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHalfPowerRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode (rawOptimizerHalf.pow p) := by + rw [machineBetheOracleHalfPowerRawCode, + machineBetheOraclePrecision_encode, + machineRawRatPowerCode_encode] + +@[simp] theorem machineBetheOracleScaledErrorRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleScaledErrorRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode + (rawBetheOracleSixteen.mul (rawOptimizerHalf.pow p)) := by + rw [machineBetheOracleScaledErrorRawCode, + machineBetheOracleHalfPowerRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineBetheOracleMarginRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleMarginRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode (rawBetheOracleMargin m p) := by + rw [machineBetheOracleMarginRawCode, + machineBetheOracleScaledErrorRawCode_encode, + machineBetheOracleBaseDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem rawBetheOracleMargin_value (m p : β„•) : + (rawBetheOracleMargin m p).value = + 16 * (1 / 2 : β„š) ^ p * (m * m) := by + simp [rawBetheOracleMargin, rawBetheOracleSixteen, + RawRat.value_mul, RawRat.value_pow, rawOptimizerHalf_value] + +@[simp] theorem machineBetheOracleObjectiveInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleObjectiveInput + (machineBetheOracleCanonicalWord tau A p delta upper E) = + machineDirectedObjectiveSumCanonicalWord tau A + (epigraphBase E.center) p := by + simp [machineBetheOracleObjectiveInput, + machineDirectedObjectiveSumCanonicalWord] + +@[simp] theorem machineBetheOracleLowerRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleLowerRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode + (rawDirectedNegativeObjectiveSum tau A (epigraphBase E.center) p) := by + rw [machineBetheOracleLowerRawCode, + machineBetheOracleObjectiveInput_encode, + machineDirectedNegativeObjectiveSumRawCode_encode] + +@[simp] theorem machineBetheOracleHeightPlusMarginRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHeightPlusMarginRawCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rawRatBinaryCode + ((rawRatOfRat (epigraphHeight E.center)).add + (rawBetheOracleMargin m p)) := by + rw [machineBetheOracleHeightPlusMarginRawCode, + machineBetheOracleHeightRawCode_encode, + machineBetheOracleMarginRawCode_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineBetheOracleNonlinearViolationBit_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleNonlinearViolationBit + (machineBetheOracleCanonicalWord tau A p delta upper E) = + [decide + (epigraphHeight E.center + + 16 * (1 / 2 : β„š) ^ p * (m * m) < + directedNegativeObjectiveLower tau A + (betheAffineMatrixQ (epigraphBase E.center)) p)] := by + rw [machineBetheOracleNonlinearViolationBit, + machineBetheOracleLowerRawCode_encode, + machineBetheOracleHeightPlusMarginRawCode_encode, + machineRawRatLeBit_encode, machineNotBit_one] + rw [rawDirectedNegativeObjectiveSum_value, RawRat.value_add, + rawRatOfRat_value, rawBetheOracleMargin_value] + rw [← decide_not] + simp only [not_le] + +@[simp] theorem machineBetheOracleFloorNormalInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorNormalInput + (machineBetheOracleCanonicalWord tau A p delta upper E) = + machineBetheFloorCutVectorCanonicalWord + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).row + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).column := by + simp [machineBetheOracleFloorNormalInput, + machineBetheFloorCutVectorCanonicalWord] + +@[simp] theorem machineBetheOracleFloorResponse_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleFloorResponse + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalCentralOracleResponseBinaryCode + (.cut (betheFloorCutNormal + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).row + (finalBetheFloorScanSemanticState delta + (epigraphBase E.center)).column)) := by + rw [machineBetheOracleFloorResponse, + machineBetheOracleFloorNormalInput_encode, + machineBetheFloorCutVectorCode_encode_oracleNormal] + rfl + +@[simp] theorem machineBetheOracleHeightResponse_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleHeightResponse + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalCentralOracleResponseBinaryCode + (.cut (epigraphUpperNormal (m * m))) := by + rw [machineBetheOracleHeightResponse, + machineBetheOracleDimension_encode, + machineBetheHeightNormalVectorCode_encode] + rfl + +@[simp] theorem machineBetheOracleNonlinearResponse_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleNonlinearResponse + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalCentralOracleResponseBinaryCode + (.cut (epigraphNormal + ((betheDirectedEpigraphData tau A p).gradient + (epigraphBase E.center)))) := by + rw [machineBetheOracleNonlinearResponse, + machineBetheOracleObjectiveInput_encode, + machineDirectedEpigraphNormalVectorCode_encode_oracleNormal] + rfl + +@[simp] theorem machineBetheOracleAcceptResponse_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheOracleAcceptResponse + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalCentralOracleResponseBinaryCode + (RationalCentralOracleResponse.accept : + RationalCentralOracleResponse (m * m + 1)) := by + rfl + +/-- Semantic oracle implemented by the row-major machine scan. The scan +state is exposed here only to state the exact program-correctness theorem; +the validity proof below uses its established first-violation invariant. -/ +def scannedBetheBoundedEpigraphOracle {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) : + RationalCentralOracle (m * m + 1) := + fun E ↦ + let state := finalBetheFloorScanSemanticState delta + (epigraphBase E.center) + if state.found then + .cut (betheFloorCutNormal state.row state.column) + else if upper.value < epigraphHeight E.center then + .cut (epigraphUpperNormal (m * m)) + else + directedEpigraphOracle + (betheDirectedEpigraphData tau A p) + (16 * (1 / 2 : β„š) ^ p) (m * m) E + +@[simp] theorem machineBetheEpigraphOracleResponseCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) + (E : RationalEllipsoidState (m * m + 1)) : + machineBetheEpigraphOracleResponseCode + (machineBetheOracleCanonicalWord tau A p delta upper E) = + rationalCentralOracleResponseBinaryCode + (scannedBetheBoundedEpigraphOracle tau A p delta upper E) := by + let state := finalBetheFloorScanSemanticState delta + (epigraphBase E.center) + rw [machineBetheEpigraphOracleResponseCode, + machineBetheOracleFloorFoundBit_encode] + change machineIfHead [state.found] + (machineBetheOracleFloorResponse + (machineBetheOracleCanonicalWord tau A p delta upper E)) + _ = _ + cases hfound : state.found + Β· rw [machineIfHead_false] + by_cases hheight : upper.value < epigraphHeight E.center + Β· rw [machineBetheOracleHeightViolationBit_encode] + simp only [hheight, decide_true, machineIfHead_true] + rw [machineBetheOracleHeightResponse_encode] + simp [scannedBetheBoundedEpigraphOracle, state, hfound, hheight] + Β· rw [machineBetheOracleHeightViolationBit_encode] + simp only [hheight, decide_false, machineIfHead_false] + by_cases hnonlinear : epigraphHeight E.center + + 16 * (1 / 2 : β„š) ^ p * (m * m) < + directedNegativeObjectiveLower tau A + (betheAffineMatrixQ (epigraphBase E.center)) p + Β· rw [machineBetheOracleNonlinearViolationBit_encode] + simp only [hnonlinear, decide_true, machineIfHead_true] + rw [machineBetheOracleNonlinearResponse_encode] + have hnonlinear' : epigraphHeight E.center + + 16 * (2 ^ p : β„š)⁻¹ * (m * m) < + directedNegativeObjectiveLower tau A + (betheAffineMatrixQ (epigraphBase E.center)) p := by + simpa [one_div, div_pow] using! hnonlinear + simp [scannedBetheBoundedEpigraphOracle, state, hfound, hheight, + directedEpigraphOracle, betheDirectedEpigraphData, hnonlinear'] + Β· rw [machineBetheOracleNonlinearViolationBit_encode] + simp only [hnonlinear, decide_false, machineIfHead_false] + rw [machineBetheOracleAcceptResponse_encode] + have hnonlinear' : Β¬(epigraphHeight E.center + + 16 * (2 ^ p : β„š)⁻¹ * (m * m) < + directedNegativeObjectiveLower tau A + (betheAffineMatrixQ (epigraphBase E.center)) p) := by + simpa [one_div, div_pow] using! hnonlinear + simp [scannedBetheBoundedEpigraphOracle, state, hfound, hheight, + directedEpigraphOracle, betheDirectedEpigraphData, hnonlinear'] + Β· rw [machineIfHead_true, + machineBetheOracleFloorResponse_encode] + simp [scannedBetheBoundedEpigraphOracle, state, hfound] + +/-! ## Mathematical validity of the implemented scan oracle -/ + +theorem scannedBetheBoundedEpigraphOracle_valid {m : β„•} (hm : 0 < m) + {tau : β„š} {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (htau0 : 0 ≀ tau) (htau1 : tau ≀ 1) (hA : βˆ€ i j, 0 < A i j) + {delta : RawRat} (hdelta : 0 < delta.value) + (p : β„•) (upper : RawRat) : + RationalCentralOracleValid + (BetheEpigraphTarget (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + (delta.value : ℝ) (upper.value : ℝ)) + (scannedBetheBoundedEpigraphOracle tau A p delta upper) := by + intro E a hresponse + rw [scannedBetheBoundedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hfloor + Β· let state := finalBetheFloorScanSemanticState delta + (epigraphBase E.center) + have hfloor' : state.found = true := by simpa only [state] using! hfloor + cases hresponse + refine ⟨betheFloorCutNormal_ne_zero hm state.row state.column, ?_⟩ + intro z hz + have hbelow : betheAffineMatrixQ (epigraphBase E.center) + state.row state.column < delta.value := by + exact finalBetheFloorScanSemanticState_found_is_below + delta (epigraphBase E.center) hfloor' + have htargetFloor : (delta.value : ℝ) ≀ + birkhoffAffineMap (vectorToSquareMatrix (epigraphBase z)) + state.row state.column := by + simpa only [BetheEpigraphTarget] using! hz.1 state.row state.column + have hcut := betheFloorCut_valid hbelow htargetFloor + rw [finiteDot, Fin.sum_univ_castSucc] at hcut ⊒ + simpa [rationalCenterReal, epigraphBase] using! hcut.le + Β· split at hresponse <;> rename_i hheight + Β· cases hresponse + refine ⟨epigraphUpperNormal_ne_zero (m * m), ?_⟩ + intro z hz + have hdot := epigraphUpperNormal_dot_displacement z E.center + rw [show finiteDot + (fun i ↦ (epigraphUpperNormal (m * m) i : ℝ)) + (fun i ↦ z i - rationalCenterReal E i) = + epigraphHeight z - (epigraphHeight E.center : β„š) by + simpa only [rationalCenterReal] using! hdot] + have hzUpper : epigraphHeight z ≀ (upper.value : ℝ) := by + simpa only [BetheEpigraphTarget] using! hz.2.2 + have hheightReal : (upper.value : ℝ) < + ((epigraphHeight E.center : β„š) : ℝ) := by + exact_mod_cast hheight + linarith + Β· have hqueryFloor : βˆ€ i j, delta.value ≀ + betheAffineMatrixQ (epigraphBase E.center) i j := by + apply finalBetheFloorScanSemanticState_notFound_all_above + simpa using! hfloor + refine ⟨directedEpigraphOracle_cut_ne_zero + (betheDirectedEpigraphData tau A p) + (16 * (1 / 2 : β„š) ^ p) (m * m) E hresponse, ?_⟩ + intro z hz + exact (betheDirectedEpigraphOracle_cut_valid hm htau0 htau1 hA + hdelta (upper := (upper.value : ℝ)) p E hqueryFloor + hresponse hz).2.le + +theorem scannedBetheBoundedEpigraphOracle_acceptsOnly {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) : + RationalCentralOracleAcceptsOnly + (BetheEpigraphOracleAccepted tau A p delta.value upper.value) + (scannedBetheBoundedEpigraphOracle tau A p delta upper) := by + intro E hresponse + rw [scannedBetheBoundedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hfloor + Β· contradiction + Β· split at hresponse <;> rename_i hheight + Β· contradiction + Β· rw [directedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hnonlinear + Β· contradiction + Β· cases hresponse + refine ⟨?_, not_lt.mp hheight, ?_⟩ + Β· apply finalBetheFloorScanSemanticState_notFound_all_above + simpa using! hfloor + Β· exact not_lt.mp hnonlinear + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityFit.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityFit.lean new file mode 100644 index 0000000000..5ef6a219f7 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityFit.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledStateEncodingBound +public import Mathlib.Tactic + +/-! +# The canonical Bethe feasibility run always fits its finite-word ruler + +The determinant and magnitude invariants of the fixed schedule imply a single +ordinary-binary bound for every state reachable during the bounded run. This +discharges the last side condition in the program-correctness theorem for the +feasibility machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- The ellipsoid state-code bound obtained from the scheduled magnitude and rounding-precision +budgets. -/ +def scheduledFeasibilityStateCodeBound (d L K T : β„•) : β„• := + rationalEllipsoidMachineCodeBound d + (K + T * (6 + 3 * d)) + (roundedEllipsoidPrecisionSchedule d L K T + 10 + 4 * d) + +/-- Specialize the scheduled state-code bound to the initial ball determinant and magnitude +budgets. -/ +def explicitBallFeasibilityStateCodeBound (d T : β„•) (R : β„š) : β„• := + scheduledFeasibilityStateCodeBound d + (explicitBallInitialDetExponent d R) + (explicitBallInitialMagnitudeExponent d R) T + +theorem MachineBetheFeasibilityFits.of_invariant + {m L K T t iterations : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + {Target : (Fin (m * m + 1) β†’ ℝ) β†’ Prop} + (hvalid : RationalCentralOracleValid Target + (scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper)) + (E : RationalEllipsoidState (m * m + 1)) + (hE : ScheduledEllipsoidInvariant (m * m + 1) L K t E) + (hbudget : t + iterations ≀ T) : + MachineBetheFeasibilityFits tau A oraclePrecision delta upper + (roundedEllipsoidPrecisionSchedule (m * m + 1) L K T) + (scheduledFeasibilityStateCodeBound (m * m + 1) L K T) + iterations E := by + let d := m * m + 1 + have hd : 0 < d := by + dsimp only [d] + omega + induction iterations generalizing t E with + | zero => trivial + | succ iterations ih => + rw [MachineBetheFeasibilityFits] + cases hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper E with + | accept => trivial + | cut a => + have ha : a β‰  0 := (hvalid E a hresponse).1 + have hpulled : rationalPulledBackNormal E a β‰  0 := + rationalPulledBackNormal_ne_zero_of_det_ne_zero + E a hE.det_ne_zero ha + have htT : t ≀ T := by omega + let p := roundedEllipsoidPrecisionSchedule d L K T + let E₁ := scheduledRoundedEllipsoidCentralUpdate p E a + have hadvance := hE.advance hd a hpulled htT + have hE₁ : ScheduledEllipsoidInvariant d L K (t + 1) E₁ := by + simpa only [d, p, E₁] using! hadvance.2 + constructor + Β· have hexponent : K + (t + 1) * (6 + 3 * d) ≀ + K + T * (6 + 3 * d) := by + gcongr + omega + have hpow : (2 : β„š) ^ (K + (t + 1) * (6 + 3 * d)) ≀ + (2 : β„š) ^ (K + T * (6 + 3 * d)) := by + exact pow_le_pow_rightβ‚€ (by norm_num) hexponent + have hM : rationalStateAbsBound E₁ ≀ + (2 : β„š) ^ (K + T * (6 + 3 * d)) := + hE₁.magnitude.trans hpow + have hcode := + scheduledRoundedEllipsoidCentralUpdate_stateCode_length_le + hd E a hM + simpa only [d, p, E₁, + scheduledFeasibilityStateCodeBound] using! hcode + Β· have hbudget' : (t + 1) + iterations ≀ T := by omega + exact ih (t := t + 1) (E := E₁) hE₁ hbudget' + +theorem explicitBallMachineBetheFeasibilityFits + {m : β„•} (hm : 0 < m) + {tau : β„š} (htau0 : 0 ≀ tau) (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hA : βˆ€ i j, 0 < A i j) + (oraclePrecision : β„•) {delta : RawRat} + (hdelta : 0 < delta.value) (upper : RawRat) + (budget : β„•) {R : β„š} (hR : 0 < R) : + MachineBetheFeasibilityFits tau A oraclePrecision delta upper + (explicitBallFeasibilityPrecision (m * m + 1) budget R) + (explicitBallFeasibilityStateCodeBound (m * m + 1) budget R) + budget (rationalBallEllipsoid (m * m + 1) 0 R) := by + let d := m * m + 1 + let L := explicitBallInitialDetExponent d R + let K := explicitBallInitialMagnitudeExponent d R + have hInv : ScheduledEllipsoidInvariant d L K 0 + (rationalBallEllipsoid d 0 R) := by + simpa only [d, L, K] using! explicitBallInitialInvariant hR + have hvalid := scannedBetheBoundedEpigraphOracle_valid + hm htau0 htau1 hA hdelta oraclePrecision upper + have hfit := MachineBetheFeasibilityFits.of_invariant + (L := L) (K := K) (T := budget) (t := 0) (iterations := budget) + tau A oraclePrecision delta upper hvalid + (rationalBallEllipsoid d 0 R) hInv (by omega) + simpa only [d, L, K, explicitBallFeasibilityPrecision, + explicitBallFeasibilityStateCodeBound] using! hfit + +theorem machineExplicitBallBetheFeasibilityResultCode_encode + {m : β„•} (hm : 0 < m) + {tau : β„š} (htau0 : 0 ≀ tau) (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hA : βˆ€ i j, 0 < A i j) + (oraclePrecision : β„•) {delta : RawRat} + (hdelta : 0 < delta.value) (upper : RawRat) + (budget : β„•) {R : β„š} (hR : 0 < R) : + machineBetheFeasibilityResultCode + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper + (explicitBallFeasibilityPrecision (m * m + 1) budget R) + budget + (explicitBallFeasibilityStateCodeBound (m * m + 1) budget R) + (rationalBallEllipsoid (m * m + 1) 0 R)) = + rationalFeasibilityResultBinaryCode + (runExplicitBallRationalFeasibility + (scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper) budget R) := by + rw [runExplicitBallRationalFeasibility] + exact machineBetheFeasibilityResultCode_encode tau A oraclePrecision + delta upper + (explicitBallFeasibilityPrecision (m * m + 1) budget R) + budget (explicitBallFeasibilityStateCodeBound (m * m + 1) budget R) + (rationalBallEllipsoid (m * m + 1) 0 R) + (explicitBallMachineBetheFeasibilityFits hm htau0 htau1 hA + oraclePrecision hdelta upper budget hR) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityLoop.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityLoop.lean new file mode 100644 index 0000000000..a1dbf7e2d3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilityLoop.lean @@ -0,0 +1,696 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheThresholdFeasibility +public import Mathlib.Tactic + +/-! +# A finite-word fixed-precision Bethe feasibility loop + +The loop stores the immutable call word beside the current ellipsoid. Every +new ellipsoid word is clamped to an explicit ruler stored in the call. This +makes the iteration polynomial-time on every malformed input. A separate +semantic predicate records that the clamp is inactive on the canonical run. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Call layout -/ + +/-- Call layout: +`pair budgetUnary (pair stateBound (pair roundingPrecisionUnary + (pair oracleStatic initialEllipsoid)))`. + +The oracle-static word has layout +`pair mUnary (pair oraclePrecisionUnary (pair tauRaw + (pair deltaRaw (pair upperRaw matrixCode))))`. -/ +def machineBetheFeasibilityBudget (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the feasibility input payload following its iteration budget. -/ +def machineBetheFeasibilityAfterBudget (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the state-code bound word from a feasibility input. -/ +def machineBetheFeasibilityBound (word : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityAfterBudget word) + +/-- Extract the feasibility payload following the state-code bound word. -/ +def machineBetheFeasibilityAfterBound (word : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityAfterBudget word) + +/-- Extract the rounding-precision ruler from a feasibility input. -/ +def machineBetheFeasibilityRoundingPrecision + (word : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityAfterBound word) + +/-- Extract the static oracle data and initial ellipsoid payload. -/ +def machineBetheFeasibilityStaticAndInitial + (word : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityAfterBound word) + +/-- Extract the static oracle data retained throughout the feasibility iteration. -/ +def machineBetheFeasibilityOracleStatic + (word : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityStaticAndInitial word) + +/-- Extract the initial ellipsoid code from the feasibility input. -/ +def machineBetheFeasibilityInitialEllipsoid + (word : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityStaticAndInitial word) + +/-! ## Iteration state -/ + +/-- Encode the acceptance flag, original input, current ellipsoid, and bound as a feasibility +state. -/ +def machineBetheFeasibilityStatePack + (accepted source ellipsoid bound : List Bool) : List Bool := + pair accepted (pair source (pair ellipsoid bound)) + +/-- Extract the acceptance-flag word from a feasibility state. -/ +def machineBetheFeasibilityStateAccepted + (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the original feasibility input retained in the state. -/ +def machineBetheFeasibilityStateSource + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the current ellipsoid code from a feasibility state. -/ +def machineBetheFeasibilityStateEllipsoid + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extract the stored bound word from a feasibility state. -/ +def machineBetheFeasibilityStateBound + (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Initialize feasibility with a false acceptance flag and the supplied initial ellipsoid and +code bound. -/ +def machineBetheFeasibilityInit (word : List Bool) : List Bool := + machineBetheFeasibilityStatePack [false] word + (machineBetheFeasibilityInitialEllipsoid word) + (machineBetheFeasibilityBound word) + +/-! ## One oracle/update step -/ + +/-- Extract the static oracle dimension ruler from a feasibility state. -/ +def machineBetheFeasibilityStaticDimension + (state : List Bool) : List Bool := + machinePairFirst + (machineBetheFeasibilityOracleStatic + (machineBetheFeasibilityStateSource state)) + +/-- Extract the static oracle payload following the dimension ruler. -/ +def machineBetheFeasibilityStaticRest + (state : List Bool) : List Bool := + machinePairSecond + (machineBetheFeasibilityOracleStatic + (machineBetheFeasibilityStateSource state)) + +/-- Extract the static oracle precision ruler from a feasibility state. -/ +def machineBetheFeasibilityStaticOraclePrecision + (state : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityStaticRest state) + +/-- Extract the static oracle payload following its precision ruler. -/ +def machineBetheFeasibilityStaticAfterPrecision + (state : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityStaticRest state) + +/-- Extract the static regularization parameter from a feasibility state. -/ +def machineBetheFeasibilityStaticTau + (state : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityStaticAfterPrecision state) + +/-- Extract the static oracle payload following the regularization parameter. -/ +def machineBetheFeasibilityStaticAfterTau + (state : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityStaticAfterPrecision state) + +/-- Extract the raw-rational floor parameter from the immutable feasibility oracle data. -/ +def machineBetheFeasibilityStaticDelta + (state : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityStaticAfterTau state) + +/-- The immutable oracle payload following the floor parameter, containing the upper threshold +and matrix. -/ +def machineBetheFeasibilityStaticAfterDelta + (state : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityStaticAfterTau state) + +/-- Extract the raw-rational objective upper threshold from the immutable oracle data. -/ +def machineBetheFeasibilityStaticUpper + (state : List Bool) : List Bool := + machinePairFirst (machineBetheFeasibilityStaticAfterDelta state) + +/-- Extract the encoded rational matrix from the immutable oracle data. -/ +def machineBetheFeasibilityStaticMatrix + (state : List Bool) : List Bool := + machinePairSecond (machineBetheFeasibilityStaticAfterDelta state) + +/-- Package the static dimension, precision, regularization, floor, upper threshold, and matrix +with the current ellipsoid for an oracle call. -/ +def machineBetheFeasibilityOracleInput + (state : List Bool) : List Bool := + pair (machineBetheFeasibilityStaticDimension state) + (pair (machineBetheFeasibilityStaticOraclePrecision state) + (pair (machineBetheFeasibilityStaticTau state) + (pair (machineBetheFeasibilityStaticDelta state) + (pair (machineBetheFeasibilityStaticUpper state) + (pair (machineBetheFeasibilityStaticMatrix state) + (machineBetheFeasibilityStateEllipsoid state)))))) + +/-- Run the encoded bounded Bethe epigraph oracle on the current feasibility state. -/ +def machineBetheFeasibilityOracleResponse + (state : List Bool) : List Bool := + machineBetheEpigraphOracleResponseCode + (machineBetheFeasibilityOracleInput state) + +/-- The oracle response bit, which selects a cut when true and acceptance when false. -/ +def machineBetheFeasibilityResponseTag + (state : List Bool) : List Bool := + machineHeadBit (machineRationalTaggedResultTag + (machineBetheFeasibilityOracleResponse state)) + +/-- Extract the payload of the tagged oracle response, used as the cut normal when a cut is +returned. -/ +def machineBetheFeasibilityResponsePayload + (state : List Bool) : List Bool := + machineRationalTaggedResultPayload + (machineBetheFeasibilityOracleResponse state) + +/-- Package the stored rounding precision, current ellipsoid, and oracle cut payload for the +scheduled update. -/ +def machineBetheFeasibilityScheduledUpdateInput + (state : List Bool) : List Bool := + pair (machineBetheFeasibilityRoundingPrecision + (machineBetheFeasibilityStateSource state)) + (pair (machineBetheFeasibilityStateEllipsoid state) + (machineBetheFeasibilityResponsePayload state)) + +/-- Compute the scheduled rounded central-cut ellipsoid before imposing the stored code-length +bound. -/ +def machineBetheFeasibilityUpdatedEllipsoidCandidate + (state : List Bool) : List Bool := + machineScheduledRoundedEllipsoidCentralUpdateCode + (machineBetheFeasibilityScheduledUpdateInput state) + +/-- Truncate the candidate ellipsoid code to the length of the state-bound word. -/ +def machineBetheFeasibilityUpdatedEllipsoid + (state : List Bool) : List Bool := + (machineBetheFeasibilityUpdatedEllipsoidCandidate state).take + (machineBetheFeasibilityStateBound state).length + +/-- Store an unaccepted state with the truncated updated ellipsoid, retaining the source call +and bound. -/ +def machineBetheFeasibilityCutState + (state : List Bool) : List Bool := + machineBetheFeasibilityStatePack [false] + (machineBetheFeasibilityStateSource state) + (machineBetheFeasibilityUpdatedEllipsoid state) + (machineBetheFeasibilityStateBound state) + +/-- Mark the current state accepted while retaining its source call, ellipsoid, and bound. -/ +def machineBetheFeasibilityAcceptState + (state : List Bool) : List Bool := + machineBetheFeasibilityStatePack [true] + (machineBetheFeasibilityStateSource state) + (machineBetheFeasibilityStateEllipsoid state) + (machineBetheFeasibilityStateBound state) + +/-- Leave an accepted state fixed; otherwise perform the oracle's cut update or mark the current +ellipsoid accepted. -/ +def machineBetheFeasibilityStep (state : List Bool) : List Bool := + machineIfHead (machineHeadBit + (machineBetheFeasibilityStateAccepted state)) state + (machineIfHead (machineBetheFeasibilityResponseTag state) + (machineBetheFeasibilityCutState state) + (machineBetheFeasibilityAcceptState state)) + +/-! ## Final result -/ + +/-- Iterate the feasibility transition from its initial state for the length of the supplied +budget word. -/ +def machineBetheFeasibilityFinalState (word : List Bool) : List Bool := + (machineBetheFeasibilityStep)^[(machineBetheFeasibilityBudget word).length] + (machineBetheFeasibilityInit word) + +/-- Encode an accepted center with the false tag, or the final unaccepted ellipsoid with the +true tag. -/ +def machineBetheFeasibilityStateResultCode + (state : List Bool) : List Bool := + machineIfHead (machineHeadBit + (machineBetheFeasibilityStateAccepted state)) + (pair [false] + (machineRationalEllipsoidCenterWord + (machineBetheFeasibilityStateEllipsoid state))) + (pair [true] (machineBetheFeasibilityStateEllipsoid state)) + +/-- Extract the tagged feasibility result after the prescribed number of encoded transitions. -/ +def machineBetheFeasibilityResultCode (word : List Bool) : List Bool := + machineBetheFeasibilityStateResultCode + (machineBetheFeasibilityFinalState word) + +/-! ## Polynomial-time closure of accessors and one step -/ + +theorem machineBetheFeasibilityBudget_mem_FP : + machineBetheFeasibilityBudget ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFeasibilityAfterBudget_mem_FP : + machineBetheFeasibilityAfterBudget ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFeasibilityBound_mem_FP : + machineBetheFeasibilityBound ∈ FP := by + simpa only [machineBetheFeasibilityBound] using! + machineCompose_mem_FP machineBetheFeasibilityAfterBudget_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityAfterBound_mem_FP : + machineBetheFeasibilityAfterBound ∈ FP := by + simpa only [machineBetheFeasibilityAfterBound] using! + machineCompose_mem_FP machineBetheFeasibilityAfterBudget_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityRoundingPrecision_mem_FP : + machineBetheFeasibilityRoundingPrecision ∈ FP := by + simpa only [machineBetheFeasibilityRoundingPrecision] using! + machineCompose_mem_FP machineBetheFeasibilityAfterBound_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticAndInitial_mem_FP : + machineBetheFeasibilityStaticAndInitial ∈ FP := by + simpa only [machineBetheFeasibilityStaticAndInitial] using! + machineCompose_mem_FP machineBetheFeasibilityAfterBound_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityOracleStatic_mem_FP : + machineBetheFeasibilityOracleStatic ∈ FP := by + simpa only [machineBetheFeasibilityOracleStatic] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAndInitial_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityInitialEllipsoid_mem_FP : + machineBetheFeasibilityInitialEllipsoid ∈ FP := by + simpa only [machineBetheFeasibilityInitialEllipsoid] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAndInitial_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityStateAccepted_mem_FP : + machineBetheFeasibilityStateAccepted ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStateSource_mem_FP : + machineBetheFeasibilityStateSource ∈ FP := by + simpa only [machineBetheFeasibilityStateSource] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStateEllipsoid_mem_FP : + machineBetheFeasibilityStateEllipsoid ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheFeasibilityStateEllipsoid] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStateBound_mem_FP : + machineBetheFeasibilityStateBound ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheFeasibilityStateBound] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineBetheFeasibilityInit_mem_FP : + machineBetheFeasibilityInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineBetheFeasibilityInitialEllipsoid_mem_FP + machineBetheFeasibilityBound_mem_FP)) + +theorem machineBetheFeasibilityStaticDimension_mem_FP : + machineBetheFeasibilityStaticDimension ∈ FP := by + have hstatic := machineCompose_mem_FP + machineBetheFeasibilityStateSource_mem_FP + machineBetheFeasibilityOracleStatic_mem_FP + simpa only [machineBetheFeasibilityStaticDimension] using! + machineCompose_mem_FP hstatic machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticRest_mem_FP : + machineBetheFeasibilityStaticRest ∈ FP := by + have hstatic := machineCompose_mem_FP + machineBetheFeasibilityStateSource_mem_FP + machineBetheFeasibilityOracleStatic_mem_FP + simpa only [machineBetheFeasibilityStaticRest] using! + machineCompose_mem_FP hstatic machinePairSecond_mem_FP + +theorem machineBetheFeasibilityStaticOraclePrecision_mem_FP : + machineBetheFeasibilityStaticOraclePrecision ∈ FP := by + simpa only [machineBetheFeasibilityStaticOraclePrecision] using! + machineCompose_mem_FP machineBetheFeasibilityStaticRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticAfterPrecision_mem_FP : + machineBetheFeasibilityStaticAfterPrecision ∈ FP := by + simpa only [machineBetheFeasibilityStaticAfterPrecision] using! + machineCompose_mem_FP machineBetheFeasibilityStaticRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityStaticTau_mem_FP : + machineBetheFeasibilityStaticTau ∈ FP := by + simpa only [machineBetheFeasibilityStaticTau] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterPrecision_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticAfterTau_mem_FP : + machineBetheFeasibilityStaticAfterTau ∈ FP := by + simpa only [machineBetheFeasibilityStaticAfterTau] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterPrecision_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityStaticDelta_mem_FP : + machineBetheFeasibilityStaticDelta ∈ FP := by + simpa only [machineBetheFeasibilityStaticDelta] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterTau_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticAfterDelta_mem_FP : + machineBetheFeasibilityStaticAfterDelta ∈ FP := by + simpa only [machineBetheFeasibilityStaticAfterDelta] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterTau_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityStaticUpper_mem_FP : + machineBetheFeasibilityStaticUpper ∈ FP := by + simpa only [machineBetheFeasibilityStaticUpper] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterDelta_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFeasibilityStaticMatrix_mem_FP : + machineBetheFeasibilityStaticMatrix ∈ FP := by + simpa only [machineBetheFeasibilityStaticMatrix] using! + machineCompose_mem_FP machineBetheFeasibilityStaticAfterDelta_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFeasibilityOracleInput_mem_FP : + machineBetheFeasibilityOracleInput ∈ FP := + machinePair_mem_FP machineBetheFeasibilityStaticDimension_mem_FP + (machinePair_mem_FP + machineBetheFeasibilityStaticOraclePrecision_mem_FP + (machinePair_mem_FP machineBetheFeasibilityStaticTau_mem_FP + (machinePair_mem_FP machineBetheFeasibilityStaticDelta_mem_FP + (machinePair_mem_FP machineBetheFeasibilityStaticUpper_mem_FP + (machinePair_mem_FP machineBetheFeasibilityStaticMatrix_mem_FP + machineBetheFeasibilityStateEllipsoid_mem_FP))))) + +theorem machineBetheFeasibilityOracleResponse_mem_FP : + machineBetheFeasibilityOracleResponse ∈ FP := by + simpa only [machineBetheFeasibilityOracleResponse] using! + machineCompose_mem_FP machineBetheFeasibilityOracleInput_mem_FP + machineBetheEpigraphOracleResponseCode_mem_FP + +theorem machineBetheFeasibilityResponseTag_mem_FP : + machineBetheFeasibilityResponseTag ∈ FP := by + have htag := machineCompose_mem_FP + machineBetheFeasibilityOracleResponse_mem_FP + machineRationalTaggedResultTag_mem_FP + simpa only [machineBetheFeasibilityResponseTag] using! + machineCompose_mem_FP htag machineHeadBit_mem_FP + +theorem machineBetheFeasibilityResponsePayload_mem_FP : + machineBetheFeasibilityResponsePayload ∈ FP := by + simpa only [machineBetheFeasibilityResponsePayload] using! + machineCompose_mem_FP machineBetheFeasibilityOracleResponse_mem_FP + machineRationalTaggedResultPayload_mem_FP + +theorem machineBetheFeasibilityScheduledUpdateInput_mem_FP : + machineBetheFeasibilityScheduledUpdateInput ∈ FP := by + have hp := machineCompose_mem_FP + machineBetheFeasibilityStateSource_mem_FP + machineBetheFeasibilityRoundingPrecision_mem_FP + exact machinePair_mem_FP hp + (machinePair_mem_FP machineBetheFeasibilityStateEllipsoid_mem_FP + machineBetheFeasibilityResponsePayload_mem_FP) + +theorem machineBetheFeasibilityUpdatedEllipsoidCandidate_mem_FP : + machineBetheFeasibilityUpdatedEllipsoidCandidate ∈ FP := by + simpa only [machineBetheFeasibilityUpdatedEllipsoidCandidate] using! + machineCompose_mem_FP + machineBetheFeasibilityScheduledUpdateInput_mem_FP + machineScheduledRoundedEllipsoidCentralUpdateCode_mem_FP + +theorem machineBetheFeasibilityUpdatedEllipsoid_mem_FP : + machineBetheFeasibilityUpdatedEllipsoid ∈ FP := by + simpa only [machineBetheFeasibilityUpdatedEllipsoid] using! + machineTake_mem_FP machineBetheFeasibilityStateBound_mem_FP + machineBetheFeasibilityUpdatedEllipsoidCandidate_mem_FP + +theorem machineBetheFeasibilityCutState_mem_FP : + machineBetheFeasibilityCutState ∈ FP := + machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP machineBetheFeasibilityStateSource_mem_FP + (machinePair_mem_FP machineBetheFeasibilityUpdatedEllipsoid_mem_FP + machineBetheFeasibilityStateBound_mem_FP)) + +theorem machineBetheFeasibilityAcceptState_mem_FP : + machineBetheFeasibilityAcceptState ∈ FP := + machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineBetheFeasibilityStateSource_mem_FP + (machinePair_mem_FP machineBetheFeasibilityStateEllipsoid_mem_FP + machineBetheFeasibilityStateBound_mem_FP)) + +theorem machineBetheFeasibilityStep_mem_FP : + machineBetheFeasibilityStep ∈ FP := by + have haccepted := machineCompose_mem_FP + machineBetheFeasibilityStateAccepted_mem_FP machineHeadBit_mem_FP + have hbranch := machineIfHead_mem_FP + machineBetheFeasibilityResponseTag_mem_FP + machineBetheFeasibilityCutState_mem_FP + machineBetheFeasibilityAcceptState_mem_FP + simpa only [machineBetheFeasibilityStep] using! + machineIfHead_mem_FP haccepted id_mem_FP hbranch + +theorem machineBetheFeasibilityStateResultCode_mem_FP : + machineBetheFeasibilityStateResultCode ∈ FP := by + have htest := machineCompose_mem_FP + machineBetheFeasibilityStateAccepted_mem_FP machineHeadBit_mem_FP + have hcenter := machineCompose_mem_FP + machineBetheFeasibilityStateEllipsoid_mem_FP + machineRationalEllipsoidCenterWord_mem_FP + exact machineIfHead_mem_FP htest + (machinePair_mem_FP (machineConst_mem_FP [false]) hcenter) + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineBetheFeasibilityStateEllipsoid_mem_FP) + +/-! ## Global state envelope and polynomial iteration -/ + +@[simp] theorem machineBetheFeasibilityStateAccepted_pack + (accepted source ellipsoid bound : List Bool) : + machineBetheFeasibilityStateAccepted + (machineBetheFeasibilityStatePack accepted source ellipsoid bound) = + accepted := by + simp [machineBetheFeasibilityStateAccepted, + machineBetheFeasibilityStatePack] + +@[simp] theorem machineBetheFeasibilityStateSource_pack + (accepted source ellipsoid bound : List Bool) : + machineBetheFeasibilityStateSource + (machineBetheFeasibilityStatePack accepted source ellipsoid bound) = + source := by + simp [machineBetheFeasibilityStateSource, + machineBetheFeasibilityStatePack] + +@[simp] theorem machineBetheFeasibilityStateEllipsoid_pack + (accepted source ellipsoid bound : List Bool) : + machineBetheFeasibilityStateEllipsoid + (machineBetheFeasibilityStatePack accepted source ellipsoid bound) = + ellipsoid := by + simp [machineBetheFeasibilityStateEllipsoid, + machineBetheFeasibilityStatePack] + +@[simp] theorem machineBetheFeasibilityStateBound_pack + (accepted source ellipsoid bound : List Bool) : + machineBetheFeasibilityStateBound + (machineBetheFeasibilityStatePack accepted source ellipsoid bound) = + bound := by + simp [machineBetheFeasibilityStateBound, + machineBetheFeasibilityStatePack] + +/-- The state has the canonical four-field layout, an acceptance word of length at most one, and +source, ellipsoid, and bound words no longer than the original input. -/ +def MachineBetheFeasibilityStateBound + (word state : List Bool) : Prop := + state = machineBetheFeasibilityStatePack + (machineBetheFeasibilityStateAccepted state) + (machineBetheFeasibilityStateSource state) + (machineBetheFeasibilityStateEllipsoid state) + (machineBetheFeasibilityStateBound state) ∧ + (machineBetheFeasibilityStateAccepted state).length ≀ 1 ∧ + (machineBetheFeasibilityStateSource state).length ≀ word.length ∧ + (machineBetheFeasibilityStateEllipsoid state).length ≀ word.length ∧ + (machineBetheFeasibilityStateBound state).length ≀ word.length + +theorem machineBetheFeasibilityBound_length_le (word : List Bool) : + (machineBetheFeasibilityBound word).length ≀ word.length := by + exact (machinePairFirst_length_le + (machineBetheFeasibilityAfterBudget word)).trans + (machinePairSecond_length_le word) + +theorem machineBetheFeasibilityInitialEllipsoid_length_le + (word : List Bool) : + (machineBetheFeasibilityInitialEllipsoid word).length ≀ word.length := by + exact (machinePairSecond_length_le + (machineBetheFeasibilityStaticAndInitial word)).trans + ((machinePairSecond_length_le + (machineBetheFeasibilityAfterBound word)).trans + ((machinePairSecond_length_le + (machineBetheFeasibilityAfterBudget word)).trans + (machinePairSecond_length_le word))) + +theorem machineBetheFeasibilityInit_bound (word : List Bool) : + MachineBetheFeasibilityStateBound word + (machineBetheFeasibilityInit word) := by + simp only [machineBetheFeasibilityInit, + MachineBetheFeasibilityStateBound, + machineBetheFeasibilityStateAccepted_pack, + machineBetheFeasibilityStateSource_pack, + machineBetheFeasibilityStateEllipsoid_pack, + machineBetheFeasibilityStateBound_pack, List.length_singleton] + exact ⟨trivial, by simp, le_rfl, + machineBetheFeasibilityInitialEllipsoid_length_le word, + machineBetheFeasibilityBound_length_le word⟩ + +theorem machineBetheFeasibilityCutState_bound {word state : List Bool} + (hs : MachineBetheFeasibilityStateBound word state) : + MachineBetheFeasibilityStateBound word + (machineBetheFeasibilityCutState state) := by + rcases hs with ⟨hdecomp, haccepted, hsource, hellipsoid, hbound⟩ + simp only [machineBetheFeasibilityCutState, + MachineBetheFeasibilityStateBound, + machineBetheFeasibilityStateAccepted_pack, + machineBetheFeasibilityStateSource_pack, + machineBetheFeasibilityStateEllipsoid_pack, + machineBetheFeasibilityStateBound_pack, List.length_singleton] + refine ⟨trivial, by simp, hsource, ?_, hbound⟩ + exact (List.length_take_le _ _).trans hbound + +theorem machineBetheFeasibilityAcceptState_bound {word state : List Bool} + (hs : MachineBetheFeasibilityStateBound word state) : + MachineBetheFeasibilityStateBound word + (machineBetheFeasibilityAcceptState state) := by + rcases hs with ⟨hdecomp, haccepted, hsource, hellipsoid, hbound⟩ + simp only [machineBetheFeasibilityAcceptState, + MachineBetheFeasibilityStateBound, + machineBetheFeasibilityStateAccepted_pack, + machineBetheFeasibilityStateSource_pack, + machineBetheFeasibilityStateEllipsoid_pack, + machineBetheFeasibilityStateBound_pack, List.length_singleton] + exact ⟨trivial, by simp, hsource, hellipsoid, hbound⟩ + +theorem machineBetheFeasibilityStep_bound {word state : List Bool} + (hs : MachineBetheFeasibilityStateBound word state) : + MachineBetheFeasibilityStateBound word + (machineBetheFeasibilityStep state) := by + rw [machineBetheFeasibilityStep] + cases ha : machineBetheFeasibilityStateAccepted state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + rw [machineBetheFeasibilityResponseTag] + cases hr : machineRationalTaggedResultTag + (machineBetheFeasibilityOracleResponse state) with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFeasibilityAcceptState_bound hs + | cons responseBit responseTail => + rw [machineHeadBit_cons] + cases responseBit + Β· rw [machineIfHead_false] + exact machineBetheFeasibilityAcceptState_bound hs + Β· rw [machineIfHead_true] + exact machineBetheFeasibilityCutState_bound hs + | cons acceptedBit acceptedTail => + rw [machineHeadBit_cons] + cases acceptedBit + Β· rw [machineIfHead_false] + rw [machineBetheFeasibilityResponseTag] + cases hr : machineRationalTaggedResultTag + (machineBetheFeasibilityOracleResponse state) with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFeasibilityAcceptState_bound hs + | cons responseBit responseTail => + rw [machineHeadBit_cons] + cases responseBit + Β· rw [machineIfHead_false] + exact machineBetheFeasibilityAcceptState_bound hs + Β· rw [machineIfHead_true] + exact machineBetheFeasibilityCutState_bound hs + Β· rw [machineIfHead_true] + exact hs + +theorem machineBetheFeasibilityIterate_bound (word : List Bool) : βˆ€ k, + MachineBetheFeasibilityStateBound word + ((machineBetheFeasibilityStep)^[k] + (machineBetheFeasibilityInit word)) := by + intro k + induction k with + | zero => exact machineBetheFeasibilityInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineBetheFeasibilityStep_bound ih + +/-- A uniform state-width envelope obtained by packing four copies of the input prefixed by one +false bit. -/ +def machineBetheFeasibilityWidth (word : List Bool) : List Bool := + let envelope := [false] ++ word + machineBetheFeasibilityStatePack envelope envelope envelope envelope + +theorem machineBetheFeasibilityWidth_mem_FP : + machineBetheFeasibilityWidth ∈ FP := by + have henvelope : (fun word : List Bool ↦ false :: word) ∈ FP := + by simpa only [List.singleton_append] using! + machineAppend_mem_FP (machineConst_mem_FP [false]) id_mem_FP + simpa only [machineBetheFeasibilityWidth] using! + machinePair_mem_FP henvelope + (machinePair_mem_FP henvelope + (machinePair_mem_FP henvelope henvelope)) + +theorem machineBetheFeasibilityIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_hiterations : iterations ≀ + (machineBetheFeasibilityBudget word).length) : + ((machineBetheFeasibilityStep)^[iterations] + (machineBetheFeasibilityInit word)).length ≀ + (machineBetheFeasibilityWidth word).length := by + rcases machineBetheFeasibilityIterate_bound word iterations with + ⟨hdecomp, haccepted, hsource, hellipsoid, hbound⟩ + rw [hdecomp] + simp only [machineBetheFeasibilityStatePack, + machineBetheFeasibilityWidth, pair_length, List.length_append, + List.length_singleton] + omega + +theorem machineBetheFeasibilityFinalState_mem_FP : + machineBetheFeasibilityFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineBetheFeasibilityStep_mem_FP + machineBetheFeasibilityInit_mem_FP machineBetheFeasibilityBudget_mem_FP + machineBetheFeasibilityWidth_mem_FP + machineBetheFeasibilityIterate_length_le_width + +theorem machineBetheFeasibilityResultCode_mem_FP : + machineBetheFeasibilityResultCode ∈ FP := by + simpa only [machineBetheFeasibilityResultCode] using! + machineCompose_mem_FP machineBetheFeasibilityFinalState_mem_FP + machineBetheFeasibilityStateResultCode_mem_FP + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilitySemantics.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilitySemantics.lean new file mode 100644 index 0000000000..14770cd660 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFeasibilitySemantics.lean @@ -0,0 +1,540 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityLoop +public import Mathlib.Tactic + +/-! +# Semantics of the finite-word Bethe feasibility loop + +This file connects the finite-word iterator to the recursive rational +feasibility algorithm. The only intermediate side condition is the explicit +statement that every canonical updated ellipsoid fits the ruler carried by the +call word. A later encoding-bound theorem discharges that condition for the +public schedule. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Canonical calls and states -/ + +/-- Encode the fixed oracle data with unary dimension and precision, raw-rational parameters, +and the rational matrix code. -/ +def machineBetheFeasibilityCanonicalStaticWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) : List Bool := + pair (List.replicate m true) + (pair (List.replicate oraclePrecision true) + (pair (rawRatBinaryCode (rawRatOfRat tau)) + (pair (rawRatBinaryCode delta) + (pair (rawRatBinaryCode upper) + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩))))) + +/-- Encode a feasibility call with unary iteration, state-length, and rounding bounds, followed +by its static oracle data and initial ellipsoid. -/ +def machineBetheFeasibilityCanonicalWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : List Bool := + pair (List.replicate budget true) + (pair (List.replicate stateBound true) + (pair (List.replicate roundingPrecision true) + (pair + (machineBetheFeasibilityCanonicalStaticWord + tau A oraclePrecision delta upper) + (rationalEllipsoidStateBinaryCode initial)))) + +/-- Encode a semantic feasibility state with its acceptance bit, original canonical call, +current ellipsoid, and unary length bound. -/ +def machineBetheFeasibilityCanonicalState {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : List Bool := + machineBetheFeasibilityStatePack [accepted] + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision delta upper + roundingPrecision budget stateBound initial) + (rationalEllipsoidStateBinaryCode current) + (List.replicate stateBound true) + +@[simp] theorem machineBetheFeasibilityBudget_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityBudget + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + List.replicate budget true := by + rw [machineBetheFeasibilityBudget, + machineBetheFeasibilityCanonicalWord, machinePairFirst_pair] + +@[simp] theorem machineBetheFeasibilityBound_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityBound + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + List.replicate stateBound true := by + rw [machineBetheFeasibilityBound, machineBetheFeasibilityAfterBudget, + machineBetheFeasibilityCanonicalWord, machinePairSecond_pair, + machinePairFirst_pair] + +@[simp] theorem machineBetheFeasibilityRoundingPrecision_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityRoundingPrecision + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + List.replicate roundingPrecision true := by + rw [machineBetheFeasibilityRoundingPrecision, + machineBetheFeasibilityAfterBound, + machineBetheFeasibilityAfterBudget, + machineBetheFeasibilityCanonicalWord] + simp only [machinePairSecond_pair, machinePairFirst_pair] + +@[simp] theorem machineBetheFeasibilityOracleStatic_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityOracleStatic + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + machineBetheFeasibilityCanonicalStaticWord + tau A oraclePrecision delta upper := by + rw [machineBetheFeasibilityOracleStatic, + machineBetheFeasibilityStaticAndInitial, + machineBetheFeasibilityAfterBound, + machineBetheFeasibilityAfterBudget, + machineBetheFeasibilityCanonicalWord] + simp only [machinePairSecond_pair, machinePairFirst_pair] + +@[simp] theorem machineBetheFeasibilityInitialEllipsoid_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityInitialEllipsoid + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + rationalEllipsoidStateBinaryCode initial := by + rw [machineBetheFeasibilityInitialEllipsoid, + machineBetheFeasibilityStaticAndInitial, + machineBetheFeasibilityAfterBound, + machineBetheFeasibilityAfterBudget, + machineBetheFeasibilityCanonicalWord] + simp only [machinePairSecond_pair] + +@[simp] theorem machineBetheFeasibilityInit_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityInit + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial initial := by + rw [machineBetheFeasibilityInit, + machineBetheFeasibilityInitialEllipsoid_encode, + machineBetheFeasibilityBound_encode] + rfl + +@[simp] theorem machineBetheFeasibilityStateAccepted_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateAccepted + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + [accepted] := by + rw [machineBetheFeasibilityCanonicalState, + machineBetheFeasibilityStateAccepted_pack] + +@[simp] theorem machineBetheFeasibilityStateSource_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateSource + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheFeasibilityCanonicalWord tau A oraclePrecision delta upper + roundingPrecision budget stateBound initial := by + rw [machineBetheFeasibilityCanonicalState, + machineBetheFeasibilityStateSource_pack] + +@[simp] theorem machineBetheFeasibilityStateEllipsoid_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateEllipsoid + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalEllipsoidStateBinaryCode current := by + rw [machineBetheFeasibilityCanonicalState, + machineBetheFeasibilityStateEllipsoid_pack] + +@[simp] theorem machineBetheFeasibilityStateBound_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateBound + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + List.replicate stateBound true := by + rw [machineBetheFeasibilityCanonicalState, + machineBetheFeasibilityStateBound_pack] + +@[simp] theorem machineBetheFeasibilityOracleInput_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityOracleInput + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheOracleCanonicalWord + tau A oraclePrecision delta upper current := by + simp only [machineBetheFeasibilityOracleInput, + machineBetheFeasibilityStaticDimension, + machineBetheFeasibilityStaticRest, + machineBetheFeasibilityStaticOraclePrecision, + machineBetheFeasibilityStaticAfterPrecision, + machineBetheFeasibilityStaticTau, + machineBetheFeasibilityStaticAfterTau, + machineBetheFeasibilityStaticDelta, + machineBetheFeasibilityStaticAfterDelta, + machineBetheFeasibilityStaticUpper, + machineBetheFeasibilityStaticMatrix, + machineBetheFeasibilityStateSource_encode, + machineBetheFeasibilityOracleStatic_encode, + machineBetheFeasibilityStateEllipsoid_encode, + machineBetheFeasibilityCanonicalStaticWord, + machineBetheOracleCanonicalWord, machinePairFirst_pair, + machinePairSecond_pair] + +@[simp] theorem machineBetheFeasibilityOracleResponse_encode {m : β„•} + (accepted : Bool) + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityOracleResponse + (machineBetheFeasibilityCanonicalState accepted tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalCentralOracleResponseBinaryCode + (scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current) := by + rw [machineBetheFeasibilityOracleResponse, + machineBetheFeasibilityOracleInput_encode, + machineBetheEpigraphOracleResponseCode_encode] + +/-! ## Exact one-step behavior -/ + +@[simp] theorem machineBetheFeasibilityStep_accepted_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStep + (machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current := by + rw [machineBetheFeasibilityStep] + simp only [machineBetheFeasibilityStateAccepted_encode, + machineHeadBit_cons, machineIfHead_true] + +theorem machineBetheFeasibilityResponseTag_accept_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .accept) : + machineBetheFeasibilityResponseTag + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + [false] := by + rw [machineBetheFeasibilityResponseTag, + machineBetheFeasibilityOracleResponse_encode, hresponse] + rfl + +theorem machineBetheFeasibilityStep_accept_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .accept) : + machineBetheFeasibilityStep + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current := by + rw [machineBetheFeasibilityStep] + simp only [machineBetheFeasibilityStateAccepted_encode, + machineHeadBit_cons, machineIfHead_false] + rw [machineBetheFeasibilityResponseTag_accept_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current hresponse] + rw [machineIfHead_false, machineBetheFeasibilityAcceptState, + machineBetheFeasibilityStateSource_encode, + machineBetheFeasibilityStateEllipsoid_encode, + machineBetheFeasibilityStateBound_encode] + rfl + +theorem machineBetheFeasibilityResponseTag_cut_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (a : Fin (m * m + 1) β†’ β„š) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .cut a) : + machineBetheFeasibilityResponseTag + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + [true] := by + rw [machineBetheFeasibilityResponseTag, + machineBetheFeasibilityOracleResponse_encode, hresponse] + rfl + +theorem machineBetheFeasibilityResponsePayload_cut_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (a : Fin (m * m + 1) β†’ β„š) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .cut a) : + machineBetheFeasibilityResponsePayload + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalFiniteVectorCode a := by + rw [machineBetheFeasibilityResponsePayload, + machineBetheFeasibilityOracleResponse_encode, hresponse] + rfl + +theorem machineBetheFeasibilityUpdatedCandidate_cut_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (a : Fin (m * m + 1) β†’ β„š) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .cut a) : + machineBetheFeasibilityUpdatedEllipsoidCandidate + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoidCentralUpdate + roundingPrecision current a) := by + rw [machineBetheFeasibilityUpdatedEllipsoidCandidate, + machineBetheFeasibilityScheduledUpdateInput] + rw [machineBetheFeasibilityStateSource_encode, + machineBetheFeasibilityRoundingPrecision_encode, + machineBetheFeasibilityStateEllipsoid_encode, + machineBetheFeasibilityResponsePayload_cut_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current a hresponse] + exact machineScheduledRoundedEllipsoidCentralUpdateCode_encode + roundingPrecision current a + +theorem machineBetheFeasibilityStep_cut_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (a : Fin (m * m + 1) β†’ β„š) + (hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current = .cut a) + (hfit : (rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoidCentralUpdate + roundingPrecision current a)).length ≀ stateBound) : + machineBetheFeasibilityStep + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial + (scheduledRoundedEllipsoidCentralUpdate + roundingPrecision current a) := by + have htag := machineBetheFeasibilityResponseTag_cut_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current a hresponse + rw [machineBetheFeasibilityStep] + rw [show machineHeadBit + (machineBetheFeasibilityStateAccepted + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current)) = + [false] by + rw [machineBetheFeasibilityStateAccepted_encode] + rfl] + rw [machineIfHead_false, htag] + rw [machineIfHead_true, machineBetheFeasibilityCutState] + rw [machineBetheFeasibilityStateSource_encode, + machineBetheFeasibilityStateBound_encode, + machineBetheFeasibilityUpdatedEllipsoid, + machineBetheFeasibilityUpdatedCandidate_cut_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current a hresponse] + rw [machineBetheFeasibilityStateBound_encode, List.length_replicate] + rw [List.take_of_length_le hfit] + rfl + +/-! ## The ruler condition and complete recursive semantics -/ + +/-- Every scheduled cut update reached during the remaining iterations fits the supplied +code-length bound; an accepted oracle response ends the requirement. -/ +def MachineBetheFeasibilityFits {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision stateBound : β„•) : + β„• β†’ RationalEllipsoidState (m * m + 1) β†’ Prop + | 0, _ => True + | iterations + 1, E => + match scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper E with + | .accept => True + | .cut a => + (rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoidCentralUpdate + roundingPrecision E a)).length ≀ stateBound ∧ + MachineBetheFeasibilityFits tau A oraclePrecision delta upper + roundingPrecision stateBound iterations + (scheduledRoundedEllipsoidCentralUpdate + roundingPrecision E a) + +theorem machineBetheFeasibilityIterate_accepted_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound iterations : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + (machineBetheFeasibilityStep^[iterations]) + (machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current := by + induction iterations with + | zero => rfl + | succ iterations ih => + rw [Function.iterate_succ_apply] + rw [machineBetheFeasibilityStep_accepted_encode] + exact ih + +theorem machineBetheFeasibilityStateResult_accepted_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateResultCode + (machineBetheFeasibilityCanonicalState true tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalFeasibilityResultBinaryCode (.accepted current.center) := by + simp [machineBetheFeasibilityStateResultCode, + machineBetheFeasibilityCanonicalState, + rationalFeasibilityResultBinaryCode] + +theorem machineBetheFeasibilityStateResult_exhausted_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) : + machineBetheFeasibilityStateResultCode + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current) = + rationalFeasibilityResultBinaryCode (.exhausted current) := by + simp [machineBetheFeasibilityStateResultCode, + machineBetheFeasibilityCanonicalState, + rationalFeasibilityResultBinaryCode] + +theorem machineBetheFeasibilityIterateResult_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound iterations : β„•) + (initial current : RationalEllipsoidState (m * m + 1)) + (hfit : MachineBetheFeasibilityFits tau A oraclePrecision delta upper + roundingPrecision stateBound iterations current) : + machineBetheFeasibilityStateResultCode + ((machineBetheFeasibilityStep^[iterations]) + (machineBetheFeasibilityCanonicalState false tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial current)) = + rationalFeasibilityResultBinaryCode + (runFixedPrecisionRationalFeasibility roundingPrecision + (scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper) iterations current) := by + induction iterations generalizing current with + | zero => + simpa [runFixedPrecisionRationalFeasibility] using! + machineBetheFeasibilityStateResult_exhausted_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current + | succ iterations ih => + rw [Function.iterate_succ_apply] + rw [runFixedPrecisionRationalFeasibility] + cases hresponse : scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper current with + | accept => + rw [machineBetheFeasibilityStep_accept_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current hresponse] + rw [machineBetheFeasibilityIterate_accepted_encode] + exact machineBetheFeasibilityStateResult_accepted_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current + | cut a => + have hfit' := hfit + simp only [MachineBetheFeasibilityFits, hresponse] at hfit' + rw [machineBetheFeasibilityStep_cut_encode tau A + oraclePrecision delta upper roundingPrecision budget stateBound + initial current a hresponse hfit'.1] + exact ih _ hfit'.2 + +theorem machineBetheFeasibilityResultCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (oraclePrecision : β„•) (delta upper : RawRat) + (roundingPrecision budget stateBound : β„•) + (initial : RationalEllipsoidState (m * m + 1)) + (hfit : MachineBetheFeasibilityFits tau A oraclePrecision delta upper + roundingPrecision stateBound budget initial) : + machineBetheFeasibilityResultCode + (machineBetheFeasibilityCanonicalWord tau A oraclePrecision + delta upper roundingPrecision budget stateBound initial) = + rationalFeasibilityResultBinaryCode + (runFixedPrecisionRationalFeasibility roundingPrecision + (scannedBetheBoundedEpigraphOracle + tau A oraclePrecision delta upper) budget initial) := by + rw [machineBetheFeasibilityResultCode, + machineBetheFeasibilityFinalState, + machineBetheFeasibilityBudget_encode, + List.length_replicate, + machineBetheFeasibilityInit_encode] + exact machineBetheFeasibilityIterateResult_encode tau A oraclePrecision + delta upper roundingPrecision budget stateBound budget initial initial hfit + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutEntry.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutEntry.lean new file mode 100644 index 0000000000..a8b79b3acc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutEntry.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BetheFloorCutFormula +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheHeightCap + +/-! +# Finite-word coefficients of Bethe floor cuts + +For a queried recovered entry and a current base coordinate, this machine +returns the canonical rational code of the corresponding cut coefficient. +The four cases are a negative unit vector, a positive row, a positive column, +and the constant negative-one vector. A supplied height-coordinate bit +overrides all four cases with zero. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the unary base dimension from a floor-cut coefficient query. -/ +def machineBetheFloorCutEntryDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- The floor-cut query payload following the dimension word. -/ +def machineBetheFloorCutEntryRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary row index of the recovered matrix entry whose floor is being tested. -/ +def machineBetheFloorCutEntryQueryRow (word : List Bool) : List Bool := + machinePairFirst (machineBetheFloorCutEntryRest word) + +/-- Extract the unary column index of the recovered matrix entry whose floor is being tested. -/ +def machineBetheFloorCutEntryQueryColumn (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineBetheFloorCutEntryRest word)) + +/-- Extract the unary row index of the base coordinate at which to evaluate the cut normal. -/ +def machineBetheFloorCutEntryBaseRow (word : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond + (machineBetheFloorCutEntryRest word))) + +/-- Extract the unary column index of the base coordinate at which to evaluate the cut normal. -/ +def machineBetheFloorCutEntryBaseColumn (word : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond + (machineBetheFloorCutEntryRest word)))) + +/-- Extract the bit identifying the extra epigraph height coordinate. -/ +def machineBetheFloorCutEntryHeightBit (word : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond + (machineBetheFloorCutEntryRest word)))) + +/-- Test whether the queried recovered entry lies in the final row by comparing its unary row +index with the base dimension. -/ +def machineBetheFloorCutEntryQueryLastRowBit + (word : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineBetheFloorCutEntryQueryRow word) + (machineBetheFloorCutEntryDimension word)) + +/-- Test whether the queried recovered entry lies in the final column by comparing its unary +column index with the base dimension. -/ +def machineBetheFloorCutEntryQueryLastColumnBit + (word : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineBetheFloorCutEntryQueryColumn word) + (machineBetheFloorCutEntryDimension word)) + +/-- Test equality of the base-coordinate row and queried recovered-entry row. -/ +def machineBetheFloorCutEntryBaseRowEqBit + (word : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineBetheFloorCutEntryBaseRow word) + (machineBetheFloorCutEntryQueryRow word)) + +/-- Test equality of the base-coordinate column and queried recovered-entry column. -/ +def machineBetheFloorCutEntryBaseColumnEqBit + (word : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineBetheFloorCutEntryBaseColumn word) + (machineBetheFloorCutEntryQueryColumn word)) + +/-- The conjunction of the row and column equality tests for the base coordinate and recovered +entry. -/ +def machineBetheFloorCutEntryBothBaseEqBit + (word : List Bool) : List Bool := + machineAndBit (machineBetheFloorCutEntryBaseRowEqBit word) + (machineBetheFloorCutEntryBaseColumnEqBit word) + +/-- The canonical rational-entry encoding of zero. -/ +def machineBetheFloorCutEntryZeroCode : List Bool := + rationalEntryBinaryCode 0 + +/-- The canonical rational-entry encoding of one. -/ +def machineBetheFloorCutEntryOneCode : List Bool := + rationalEntryBinaryCode 1 + +/-- The canonical rational-entry encoding of negative one. -/ +def machineBetheFloorCutEntryNegOneCode : List Bool := + rationalEntryBinaryCode (-1) + +/-- Evaluate the floor-cut coefficient: negative one at an internal matching coordinate or the +final corner, positive one on the relevant final-row or final-column slice, and zero elsewhere. -/ +def machineBetheFloorCutEntryBaseCode (word : List Bool) : List Bool := + machineIfHead (machineBetheFloorCutEntryQueryLastRowBit word) + (machineIfHead (machineBetheFloorCutEntryQueryLastColumnBit word) + machineBetheFloorCutEntryNegOneCode + (machineIfHead (machineBetheFloorCutEntryBaseColumnEqBit word) + machineBetheFloorCutEntryOneCode machineBetheFloorCutEntryZeroCode)) + (machineIfHead (machineBetheFloorCutEntryQueryLastColumnBit word) + (machineIfHead (machineBetheFloorCutEntryBaseRowEqBit word) + machineBetheFloorCutEntryOneCode machineBetheFloorCutEntryZeroCode) + (machineIfHead (machineBetheFloorCutEntryBothBaseEqBit word) + machineBetheFloorCutEntryNegOneCode machineBetheFloorCutEntryZeroCode)) + +/-- Return zero at the epigraph height coordinate and the floor-cut base coefficient at every +other coordinate. -/ +def machineBetheFloorCutEntryCode (word : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBetheFloorCutEntryHeightBit word)) + machineBetheFloorCutEntryZeroCode + (machineBetheFloorCutEntryBaseCode word) + +theorem machineBetheFloorCutEntryDimension_mem_FP : + machineBetheFloorCutEntryDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorCutEntryRest_mem_FP : + machineBetheFloorCutEntryRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFloorCutEntryQueryRow_mem_FP : + machineBetheFloorCutEntryQueryRow ∈ FP := by + simpa only [machineBetheFloorCutEntryQueryRow] using! + machineCompose_mem_FP machineBetheFloorCutEntryRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFloorCutEntryQueryColumn_mem_FP : + machineBetheFloorCutEntryQueryColumn ∈ FP := by + have htail := machineCompose_mem_FP machineBetheFloorCutEntryRest_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheFloorCutEntryQueryColumn] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheFloorCutEntryBaseRow_mem_FP : + machineBetheFloorCutEntryBaseRow ∈ FP := by + have htailOne := machineCompose_mem_FP + machineBetheFloorCutEntryRest_mem_FP machinePairSecond_mem_FP + have htailTwo := machineCompose_mem_FP htailOne machinePairSecond_mem_FP + simpa only [machineBetheFloorCutEntryBaseRow] using! + machineCompose_mem_FP htailTwo machinePairFirst_mem_FP + +theorem machineBetheFloorCutEntryBaseColumn_mem_FP : + machineBetheFloorCutEntryBaseColumn ∈ FP := by + have htailOne := machineCompose_mem_FP + machineBetheFloorCutEntryRest_mem_FP machinePairSecond_mem_FP + have htailTwo := machineCompose_mem_FP htailOne machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineBetheFloorCutEntryBaseColumn] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineBetheFloorCutEntryHeightBit_mem_FP : + machineBetheFloorCutEntryHeightBit ∈ FP := by + have htailOne := machineCompose_mem_FP + machineBetheFloorCutEntryRest_mem_FP machinePairSecond_mem_FP + have htailTwo := machineCompose_mem_FP htailOne machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineBetheFloorCutEntryHeightBit] using! + machineCompose_mem_FP htailThree machinePairSecond_mem_FP + +theorem machineBetheFloorCutEntryQueryLastRowBit_mem_FP : + machineBetheFloorCutEntryQueryLastRowBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineBetheFloorCutEntryQueryRow_mem_FP + machineBetheFloorCutEntryDimension_mem_FP + simpa only [machineBetheFloorCutEntryQueryLastRowBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineBetheFloorCutEntryQueryLastColumnBit_mem_FP : + machineBetheFloorCutEntryQueryLastColumnBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineBetheFloorCutEntryQueryColumn_mem_FP + machineBetheFloorCutEntryDimension_mem_FP + simpa only [machineBetheFloorCutEntryQueryLastColumnBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineBetheFloorCutEntryBaseRowEqBit_mem_FP : + machineBetheFloorCutEntryBaseRowEqBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineBetheFloorCutEntryBaseRow_mem_FP + machineBetheFloorCutEntryQueryRow_mem_FP + simpa only [machineBetheFloorCutEntryBaseRowEqBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineBetheFloorCutEntryBaseColumnEqBit_mem_FP : + machineBetheFloorCutEntryBaseColumnEqBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineBetheFloorCutEntryBaseColumn_mem_FP + machineBetheFloorCutEntryQueryColumn_mem_FP + simpa only [machineBetheFloorCutEntryBaseColumnEqBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineBetheFloorCutEntryBothBaseEqBit_mem_FP : + machineBetheFloorCutEntryBothBaseEqBit ∈ FP := + machineAndBit_mem_FP machineBetheFloorCutEntryBaseRowEqBit_mem_FP + machineBetheFloorCutEntryBaseColumnEqBit_mem_FP + +theorem machineBetheFloorCutEntryBaseCode_mem_FP : + machineBetheFloorCutEntryBaseCode ∈ FP := by + let hzero : (fun _ : List Bool ↦ machineBetheFloorCutEntryZeroCode) ∈ FP := + machineConst_mem_FP _ + let hone : (fun _ : List Bool ↦ machineBetheFloorCutEntryOneCode) ∈ FP := + machineConst_mem_FP _ + let hnegOne : (fun _ : List Bool ↦ machineBetheFloorCutEntryNegOneCode) ∈ FP := + machineConst_mem_FP _ + have hcolumn := machineIfHead_mem_FP + machineBetheFloorCutEntryBaseColumnEqBit_mem_FP hone hzero + have hlastRow := machineIfHead_mem_FP + machineBetheFloorCutEntryQueryLastColumnBit_mem_FP hnegOne hcolumn + have hrow := machineIfHead_mem_FP + machineBetheFloorCutEntryBaseRowEqBit_mem_FP hone hzero + have hnotUpperLeft := machineIfHead_mem_FP + machineBetheFloorCutEntryBothBaseEqBit_mem_FP hnegOne hzero + have hnotLastRow := machineIfHead_mem_FP + machineBetheFloorCutEntryQueryLastColumnBit_mem_FP hrow hnotUpperLeft + exact machineIfHead_mem_FP machineBetheFloorCutEntryQueryLastRowBit_mem_FP + hlastRow hnotLastRow + +theorem machineBetheFloorCutEntryCode_mem_FP : + machineBetheFloorCutEntryCode ∈ FP := by + have hheight := machineCompose_mem_FP + machineBetheFloorCutEntryHeightBit_mem_FP machineHeadBit_mem_FP + exact machineIfHead_mem_FP hheight + (machineConst_mem_FP machineBetheFloorCutEntryZeroCode) + machineBetheFloorCutEntryBaseCode_mem_FP + +/-- Encode a recovered-entry index, a base-coordinate index, and the height flag using unary +dimensions and indices. -/ +def machineBetheFloorCutEntryCanonicalWord {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : List Bool := + pair (List.replicate m true) + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) [isHeight])))) + +@[simp] theorem machineBetheFloorCutEntryQueryLastRowBit_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryQueryLastRowBit + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + [decide (i = Fin.last m)] := by + simp only [machineBetheFloorCutEntryQueryLastRowBit, + machineBetheFloorCutEntryQueryRow, machineBetheFloorCutEntryRest, + machineBetheFloorCutEntryDimension, + machineBetheFloorCutEntryCanonicalWord, machinePairFirst_pair, + machinePairSecond_pair, machineUnaryRulersEqualBit_replicate, + machineHeadBit_cons] + by_cases hi : i = Fin.last m + Β· simp [hi] + Β· have hval : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + simp [hi, hval] + +@[simp] theorem machineBetheFloorCutEntryQueryLastColumnBit_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryQueryLastColumnBit + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + [decide (j = Fin.last m)] := by + simp only [machineBetheFloorCutEntryQueryLastColumnBit, + machineBetheFloorCutEntryQueryColumn, machineBetheFloorCutEntryRest, + machineBetheFloorCutEntryDimension, + machineBetheFloorCutEntryCanonicalWord, machinePairFirst_pair, + machinePairSecond_pair, machineUnaryRulersEqualBit_replicate, + machineHeadBit_cons] + by_cases hj : j = Fin.last m + Β· simp [hj] + Β· have hval : j.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + simp [hj, hval] + +@[simp] theorem machineBetheFloorCutEntryBaseRowEqBit_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryBaseRowEqBit + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + [decide (a.castSucc = i)] := by + simp only [machineBetheFloorCutEntryBaseRowEqBit, + machineBetheFloorCutEntryBaseRow, + machineBetheFloorCutEntryQueryRow, machineBetheFloorCutEntryRest, + machineBetheFloorCutEntryCanonicalWord, machinePairFirst_pair, + machinePairSecond_pair, machineUnaryRulersEqualBit_replicate, + machineHeadBit_cons] + by_cases hai : a.castSucc = i + Β· subst i + simp + Β· have hval : a.1 β‰  i.1 := by + intro h + apply hai + apply Fin.ext + simpa using! h + simp [hai, hval] + +@[simp] theorem machineBetheFloorCutEntryBaseColumnEqBit_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryBaseColumnEqBit + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + [decide (b.castSucc = j)] := by + simp only [machineBetheFloorCutEntryBaseColumnEqBit, + machineBetheFloorCutEntryBaseColumn, + machineBetheFloorCutEntryQueryColumn, machineBetheFloorCutEntryRest, + machineBetheFloorCutEntryCanonicalWord, machinePairFirst_pair, + machinePairSecond_pair, machineUnaryRulersEqualBit_replicate, + machineHeadBit_cons] + by_cases hbj : b.castSucc = j + Β· subst j + simp + Β· have hval : b.1 β‰  j.1 := by + intro h + apply hbj + apply Fin.ext + simpa using! h + simp [hbj, hval] + +@[simp] theorem machineBetheFloorCutEntryHeightBit_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryHeightBit + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + [isHeight] := by + simp [machineBetheFloorCutEntryHeightBit, + machineBetheFloorCutEntryRest, + machineBetheFloorCutEntryCanonicalWord] + +@[simp] theorem machineBetheFloorCutEntryBaseCode_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : + machineBetheFloorCutEntryBaseCode + (machineBetheFloorCutEntryCanonicalWord i j a b false) = + rationalEntryBinaryCode (explicitBetheFloorCutBaseEntry i j a b) := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode] + Β· by_cases hbj : b = j + Β· subst b + simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode] + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode, hbj] + Β· by_cases hai : a = i + Β· subst a + simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode] + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode, hai] + Β· by_cases hai : a = i <;> by_cases hbj : b = j + Β· subst a + subst b + simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode] + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode, hai, hbj] + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode, hai, hbj] + Β· simp [machineBetheFloorCutEntryBaseCode, + machineBetheFloorCutEntryBothBaseEqBit, + machineBetheFloorCutEntryNegOneCode, + machineBetheFloorCutEntryZeroCode, + machineBetheFloorCutEntryOneCode, hai, hbj] + +@[simp] theorem machineBetheFloorCutEntryCode_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) (isHeight : Bool) : + machineBetheFloorCutEntryCode + (machineBetheFloorCutEntryCanonicalWord i j a b isHeight) = + rationalEntryBinaryCode + (if isHeight then 0 else explicitBetheFloorCutBaseEntry i j a b) := by + cases isHeight + Β· simp [machineBetheFloorCutEntryCode] + Β· simp [machineBetheFloorCutEntryCode, + machineBetheFloorCutEntryZeroCode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutVector.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutVector.lean new file mode 100644 index 0000000000..204345d063 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorCutVector.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListSnoc + +/-! +# Finite-word Bethe floor-cut vectors + +The floor scan identifies a recovered matrix coordinate `(i,j)`. This file +uses the common row-major grid generator to construct all `m^2` coefficients +of its affine pullback, then appends the zero epigraph-height coefficient. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Adapter from grid-entry inputs to floor-cut-entry inputs -/ + +/-- Extract the unary base-row index from a floor-cut grid-generator request. -/ +def machineBetheFloorCutGridBaseRow (word : List Bool) : List Bool := + machinePairFirst word + +/-- The grid-generator payload following the base-row word. -/ +def machineBetheFloorCutGridRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary base-column index from a floor-cut grid-generator request. -/ +def machineBetheFloorCutGridBaseColumn (word : List Bool) : List Bool := + machinePairFirst (machineBetheFloorCutGridRest word) + +/-- Extract the original floor-cut vector request carried by the grid generator. -/ +def machineBetheFloorCutGridPayload (word : List Bool) : List Bool := + machinePairSecond (machineBetheFloorCutGridRest word) + +/-- Extract the unary base dimension from a request for the complete floor-cut vector. -/ +def machineBetheFloorCutVectorDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- The floor-cut vector request after removing its dimension word. -/ +def machineBetheFloorCutVectorRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the queried recovered-entry row from the floor-cut vector request. -/ +def machineBetheFloorCutVectorQueryRow (word : List Bool) : List Bool := + machinePairFirst (machineBetheFloorCutVectorRest word) + +/-- Extract the queried recovered-entry column from the floor-cut vector request. -/ +def machineBetheFloorCutVectorQueryColumn (word : List Bool) : List Bool := + machinePairSecond (machineBetheFloorCutVectorRest word) + +/-- Combine the stored recovered-entry query with the generator's base-row and base-column +indices, setting the height flag to false. -/ +def machineBetheFloorCutGridEntryInput (word : List Bool) : List Bool := + let payload := machineBetheFloorCutGridPayload word + pair (machineBetheFloorCutVectorDimension payload) + (pair (machineBetheFloorCutVectorQueryRow payload) + (pair (machineBetheFloorCutVectorQueryColumn payload) + (pair (machineBetheFloorCutGridBaseRow word) + (pair (machineBetheFloorCutGridBaseColumn word) [false])))) + +/-- Evaluate the encoded floor-cut coefficient at the current grid coordinate. -/ +def machineBetheFloorCutGridEntryCode (word : List Bool) : List Bool := + machineBetheFloorCutEntryCode (machineBetheFloorCutGridEntryInput word) + +theorem machineBetheFloorCutGridBaseRow_mem_FP : + machineBetheFloorCutGridBaseRow ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorCutGridRest_mem_FP : + machineBetheFloorCutGridRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFloorCutGridBaseColumn_mem_FP : + machineBetheFloorCutGridBaseColumn ∈ FP := by + simpa only [machineBetheFloorCutGridBaseColumn] using! + machineCompose_mem_FP machineBetheFloorCutGridRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFloorCutGridPayload_mem_FP : + machineBetheFloorCutGridPayload ∈ FP := by + simpa only [machineBetheFloorCutGridPayload] using! + machineCompose_mem_FP machineBetheFloorCutGridRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFloorCutVectorDimension_mem_FP : + machineBetheFloorCutVectorDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorCutVectorRest_mem_FP : + machineBetheFloorCutVectorRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFloorCutVectorQueryRow_mem_FP : + machineBetheFloorCutVectorQueryRow ∈ FP := by + simpa only [machineBetheFloorCutVectorQueryRow] using! + machineCompose_mem_FP machineBetheFloorCutVectorRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFloorCutVectorQueryColumn_mem_FP : + machineBetheFloorCutVectorQueryColumn ∈ FP := by + simpa only [machineBetheFloorCutVectorQueryColumn] using! + machineCompose_mem_FP machineBetheFloorCutVectorRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFloorCutGridEntryInput_mem_FP : + machineBetheFloorCutGridEntryInput ∈ FP := by + have hdimension := machineCompose_mem_FP + machineBetheFloorCutGridPayload_mem_FP + machineBetheFloorCutVectorDimension_mem_FP + have hqueryRow := machineCompose_mem_FP + machineBetheFloorCutGridPayload_mem_FP + machineBetheFloorCutVectorQueryRow_mem_FP + have hqueryColumn := machineCompose_mem_FP + machineBetheFloorCutGridPayload_mem_FP + machineBetheFloorCutVectorQueryColumn_mem_FP + exact machinePair_mem_FP hdimension + (machinePair_mem_FP hqueryRow + (machinePair_mem_FP hqueryColumn + (machinePair_mem_FP machineBetheFloorCutGridBaseRow_mem_FP + (machinePair_mem_FP machineBetheFloorCutGridBaseColumn_mem_FP + (machineConst_mem_FP [false]))))) + +theorem machineBetheFloorCutGridEntryCode_mem_FP : + machineBetheFloorCutGridEntryCode ∈ FP := by + simpa only [machineBetheFloorCutGridEntryCode] using! + machineCompose_mem_FP machineBetheFloorCutGridEntryInput_mem_FP + machineBetheFloorCutEntryCode_mem_FP + +/-! ## Complete vector machine -/ + +/-- The twice-iterated binary-width ruler used to bound generated floor-cut entries. -/ +def machineBetheFloorCutVectorBound (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 word + +/-- Package the unary grid dimension, entry-width ruler, and original floor-cut vector request +for grid generation. -/ +def machineBetheFloorCutVectorGeneratorInput + (word : List Bool) : List Bool := + pair (machineBetheFloorCutVectorDimension word) + (pair (machineBetheFloorCutVectorBound word) word) + +/-- Generate the encoded floor-cut coefficients over the square grid of base coordinates. -/ +def machineBetheFloorCutVectorBaseCode (word : List Bool) : List Bool := + machineUnaryGridGeneratorCode machineBetheFloorCutGridEntryCode + (machineBetheFloorCutVectorGeneratorInput word) + +/-- Package a zero rational entry for appending to the generated base-coordinate vector. -/ +def machineBetheFloorCutVectorSnocInput (word : List Bool) : List Bool := + pair (rationalEntryBinaryCode 0) + (machineBetheFloorCutVectorBaseCode word) + +/-- Append the zero height coefficient to the generated base-coordinate floor-cut vector. -/ +def machineBetheFloorCutVectorCode (word : List Bool) : List Bool := + machineBinaryListSnoc (machineBetheFloorCutVectorSnocInput word) + +theorem machineBetheFloorCutVectorBound_mem_FP : + machineBetheFloorCutVectorBound ∈ FP := + machineIteratedBinaryWidth_mem_FP 2 + +theorem machineBetheFloorCutVectorGeneratorInput_mem_FP : + machineBetheFloorCutVectorGeneratorInput ∈ FP := + machinePair_mem_FP machineBetheFloorCutVectorDimension_mem_FP + (machinePair_mem_FP machineBetheFloorCutVectorBound_mem_FP id_mem_FP) + +theorem machineBetheFloorCutVectorBaseCode_mem_FP : + machineBetheFloorCutVectorBaseCode ∈ FP := by + have hgenerator := machineUnaryGridGeneratorCode_mem_FP + machineBetheFloorCutGridEntryCode_mem_FP + simpa only [machineBetheFloorCutVectorBaseCode] using! + machineCompose_mem_FP machineBetheFloorCutVectorGeneratorInput_mem_FP + hgenerator + +theorem machineBetheFloorCutVectorSnocInput_mem_FP : + machineBetheFloorCutVectorSnocInput ∈ FP := + machinePair_mem_FP (machineConst_mem_FP (rationalEntryBinaryCode 0)) + machineBetheFloorCutVectorBaseCode_mem_FP + +theorem machineBetheFloorCutVectorCode_mem_FP : + machineBetheFloorCutVectorCode ∈ FP := by + simpa only [machineBetheFloorCutVectorCode] using! + machineCompose_mem_FP machineBetheFloorCutVectorSnocInput_mem_FP + machineBinaryListSnoc_mem_FP + +/-- Encode a floor-cut vector request with unary base dimension and recovered-entry row and +column indices. -/ +def machineBetheFloorCutVectorCanonicalWord {m : β„•} + (i j : Fin (m + 1)) : List Bool := + pair (List.replicate m true) + (pair (List.replicate i.1 true) (List.replicate j.1 true)) + +@[simp] theorem machineBetheFloorCutGridEntryInput_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : + machineBetheFloorCutGridEntryInput + (pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) + (machineBetheFloorCutVectorCanonicalWord i j))) = + machineBetheFloorCutEntryCanonicalWord i j a b false := by + simp [machineBetheFloorCutGridEntryInput, + machineBetheFloorCutGridPayload, machineBetheFloorCutGridRest, + machineBetheFloorCutGridBaseRow, + machineBetheFloorCutGridBaseColumn, + machineBetheFloorCutVectorDimension, + machineBetheFloorCutVectorQueryRow, + machineBetheFloorCutVectorQueryColumn, + machineBetheFloorCutVectorRest, + machineBetheFloorCutVectorCanonicalWord, + machineBetheFloorCutEntryCanonicalWord] + +@[simp] theorem machineBetheFloorCutGridEntryCode_encode {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : + machineBetheFloorCutGridEntryCode + (pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) + (machineBetheFloorCutVectorCanonicalWord i j))) = + rationalEntryBinaryCode (explicitBetheFloorCutBaseEntry i j a b) := by + rw [machineBetheFloorCutGridEntryCode, + machineBetheFloorCutGridEntryInput_encode, + machineBetheFloorCutEntryCode_encode] + simp + +theorem betheFloorCut_entry_code_length_le {m : β„•} + (i j : Fin (m + 1)) (a b : Fin m) : + (rationalEntryBinaryCode + (explicitBetheFloorCutBaseEntry i j a b)).length ≀ 16 := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· norm_num [rationalEntryBinaryCode, integerBinaryCode] <;> decide + Β· by_cases hb : b = j <;> + simp [hb, rationalEntryBinaryCode, integerBinaryCode] <;> decide + Β· by_cases ha : a = i <;> + simp [ha, rationalEntryBinaryCode, integerBinaryCode] <;> decide + Β· by_cases ha : a = i <;> by_cases hb : b = j <;> + simp [ha, hb, rationalEntryBinaryCode, integerBinaryCode] <;> decide + +theorem betheFloorCut_base_code_length_le_bound {m : β„•} + (i j : Fin (m + 1)) : + (binaryListCode rationalEntryBinaryCode + (unaryGridValues (explicitBetheFloorCutBaseEntry i j))).length ≀ + (machineBetheFloorCutVectorBound + (machineBetheFloorCutVectorCanonicalWord i j)).length := by + let word := machineBetheFloorCutVectorCanonicalWord i j + let L := word.length + let T := L + 16 + have hmL : m ≀ L := by + simp only [L, word, machineBetheFloorCutVectorCanonicalWord, + pair_length, List.length_replicate] + omega + have heach : βˆ€ q ∈ + unaryGridValues (explicitBetheFloorCutBaseEntry i j), + (rationalEntryBinaryCode q).length ≀ 16 := by + intro q hq + rw [unaryGridValues] at hq + obtain ⟨k, rfl⟩ := List.mem_ofFn.mp hq + exact betheFloorCut_entry_code_length_le i j _ _ + have hsum := List.sum_le_card_nsmul + ((unaryGridValues (explicitBetheFloorCutBaseEntry i j)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + 34 (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + have hmT : m ≀ T := hmL.trans (by simp [T]) + have hmm := Nat.mul_le_mul hmT hmT + have hbase : 16 ≀ T := by simp [T] + have hcoefficient : 34 ≀ T ^ 2 := by + have hpow := Nat.pow_le_pow_left hbase 2 + exact (by norm_num : 34 ≀ 16 ^ 2).trans hpow + have hmul := Nat.mul_le_mul hmm hcoefficient + have hcode : + (binaryListCode rationalEntryBinaryCode + (unaryGridValues (explicitBetheFloorCutBaseEntry i j))).length ≀ + T ^ 4 := by + rw [binaryListCode_length_eq_sum] + simp only [List.length_map, unaryGridValues_length, + Nat.nsmul_eq_mul] at hsum + calc + _ ≀ m * m * 34 := hsum + _ ≀ T * T * T ^ 2 := hmul + _ = T ^ 4 := by ring + rw [machineBetheFloorCutVectorBound, + machineIteratedBinaryWidth_length] + exact hcode.trans (by + simpa only [T, L, word] using! + certificateExpGuardWidth_pow_lower 1 + (machineBetheFloorCutVectorCanonicalWord i j).length) + +@[simp] theorem machineBetheFloorCutVectorGeneratorInput_encode {m : β„•} + (i j : Fin (m + 1)) : + machineBetheFloorCutVectorGeneratorInput + (machineBetheFloorCutVectorCanonicalWord i j) = + machineUnaryGridGeneratorCanonicalWord m + (machineBetheFloorCutVectorBound + (machineBetheFloorCutVectorCanonicalWord i j)) + (machineBetheFloorCutVectorCanonicalWord i j) := by + simp [machineBetheFloorCutVectorGeneratorInput, + machineBetheFloorCutVectorDimension, + machineBetheFloorCutVectorCanonicalWord, + machineUnaryGridGeneratorCanonicalWord] + +@[simp] theorem machineBetheFloorCutVectorBaseCode_encode {m : β„•} + (i j : Fin (m + 1)) : + machineBetheFloorCutVectorBaseCode + (machineBetheFloorCutVectorCanonicalWord i j) = + binaryListCode rationalEntryBinaryCode + (unaryGridValues (explicitBetheFloorCutBaseEntry i j)) := by + rw [machineBetheFloorCutVectorBaseCode, + machineBetheFloorCutVectorGeneratorInput_encode] + exact machineUnaryGridGeneratorCode_encode_of_bound + machineBetheFloorCutGridEntryCode + (explicitBetheFloorCutBaseEntry i j) + (machineBetheFloorCutVectorBound + (machineBetheFloorCutVectorCanonicalWord i j)) + (machineBetheFloorCutVectorCanonicalWord i j) + (machineBetheFloorCutGridEntryCode_encode i j) + (betheFloorCut_base_code_length_le_bound i j) + +theorem ofFn_explicitBetheFloorCutNormal {m : β„•} + (i j : Fin (m + 1)) : + List.ofFn (explicitBetheFloorCutNormal i j) = + unaryGridValues (explicitBetheFloorCutBaseEntry i j) ++ [0] := by + rw [List.ofFn_succ'] + simp only [explicitBetheFloorCutNormal, Fin.snoc_castSucc, + Fin.snoc_last, List.concat_eq_append, unaryGridValues] + +@[simp] theorem machineBetheFloorCutVectorCode_encode {m : β„•} + (i j : Fin (m + 1)) : + machineBetheFloorCutVectorCode + (machineBetheFloorCutVectorCanonicalWord i j) = + rationalFiniteVectorCode (explicitBetheFloorCutNormal i j) := by + rw [machineBetheFloorCutVectorCode, + machineBetheFloorCutVectorSnocInput, + machineBetheFloorCutVectorBaseCode_encode, + machineBinaryListSnoc_encode, + rationalFiniteVectorCode, ofFn_explicitBetheFloorCutNormal] + +@[simp] theorem machineBetheFloorCutVectorCode_encode_oracleNormal {m : β„•} + (i j : Fin (m + 1)) : + machineBetheFloorCutVectorCode + (machineBetheFloorCutVectorCanonicalWord i j) = + rationalFiniteVectorCode (betheFloorCutNormal i j) := by + rw [machineBetheFloorCutVectorCode_encode, + explicitBetheFloorCutNormal_eq] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorScan.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorScan.lean new file mode 100644 index 0000000000..d3b11efaa0 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorScan.lean @@ -0,0 +1,1542 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorTest +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary + +/-! +# Finite-word row-major scan of all Bethe floor constraints + +The scan keeps unary row and column counters, a one-bit found flag, a one-bit +done flag, and the immutable input payload. It examines the recovered +`(m+1)`-by-`(m+1)` matrix in row-major order and freezes at the first strict +floor violation. Its iteration ruler is constructed, in polynomial time, +as exactly `(m+1)^2` unary bits on canonical inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Input and state layout -/ + +/-- Extracts the unary dimension parameter from the floor-scan input. -/ +def machineBetheFloorScanDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the paired threshold and coordinate vector from the floor-scan input. -/ +def machineBetheFloorScanRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the encoded rational floor threshold from the scan input. -/ +def machineBetheFloorScanThreshold (word : List Bool) : List Bool := + machinePairFirst (machineBetheFloorScanRest word) + +/-- Extracts the encoded rational coordinate vector from the scan input. -/ +def machineBetheFloorScanVector (word : List Bool) : List Bool := + machinePairSecond (machineBetheFloorScanRest word) + +/-- Encodes a floor-scan state as row, column, found flag, done flag, and input payload. -/ +def machineBetheFloorScanPack (row column found done payload : List Bool) : + List Bool := + pair row (pair column (pair found (pair done payload))) + +/-- Extracts the current unary row index from the floor-scan state. -/ +def machineBetheFloorScanRow (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the current unary column index from the floor-scan state. -/ +def machineBetheFloorScanColumn (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the flag recording discovery of an entry below the floor threshold. -/ +def machineBetheFloorScanFound (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the flag recording completion of the floor scan. -/ +def machineBetheFloorScanDone (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the original scan input stored in the state. -/ +def machineBetheFloorScanPayload (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Reads the unary dimension parameter from the state's stored input. -/ +def machineBetheFloorScanStateDimension (state : List Bool) : List Bool := + machineBetheFloorScanDimension (machineBetheFloorScanPayload state) + +/-- Reads the rational floor threshold from the state's stored input. -/ +def machineBetheFloorScanStateThreshold (state : List Bool) : List Bool := + machineBetheFloorScanThreshold (machineBetheFloorScanPayload state) + +/-- Reads the rational coordinate vector from the state's stored input. -/ +def machineBetheFloorScanStateVector (state : List Bool) : List Bool := + machineBetheFloorScanVector (machineBetheFloorScanPayload state) + +/-- Tests whether the current row ruler equals the dimension ruler, marking the last row. -/ +def machineBetheFloorScanLastRowBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineBetheFloorScanRow state) + (machineBetheFloorScanStateDimension state) + +/-- Tests whether the current column ruler equals the dimension ruler, marking the last column. -/ +def machineBetheFloorScanLastColumnBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineBetheFloorScanColumn state) + (machineBetheFloorScanStateDimension state) + +/-- Assembles the dimension, current indices, and coordinate vector for an affine-entry query. -/ +def machineBetheFloorScanEntryWord (state : List Bool) : List Bool := + pair (machineBetheFloorScanStateDimension state) + (pair (machineBetheFloorScanRow state) + (pair (machineBetheFloorScanColumn state) + (machineBetheFloorScanStateVector state))) + +/-- Pairs the floor threshold with the current affine-entry query. -/ +def machineBetheFloorScanTestWord (state : List Bool) : List Bool := + pair (machineBetheFloorScanStateThreshold state) + (machineBetheFloorScanEntryWord state) + +/-- Tests whether the current affine matrix entry violates the floor constraint. -/ +def machineBetheFloorScanViolationBit (state : List Bool) : List Bool := + machineBetheFloorViolationBit (machineBetheFloorScanTestWord state) + +/-- Increments the current unary row index by appending one bit. -/ +def machineBetheFloorScanNextRow (state : List Bool) : List Bool := + machineBetheFloorScanRow state ++ [true] + +/-- Increments the current unary column index by appending one bit. -/ +def machineBetheFloorScanNextColumn (state : List Bool) : List Bool := + machineBetheFloorScanColumn state ++ [true] + +/-- Sets the found flag while retaining the current indices and input payload. -/ +def machineBetheFloorScanMarkFound (state : List Bool) : List Bool := + machineBetheFloorScanPack (machineBetheFloorScanRow state) + (machineBetheFloorScanColumn state) [true] + (machineBetheFloorScanDone state) + (machineBetheFloorScanPayload state) + +/-- Sets the done flag while retaining the current indices and input payload. -/ +def machineBetheFloorScanFinish (state : List Bool) : List Bool := + machineBetheFloorScanPack (machineBetheFloorScanRow state) + (machineBetheFloorScanColumn state) + (machineBetheFloorScanFound state) [true] + (machineBetheFloorScanPayload state) + +/-- Advances to the next row and resets the column index to zero. -/ +def machineBetheFloorScanAdvanceRow (state : List Bool) : List Bool := + machineBetheFloorScanPack (machineBetheFloorScanNextRow state) [] + (machineBetheFloorScanFound state) (machineBetheFloorScanDone state) + (machineBetheFloorScanPayload state) + +/-- Advances the column index while retaining the current row and flags. -/ +def machineBetheFloorScanAdvanceColumn (state : List Bool) : List Bool := + machineBetheFloorScanPack (machineBetheFloorScanRow state) + (machineBetheFloorScanNextColumn state) + (machineBetheFloorScanFound state) (machineBetheFloorScanDone state) + (machineBetheFloorScanPayload state) + +/-- Advances in row-major order, marking completion after the final matrix entry. -/ +def machineBetheFloorScanAdvance (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBetheFloorScanLastColumnBit state)) + (machineIfHead (machineHeadBit (machineBetheFloorScanLastRowBit state)) + (machineBetheFloorScanFinish state) + (machineBetheFloorScanAdvanceRow state)) + (machineBetheFloorScanAdvanceColumn state) + +/-- Marks a floor violation at the current entry or advances to the next entry. -/ +def machineBetheFloorScanProcess (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBetheFloorScanViolationBit state)) + (machineBetheFloorScanMarkFound state) + (machineBetheFloorScanAdvance state) + +/-- Performs one floor-scan step, leaving found or completed states fixed. -/ +def machineBetheFloorScanStep (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBetheFloorScanFound state)) state + (machineIfHead (machineHeadBit (machineBetheFloorScanDone state)) state + (machineBetheFloorScanProcess state)) + +/-- Initializes the floor scan at row and column zero with both flags false. -/ +def machineBetheFloorScanInit (word : List Bool) : List Bool := + machineBetheFloorScanPack [] [] [false] [false] word + +/-! ## Exact polynomial iteration ruler -/ + +/-- Computes binary bits for the length of the input's dimension ruler. -/ +def machineBetheFloorScanDimensionBits (word : List Bool) : List Bool := + machineLengthBits (machineBetheFloorScanDimension word) + +/-- Computes binary bits for one plus the dimension-ruler length. -/ +def machineBetheFloorScanOrderBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBetheFloorScanDimensionBits word) [true]) + +/-- Computes the square of one plus the dimension-ruler length as binary bits. -/ +def machineBetheFloorScanWorkBits (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineBetheFloorScanOrderBits word) + (machineBetheFloorScanOrderBits word)) + +/-- Supplies the binary-multiplication width bound used to construct the scan ruler. -/ +def machineBetheFloorScanGuard (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Converts the square of the matrix order to a unary iteration ruler within the guard bound. -/ +def machineBetheFloorScanRuler (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineBetheFloorScanGuard word) + (machineBetheFloorScanWorkBits word)) + +/-- Applies the binary-multiplication width bound twice to bound encoded scan components. -/ +def machineBetheFloorScanStateEnvelope (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth word) + +/-- Packs five copies of the state envelope to provide an encoded-state width bound. -/ +def machineBetheFloorScanWidth (word : List Bool) : List Bool := + let bound := machineBetheFloorScanStateEnvelope word + machineBetheFloorScanPack bound bound bound bound bound + +/-- Runs the floor-scan step for the number of iterations specified by its unary ruler. -/ +def machineBetheFloorScanFinalState (word : List Bool) : List Bool := + (machineBetheFloorScanStep)^[(machineBetheFloorScanRuler word).length] + (machineBetheFloorScanInit word) + +/-- The public result is a found bit followed by the unary row and column of +the first violation. When the bit is false the two counters are ignored. -/ +def machineBetheFloorScanResultCode (word : List Bool) : List Bool := + pair (machineBetheFloorScanFound (machineBetheFloorScanFinalState word)) + (pair (machineBetheFloorScanRow (machineBetheFloorScanFinalState word)) + (machineBetheFloorScanColumn + (machineBetheFloorScanFinalState word))) + +/-! ## Polynomial-time closure -/ + +theorem machineBetheFloorScanDimension_mem_FP : + machineBetheFloorScanDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorScanRest_mem_FP : + machineBetheFloorScanRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFloorScanThreshold_mem_FP : + machineBetheFloorScanThreshold ∈ FP := by + simpa only [machineBetheFloorScanThreshold] using! + machineCompose_mem_FP machineBetheFloorScanRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheFloorScanVector_mem_FP : + machineBetheFloorScanVector ∈ FP := by + simpa only [machineBetheFloorScanVector] using! + machineCompose_mem_FP machineBetheFloorScanRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheFloorScanRow_mem_FP : + machineBetheFloorScanRow ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorScanColumn_mem_FP : + machineBetheFloorScanColumn ∈ FP := by + simpa only [machineBetheFloorScanColumn] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBetheFloorScanFound_mem_FP : + machineBetheFloorScanFound ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineBetheFloorScanFound] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineBetheFloorScanDone_mem_FP : + machineBetheFloorScanDone ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineBetheFloorScanDone] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineBetheFloorScanPayload_mem_FP : + machineBetheFloorScanPayload ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineBetheFloorScanPayload] using! + machineCompose_mem_FP htailThree machinePairSecond_mem_FP + +theorem machineBetheFloorScanStateDimension_mem_FP : + machineBetheFloorScanStateDimension ∈ FP := by + simpa only [machineBetheFloorScanStateDimension] using! + machineCompose_mem_FP machineBetheFloorScanPayload_mem_FP + machineBetheFloorScanDimension_mem_FP + +theorem machineBetheFloorScanStateThreshold_mem_FP : + machineBetheFloorScanStateThreshold ∈ FP := by + simpa only [machineBetheFloorScanStateThreshold] using! + machineCompose_mem_FP machineBetheFloorScanPayload_mem_FP + machineBetheFloorScanThreshold_mem_FP + +theorem machineBetheFloorScanStateVector_mem_FP : + machineBetheFloorScanStateVector ∈ FP := by + simpa only [machineBetheFloorScanStateVector] using! + machineCompose_mem_FP machineBetheFloorScanPayload_mem_FP + machineBetheFloorScanVector_mem_FP + +theorem machineBetheFloorScanLastRowBit_mem_FP : + machineBetheFloorScanLastRowBit ∈ FP := + machineUnaryRulersEqualBit_mem_FP machineBetheFloorScanRow_mem_FP + machineBetheFloorScanStateDimension_mem_FP + +theorem machineBetheFloorScanLastColumnBit_mem_FP : + machineBetheFloorScanLastColumnBit ∈ FP := + machineUnaryRulersEqualBit_mem_FP machineBetheFloorScanColumn_mem_FP + machineBetheFloorScanStateDimension_mem_FP + +theorem machineBetheFloorScanEntryWord_mem_FP : + machineBetheFloorScanEntryWord ∈ FP := + machinePair_mem_FP machineBetheFloorScanStateDimension_mem_FP + (machinePair_mem_FP machineBetheFloorScanRow_mem_FP + (machinePair_mem_FP machineBetheFloorScanColumn_mem_FP + machineBetheFloorScanStateVector_mem_FP)) + +theorem machineBetheFloorScanTestWord_mem_FP : + machineBetheFloorScanTestWord ∈ FP := + machinePair_mem_FP machineBetheFloorScanStateThreshold_mem_FP + machineBetheFloorScanEntryWord_mem_FP + +theorem machineBetheFloorScanViolationBit_mem_FP : + machineBetheFloorScanViolationBit ∈ FP := by + simpa only [machineBetheFloorScanViolationBit] using! + machineCompose_mem_FP machineBetheFloorScanTestWord_mem_FP + machineBetheFloorViolationBit_mem_FP + +theorem machineBetheFloorScanNextRow_mem_FP : + machineBetheFloorScanNextRow ∈ FP := + machineAppend_mem_FP machineBetheFloorScanRow_mem_FP + (machineConst_mem_FP [true]) + +theorem machineBetheFloorScanNextColumn_mem_FP : + machineBetheFloorScanNextColumn ∈ FP := + machineAppend_mem_FP machineBetheFloorScanColumn_mem_FP + (machineConst_mem_FP [true]) + +theorem machineBetheFloorScanMarkFound_mem_FP : + machineBetheFloorScanMarkFound ∈ FP := + machinePair_mem_FP machineBetheFloorScanRow_mem_FP + (machinePair_mem_FP machineBetheFloorScanColumn_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineBetheFloorScanDone_mem_FP + machineBetheFloorScanPayload_mem_FP))) + +theorem machineBetheFloorScanFinish_mem_FP : + machineBetheFloorScanFinish ∈ FP := + machinePair_mem_FP machineBetheFloorScanRow_mem_FP + (machinePair_mem_FP machineBetheFloorScanColumn_mem_FP + (machinePair_mem_FP machineBetheFloorScanFound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineBetheFloorScanPayload_mem_FP))) + +theorem machineBetheFloorScanAdvanceRow_mem_FP : + machineBetheFloorScanAdvanceRow ∈ FP := + machinePair_mem_FP machineBetheFloorScanNextRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineBetheFloorScanFound_mem_FP + (machinePair_mem_FP machineBetheFloorScanDone_mem_FP + machineBetheFloorScanPayload_mem_FP))) + +theorem machineBetheFloorScanAdvanceColumn_mem_FP : + machineBetheFloorScanAdvanceColumn ∈ FP := + machinePair_mem_FP machineBetheFloorScanRow_mem_FP + (machinePair_mem_FP machineBetheFloorScanNextColumn_mem_FP + (machinePair_mem_FP machineBetheFloorScanFound_mem_FP + (machinePair_mem_FP machineBetheFloorScanDone_mem_FP + machineBetheFloorScanPayload_mem_FP))) + +theorem machineBetheFloorScanAdvance_mem_FP : + machineBetheFloorScanAdvance ∈ FP := by + have hlastRowHead := machineCompose_mem_FP + machineBetheFloorScanLastRowBit_mem_FP machineHeadBit_mem_FP + have hlastColumnHead := machineCompose_mem_FP + machineBetheFloorScanLastColumnBit_mem_FP machineHeadBit_mem_FP + have hlast := machineIfHead_mem_FP + hlastRowHead + machineBetheFloorScanFinish_mem_FP + machineBetheFloorScanAdvanceRow_mem_FP + exact machineIfHead_mem_FP hlastColumnHead + hlast machineBetheFloorScanAdvanceColumn_mem_FP + +theorem machineBetheFloorScanProcess_mem_FP : + machineBetheFloorScanProcess ∈ FP := by + have hhead := machineCompose_mem_FP + machineBetheFloorScanViolationBit_mem_FP machineHeadBit_mem_FP + exact machineIfHead_mem_FP hhead machineBetheFloorScanMarkFound_mem_FP + machineBetheFloorScanAdvance_mem_FP + +theorem machineBetheFloorScanStep_mem_FP : + machineBetheFloorScanStep ∈ FP := by + have hfoundHead := machineCompose_mem_FP + machineBetheFloorScanFound_mem_FP machineHeadBit_mem_FP + have hdoneHead := machineCompose_mem_FP + machineBetheFloorScanDone_mem_FP machineHeadBit_mem_FP + have hnotFound := machineIfHead_mem_FP + hdoneHead id_mem_FP + machineBetheFloorScanProcess_mem_FP + exact machineIfHead_mem_FP hfoundHead id_mem_FP + hnotFound + +theorem machineBetheFloorScanInit_mem_FP : + machineBetheFloorScanInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP))) + +theorem machineBetheFloorScanDimensionBits_mem_FP : + machineBetheFloorScanDimensionBits ∈ FP := by + simpa only [machineBetheFloorScanDimensionBits] using! + machineCompose_mem_FP machineBetheFloorScanDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineBetheFloorScanOrderBits_mem_FP : + machineBetheFloorScanOrderBits ∈ FP := by + have hinput := machinePair_mem_FP + machineBetheFloorScanDimensionBits_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineBetheFloorScanOrderBits] using! + machineCompose_mem_FP hinput machineBinaryAddBits_mem_FP + +theorem machineBetheFloorScanWorkBits_mem_FP : + machineBetheFloorScanWorkBits ∈ FP := by + have hinput := machinePair_mem_FP machineBetheFloorScanOrderBits_mem_FP + machineBetheFloorScanOrderBits_mem_FP + simpa only [machineBetheFloorScanWorkBits] using! + machineCompose_mem_FP hinput machineBinaryMulBits_mem_FP + +theorem machineBetheFloorScanGuard_mem_FP : + machineBetheFloorScanGuard ∈ FP := machineBinaryMulWidth_mem_FP + +theorem machineBetheFloorScanRuler_mem_FP : + machineBetheFloorScanRuler ∈ FP := by + have hinput := machinePair_mem_FP machineBetheFloorScanGuard_mem_FP + machineBetheFloorScanWorkBits_mem_FP + simpa only [machineBetheFloorScanRuler] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineBetheFloorScanStateEnvelope_mem_FP : + machineBetheFloorScanStateEnvelope ∈ FP := by + simpa only [machineBetheFloorScanStateEnvelope] using! + machineCompose_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineBetheFloorScanWidth_mem_FP : + machineBetheFloorScanWidth ∈ FP := by + have hbound := machineBetheFloorScanStateEnvelope_mem_FP + exact machinePair_mem_FP hbound + (machinePair_mem_FP hbound + (machinePair_mem_FP hbound (machinePair_mem_FP hbound hbound))) + +/-! ## A global state envelope for the Cobham iteration -/ + +@[simp] theorem machineBetheFloorScanRow_pack + (row column found done payload) : + machineBetheFloorScanRow + (machineBetheFloorScanPack row column found done payload) = row := by + simp [machineBetheFloorScanRow, machineBetheFloorScanPack] + +@[simp] theorem machineBetheFloorScanColumn_pack + (row column found done payload) : + machineBetheFloorScanColumn + (machineBetheFloorScanPack row column found done payload) = column := by + simp [machineBetheFloorScanColumn, machineBetheFloorScanPack] + +@[simp] theorem machineBetheFloorScanFound_pack + (row column found done payload) : + machineBetheFloorScanFound + (machineBetheFloorScanPack row column found done payload) = found := by + simp [machineBetheFloorScanFound, machineBetheFloorScanPack] + +@[simp] theorem machineBetheFloorScanDone_pack + (row column found done payload) : + machineBetheFloorScanDone + (machineBetheFloorScanPack row column found done payload) = done := by + simp [machineBetheFloorScanDone, machineBetheFloorScanPack] + +@[simp] theorem machineBetheFloorScanPayload_pack + (row column found done payload) : + machineBetheFloorScanPayload + (machineBetheFloorScanPack row column found done payload) = payload := by + simp [machineBetheFloorScanPayload, machineBetheFloorScanPack] + +/-- Bounds a canonically packed scan state's index lengths, single-bit flags, and payload +length. -/ +def MachineBetheFloorScanStateBound + (word : List Bool) (iterations : β„•) (state : List Bool) : Prop := + state = machineBetheFloorScanPack + (machineBetheFloorScanRow state) + (machineBetheFloorScanColumn state) + (machineBetheFloorScanFound state) + (machineBetheFloorScanDone state) + (machineBetheFloorScanPayload state) ∧ + (machineBetheFloorScanRow state).length ≀ word.length + iterations ∧ + (machineBetheFloorScanColumn state).length ≀ word.length + iterations ∧ + (machineBetheFloorScanFound state).length ≀ 1 ∧ + (machineBetheFloorScanDone state).length ≀ 1 ∧ + (machineBetheFloorScanPayload state).length ≀ word.length + +theorem machineBetheFloorScanInit_bound (word : List Bool) : + MachineBetheFloorScanStateBound word 0 + (machineBetheFloorScanInit word) := by + simp [MachineBetheFloorScanStateBound, machineBetheFloorScanInit] + +@[simp] theorem machineIfHead_nil_floorScan + (whenTrue whenFalse : List Bool) : + machineIfHead [] whenTrue whenFalse = [] := by + simp [machineIfHead, Cobham.selectHead] + +theorem machineBetheFloorScanMarkFound_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanMarkFound state) := by + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + simp only [machineBetheFloorScanMarkFound, + MachineBetheFloorScanStateBound, + machineBetheFloorScanRow_pack, machineBetheFloorScanColumn_pack, + machineBetheFloorScanFound_pack, machineBetheFloorScanDone_pack, + machineBetheFloorScanPayload_pack, List.length_singleton] + exact ⟨trivial, hrow.trans (by omega), hcolumn.trans (by omega), + by simp, hdone, hpayload⟩ + +theorem machineBetheFloorScanFinish_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanFinish state) := by + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + simp only [machineBetheFloorScanFinish, + MachineBetheFloorScanStateBound, + machineBetheFloorScanRow_pack, machineBetheFloorScanColumn_pack, + machineBetheFloorScanFound_pack, machineBetheFloorScanDone_pack, + machineBetheFloorScanPayload_pack, List.length_singleton] + exact ⟨trivial, hrow.trans (by omega), hcolumn.trans (by omega), + hfound, by simp, hpayload⟩ + +theorem machineBetheFloorScanAdvanceRow_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanAdvanceRow state) := by + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + simp only [machineBetheFloorScanAdvanceRow, + MachineBetheFloorScanStateBound, + machineBetheFloorScanRow_pack, machineBetheFloorScanColumn_pack, + machineBetheFloorScanFound_pack, machineBetheFloorScanDone_pack, + machineBetheFloorScanPayload_pack, machineBetheFloorScanNextRow, + List.length_append, List.length_singleton, List.length_nil] + exact ⟨trivial, by omega, by omega, hfound, hdone, hpayload⟩ + +theorem machineBetheFloorScanAdvanceColumn_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanAdvanceColumn state) := by + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + simp only [machineBetheFloorScanAdvanceColumn, + MachineBetheFloorScanStateBound, + machineBetheFloorScanRow_pack, machineBetheFloorScanColumn_pack, + machineBetheFloorScanFound_pack, machineBetheFloorScanDone_pack, + machineBetheFloorScanPayload_pack, machineBetheFloorScanNextColumn, + List.length_append, List.length_singleton] + exact ⟨trivial, hrow.trans (by omega), by omega, hfound, hdone, hpayload⟩ + +theorem machineBetheFloorScanAdvance_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanAdvance state) := by + rw [machineBetheFloorScanAdvance] + cases hc : machineBetheFloorScanLastColumnBit state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFloorScanAdvanceColumn_bound hs + | cons columnBit columnTail => + rw [machineHeadBit_cons] + cases columnBit + Β· rw [machineIfHead_false] + exact machineBetheFloorScanAdvanceColumn_bound hs + Β· rw [machineIfHead_true] + cases hr : machineBetheFloorScanLastRowBit state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFloorScanAdvanceRow_bound hs + | cons rowBit rowTail => + rw [machineHeadBit_cons] + cases rowBit + Β· rw [machineIfHead_false] + exact machineBetheFloorScanAdvanceRow_bound hs + Β· rw [machineIfHead_true] + exact machineBetheFloorScanFinish_bound hs + +theorem machineBetheFloorScanProcess_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanProcess state) := by + rw [machineBetheFloorScanProcess] + cases hv : machineBetheFloorScanViolationBit state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFloorScanAdvance_bound hs + | cons violationBit violationTail => + rw [machineHeadBit_cons] + cases violationBit + Β· rw [machineIfHead_false] + exact machineBetheFloorScanAdvance_bound hs + Β· rw [machineIfHead_true] + exact machineBetheFloorScanMarkFound_bound hs + +theorem machineBetheFloorScanStep_bound {word state : List Bool} + {iterations : β„•} + (hs : MachineBetheFloorScanStateBound word iterations state) : + MachineBetheFloorScanStateBound word (iterations + 1) + (machineBetheFloorScanStep state) := by + rw [machineBetheFloorScanStep] + cases hf : machineBetheFloorScanFound state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + cases hd : machineBetheFloorScanDone state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFloorScanProcess_bound hs + | cons doneBit doneTail => + rw [machineHeadBit_cons] + cases doneBit + Β· rw [machineIfHead_false] + exact machineBetheFloorScanProcess_bound hs + Β· rw [machineIfHead_true] + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + exact ⟨hdecomp, hrow.trans (by omega), + hcolumn.trans (by omega), hfound, hdone, hpayload⟩ + | cons foundBit foundTail => + rw [machineHeadBit_cons] + cases foundBit + Β· rw [machineIfHead_false] + cases hd : machineBetheFloorScanDone state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + exact machineBetheFloorScanProcess_bound hs + | cons doneBit doneTail => + rw [machineHeadBit_cons] + cases doneBit + Β· rw [machineIfHead_false] + exact machineBetheFloorScanProcess_bound hs + Β· rw [machineIfHead_true] + rcases hs with + ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + exact ⟨hdecomp, hrow.trans (by omega), + hcolumn.trans (by omega), hfound, hdone, hpayload⟩ + Β· rw [machineIfHead_true] + rcases hs with ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + exact ⟨hdecomp, hrow.trans (by omega), + hcolumn.trans (by omega), hfound, hdone, hpayload⟩ + +theorem machineBetheFloorScanIterate_bound (word : List Bool) : βˆ€ k, + MachineBetheFloorScanStateBound word k + ((machineBetheFloorScanStep)^[k] + (machineBetheFloorScanInit word)) := by + intro k + induction k with + | zero => exact machineBetheFloorScanInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineBetheFloorScanStep_bound ih + +theorem machineBetheFloorScanRuler_length_le_envelope (word : List Bool) : + (machineBetheFloorScanRuler word).length ≀ + (machineBinaryMulWidth word).length := by + let input := pair (machineBetheFloorScanGuard word) + (machineBetheFloorScanWorkBits word) + have hbound := machineBoundedUnaryIterate_bound input + (machineBetheFloorScanGuard word).length + have hacc := hbound.2.2 + simpa only [machineBetheFloorScanRuler, machineBoundedUnary, + machineBoundedUnaryFinalState, machineBoundedUnaryRuler, + input, machinePairFirst_pair, machineBetheFloorScanGuard] using! hacc + +theorem machineBetheFloorScanIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBetheFloorScanRuler word).length) : + ((machineBetheFloorScanStep)^[iterations] + (machineBetheFloorScanInit word)).length ≀ + (machineBetheFloorScanWidth word).length := by + rcases machineBetheFloorScanIterate_bound word iterations with + ⟨hdecomp, hrow, hcolumn, hfound, hdone, hpayload⟩ + have hk : iterations ≀ (machineBinaryMulWidth word).length := + hiterations.trans (machineBetheFloorScanRuler_length_le_envelope word) + rw [hdecomp] + simp only [machineBetheFloorScanPack, machineBetheFloorScanWidth, + machineBetheFloorScanStateEnvelope, pair_length, + machineBinaryMulWidth, List.length_replicate, List.length_append] + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] at hk + nlinarith [sq_nonneg word.length] + +theorem machineBetheFloorScanFinalState_mem_FP : + machineBetheFloorScanFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineBetheFloorScanStep_mem_FP + machineBetheFloorScanInit_mem_FP machineBetheFloorScanRuler_mem_FP + machineBetheFloorScanWidth_mem_FP + machineBetheFloorScanIterate_length_le_width + +theorem machineBetheFloorScanResultCode_mem_FP : + machineBetheFloorScanResultCode ∈ FP := by + have hfound := machineCompose_mem_FP + machineBetheFloorScanFinalState_mem_FP machineBetheFloorScanFound_mem_FP + have hrow := machineCompose_mem_FP + machineBetheFloorScanFinalState_mem_FP machineBetheFloorScanRow_mem_FP + have hcolumn := machineCompose_mem_FP + machineBetheFloorScanFinalState_mem_FP machineBetheFloorScanColumn_mem_FP + exact machinePair_mem_FP hfound (machinePair_mem_FP hrow hcolumn) + +/-! ## Canonical ruler semantics -/ + +/-- Encodes a dimension, rational threshold, and coordinate vector as a canonical floor-scan +input. -/ +def machineBetheFloorScanCanonicalWord {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : List Bool := + pair (List.replicate m true) + (pair (rawRatBinaryCode delta) (rationalFiniteVectorCode y)) + +@[simp] theorem machineBetheFloorScanDimension_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanDimension + (machineBetheFloorScanCanonicalWord delta y) = + List.replicate m true := by + simp [machineBetheFloorScanDimension, + machineBetheFloorScanCanonicalWord] + +@[simp] theorem machineBetheFloorScanThreshold_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanThreshold + (machineBetheFloorScanCanonicalWord delta y) = + rawRatBinaryCode delta := by + simp [machineBetheFloorScanThreshold, machineBetheFloorScanRest, + machineBetheFloorScanCanonicalWord] + +@[simp] theorem machineBetheFloorScanVector_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanVector + (machineBetheFloorScanCanonicalWord delta y) = + rationalFiniteVectorCode y := by + simp [machineBetheFloorScanVector, machineBetheFloorScanRest, + machineBetheFloorScanCanonicalWord] + +@[simp] theorem machineBetheFloorScanWorkBits_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanWorkBits + (machineBetheFloorScanCanonicalWord delta y) = + ((m + 1) * (m + 1)).bits := by + rw [machineBetheFloorScanWorkBits, machineBetheFloorScanOrderBits, + machineBetheFloorScanDimensionBits, + machineBetheFloorScanDimension_encode, machineLengthBits_encode, + List.length_replicate] + have hone : ([true] : List Bool) = (1 : β„•).bits := rfl + rw [hone, machineBinaryAddBits_pair_natBits, + machineBinaryMulBits_pair_natBits] + +theorem machineBetheFloorScanWork_le_guard {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + (m + 1) * (m + 1) ≀ + (machineBetheFloorScanGuard + (machineBetheFloorScanCanonicalWord delta y)).length := by + have hm : m ≀ (machineBetheFloorScanCanonicalWord delta y).length := by + simp only [machineBetheFloorScanCanonicalWord, pair_length, + List.length_replicate] + omega + simp only [machineBetheFloorScanGuard, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +@[simp] theorem machineBetheFloorScanRuler_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanRuler + (machineBetheFloorScanCanonicalWord delta y) = + List.replicate ((m + 1) * (m + 1)) true := by + rw [machineBetheFloorScanRuler, + machineBetheFloorScanWorkBits_encode, + machineBoundedUnary_encode_of_le] + exact machineBetheFloorScanWork_le_guard delta y + +/-! ## Exact state semantics on canonical inputs -/ + +/-- Successor inside `Fin (m+1)`, fixing the last element. The scan invokes +this operation only away from the last element. -/ +def betheFloorScanNextFin {m : β„•} (i : Fin (m + 1)) : Fin (m + 1) := + if h : i.1 < m then ⟨i.1 + 1, by omega⟩ else i + +@[simp] theorem betheFloorScanNextFin_val {m : β„•} + (i : Fin (m + 1)) (hi : i β‰  Fin.last m) : + (betheFloorScanNextFin i).1 = i.1 + 1 := by + have hlt : i.1 < m := by + have hle : i.1 ≀ m := by omega + have hne : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + omega + simp [betheFloorScanNextFin, hlt] + +/-- Typed semantic state mirrored by the finite-word scan. -/ +structure BetheFloorScanSemanticState (m : β„•) where + /-- Current row of the affine matrix, whose indices range from zero through `m`. -/ + row : Fin (m + 1) + /-- Current column of the affine matrix, whose indices range from zero through `m`. -/ + column : Fin (m + 1) + /-- Records whether the scan has found an entry below the floor threshold. -/ + found : Bool + /-- Records whether the scan has examined all matrix entries without stopping at a violation. -/ + done : Bool + +/-- Initializes the semantic floor scan at the first matrix entry with both flags false. -/ +def betheFloorScanSemanticInit (m : β„•) : + BetheFloorScanSemanticState m where + row := ⟨0, by omega⟩ + column := ⟨0, by omega⟩ + found := false + done := false + +/-- Scans one affine matrix entry in row-major order, stopping at a floor violation or +completion. -/ +def betheFloorScanSemanticStep {m : β„•} (delta : RawRat) + (y : Fin (m * m) β†’ β„š) (state : BetheFloorScanSemanticState m) : + BetheFloorScanSemanticState m := + if state.found then state + else if state.done then state + else if betheAffineMatrixQ y state.row state.column < delta.value then + { state with found := true } + else if hcolumn : state.column = Fin.last m then + if hrow : state.row = Fin.last m then + { state with done := true } + else + { state with + row := betheFloorScanNextFin state.row + column := ⟨0, by omega⟩ } + else + { state with column := betheFloorScanNextFin state.column } + +/-- Encodes a semantic scan state with unary indices, Boolean flags, and its canonical input. -/ +def machineBetheFloorScanCanonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : List Bool := + machineBetheFloorScanPack + (List.replicate state.row.1 true) + (List.replicate state.column.1 true) + [state.found] [state.done] + (machineBetheFloorScanCanonicalWord delta y) + +@[simp] theorem machineBetheFloorScanRow_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanRow + (machineBetheFloorScanCanonicalState delta y state) = + List.replicate state.row.1 true := by + simp [machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanColumn_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanColumn + (machineBetheFloorScanCanonicalState delta y state) = + List.replicate state.column.1 true := by + simp [machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanFound_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanFound + (machineBetheFloorScanCanonicalState delta y state) = + [state.found] := by + simp [machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanDone_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanDone + (machineBetheFloorScanCanonicalState delta y state) = + [state.done] := by + simp [machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanPayload_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanPayload + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalWord delta y := by + simp [machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanStateDimension_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanStateDimension + (machineBetheFloorScanCanonicalState delta y state) = + List.replicate m true := by + rw [machineBetheFloorScanStateDimension, + machineBetheFloorScanPayload_canonicalState, + machineBetheFloorScanDimension_encode] + +@[simp] theorem machineBetheFloorScanStateThreshold_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanStateThreshold + (machineBetheFloorScanCanonicalState delta y state) = + rawRatBinaryCode delta := by + rw [machineBetheFloorScanStateThreshold, + machineBetheFloorScanPayload_canonicalState, + machineBetheFloorScanThreshold_encode] + +@[simp] theorem machineBetheFloorScanStateVector_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanStateVector + (machineBetheFloorScanCanonicalState delta y state) = + rationalFiniteVectorCode y := by + rw [machineBetheFloorScanStateVector, + machineBetheFloorScanPayload_canonicalState, + machineBetheFloorScanVector_encode] + +@[simp] theorem machineBetheFloorScanLastRowBit_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanLastRowBit + (machineBetheFloorScanCanonicalState delta y state) = + [decide (state.row = Fin.last m)] := by + rw [machineBetheFloorScanLastRowBit, + machineBetheFloorScanRow_canonicalState, + machineBetheFloorScanStateDimension_canonicalState, + machineUnaryRulersEqualBit_replicate] + by_cases hi : state.row = Fin.last m + Β· simp [hi] + Β· have hval : state.row.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + simp [hi, hval] + +@[simp] theorem machineBetheFloorScanLastColumnBit_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanLastColumnBit + (machineBetheFloorScanCanonicalState delta y state) = + [decide (state.column = Fin.last m)] := by + rw [machineBetheFloorScanLastColumnBit, + machineBetheFloorScanColumn_canonicalState, + machineBetheFloorScanStateDimension_canonicalState, + machineUnaryRulersEqualBit_replicate] + by_cases hj : state.column = Fin.last m + Β· simp [hj] + Β· have hval : state.column.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + simp [hj, hval] + +@[simp] theorem machineBetheFloorScanEntryWord_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanEntryWord + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheAffineEntryCanonicalWord state.row state.column y := by + simp [machineBetheFloorScanEntryWord, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineBetheFloorScanTestWord_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanTestWord + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorTestCanonicalWord delta state.row state.column y := by + simp [machineBetheFloorScanTestWord, + machineBetheFloorTestCanonicalWord] + +@[simp] theorem machineBetheFloorScanViolationBit_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanViolationBit + (machineBetheFloorScanCanonicalState delta y state) = + [decide (betheAffineMatrixQ y state.row state.column < delta.value)] := by + rw [machineBetheFloorScanViolationBit, + machineBetheFloorScanTestWord_canonicalState, + machineBetheFloorViolationBit_encode] + +@[simp] theorem machineBetheFloorScanNextRow_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) + (hrow : state.row β‰  Fin.last m) : + machineBetheFloorScanNextRow + (machineBetheFloorScanCanonicalState delta y state) = + List.replicate (betheFloorScanNextFin state.row).1 true := by + rw [machineBetheFloorScanNextRow, + machineBetheFloorScanRow_canonicalState, + betheFloorScanNextFin_val state.row hrow, + List.replicate_succ'] + +@[simp] theorem machineBetheFloorScanNextColumn_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) + (hcolumn : state.column β‰  Fin.last m) : + machineBetheFloorScanNextColumn + (machineBetheFloorScanCanonicalState delta y state) = + List.replicate (betheFloorScanNextFin state.column).1 true := by + rw [machineBetheFloorScanNextColumn, + machineBetheFloorScanColumn_canonicalState, + betheFloorScanNextFin_val state.column hcolumn, + List.replicate_succ'] + +@[simp] theorem machineBetheFloorScanMarkFound_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanMarkFound + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + { state with found := true } := by + simp [machineBetheFloorScanMarkFound, + machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanFinish_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanFinish + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + { state with done := true } := by + simp [machineBetheFloorScanFinish, + machineBetheFloorScanCanonicalState] + +@[simp] theorem machineBetheFloorScanAdvanceRow_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) + (hrow : state.row β‰  Fin.last m) : + machineBetheFloorScanAdvanceRow + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + { state with + row := betheFloorScanNextFin state.row + column := ⟨0, by omega⟩ } := by + rw [machineBetheFloorScanAdvanceRow] + simp only [machineBetheFloorScanNextRow_canonicalState delta y state hrow, + machineBetheFloorScanFound_canonicalState, + machineBetheFloorScanDone_canonicalState, + machineBetheFloorScanPayload_canonicalState] + rfl + +@[simp] theorem machineBetheFloorScanAdvanceColumn_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) + (hcolumn : state.column β‰  Fin.last m) : + machineBetheFloorScanAdvanceColumn + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + { state with column := betheFloorScanNextFin state.column } := by + rw [machineBetheFloorScanAdvanceColumn] + simp only [machineBetheFloorScanRow_canonicalState, + machineBetheFloorScanNextColumn_canonicalState delta y state hcolumn, + machineBetheFloorScanFound_canonicalState, + machineBetheFloorScanDone_canonicalState, + machineBetheFloorScanPayload_canonicalState] + rfl + +@[simp] theorem machineBetheFloorScanStep_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : + machineBetheFloorScanStep + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + (betheFloorScanSemanticStep delta y state) := by + cases hfound : state.found + Β· cases hdone : state.done + Β· by_cases hbelow : + betheAffineMatrixQ y state.row state.column < delta.value + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_false, + machineBetheFloorScanDone_canonicalState, + machineHeadBit_cons, hdone, machineIfHead_false, + machineBetheFloorScanProcess, + machineBetheFloorScanViolationBit_canonicalState, + machineHeadBit_cons] + have hdecBelow : decide + (betheAffineMatrixQ y state.row state.column < delta.value) = + true := by simp [hbelow] + rw [hdecBelow, machineIfHead_true, + machineBetheFloorScanMarkFound_canonicalState] + simp [betheFloorScanSemanticStep, hfound, hdone, hbelow] + Β· by_cases hcolumn : state.column = Fin.last m + Β· by_cases hrow : state.row = Fin.last m + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_false, + machineBetheFloorScanDone_canonicalState, + machineHeadBit_cons, hdone, machineIfHead_false, + machineBetheFloorScanProcess, + machineBetheFloorScanViolationBit_canonicalState, + machineHeadBit_cons] + have hdecBelow : decide + (betheAffineMatrixQ y state.row state.column < delta.value) = + false := by simp [hbelow] + have hdecColumn : decide + (state.column = Fin.last m) = true := by simp [hcolumn] + have hdecRow : decide + (state.row = Fin.last m) = true := by simp [hrow] + have hbelowLast : Β¬betheAffineMatrixQ y + (Fin.last m) (Fin.last m) < delta.value := by + simpa [hrow, hcolumn] using! hbelow + rw [hdecBelow, machineIfHead_false, + machineBetheFloorScanAdvance, + machineBetheFloorScanLastColumnBit_canonicalState, + machineHeadBit_cons, hdecColumn, machineIfHead_true, + machineBetheFloorScanLastRowBit_canonicalState, + machineHeadBit_cons, hdecRow, machineIfHead_true, + machineBetheFloorScanFinish_canonicalState] + simp [betheFloorScanSemanticStep, hfound, hdone, hbelowLast, + hcolumn, hrow] + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_false, + machineBetheFloorScanDone_canonicalState, + machineHeadBit_cons, hdone, machineIfHead_false, + machineBetheFloorScanProcess, + machineBetheFloorScanViolationBit_canonicalState, + machineHeadBit_cons] + have hdecBelow : decide + (betheAffineMatrixQ y state.row state.column < delta.value) = + false := by simp [hbelow] + have hdecColumn : decide + (state.column = Fin.last m) = true := by simp [hcolumn] + have hdecRow : decide + (state.row = Fin.last m) = false := by simp [hrow] + have hbelowLastColumn : Β¬betheAffineMatrixQ y + state.row (Fin.last m) < delta.value := by + simpa [hcolumn] using! hbelow + rw [hdecBelow, machineIfHead_false, + machineBetheFloorScanAdvance, + machineBetheFloorScanLastColumnBit_canonicalState, + machineHeadBit_cons, hdecColumn, machineIfHead_true, + machineBetheFloorScanLastRowBit_canonicalState, + machineHeadBit_cons, hdecRow, machineIfHead_false, + machineBetheFloorScanAdvanceRow_canonicalState delta y state hrow] + simp [betheFloorScanSemanticStep, hfound, hdone, + hbelowLastColumn, hcolumn, hrow] + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_false, + machineBetheFloorScanDone_canonicalState, + machineHeadBit_cons, hdone, machineIfHead_false, + machineBetheFloorScanProcess, + machineBetheFloorScanViolationBit_canonicalState, + machineHeadBit_cons] + have hdecBelow : decide + (betheAffineMatrixQ y state.row state.column < delta.value) = + false := by simp [hbelow] + have hdecColumn : decide + (state.column = Fin.last m) = false := by simp [hcolumn] + rw [hdecBelow, machineIfHead_false, + machineBetheFloorScanAdvance, + machineBetheFloorScanLastColumnBit_canonicalState, + machineHeadBit_cons, hdecColumn, machineIfHead_false, + machineBetheFloorScanAdvanceColumn_canonicalState + delta y state hcolumn] + simp [betheFloorScanSemanticStep, hfound, hdone, hbelow, + hcolumn] + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_false, + machineBetheFloorScanDone_canonicalState, + machineHeadBit_cons, hdone, machineIfHead_true] + simp [betheFloorScanSemanticStep, hfound, hdone] + Β· rw [machineBetheFloorScanStep, + machineBetheFloorScanFound_canonicalState, + machineHeadBit_cons, hfound, machineIfHead_true] + simp [betheFloorScanSemanticStep, hfound] + +theorem machineBetheFloorScanIterate_canonicalState {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) : βˆ€ k, + (machineBetheFloorScanStep)^[k] + (machineBetheFloorScanCanonicalState delta y state) = + machineBetheFloorScanCanonicalState delta y + ((betheFloorScanSemanticStep delta y)^[k] state) := by + intro k + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih, + machineBetheFloorScanStep_canonicalState] + +@[simp] theorem machineBetheFloorScanInit_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanInit + (machineBetheFloorScanCanonicalWord delta y) = + machineBetheFloorScanCanonicalState delta y + (betheFloorScanSemanticInit m) := by + simp [machineBetheFloorScanInit, machineBetheFloorScanCanonicalState, + betheFloorScanSemanticInit] + +/-- Runs the semantic scan for `(m + 1)^2` steps, enough to examine every matrix entry. -/ +def finalBetheFloorScanSemanticState {m : β„•} (delta : RawRat) + (y : Fin (m * m) β†’ β„š) : BetheFloorScanSemanticState m := + (betheFloorScanSemanticStep delta y)^[(m + 1) * (m + 1)] + (betheFloorScanSemanticInit m) + +@[simp] theorem machineBetheFloorScanFinalState_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanFinalState + (machineBetheFloorScanCanonicalWord delta y) = + machineBetheFloorScanCanonicalState delta y + (finalBetheFloorScanSemanticState delta y) := by + rw [machineBetheFloorScanFinalState, machineBetheFloorScanRuler_encode, + List.length_replicate, machineBetheFloorScanInit_encode, + machineBetheFloorScanIterate_canonicalState] + rfl + +/-- Encodes the found flag and the row and column at which the semantic scan stopped. -/ +def betheFloorScanSemanticResultCode {m : β„•} + (state : BetheFloorScanSemanticState m) : List Bool := + pair [state.found] + (pair (List.replicate state.row.1 true) + (List.replicate state.column.1 true)) + +@[simp] theorem machineBetheFloorScanResultCode_encode {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + machineBetheFloorScanResultCode + (machineBetheFloorScanCanonicalWord delta y) = + betheFloorScanSemanticResultCode + (finalBetheFloorScanSemanticState delta y) := by + rw [machineBetheFloorScanResultCode, + machineBetheFloorScanFinalState_encode] + simp [betheFloorScanSemanticResultCode] + +/-! ## Mathematical correctness of the row-major semantic scan -/ + +/-- Numbers matrix entries in row-major order by `i * (m + 1) + j`. -/ +def betheFloorScanOrdinal {m : β„•} + (i j : Fin (m + 1)) : β„• := i.1 * (m + 1) + j.1 + +theorem betheFloorScanOrdinal_lt_square {m : β„•} + (i j : Fin (m + 1)) : + betheFloorScanOrdinal i j < (m + 1) * (m + 1) := by + rw [betheFloorScanOrdinal] + calc + i.1 * (m + 1) + j.1 < i.1 * (m + 1) + (m + 1) := + Nat.add_lt_add_left j.isLt _ + _ = (i.1 + 1) * (m + 1) := by ring + _ ≀ (m + 1) * (m + 1) := + Nat.mul_le_mul_right (m + 1) (by omega) + +theorem betheFloorScanOrdinal_injective (m : β„•) : + Function.Injective + (fun ij : Fin (m + 1) Γ— Fin (m + 1) ↦ + betheFloorScanOrdinal ij.1 ij.2) := by + intro a b hab + have hmod := congrArg (fun q : β„• ↦ q % (m + 1)) hab + have hmodA : betheFloorScanOrdinal a.1 a.2 % (m + 1) = a.2.1 := by + simp [betheFloorScanOrdinal, Nat.add_mod, + Nat.mod_eq_of_lt a.2.isLt] + have hmodB : betheFloorScanOrdinal b.1 b.2 % (m + 1) = b.2.1 := by + simp [betheFloorScanOrdinal, Nat.add_mod, + Nat.mod_eq_of_lt b.2.isLt] + have hcolumn : a.2.1 = b.2.1 := by + calc + a.2.1 = betheFloorScanOrdinal a.1 a.2 % (m + 1) := hmodA.symm + _ = betheFloorScanOrdinal b.1 b.2 % (m + 1) := hmod + _ = b.2.1 := hmodB + have hrowMul : a.1.1 * (m + 1) = b.1.1 * (m + 1) := by + have hab' := hab + simp only [betheFloorScanOrdinal] at hab' + rw [hcolumn] at hab' + exact Nat.add_right_cancel hab' + have hrow : a.1.1 = b.1.1 := + Nat.mul_right_cancel (by omega : 0 < m + 1) hrowMul + exact Prod.ext (Fin.ext hrow) (Fin.ext hcolumn) + +theorem betheFloorScanOrdinal_nextColumn {m : β„•} + (i j : Fin (m + 1)) (hj : j β‰  Fin.last m) : + betheFloorScanOrdinal i (betheFloorScanNextFin j) = + betheFloorScanOrdinal i j + 1 := by + simp [betheFloorScanOrdinal, betheFloorScanNextFin_val j hj] + omega + +theorem betheFloorScanOrdinal_nextRow {m : β„•} + (i : Fin (m + 1)) (hi : i β‰  Fin.last m) : + betheFloorScanOrdinal (betheFloorScanNextFin i) ⟨0, by omega⟩ = + betheFloorScanOrdinal i (Fin.last m) + 1 := by + rw [betheFloorScanOrdinal, betheFloorScanOrdinal, + betheFloorScanNextFin_val i hi] + simp + ring + +@[simp] theorem betheFloorScanOrdinal_last_last (m : β„•) : + betheFloorScanOrdinal (Fin.last m) (Fin.last m) + 1 = + (m + 1) * (m + 1) := by + simp [betheFloorScanOrdinal] + ring + +theorem betheFloorScanOrdinal_lt_last_of_ne {m : β„•} + (i j : Fin (m + 1)) + (hij : (i, j) β‰  (Fin.last m, Fin.last m)) : + betheFloorScanOrdinal i j < + betheFloorScanOrdinal (Fin.last m) (Fin.last m) := by + by_cases hi : i = Fin.last m + Β· have hj : j β‰  Fin.last m := by + intro hj + exact hij (by simp [hi, hj]) + have hjlt : j.1 < m := by + have hjle : j.1 ≀ m := by omega + have hjne : j.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + omega + subst i + simp only [betheFloorScanOrdinal, Fin.val_last] + omega + Β· have hilt : i.1 < m := by + have hile : i.1 ≀ m := by omega + have hine : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + omega + calc + betheFloorScanOrdinal i j < + (i.1 + 1) * (m + 1) := by + rw [betheFloorScanOrdinal] + calc + i.1 * (m + 1) + j.1 < + i.1 * (m + 1) + (m + 1) := + Nat.add_lt_add_left j.isLt _ + _ = (i.1 + 1) * (m + 1) := by ring + _ ≀ m * (m + 1) := + Nat.mul_le_mul_right (m + 1) (by omega) + _ ≀ betheFloorScanOrdinal (Fin.last m) (Fin.last m) := by + simp [betheFloorScanOrdinal] + +/-- Records either the first violating entry, successful completion, or the next unchecked +ordinal. -/ +def BetheFloorScanInvariant {m : β„•} (delta : RawRat) + (y : Fin (m * m) β†’ β„š) (k : β„•) + (state : BetheFloorScanSemanticState m) : Prop := + (state.found = true ∧ + betheAffineMatrixQ y state.row state.column < delta.value ∧ + betheFloorScanOrdinal state.row state.column < k ∧ + βˆ€ i j, + betheFloorScanOrdinal i j < + betheFloorScanOrdinal state.row state.column β†’ + delta.value ≀ betheAffineMatrixQ y i j) ∨ + (state.found = false ∧ state.done = true ∧ + (m + 1) * (m + 1) ≀ k ∧ + βˆ€ i j, delta.value ≀ betheAffineMatrixQ y i j) ∨ + (state.found = false ∧ state.done = false ∧ + betheFloorScanOrdinal state.row state.column = k ∧ + βˆ€ i j, betheFloorScanOrdinal i j < k β†’ + delta.value ≀ betheAffineMatrixQ y i j) + +theorem betheFloorScanExtendPrior {m k : β„•} {delta : RawRat} + {y : Fin (m * m) β†’ β„š} + {row column : Fin (m + 1)} + (hordinal : betheFloorScanOrdinal row column = k) + (hprior : βˆ€ i j, betheFloorScanOrdinal i j < k β†’ + delta.value ≀ betheAffineMatrixQ y i j) + (hcurrent : delta.value ≀ betheAffineMatrixQ y row column) : + βˆ€ i j, betheFloorScanOrdinal i j < k + 1 β†’ + delta.value ≀ betheAffineMatrixQ y i j := by + intro i j hij + by_cases hlt : betheFloorScanOrdinal i j < k + Β· exact hprior i j hlt + Β· have heqOrdinal : betheFloorScanOrdinal i j = + betheFloorScanOrdinal row column := by omega + have hpairs : (i, j) = (row, column) := + betheFloorScanOrdinal_injective m heqOrdinal + cases hpairs + exact hcurrent + +theorem betheFloorScanSemanticInit_invariant {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + BetheFloorScanInvariant delta y 0 + (betheFloorScanSemanticInit m) := by + right + right + simp [betheFloorScanSemanticInit, betheFloorScanOrdinal] + +theorem betheFloorScanSemanticStep_invariant {m k : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (state : BetheFloorScanSemanticState m) + (hinvariant : BetheFloorScanInvariant delta y k state) : + BetheFloorScanInvariant delta y (k + 1) + (betheFloorScanSemanticStep delta y state) := by + rcases hinvariant with hfound | hrest + Β· rcases hfound with ⟨hfound, hbelow, hord, hprior⟩ + have hstep : betheFloorScanSemanticStep delta y state = state := by + simp [betheFloorScanSemanticStep, hfound] + rw [hstep] + left + exact ⟨hfound, hbelow, by omega, hprior⟩ + Β· rcases hrest with hdone | hactive + Β· rcases hdone with ⟨hfound, hdone, hwork, hall⟩ + have hstep : betheFloorScanSemanticStep delta y state = state := by + simp [betheFloorScanSemanticStep, hfound, hdone] + rw [hstep] + right + left + exact ⟨hfound, hdone, hwork.trans (by omega), hall⟩ + Β· rcases hactive with ⟨hfound, hdone, hord, hprior⟩ + by_cases hbelow : + betheAffineMatrixQ y state.row state.column < delta.value + Β· have hstep : betheFloorScanSemanticStep delta y state = + { state with found := true } := by + simp [betheFloorScanSemanticStep, hfound, hdone, hbelow] + rw [hstep] + left + refine ⟨rfl, hbelow, ?_, ?_⟩ + Β· change betheFloorScanOrdinal state.row state.column < k + 1 + omega + intro i j hij + apply hprior i j + rwa [hord] at hij + Β· have hcurrent : delta.value ≀ + betheAffineMatrixQ y state.row state.column := not_lt.mp hbelow + have hextend := betheFloorScanExtendPrior hord hprior hcurrent + by_cases hcolumn : state.column = Fin.last m + Β· by_cases hrow : state.row = Fin.last m + Β· have hbelowLast : Β¬betheAffineMatrixQ y + (Fin.last m) (Fin.last m) < delta.value := by + simpa [hrow, hcolumn] using! hbelow + have hcurrentLast : delta.value ≀ betheAffineMatrixQ y + (Fin.last m) (Fin.last m) := not_lt.mp hbelowLast + have hstep : betheFloorScanSemanticStep delta y state = + { state with done := true } := by + simp [betheFloorScanSemanticStep, hfound, hdone, hbelowLast, + hcolumn, hrow] + rw [hstep] + right + left + refine ⟨hfound, rfl, ?_, ?_⟩ + Β· calc + (m + 1) * (m + 1) = + betheFloorScanOrdinal (Fin.last m) (Fin.last m) + 1 := + (betheFloorScanOrdinal_last_last m).symm + _ = betheFloorScanOrdinal state.row state.column + 1 := by + rw [hrow, hcolumn] + _ = k + 1 := congrArg (Β· + 1) hord + _ ≀ k + 1 := le_rfl + Β· intro i j + by_cases hij : (i, j) = (Fin.last m, Fin.last m) + Β· cases hij + exact hcurrentLast + Β· apply hprior i j + rw [← hord, hrow, hcolumn] + exact betheFloorScanOrdinal_lt_last_of_ne i j hij + Β· have hbelowLastColumn : Β¬betheAffineMatrixQ y + state.row (Fin.last m) < delta.value := by + simpa [hcolumn] using! hbelow + have hstep : betheFloorScanSemanticStep delta y state = + { state with + row := betheFloorScanNextFin state.row + column := ⟨0, by omega⟩ } := by + simp [betheFloorScanSemanticStep, hfound, hdone, + hbelowLastColumn, hcolumn, hrow] + rw [hstep] + right + right + refine ⟨hfound, hdone, ?_, hextend⟩ + rw [betheFloorScanOrdinal_nextRow state.row hrow, + ← hcolumn, hord] + Β· have hstep : betheFloorScanSemanticStep delta y state = + { state with + column := betheFloorScanNextFin state.column } := by + simp [betheFloorScanSemanticStep, hfound, hdone, hbelow, + hcolumn] + rw [hstep] + right + right + refine ⟨hfound, hdone, ?_, hextend⟩ + rw [betheFloorScanOrdinal_nextColumn state.row state.column hcolumn, + hord] + +theorem betheFloorScanSemanticIterate_invariant {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : βˆ€ k, + BetheFloorScanInvariant delta y k + ((betheFloorScanSemanticStep delta y)^[k] + (betheFloorScanSemanticInit m)) := by + intro k + induction k with + | zero => exact betheFloorScanSemanticInit_invariant delta y + | succ k ih => + rw [Function.iterate_succ_apply'] + exact betheFloorScanSemanticStep_invariant delta y _ ih + +theorem finalBetheFloorScanSemanticState_invariant {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + BetheFloorScanInvariant delta y ((m + 1) * (m + 1)) + (finalBetheFloorScanSemanticState delta y) := by + simpa only [finalBetheFloorScanSemanticState] using! + betheFloorScanSemanticIterate_invariant delta y + ((m + 1) * (m + 1)) + +theorem finalBetheFloorScanSemanticState_found_is_below {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (hfound : (finalBetheFloorScanSemanticState delta y).found = true) : + betheAffineMatrixQ y + (finalBetheFloorScanSemanticState delta y).row + (finalBetheFloorScanSemanticState delta y).column < delta.value := by + rcases finalBetheFloorScanSemanticState_invariant delta y with + hfoundCase | hrest + Β· exact hfoundCase.2.1 + Β· rcases hrest with hdoneCase | hactiveCase + Β· rw [hfound] at hdoneCase + simp at hdoneCase + Β· rw [hfound] at hactiveCase + simp at hactiveCase + +theorem finalBetheFloorScanSemanticState_notFound_all_above {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) + (hnotFound : + (finalBetheFloorScanSemanticState delta y).found = false) : + βˆ€ i j, delta.value ≀ betheAffineMatrixQ y i j := by + rcases finalBetheFloorScanSemanticState_invariant delta y with + hfoundCase | hrest + Β· rw [hnotFound] at hfoundCase + simp at hfoundCase + Β· rcases hrest with hdoneCase | hactiveCase + Β· exact hdoneCase.2.2.2 + Β· exfalso + have heq := hactiveCase.2.2.1 + have hlt := betheFloorScanOrdinal_lt_square + (finalBetheFloorScanSemanticState delta y).row + (finalBetheFloorScanSemanticState delta y).column + omega + +theorem finalBetheFloorScanSemanticState_found_iff_exists_below {m : β„•} + (delta : RawRat) (y : Fin (m * m) β†’ β„š) : + (finalBetheFloorScanSemanticState delta y).found = true ↔ + βˆƒ i j, betheAffineMatrixQ y i j < delta.value := by + constructor + Β· intro hfound + exact ⟨(finalBetheFloorScanSemanticState delta y).row, + (finalBetheFloorScanSemanticState delta y).column, + finalBetheFloorScanSemanticState_found_is_below delta y hfound⟩ + Β· rintro ⟨i, j, hij⟩ + cases hfound : (finalBetheFloorScanSemanticState delta y).found + Β· have hall := finalBetheFloorScanSemanticState_notFound_all_above + delta y hfound i j + exact (not_lt_of_ge hall hij).elim + Β· rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorTest.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorTest.lean new file mode 100644 index 0000000000..18537d3aaf --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheFloorTest.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheAffineEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineBool + +/-! +# Exact finite-word test for a violated Bethe floor constraint + +The floor oracle must distinguish the strict inequality +`betheAffineMatrixQ y i j < delta` from the permitted boundary case. We do +this without normalization or approximate arithmetic: compute the recovered +entry as an unreduced rational and negate the exact comparison +`delta <= entry`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the encoded rational threshold from a floor-test input. -/ +def machineBetheFloorTestThreshold (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the affine-entry query from a floor-test input. -/ +def machineBetheFloorTestEntryWord (word : List Bool) : List Bool := + machinePairSecond word + +/-- Computes the encoded raw rational value of the queried affine matrix entry. -/ +def machineBetheFloorTestEntryRawCode (word : List Bool) : List Bool := + machineBetheAffineEntryRawCode (machineBetheFloorTestEntryWord word) + +/-- Compares the encoded floor threshold with the queried affine matrix entry. -/ +def machineBetheFloorTestThresholdLeEntryBit + (word : List Bool) : List Bool := + machineRawRatLeBit + (pair (machineBetheFloorTestThreshold word) + (machineBetheFloorTestEntryRawCode word)) + +/-- One-bit answer, true exactly when the recovered entry is strictly below +the supplied rational floor on canonical inputs. -/ +def machineBetheFloorViolationBit (word : List Bool) : List Bool := + machineNotBit (machineBetheFloorTestThresholdLeEntryBit word) + +theorem machineBetheFloorTestThreshold_mem_FP : + machineBetheFloorTestThreshold ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheFloorTestEntryWord_mem_FP : + machineBetheFloorTestEntryWord ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheFloorTestEntryRawCode_mem_FP : + machineBetheFloorTestEntryRawCode ∈ FP := by + simpa only [machineBetheFloorTestEntryRawCode] using! + machineCompose_mem_FP machineBetheFloorTestEntryWord_mem_FP + machineBetheAffineEntryRawCode_mem_FP + +theorem machineBetheFloorTestThresholdLeEntryBit_mem_FP : + machineBetheFloorTestThresholdLeEntryBit ∈ FP := by + have hinput := machinePair_mem_FP + machineBetheFloorTestThreshold_mem_FP + machineBetheFloorTestEntryRawCode_mem_FP + simpa only [machineBetheFloorTestThresholdLeEntryBit] using! + machineCompose_mem_FP hinput machineRawRatLeBit_mem_FP + +theorem machineBetheFloorViolationBit_mem_FP : + machineBetheFloorViolationBit ∈ FP := by + simpa only [machineBetheFloorViolationBit] using! + machineNotBit_mem_FP + machineBetheFloorTestThresholdLeEntryBit_mem_FP + +/-- Encodes a threshold, matrix indices, and coordinate vector for a canonical floor test. -/ +def machineBetheFloorTestCanonicalWord {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : List Bool := + pair (rawRatBinaryCode delta) + (machineBetheAffineEntryCanonicalWord i j y) + +@[simp] theorem machineBetheFloorTestThreshold_encode {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : + machineBetheFloorTestThreshold + (machineBetheFloorTestCanonicalWord delta i j y) = + rawRatBinaryCode delta := by + simp [machineBetheFloorTestThreshold, + machineBetheFloorTestCanonicalWord] + +@[simp] theorem machineBetheFloorTestEntryWord_encode {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : + machineBetheFloorTestEntryWord + (machineBetheFloorTestCanonicalWord delta i j y) = + machineBetheAffineEntryCanonicalWord i j y := by + simp [machineBetheFloorTestEntryWord, + machineBetheFloorTestCanonicalWord] + +@[simp] theorem machineBetheFloorTestEntryRawCode_encode {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : + machineBetheFloorTestEntryRawCode + (machineBetheFloorTestCanonicalWord delta i j y) = + rawRatBinaryCode (rawBetheAffineEntry y i j) := by + rw [machineBetheFloorTestEntryRawCode, + machineBetheFloorTestEntryWord_encode, + machineBetheAffineEntryRawCode_encode] + +@[simp] theorem machineBetheFloorTestThresholdLeEntryBit_encode {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : + machineBetheFloorTestThresholdLeEntryBit + (machineBetheFloorTestCanonicalWord delta i j y) = + [decide (delta.value ≀ betheAffineMatrixQ y i j)] := by + rw [machineBetheFloorTestThresholdLeEntryBit, + machineBetheFloorTestThreshold_encode, + machineBetheFloorTestEntryRawCode_encode, + machineRawRatLeBit_encode, + rawBetheAffineEntry_value] + +@[simp] theorem machineBetheFloorViolationBit_encode {m : β„•} + (delta : RawRat) (i j : Fin (m + 1)) + (y : Fin (m * m) β†’ β„š) : + machineBetheFloorViolationBit + (machineBetheFloorTestCanonicalWord delta i j y) = + [decide (betheAffineMatrixQ y i j < delta.value)] := by + rw [machineBetheFloorViolationBit, + machineBetheFloorTestThresholdLeEntryBit_encode, + machineNotBit_one] + by_cases h : delta.value ≀ betheAffineMatrixQ y i j + Β· have hnot : Β¬betheAffineMatrixQ y i j < delta.value := + not_lt_of_ge h + simp [h, hnot] + Β· have hlt : betheAffineMatrixQ y i j < delta.value := lt_of_not_ge h + simp [h, hlt] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightCap.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightCap.lean new file mode 100644 index 0000000000..9ef2287a0a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightCap.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorScan +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex + +/-! +# Exact finite-word test for the Bethe epigraph height cap + +The last coordinate of a rational epigraph point is its height. Given a +unary ruler for the number of base coordinates, this machine retrieves that +last entry and tests the strict violation `upper < height` by exact rational +cross multiplication. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary height-coordinate index from the height-cap input. -/ +def machineBetheHeightCapDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the paired upper bound and rational vector from the height-cap input. -/ +def machineBetheHeightCapRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the encoded rational upper bound from the height-cap input. -/ +def machineBetheHeightCapUpper (word : List Bool) : List Bool := + machinePairFirst (machineBetheHeightCapRest word) + +/-- Extracts the encoded rational vector from the height-cap input. -/ +def machineBetheHeightCapVector (word : List Bool) : List Bool := + machinePairSecond (machineBetheHeightCapRest word) + +/-- Pairs the unary height-coordinate index with the encoded vector for list lookup. -/ +def machineBetheHeightCapIndexInput (word : List Bool) : List Bool := + pair (machineBetheHeightCapDimension word) + (machineBetheHeightCapVector word) + +/-- Looks up the encoded height coordinate in the rational vector. -/ +def machineBetheHeightCapEntryCode (word : List Bool) : List Bool := + machineListIndex (machineBetheHeightCapIndexInput word) + +/-- Tests whether the encoded height coordinate is at most the encoded upper bound. -/ +def machineBetheHeightLeUpperBit (word : List Bool) : List Bool := + machineRawRatLeBit + (pair (machineBetheHeightCapEntryCode word) + (machineBetheHeightCapUpper word)) + +/-- One-bit answer, true exactly when the height is strictly above the cap on +canonical inputs. -/ +def machineBetheHeightCapViolationBit (word : List Bool) : List Bool := + machineNotBit (machineBetheHeightLeUpperBit word) + +theorem machineBetheHeightCapDimension_mem_FP : + machineBetheHeightCapDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineBetheHeightCapRest_mem_FP : + machineBetheHeightCapRest ∈ FP := machinePairSecond_mem_FP + +theorem machineBetheHeightCapUpper_mem_FP : + machineBetheHeightCapUpper ∈ FP := by + simpa only [machineBetheHeightCapUpper] using! + machineCompose_mem_FP machineBetheHeightCapRest_mem_FP + machinePairFirst_mem_FP + +theorem machineBetheHeightCapVector_mem_FP : + machineBetheHeightCapVector ∈ FP := by + simpa only [machineBetheHeightCapVector] using! + machineCompose_mem_FP machineBetheHeightCapRest_mem_FP + machinePairSecond_mem_FP + +theorem machineBetheHeightCapIndexInput_mem_FP : + machineBetheHeightCapIndexInput ∈ FP := + machinePair_mem_FP machineBetheHeightCapDimension_mem_FP + machineBetheHeightCapVector_mem_FP + +theorem machineBetheHeightCapEntryCode_mem_FP : + machineBetheHeightCapEntryCode ∈ FP := by + simpa only [machineBetheHeightCapEntryCode] using! + machineCompose_mem_FP machineBetheHeightCapIndexInput_mem_FP + machineListIndex_mem_FP + +theorem machineBetheHeightLeUpperBit_mem_FP : + machineBetheHeightLeUpperBit ∈ FP := by + have hinput := machinePair_mem_FP machineBetheHeightCapEntryCode_mem_FP + machineBetheHeightCapUpper_mem_FP + simpa only [machineBetheHeightLeUpperBit] using! + machineCompose_mem_FP hinput machineRawRatLeBit_mem_FP + +theorem machineBetheHeightCapViolationBit_mem_FP : + machineBetheHeightCapViolationBit ∈ FP := by + simpa only [machineBetheHeightCapViolationBit] using! + machineNotBit_mem_FP machineBetheHeightLeUpperBit_mem_FP + +/-- Encodes a rational upper bound and a vector whose final coordinate is its height. -/ +def machineBetheHeightCapCanonicalWord {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : List Bool := + pair (List.replicate d true) + (pair (rawRatBinaryCode upper) (rationalFiniteVectorCode q)) + +@[simp] theorem machineBetheHeightCapDimension_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightCapDimension + (machineBetheHeightCapCanonicalWord upper q) = + List.replicate d true := by + simp [machineBetheHeightCapDimension, + machineBetheHeightCapCanonicalWord] + +@[simp] theorem machineBetheHeightCapUpper_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightCapUpper + (machineBetheHeightCapCanonicalWord upper q) = + rawRatBinaryCode upper := by + simp [machineBetheHeightCapUpper, machineBetheHeightCapRest, + machineBetheHeightCapCanonicalWord] + +@[simp] theorem machineBetheHeightCapVector_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightCapVector + (machineBetheHeightCapCanonicalWord upper q) = + rationalFiniteVectorCode q := by + simp [machineBetheHeightCapVector, machineBetheHeightCapRest, + machineBetheHeightCapCanonicalWord] + +@[simp] theorem machineBetheHeightCapEntryCode_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightCapEntryCode + (machineBetheHeightCapCanonicalWord upper q) = + rawRatBinaryCode (rawRatOfRat (q (Fin.last d))) := by + rw [machineBetheHeightCapEntryCode, + machineBetheHeightCapIndexInput, + machineBetheHeightCapDimension_encode, + machineBetheHeightCapVector_encode, + rationalFiniteVectorCode, + machineListIndex_binaryListCode rationalEntryBinaryCode + (List.ofFn q) d] + Β· rw [rawRatBinaryCode_rawRatOfRat] + congr 1 + change (List.ofFn q)[d] = q (Fin.last d) + simp only [List.getElem_ofFn] + apply congrArg q + apply Fin.ext + rfl + +@[simp] theorem machineBetheHeightLeUpperBit_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightLeUpperBit + (machineBetheHeightCapCanonicalWord upper q) = + [decide (q (Fin.last d) ≀ upper.value)] := by + rw [machineBetheHeightLeUpperBit, + machineBetheHeightCapEntryCode_encode, + machineBetheHeightCapUpper_encode, + machineRawRatLeBit_encode, + rawRatOfRat_value] + +@[simp] theorem machineBetheHeightCapViolationBit_encode {d : β„•} + (upper : RawRat) (q : Fin (d + 1) β†’ β„š) : + machineBetheHeightCapViolationBit + (machineBetheHeightCapCanonicalWord upper q) = + [decide (upper.value < q (Fin.last d))] := by + rw [machineBetheHeightCapViolationBit, + machineBetheHeightLeUpperBit_encode, + machineNotBit_one] + by_cases h : q (Fin.last d) ≀ upper.value + Β· have hnot : Β¬upper.value < q (Fin.last d) := not_lt_of_ge h + simp [h, hnot] + Β· have hlt : upper.value < q (Fin.last d) := lt_of_not_ge h + simp [h, hlt] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightNormal.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightNormal.lean new file mode 100644 index 0000000000..0aecccef10 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBetheHeightNormal.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutVector + +/-! +# Finite-word height-cap normals + +The upper-height constraint has normal `(0,...,0,1)`. We construct its +`m^2` zero base coordinates with the common grid generator and append the +single positive height coordinate with the verified list-snoc machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Produces the encoded zero entry used in the non-height coordinates of the cut normal. -/ +def machineBetheHeightNormalEntryCode (_word : List Bool) : List Bool := + rationalEntryBinaryCode 0 + +/-- Supplies a twice-iterated binary width bound for generating the height-cut normal. -/ +def machineBetheHeightNormalBound (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 word + +/-- Packages the coordinate ruler, entry bound, and payload for generating zero normal entries. -/ +def machineBetheHeightNormalGeneratorInput + (word : List Bool) : List Bool := + pair word (pair (machineBetheHeightNormalBound word) word) + +/-- Generates the encoded list of zero entries preceding the height coordinate of the normal. -/ +def machineBetheHeightNormalBaseCode (word : List Bool) : List Bool := + machineUnaryGridGeneratorCode machineBetheHeightNormalEntryCode + (machineBetheHeightNormalGeneratorInput word) + +/-- Pairs the encoded unit entry with the zero prefix for appending the height coordinate. -/ +def machineBetheHeightNormalSnocInput (word : List Bool) : List Bool := + pair (rationalEntryBinaryCode 1) + (machineBetheHeightNormalBaseCode word) + +/-- Encodes the height-cap cut normal by appending one to a vector of zero entries. -/ +def machineBetheHeightNormalVectorCode (word : List Bool) : List Bool := + machineBinaryListSnoc (machineBetheHeightNormalSnocInput word) + +theorem machineBetheHeightNormalEntryCode_mem_FP : + machineBetheHeightNormalEntryCode ∈ FP := + machineConst_mem_FP (rationalEntryBinaryCode 0) + +theorem machineBetheHeightNormalBound_mem_FP : + machineBetheHeightNormalBound ∈ FP := + machineIteratedBinaryWidth_mem_FP 2 + +theorem machineBetheHeightNormalGeneratorInput_mem_FP : + machineBetheHeightNormalGeneratorInput ∈ FP := + machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineBetheHeightNormalBound_mem_FP id_mem_FP) + +theorem machineBetheHeightNormalBaseCode_mem_FP : + machineBetheHeightNormalBaseCode ∈ FP := by + have hgenerator := machineUnaryGridGeneratorCode_mem_FP + machineBetheHeightNormalEntryCode_mem_FP + simpa only [machineBetheHeightNormalBaseCode] using! + machineCompose_mem_FP machineBetheHeightNormalGeneratorInput_mem_FP + hgenerator + +theorem machineBetheHeightNormalSnocInput_mem_FP : + machineBetheHeightNormalSnocInput ∈ FP := + machinePair_mem_FP (machineConst_mem_FP (rationalEntryBinaryCode 1)) + machineBetheHeightNormalBaseCode_mem_FP + +theorem machineBetheHeightNormalVectorCode_mem_FP : + machineBetheHeightNormalVectorCode ∈ FP := by + simpa only [machineBetheHeightNormalVectorCode] using! + machineCompose_mem_FP machineBetheHeightNormalSnocInput_mem_FP + machineBinaryListSnoc_mem_FP + +theorem rationalEntryBinaryCode_zero_length_le : + (rationalEntryBinaryCode 0).length ≀ 16 := by + norm_num [rationalEntryBinaryCode, integerBinaryCode] + +theorem betheHeightNormal_base_code_length_le_bound (m : β„•) : + (binaryListCode rationalEntryBinaryCode + (unaryGridValues (fun _ _ : Fin m ↦ (0 : β„š)))).length ≀ + (machineBetheHeightNormalBound + (List.replicate m true)).length := by + let word := List.replicate m true + let L := word.length + let T := L + 16 + have hmL : m ≀ L := by simp [L, word] + have hsum := List.sum_le_card_nsmul + ((unaryGridValues (fun _ _ : Fin m ↦ (0 : β„š))).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + 34 (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + rw [unaryGridValues] at hq + obtain ⟨k, rfl⟩ := List.mem_ofFn.mp hq + have hzero := rationalEntryBinaryCode_zero_length_le + omega) + have hmT : m ≀ T := hmL.trans (by simp [T]) + have hmm := Nat.mul_le_mul hmT hmT + have hbase : 16 ≀ T := by simp [T] + have hcoefficient : 34 ≀ T ^ 2 := by + have hpow := Nat.pow_le_pow_left hbase 2 + exact (by norm_num : 34 ≀ 16 ^ 2).trans hpow + have hmul := Nat.mul_le_mul hmm hcoefficient + have hcode : + (binaryListCode rationalEntryBinaryCode + (unaryGridValues (fun _ _ : Fin m ↦ (0 : β„š)))).length ≀ + T ^ 4 := by + rw [binaryListCode_length_eq_sum] + simp only [List.length_map, unaryGridValues_length, + Nat.nsmul_eq_mul] at hsum + calc + _ ≀ m * m * 34 := hsum + _ ≀ T * T * T ^ 2 := hmul + _ = T ^ 4 := by ring + rw [machineBetheHeightNormalBound, + machineIteratedBinaryWidth_length] + exact hcode.trans (by + simpa only [T, L, word] using! + certificateExpGuardWidth_pow_lower 1 + (List.replicate m true).length) + +@[simp] theorem machineBetheHeightNormalGeneratorInput_encode (m : β„•) : + machineBetheHeightNormalGeneratorInput (List.replicate m true) = + machineUnaryGridGeneratorCanonicalWord m + (machineBetheHeightNormalBound (List.replicate m true)) + (List.replicate m true) := by + simp [machineBetheHeightNormalGeneratorInput, + machineUnaryGridGeneratorCanonicalWord] + +@[simp] theorem machineBetheHeightNormalBaseCode_encode (m : β„•) : + machineBetheHeightNormalBaseCode (List.replicate m true) = + binaryListCode rationalEntryBinaryCode + (unaryGridValues (fun _ _ : Fin m ↦ (0 : β„š))) := by + rw [machineBetheHeightNormalBaseCode, + machineBetheHeightNormalGeneratorInput_encode] + exact machineUnaryGridGeneratorCode_encode_of_bound + machineBetheHeightNormalEntryCode (fun _ _ : Fin m ↦ (0 : β„š)) + (machineBetheHeightNormalBound (List.replicate m true)) + (List.replicate m true) (by intro i j; rfl) + (betheHeightNormal_base_code_length_le_bound m) + +theorem ofFn_epigraphUpperNormal_square (m : β„•) : + List.ofFn (epigraphUpperNormal (m * m)) = + unaryGridValues (fun _ _ : Fin m ↦ (0 : β„š)) ++ [1] := by + rw [List.ofFn_succ'] + simp [epigraphUpperNormal, unaryGridValues] + +@[simp] theorem machineBetheHeightNormalVectorCode_encode (m : β„•) : + machineBetheHeightNormalVectorCode (List.replicate m true) = + rationalFiniteVectorCode (epigraphUpperNormal (m * m)) := by + rw [machineBetheHeightNormalVectorCode, + machineBetheHeightNormalSnocInput, + machineBetheHeightNormalBaseCode_encode, + machineBinaryListSnoc_encode, + rationalFiniteVectorCode, ofFn_epigraphUpperNormal_square] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAdd.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAdd.lean new file mode 100644 index 0000000000..b12819cd77 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAdd.lean @@ -0,0 +1,398 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBool + +/-! +# A composed polynomial-time binary adder + +The adder uses little-endian words, matching `Nat.bits`. Its state is +`pair x (pair y (pair carry accRev))`. One verified `FP` step consumes at +most one bit from each operand and prepends one result bit to `accRev`. +Complexitylib's proved bounded-iteration machine runs this step for the +length of a linear ruler; the final reversal restores little-endian order. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes binary-addition state as two remaining operands, carry, and reversed accumulated +bits. -/ +def machineBinaryAddPack + (x y carry accRev : List Bool) : List Bool := + pair x (pair y (pair carry accRev)) + +/-- Extracts the unprocessed bits of the first addition operand. -/ +def machineBinaryAddX (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed bits of the second addition operand. -/ +def machineBinaryAddY (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the carry word from the binary-addition state. -/ +def machineBinaryAddCarry (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulated sum bits in reverse order. -/ +def machineBinaryAddAccRev (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +theorem machineBinaryAddPack_mem_FP + {x y carry accRev : List Bool β†’ List Bool} + (hx : x ∈ Complexity.FP) (hy : y ∈ Complexity.FP) + (hcarry : carry ∈ Complexity.FP) (hacc : accRev ∈ Complexity.FP) : + (fun word => machineBinaryAddPack (x word) (y word) + (carry word) (accRev word)) ∈ Complexity.FP := by + exact machinePair_mem_FP hx + (machinePair_mem_FP hy (machinePair_mem_FP hcarry hacc)) + +theorem machineBinaryAddX_mem_FP : machineBinaryAddX ∈ Complexity.FP := by + simpa only [machineBinaryAddX] using! machinePairFirst_mem_FP + +theorem machineBinaryAddY_mem_FP : machineBinaryAddY ∈ Complexity.FP := by + simpa only [machineBinaryAddY] using! + (machineCompose_mem_FP (f := machinePairSecond) (g := machinePairFirst) + machinePairSecond_mem_FP machinePairFirst_mem_FP) + +theorem machineBinaryAddCarry_mem_FP : + machineBinaryAddCarry ∈ Complexity.FP := by + have hsecond : + (fun word => machinePairSecond (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP (f := machinePairSecond) (g := machinePairSecond) + machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinaryAddCarry] using! + (machineCompose_mem_FP (f := fun word => + machinePairSecond (machinePairSecond word)) + (g := machinePairFirst) hsecond machinePairFirst_mem_FP) + +theorem machineBinaryAddAccRev_mem_FP : + machineBinaryAddAccRev ∈ Complexity.FP := by + have hsecond : + (fun word => machinePairSecond (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP (f := machinePairSecond) (g := machinePairSecond) + machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinaryAddAccRev] using! + (machineCompose_mem_FP (f := fun word => + machinePairSecond (machinePairSecond word)) + (g := machinePairSecond) hsecond machinePairSecond_mem_FP) + +@[simp] theorem machineBinaryAddX_pack (x y carry accRev : List Bool) : + machineBinaryAddX (machineBinaryAddPack x y carry accRev) = x := by + simp [machineBinaryAddX, machineBinaryAddPack] + +@[simp] theorem machineBinaryAddY_pack (x y carry accRev : List Bool) : + machineBinaryAddY (machineBinaryAddPack x y carry accRev) = y := by + simp [machineBinaryAddY, machineBinaryAddPack] + +@[simp] theorem machineBinaryAddCarry_pack (x y carry accRev : List Bool) : + machineBinaryAddCarry (machineBinaryAddPack x y carry accRev) = carry := by + simp [machineBinaryAddCarry, machineBinaryAddPack] + +@[simp] theorem machineBinaryAddAccRev_pack (x y carry accRev : List Bool) : + machineBinaryAddAccRev (machineBinaryAddPack x y carry accRev) = accRev := by + simp [machineBinaryAddAccRev, machineBinaryAddPack] + +/-- One-bit flag saying that an addition step remains: an operand is +nonempty, or both operands are empty and the carry is true. -/ +def machineBinaryAddActive (state : List Bool) : List Bool := + machineIfEmpty (machineBinaryAddX state) + (machineIfEmpty (machineBinaryAddY state) + (machineBinaryAddCarry state) [true]) + [true] + +/-- Computes the next sum bit from the two operand heads and the carry. -/ +def machineBinaryAddSumBit (state : List Bool) : List Bool := + machineFullAdderSum + (machineHeadBit (machineBinaryAddX state)) + (machineHeadBit (machineBinaryAddY state)) + (machineBinaryAddCarry state) + +/-- Computes the next carry from the two operand heads and the current carry. -/ +def machineBinaryAddNextCarry (state : List Bool) : List Bool := + machineFullAdderCarry + (machineHeadBit (machineBinaryAddX state)) + (machineHeadBit (machineBinaryAddY state)) + (machineBinaryAddCarry state) + +/-- Consumes one bit from each operand, updates the carry, and prepends the new sum bit. -/ +def machineBinaryAddAdvanced (state : List Bool) : List Bool := + machineBinaryAddPack + (machineBinaryAddX state).tail + (machineBinaryAddY state).tail + (machineBinaryAddNextCarry state) + (machineBinaryAddSumBit state ++ machineBinaryAddAccRev state) + +/-- Total addition transition. A completed state is a fixed point. -/ +def machineBinaryAddStep (state : List Bool) : List Bool := + machineIfHead (machineBinaryAddActive state) + (machineBinaryAddAdvanced state) state + +theorem machineBinaryAddActive_mem_FP : + machineBinaryAddActive ∈ Complexity.FP := by + apply machineIfEmpty_mem_FP machineBinaryAddX_mem_FP + Β· apply machineIfEmpty_mem_FP machineBinaryAddY_mem_FP + Β· exact machineBinaryAddCarry_mem_FP + Β· exact machineConst_mem_FP [true] + Β· exact machineConst_mem_FP [true] + +theorem machineBinaryAddSumBit_mem_FP : + machineBinaryAddSumBit ∈ Complexity.FP := by + apply machineFullAdderSum_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddX_mem_FP machineHeadBit_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddY_mem_FP machineHeadBit_mem_FP + Β· exact machineBinaryAddCarry_mem_FP + +theorem machineBinaryAddNextCarry_mem_FP : + machineBinaryAddNextCarry ∈ Complexity.FP := by + apply machineFullAdderCarry_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddX_mem_FP machineHeadBit_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddY_mem_FP machineHeadBit_mem_FP + Β· exact machineBinaryAddCarry_mem_FP + +theorem machineBinaryAddAdvanced_mem_FP : + machineBinaryAddAdvanced ∈ Complexity.FP := by + apply machineBinaryAddPack_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddX_mem_FP machineTail_mem_FP + Β· exact machineCompose_mem_FP machineBinaryAddY_mem_FP machineTail_mem_FP + Β· exact machineBinaryAddNextCarry_mem_FP + Β· exact machineAppend_mem_FP machineBinaryAddSumBit_mem_FP + machineBinaryAddAccRev_mem_FP + +theorem machineBinaryAddStep_mem_FP : + machineBinaryAddStep ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineBinaryAddActive_mem_FP + machineBinaryAddAdvanced_mem_FP id_mem_FP + +/-- Initial state from a paired pair of operand words. -/ +def machineBinaryAddInit (word : List Bool) : List Bool := + machineBinaryAddPack (machinePairFirst word) (machinePairSecond word) + [false] [] + +/-- A linear-length iteration ruler. -/ +def machineBinaryAddRuler (word : List Bool) : List Bool := + machinePairFirst word ++ machinePairSecond word ++ [false] + +/-- A quadratic-width zero word. This is intentionally generous and makes +the bounded-iteration proof independent of fine constant accounting. -/ +def machineBinaryAddWidth (word : List Bool) : List Bool := + let padded := List.replicate 8 false ++ word + List.replicate (padded.length * padded.length) false + +theorem machineBinaryAddInit_mem_FP : + machineBinaryAddInit ∈ Complexity.FP := by + exact machineBinaryAddPack_mem_FP machinePairFirst_mem_FP + machinePairSecond_mem_FP (machineConst_mem_FP [false]) + (machineConst_mem_FP []) + +theorem machineBinaryAddRuler_mem_FP : + machineBinaryAddRuler ∈ Complexity.FP := by + apply machineAppend_mem_FP + Β· exact machineAppend_mem_FP machinePairFirst_mem_FP machinePairSecond_mem_FP + Β· exact machineConst_mem_FP [false] + +theorem machineBinaryAddWidth_mem_FP : + machineBinaryAddWidth ∈ Complexity.FP := by + let padded : List Bool β†’ List Bool := + fun word => List.replicate 8 false ++ word + have hpadded : padded ∈ Complexity.FP := by + exact machineAppend_mem_FP (machineConst_mem_FP (List.replicate 8 false)) + id_mem_FP + simpa only [machineBinaryAddWidth, padded] using! + Cobham.mulLenFn_mem_FP hpadded hpadded + +@[simp] theorem machineBinaryAddStep_pack + (x y accRev : List Bool) (carry : Bool) : + machineBinaryAddStep (machineBinaryAddPack x y [carry] accRev) = + if x = [] ∧ y = [] ∧ carry = false then + machineBinaryAddPack x y [carry] accRev + else + machineBinaryAddPack x.tail y.tail + [((x.head?.getD false && y.head?.getD false) || + (x.head?.getD false && carry) || + (y.head?.getD false && carry))] + (xor (xor (x.head?.getD false) (y.head?.getD false)) carry :: + accRev) := by + cases x with + | nil => + cases y with + | nil => cases carry <;> rfl + | cons y ys => + cases y <;> cases carry <;> + simp [machineBinaryAddStep, machineBinaryAddActive, + machineBinaryAddAdvanced, machineBinaryAddSumBit, + machineBinaryAddNextCarry, machineFullAdderSum, + machineFullAdderCarry, machineMajorityBit, machineXorBit, + machineAndBit, machineOrBit, machineNotBit] + | cons x xs => + cases x <;> cases y with + | nil => + cases carry <;> + simp [machineBinaryAddStep, machineBinaryAddActive, + machineBinaryAddAdvanced, machineBinaryAddSumBit, + machineBinaryAddNextCarry, machineFullAdderSum, + machineFullAdderCarry, machineMajorityBit, machineXorBit, + machineAndBit, machineOrBit, machineNotBit] + | cons y ys => + cases y <;> cases carry <;> + simp [machineBinaryAddStep, machineBinaryAddActive, + machineBinaryAddAdvanced, machineBinaryAddSumBit, + machineBinaryAddNextCarry, machineFullAdderSum, + machineFullAdderCarry, machineMajorityBit, machineXorBit, + machineAndBit, machineOrBit, machineNotBit] + +theorem machineBinaryAddStep_pack_length_le + (x y accRev : List Bool) (carry : Bool) : + (machineBinaryAddStep (machineBinaryAddPack x y [carry] accRev)).length ≀ + (machineBinaryAddPack x y [carry] accRev).length + 1 := by + rw [machineBinaryAddStep_pack] + split + Β· omega + Β· simp only [machineBinaryAddPack, pair_length, List.length_cons] + simp only [List.length_tail] + omega + +theorem machinePairFirst_length_le (word : List Bool) : + (machinePairFirst word).length ≀ word.length := by + change (Cobham.fstBlock word).length ≀ word.length + have hstrong : βˆ€ n : β„•, βˆ€ word : List Bool, word.length = n β†’ + (Cobham.fstBlock word).length ≀ word.length := by + intro n + induction n using Nat.strongRecOn with + | ind n ih => + intro word hlength + cases word with + | nil => rfl + | cons a word => + cases word with + | nil => simp [Cobham.fstBlock] + | cons b word => + have hrest := ih word.length (by simp at hlength; omega) + word rfl + cases a <;> cases b <;> + simp [Cobham.fstBlock, hrest] <;> omega + exact hstrong word.length word rfl + +theorem machinePairSecond_length_le (word : List Bool) : + (machinePairSecond word).length ≀ word.length := by + unfold machinePairSecond Cobham.sndBlock + cases hpair : unpair? word with + | none => simp + | some components => + obtain ⟨left, right⟩ := components + have hword : word = pair left right := + eq_pair_of_unpair?_eq_some hpair + subst word + simp + +/-- States reachable from the canonical pack retain a one-bit carry. -/ +def MachineBinaryAddWellFormed (state : List Bool) : Prop := + βˆƒ x y accRev : List Bool, βˆƒ carry : Bool, + state = machineBinaryAddPack x y [carry] accRev + +theorem machineBinaryAddInit_wellFormed (word : List Bool) : + MachineBinaryAddWellFormed (machineBinaryAddInit word) := by + exact ⟨machinePairFirst word, machinePairSecond word, [], false, rfl⟩ + +theorem machineBinaryAddStep_wellFormed {state : List Bool} + (hstate : MachineBinaryAddWellFormed state) : + MachineBinaryAddWellFormed (machineBinaryAddStep state) := by + obtain ⟨x, y, accRev, carry, rfl⟩ := hstate + rw [machineBinaryAddStep_pack] + split + Β· exact ⟨x, y, accRev, carry, rfl⟩ + Β· exact ⟨x.tail, y.tail, + xor (xor (x.head?.getD false) (y.head?.getD false)) carry :: accRev, + ((x.head?.getD false && y.head?.getD false) || + (x.head?.getD false && carry) || + (y.head?.getD false && carry)), rfl⟩ + +theorem machineBinaryAddIterate_wellFormed_length_le + {state : List Bool} (hstate : MachineBinaryAddWellFormed state) : + βˆ€ iterations : β„•, + MachineBinaryAddWellFormed (machineBinaryAddStep^[iterations] state) ∧ + (machineBinaryAddStep^[iterations] state).length ≀ + state.length + iterations := by + intro iterations + induction iterations with + | zero => simpa using! And.intro hstate (Nat.le_refl state.length) + | succ iterations ih => + rw [Function.iterate_succ_apply'] + obtain ⟨hwell, hlength⟩ := ih + have hnext := machineBinaryAddStep_wellFormed hwell + obtain ⟨x, y, accRev, carry, hrepr⟩ := hwell + have hstep := machineBinaryAddStep_pack_length_le x y accRev carry + rw [← hrepr] at hstep + refine ⟨hnext, ?_⟩ + omega + +theorem machineBinaryAddInit_length_le (word : List Bool) : + (machineBinaryAddInit word).length ≀ 4 * word.length + 8 := by + simp only [machineBinaryAddInit, machineBinaryAddPack, pair_length, + List.length_cons, List.length_nil] + have hfirst := machinePairFirst_length_le word + have hsecond := machinePairSecond_length_le word + omega + +theorem machineBinaryAddRuler_length_le (word : List Bool) : + (machineBinaryAddRuler word).length ≀ 2 * word.length + 1 := by + simp only [machineBinaryAddRuler, List.length_append, List.length_cons, + List.length_nil] + have hfirst := machinePairFirst_length_le word + have hsecond := machinePairSecond_length_le word + omega + +theorem machineBinaryAddWidth_length (word : List Bool) : + (machineBinaryAddWidth word).length = (word.length + 8) ^ 2 := by + simp [machineBinaryAddWidth, pow_two] + +theorem machineBinaryAddIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBinaryAddRuler word).length) : + (machineBinaryAddStep^[iterations] (machineBinaryAddInit word)).length ≀ + (machineBinaryAddWidth word).length := by + have hiter := + (machineBinaryAddIterate_wellFormed_length_le + (machineBinaryAddInit_wellFormed word) iterations).2 + have hinit := machineBinaryAddInit_length_le word + have hruler := machineBinaryAddRuler_length_le word + rw [machineBinaryAddWidth_length] + nlinarith [sq_nonneg (word.length : β„€)] + +/-- Final bounded-iteration state. -/ +def machineBinaryAddFinalState (word : List Bool) : List Bool := + machineBinaryAddStep^[(machineBinaryAddRuler word).length] + (machineBinaryAddInit word) + +/-- Machine-level binary addition. The final accumulator is reversed from +the transition-friendly most-recent-bit-first representation. -/ +def machineBinaryAddBits (word : List Bool) : List Bool := + (machineBinaryAddAccRev (machineBinaryAddFinalState word)).reverse + +theorem machineBinaryAddFinalState_mem_FP : + machineBinaryAddFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBinaryAddStep_mem_FP + machineBinaryAddInit_mem_FP machineBinaryAddRuler_mem_FP + machineBinaryAddWidth_mem_FP machineBinaryAddIterate_length_le_width + +theorem machineBinaryAddBits_mem_FP : + machineBinaryAddBits ∈ Complexity.FP := by + have hacc : + (fun word => machineBinaryAddAccRev + (machineBinaryAddFinalState word)) ∈ Complexity.FP := + machineCompose_mem_FP machineBinaryAddFinalState_mem_FP + machineBinaryAddAccRev_mem_FP + simpa only [machineBinaryAddBits] using! + (machineCompose_mem_FP hacc machineReverse_mem_FP) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAddSemantics.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAddSemantics.lean new file mode 100644 index 0000000000..45f17428cc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryAddSemantics.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAdd +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd + +/-! +# Correctness of the composed polynomial-time binary adder + +The bounded Cobham loop in `MachineBinaryAdd` is proved here to implement the +same ripple-carry recurrence as Complexitylib's canonical binary adder. This +connects the concrete `FP` construction to arithmetic addition. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +private theorem machineBinaryAddIterate_max + (x y accRev : List Bool) (carry : Bool) : + machineBinaryAddStep^[max x.length y.length + 1] + (machineBinaryAddPack x y [carry] accRev) = + machineBinaryAddPack [] [] [false] + ((BinaryRippleAdd.ripple carry x y).reverse ++ accRev) := by + induction hmeasure : x.length + y.length using Nat.strongRecOn + generalizing x y carry accRev with + | ind measure ih => + cases x with + | nil => + cases y with + | nil => + cases carry <;> + simp [machineBinaryAddStep_pack, BinaryRippleAdd.ripple, + Function.iterate_succ_apply] + | cons y ys => + simp only [List.length_nil, List.length_cons, Nat.zero_add] + at hmeasure + have hrec := ih ys.length (by omega) [] ys + (BinaryRippleAdd.sumBit carry false y :: accRev) + (BinaryRippleAdd.carryBit carry false y) (by simp) + have hrec' := hrec + simp only [List.length_nil] at hrec' + simp only [List.length_nil, List.length_cons] + rw [show max 0 (ys.length + 1) + 1 = + (max 0 ys.length + 1).succ by omega, + Function.iterate_succ_apply, machineBinaryAddStep_pack] + simp only [List.nil_eq, List.cons_ne_nil, and_false, + ↓reduceIte, List.tail_cons, List.tail_nil, List.head?_nil, + Option.getD_none, List.head?_cons, Option.getD_some] + simp only [true_and, false_and, ↓reduceIte] + rw [show + ((false && y) || (false && carry) || (y && carry)) = + BinaryRippleAdd.carryBit carry false y by + cases carry <;> cases y <;> rfl, + show xor (xor false y) carry = + BinaryRippleAdd.sumBit carry false y by + cases carry <;> cases y <;> rfl, + hrec'] + simp [BinaryRippleAdd.ripple, List.reverse_cons, + List.append_assoc] + | cons x xs => + cases y with + | nil => + simp only [List.length_nil, List.length_cons, Nat.add_zero] + at hmeasure + have hrec := ih xs.length (by omega) xs [] + (BinaryRippleAdd.sumBit carry x false :: accRev) + (BinaryRippleAdd.carryBit carry x false) (by simp) + have hrec' := hrec + simp only [List.length_nil] at hrec' + simp only [List.length_nil, List.length_cons] + rw [show max (xs.length + 1) 0 + 1 = + (max xs.length 0 + 1).succ by omega, + Function.iterate_succ_apply, machineBinaryAddStep_pack] + simp only [List.cons_ne_nil, List.nil_eq, and_false, + ↓reduceIte, List.tail_cons, List.tail_nil, List.head?_cons, + Option.getD_some, List.head?_nil, Option.getD_none] + simp only [false_and, ↓reduceIte] + rw [show + ((x && false) || (x && carry) || (false && carry)) = + BinaryRippleAdd.carryBit carry x false by + cases carry <;> cases x <;> rfl, + show xor (xor x false) carry = + BinaryRippleAdd.sumBit carry x false by + cases carry <;> cases x <;> rfl, + hrec'] + simp [BinaryRippleAdd.ripple, List.reverse_cons, + List.append_assoc] + | cons y ys => + simp only [List.length_cons] at hmeasure + have hrec := ih (xs.length + ys.length) (by omega) + xs ys + (BinaryRippleAdd.sumBit carry x y :: accRev) + (BinaryRippleAdd.carryBit carry x y) rfl + simp only [List.length_cons] + rw [show max (xs.length + 1) (ys.length + 1) + 1 = + (max xs.length ys.length + 1).succ by omega, + Function.iterate_succ_apply, machineBinaryAddStep_pack] + simp only [List.cons_ne_nil, and_false, ↓reduceIte, + List.tail_cons, List.head?_cons, Option.getD_some] + simp only [false_and, ↓reduceIte] + rw [show + ((x && y) || (x && carry) || (y && carry)) = + BinaryRippleAdd.carryBit carry x y by + cases carry <;> cases x <;> cases y <;> rfl, + show xor (xor x y) carry = + BinaryRippleAdd.sumBit carry x y by + cases carry <;> cases x <;> cases y <;> rfl, + hrec] + simp [BinaryRippleAdd.ripple, List.reverse_cons, + List.append_assoc] + +private theorem machineBinaryAddStep_done (accRev : List Bool) : + machineBinaryAddStep (machineBinaryAddPack [] [] [false] accRev) = + machineBinaryAddPack [] [] [false] accRev := by + rw [machineBinaryAddStep_pack] + simp + +private theorem machineBinaryAddIterate_done (accRev : List Bool) (k : β„•) : + machineBinaryAddStep^[k] + (machineBinaryAddPack [] [] [false] accRev) = + machineBinaryAddPack [] [] [false] accRev := by + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply, machineBinaryAddStep_done, ih] + +/-- The composed adder agrees with ripple carry on arbitrary operand words. +This stronger total-input statement is what later arithmetic machines use for +their size bounds; canonicality is needed only when interpreting the answer as +`Nat.bits`. -/ +theorem machineBinaryAddBits_pair_lists (x y : List Bool) : + machineBinaryAddBits (pair x y) = + BinaryRippleAdd.ripple false x y := by + simp only [machineBinaryAddBits, machineBinaryAddFinalState, + machineBinaryAddRuler, machineBinaryAddInit, machinePairFirst_pair, + machinePairSecond_pair, List.length_append, List.length_cons, + List.length_nil] + rw [show x.length + y.length + 1 = + min x.length y.length + (max x.length y.length + 1) by + have hminmax := min_add_max x.length y.length + omega, + Function.iterate_add_apply, machineBinaryAddIterate_max, + machineBinaryAddIterate_done] + simp [machineBinaryAddAccRev, machineBinaryAddPack] + +/-- Ripple carry emits at most one bit beyond the longer input word. -/ +theorem binaryRippleAdd_length_le : βˆ€ (carry : Bool) (x y : List Bool), + (BinaryRippleAdd.ripple carry x y).length ≀ + max x.length y.length + 1 := by + intro carry x y + induction x generalizing carry y with + | nil => + induction y generalizing carry with + | nil => cases carry <;> simp [BinaryRippleAdd.ripple] + | cons bit rest ih => + simp only [BinaryRippleAdd.ripple, List.length_cons, + List.length_nil] + have hrec := ih (BinaryRippleAdd.carryBit carry false bit) + have hrec' : + (BinaryRippleAdd.ripple + (BinaryRippleAdd.carryBit carry false bit) [] rest).length ≀ + rest.length + 1 := by + simpa using! hrec + omega + | cons bit rest ih => + cases y with + | nil => + simp only [BinaryRippleAdd.ripple, List.length_cons, + List.length_nil] + have hrec := ih (BinaryRippleAdd.carryBit carry bit false) [] + have hrec' : + (BinaryRippleAdd.ripple + (BinaryRippleAdd.carryBit carry bit false) rest []).length ≀ + rest.length + 1 := by + simpa using! hrec + omega + | cons other tail => + simp only [BinaryRippleAdd.ripple, List.length_cons] + have hrec := ih (BinaryRippleAdd.carryBit carry bit other) tail + omega + +theorem machineBinaryAddBits_pair_length_le (x y : List Bool) : + (machineBinaryAddBits (pair x y)).length ≀ + max x.length y.length + 1 := by + rw [machineBinaryAddBits_pair_lists] + exact binaryRippleAdd_length_le false x y + +/-- The composed bounded-loop machine returns the canonical binary expansion +of the sum of canonically encoded natural-number inputs. -/ +theorem machineBinaryAddBits_pair_natBits (x y : β„•) : + machineBinaryAddBits (pair x.bits y.bits) = (x + y).bits := by + simp only [machineBinaryAddBits, machineBinaryAddFinalState, + machineBinaryAddRuler, machineBinaryAddInit, machinePairFirst_pair, + machinePairSecond_pair, List.length_append, List.length_cons, + List.length_nil] + rw [show x.bits.length + y.bits.length + 1 = + min x.bits.length y.bits.length + + (max x.bits.length y.bits.length + 1) by + have hminmax := min_add_max x.bits.length y.bits.length + omega, + Function.iterate_add_apply, machineBinaryAddIterate_max, + machineBinaryAddIterate_done] + simp [machineBinaryAddAccRev, machineBinaryAddPack, + BinaryRippleAdd.ripple_natBits] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryCompare.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryCompare.lean new file mode 100644 index 0000000000..33043fc31f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryCompare.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinarySub + +/-! +# Polynomial-time comparison of canonical binary naturals + +Truncated subtraction is zero exactly when the left operand is at most the +right. This gives compact comparison machines while reusing the fully +verified borrow scan. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Tests whether the first encoded natural number is at most the second using truncated +subtraction. -/ +def machineBinaryNatLeBit (word : List Bool) : List Bool := + machineIfEmpty (machineBinarySubBits word) [true] [false] + +/-- Tests strict inequality of the encoded natural numbers using reversed truncated subtraction. -/ +def machineBinaryNatLtBit (word : List Bool) : List Bool := + let swapped := pair (machinePairSecond word) (machinePairFirst word) + machineIfEmpty (machineBinarySubBits swapped) [false] [true] + +/-- Tests equality of the encoded natural numbers by comparing them in both directions. -/ +def machineBinaryNatEqBit (word : List Bool) : List Bool := + machineAndBit (machineBinaryNatLeBit word) + (machineBinaryNatLeBit + (pair (machinePairSecond word) (machinePairFirst word))) + +theorem machineBinaryNatLeBit_mem_FP : + machineBinaryNatLeBit ∈ Complexity.FP := by + simpa only [machineBinaryNatLeBit] using! + machineIfEmpty_mem_FP machineBinarySubBits_mem_FP + (machineConst_mem_FP [true]) (machineConst_mem_FP [false]) + +theorem machineBinaryNatLtBit_mem_FP : + machineBinaryNatLtBit ∈ Complexity.FP := by + have hswap : (fun word => pair (machinePairSecond word) + (machinePairFirst word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + have hsub := machineCompose_mem_FP hswap machineBinarySubBits_mem_FP + simpa only [machineBinaryNatLtBit] using! + machineIfEmpty_mem_FP hsub (machineConst_mem_FP [false]) + (machineConst_mem_FP [true]) + +theorem machineBinaryNatEqBit_mem_FP : + machineBinaryNatEqBit ∈ Complexity.FP := by + have hswap : (fun word => pair (machinePairSecond word) + (machinePairFirst word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + have hswappedLe := machineCompose_mem_FP hswap machineBinaryNatLeBit_mem_FP + simpa only [machineBinaryNatEqBit] using! + machineAndBit_mem_FP machineBinaryNatLeBit_mem_FP hswappedLe + +theorem machineBinaryNatLeBit_pair_natBits (lhs rhs : β„•) : + machineBinaryNatLeBit (pair lhs.bits rhs.bits) = [decide (lhs ≀ rhs)] := by + rw [machineBinaryNatLeBit, machineBinarySubBits_pair_natBits] + by_cases h : lhs ≀ rhs + Β· have hzero : lhs - rhs = 0 := Nat.sub_eq_zero_of_le h + rw [hzero] + simp [h] + Β· have hpos : 0 < lhs - rhs := Nat.sub_pos_of_lt (Nat.lt_of_not_ge h) + cases hbits : (lhs - rhs).bits with + | nil => + have hlen : (lhs - rhs).bits.length = 0 := by rw [hbits]; rfl + have hsize : (lhs - rhs).size = 0 := by + simpa only [Nat.size_eq_bits_len] using! hlen + have := Nat.size_eq_zero.mp hsize + omega + | cons bit rest => simp [hbits, h] + +theorem machineBinaryNatLtBit_pair_natBits (lhs rhs : β„•) : + machineBinaryNatLtBit (pair lhs.bits rhs.bits) = [decide (lhs < rhs)] := by + simp only [machineBinaryNatLtBit, machinePairFirst_pair, + machinePairSecond_pair, machineBinarySubBits_pair_natBits] + by_cases h : lhs < rhs + Β· have hpos : 0 < rhs - lhs := Nat.sub_pos_of_lt h + cases hbits : (rhs - lhs).bits with + | nil => + have hlen : (rhs - lhs).bits.length = 0 := by rw [hbits]; rfl + have hsize : (rhs - lhs).size = 0 := by + simpa only [Nat.size_eq_bits_len] using! hlen + have := Nat.size_eq_zero.mp hsize + omega + | cons bit rest => simp [hbits, h] + Β· have hzero : rhs - lhs = 0 := Nat.sub_eq_zero_of_le (Nat.le_of_not_gt h) + rw [hzero] + simp [h] + +theorem machineBinaryNatEqBit_pair_natBits (lhs rhs : β„•) : + machineBinaryNatEqBit (pair lhs.bits rhs.bits) = [decide (lhs = rhs)] := by + simp only [machineBinaryNatEqBit, machinePairFirst_pair, + machinePairSecond_pair, machineBinaryNatLeBit_pair_natBits] + by_cases h : lhs = rhs + Β· subst rhs + simp + Β· have hnotboth : Β¬ (lhs ≀ rhs ∧ rhs ≀ lhs) := by + exact fun hboth => h (Nat.le_antisymm hboth.1 hboth.2) + rcases not_and_or.mp hnotboth with hleft | hright + Β· simp [h, hleft] + Β· simp [h, hright] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryDivision.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryDivision.lean new file mode 100644 index 0000000000..485ece8b87 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryDivision.lean @@ -0,0 +1,697 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryCompare +public import LeanPool.BeyondBethe.BeyondBethe.BinaryLongDivision + +/-! +# Polynomial-time binary long division + +The machine reverses the little-endian dividend and performs the usual +most-significant-bit-first long-division recurrence. Its state stores the +unread bits, the fixed divisor, quotient, and remainder. All arithmetic and +tests are the previously verified `FP` bitstring routines. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes division state as remaining dividend bits, divisor, quotient, and remainder. -/ +def machineBinaryDivPack + (remaining divisor quotient remainder : List Bool) : List Bool := + pair remaining (pair divisor (pair quotient remainder)) + +/-- Extracts the dividend bits still to be processed by long division. -/ +def machineBinaryDivRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the fixed divisor from the binary-division state. -/ +def machineBinaryDivDivisor (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the current quotient from the binary-division state. -/ +def machineBinaryDivQuotient (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the current remainder from the binary-division state. -/ +def machineBinaryDivRemainder (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Doubles the current quotient before processing the next dividend bit. -/ +def machineBinaryDivDoubleQuotient (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBinaryDivQuotient state) + (machineBinaryDivQuotient state)) + +/-- Doubles the current remainder before processing the next dividend bit. -/ +def machineBinaryDivDoubleRemainder (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBinaryDivRemainder state) + (machineBinaryDivRemainder state)) + +/-- Forms the trial remainder by doubling the remainder and adding the next dividend bit. -/ +def machineBinaryDivTrial (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBinaryDivRemaining state)) + (machineBinaryAddBits + (pair (machineBinaryDivDoubleRemainder state) [true])) + (machineBinaryDivDoubleRemainder state) + +/-- Tests whether the nonempty divisor is at most the trial remainder. -/ +def machineBinaryDivTake (state : List Bool) : List Bool := + machineIfEmpty (machineBinaryDivDivisor state) [false] + (machineBinaryNatLeBit + (pair (machineBinaryDivDivisor state) (machineBinaryDivTrial state))) + +/-- Forms twice the current quotient plus one for a successful subtraction step. -/ +def machineBinaryDivIncrementedQuotient (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBinaryDivDoubleQuotient state) [true]) + +/-- Updates the quotient according to the trial comparison, returning zero for an empty divisor. -/ +def machineBinaryDivNextQuotient (state : List Bool) : List Bool := + machineIfEmpty (machineBinaryDivDivisor state) [] + (machineIfHead (machineBinaryDivTake state) + (machineBinaryDivIncrementedQuotient state) + (machineBinaryDivDoubleQuotient state)) + +/-- Subtracts the divisor from the trial remainder when the comparison permits it. -/ +def machineBinaryDivNextRemainder (state : List Bool) : List Bool := + machineIfHead (machineBinaryDivTake state) + (machineBinarySubBits + (pair (machineBinaryDivTrial state) (machineBinaryDivDivisor state))) + (machineBinaryDivTrial state) + +/-- Consumes one dividend bit and updates the quotient and remainder. -/ +def machineBinaryDivStep (state : List Bool) : List Bool := + machineBinaryDivPack (machineBinaryDivRemaining state).tail + (machineBinaryDivDivisor state) + (machineBinaryDivNextQuotient state) + (machineBinaryDivNextRemainder state) + +/-- Initializes long division with reversed dividend bits and zero quotient and remainder. -/ +def machineBinaryDivInit (word : List Bool) : List Bool := + machineBinaryDivPack (machinePairFirst word).reverse + (machinePairSecond word) [] [] + +/-- Uses the dividend bits as the iteration ruler for long division. -/ +def machineBinaryDivRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Provides a quadratic state-width ruler of length `(word.length + 16)^2`. -/ +def machineBinaryDivWidth (word : List Bool) : List Bool := + let padded := List.replicate 16 false ++ word + List.replicate (padded.length * padded.length) false + +/-- Runs one long-division step per dividend bit. -/ +def machineBinaryDivFinalState (word : List Bool) : List Bool := + machineBinaryDivStep^[(machineBinaryDivRuler word).length] + (machineBinaryDivInit word) + +/-- Paired canonical quotient and remainder words. -/ +def machineBinaryDivModBits (word : List Bool) : List Bool := + pair (machineBinaryDivQuotient (machineBinaryDivFinalState word)) + (machineBinaryDivRemainder (machineBinaryDivFinalState word)) + +theorem machineBinaryDivRemaining_mem_FP : + machineBinaryDivRemaining ∈ Complexity.FP := by + simpa only [machineBinaryDivRemaining] using! machinePairFirst_mem_FP + +theorem machineBinaryDivDivisor_mem_FP : + machineBinaryDivDivisor ∈ Complexity.FP := by + simpa only [machineBinaryDivDivisor] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBinaryDivQuotient_mem_FP : + machineBinaryDivQuotient ∈ Complexity.FP := by + have hsecond2 : (fun word => machinePairSecond (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinaryDivQuotient] using! + machineCompose_mem_FP hsecond2 machinePairFirst_mem_FP + +theorem machineBinaryDivRemainder_mem_FP : + machineBinaryDivRemainder ∈ Complexity.FP := by + have hsecond2 : (fun word => machinePairSecond (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinaryDivRemainder] using! + machineCompose_mem_FP hsecond2 machinePairSecond_mem_FP + +theorem machineBinaryDivPack_mem_FP + {remaining divisor quotient remainder : List Bool β†’ List Bool} + (hremaining : remaining ∈ Complexity.FP) + (hdivisor : divisor ∈ Complexity.FP) + (hquotient : quotient ∈ Complexity.FP) + (hremainder : remainder ∈ Complexity.FP) : + (fun word => machineBinaryDivPack (remaining word) (divisor word) + (quotient word) (remainder word)) ∈ Complexity.FP := by + exact machinePair_mem_FP hremaining + (machinePair_mem_FP hdivisor + (machinePair_mem_FP hquotient hremainder)) + +theorem machineBinaryDivDoubleQuotient_mem_FP : + machineBinaryDivDoubleQuotient ∈ Complexity.FP := by + have hpair : (fun state => pair (machineBinaryDivQuotient state) + (machineBinaryDivQuotient state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivQuotient_mem_FP + machineBinaryDivQuotient_mem_FP + simpa only [machineBinaryDivDoubleQuotient] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineBinaryDivDoubleRemainder_mem_FP : + machineBinaryDivDoubleRemainder ∈ Complexity.FP := by + have hpair : (fun state => pair (machineBinaryDivRemainder state) + (machineBinaryDivRemainder state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivRemainder_mem_FP + machineBinaryDivRemainder_mem_FP + simpa only [machineBinaryDivDoubleRemainder] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineBinaryDivTrial_mem_FP : + machineBinaryDivTrial ∈ Complexity.FP := by + have hflag : (fun state => machineHeadBit + (machineBinaryDivRemaining state)) ∈ Complexity.FP := + machineCompose_mem_FP machineBinaryDivRemaining_mem_FP + machineHeadBit_mem_FP + have hpair : (fun state => pair + (machineBinaryDivDoubleRemainder state) [true]) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivDoubleRemainder_mem_FP + (machineConst_mem_FP [true]) + have hone := machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + simpa only [machineBinaryDivTrial] using! + machineIfHead_mem_FP hflag hone machineBinaryDivDoubleRemainder_mem_FP + +theorem machineBinaryDivTake_mem_FP : + machineBinaryDivTake ∈ Complexity.FP := by + have hpair : (fun state => pair (machineBinaryDivDivisor state) + (machineBinaryDivTrial state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivDivisor_mem_FP + machineBinaryDivTrial_mem_FP + have hle := machineCompose_mem_FP hpair machineBinaryNatLeBit_mem_FP + simpa only [machineBinaryDivTake] using! + machineIfEmpty_mem_FP machineBinaryDivDivisor_mem_FP + (machineConst_mem_FP [false]) hle + +theorem machineBinaryDivIncrementedQuotient_mem_FP : + machineBinaryDivIncrementedQuotient ∈ Complexity.FP := by + have hpair : (fun state => pair + (machineBinaryDivDoubleQuotient state) [true]) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivDoubleQuotient_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineBinaryDivIncrementedQuotient] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineBinaryDivNextQuotient_mem_FP : + machineBinaryDivNextQuotient ∈ Complexity.FP := by + have hnonzero := machineIfHead_mem_FP machineBinaryDivTake_mem_FP + machineBinaryDivIncrementedQuotient_mem_FP + machineBinaryDivDoubleQuotient_mem_FP + simpa only [machineBinaryDivNextQuotient] using! + machineIfEmpty_mem_FP machineBinaryDivDivisor_mem_FP + (machineConst_mem_FP []) hnonzero + +theorem machineBinaryDivNextRemainder_mem_FP : + machineBinaryDivNextRemainder ∈ Complexity.FP := by + have hpair : (fun state => pair (machineBinaryDivTrial state) + (machineBinaryDivDivisor state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryDivTrial_mem_FP + machineBinaryDivDivisor_mem_FP + have hsub := machineCompose_mem_FP hpair machineBinarySubBits_mem_FP + simpa only [machineBinaryDivNextRemainder] using! + machineIfHead_mem_FP machineBinaryDivTake_mem_FP hsub + machineBinaryDivTrial_mem_FP + +theorem machineBinaryDivStep_mem_FP : + machineBinaryDivStep ∈ Complexity.FP := by + exact machineBinaryDivPack_mem_FP + (machineCompose_mem_FP machineBinaryDivRemaining_mem_FP machineTail_mem_FP) + machineBinaryDivDivisor_mem_FP machineBinaryDivNextQuotient_mem_FP + machineBinaryDivNextRemainder_mem_FP + +theorem machineBinaryDivInit_mem_FP : + machineBinaryDivInit ∈ Complexity.FP := by + have hreverse := machineCompose_mem_FP machinePairFirst_mem_FP + machineReverse_mem_FP + exact machineBinaryDivPack_mem_FP hreverse machinePairSecond_mem_FP + (machineConst_mem_FP []) (machineConst_mem_FP []) + +theorem machineBinaryDivRuler_mem_FP : + machineBinaryDivRuler ∈ Complexity.FP := by + simpa only [machineBinaryDivRuler] using! machinePairFirst_mem_FP + +theorem machineBinaryDivWidth_mem_FP : + machineBinaryDivWidth ∈ Complexity.FP := by + let padded : List Bool β†’ List Bool := + fun word => List.replicate 16 false ++ word + have hpadded : padded ∈ Complexity.FP := + machineAppend_mem_FP (machineConst_mem_FP (List.replicate 16 false)) + id_mem_FP + simpa only [machineBinaryDivWidth, padded] using! + Cobham.mulLenFn_mem_FP hpadded hpadded + +@[simp] theorem machineBinaryDivRemaining_pack (remaining divisor quotient remainder) : + machineBinaryDivRemaining + (machineBinaryDivPack remaining divisor quotient remainder) = + remaining := by simp [machineBinaryDivRemaining, machineBinaryDivPack] + +@[simp] theorem machineBinaryDivDivisor_pack (remaining divisor quotient remainder) : + machineBinaryDivDivisor + (machineBinaryDivPack remaining divisor quotient remainder) = + divisor := by simp [machineBinaryDivDivisor, machineBinaryDivPack] + +@[simp] theorem machineBinaryDivQuotient_pack (remaining divisor quotient remainder) : + machineBinaryDivQuotient + (machineBinaryDivPack remaining divisor quotient remainder) = + quotient := by simp [machineBinaryDivQuotient, machineBinaryDivPack] + +@[simp] theorem machineBinaryDivRemainder_pack (remaining divisor quotient remainder) : + machineBinaryDivRemainder + (machineBinaryDivPack remaining divisor quotient remainder) = + remainder := by simp [machineBinaryDivRemainder, machineBinaryDivPack] + +/-- Bounds the remaining dividend length and the growth of quotient and remainder encodings. -/ +def MachineBinaryDivReachable + (dividend divisor : List Bool) (iterations : β„•) + (state : List Bool) : Prop := + βˆƒ remaining quotient remainder, + state = machineBinaryDivPack remaining divisor quotient remainder ∧ + remaining.length ≀ dividend.length ∧ + quotient.length ≀ 2 * iterations ∧ + remainder.length ≀ divisor.length + 2 * iterations + +theorem machineIfEmpty_length_le_max (test whenEmpty whenNonempty : List Bool) : + (machineIfEmpty test whenEmpty whenNonempty).length ≀ + max whenEmpty.length whenNonempty.length := by + cases test with + | nil => simp + | cons bit tail => simp + +theorem machineIfEmpty_of_ne_nil (test whenEmpty whenNonempty : List Bool) + (htest : test β‰  []) : + machineIfEmpty test whenEmpty whenNonempty = whenNonempty := by + cases test with + | nil => exact False.elim (htest rfl) + | cons bit tail => simp + +theorem machineIfHead_length_le_max (flag whenTrue whenFalse : List Bool) : + (machineIfHead flag whenTrue whenFalse).length ≀ + max whenTrue.length whenFalse.length := by + cases flag with + | nil => simp [machineIfHead, Cobham.selectHead] + | cons bit tail => cases bit <;> simp + +theorem machineBinaryDivInit_reachable (word : List Bool) : + MachineBinaryDivReachable (machinePairFirst word) + (machinePairSecond word) 0 (machineBinaryDivInit word) := by + refine ⟨(machinePairFirst word).reverse, [], [], rfl, ?_, by simp, by simp⟩ + simp + +theorem machineBinaryDivDoubleQuotient_length_le + (remaining divisor quotient remainder : List Bool) : + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor quotient remainder)).length ≀ + quotient.length + 1 := by + simp only [machineBinaryDivDoubleQuotient, machineBinaryDivQuotient_pack] + simpa using! machineBinaryAddBits_pair_length_le quotient quotient + +theorem machineBinaryDivDoubleRemainder_length_le + (remaining divisor quotient remainder : List Bool) : + (machineBinaryDivDoubleRemainder + (machineBinaryDivPack remaining divisor quotient remainder)).length ≀ + remainder.length + 1 := by + simp only [machineBinaryDivDoubleRemainder, machineBinaryDivRemainder_pack] + simpa using! machineBinaryAddBits_pair_length_le remainder remainder + +theorem machineBinaryDivTrial_length_le + (remaining divisor quotient remainder : List Bool) : + (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)).length ≀ + remainder.length + 2 := by + cases remaining with + | nil => + simp [machineBinaryDivTrial] + have h := machineBinaryDivDoubleRemainder_length_le + [] divisor quotient remainder + omega + | cons bit remaining => + cases bit with + | false => + simp [machineBinaryDivTrial] + have h := machineBinaryDivDoubleRemainder_length_le + (false :: remaining) divisor quotient remainder + omega + | true => + simp only [machineBinaryDivTrial, machineBinaryDivRemaining_pack, + machineHeadBit_cons, machineIfHead_true] + have hdouble := machineBinaryDivDoubleRemainder_length_le + (true :: remaining) divisor quotient remainder + have hadd := machineBinaryAddBits_pair_length_le + (machineBinaryDivDoubleRemainder + (machineBinaryDivPack (true :: remaining) divisor quotient remainder)) + [true] + have hmax : max + (machineBinaryDivDoubleRemainder + (machineBinaryDivPack (true :: remaining) divisor quotient remainder)).length + [true].length ≀ remainder.length + 1 := by + apply max_le + Β· exact hdouble + Β· simp + omega + +theorem machineBinaryDivStep_reachable + {dividend divisor : List Bool} {iterations : β„•} {state : List Bool} + (hstate : MachineBinaryDivReachable dividend divisor iterations state) : + MachineBinaryDivReachable dividend divisor (iterations + 1) + (machineBinaryDivStep state) := by + obtain ⟨remaining, quotient, remainder, rfl, hremaining, hquotient, + hremainder⟩ := hstate + simp only [machineBinaryDivStep, machineBinaryDivRemaining_pack, + machineBinaryDivDivisor_pack] + refine ⟨remaining.tail, + machineBinaryDivNextQuotient + (machineBinaryDivPack remaining divisor quotient remainder), + machineBinaryDivNextRemainder + (machineBinaryDivPack remaining divisor quotient remainder), + rfl, ?_, ?_, ?_⟩ + Β· have htail : remaining.tail.length ≀ remaining.length := by + cases remaining <;> simp + exact htail.trans hremaining + Β· simp only [machineBinaryDivNextQuotient, machineBinaryDivDivisor_pack] + have hdouble := machineBinaryDivDoubleQuotient_length_le + remaining divisor quotient remainder + have hinc := machineBinaryAddBits_pair_length_le + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor quotient remainder)) [true] + have hmaxDouble : max + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor quotient remainder)).length + [true].length ≀ quotient.length + 1 := by + apply max_le + Β· exact hdouble + Β· simp + have hinc' : + (machineBinaryDivIncrementedQuotient + (machineBinaryDivPack remaining divisor quotient remainder)).length ≀ + quotient.length + 2 := by + simpa only [machineBinaryDivIncrementedQuotient] using! + hinc.trans (Nat.add_le_add_right hmaxDouble 1) + have hnonzero := machineIfHead_length_le_max + (machineBinaryDivTake + (machineBinaryDivPack remaining divisor quotient remainder)) + (machineBinaryDivIncrementedQuotient + (machineBinaryDivPack remaining divisor quotient remainder)) + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor quotient remainder)) + have houter := machineIfEmpty_length_le_max divisor [] + (machineIfHead + (machineBinaryDivTake + (machineBinaryDivPack remaining divisor quotient remainder)) + (machineBinaryDivIncrementedQuotient + (machineBinaryDivPack remaining divisor quotient remainder)) + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor quotient remainder))) + simp only [List.length_nil, zero_le, max_eq_right] at houter + omega + Β· simp only [machineBinaryDivNextRemainder, machineBinaryDivDivisor_pack] + have htrial := machineBinaryDivTrial_length_le + remaining divisor quotient remainder + have hsub := machineBinarySubBits_pair_length_le + (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)) divisor + have hsub' : + (machineBinarySubBits + (pair (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)) + divisor)).length ≀ divisor.length + 2 * (iterations + 1) := by + apply hsub.trans + apply max_le + Β· omega + Β· omega + have hselect := machineIfHead_length_le_max + (machineBinaryDivTake + (machineBinaryDivPack remaining divisor quotient remainder)) + (machineBinarySubBits + (pair (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)) divisor)) + (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)) + have htrial' : + (machineBinaryDivTrial + (machineBinaryDivPack remaining divisor quotient remainder)).length ≀ + divisor.length + 2 * (iterations + 1) := by omega + exact hselect.trans (max_le hsub' htrial') + +theorem machineBinaryDivIterate_reachable (word : List Bool) : + βˆ€ iterations, + MachineBinaryDivReachable (machinePairFirst word) + (machinePairSecond word) iterations + (machineBinaryDivStep^[iterations] (machineBinaryDivInit word)) := by + intro iterations + induction iterations with + | zero => exact machineBinaryDivInit_reachable word + | succ iterations ih => + rw [Function.iterate_succ_apply'] + simpa [Nat.succ_eq_add_one] using! machineBinaryDivStep_reachable ih + +theorem machineBinaryDivIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBinaryDivRuler word).length) : + (machineBinaryDivStep^[iterations] + (machineBinaryDivInit word)).length ≀ + (machineBinaryDivWidth word).length := by + obtain ⟨remaining, quotient, remainder, hstate, hremaining, + hquotient, hremainder⟩ := machineBinaryDivIterate_reachable word iterations + rw [hstate] + have hdividend := machinePairFirst_length_le word + have hdivisor := machinePairSecond_length_le word + have hit : iterations ≀ word.length := hiterations.trans hdividend + simp only [machineBinaryDivPack, pair_length, machineBinaryDivWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineBinaryDivFinalState_mem_FP : + machineBinaryDivFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBinaryDivStep_mem_FP + machineBinaryDivInit_mem_FP machineBinaryDivRuler_mem_FP + machineBinaryDivWidth_mem_FP machineBinaryDivIterate_length_le_width + +theorem machineBinaryDivModBits_mem_FP : + machineBinaryDivModBits ∈ Complexity.FP := by + have hquotient := machineCompose_mem_FP machineBinaryDivFinalState_mem_FP + machineBinaryDivQuotient_mem_FP + have hremainder := machineCompose_mem_FP machineBinaryDivFinalState_mem_FP + machineBinaryDivRemainder_mem_FP + simpa only [machineBinaryDivModBits] using! + machinePair_mem_FP hquotient hremainder + +/-- Forward form of the semantic recurrence, on most-significant-first bits. -/ +def binaryLongDivForward (divisor : β„•) : + List Bool β†’ β„• Γ— β„• β†’ β„• Γ— β„• + | [], qr => qr + | bit :: remaining, qr => + binaryLongDivForward divisor remaining + (binaryLongDivStep divisor bit qr) + +theorem binaryLongDivForward_append (divisor : β„•) + (first second : List Bool) (qr : β„• Γ— β„•) : + binaryLongDivForward divisor (first ++ second) qr = + binaryLongDivForward divisor second + (binaryLongDivForward divisor first qr) := by + induction first generalizing qr with + | nil => rfl + | cons bit remaining ih => + simp only [List.cons_append, binaryLongDivForward] + exact ih (binaryLongDivStep divisor bit qr) + +theorem binaryLongDivForward_reverse (divisor : β„•) (bits : List Bool) : + binaryLongDivForward divisor bits.reverse (0, 0) = + binaryLongDivBits divisor bits := by + induction bits with + | nil => rfl + | cons bit remaining ih => + rw [List.reverse_cons, binaryLongDivForward_append] + simp only [binaryLongDivForward] + rw [ih] + rfl + +theorem natBits_ne_nil_of_ne_zero {n : β„•} (hn : n β‰  0) : n.bits β‰  [] := by + intro hbits + have hlen : n.bits.length = 0 := by simp [hbits] + have hsize : n.size = 0 := by + simpa only [Nat.size_eq_bits_len] using! hlen + exact hn (Nat.size_eq_zero.mp hsize) + +@[simp] theorem machineBinaryDivDoubleQuotient_pack_natBits + (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivDoubleQuotient + (machineBinaryDivPack remaining divisor.bits quotient.bits remainder.bits) = + (quotient + quotient).bits := by + simp only [machineBinaryDivDoubleQuotient, machineBinaryDivQuotient_pack] + exact machineBinaryAddBits_pair_natBits quotient quotient + +@[simp] theorem machineBinaryDivDoubleRemainder_pack_natBits + (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivDoubleRemainder + (machineBinaryDivPack remaining divisor.bits quotient.bits remainder.bits) = + (remainder + remainder).bits := by + simp only [machineBinaryDivDoubleRemainder, machineBinaryDivRemainder_pack] + exact machineBinaryAddBits_pair_natBits remainder remainder + +@[simp] theorem machineBinaryDivTrial_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivTrial + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + (remainder + remainder + bitValue bit).bits := by + cases bit with + | false => simp [machineBinaryDivTrial, bitValue] + | true => + simp only [machineBinaryDivTrial, machineBinaryDivRemaining_pack, + machineHeadBit_cons, machineIfHead_true, + machineBinaryDivDoubleRemainder_pack_natBits, bitValue] + simpa using! machineBinaryAddBits_pair_natBits (remainder + remainder) 1 + +@[simp] theorem machineBinaryDivTake_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivTake + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + if divisor = 0 then [false] + else [(divisor ≀ remainder + remainder + bitValue bit)] := by + by_cases hdivisor : divisor = 0 + Β· subst divisor + simp [machineBinaryDivTake] + Β· simp only [machineBinaryDivTake, machineBinaryDivDivisor_pack, + machineBinaryDivTrial_pack_natBits] + rw [machineIfEmpty_of_ne_nil divisor.bits [false] + (machineBinaryNatLeBit + (pair divisor.bits + (remainder + remainder + bitValue bit).bits)) + (natBits_ne_nil_of_ne_zero hdivisor)] + rw [machineBinaryNatLeBit_pair_natBits] + simp [hdivisor] + +@[simp] theorem machineBinaryDivIncrementedQuotient_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivIncrementedQuotient + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + (quotient + quotient + 1).bits := by + simp only [machineBinaryDivIncrementedQuotient, + machineBinaryDivDoubleQuotient_pack_natBits] + simpa using! machineBinaryAddBits_pair_natBits (quotient + quotient) 1 + +@[simp] theorem machineBinaryDivNextQuotient_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivNextQuotient + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + if divisor = 0 then [] + else if divisor ≀ remainder + remainder + bitValue bit then + (quotient + quotient + 1).bits + else (quotient + quotient).bits := by + by_cases hdivisor : divisor = 0 + Β· subst divisor + simp [machineBinaryDivNextQuotient] + Β· simp only [machineBinaryDivNextQuotient, machineBinaryDivDivisor_pack] + rw [machineIfEmpty_of_ne_nil divisor.bits [] + (machineIfHead + (machineBinaryDivTake + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits)) + (machineBinaryDivIncrementedQuotient + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits)) + (machineBinaryDivDoubleQuotient + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits))) + (natBits_ne_nil_of_ne_zero hdivisor)] + by_cases htake : divisor ≀ remainder + remainder + bitValue bit + Β· simp [hdivisor, htake] + Β· simp [hdivisor, htake] + +@[simp] theorem machineBinaryDivNextRemainder_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivNextRemainder + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + if divisor = 0 then + (remainder + remainder + bitValue bit).bits + else if divisor ≀ remainder + remainder + bitValue bit then + (remainder + remainder + bitValue bit - divisor).bits + else (remainder + remainder + bitValue bit).bits := by + rw [machineBinaryDivNextRemainder, + machineBinaryDivTake_pack_natBits, + machineBinaryDivTrial_pack_natBits] + by_cases hdivisor : divisor = 0 + Β· simp [hdivisor] + Β· by_cases htake : divisor ≀ remainder + remainder + bitValue bit + Β· simp only [hdivisor, ite_false] + simp only [htake, decide_true, machineIfHead_true, + machineBinaryDivDivisor_pack, if_true] + rw [machineBinarySubBits_pair_natBits] + Β· simp [hdivisor, htake] + +theorem machineBinaryDivStep_pack_natBits + (bit : Bool) (remaining : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivStep + (machineBinaryDivPack (bit :: remaining) divisor.bits + quotient.bits remainder.bits) = + let next := binaryLongDivStep divisor bit (quotient, remainder) + machineBinaryDivPack remaining divisor.bits next.1.bits next.2.bits := by + simp only [machineBinaryDivStep, machineBinaryDivRemaining_pack, + machineBinaryDivDivisor_pack, List.tail_cons, + machineBinaryDivNextQuotient_pack_natBits, + machineBinaryDivNextRemainder_pack_natBits] + by_cases hdivisor : divisor = 0 + Β· simp [binaryLongDivStep, hdivisor, two_mul] + Β· by_cases htake : divisor ≀ remainder + remainder + bitValue bit + Β· simp [binaryLongDivStep, hdivisor, htake, two_mul] + Β· simp [binaryLongDivStep, hdivisor, htake, two_mul] + +theorem machineBinaryDivIterate_natBits + (bits : List Bool) (divisor quotient remainder : β„•) : + machineBinaryDivStep^[bits.length] + (machineBinaryDivPack bits divisor.bits quotient.bits remainder.bits) = + let final := binaryLongDivForward divisor bits (quotient, remainder) + machineBinaryDivPack [] divisor.bits final.1.bits final.2.bits := by + induction bits generalizing quotient remainder with + | nil => rfl + | cons bit remaining ih => + rw [List.length_cons, Function.iterate_succ_apply, + machineBinaryDivStep_pack_natBits] + let next := binaryLongDivStep divisor bit (quotient, remainder) + simpa only [binaryLongDivForward] using! ih next.1 next.2 + +/-- Exact quotient/remainder correctness, including the zero-divisor +convention inherited from `Nat.div` and `Nat.mod`. -/ +theorem machineBinaryDivModBits_pair_natBits (dividend divisor : β„•) : + machineBinaryDivModBits (pair dividend.bits divisor.bits) = + pair (dividend / divisor).bits (dividend % divisor).bits := by + simp only [machineBinaryDivModBits, machineBinaryDivFinalState, + machineBinaryDivRuler, machineBinaryDivInit, machinePairFirst_pair, + machinePairSecond_pair] + rw [← @List.length_reverse Bool dividend.bits] + change pair + (machineBinaryDivQuotient + (machineBinaryDivStep^[dividend.bits.reverse.length] + (machineBinaryDivPack dividend.bits.reverse divisor.bits + (0 : β„•).bits (0 : β„•).bits))) + (machineBinaryDivRemainder + (machineBinaryDivStep^[dividend.bits.reverse.length] + (machineBinaryDivPack dividend.bits.reverse divisor.bits + (0 : β„•).bits (0 : β„•).bits))) = _ + rw [machineBinaryDivIterate_natBits dividend.bits.reverse divisor 0 0] + simp only [machineBinaryDivQuotient_pack, machineBinaryDivRemainder_pack] + rw [binaryLongDivForward_reverse, binaryLongDivBits_eq_div_mod] + simp only [Prod.fst, Prod.snd, Nat.fromBitsLE_bits] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryGCD.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryGCD.lean new file mode 100644 index 0000000000..1db8d5c051 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryGCD.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryDivision +public import LeanPool.BeyondBethe.BeyondBethe.MachineTrimHighZeros + +/-! +# Polynomial-time binary gcd + +This is a fixed-budget Euclidean algorithm on canonical little-endian words. +The input components are canonicalized first. Each step obtains its remainder +from the verified long-division machine, and two iterations per bit of the +initial second component suffice by the previously proved Euclid bound. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the remainder component of the encoded division-with-remainder result. -/ +def machineBinaryRemainderBits (word : List Bool) : List Bool := + machinePairSecond (machineBinaryDivModBits word) + +/-- Performs a Euclidean step, leaving states with zero second operand fixed. -/ +def machineBinaryGcdStep (state : List Bool) : List Bool := + machineIfEmpty (machinePairSecond state) state + (pair (machinePairSecond state) (machineBinaryRemainderBits state)) + +/-- Initializes the Euclidean algorithm after trimming high zeros from both operands. -/ +def machineBinaryGcdInit (word : List Bool) : List Bool := + pair (machineTrimHighZeros (machinePairFirst word)) + (machineTrimHighZeros (machinePairSecond word)) + +/-- Uses twice the normalized second-operand bit length as the Euclidean iteration budget. -/ +def machineBinaryGcdRuler (word : List Bool) : List Bool := + let second := machineTrimHighZeros (machinePairSecond word) + second ++ second + +/-- Provides a quadratic encoded-state width ruler for the Euclidean algorithm. -/ +def machineBinaryGcdWidth (word : List Bool) : List Bool := + let padded := List.replicate 16 false ++ word + List.replicate (padded.length * padded.length) false + +/-- Runs the Euclidean step for twice the normalized second-operand bit length. -/ +def machineBinaryGcdFinalState (word : List Bool) : List Bool := + machineBinaryGcdStep^[(machineBinaryGcdRuler word).length] + (machineBinaryGcdInit word) + +/-- Extracts the greatest common divisor from the final Euclidean state. -/ +def machineBinaryGcdBits (word : List Bool) : List Bool := + machinePairFirst (machineBinaryGcdFinalState word) + +theorem machineBinaryRemainderBits_mem_FP : + machineBinaryRemainderBits ∈ Complexity.FP := by + simpa only [machineBinaryRemainderBits] using! + machineCompose_mem_FP machineBinaryDivModBits_mem_FP + machinePairSecond_mem_FP + +theorem machineBinaryGcdStep_mem_FP : + machineBinaryGcdStep ∈ Complexity.FP := by + have hpair : (fun state => pair (machinePairSecond state) + (machineBinaryRemainderBits state)) ∈ Complexity.FP := + machinePair_mem_FP machinePairSecond_mem_FP + machineBinaryRemainderBits_mem_FP + simpa only [machineBinaryGcdStep] using! + machineIfEmpty_mem_FP machinePairSecond_mem_FP id_mem_FP hpair + +theorem machineBinaryGcdInit_mem_FP : + machineBinaryGcdInit ∈ Complexity.FP := by + have hfirst := machineCompose_mem_FP machinePairFirst_mem_FP + machineTrimHighZeros_mem_FP + have hsecond := machineCompose_mem_FP machinePairSecond_mem_FP + machineTrimHighZeros_mem_FP + simpa only [machineBinaryGcdInit] using! machinePair_mem_FP hfirst hsecond + +theorem machineBinaryGcdRuler_mem_FP : + machineBinaryGcdRuler ∈ Complexity.FP := by + have hsecond := machineCompose_mem_FP machinePairSecond_mem_FP + machineTrimHighZeros_mem_FP + simpa only [machineBinaryGcdRuler] using! machineAppend_mem_FP hsecond hsecond + +theorem machineBinaryGcdWidth_mem_FP : + machineBinaryGcdWidth ∈ Complexity.FP := by + let padded : List Bool β†’ List Bool := + fun word => List.replicate 16 false ++ word + have hpadded : padded ∈ Complexity.FP := + machineAppend_mem_FP (machineConst_mem_FP (List.replicate 16 false)) + id_mem_FP + simpa only [machineBinaryGcdWidth, padded] using! + Cobham.mulLenFn_mem_FP hpadded hpadded + +theorem machineBinaryGcdStep_pair_natBits (a b : β„•) : + machineBinaryGcdStep (pair a.bits b.bits) = + pair (binaryEuclidStep (a, b)).1.bits + (binaryEuclidStep (a, b)).2.bits := by + rw [binaryEuclidStep_eq] + by_cases hb : b = 0 + Β· subst b + simp [machineBinaryGcdStep] + Β· simp only [machineBinaryGcdStep, machinePairSecond_pair] + rw [machineIfEmpty_of_ne_nil b.bits (pair a.bits b.bits) + (pair b.bits (machineBinaryRemainderBits (pair a.bits b.bits))) + (natBits_ne_nil_of_ne_zero hb)] + simp only [machineBinaryRemainderBits, + machineBinaryDivModBits_pair_natBits, machinePairSecond_pair, + hb, ite_false, Prod.fst, Prod.snd] + +/-- Expresses a state as a pair of canonical natural-number bit strings bounded by the input +length. -/ +def MachineBinaryGcdReachable (word state : List Bool) : Prop := + βˆƒ a b : β„•, + state = pair a.bits b.bits ∧ + a.bits.length ≀ word.length ∧ b.bits.length ≀ word.length + +theorem machineBinaryGcdInit_reachable (word : List Bool) : + MachineBinaryGcdReachable word (machineBinaryGcdInit word) := by + let a := Nat.fromBitsLE (machinePairFirst word) + let b := Nat.fromBitsLE (machinePairSecond word) + refine ⟨a, b, ?_, ?_, ?_⟩ + Β· simp only [machineBinaryGcdInit, machineTrimHighZeros_eq, + BinaryRippleSub.trimHighZeros_eq_natBits_internal, a, b] + Β· have htrim := binaryTrimHighZeros_length_le (machinePairFirst word) + rw [BinaryRippleSub.trimHighZeros_eq_natBits_internal] at htrim + exact htrim.trans (machinePairFirst_length_le word) + Β· have htrim := binaryTrimHighZeros_length_le (machinePairSecond word) + rw [BinaryRippleSub.trimHighZeros_eq_natBits_internal] at htrim + exact htrim.trans (machinePairSecond_length_le word) + +theorem machineBinaryGcdStep_reachable {word state : List Bool} + (hstate : MachineBinaryGcdReachable word state) : + MachineBinaryGcdReachable word (machineBinaryGcdStep state) := by + obtain ⟨a, b, rfl, ha, hb⟩ := hstate + rw [machineBinaryGcdStep_pair_natBits] + by_cases hbzero : b = 0 + Β· subst b + refine ⟨a, 0, ?_, ha, by simp⟩ + simp [binaryEuclidStep] + Β· refine ⟨b, a % b, ?_, hb, ?_⟩ + Β· simp [binaryEuclidStep, hbzero, binaryLongDiv_eq_div_mod] + Β· have hsize := Nat.size_le_size (Nat.mod_le a b) + have hbits : (a % b).bits.length ≀ a.bits.length := by + simpa only [Nat.size_eq_bits_len] using! hsize + exact hbits.trans ha + +theorem machineBinaryGcdIterate_reachable (word : List Bool) : + βˆ€ steps : β„•, + MachineBinaryGcdReachable word + (machineBinaryGcdStep^[steps] (machineBinaryGcdInit word)) := by + intro steps + induction steps with + | zero => exact machineBinaryGcdInit_reachable word + | succ steps ih => + rw [Function.iterate_succ_apply'] + exact machineBinaryGcdStep_reachable ih + +theorem machineBinaryGcdIterate_length_le_width + (word : List Bool) (steps : β„•) + (_hsteps : steps ≀ (machineBinaryGcdRuler word).length) : + (machineBinaryGcdStep^[steps] (machineBinaryGcdInit word)).length ≀ + (machineBinaryGcdWidth word).length := by + obtain ⟨a, b, hstate, ha, hb⟩ := + machineBinaryGcdIterate_reachable word steps + rw [hstate] + simp only [pair_length, machineBinaryGcdWidth, List.length_replicate, + List.length_append] + nlinarith + +theorem machineBinaryGcdFinalState_mem_FP : + machineBinaryGcdFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBinaryGcdStep_mem_FP + machineBinaryGcdInit_mem_FP machineBinaryGcdRuler_mem_FP + machineBinaryGcdWidth_mem_FP machineBinaryGcdIterate_length_le_width + +theorem machineBinaryGcdBits_mem_FP : + machineBinaryGcdBits ∈ Complexity.FP := by + simpa only [machineBinaryGcdBits] using! + machineCompose_mem_FP machineBinaryGcdFinalState_mem_FP + machinePairFirst_mem_FP + +theorem machineBinaryGcdIterate_pair_natBits (steps a b : β„•) : + machineBinaryGcdStep^[steps] (pair a.bits b.bits) = + let final := binaryEuclidIterate steps (a, b) + pair final.1.bits final.2.bits := by + induction steps generalizing a b with + | zero => rfl + | succ steps ih => + rw [Function.iterate_succ_apply, machineBinaryGcdStep_pair_natBits] + simpa only [binaryEuclidIterate] using! + ih (binaryEuclidStep (a, b)).1 (binaryEuclidStep (a, b)).2 + +theorem machineBinaryGcdBits_eq (word : List Bool) : + machineBinaryGcdBits word = + (Nat.gcd (Nat.fromBitsLE (machinePairFirst word)) + (Nat.fromBitsLE (machinePairSecond word))).bits := by + let a := Nat.fromBitsLE (machinePairFirst word) + let b := Nat.fromBitsLE (machinePairSecond word) + simp only [machineBinaryGcdBits, machineBinaryGcdFinalState, + machineBinaryGcdRuler, machineBinaryGcdInit, + machineTrimHighZeros_eq, + BinaryRippleSub.trimHighZeros_eq_natBits_internal, + List.length_append, a, b] + rw [show b.bits.length + b.bits.length = 2 * b.size by + simp [Nat.size_eq_bits_len, two_mul]] + rw [machineBinaryGcdIterate_pair_natBits] + simp only [machinePairFirst_pair] + change (binaryEuclidBounded + (Nat.fromBitsLE (machinePairFirst word)) + (Nat.fromBitsLE (machinePairSecond word))).bits = _ + rw [binaryEuclidBounded_eq_gcd] + +theorem machineBinaryGcdBits_pair_natBits (a b : β„•) : + machineBinaryGcdBits (pair a.bits b.bits) = (Nat.gcd a b).bits := by + rw [machineBinaryGcdBits_eq] + simp only [machinePairFirst_pair, machinePairSecond_pair, + Nat.fromBitsLE_bits] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListInit.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListInit.lean new file mode 100644 index 0000000000..df014077ed --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListInit.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse + +/-! +# Removing the last entry of a finite-word list + +The center of an epigraph ellipsoid is stored as a right-nested list. The +base point consists of every coordinate except the final height coordinate. +This machine reverses the list, removes its first encoded entry, and reverses +again. It is total and polynomial-time on arbitrary finite words. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Reverses an encoded list before removing its final entry. -/ +def machineBinaryListInitReversed (word : List Bool) : List Bool := + machineListReverse word + +/-- Removes the head of the reversed encoded list. -/ +def machineBinaryListInitReversedTail (word : List Bool) : List Bool := + machineListTail (machineBinaryListInitReversed word) + +/-- Returns the encoded list without its last entry by reversing, taking the tail, and reversing +again. -/ +def machineBinaryListInit (word : List Bool) : List Bool := + machineListReverse (machineBinaryListInitReversedTail word) + +theorem machineBinaryListInitReversed_mem_FP : + machineBinaryListInitReversed ∈ FP := by + simpa only [machineBinaryListInitReversed] using! + machineListReverse_mem_FP + +theorem machineBinaryListInitReversedTail_mem_FP : + machineBinaryListInitReversedTail ∈ FP := by + simpa only [machineBinaryListInitReversedTail] using! + machineCompose_mem_FP machineBinaryListInitReversed_mem_FP + machineListTail_mem_FP + +theorem machineBinaryListInit_mem_FP : machineBinaryListInit ∈ FP := by + simpa only [machineBinaryListInit] using! + machineCompose_mem_FP machineBinaryListInitReversedTail_mem_FP + machineListReverse_mem_FP + +@[simp] theorem machineBinaryListInit_encode + {alpha : Type*} (encode : alpha β†’ List Bool) + (xs : List alpha) (x : alpha) : + machineBinaryListInit (binaryListCode encode (xs ++ [x])) = + binaryListCode encode xs := by + rw [machineBinaryListInit, machineBinaryListInitReversedTail, + machineBinaryListInitReversed, machineListReverse_encode] + rw [List.reverse_append] + simp only [List.reverse_singleton, List.singleton_append] + rw [machineListTail_cons, machineListReverse_encode] + simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListSnoc.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListSnoc.lean new file mode 100644 index 0000000000..0726966593 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryListSnoc.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse + +/-! +# Appending one entry to a finite-word list + +The canonical list representation is right-nested, so appending an entry is +not a constant-time constructor operation. This machine reverses the encoded +list, prepends the supplied encoded entry, and reverses once more. The two +uses of the verified list-reversal machine make the construction total and +polynomial-time on arbitrary finite words. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Input layout: `pair encodedEntry encodedList`. -/ +def machineBinaryListSnocEntry (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded list to which an entry will be appended. -/ +def machineBinaryListSnocList (word : List Bool) : List Bool := + machinePairSecond word + +/-- Reverses the encoded list before appending its new final entry. -/ +def machineBinaryListSnocReversedList (word : List Bool) : List Bool := + machineListReverse (machineBinaryListSnocList word) + +/-- Prepends the new entry to the reversed encoded list. -/ +def machineBinaryListSnocPrependInput (word : List Bool) : List Bool := + pair (machineBinaryListSnocEntry word) + (machineBinaryListSnocReversedList word) + +/-- Appends an encoded entry to a list by reversing the prepended reversed list. -/ +def machineBinaryListSnoc (word : List Bool) : List Bool := + machineListReverse (machineBinaryListSnocPrependInput word) + +theorem machineBinaryListSnocEntry_mem_FP : + machineBinaryListSnocEntry ∈ FP := machinePairFirst_mem_FP + +theorem machineBinaryListSnocList_mem_FP : + machineBinaryListSnocList ∈ FP := machinePairSecond_mem_FP + +theorem machineBinaryListSnocReversedList_mem_FP : + machineBinaryListSnocReversedList ∈ FP := by + simpa only [machineBinaryListSnocReversedList] using! + machineCompose_mem_FP machineBinaryListSnocList_mem_FP + machineListReverse_mem_FP + +theorem machineBinaryListSnocPrependInput_mem_FP : + machineBinaryListSnocPrependInput ∈ FP := + machinePair_mem_FP machineBinaryListSnocEntry_mem_FP + machineBinaryListSnocReversedList_mem_FP + +theorem machineBinaryListSnoc_mem_FP : machineBinaryListSnoc ∈ FP := by + simpa only [machineBinaryListSnoc] using! + machineCompose_mem_FP machineBinaryListSnocPrependInput_mem_FP + machineListReverse_mem_FP + +@[simp] theorem machineBinaryListSnoc_encode + {alpha : Type*} (encode : alpha β†’ List Bool) + (xs : List alpha) (x : alpha) : + machineBinaryListSnoc + (pair (encode x) (binaryListCode encode xs)) = + binaryListCode encode (xs ++ [x]) := by + rw [machineBinaryListSnoc, machineBinaryListSnocPrependInput, + machineBinaryListSnocEntry, machineBinaryListSnocReversedList, + machineBinaryListSnocList, machinePairFirst_pair, + machinePairSecond_pair, machineListReverse_encode] + change machineListReverse + (binaryListCode encode (x :: xs.reverse)) = _ + rw [machineListReverse_encode] + simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryMul.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryMul.lean new file mode 100644 index 0000000000..0235615cd7 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinaryMul.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits + +/-! +# A composed polynomial-time binary multiplier + +The multiplier scans the little-endian multiplier. Its state contains the +unread multiplier, the current doubled multiplicand, and the accumulated +partial product. Each iteration uses the already verified binary adder. A +quadratic Cobham width bound is proved for every input string, while exact +arithmetic correctness is proved on canonical `Nat.bits` operands. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes multiplication state as remaining multiplier bits, shifted multiplicand, and +accumulator. -/ +def machineBinaryMulPack + (remaining shift acc : List Bool) : List Bool := + pair remaining (pair shift acc) + +/-- Extracts the unprocessed multiplier bits from the multiplication state. -/ +def machineBinaryMulRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the shifted multiplicand from the multiplication state. -/ +def machineBinaryMulShift (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated product from the multiplication state. -/ +def machineBinaryMulAcc (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Doubles the shifted multiplicand for the next multiplier bit. -/ +def machineBinaryMulNextShift (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBinaryMulShift state) (machineBinaryMulShift state)) + +/-- Adds the shifted multiplicand to the accumulator when the current multiplier bit is set. -/ +def machineBinaryMulNextAcc (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineBinaryMulRemaining state)) + (machineBinaryAddBits + (pair (machineBinaryMulAcc state) (machineBinaryMulShift state))) + (machineBinaryMulAcc state) + +/-- Consumes one multiplier bit, doubles the shift, and conditionally updates the accumulator. -/ +def machineBinaryMulStep (state : List Bool) : List Bool := + machineBinaryMulPack + (machineBinaryMulRemaining state).tail + (machineBinaryMulNextShift state) + (machineBinaryMulNextAcc state) + +/-- Initializes multiplication with the second operand as multiplier and a zero accumulator. -/ +def machineBinaryMulInit (word : List Bool) : List Bool := + machineBinaryMulPack (machinePairSecond word) (machinePairFirst word) [] + +/-- Uses the second operand's bits as the multiplication iteration ruler. -/ +def machineBinaryMulRuler (word : List Bool) : List Bool := + machinePairSecond word + +/-- A deliberately generous quadratic state envelope. -/ +def machineBinaryMulWidth (word : List Bool) : List Bool := + let padded := List.replicate 16 false ++ word + List.replicate (padded.length * padded.length) false + +/-- Runs one multiplication step for each bit of the second operand. -/ +def machineBinaryMulFinalState (word : List Bool) : List Bool := + machineBinaryMulStep^[(machineBinaryMulRuler word).length] + (machineBinaryMulInit word) + +/-- Extracts the accumulated product from the final multiplication state. -/ +def machineBinaryMulBits (word : List Bool) : List Bool := + machineBinaryMulAcc (machineBinaryMulFinalState word) + +theorem machineBinaryMulRemaining_mem_FP : + machineBinaryMulRemaining ∈ Complexity.FP := by + simpa only [machineBinaryMulRemaining] using! machinePairFirst_mem_FP + +theorem machineBinaryMulShift_mem_FP : + machineBinaryMulShift ∈ Complexity.FP := by + simpa only [machineBinaryMulShift] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBinaryMulAcc_mem_FP : + machineBinaryMulAcc ∈ Complexity.FP := by + simpa only [machineBinaryMulAcc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineBinaryMulPack_mem_FP + {remaining shift acc : List Bool β†’ List Bool} + (hremaining : remaining ∈ Complexity.FP) + (hshift : shift ∈ Complexity.FP) (hacc : acc ∈ Complexity.FP) : + (fun word => machineBinaryMulPack (remaining word) (shift word) + (acc word)) ∈ Complexity.FP := by + exact machinePair_mem_FP hremaining (machinePair_mem_FP hshift hacc) + +theorem machineBinaryMulNextShift_mem_FP : + machineBinaryMulNextShift ∈ Complexity.FP := by + have hpair : (fun state => pair (machineBinaryMulShift state) + (machineBinaryMulShift state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryMulShift_mem_FP + machineBinaryMulShift_mem_FP + simpa only [machineBinaryMulNextShift] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineBinaryMulNextAcc_mem_FP : + machineBinaryMulNextAcc ∈ Complexity.FP := by + have hflag : (fun state => + machineHeadBit (machineBinaryMulRemaining state)) ∈ Complexity.FP := + machineCompose_mem_FP machineBinaryMulRemaining_mem_FP + machineHeadBit_mem_FP + have hpair : (fun state => pair (machineBinaryMulAcc state) + (machineBinaryMulShift state)) ∈ Complexity.FP := + machinePair_mem_FP machineBinaryMulAcc_mem_FP + machineBinaryMulShift_mem_FP + have hadd : (fun state => machineBinaryAddBits + (pair (machineBinaryMulAcc state) (machineBinaryMulShift state))) ∈ + Complexity.FP := + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + exact machineIfHead_mem_FP hflag hadd machineBinaryMulAcc_mem_FP + +theorem machineBinaryMulStep_mem_FP : + machineBinaryMulStep ∈ Complexity.FP := by + apply machineBinaryMulPack_mem_FP + Β· exact machineCompose_mem_FP machineBinaryMulRemaining_mem_FP + machineTail_mem_FP + Β· exact machineBinaryMulNextShift_mem_FP + Β· exact machineBinaryMulNextAcc_mem_FP + +theorem machineBinaryMulInit_mem_FP : + machineBinaryMulInit ∈ Complexity.FP := by + exact machineBinaryMulPack_mem_FP machinePairSecond_mem_FP + machinePairFirst_mem_FP (machineConst_mem_FP []) + +theorem machineBinaryMulRuler_mem_FP : + machineBinaryMulRuler ∈ Complexity.FP := by + simpa only [machineBinaryMulRuler] using! machinePairSecond_mem_FP + +theorem machineBinaryMulWidth_mem_FP : + machineBinaryMulWidth ∈ Complexity.FP := by + let padded : List Bool β†’ List Bool := + fun word => List.replicate 16 false ++ word + have hpadded : padded ∈ Complexity.FP := + machineAppend_mem_FP (machineConst_mem_FP (List.replicate 16 false)) + id_mem_FP + simpa only [machineBinaryMulWidth, padded] using! + Cobham.mulLenFn_mem_FP hpadded hpadded + +@[simp] theorem machineBinaryMulRemaining_pack (remaining shift acc) : + machineBinaryMulRemaining (machineBinaryMulPack remaining shift acc) = + remaining := by + simp [machineBinaryMulRemaining, machineBinaryMulPack] + +@[simp] theorem machineBinaryMulShift_pack (remaining shift acc) : + machineBinaryMulShift (machineBinaryMulPack remaining shift acc) = + shift := by + simp [machineBinaryMulShift, machineBinaryMulPack] + +@[simp] theorem machineBinaryMulAcc_pack (remaining shift acc) : + machineBinaryMulAcc (machineBinaryMulPack remaining shift acc) = acc := by + simp [machineBinaryMulAcc, machineBinaryMulPack] + +@[simp] theorem machineBinaryMulStep_pack + (bit : Bool) (remaining shift acc : List Bool) : + machineBinaryMulStep + (machineBinaryMulPack (bit :: remaining) shift acc) = + machineBinaryMulPack remaining + (machineBinaryAddBits (pair shift shift)) + (if bit then machineBinaryAddBits (pair acc shift) else acc) := by + cases bit <;> + simp [machineBinaryMulStep, machineBinaryMulNextShift, + machineBinaryMulNextAcc] + +/-- Pure list-level fold mirrored by the bounded machine loop. -/ +def binaryMulFold : List Bool β†’ List Bool β†’ List Bool β†’ + List Bool Γ— List Bool + | [], shift, acc => (shift, acc) + | bit :: remaining, shift, acc => + binaryMulFold remaining + (machineBinaryAddBits (pair shift shift)) + (if bit then machineBinaryAddBits (pair acc shift) else acc) + +theorem machineBinaryMulIterate_length + (bits shift acc : List Bool) : + machineBinaryMulStep^[bits.length] + (machineBinaryMulPack bits shift acc) = + machineBinaryMulPack [] + (binaryMulFold bits shift acc).1 + (binaryMulFold bits shift acc).2 := by + induction bits generalizing shift acc with + | nil => rfl + | cons bit remaining ih => + rw [List.length_cons, Function.iterate_succ_apply, + machineBinaryMulStep_pack, ih] + rfl + +/-- Bounds the remaining multiplier length and the growth of the shifted operand and +accumulator. -/ +def MachineBinaryMulReachable + (lhs rhs : List Bool) (iterations : β„•) (state : List Bool) : Prop := + βˆƒ remaining shift acc, + state = machineBinaryMulPack remaining shift acc ∧ + remaining.length ≀ rhs.length ∧ + shift.length ≀ lhs.length + iterations ∧ + acc.length ≀ lhs.length + iterations + 1 + +theorem machineBinaryMulInit_reachable (word : List Bool) : + MachineBinaryMulReachable (machinePairFirst word) + (machinePairSecond word) 0 (machineBinaryMulInit word) := by + refine ⟨machinePairSecond word, machinePairFirst word, [], rfl, + le_rfl, ?_, ?_⟩ <;> simp + +theorem machineBinaryMulStep_reachable + {lhs rhs : List Bool} {iterations : β„•} {state : List Bool} + (hstate : MachineBinaryMulReachable lhs rhs iterations state) : + MachineBinaryMulReachable lhs rhs (iterations + 1) + (machineBinaryMulStep state) := by + obtain ⟨remaining, shift, acc, rfl, hremaining, hshift, hacc⟩ := hstate + cases remaining with + | nil => + refine ⟨[], machineBinaryAddBits (pair shift shift), + machineBinaryMulNextAcc (machineBinaryMulPack [] shift acc), + ?_, by simp, ?_, ?_⟩ + Β· simp [machineBinaryMulStep, machineBinaryMulNextShift] + Β· have hadd := machineBinaryAddBits_pair_length_le shift shift + omega + Β· simp [machineBinaryMulNextAcc] + omega + | cons bit remaining => + refine ⟨remaining, machineBinaryAddBits (pair shift shift), + (if bit then machineBinaryAddBits (pair acc shift) else acc), + machineBinaryMulStep_pack bit remaining shift acc, + ?_, ?_, ?_⟩ + Β· simp only [List.length_cons] at hremaining + omega + Β· have hadd := machineBinaryAddBits_pair_length_le shift shift + omega + Β· cases bit with + | false => simp; omega + | true => + simp only [Bool.true_eq, if_true] + have hadd := machineBinaryAddBits_pair_length_le acc shift + omega + +theorem machineBinaryMulIterate_reachable (word : List Bool) : + βˆ€ iterations, + MachineBinaryMulReachable (machinePairFirst word) + (machinePairSecond word) iterations + (machineBinaryMulStep^[iterations] (machineBinaryMulInit word)) := by + intro iterations + induction iterations with + | zero => exact machineBinaryMulInit_reachable word + | succ iterations ih => + rw [Function.iterate_succ_apply'] + simpa [Nat.succ_eq_add_one] using! machineBinaryMulStep_reachable ih + +theorem machineBinaryMulIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBinaryMulRuler word).length) : + (machineBinaryMulStep^[iterations] + (machineBinaryMulInit word)).length ≀ + (machineBinaryMulWidth word).length := by + obtain ⟨remaining, shift, acc, hstate, hremaining, hshift, hacc⟩ := + machineBinaryMulIterate_reachable word iterations + rw [hstate] + have hlhs := machinePairFirst_length_le word + have hrhs := machinePairSecond_length_le word + have hit : iterations ≀ word.length := by + exact hiterations.trans hrhs + simp only [machineBinaryMulPack, pair_length, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineBinaryMulFinalState_mem_FP : + machineBinaryMulFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBinaryMulStep_mem_FP + machineBinaryMulInit_mem_FP machineBinaryMulRuler_mem_FP + machineBinaryMulWidth_mem_FP machineBinaryMulIterate_length_le_width + +theorem machineBinaryMulBits_mem_FP : + machineBinaryMulBits ∈ Complexity.FP := by + simpa only [machineBinaryMulBits] using! + machineCompose_mem_FP machineBinaryMulFinalState_mem_FP + machineBinaryMulAcc_mem_FP + +theorem binaryMulFold_natBits (bits : List Bool) (shift acc : β„•) : + (binaryMulFold bits shift.bits acc.bits).2 = + (acc + shift * Nat.fromBitsLE bits).bits := by + induction bits generalizing shift acc with + | nil => + have hempty : Nat.fromBitsLE [] = 0 := rfl + simp [binaryMulFold, hempty] + | cons bit remaining ih => + cases bit with + | false => + simp only [binaryMulFold, machineBinaryAddBits_pair_natBits] + simp only [Bool.false_eq_true, ↓reduceIte] + rw [ih (shift + shift) acc] + simp only [Nat.fromBitsLE_cons] + congr 1 + simp only [Bool.false_eq_true, ite_false] + ring + | true => + simp only [binaryMulFold, machineBinaryAddBits_pair_natBits] + simp only [↓reduceIte] + rw [ih (shift + shift) (acc + shift)] + simp only [Nat.fromBitsLE_cons] + congr 1 + simp only [eq_self, if_true] + ring + +/-- The concrete multiplier returns the canonical binary expansion of the +product of two canonically encoded natural numbers. -/ +theorem machineBinaryMulBits_pair_natBits (lhs rhs : β„•) : + machineBinaryMulBits (pair lhs.bits rhs.bits) = (lhs * rhs).bits := by + simp only [machineBinaryMulBits, machineBinaryMulFinalState, + machineBinaryMulRuler, machineBinaryMulInit, machinePairFirst_pair, + machinePairSecond_pair] + rw [machineBinaryMulIterate_length] + simp only [machineBinaryMulAcc_pack] + have hfold := binaryMulFold_natBits rhs.bits lhs 0 + calc + (binaryMulFold rhs.bits lhs.bits []).2 = + (lhs * Nat.fromBitsLE rhs.bits).bits := by simpa using! hfold + _ = (lhs * rhs).bits := by rw [Nat.fromBitsLE_bits] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBinarySub.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBinarySub.lean new file mode 100644 index 0000000000..b30496a83a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBinarySub.lean @@ -0,0 +1,534 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineTrimHighZeros +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub + +/-! +# A composed polynomial-time binary subtractor + +The state is `pair x (pair y (pair borrow accRev))`. A bounded ripple-borrow +scan produces a fixed-width difference; a verified final branch maps +underflow to zero and otherwise removes redundant high zeroes. Thus the +machine implements truncated subtraction on canonical natural words. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes subtraction state as remaining operands, borrow, and reversed accumulated bits. -/ +def machineBinarySubPack + (x y borrow accRev : List Bool) : List Bool := + pair x (pair y (pair borrow accRev)) + +/-- Extracts the unprocessed minuend bits from the subtraction state. -/ +def machineBinarySubX (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed subtrahend bits from the subtraction state. -/ +def machineBinarySubY (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the borrow word from the binary-subtraction state. -/ +def machineBinarySubBorrow (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extract the reversed output-bit accumulator from the subtraction state. -/ +def machineBinarySubAccRev (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Return a true bit exactly when at least one operand still has an unprocessed bit. -/ +def machineBinarySubActive (state : List Bool) : List Bool := + machineIfEmpty (machineBinarySubX state) + (machineIfEmpty (machineBinarySubY state) [false] [true]) [true] + +/-- The current difference bit, computed as the parity of the operand heads and incoming borrow. -/ +def machineBinarySubDiffBit (state : List Bool) : List Bool := + machineFullAdderSum + (machineHeadBit (machineBinarySubX state)) + (machineHeadBit (machineBinarySubY state)) + (machineBinarySubBorrow state) + +/-- Compute the outgoing borrow from the two operand heads and incoming borrow. -/ +def machineBinarySubNextBorrow (state : List Bool) : List Bool := + let lhs := machineHeadBit (machineBinarySubX state) + let rhs := machineHeadBit (machineBinarySubY state) + let borrow := machineBinarySubBorrow state + machineOrBit (machineAndBit (machineNotBit lhs) rhs) + (machineOrBit (machineAndBit (machineNotBit lhs) borrow) + (machineAndBit rhs borrow)) + +/-- Consume both operand heads, update the borrow, and prepend the new difference bit to the +reversed accumulator. -/ +def machineBinarySubAdvanced (state : List Bool) : List Bool := + machineBinarySubPack + (machineBinarySubX state).tail + (machineBinarySubY state).tail + (machineBinarySubNextBorrow state) + (machineBinarySubDiffBit state ++ machineBinarySubAccRev state) + +/-- Advance subtraction while either operand remains; otherwise leave the state fixed. -/ +def machineBinarySubStep (state : List Bool) : List Bool := + machineIfHead (machineBinarySubActive state) + (machineBinarySubAdvanced state) state + +/-- Initialize subtraction from the two decoded operands with no borrow and an empty +accumulator. -/ +def machineBinarySubInit (word : List Bool) : List Bool := + machineBinarySubPack (machinePairFirst word) (machinePairSecond word) + [false] [] + +/-- Concatenate the operand words to obtain a sufficient subtraction iteration ruler. -/ +def machineBinarySubRuler (word : List Bool) : List Bool := + machinePairFirst word ++ machinePairSecond word + +/-- A false-bit width ruler of length `(word.length + 8)^2` for subtraction states. -/ +def machineBinarySubWidth (word : List Bool) : List Bool := + let padded := List.replicate 8 false ++ word + List.replicate (padded.length * padded.length) false + +/-- Run subtraction for the sum of the two decoded operand lengths. -/ +def machineBinarySubFinalState (word : List Bool) : List Bool := + machineBinarySubStep^[(machineBinarySubRuler word).length] + (machineBinarySubInit word) + +/-- Return zero on a final borrow; otherwise reverse the accumulated difference bits and remove +high zeros. -/ +def machineBinarySubBits (word : List Bool) : List Bool := + let state := machineBinarySubFinalState word + machineIfHead (machineBinarySubBorrow state) [] + (machineTrimHighZeros (machineBinarySubAccRev state).reverse) + +theorem machineBinarySubX_mem_FP : machineBinarySubX ∈ Complexity.FP := by + simpa only [machineBinarySubX] using! machinePairFirst_mem_FP + +theorem machineBinarySubY_mem_FP : machineBinarySubY ∈ Complexity.FP := by + simpa only [machineBinarySubY] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBinarySubBorrow_mem_FP : + machineBinarySubBorrow ∈ Complexity.FP := by + have hsecond2 : (fun word => + machinePairSecond (machinePairSecond word)) ∈ Complexity.FP := + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinarySubBorrow] using! + machineCompose_mem_FP hsecond2 machinePairFirst_mem_FP + +theorem machineBinarySubAccRev_mem_FP : + machineBinarySubAccRev ∈ Complexity.FP := by + have hsecond2 : (fun word => + machinePairSecond (machinePairSecond word)) ∈ Complexity.FP := + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineBinarySubAccRev] using! + machineCompose_mem_FP hsecond2 machinePairSecond_mem_FP + +theorem machineBinarySubPack_mem_FP + {x y borrow accRev : List Bool β†’ List Bool} + (hx : x ∈ Complexity.FP) (hy : y ∈ Complexity.FP) + (hborrow : borrow ∈ Complexity.FP) (hacc : accRev ∈ Complexity.FP) : + (fun word => machineBinarySubPack (x word) (y word) + (borrow word) (accRev word)) ∈ Complexity.FP := by + exact machinePair_mem_FP hx + (machinePair_mem_FP hy (machinePair_mem_FP hborrow hacc)) + +theorem machineBinarySubActive_mem_FP : + machineBinarySubActive ∈ Complexity.FP := by + apply machineIfEmpty_mem_FP machineBinarySubX_mem_FP + Β· exact machineIfEmpty_mem_FP machineBinarySubY_mem_FP + (machineConst_mem_FP [false]) (machineConst_mem_FP [true]) + Β· exact machineConst_mem_FP [true] + +theorem machineBinarySubDiffBit_mem_FP : + machineBinarySubDiffBit ∈ Complexity.FP := by + apply machineFullAdderSum_mem_FP + Β· exact machineCompose_mem_FP machineBinarySubX_mem_FP + machineHeadBit_mem_FP + Β· exact machineCompose_mem_FP machineBinarySubY_mem_FP + machineHeadBit_mem_FP + Β· exact machineBinarySubBorrow_mem_FP + +theorem machineBinarySubNextBorrow_mem_FP : + machineBinarySubNextBorrow ∈ Complexity.FP := by + have hlhs : (fun state => machineHeadBit (machineBinarySubX state)) ∈ + Complexity.FP := + machineCompose_mem_FP machineBinarySubX_mem_FP machineHeadBit_mem_FP + have hrhs : (fun state => machineHeadBit (machineBinarySubY state)) ∈ + Complexity.FP := + machineCompose_mem_FP machineBinarySubY_mem_FP machineHeadBit_mem_FP + apply machineOrBit_mem_FP + Β· exact machineAndBit_mem_FP (machineNotBit_mem_FP hlhs) hrhs + Β· apply machineOrBit_mem_FP + Β· exact machineAndBit_mem_FP (machineNotBit_mem_FP hlhs) + machineBinarySubBorrow_mem_FP + Β· exact machineAndBit_mem_FP hrhs machineBinarySubBorrow_mem_FP + +theorem machineBinarySubAdvanced_mem_FP : + machineBinarySubAdvanced ∈ Complexity.FP := by + apply machineBinarySubPack_mem_FP + Β· exact machineCompose_mem_FP machineBinarySubX_mem_FP machineTail_mem_FP + Β· exact machineCompose_mem_FP machineBinarySubY_mem_FP machineTail_mem_FP + Β· exact machineBinarySubNextBorrow_mem_FP + Β· exact machineAppend_mem_FP machineBinarySubDiffBit_mem_FP + machineBinarySubAccRev_mem_FP + +theorem machineBinarySubStep_mem_FP : + machineBinarySubStep ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineBinarySubActive_mem_FP + machineBinarySubAdvanced_mem_FP id_mem_FP + +theorem machineBinarySubInit_mem_FP : + machineBinarySubInit ∈ Complexity.FP := by + exact machineBinarySubPack_mem_FP machinePairFirst_mem_FP + machinePairSecond_mem_FP (machineConst_mem_FP [false]) + (machineConst_mem_FP []) + +theorem machineBinarySubRuler_mem_FP : + machineBinarySubRuler ∈ Complexity.FP := by + exact machineAppend_mem_FP machinePairFirst_mem_FP machinePairSecond_mem_FP + +theorem machineBinarySubWidth_mem_FP : + machineBinarySubWidth ∈ Complexity.FP := by + let padded : List Bool β†’ List Bool := + fun word => List.replicate 8 false ++ word + have hpadded : padded ∈ Complexity.FP := + machineAppend_mem_FP (machineConst_mem_FP (List.replicate 8 false)) + id_mem_FP + simpa only [machineBinarySubWidth, padded] using! + Cobham.mulLenFn_mem_FP hpadded hpadded + +@[simp] theorem machineBinarySubX_pack (x y borrow accRev) : + machineBinarySubX (machineBinarySubPack x y borrow accRev) = x := by + simp [machineBinarySubX, machineBinarySubPack] + +@[simp] theorem machineBinarySubY_pack (x y borrow accRev) : + machineBinarySubY (machineBinarySubPack x y borrow accRev) = y := by + simp [machineBinarySubY, machineBinarySubPack] + +@[simp] theorem machineBinarySubBorrow_pack (x y borrow accRev) : + machineBinarySubBorrow (machineBinarySubPack x y borrow accRev) = + borrow := by + simp [machineBinarySubBorrow, machineBinarySubPack] + +@[simp] theorem machineBinarySubAccRev_pack (x y borrow accRev) : + machineBinarySubAccRev (machineBinarySubPack x y borrow accRev) = + accRev := by + simp [machineBinarySubAccRev, machineBinarySubPack] + +@[simp] theorem machineBinarySubStep_pack + (x y accRev : List Bool) (borrow : Bool) : + machineBinarySubStep (machineBinarySubPack x y [borrow] accRev) = + if x = [] ∧ y = [] then + machineBinarySubPack x y [borrow] accRev + else + machineBinarySubPack x.tail y.tail + [BinaryRippleSub.borrowBit borrow + (x.head?.getD false) (y.head?.getD false)] + (BinaryRippleSub.diffBit borrow + (x.head?.getD false) (y.head?.getD false) :: accRev) := by + cases x with + | nil => + cases y with + | nil => cases borrow <;> rfl + | cons y ys => + cases y <;> cases borrow <;> + simp [machineBinarySubStep, machineBinarySubActive, + machineBinarySubAdvanced, machineBinarySubDiffBit, + machineBinarySubNextBorrow, BinaryRippleSub.diffBit, + BinaryRippleSub.borrowBit, machineFullAdderSum, + machineXorBit, machineOrBit, machineAndBit, machineNotBit] + | cons x xs => + cases x <;> cases y with + | nil => + cases borrow <;> + simp [machineBinarySubStep, machineBinarySubActive, + machineBinarySubAdvanced, machineBinarySubDiffBit, + machineBinarySubNextBorrow, BinaryRippleSub.diffBit, + BinaryRippleSub.borrowBit, machineFullAdderSum, + machineXorBit, machineOrBit, machineAndBit, machineNotBit] + | cons y ys => + cases y <;> cases borrow <;> + simp [machineBinarySubStep, machineBinarySubActive, + machineBinarySubAdvanced, machineBinarySubDiffBit, + machineBinarySubNextBorrow, BinaryRippleSub.diffBit, + BinaryRippleSub.borrowBit, machineFullAdderSum, + machineXorBit, machineOrBit, machineAndBit, machineNotBit] + +theorem machineBinarySubStep_pack_length_le + (x y accRev : List Bool) (borrow : Bool) : + (machineBinarySubStep + (machineBinarySubPack x y [borrow] accRev)).length ≀ + (machineBinarySubPack x y [borrow] accRev).length + 1 := by + rw [machineBinarySubStep_pack] + split + Β· omega + Β· simp only [machineBinarySubPack, pair_length, List.length_cons, + List.length_tail] + omega + +/-- The subtraction state is a packed pair of operand words, a singleton borrow bit, and a +reversed accumulator. -/ +def MachineBinarySubWellFormed (state : List Bool) : Prop := + βˆƒ x y accRev : List Bool, βˆƒ borrow : Bool, + state = machineBinarySubPack x y [borrow] accRev + +theorem machineBinarySubInit_wellFormed (word : List Bool) : + MachineBinarySubWellFormed (machineBinarySubInit word) := by + exact ⟨machinePairFirst word, machinePairSecond word, [], false, rfl⟩ + +theorem machineBinarySubStep_wellFormed {state : List Bool} + (hstate : MachineBinarySubWellFormed state) : + MachineBinarySubWellFormed (machineBinarySubStep state) := by + obtain ⟨x, y, accRev, borrow, rfl⟩ := hstate + rw [machineBinarySubStep_pack] + split + Β· exact ⟨x, y, accRev, borrow, rfl⟩ + Β· exact ⟨x.tail, y.tail, + BinaryRippleSub.diffBit borrow (x.head?.getD false) + (y.head?.getD false) :: accRev, + BinaryRippleSub.borrowBit borrow (x.head?.getD false) + (y.head?.getD false), rfl⟩ + +theorem machineBinarySubIterate_wellFormed_length_le + {state : List Bool} (hstate : MachineBinarySubWellFormed state) : + βˆ€ iterations, + MachineBinarySubWellFormed (machineBinarySubStep^[iterations] state) ∧ + (machineBinarySubStep^[iterations] state).length ≀ + state.length + iterations := by + intro iterations + induction iterations with + | zero => simpa using! And.intro hstate (Nat.le_refl state.length) + | succ iterations ih => + rw [Function.iterate_succ_apply'] + obtain ⟨hwell, hlength⟩ := ih + have hnext := machineBinarySubStep_wellFormed hwell + obtain ⟨x, y, accRev, borrow, hrepr⟩ := hwell + have hstep := machineBinarySubStep_pack_length_le x y accRev borrow + rw [← hrepr] at hstep + exact ⟨hnext, by omega⟩ + +theorem machineBinarySubInit_length_le (word : List Bool) : + (machineBinarySubInit word).length ≀ 4 * word.length + 8 := by + simp only [machineBinarySubInit, machineBinarySubPack, pair_length, + List.length_cons, List.length_nil] + have hfirst := machinePairFirst_length_le word + have hsecond := machinePairSecond_length_le word + omega + +theorem machineBinarySubRuler_length_le (word : List Bool) : + (machineBinarySubRuler word).length ≀ 2 * word.length := by + simp only [machineBinarySubRuler, List.length_append] + have hfirst := machinePairFirst_length_le word + have hsecond := machinePairSecond_length_le word + omega + +@[simp] theorem machineBinarySubWidth_length (word : List Bool) : + (machineBinarySubWidth word).length = (word.length + 8) ^ 2 := by + simp [machineBinarySubWidth, pow_two] + +theorem machineBinarySubIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBinarySubRuler word).length) : + (machineBinarySubStep^[iterations] + (machineBinarySubInit word)).length ≀ + (machineBinarySubWidth word).length := by + have hrun := (machineBinarySubIterate_wellFormed_length_le + (machineBinarySubInit_wellFormed word) iterations).2 + have hinit := machineBinarySubInit_length_le word + have hruler := machineBinarySubRuler_length_le word + rw [machineBinarySubWidth_length] + nlinarith + +theorem machineBinarySubFinalState_mem_FP : + machineBinarySubFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBinarySubStep_mem_FP + machineBinarySubInit_mem_FP machineBinarySubRuler_mem_FP + machineBinarySubWidth_mem_FP machineBinarySubIterate_length_le_width + +theorem machineBinarySubBits_mem_FP : + machineBinarySubBits ∈ Complexity.FP := by + have hborrow : (fun word => machineBinarySubBorrow + (machineBinarySubFinalState word)) ∈ Complexity.FP := + machineCompose_mem_FP machineBinarySubFinalState_mem_FP + machineBinarySubBorrow_mem_FP + have hacc : (fun word => machineBinarySubAccRev + (machineBinarySubFinalState word)) ∈ Complexity.FP := + machineCompose_mem_FP machineBinarySubFinalState_mem_FP + machineBinarySubAccRev_mem_FP + have hrev := machineCompose_mem_FP hacc machineReverse_mem_FP + have htrim := machineCompose_mem_FP hrev machineTrimHighZeros_mem_FP + simpa only [machineBinarySubBits] using! machineIfHead_mem_FP hborrow + (machineConst_mem_FP []) htrim + +private theorem machineBinarySubStep_done (borrow : Bool) + (accRev : List Bool) : + machineBinarySubStep + (machineBinarySubPack [] [] [borrow] accRev) = + machineBinarySubPack [] [] [borrow] accRev := by + rw [machineBinarySubStep_pack] + simp + +private theorem machineBinarySubIterate_done (borrow : Bool) + (accRev : List Bool) (k : β„•) : + machineBinarySubStep^[k] + (machineBinarySubPack [] [] [borrow] accRev) = + machineBinarySubPack [] [] [borrow] accRev := by + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply, machineBinarySubStep_done, ih] + +private theorem machineBinarySubIterate_max + (x y accRev : List Bool) (borrow : Bool) : + machineBinarySubStep^[max x.length y.length] + (machineBinarySubPack x y [borrow] accRev) = + let raw := BinaryRippleSub.scan borrow x y + machineBinarySubPack [] [] [raw.borrow] + (raw.bits.reverse ++ accRev) := by + induction hmeasure : x.length + y.length using Nat.strongRecOn + generalizing x y borrow accRev with + | ind measure ih => + cases x with + | nil => + cases y with + | nil => + simp [BinaryRippleSub.scan] + | cons y ys => + simp only [List.length_nil, List.length_cons, Nat.zero_add] + at hmeasure + have hrec := ih ys.length (by omega) [] ys + (BinaryRippleSub.diffBit borrow false y :: accRev) + (BinaryRippleSub.borrowBit borrow false y) (by simp) + have hrec' := hrec + simp only [List.length_nil] at hrec' + simp only [List.length_nil, List.length_cons] + rw [show max 0 (ys.length + 1) = + (max 0 ys.length).succ by omega, + Function.iterate_succ_apply, machineBinarySubStep_pack] + simp only [List.nil_eq, List.cons_ne_nil, and_false, + ↓reduceIte, List.tail_nil, List.tail_cons, List.head?_nil, + Option.getD_none, List.head?_cons, Option.getD_some] + rw [hrec'] + simp [BinaryRippleSub.scan, List.reverse_cons, + List.append_assoc] + | cons x xs => + cases y with + | nil => + simp only [List.length_nil, List.length_cons, Nat.add_zero] + at hmeasure + have hrec := ih xs.length (by omega) xs [] + (BinaryRippleSub.diffBit borrow x false :: accRev) + (BinaryRippleSub.borrowBit borrow x false) (by simp) + have hrec' := hrec + simp only [List.length_nil] at hrec' + simp only [List.length_nil, List.length_cons] + rw [show max (xs.length + 1) 0 = + (max xs.length 0).succ by omega, + Function.iterate_succ_apply, machineBinarySubStep_pack] + simp only [List.cons_ne_nil, List.nil_eq, and_false, + ↓reduceIte, List.tail_cons, List.tail_nil, List.head?_cons, + Option.getD_some, List.head?_nil, Option.getD_none] + simp only [false_and, ite_false] + rw [hrec'] + simp [BinaryRippleSub.scan, List.reverse_cons, + List.append_assoc] + | cons y ys => + simp only [List.length_cons] at hmeasure + have hrec := ih (xs.length + ys.length) (by omega) xs ys + (BinaryRippleSub.diffBit borrow x y :: accRev) + (BinaryRippleSub.borrowBit borrow x y) rfl + simp only [List.length_cons] + rw [show max (xs.length + 1) (ys.length + 1) = + (max xs.length ys.length).succ by omega, + Function.iterate_succ_apply, machineBinarySubStep_pack] + simp only [List.cons_ne_nil, and_false, ↓reduceIte, + List.tail_cons, List.head?_cons, Option.getD_some] + rw [hrec] + simp [BinaryRippleSub.scan, List.reverse_cons, + List.append_assoc] + +/-- The machine agrees with the library's canonical ripple-borrow semantics +on arbitrary operand words. -/ +theorem machineBinarySubBits_pair_lists (x y : List Bool) : + machineBinarySubBits (pair x y) = BinaryRippleSub.subtract x y := by + simp only [machineBinarySubBits, machineBinarySubFinalState, + machineBinarySubRuler, machineBinarySubInit, machinePairFirst_pair, + machinePairSecond_pair, List.length_append] + rw [show x.length + y.length = + min x.length y.length + max x.length y.length by + have hminmax := min_add_max x.length y.length + exact hminmax.symm, + Function.iterate_add_apply, machineBinarySubIterate_max, + machineBinarySubIterate_done] + simp only [machineBinarySubBorrow_pack, machineBinarySubAccRev_pack] + let raw := BinaryRippleSub.scan false x y + change machineIfHead [raw.borrow] [] + (machineTrimHighZeros (raw.bits.reverse ++ []).reverse) = _ + simp only [List.append_nil, List.reverse_reverse] + rw [machineTrimHighZeros_eq] + cases hborrow : raw.borrow with + | false => + rw [machineIfHead_false] + simp [BinaryRippleSub.subtract, raw, hborrow] + | true => + rw [machineIfHead_true] + simp [BinaryRippleSub.subtract, raw, hborrow] + +theorem binaryRippleSub_scan_bits_length : + βˆ€ (borrow : Bool) (x y : List Bool), + (BinaryRippleSub.scan borrow x y).bits.length = + max x.length y.length := by + intro borrow x y + induction x generalizing borrow y with + | nil => + induction y generalizing borrow with + | nil => simp [BinaryRippleSub.scan] + | cons bit rest ih => + simp [BinaryRippleSub.scan, ih] + | cons bit rest ih => + cases y with + | nil => + simp [BinaryRippleSub.scan, ih] + | cons other tail => + simp [BinaryRippleSub.scan, ih] + +theorem binaryRippleSub_trimHighZeros_length_le : βˆ€ bits : List Bool, + (BinaryRippleSub.trimHighZeros bits).length ≀ bits.length := by + intro bits + induction bits with + | nil => rfl + | cons bit rest ih => + simp only [BinaryRippleSub.trimHighZeros] + cases htrim : BinaryRippleSub.trimHighZeros rest with + | nil => cases bit <;> simp + | cons high tail => + simp only [htrim, List.length_cons] at ih ⊒ + omega + +theorem binaryRippleSub_subtract_length_le (x y : List Bool) : + (BinaryRippleSub.subtract x y).length ≀ max x.length y.length := by + rw [BinaryRippleSub.subtract] + let raw := BinaryRippleSub.scan false x y + cases raw.borrow + Β· exact (binaryRippleSub_trimHighZeros_length_le raw.bits).trans_eq + (binaryRippleSub_scan_bits_length false x y) + Β· simp + +theorem machineBinarySubBits_pair_length_le (x y : List Bool) : + (machineBinarySubBits (pair x y)).length ≀ max x.length y.length := by + rw [machineBinarySubBits_pair_lists] + exact binaryRippleSub_subtract_length_le x y + +theorem machineBinarySubBits_pair_natBits (lhs rhs : β„•) : + machineBinarySubBits (pair lhs.bits rhs.bits) = (lhs - rhs).bits := by + rw [machineBinarySubBits_pair_lists, + BinaryRippleSub.subtract_natBits] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBitAssembly.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBitAssembly.lean new file mode 100644 index 0000000000..e4f1e79048 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBitAssembly.lean @@ -0,0 +1,332 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineRAMBridge + +/-! +# Assembling a polynomial number of queried output bits + +This file turns any one-bit `FP` query routine into a full output routine. At +iteration `k`, the state stores `k.bits`, the first `k` queried bits, and the +unchanged original input. A verified binary addition increments the counter. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Query bit `k`, represented by the canonical paired input +`pair k.bits word`. Truncating to `machineHeadBit` guarantees one output bit +even on malformed inputs or for a total query function with arbitrary output. -/ +def machineQueriedBit (query : List Bool β†’ List Bool) + (counter word : List Bool) : List Bool := + machineHeadBit (query (pair counter word)) + +/-- Package the binary query counter, accumulated output bits, and immutable input word. -/ +def machineBitAssemblyPack + (counter acc word : List Bool) : List Bool := + pair counter (pair acc word) + +/-- Extract the binary query-position counter from the assembly state. -/ +def machineBitAssemblyCounter (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the output bits already assembled. -/ +def machineBitAssemblyAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the immutable input supplied to each output-bit query. -/ +def machineBitAssemblyInput (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Increment the assembly state's binary query counter by one. -/ +def machineBitAssemblyNextCounter (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineBitAssemblyCounter state) [true]) + +/-- Append the queried output bit at the current counter, increment the counter, and retain the +original input. -/ +def machineBitAssemblyStep (query : List Bool β†’ List Bool) + (state : List Bool) : List Bool := + machineBitAssemblyPack + (machineBitAssemblyNextCounter state) + (machineBitAssemblyAcc state ++ + machineQueriedBit query (machineBitAssemblyCounter state) + (machineBitAssemblyInput state)) + (machineBitAssemblyInput state) + +/-- Initialize bit assembly at counter zero with an empty output accumulator. -/ +def machineBitAssemblyInit (word : List Bool) : List Bool := + machineBitAssemblyPack [] [] word + +/-- A state with two ruler-sized fields is an exact length envelope for every +semantic assembly state before the ruler is exhausted. -/ +def machineBitAssemblyWidth (ruler : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineBitAssemblyPack (ruler word) (ruler word) word + +/-- Run bit assembly for the number of positions specified by the ruler's length. -/ +def machineBitAssemblyFinalState + (query ruler : List Bool β†’ List Bool) (word : List Bool) : List Bool := + (machineBitAssemblyStep query)^[(ruler word).length] + (machineBitAssemblyInit word) + +/-- Return the accumulated output bits after all ruler-bounded queries. -/ +def machineAssembleBits + (query ruler : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineBitAssemblyAcc (machineBitAssemblyFinalState query ruler word) + +theorem machineBitAssemblyCounter_mem_FP : + machineBitAssemblyCounter ∈ Complexity.FP := by + simpa only [machineBitAssemblyCounter] using! machinePairFirst_mem_FP + +theorem machineBitAssemblyAcc_mem_FP : + machineBitAssemblyAcc ∈ Complexity.FP := by + simpa only [machineBitAssemblyAcc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineBitAssemblyInput_mem_FP : + machineBitAssemblyInput ∈ Complexity.FP := by + simpa only [machineBitAssemblyInput] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineQueriedBit_mem_FP + {query counter word : List Bool β†’ List Bool} + (hquery : query ∈ Complexity.FP) + (hcounter : counter ∈ Complexity.FP) + (hword : word ∈ Complexity.FP) : + (fun input => machineQueriedBit query (counter input) (word input)) ∈ + Complexity.FP := by + have hpayload : + (fun input => pair (counter input) (word input)) ∈ Complexity.FP := + machinePair_mem_FP hcounter hword + exact machineCompose_mem_FP + (machineCompose_mem_FP hpayload hquery) machineHeadBit_mem_FP + +theorem machineBitAssemblyNextCounter_mem_FP : + machineBitAssemblyNextCounter ∈ Complexity.FP := by + have hpayload : + (fun state => pair (machineBitAssemblyCounter state) [true]) ∈ + Complexity.FP := + machinePair_mem_FP machineBitAssemblyCounter_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineBitAssemblyNextCounter] using! + machineCompose_mem_FP hpayload machineBinaryAddBits_mem_FP + +theorem machineBitAssemblyStep_mem_FP + {query : List Bool β†’ List Bool} (hquery : query ∈ Complexity.FP) : + machineBitAssemblyStep query ∈ Complexity.FP := by + have hbit : + (fun state => machineQueriedBit query + (machineBitAssemblyCounter state) + (machineBitAssemblyInput state)) ∈ Complexity.FP := + machineQueriedBit_mem_FP hquery machineBitAssemblyCounter_mem_FP + machineBitAssemblyInput_mem_FP + have hacc : + (fun state => machineBitAssemblyAcc state ++ + machineQueriedBit query (machineBitAssemblyCounter state) + (machineBitAssemblyInput state)) ∈ Complexity.FP := + machineAppend_mem_FP machineBitAssemblyAcc_mem_FP hbit + exact machinePair_mem_FP machineBitAssemblyNextCounter_mem_FP + (machinePair_mem_FP hacc machineBitAssemblyInput_mem_FP) + +theorem machineBitAssemblyInit_mem_FP : + machineBitAssemblyInit ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP) + +theorem machineBitAssemblyWidth_mem_FP + {ruler : List Bool β†’ List Bool} (hruler : ruler ∈ Complexity.FP) : + machineBitAssemblyWidth ruler ∈ Complexity.FP := by + exact machinePair_mem_FP hruler (machinePair_mem_FP hruler id_mem_FP) + +@[simp] theorem machineBitAssemblyCounter_pack (counter acc word) : + machineBitAssemblyCounter (machineBitAssemblyPack counter acc word) = + counter := by + simp [machineBitAssemblyCounter, machineBitAssemblyPack] + +@[simp] theorem machineBitAssemblyAcc_pack (counter acc word) : + machineBitAssemblyAcc (machineBitAssemblyPack counter acc word) = acc := by + simp [machineBitAssemblyAcc, machineBitAssemblyPack] + +@[simp] theorem machineBitAssemblyInput_pack (counter acc word) : + machineBitAssemblyInput (machineBitAssemblyPack counter acc word) = word := by + simp [machineBitAssemblyInput, machineBitAssemblyPack] + +/-- The semantic list of the first `iterations` queried bits. -/ +def assembledQueryBits (query : List Bool β†’ List Bool) + (word : List Bool) : β„• β†’ List Bool + | 0 => [] + | k + 1 => assembledQueryBits query word k ++ + machineHeadBit (query (pair k.bits word)) + +@[simp] theorem assembledQueryBits_length + (query : List Bool β†’ List Bool) (word : List Bool) : + βˆ€ k, (assembledQueryBits query word k).length = k := by + intro k + induction k with + | zero => rfl + | succ k ih => + simp [assembledQueryBits, ih] + +theorem natBits_length_le_self (k : β„•) : k.bits.length ≀ k := by + rw [Nat.size_eq_bits_len] + exact Nat.size_le.mpr k.lt_two_pow_self + +@[simp] theorem machineBitAssemblyStep_semantics + (query : List Bool β†’ List Bool) (word : List Bool) (k : β„•) : + machineBitAssemblyStep query + (machineBitAssemblyPack k.bits + (assembledQueryBits query word k) word) = + machineBitAssemblyPack (k + 1).bits + (assembledQueryBits query word (k + 1)) word := by + simp only [machineBitAssemblyStep, machineBitAssemblyNextCounter, + machineBitAssemblyCounter_pack, machineBitAssemblyAcc_pack, + machineQueriedBit, machineBitAssemblyInput_pack, assembledQueryBits] + rw [show ([true] : List Bool) = (1 : β„•).bits by decide, + machineBinaryAddBits_pair_natBits] + +theorem machineBitAssemblyIterate_semantics + (query : List Bool β†’ List Bool) (word : List Bool) : + βˆ€ k, + (machineBitAssemblyStep query)^[k] (machineBitAssemblyInit word) = + machineBitAssemblyPack k.bits + (assembledQueryBits query word k) word := by + intro k + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih, + machineBitAssemblyStep_semantics] + +theorem machineBitAssemblyIterate_length_le_width + (query ruler : List Bool β†’ List Bool) (word : List Bool) + (iterations : β„•) (hiterations : iterations ≀ (ruler word).length) : + ((machineBitAssemblyStep query)^[iterations] + (machineBitAssemblyInit word)).length ≀ + (machineBitAssemblyWidth ruler word).length := by + rw [machineBitAssemblyIterate_semantics] + simp only [machineBitAssemblyPack, pair_length] + have hcounter := natBits_length_le_self iterations + have hacc := assembledQueryBits_length query word iterations + simp only [machineBitAssemblyWidth, machineBitAssemblyPack, pair_length] + omega + +theorem machineBitAssemblyFinalState_mem_FP + {query ruler : List Bool β†’ List Bool} + (hquery : query ∈ Complexity.FP) (hruler : ruler ∈ Complexity.FP) : + machineBitAssemblyFinalState query ruler ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP (machineBitAssemblyStep_mem_FP hquery) + machineBitAssemblyInit_mem_FP hruler + (machineBitAssemblyWidth_mem_FP hruler) + (machineBitAssemblyIterate_length_le_width query ruler) + +theorem machineAssembleBits_mem_FP + {query ruler : List Bool β†’ List Bool} + (hquery : query ∈ Complexity.FP) (hruler : ruler ∈ Complexity.FP) : + machineAssembleBits query ruler ∈ Complexity.FP := by + simpa only [machineAssembleBits] using! + machineCompose_mem_FP + (machineBitAssemblyFinalState_mem_FP hquery hruler) + machineBitAssemblyAcc_mem_FP + +theorem machineAssembleBits_eq + (query ruler : List Bool β†’ List Bool) (word : List Bool) : + machineAssembleBits query ruler word = + assembledQueryBits query word (ruler word).length := by + simp [machineAssembleBits, machineBitAssemblyFinalState, + machineBitAssemblyIterate_semantics] + +theorem assembledQueryBits_eq_take + (query target : List Bool β†’ List Bool) + (hquery : βˆ€ word k, k < (target word).length β†’ + query (pair k.bits word) = [(target word)[k]?.getD false]) : + βˆ€ word k, k ≀ (target word).length β†’ + assembledQueryBits query word k = (target word).take k := by + intro word k hk + induction k with + | zero => rfl + | succ k ih => + have hklt : k < (target word).length := by omega + rw [assembledQueryBits, ih (by omega), hquery word k hklt] + simp only [machineHeadBit_cons] + rw [List.getElem?_eq_getElem hklt] + simp only [Option.getD_some] + exact (List.take_succ_eq_append_getElem hklt).symm + +/-- Exact bit queries assembled for exactly the target length reproduce the +target word, including internal and trailing zero bits. -/ +theorem machineAssembleBits_realizes + (query ruler target : List Bool β†’ List Bool) + (hruler : βˆ€ word, (ruler word).length = (target word).length) + (hquery : βˆ€ word k, k < (target word).length β†’ + query (pair k.bits word) = [(target word)[k]?.getD false]) : + machineAssembleBits query ruler = target := by + funext word + rw [machineAssembleBits_eq, hruler, + assembledQueryBits_eq_take query target hquery word + (target word).length le_rfl, + List.take_length] + +/-- The bit graph of a total string function, expressed using canonical +pairing and little-endian natural indices. -/ +def outputBitLanguage (target : List Bool β†’ List Bool) : Language := + {payload | (target (machinePairSecond payload))[ + Nat.fromBitsLE (machinePairFirst payload)]?.getD false = true} + +instance outputBitLanguage_decidable (target : List Bool β†’ List Bool) : + DecidablePred (fun word => word ∈ outputBitLanguage target) := by + intro word + change Decidable + ((target (machinePairSecond word))[ + Nat.fromBitsLE (machinePairFirst word)]?.getD false = true) + infer_instance + +theorem outputBitLanguage_flag_pair_all + (target : List Bool β†’ List Bool) (word : List Bool) (k : β„•) : + MachineRAMBridge.languageFlag (outputBitLanguage target) + (pair k.bits word) = [(target word)[k]?.getD false] := by + simp only [MachineRAMBridge.languageFlag, outputBitLanguage, + machinePairFirst_pair, machinePairSecond_pair, Nat.fromBitsLE_bits, + Set.mem_setOf_eq] + cases hbit : (target word)[k]? with + | none => simp [hbit] + | some bit => cases bit <;> simp [hbit] + +theorem outputBitLanguage_flag_pair + (target : List Bool β†’ List Bool) (word : List Bool) (k : β„•) + (_hk : k < (target word).length) : + MachineRAMBridge.languageFlag (outputBitLanguage target) + (pair k.bits word) = [(target word)[k]?.getD false] := + outputBitLanguage_flag_pair_all target word k + +/-- A polynomial-time RAM decider for the bit graph, together with an `FP` +ruler of the exact output length, yields an unconditional `FP` implementation +of the whole string function. -/ +theorem target_mem_FP_of_ramBitProgram + (target ruler : List Bool β†’ List Bool) + (program : RAM.Program) (p : Polynomial β„•) + (hdecides : program.DecidesInTime (outputBitLanguage target) p.eval) + (hrulerFP : ruler ∈ Complexity.FP) + (hrulerLength : βˆ€ word, + (ruler word).length = (target word).length) : + target ∈ Complexity.FP := by + let query := MachineRAMBridge.languageFlag (outputBitLanguage target) + have hqueryFP : query ∈ Complexity.FP := + MachineRAMBridge.languageFlag_mem_FP_of_ramProgram program p hdecides + have hassembly : machineAssembleBits query ruler ∈ Complexity.FP := + machineAssembleBits_mem_FP hqueryFP hrulerFP + have heq : machineAssembleBits query ruler = target := + machineAssembleBits_realizes query ruler target hrulerLength + (outputBitLanguage_flag_pair target) + rwa [heq] at hassembly + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBool.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBool.lean new file mode 100644 index 0000000000..2d7f058a17 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBool.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics + +/-! +# Verified one-bit machine logic + +Boolean values are represented by the one-bit words `[false]` and `[true]`. +The definitions remain total on arbitrary bitstrings by inspecting only the +leading bit through the verified selector machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Negate the input word's head bit and return its singleton encoding. -/ +def machineNotBit (a : List Bool) : List Bool := + machineIfHead a [false] [true] + +/-- Negate the second bit word when the first head is true; otherwise return the second word +unchanged. -/ +def machineXorBit (a b : List Bool) : List Bool := + machineIfHead a (machineNotBit b) b + +/-- Return the second bit word when the first head is true, and a false singleton otherwise. -/ +def machineAndBit (a b : List Bool) : List Bool := + machineIfHead a b [false] + +/-- Return a true singleton when the first head is true, and the second bit word otherwise. -/ +def machineOrBit (a b : List Bool) : List Bool := + machineIfHead a [true] b + +/-- The majority operation on three encoded bits, expressed through pairwise conjunctions. -/ +def machineMajorityBit (a b c : List Bool) : List Bool := + machineOrBit (machineAndBit a b) + (machineOrBit (machineAndBit a c) (machineAndBit b c)) + +/-- The full-adder sum bit, given by XOR of both input bits and the incoming carry. -/ +def machineFullAdderSum (a b carry : List Bool) : List Bool := + machineXorBit (machineXorBit a b) carry + +/-- The full-adder carry bit, given by the majority of both input bits and the incoming carry. -/ +def machineFullAdderCarry (a b carry : List Bool) : List Bool := + machineMajorityBit a b carry + +theorem machineNotBit_mem_FP {a : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) : + (fun word => machineNotBit (a word)) ∈ Complexity.FP := by + exact machineIfHead_mem_FP ha (machineConst_mem_FP [false]) + (machineConst_mem_FP [true]) + +theorem machineXorBit_mem_FP + {a b : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) : + (fun word => machineXorBit (a word) (b word)) ∈ Complexity.FP := by + exact machineIfHead_mem_FP ha (machineNotBit_mem_FP hb) hb + +theorem machineAndBit_mem_FP + {a b : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) : + (fun word => machineAndBit (a word) (b word)) ∈ Complexity.FP := by + exact machineIfHead_mem_FP ha hb (machineConst_mem_FP [false]) + +theorem machineOrBit_mem_FP + {a b : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) : + (fun word => machineOrBit (a word) (b word)) ∈ Complexity.FP := by + exact machineIfHead_mem_FP ha (machineConst_mem_FP [true]) hb + +theorem machineMajorityBit_mem_FP + {a b c : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) + (hc : c ∈ Complexity.FP) : + (fun word => machineMajorityBit (a word) (b word) (c word)) ∈ + Complexity.FP := by + apply machineOrBit_mem_FP + Β· exact machineAndBit_mem_FP ha hb + Β· apply machineOrBit_mem_FP + Β· exact machineAndBit_mem_FP ha hc + Β· exact machineAndBit_mem_FP hb hc + +theorem machineFullAdderSum_mem_FP + {a b carry : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) + (hcarry : carry ∈ Complexity.FP) : + (fun word => machineFullAdderSum (a word) (b word) (carry word)) ∈ + Complexity.FP := by + exact machineXorBit_mem_FP (machineXorBit_mem_FP ha hb) hcarry + +theorem machineFullAdderCarry_mem_FP + {a b carry : List Bool β†’ List Bool} + (ha : a ∈ Complexity.FP) (hb : b ∈ Complexity.FP) + (hcarry : carry ∈ Complexity.FP) : + (fun word => machineFullAdderCarry (a word) (b word) (carry word)) ∈ + Complexity.FP := by + exact machineMajorityBit_mem_FP ha hb hcarry + +@[simp] theorem machineNotBit_one (a : Bool) : + machineNotBit [a] = [!a] := by + cases a <;> rfl + +@[simp] theorem machineXorBit_one (a b : Bool) : + machineXorBit [a] [b] = [xor a b] := by + cases a <;> cases b <;> rfl + +@[simp] theorem machineAndBit_one (a b : Bool) : + machineAndBit [a] [b] = [a && b] := by + cases a <;> cases b <;> rfl + +@[simp] theorem machineOrBit_one (a b : Bool) : + machineOrBit [a] [b] = [a || b] := by + cases a <;> cases b <;> rfl + +@[simp] theorem machineFullAdderSum_one (a b carry : Bool) : + machineFullAdderSum [a] [b] [carry] = [xor (xor a b) carry] := by + simp [machineFullAdderSum] + +@[simp] theorem machineFullAdderCarry_one (a b carry : Bool) : + machineFullAdderCarry [a] [b] [carry] = + [(a && b) || (a && carry) || (b && carry)] := by + cases a <;> cases b <;> cases carry <;> rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanInit.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanInit.lean new file mode 100644 index 0000000000..cc183e516a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanInit.lean @@ -0,0 +1,427 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanMemory + +/-! +# Polynomially bounded Boolean storage initialization + +The matching machine needs all-false vectors and square Boolean matrices. +Both constructors use unary dimension rulers. Their state is clamped by a +quadratic word computed from the original input; the exact semantic bounds +show that this clamp is inactive on canonical dimension rulers. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## False vectors -/ + +/-- Prepend one encoded false entry to a Boolean-vector code. -/ +def machineFalseVectorStep (acc : List Bool) : List Bool := + pair [false] acc + +/-- Use the binary-multiplication width ruler to bound the false-vector construction. -/ +def machineFalseVectorWidth (ruler : List Bool) : List Bool := + machineBinaryMulWidth ruler + +/-- Build a Boolean-vector code containing as many false entries as the ruler has bits. -/ +def machineFalseVectorCode (ruler : List Bool) : List Bool := + (machineFalseVectorStep)^[ruler.length] [] + +theorem machineFalseVectorStep_mem_FP : + machineFalseVectorStep ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP + +theorem machineFalseVectorWidth_mem_FP : + machineFalseVectorWidth ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineFalseVectorIterate_semantics : βˆ€ k, + (machineFalseVectorStep)^[k] [] = + boolVectorCode (List.replicate k false) := by + intro k + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineFalseVectorStep, boolVectorCode, binaryListCode, + boolElementCode, List.replicate_succ] + +theorem machineFalseVectorIterate_length_le_width + (ruler : List Bool) (iterations : β„•) + (hiterations : iterations ≀ ruler.length) : + ((machineFalseVectorStep)^[iterations] []).length ≀ + (machineFalseVectorWidth ruler).length := by + rw [machineFalseVectorIterate_semantics] + simp only [boolVectorCode, binaryListCode_length_eq_sum, + List.map_replicate, List.sum_replicate, boolElementCode, + List.length_singleton, machineFalseVectorWidth, + machineBinaryMulWidth, List.length_replicate, List.length_append, + Nat.nsmul_eq_mul] + nlinarith + +theorem machineFalseVectorCode_mem_FP : + machineFalseVectorCode ∈ Complexity.FP := by + simpa only [machineFalseVectorCode] using! + Cobham.iterate_mem_FP machineFalseVectorStep_mem_FP + (machineConst_mem_FP []) id_mem_FP machineFalseVectorWidth_mem_FP + machineFalseVectorIterate_length_le_width + +@[simp] theorem machineFalseVectorCode_encode (n : β„•) : + machineFalseVectorCode (List.replicate n true) = + boolVectorCode (List.replicate n false) := by + rw [machineFalseVectorCode, List.length_replicate, + machineFalseVectorIterate_semantics] + +/-! ## Repeated-row matrices -/ + +/-- Extract the row-count ruler from a repeated-row matrix request. -/ +def machineRepeatedRowMatrixRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the encoded row to repeat. -/ +def machineRepeatedRowMatrixRow (word : List Bool) : List Bool := + machinePairSecond word + +/-- The binary-multiplication width ruler used to cap the repeated-row matrix accumulator. -/ +def machineRepeatedRowMatrixBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Package the repeated row, encoded matrix accumulator, and accumulator-length ruler. -/ +def machineRepeatedRowMatrixPack + (row acc bound : List Bool) : List Bool := + pair row (pair acc bound) + +/-- Extract the immutable row code from a matrix-construction state. -/ +def machineRepeatedRowMatrixStateRow (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the encoded matrix rows accumulated so far. -/ +def machineRepeatedRowMatrixStateAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the word whose length bounds the matrix accumulator. -/ +def machineRepeatedRowMatrixStateBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Prepend one copy of the stored row to the matrix accumulator before truncation. -/ +def machineRepeatedRowMatrixCandidate (state : List Bool) : List Bool := + pair (machineRepeatedRowMatrixStateRow state) + (machineRepeatedRowMatrixStateAcc state) + +/-- Truncate the candidate matrix code to the stored bound word's length. -/ +def machineRepeatedRowMatrixNextAcc (state : List Bool) : List Bool := + (machineRepeatedRowMatrixCandidate state).take + (machineRepeatedRowMatrixStateBound state).length + +/-- Replace the matrix accumulator by its bounded row-prepending update, preserving the row and +bound. -/ +def machineRepeatedRowMatrixStep (state : List Bool) : List Bool := + machineRepeatedRowMatrixPack (machineRepeatedRowMatrixStateRow state) + (machineRepeatedRowMatrixNextAcc state) + (machineRepeatedRowMatrixStateBound state) + +/-- Initialize repeated-row construction with an empty matrix and its computed width bound. -/ +def machineRepeatedRowMatrixInit (word : List Bool) : List Bool := + machineRepeatedRowMatrixPack (machineRepeatedRowMatrixRow word) [] + (machineRepeatedRowMatrixBound word) + +/-- A state-width envelope formed by packing three copies of the matrix accumulator bound. -/ +def machineRepeatedRowMatrixWidth (word : List Bool) : List Bool := + machineRepeatedRowMatrixPack (machineRepeatedRowMatrixBound word) + (machineRepeatedRowMatrixBound word) + (machineRepeatedRowMatrixBound word) + +/-- Repeat the bounded row-prepending step for the length of the row-count ruler. -/ +def machineRepeatedRowMatrixFinalState (word : List Bool) : List Bool := + (machineRepeatedRowMatrixStep)^[(machineRepeatedRowMatrixRuler word).length] + (machineRepeatedRowMatrixInit word) + +/-- Return the encoded matrix accumulator after the requested bounded row repetitions. -/ +def machineRepeatedRowMatrixCode (word : List Bool) : List Bool := + machineRepeatedRowMatrixStateAcc + (machineRepeatedRowMatrixFinalState word) + +theorem machineRepeatedRowMatrixRuler_mem_FP : + machineRepeatedRowMatrixRuler ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRepeatedRowMatrixRow_mem_FP : + machineRepeatedRowMatrixRow ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineRepeatedRowMatrixBound_mem_FP : + machineRepeatedRowMatrixBound ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineRepeatedRowMatrixStateRow_mem_FP : + machineRepeatedRowMatrixStateRow ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRepeatedRowMatrixStateAcc_mem_FP : + machineRepeatedRowMatrixStateAcc ∈ Complexity.FP := by + simpa only [machineRepeatedRowMatrixStateAcc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRepeatedRowMatrixStateBound_mem_FP : + machineRepeatedRowMatrixStateBound ∈ Complexity.FP := by + simpa only [machineRepeatedRowMatrixStateBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRepeatedRowMatrixCandidate_mem_FP : + machineRepeatedRowMatrixCandidate ∈ Complexity.FP := by + exact machinePair_mem_FP machineRepeatedRowMatrixStateRow_mem_FP + machineRepeatedRowMatrixStateAcc_mem_FP + +theorem machineRepeatedRowMatrixNextAcc_mem_FP : + machineRepeatedRowMatrixNextAcc ∈ Complexity.FP := by + simpa only [machineRepeatedRowMatrixNextAcc] using! + machineTake_mem_FP machineRepeatedRowMatrixStateBound_mem_FP + machineRepeatedRowMatrixCandidate_mem_FP + +theorem machineRepeatedRowMatrixStep_mem_FP : + machineRepeatedRowMatrixStep ∈ Complexity.FP := by + exact machinePair_mem_FP machineRepeatedRowMatrixStateRow_mem_FP + (machinePair_mem_FP machineRepeatedRowMatrixNextAcc_mem_FP + machineRepeatedRowMatrixStateBound_mem_FP) + +theorem machineRepeatedRowMatrixInit_mem_FP : + machineRepeatedRowMatrixInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineRepeatedRowMatrixRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + machineRepeatedRowMatrixBound_mem_FP) + +theorem machineRepeatedRowMatrixWidth_mem_FP : + machineRepeatedRowMatrixWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineRepeatedRowMatrixBound_mem_FP + (machinePair_mem_FP machineRepeatedRowMatrixBound_mem_FP + machineRepeatedRowMatrixBound_mem_FP) + +@[simp] theorem machineRepeatedRowMatrixStateRow_pack (a b c) : + machineRepeatedRowMatrixStateRow + (machineRepeatedRowMatrixPack a b c) = a := by + simp [machineRepeatedRowMatrixStateRow, machineRepeatedRowMatrixPack] + +@[simp] theorem machineRepeatedRowMatrixStateAcc_pack (a b c) : + machineRepeatedRowMatrixStateAcc + (machineRepeatedRowMatrixPack a b c) = b := by + simp [machineRepeatedRowMatrixStateAcc, machineRepeatedRowMatrixPack] + +@[simp] theorem machineRepeatedRowMatrixStateBound_pack (a b c) : + machineRepeatedRowMatrixStateBound + (machineRepeatedRowMatrixPack a b c) = c := by + simp [machineRepeatedRowMatrixStateBound, machineRepeatedRowMatrixPack] + +/-- The state has the expected row, accumulator, and bound layout, with every field bounded by +the computed ruler length. -/ +def MachineRepeatedRowMatrixStateBound + (word state : List Bool) : Prop := + let B := (machineRepeatedRowMatrixBound word).length + state = machineRepeatedRowMatrixPack + (machineRepeatedRowMatrixStateRow state) + (machineRepeatedRowMatrixStateAcc state) + (machineRepeatedRowMatrixStateBound state) ∧ + (machineRepeatedRowMatrixStateRow state).length ≀ B ∧ + (machineRepeatedRowMatrixStateAcc state).length ≀ B ∧ + (machineRepeatedRowMatrixStateBound state).length ≀ B + +theorem machineRepeatedRowMatrix_word_length_le_bound (word : List Bool) : + word.length ≀ (machineRepeatedRowMatrixBound word).length := by + simp only [machineRepeatedRowMatrixBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineRepeatedRowMatrixInit_bound (word : List Bool) : + MachineRepeatedRowMatrixStateBound word + (machineRepeatedRowMatrixInit word) := by + simp only [MachineRepeatedRowMatrixStateBound, + machineRepeatedRowMatrixInit, + machineRepeatedRowMatrixStateRow_pack, + machineRepeatedRowMatrixStateAcc_pack, + machineRepeatedRowMatrixStateBound_pack] + refine ⟨trivial, ?_, by simp, le_rfl⟩ + exact (machinePairSecond_length_le word).trans + (machineRepeatedRowMatrix_word_length_le_bound word) + +theorem machineRepeatedRowMatrixStep_bound + {word state : List Bool} + (hstate : MachineRepeatedRowMatrixStateBound word state) : + MachineRepeatedRowMatrixStateBound word + (machineRepeatedRowMatrixStep state) := by + dsimp only [MachineRepeatedRowMatrixStateBound] at hstate ⊒ + rcases hstate with ⟨_, hrow, _hacc, hbound⟩ + simp only [machineRepeatedRowMatrixStep, + machineRepeatedRowMatrixStateRow_pack, + machineRepeatedRowMatrixStateAcc_pack, + machineRepeatedRowMatrixStateBound_pack] + refine ⟨trivial, hrow, ?_, hbound⟩ + exact (List.length_take_le _ _).trans hbound + +theorem machineRepeatedRowMatrixIterate_bound (word : List Bool) : βˆ€ k, + MachineRepeatedRowMatrixStateBound word + ((machineRepeatedRowMatrixStep)^[k] + (machineRepeatedRowMatrixInit word)) := by + intro k + induction k with + | zero => exact machineRepeatedRowMatrixInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRepeatedRowMatrixStep_bound ih + +theorem machineRepeatedRowMatrixIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineRepeatedRowMatrixRuler word).length) : + ((machineRepeatedRowMatrixStep)^[iterations] + (machineRepeatedRowMatrixInit word)).length ≀ + (machineRepeatedRowMatrixWidth word).length := by + rcases machineRepeatedRowMatrixIterate_bound word iterations with + ⟨hdecomp, hrow, hacc, hbound⟩ + rw [hdecomp] + simp only [machineRepeatedRowMatrixPack, + machineRepeatedRowMatrixWidth, pair_length] + omega + +theorem machineRepeatedRowMatrixFinalState_mem_FP : + machineRepeatedRowMatrixFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineRepeatedRowMatrixStep_mem_FP + machineRepeatedRowMatrixInit_mem_FP + machineRepeatedRowMatrixRuler_mem_FP + machineRepeatedRowMatrixWidth_mem_FP + machineRepeatedRowMatrixIterate_length_le_width + +theorem machineRepeatedRowMatrixCode_mem_FP : + machineRepeatedRowMatrixCode ∈ Complexity.FP := by + simpa only [machineRepeatedRowMatrixCode] using! + machineCompose_mem_FP machineRepeatedRowMatrixFinalState_mem_FP + machineRepeatedRowMatrixStateAcc_mem_FP + +/-! ## Exact all-false square matrices -/ + +/-- Request an all-false square matrix using a unary row count and an encoded false row of the +same length. -/ +def machineFalseSquareBuilderInput (n : β„•) : List Bool := + pair (List.replicate n true) + (boolVectorCode (List.replicate n false)) + +/-- The canonical builder state containing `k` all-false rows of length `n`, with the original +square request's bound. -/ +def machineFalseSquareBuilderState (n k : β„•) : List Bool := + let word := machineFalseSquareBuilderInput n + let row := List.replicate n false + machineRepeatedRowMatrixPack (boolVectorCode row) + (boolMatrixCode (List.replicate k row)) + (machineRepeatedRowMatrixBound word) + +theorem machineFalseSquareBuilderInit_semantics (n : β„•) : + machineRepeatedRowMatrixInit (machineFalseSquareBuilderInput n) = + machineFalseSquareBuilderState n 0 := by + simp [machineRepeatedRowMatrixInit, machineFalseSquareBuilderInput, + machineFalseSquareBuilderState, machineRepeatedRowMatrixRow, + boolMatrixCode, binaryListCode] + +theorem machineFalseSquareBuilderStep_semantics + (n k : β„•) (hk : k < n) : + machineRepeatedRowMatrixStep (machineFalseSquareBuilderState n k) = + machineFalseSquareBuilderState n (k + 1) := by + let word := machineFalseSquareBuilderInput n + let row := List.replicate n false + have hrowLength : (boolVectorCode row).length = 4 * n := by + simp [boolVectorCode, binaryListCode_length_eq_sum, row, + boolElementCode, Nat.nsmul_eq_mul] + omega + have hmatrixLength : + (boolMatrixCode (List.replicate (k + 1) row)).length = + (k + 1) * (2 * (boolVectorCode row).length + 2) := by + simp [boolMatrixCode, binaryListCode_length_eq_sum, + Nat.nsmul_eq_mul] + have hbound : + (boolMatrixCode (List.replicate (k + 1) row)).length ≀ + (machineRepeatedRowMatrixBound word).length := by + rw [hmatrixLength, hrowLength] + simp only [machineRepeatedRowMatrixBound, machineBinaryMulWidth, + word, machineFalseSquareBuilderInput, pair_length, + List.length_replicate, List.length_append] + have hrowCode : + (boolVectorCode (List.replicate n false)).length = 4 * n := by + simpa only [row] using! hrowLength + rw [hrowCode] + nlinarith + have htake : + (boolMatrixCode (List.replicate (k + 1) row)).take + (machineRepeatedRowMatrixBound word).length = + boolMatrixCode (List.replicate (k + 1) row) := + List.take_of_length_le hbound + simp only [machineRepeatedRowMatrixStep, + machineFalseSquareBuilderState, + machineRepeatedRowMatrixStateRow_pack, + machineRepeatedRowMatrixStateAcc_pack, + machineRepeatedRowMatrixStateBound_pack, + machineRepeatedRowMatrixNextAcc, + machineRepeatedRowMatrixCandidate] + change machineRepeatedRowMatrixPack (boolVectorCode row) + ((boolMatrixCode (List.replicate (k + 1) row)).take + (machineRepeatedRowMatrixBound word).length) + (machineRepeatedRowMatrixBound word) = _ + rw [htake] + +theorem machineFalseSquareBuilderIterate_semantics (n : β„•) : βˆ€ k ≀ n, + (machineRepeatedRowMatrixStep)^[k] + (machineRepeatedRowMatrixInit (machineFalseSquareBuilderInput n)) = + machineFalseSquareBuilderState n k := by + intro k hk + induction k with + | zero => exact machineFalseSquareBuilderInit_semantics n + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineFalseSquareBuilderStep_semantics n k (by omega) + +@[simp] theorem machineRepeatedRowMatrixCode_falseSquare (n : β„•) : + machineRepeatedRowMatrixCode (machineFalseSquareBuilderInput n) = + boolMatrixCode + (List.replicate n (List.replicate n false)) := by + rw [machineRepeatedRowMatrixCode, machineRepeatedRowMatrixFinalState] + simp only [machineRepeatedRowMatrixRuler, + machineFalseSquareBuilderInput, machinePairFirst_pair, + List.length_replicate] + change machineRepeatedRowMatrixStateAcc + ((machineRepeatedRowMatrixStep)^[n] + (machineRepeatedRowMatrixInit + (machineFalseSquareBuilderInput n))) = _ + rw [machineFalseSquareBuilderIterate_semantics n n le_rfl] + simp [machineFalseSquareBuilderState] + +/-- Build all-false `n` by `n` Boolean storage from a canonical rational +matrix input of dimension `n`. -/ +def machineFalseSquareMatrixCode (word : List Bool) : List Bool := + let ruler := machineMatrixDimensionUnary word + let row := machineFalseVectorCode ruler + machineRepeatedRowMatrixCode (pair ruler row) + +theorem machineFalseSquareMatrixCode_mem_FP : + machineFalseSquareMatrixCode ∈ Complexity.FP := by + have hruler := machineMatrixDimensionUnary_mem_FP + have hrow := machineCompose_mem_FP hruler machineFalseVectorCode_mem_FP + have hpayload := machinePair_mem_FP hruler hrow + simpa only [machineFalseSquareMatrixCode] using! + machineCompose_mem_FP hpayload machineRepeatedRowMatrixCode_mem_FP + +@[simp] theorem machineFalseSquareMatrixCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineFalseSquareMatrixCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + boolMatrixCode + (List.replicate n (List.replicate n false)) := by + rw [machineFalseSquareMatrixCode, machineMatrixDimensionUnary_encode, + machineFalseVectorCode_encode] + exact machineRepeatedRowMatrixCode_falseSquare n + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanMemory.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanMemory.lean new file mode 100644 index 0000000000..7583f84ac8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBooleanMemory.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import LeanPool.BeyondBethe.BeyondBethe.MachineNestedMatrixMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare + +/-! +# Boolean vector and matrix memory + +Matching states use canonical right-nested lists of one-bit Boolean values. +The access and update routines below are compositions of the verified unary +list primitives. The final routine queries the support graph of a rational +matrix without decoding the matrix into a Lean object. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encode one Boolean as a singleton word. -/ +def boolElementCode (b : Bool) : List Bool := [b] + +/-- Encode a Boolean vector as a binary list of singleton Boolean codes. -/ +def boolVectorCode (v : List Bool) : List Bool := + binaryListCode boolElementCode v + +/-- Encode a Boolean matrix as a binary list of encoded Boolean rows. -/ +def boolMatrixCode (M : List (List Bool)) : List Bool := + binaryListCode boolVectorCode M + +/-- Input: `pair indexUnary boolVectorCode`. -/ +def machineBoolVectorEntryAtUnary (word : List Bool) : List Bool := + machineListIndex word + +/-- Input: `pair indexUnary (pair replacementBit boolVectorCode)`. -/ +def machineBoolVectorUpdateAtUnary (word : List Bool) : List Bool := + machineListUpdate word + +theorem machineBoolVectorEntryAtUnary_mem_FP : + machineBoolVectorEntryAtUnary ∈ Complexity.FP := + machineListIndex_mem_FP + +theorem machineBoolVectorUpdateAtUnary_mem_FP : + machineBoolVectorUpdateAtUnary ∈ Complexity.FP := + machineListUpdate_mem_FP + +@[simp] theorem machineBoolVectorEntryAtUnary_encode + (v : List Bool) (i : β„•) (hi : i < v.length) : + machineBoolVectorEntryAtUnary + (pair (List.replicate i true) (boolVectorCode v)) = [v[i]] := by + exact machineListIndex_binaryListCode boolElementCode v i hi + +@[simp] theorem machineBoolVectorUpdateAtUnary_encode + (v : List Bool) (i : β„•) (replacement : Bool) + (hi : i < v.length) : + machineBoolVectorUpdateAtUnary + (pair (List.replicate i true) + (pair [replacement] (boolVectorCode v))) = + boolVectorCode (v.set i replacement) := by + exact machineListUpdate_binaryListCode boolElementCode v replacement i hi + +/-- Input: `pair rowUnary (pair columnUnary boolMatrixCode)`. -/ +def machineBoolMatrixEntryAtUnary (word : List Bool) : List Bool := + machineNestedMatrixEntryAtUnary word + +theorem machineBoolMatrixEntryAtUnary_mem_FP : + machineBoolMatrixEntryAtUnary ∈ Complexity.FP := + machineNestedMatrixEntryAtUnary_mem_FP + +@[simp] theorem machineBoolMatrixEntryAtUnary_encode + (M : List (List Bool)) (i j : β„•) + (hi : i < M.length) (hj : j < M[i].length) : + machineBoolMatrixEntryAtUnary + (pair (List.replicate i true) + (pair (List.replicate j true) (boolMatrixCode M))) = + [M[i][j]] := by + exact machineNestedMatrixEntryAtUnary_encode boolElementCode M i j hi hj + +/-- Input: +`pair rowUnary (pair columnUnary (pair replacementBit boolMatrixCode))`. -/ +def machineBoolMatrixUpdateAtUnary (word : List Bool) : List Bool := + machineNestedMatrixUpdateAtUnary word + +theorem machineBoolMatrixUpdateAtUnary_mem_FP : + machineBoolMatrixUpdateAtUnary ∈ Complexity.FP := + machineNestedMatrixUpdateAtUnary_mem_FP + +@[simp] theorem machineBoolMatrixUpdateAtUnary_encode + (M : List (List Bool)) (i j : β„•) (replacement : Bool) + (hi : i < M.length) (hj : j < M[i].length) : + machineBoolMatrixUpdateAtUnary + (pair (List.replicate i true) + (pair (List.replicate j true) + (pair [replacement] (boolMatrixCode M)))) = + boolMatrixCode (M.set i (M[i].set j replacement)) := by + exact machineNestedMatrixUpdateAtUnary_encode boolElementCode M i j replacement hi hj + +/-! ## Rational support queries -/ + +/-- Test equality of two encoded raw rationals by checking both order comparisons. -/ +def machineRawRatEqBit (word : List Bool) : List Bool := + machineAndBit (machineRawRatLeBit word) + (machineRawRatLeBit (pair (machinePairSecond word) + (machinePairFirst word))) + +/-- Negate the raw-rational equality test. -/ +def machineRawRatNeBit (word : List Bool) : List Bool := + machineNotBit (machineRawRatEqBit word) + +theorem machineRawRatEqBit_mem_FP : + machineRawRatEqBit ∈ Complexity.FP := by + have hswap := machinePair_mem_FP machinePairSecond_mem_FP + machinePairFirst_mem_FP + have hright := machineCompose_mem_FP hswap machineRawRatLeBit_mem_FP + exact machineAndBit_mem_FP machineRawRatLeBit_mem_FP hright + +theorem machineRawRatNeBit_mem_FP : + machineRawRatNeBit ∈ Complexity.FP := by + simpa only [machineRawRatNeBit] using! + machineNotBit_mem_FP machineRawRatEqBit_mem_FP + +@[simp] theorem machineRawRatEqBit_encode (q r : RawRat) : + machineRawRatEqBit + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + [decide (q.value = r.value)] := by + rw [machineRawRatEqBit, machineRawRatLeBit_encode] + simp only [machinePairSecond_pair, machinePairFirst_pair, + machineRawRatLeBit_encode, machineAndBit_one] + apply congrArg singleton + apply Bool.eq_iff_iff.mpr + simp [le_antisymm_iff] + +@[simp] theorem machineRawRatNeBit_encode (q r : RawRat) : + machineRawRatNeBit + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + [decide (q.value β‰  r.value)] := by + rw [machineRawRatNeBit, machineRawRatEqBit_encode, machineNotBit_one] + by_cases h : q.value = r.value <;> simp [h] + +/-- Input: `pair rowUnary (pair columnUnary rationalMatrixWord)`. -/ +def machineRationalSupportBitAtUnary (word : List Bool) : List Bool := + let entry := machineMatrixEntryAtUnary word + machineRawRatNeBit + (pair entry (rawRatBinaryCode RawRat.zero)) + +theorem machineRationalSupportBitAtUnary_mem_FP : + machineRationalSupportBitAtUnary ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixEntryAtUnary_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + simpa only [machineRationalSupportBitAtUnary] using! + machineCompose_mem_FP hpair machineRawRatNeBit_mem_FP + +@[simp] theorem machineRationalSupportBitAtUnary_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : + machineRationalSupportBitAtUnary + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩))) = + [decide (A i j β‰  0)] := by + rw [machineRationalSupportBitAtUnary, + machineMatrixEntryAtUnary_encode] + rw [← rawRatBinaryCode_rawRatOfRat, machineRawRatNeBit_encode] + simp only [rawRatOfRat_value, RawRat.value_zero] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineBoundedUnary.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineBoundedUnary.lean new file mode 100644 index 0000000000..fe45b1e6b1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineBoundedUnary.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinarySub + +/-! +# Bounded conversion from binary to unary + +An unrestricted binary integer can describe an exponentially long unary word, +so binary-to-unary conversion is not polynomial-time in general. This machine +therefore receives an explicit unary guard. It returns exactly `n` true bits +when the encoded natural `n` is at most the guard length, and otherwise returns +only the guarded prefix. The guard is what later permits paper-specific +polynomial schedules without making a false global complexity claim. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Package the remaining binary integer and accumulated unary word. -/ +def machineBoundedUnaryPack (remaining acc : List Bool) : List Bool := + pair remaining acc + +/-- Extract the remaining binary integer from a bounded unary-conversion state. -/ +def machineBoundedUnaryRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the unary true-bit accumulator. -/ +def machineBoundedUnaryAcc (state : List Bool) : List Bool := + machinePairSecond state + +/-- Subtract one from the remaining binary integer using truncated natural subtraction. -/ +def machineBoundedUnaryDecrement (state : List Bool) : List Bool := + machineBinarySubBits + (pair (machineBoundedUnaryRemaining state) [true]) + +/-- Decrement the remaining binary integer and prepend one true bit to the unary accumulator. -/ +def machineBoundedUnaryContinue (state : List Bool) : List Bool := + machineBoundedUnaryPack (machineBoundedUnaryDecrement state) + (true :: machineBoundedUnaryAcc state) + +/-- Leave an empty remaining word fixed; otherwise perform one decrement-and-append conversion +step. -/ +def machineBoundedUnaryStep (state : List Bool) : List Bool := + machineIfEmpty (machineBoundedUnaryRemaining state) state + (machineBoundedUnaryContinue state) + +/-- Extract the iteration ruler that limits binary-to-unary conversion. -/ +def machineBoundedUnaryRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the binary integer to convert. -/ +def machineBoundedUnaryBits (word : List Bool) : List Bool := + machinePairSecond word + +/-- Initialize bounded unary conversion with the input integer and an empty accumulator. -/ +def machineBoundedUnaryInit (word : List Bool) : List Bool := + machineBoundedUnaryPack (machineBoundedUnaryBits word) [] + +/-- A conversion-state width envelope obtained by pairing the input word with itself. -/ +def machineBoundedUnaryWidth (word : List Bool) : List Bool := + pair word word + +/-- Run binary-to-unary conversion for the ruler's length, stopping early once the remaining +word is empty. -/ +def machineBoundedUnaryFinalState (word : List Bool) : List Bool := + (machineBoundedUnaryStep)^[(machineBoundedUnaryRuler word).length] + (machineBoundedUnaryInit word) + +/-- Expand the encoded natural into true bits, stopping at the unary guard. -/ +def machineBoundedUnary (word : List Bool) : List Bool := + machineBoundedUnaryAcc (machineBoundedUnaryFinalState word) + +private theorem machineIfEmpty_of_ne_nil_local + (test whenEmpty whenNonempty : List Bool) (h : test β‰  []) : + machineIfEmpty test whenEmpty whenNonempty = whenNonempty := by + cases test with + | nil => exact False.elim (h rfl) + | cons bit tail => simp + +theorem machineBoundedUnaryRemaining_mem_FP : + machineBoundedUnaryRemaining ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineBoundedUnaryAcc_mem_FP : + machineBoundedUnaryAcc ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineBoundedUnaryDecrement_mem_FP : + machineBoundedUnaryDecrement ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineBoundedUnaryRemaining_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineBoundedUnaryDecrement] using! + machineCompose_mem_FP hpair machineBinarySubBits_mem_FP + +theorem machineBoundedUnaryContinue_mem_FP : + machineBoundedUnaryContinue ∈ Complexity.FP := by + exact machinePair_mem_FP machineBoundedUnaryDecrement_mem_FP + (machineCompose_mem_FP machineBoundedUnaryAcc_mem_FP + (machinePrepend_mem_FP true)) + +theorem machineBoundedUnaryStep_mem_FP : + machineBoundedUnaryStep ∈ Complexity.FP := by + simpa only [machineBoundedUnaryStep] using! + machineIfEmpty_mem_FP machineBoundedUnaryRemaining_mem_FP + id_mem_FP machineBoundedUnaryContinue_mem_FP + +theorem machineBoundedUnaryRuler_mem_FP : + machineBoundedUnaryRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineBoundedUnaryBits_mem_FP : + machineBoundedUnaryBits ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineBoundedUnaryInit_mem_FP : + machineBoundedUnaryInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineBoundedUnaryBits_mem_FP + (machineConst_mem_FP []) + +theorem machineBoundedUnaryWidth_mem_FP : + machineBoundedUnaryWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP id_mem_FP + +@[simp] theorem machineBoundedUnaryRemaining_pack (remaining acc) : + machineBoundedUnaryRemaining (machineBoundedUnaryPack remaining acc) = + remaining := by + simp [machineBoundedUnaryRemaining, machineBoundedUnaryPack] + +@[simp] theorem machineBoundedUnaryAcc_pack (remaining acc) : + machineBoundedUnaryAcc (machineBoundedUnaryPack remaining acc) = acc := by + simp [machineBoundedUnaryAcc, machineBoundedUnaryPack] + +/-- The packed conversion state has a remaining binary word bounded by the input length and an +accumulator bounded by the elapsed iteration count. -/ +def MachineBoundedUnaryStateBound + (word : List Bool) (iterations : β„•) (state : List Bool) : Prop := + state = machineBoundedUnaryPack + (machineBoundedUnaryRemaining state) (machineBoundedUnaryAcc state) ∧ + (machineBoundedUnaryRemaining state).length ≀ word.length ∧ + (machineBoundedUnaryAcc state).length ≀ iterations + +theorem machineBoundedUnaryInit_bound (word : List Bool) : + MachineBoundedUnaryStateBound word 0 (machineBoundedUnaryInit word) := by + simp only [MachineBoundedUnaryStateBound, machineBoundedUnaryInit, + machineBoundedUnaryRemaining_pack, machineBoundedUnaryAcc_pack] + constructor + Β· trivial + constructor + Β· exact machinePairSecond_length_le word + Β· simp + +theorem machineBoundedUnaryStep_bound + {word state : List Bool} {iterations : β„•} + (hstate : MachineBoundedUnaryStateBound word iterations state) : + MachineBoundedUnaryStateBound word (iterations + 1) + (machineBoundedUnaryStep state) := by + rcases hstate with ⟨hdecomp, hremaining, hacc⟩ + by_cases hempty : machineBoundedUnaryRemaining state = [] + Β· rw [machineBoundedUnaryStep, hempty, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc.trans (by omega)⟩ + Β· rw [machineBoundedUnaryStep, + machineIfEmpty_of_ne_nil_local _ _ _ hempty, + machineBoundedUnaryContinue] + simp only [MachineBoundedUnaryStateBound, + machineBoundedUnaryRemaining_pack, machineBoundedUnaryAcc_pack] + constructor + Β· trivial + constructor + Β· have hsub := machineBinarySubBits_pair_length_le + (machineBoundedUnaryRemaining state) [true] + simp only [machineBoundedUnaryDecrement] + have hnonzero : 1 ≀ (machineBoundedUnaryRemaining state).length := by + have hlength : (machineBoundedUnaryRemaining state).length β‰  0 := by + intro hzero + exact hempty (List.length_eq_zero_iff.mp hzero) + omega + rw [show [true].length = 1 by rfl, max_eq_left hnonzero] at hsub + exact hsub.trans hremaining + Β· simp only [List.length_cons] + omega + +theorem machineBoundedUnaryIterate_bound (word : List Bool) : βˆ€ k, + MachineBoundedUnaryStateBound word k + ((machineBoundedUnaryStep)^[k] (machineBoundedUnaryInit word)) := by + intro k + induction k with + | zero => exact machineBoundedUnaryInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineBoundedUnaryStep_bound ih + +theorem machineBoundedUnaryIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ (machineBoundedUnaryRuler word).length) : + ((machineBoundedUnaryStep)^[iterations] + (machineBoundedUnaryInit word)).length ≀ + (machineBoundedUnaryWidth word).length := by + rcases machineBoundedUnaryIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc⟩ + rw [hdecomp] + simp only [machineBoundedUnaryPack, machineBoundedUnaryWidth, pair_length] + have hruler := machinePairFirst_length_le word + simp only [machineBoundedUnaryRuler] at hiterations + omega + +theorem machineBoundedUnaryFinalState_mem_FP : + machineBoundedUnaryFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBoundedUnaryStep_mem_FP + machineBoundedUnaryInit_mem_FP machineBoundedUnaryRuler_mem_FP + machineBoundedUnaryWidth_mem_FP + machineBoundedUnaryIterate_length_le_width + +theorem machineBoundedUnary_mem_FP : + machineBoundedUnary ∈ Complexity.FP := by + simpa only [machineBoundedUnary] using! + machineCompose_mem_FP machineBoundedUnaryFinalState_mem_FP + machineBoundedUnaryAcc_mem_FP + +/-! ## Exact semantics -/ + +/-- The canonical state after `k` steps on `n`: binary remainder `n-k` and `min k n` true bits. -/ +def boundedUnaryState (n k : β„•) : List Bool := + machineBoundedUnaryPack (n - k).bits + (List.replicate (min k n) true) + +theorem machineBoundedUnaryStep_encode (n k : β„•) : + machineBoundedUnaryStep (boundedUnaryState n k) = + boundedUnaryState n (k + 1) := by + by_cases hkn : k < n + Β· have hpos : 0 < n - k := Nat.sub_pos_of_lt hkn + have hbits : (n - k).bits β‰  [] := by + intro hnil + have hzero : n - k = 0 := by + have h := congrArg Nat.fromBitsLE hnil + simpa only [Nat.fromBitsLE_bits] using! h + omega + rw [machineBoundedUnaryStep] + simp only [boundedUnaryState, machineBoundedUnaryRemaining_pack] + rw [machineIfEmpty_of_ne_nil_local _ _ _ hbits] + rw [machineBoundedUnaryContinue] + simp only [machineBoundedUnaryDecrement, + machineBoundedUnaryRemaining_pack, machineBoundedUnaryAcc_pack] + have hone : ([true] : List Bool) = (1 : β„•).bits := by rfl + rw [hone, machineBinarySubBits_pair_natBits] + apply congrArgβ‚‚ machineBoundedUnaryPack + Β· congr 1 + Β· rw [min_eq_left (Nat.le_of_lt hkn), + min_eq_left (by omega : k + 1 ≀ n)] + simp [List.replicate_succ] + Β· have hnk : n ≀ k := Nat.le_of_not_gt hkn + rw [machineBoundedUnaryStep] + simp [boundedUnaryState, Nat.sub_eq_zero_of_le hnk, + Nat.sub_eq_zero_of_le (hnk.trans (Nat.le_succ k)), + min_eq_right hnk, min_eq_right (hnk.trans (Nat.le_succ k))] + +theorem machineBoundedUnaryIterate_encode (n : β„•) : βˆ€ k, + (machineBoundedUnaryStep)^[k] + (machineBoundedUnaryPack n.bits []) = boundedUnaryState n k := by + intro k + induction k with + | zero => simp [boundedUnaryState] + | succ k ih => + rw [Function.iterate_succ_apply', ih, + machineBoundedUnaryStep_encode] + +theorem machineBoundedUnary_encode (guard : List Bool) (n : β„•) : + machineBoundedUnary (pair guard n.bits) = + List.replicate (min guard.length n) true := by + rw [machineBoundedUnary, machineBoundedUnaryFinalState] + simp only [machineBoundedUnaryRuler, machinePairFirst_pair, + machineBoundedUnaryInit, machineBoundedUnaryBits, + machinePairSecond_pair] + rw [machineBoundedUnaryIterate_encode] + simp [boundedUnaryState] + +theorem machineBoundedUnary_encode_of_le + (guard : List Bool) (n : β„•) (hn : n ≀ guard.length) : + machineBoundedUnary (pair guard n.bits) = + List.replicate n true := by + rw [machineBoundedUnary_encode, min_eq_right hn] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateAssembly.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateAssembly.lean new file mode 100644 index 0000000000..f4d9f0c4d6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateAssembly.lean @@ -0,0 +1,341 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalExp + +/-! +# Assembly of the directed certificate from its matching gain + +This module isolates the remaining combinatorial and exponential-size +obligations. Given a finite-word machine for the fixed greedy matching gain, +it forms the complete rational certificate logarithm. Given in addition a +unary exponential guard, it returns the final canonical raw rational entry. +All composition and rational-format conversions are explicit. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The source matrix word retained by the certificate interface. -/ +def machineCertificateSourceWord (word : List Bool) : List Bool := + machinePairFirst word + +/-- The optimizer-output word consumed by the arithmetic subroutines. -/ +def machineCertificateOptimizerWord (word : List Bool) : List Bool := + machinePairSecond word + +theorem machineCertificateSourceWord_mem_FP : + machineCertificateSourceWord ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineCertificateOptimizerWord_mem_FP : + machineCertificateOptimizerWord ∈ Complexity.FP := + machinePairSecond_mem_FP + +@[simp] theorem machineCertificateSourceWord_pair + (source optimizer : List Bool) : + machineCertificateSourceWord (pair source optimizer) = source := + machinePairFirst_pair source optimizer + +@[simp] theorem machineCertificateOptimizerWord_pair + (source optimizer : List Bool) : + machineCertificateOptimizerWord (pair source optimizer) = optimizer := + machinePairSecond_pair source optimizer + +/-- Assemble the raw-rational logarithmic certificate from the row and column potentials, +directed nearby-coordinate sum, structural gain, and subtracted KKT penalty. -/ +def rawCertificateLogAssembly {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (gain : β„š) : RawRat := + (((rawCertificatePotentialSum R C).add + (rawNearbyRowsSum (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) RawRat.zero + (rationalMatrixRows X))).add + (rawRatOfRat gain)).add (rawCertificateKKTPenalty n).neg + +theorem rawCertificateLogAssembly_value {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (gain : β„š) : + (rawCertificateLogAssembly X R C gain).value = + directedNearbyBetheLower (explicitRegularizationScale n) X R C + (directedCertificatePrecision n) + + gain - explicitKKTError * n := by + rw [rawCertificateLogAssembly, RawRat.value_add, RawRat.value_add, + RawRat.value_add, RawRat.value_neg, + rawCertificatePotentialSum_value, + rawNearbyRowsSum_certificate_value, + rawRatOfRat_value, rawCertificateKKTPenalty_value] + rw [directedNearbyBetheLower] + ring + +/-- Add the encoded potential sum and nearby-matrix contribution extracted from the optimizer +payload. -/ +def machineCertificateNearbyRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair + (machineCertificatePotentialRawSumCode + (machineCertificateOptimizerWord word)) + (machineNearbyMatrixRawSumCode + (machineCertificateOptimizerWord word))) + +/-- Add the supplied gain machine's raw-rational output to the nearby-certificate sum. -/ +def machineCertificateLogBeforePenaltyRawCode + (gainMachine : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineCertificateNearbyRawCode word) (gainMachine word)) + +/-- Subtract the optimizer's encoded KKT penalty from the logarithmic certificate before +normalization. -/ +def machineCertificateLogUnnormalizedRawCode + (gainMachine : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineCertificateLogBeforePenaltyRawCode gainMachine word) + (machineRawRatNegCode + (machineCertificateKKTPenaltyRawCode + (machineCertificateOptimizerWord word)))) + +/-- Canonical raw-entry encoding of the complete certificate logarithm. -/ +def machineCertificateLogRawCode + (gainMachine : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineCertificateLogUnnormalizedRawCode gainMachine word) + +theorem machineCertificateNearbyRawCode_mem_FP : + machineCertificateNearbyRawCode ∈ Complexity.FP := by + have hpotential := machineCompose_mem_FP + machineCertificateOptimizerWord_mem_FP + machineCertificatePotentialRawSumCode_mem_FP + have hnearby := machineCompose_mem_FP + machineCertificateOptimizerWord_mem_FP + machineNearbyMatrixRawSumCode_mem_FP + have hpair := machinePair_mem_FP + hpotential hnearby + simpa only [machineCertificateNearbyRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineCertificateLogBeforePenaltyRawCode_mem_FP + {gainMachine : List Bool β†’ List Bool} + (hgain : gainMachine ∈ Complexity.FP) : + machineCertificateLogBeforePenaltyRawCode gainMachine ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineCertificateNearbyRawCode_mem_FP hgain + simpa only [machineCertificateLogBeforePenaltyRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineCertificateLogUnnormalizedRawCode_mem_FP + {gainMachine : List Bool β†’ List Bool} + (hgain : gainMachine ∈ Complexity.FP) : + machineCertificateLogUnnormalizedRawCode gainMachine ∈ Complexity.FP := by + have hpenalty := machineCompose_mem_FP + machineCertificateOptimizerWord_mem_FP + machineCertificateKKTPenaltyRawCode_mem_FP + have hneg := machineCompose_mem_FP hpenalty machineRawRatNegCode_mem_FP + have hpair := machinePair_mem_FP + (machineCertificateLogBeforePenaltyRawCode_mem_FP hgain) hneg + simpa only [machineCertificateLogUnnormalizedRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineCertificateLogRawCode_mem_FP + {gainMachine : List Bool β†’ List Bool} + (hgain : gainMachine ∈ Complexity.FP) : + machineCertificateLogRawCode gainMachine ∈ Complexity.FP := by + simpa only [machineCertificateLogRawCode] using! + machineCompose_mem_FP + (machineCertificateLogUnnormalizedRawCode_mem_FP hgain) + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineCertificateLogUnnormalizedRawCode_encode + {gainMachine : List Bool β†’ List Bool} + (source : List Bool) + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (hgain : gainMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode (rawRatOfRat (explicitCertifiedMatchingGain X))) : + machineCertificateLogUnnormalizedRawCode gainMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode + (rawCertificateLogAssembly X R C + (explicitCertifiedMatchingGain X)) := by + rw [machineCertificateLogUnnormalizedRawCode, + machineCertificateLogBeforePenaltyRawCode, + machineCertificateNearbyRawCode, + machineCertificateOptimizerWord_pair, + machineCertificatePotentialRawSumCode_encode, + machineNearbyMatrixRawSumCode_encode, + hgain, machineCertificateKKTPenaltyRawCode_encode, + machineRawRatNegCode_encode, machineRawRatAddCode_encode, + machineRawRatAddCode_encode, machineRawRatAddCode_encode] + rfl + +theorem machineCertificateLogRawCode_encode + {gainMachine : List Bool β†’ List Bool} + (source : List Bool) + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (hgain : gainMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode (rawRatOfRat (explicitCertifiedMatchingGain X))) : + machineCertificateLogRawCode gainMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode + (rawRatOfRat (explicitDirectedCertificateLog X R C)) := by + rw [machineCertificateLogRawCode, + machineCertificateLogUnnormalizedRawCode_encode + (gainMachine := gainMachine) source X R C hgain, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, + rawCertificateLogAssembly_value, + explicitDirectedCertificateLog] + +/-- Package the exponentiation guard, normalized logarithmic certificate, and optimizer-derived +exponential loss. -/ +def machineCertificateExpInput + (gainMachine guardMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + pair (guardMachine word) + (pair (machineCertificateLogRawCode gainMachine word) + (machineCertificateExpLossRawCode + (machineCertificateOptimizerWord word))) + +/-- Evaluate the bounded rational lower exponential routine on the assembled certificate input. -/ +def machineCertificateValueRawCode + (gainMachine guardMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineBoundedRationalExpLowerRawEntryCode + (machineCertificateExpInput gainMachine guardMachine word) + +theorem machineCertificateExpInput_mem_FP + {gainMachine guardMachine : List Bool β†’ List Bool} + (hgain : gainMachine ∈ Complexity.FP) + (hguard : guardMachine ∈ Complexity.FP) : + machineCertificateExpInput gainMachine guardMachine ∈ Complexity.FP := by + exact machinePair_mem_FP hguard + (machinePair_mem_FP (machineCertificateLogRawCode_mem_FP hgain) + (machineCompose_mem_FP machineCertificateOptimizerWord_mem_FP + machineCertificateExpLossRawCode_mem_FP)) + +theorem machineCertificateValueRawCode_mem_FP + {gainMachine guardMachine : List Bool β†’ List Bool} + (hgain : gainMachine ∈ Complexity.FP) + (hguard : guardMachine ∈ Complexity.FP) : + machineCertificateValueRawCode gainMachine guardMachine ∈ Complexity.FP := by + simpa only [machineCertificateValueRawCode] using! + machineCompose_mem_FP (machineCertificateExpInput_mem_FP hgain hguard) + machineBoundedRationalExpLowerRawEntryCode_mem_FP + +theorem machineCertificateValueRawCode_encode + {gainMachine guardMachine : List Bool β†’ List Bool} + (source : List Bool) + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (hgain : gainMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode (rawRatOfRat (explicitCertifiedMatchingGain X))) + (hsteps : RawRat.expApproxSteps + (rawRatOfRat (explicitDirectedCertificateLog X R C)) + (rawCertificateExpLoss n) ≀ + (guardMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩))).length) : + machineCertificateValueRawCode gainMachine guardMachine + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode + (rawRatOfRat (explicitDirectedCertificateValue X R C)) := by + rw [machineCertificateValueRawCode, machineCertificateExpInput, + machineCertificateLogRawCode_encode + (gainMachine := gainMachine) source X R C hgain, + machineCertificateOptimizerWord_pair, + machineCertificateExpLossRawCode_encode, + machineBoundedRationalExpLowerRawEntryCode_encode _ _ _ hsteps, + rawRatOfRat_value, rawCertificateExpLoss_value, + binaryRationalExpLower_eq, explicitDirectedCertificateValue] + +/-- Correctness required of the remaining fixed-gain matching transducer. -/ +def OptimizerMatchingGainStringRealizes + (gainMachine : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + gainMachine + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode (explicitLargeOptimizerOutput m B))) = + rawRatBinaryCode + (rawRatOfRat + (explicitCertifiedMatchingGain + (explicitBetheOptimizerMatrix (m := m + 1) B))) + +/-- The optimizer-dependent magnitude statement still needed by the guarded +exponential. It is separated from machine composition so that no universal +claim about arbitrary rational potentials is hidden in the evaluator. -/ +def OptimizerCertificateExpGuardFits + (guardMachine : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + (guardMachine + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode + (explicitLargeOptimizerOutput m B)))).length + +/-- The guarded exponential needs to fit only on the positive normalized +matrices on which the certificate theorem and the outer algorithm use it. -/ +def OptimizerCertificateExpGuardFitsOnPositiveNormalized + (guardMachine : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + (guardMachine + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode + (explicitLargeOptimizerOutput m B)))).length + +theorem machineCertificateValueRawCode_realizes + {gainMachine guardMachine : List Bool β†’ List Bool} + (hgain : OptimizerMatchingGainStringRealizes gainMachine) + (hguard : OptimizerCertificateExpGuardFits guardMachine) : + CertificateEvaluatorStringRealizes + (machineCertificateValueRawCode gainMachine guardMachine) := by + intro m B + simpa only [explicitLargeOptimizerOutput] using! + machineCertificateValueRawCode_encode + (gainMachine := gainMachine) (guardMachine := guardMachine) + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) + (hgain m B) (hguard m B) + +theorem machineCertificateValueRawCode_realizes_onPositive + {gainMachine guardMachine : List Bool β†’ List Bool} + (hgain : OptimizerMatchingGainStringRealizes gainMachine) + (hguard : + OptimizerCertificateExpGuardFitsOnPositiveNormalized guardMachine) : + CertificateEvaluatorStringRealizesOnPositiveNormalized + (machineCertificateValueRawCode gainMachine guardMachine) := by + intro m B hBpos hBupper + simpa only [explicitLargeOptimizerOutput] using! + machineCertificateValueRawCode_encode + (gainMachine := gainMachine) (guardMachine := guardMachine) + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) + (hgain m B) (hguard m B hBpos hBupper) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateExpGuard.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateExpGuard.lean new file mode 100644 index 0000000000..963b013476 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateExpGuard.lean @@ -0,0 +1,312 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateAssembly + +/-! +# The polynomial exponential guard for the optimizer certificate + +The exponential evaluator expands its binary step count to unary. Six fixed +applications of the verified quadratic-width constructor provide a degree-64 +guard. On positive normalized source matrices this dominates the exact +magnitude-sensitive exponential schedule. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The natural ceiling of the reciprocal of the fixed exponential evaluation loss. -/ +def explicitExpReciprocalCeil : β„• := + rationalCeilNat (1 / explicitExpEvaluationLoss) + +/-- The odd exponential step bound `2*(K + K^2*C)+1`, where `K = 34*sourceLength^2` and `C` is +the reciprocal-loss ceiling. -/ +def explicitCertificateExpStepBound (sourceLength : β„•) : β„• := + let K := 34 * sourceLength ^ 2 + 2 * (K + K ^ 2 * explicitExpReciprocalCeil) + 1 + +theorem rationalCeilNat_le_of_le_nat {q : β„š} {N : β„•} + (hq : q ≀ N) : rationalCeilNat q ≀ N := by + rw [rationalCeilNat, Int.toNat_le] + exact Int.ceil_le.mpr hq + +@[simp] theorem RawRat.expMagnitude_value (q : RawRat) : + (RawRat.expMagnitude q).value = abs q.value := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat a => + have hnonneg : 0 ≀ ((⟨Int.ofNat a, den, hden⟩ : RawRat).value) := by + rw [RawRat.value] + norm_num only [Int.cast_ofNat] + exact div_nonneg (Nat.cast_nonneg a) (by exact_mod_cast hden.le) + change ((⟨Int.ofNat a, den, hden⟩ : RawRat).value) = + abs ((⟨Int.ofNat a, den, hden⟩ : RawRat).value) + rw [abs_of_nonneg hnonneg] + | negSucc a => + have hnonpos : ((⟨Int.negSucc a, den, hden⟩ : RawRat).value) ≀ 0 := by + rw [RawRat.value] + have hnum : (((Int.negSucc a : β„€) : β„š)) < 0 := by + norm_num only [Int.cast_negSucc, Nat.cast_add, Nat.cast_one] + linarith + exact div_nonpos_of_nonpos_of_nonneg hnum.le + (by exact_mod_cast hden.le) + change ((⟨Int.negSucc a, den, hden⟩ : RawRat).neg.value) = + abs ((⟨Int.negSucc a, den, hden⟩ : RawRat).value) + rw [RawRat.value_neg, abs_of_nonpos hnonpos] + +theorem inverse_certificate_loss_le_reciprocalCeil + {n : β„•} (hn : 1 ≀ n) : + 1 / (explicitExpEvaluationLoss * n) ≀ + (explicitExpReciprocalCeil : β„š) := by + have hc : 0 < explicitExpEvaluationLoss := explicitExpEvaluationLoss_pos + have hnQ : (1 : β„š) ≀ n := by exact_mod_cast hn + have hden : explicitExpEvaluationLoss ≀ + explicitExpEvaluationLoss * n := by + simpa only [mul_one] using! mul_le_mul_of_nonneg_left hnQ hc.le + have hinv : 1 / (explicitExpEvaluationLoss * n) ≀ + 1 / explicitExpEvaluationLoss := + one_div_le_one_div_of_le hc hden + have hceil := le_rationalCeilNat + (show (0 : β„š) ≀ 1 / explicitExpEvaluationLoss by positivity) + exact hinv.trans hceil + +/-- The source-length guard depends only on an a priori magnitude bound for +the rational logarithm. It is intentionally independent of the optimizer +that produced that logarithm. -/ +theorem certificate_expApproxSteps_le_sourceBound_of_abs_le + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) (q : β„š) + (habsR : abs (q : ℝ) ≀ explicitCertificateMagnitudeBudget B) : + RawRat.expApproxSteps (rawRatOfRat q) + (rawCertificateExpLoss (m + 2)) ≀ + explicitCertificateExpStepBound + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩).length := by + let source := rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩ + let S := source.length + let t : β„š := abs q + let K := explicitCertificateMagnitudeBudget B + let Kβ‚€ := 34 * S ^ 2 + have ht : t ≀ (K : β„š) := by + exact_mod_cast habsR + have ht0 : 0 ≀ t := abs_nonneg q + have hnSource : m + 2 ≀ S := by + simpa only [S, source] using! matrix_dimension_le_code_length B + have hBSource : rationalMatrixEntryBitBound B ≀ 32 * S := by + simpa only [S, source] using! + rationalMatrixEntryBitBound_le_machineCode (by omega) B + have hS : 1 ≀ S := by omega + have hK : K ≀ Kβ‚€ := by + simp only [K, Kβ‚€, explicitCertificateMagnitudeBudget] + nlinarith + have htKβ‚€ : t ≀ (Kβ‚€ : β„š) := ht.trans (by exact_mod_cast hK) + have hinv := inverse_certificate_loss_le_reciprocalCeil + (n := m + 2) (by omega) + have hlossValue : (rawCertificateExpLoss (m + 2)).value = + explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š) := + rawCertificateExpLoss_value (m + 2) + have hsq : t ^ 2 ≀ (Kβ‚€ : β„š) ^ 2 := + pow_le_pow_leftβ‚€ ht0 htKβ‚€ 2 + have hinv0 : 0 ≀ + 1 / (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š)) := by + exact div_nonneg (by norm_num) + (mul_nonneg explicitExpEvaluationLoss_pos.le (by positivity)) + have hC0 : (0 : β„š) ≀ explicitExpReciprocalCeil := by positivity + have hdiv : t ^ 2 / + (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š)) ≀ + (Kβ‚€ : β„š) ^ 2 * explicitExpReciprocalCeil := by + calc + t ^ 2 / (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š)) = + t ^ 2 * + (1 / (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š))) := by ring + _ ≀ (Kβ‚€ : β„š) ^ 2 * + (1 / (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š))) := + mul_le_mul_of_nonneg_right hsq hinv0 + _ ≀ (Kβ‚€ : β„š) ^ 2 * explicitExpReciprocalCeil := + mul_le_mul_of_nonneg_left hinv (sq_nonneg (Kβ‚€ : β„š)) + have hu : t + t ^ 2 / + (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š)) ≀ + (Kβ‚€ + Kβ‚€ ^ 2 * explicitExpReciprocalCeil : β„•) := by + norm_num only [Nat.cast_add, Nat.cast_mul, Nat.cast_pow, + Nat.cast_ofNat] at hdiv ⊒ + exact add_le_add htKβ‚€ hdiv + have hceil : rationalCeilNat + (t + t ^ 2 / + (explicitExpEvaluationLoss * ((m + 2 : β„•) : β„š))) ≀ + Kβ‚€ + Kβ‚€ ^ 2 * explicitExpReciprocalCeil := + rationalCeilNat_le_of_le_nat hu + rw [RawRat.expApproxSteps, binaryRationalExpApproxSteps_eq, + rationalExpApproxSteps, RawRat.expMagnitude_value, + rawRatOfRat_value, hlossValue] + simpa only [t, Kβ‚€, S, source, explicitCertificateExpStepBound] using! + Nat.add_le_add_right (Nat.mul_le_mul_left 2 hceil) 1 + +theorem optimizerCertificate_expApproxSteps_le_sourceBound + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + explicitCertificateExpStepBound + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩).length := by + let q := explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) + have habsR := explicitOptimizerCertificateLog_abs_le m B hBpos hBupper + exact certificate_expApproxSteps_le_sourceBound_of_abs_le m B q + (by simpa only [q] using! habsR) + +/-- Iterate the binary-multiplication width constructor the specified number of times. -/ +def machineIteratedBinaryWidth : β„• β†’ List Bool β†’ List Bool + | 0, word => word + | k + 1, word => machineBinaryMulWidth (machineIteratedBinaryWidth k word) + +/-- The numerical width recurrence starting at `L` and replacing each width by its padded square +`(width+16)^2`. -/ +def certificateExpGuardWidth : β„• β†’ β„• β†’ β„• + | 0, L => L + | k + 1, L => (certificateExpGuardWidth k L + 16) ^ 2 + +theorem machineIteratedBinaryWidth_mem_FP (k : β„•) : + machineIteratedBinaryWidth k ∈ Complexity.FP := by + induction k with + | zero => simpa only [machineIteratedBinaryWidth] using! id_mem_FP + | succ k ih => + simpa only [machineIteratedBinaryWidth] using! + machineCompose_mem_FP ih machineBinaryMulWidth_mem_FP + +@[simp] theorem machineIteratedBinaryWidth_length (k : β„•) + (word : List Bool) : + (machineIteratedBinaryWidth k word).length = + certificateExpGuardWidth k word.length := by + induction k with + | zero => rfl + | succ k ih => + rw [machineIteratedBinaryWidth, machineBinaryMulWidth] + simp only [List.length_replicate, List.length_append, ih, + List.length_cons, List.length_nil, zero_add] + simp only [certificateExpGuardWidth] + ring + +theorem certificateExpGuardWidth_pow_lower (k S : β„•) : + (S + 16) ^ (2 ^ (k + 1)) ≀ certificateExpGuardWidth (k + 1) S := by + induction k with + | zero => simp [certificateExpGuardWidth] + | succ k ih => + rw [certificateExpGuardWidth] + have hmono : certificateExpGuardWidth (k + 1) S ^ 2 ≀ + (certificateExpGuardWidth (k + 1) S + 16) ^ 2 := by + exact Nat.pow_le_pow_left (Nat.le_add_right _ _) 2 + calc + (S + 16) ^ (2 ^ (k + 1 + 1)) = + ((S + 16) ^ (2 ^ (k + 1))) ^ 2 := by + rw [show 2 ^ (k + 1 + 1) = 2 ^ (k + 1) * 2 by + rw [pow_succ]] + rw [pow_mul] + _ ≀ certificateExpGuardWidth (k + 1) S ^ 2 := + Nat.pow_le_pow_left ih 2 + _ ≀ (certificateExpGuardWidth (k + 1) S + 16) ^ 2 := hmono + +/-- The coefficient `2312*C+69` in the explicit exponential step estimate, with `C` the +reciprocal-loss ceiling. -/ +def explicitCertificateExpCoefficient : β„• := + 2312 * explicitExpReciprocalCeil + 69 + +theorem explicitCertificateExpCoefficient_le : + explicitCertificateExpCoefficient ≀ 18 ^ 60 := by + have hrecip : explicitExpReciprocalCeil ≀ 10 ^ 69 := by + rw [explicitExpReciprocalCeil] + apply rationalCeilNat_le_of_le_nat + rw [explicitExpEvaluationLoss, explicitCertifiedEpsilon, + explicitCertifiedEpsilon_eq] + norm_num [explicitXi, explicitDelta, explicitEta, explicitRowRatio] + rw [explicitCertificateExpCoefficient] + calc + 2312 * explicitExpReciprocalCeil + 69 ≀ + 2312 * 10 ^ 69 + 69 := + Nat.add_le_add_right (Nat.mul_le_mul_left 2312 hrecip) 69 + _ ≀ 18 ^ 60 := by norm_num + +theorem explicitCertificateExpStepBound_le_guardWidth + {S : β„•} (hS : 2 ≀ S) : + explicitCertificateExpStepBound S ≀ certificateExpGuardWidth 6 S := by + let Kβ‚€ := 34 * S ^ 2 + have hSsq : S ^ 2 ≀ S ^ 4 := + Nat.pow_le_pow_right (by omega) (by omega) + have hSfour : 1 ≀ S ^ 4 := Nat.one_le_pow 4 S (by omega) + have hstepCoeff : explicitCertificateExpStepBound S ≀ + explicitCertificateExpCoefficient * S ^ 4 := by + simp only [explicitCertificateExpStepBound, Kβ‚€, + explicitCertificateExpCoefficient] + nlinarith + have hbase : 18 ≀ S + 16 := by omega + have hpow60 : 18 ^ 60 ≀ (S + 16) ^ 60 := + Nat.pow_le_pow_left hbase 60 + have hpow4 : S ^ 4 ≀ (S + 16) ^ 4 := + Nat.pow_le_pow_left (Nat.le_add_right S 16) 4 + have hguardPolynomial : explicitCertificateExpCoefficient * S ^ 4 ≀ + (S + 16) ^ 64 := by + calc + explicitCertificateExpCoefficient * S ^ 4 ≀ 18 ^ 60 * S ^ 4 := + Nat.mul_le_mul explicitCertificateExpCoefficient_le (le_refl _) + _ ≀ (S + 16) ^ 60 * (S + 16) ^ 4 := + Nat.mul_le_mul hpow60 hpow4 + _ = (S + 16) ^ 64 := by rw [← pow_add] + exact hstepCoeff.trans <| hguardPolynomial.trans <| + (by simpa using! certificateExpGuardWidth_pow_lower 5 S) + +/-- Construct the certificate exponentiation guard by applying six binary-width expansions to +the stored source word. -/ +def machineOptimizerCertificateExpGuard (word : List Bool) : List Bool := + machineIteratedBinaryWidth 6 (machineCertificateSourceWord word) + +theorem machineOptimizerCertificateExpGuard_mem_FP : + machineOptimizerCertificateExpGuard ∈ Complexity.FP := by + simpa only [machineOptimizerCertificateExpGuard] using! + machineCompose_mem_FP machineCertificateSourceWord_mem_FP + (machineIteratedBinaryWidth_mem_FP 6) + +theorem machineOptimizerCertificateExpGuard_fits + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + (machineOptimizerCertificateExpGuard + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode + (explicitLargeOptimizerOutput m B)))).length := by + let source := rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩ + have hsource : 2 ≀ source.length := + (show 2 ≀ m + 2 by omega).trans (matrix_dimension_le_code_length B) + exact (optimizerCertificate_expApproxSteps_le_sourceBound m B hBpos hBupper).trans + (by simpa only [machineOptimizerCertificateExpGuard, + machineCertificateSourceWord_pair, + machineIteratedBinaryWidth_length, source] using! + explicitCertificateExpStepBound_le_guardWidth hsource) + +theorem machineOptimizerCertificateExpGuard_fits_onPositiveNormalized : + OptimizerCertificateExpGuardFitsOnPositiveNormalized + machineOptimizerCertificateExpGuard := by + intro m B hBpos hBupper + exact machineOptimizerCertificateExpGuard_fits m B hBpos hBupper + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCertificatePotentials.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificatePotentials.lean new file mode 100644 index 0000000000..c60b8589e5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificatePotentials.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum + +/-! +# Finite-word access and summation for certificate potentials + +This is the first component of the directed certificate evaluator. It parses +the canonical optimizer-output word and forms the unreduced rational sum of +all row and column potentials. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the encoded matrix from an optimizer result word. -/ +def machineOptimizerMatrixWord (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the row-and-column potential payload from an optimizer result word. -/ +def machineOptimizerPotentialsWord (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the encoded row-potential vector. -/ +def machineOptimizerRowPotentialWord (word : List Bool) : List Bool := + machinePairFirst (machineOptimizerPotentialsWord word) + +/-- Extract the encoded column-potential vector. -/ +def machineOptimizerColumnPotentialWord (word : List Bool) : List Bool := + machinePairSecond (machineOptimizerPotentialsWord word) + +theorem machineOptimizerMatrixWord_mem_FP : + machineOptimizerMatrixWord ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineOptimizerPotentialsWord_mem_FP : + machineOptimizerPotentialsWord ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineOptimizerRowPotentialWord_mem_FP : + machineOptimizerRowPotentialWord ∈ Complexity.FP := by + simpa only [machineOptimizerRowPotentialWord] using! + machineCompose_mem_FP machineOptimizerPotentialsWord_mem_FP + machinePairFirst_mem_FP + +theorem machineOptimizerColumnPotentialWord_mem_FP : + machineOptimizerColumnPotentialWord ∈ Complexity.FP := by + simpa only [machineOptimizerColumnPotentialWord] using! + machineCompose_mem_FP machineOptimizerPotentialsWord_mem_FP + machinePairSecond_mem_FP + +@[simp] theorem machineOptimizerMatrixWord_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineOptimizerMatrixWord + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rationalMatrixBinaryEncoding.encode ⟨n, X⟩ := by + simp [machineOptimizerMatrixWord, rationalOptimizerOutputCode] + +@[simp] theorem machineOptimizerRowPotentialWord_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineOptimizerRowPotentialWord + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rationalVectorBinaryCode R := by + simp [machineOptimizerRowPotentialWord, machineOptimizerPotentialsWord, + rationalOptimizerOutputCode] + +@[simp] theorem machineOptimizerColumnPotentialWord_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineOptimizerColumnPotentialWord + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rationalVectorBinaryCode C := by + simp [machineOptimizerColumnPotentialWord, machineOptimizerPotentialsWord, + rationalOptimizerOutputCode] + +/-- Compute the raw-rational sum of the encoded row potentials. -/ +def machineCertificateRowPotentialRawSumCode + (word : List Bool) : List Bool := + machineRationalVectorRawSumCode + (machineOptimizerRowPotentialWord word) + +/-- Compute the raw-rational sum of the encoded column potentials. -/ +def machineCertificateColumnPotentialRawSumCode + (word : List Bool) : List Bool := + machineRationalVectorRawSumCode + (machineOptimizerColumnPotentialWord word) + +/-- Add the encoded row- and column-potential sums. -/ +def machineCertificatePotentialRawSumCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineCertificateRowPotentialRawSumCode word) + (machineCertificateColumnPotentialRawSumCode word)) + +theorem machineCertificateRowPotentialRawSumCode_mem_FP : + machineCertificateRowPotentialRawSumCode ∈ Complexity.FP := by + simpa only [machineCertificateRowPotentialRawSumCode] using! + machineCompose_mem_FP machineOptimizerRowPotentialWord_mem_FP + machineRationalVectorRawSumCode_mem_FP + +theorem machineCertificateColumnPotentialRawSumCode_mem_FP : + machineCertificateColumnPotentialRawSumCode ∈ Complexity.FP := by + simpa only [machineCertificateColumnPotentialRawSumCode] using! + machineCompose_mem_FP machineOptimizerColumnPotentialWord_mem_FP + machineRationalVectorRawSumCode_mem_FP + +theorem machineCertificatePotentialRawSumCode_mem_FP : + machineCertificatePotentialRawSumCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineCertificateRowPotentialRawSumCode_mem_FP + machineCertificateColumnPotentialRawSumCode_mem_FP + simpa only [machineCertificatePotentialRawSumCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +/-- The raw-rational sum of every row and column potential, using zero-initialized list sums. -/ +def rawCertificatePotentialSum {n : β„•} + (R C : Fin n β†’ β„š) : RawRat := + (rawRatListSum RawRat.zero (List.ofFn R)).add + (rawRatListSum RawRat.zero (List.ofFn C)) + +@[simp] theorem machineCertificatePotentialRawSumCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificatePotentialRawSumCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (rawCertificatePotentialSum R C) := by + simp only [machineCertificatePotentialRawSumCode, + machineCertificateRowPotentialRawSumCode, + machineCertificateColumnPotentialRawSumCode, + machineOptimizerRowPotentialWord_encode, + machineOptimizerColumnPotentialWord_encode, + machineRationalVectorRawSumCode_encode, + machineRawRatAddCode_encode, rawCertificatePotentialSum] + +theorem rawCertificatePotentialSum_value {n : β„•} + (R C : Fin n β†’ β„š) : + (rawCertificatePotentialSum R C).value = + (βˆ‘ i, R i) + βˆ‘ j, C j := by + rw [rawCertificatePotentialSum, RawRat.value_add, + rawRatListSum_ofFn_value, rawRatListSum_ofFn_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateScales.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateScales.lean new file mode 100644 index 0000000000..d703719df1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCertificateScales.lean @@ -0,0 +1,254 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificatePotentials +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedLog + +/-! +# Dimension-dependent certificate scales as finite-word functions + +The directed certificate uses three dimension-dependent quantities: the +regularization scale, the logarithm precision, and the linear KKT and +exponential losses. This file constructs all of them directly from the +dimension prefix of the optimizer's matrix word. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the optimizer matrix dimension in binary. -/ +def machineCertificateDimensionBits (word : List Bool) : List Bool := + machineMatrixDimensionWord (machineOptimizerMatrixWord word) + +/-- Extract a unary ruler for the optimizer matrix dimension. -/ +def machineCertificateDimensionUnary (word : List Bool) : List Bool := + machineMatrixDimensionUnary (machineOptimizerMatrixWord word) + +/-- Unary ruler of exact length `n + 400`. -/ +def machineCertificateLogPrecisionRuler (word : List Bool) : List Bool := + machineCertificateDimensionUnary word ++ List.replicate 400 true + +/-- Encode the matrix dimension as a nonnegative integer numerator with denominator one. -/ +def machineCertificateDimensionRawCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineCertificateDimensionBits word)) + [true] + +/-- The raw-rational natural number four. -/ +def rawCertificateFour : RawRat := RawRat.ofNat 4 + +/-- Compute the encoded raw-rational value four times the matrix dimension. -/ +def machineCertificateFourDimensionRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawCertificateFour) + (machineCertificateDimensionRawCode word)) + +/-- The raw-rational representation of the fixed structural gain parameter `explicitXi`. -/ +def rawExplicitXi : RawRat := rawRatOfRat explicitXi + +/-- Divide the fixed gain parameter by four times the encoded matrix dimension to obtain the +regularization scale. -/ +def machineCertificateRegularizationScaleRawCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode rawExplicitXi) + (machineCertificateFourDimensionRawCode word)) + +/-- The raw-rational representation of the fixed KKT error allowance. -/ +def rawExplicitKKTError : RawRat := rawRatOfRat explicitKKTError + +/-- Multiply the KKT error allowance by the encoded matrix dimension. -/ +def machineCertificateKKTPenaltyRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawExplicitKKTError) + (machineCertificateDimensionRawCode word)) + +/-- The raw-rational representation of the fixed exponential evaluation loss. -/ +def rawExplicitExpEvaluationLoss : RawRat := + rawRatOfRat explicitExpEvaluationLoss + +/-- Multiply the exponential evaluation loss by the encoded matrix dimension. -/ +def machineCertificateExpLossRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawExplicitExpEvaluationLoss) + (machineCertificateDimensionRawCode word)) + +theorem machineCertificateDimensionBits_mem_FP : + machineCertificateDimensionBits ∈ Complexity.FP := by + simpa only [machineCertificateDimensionBits] using! + machineCompose_mem_FP machineOptimizerMatrixWord_mem_FP + machineMatrixDimensionWord_mem_FP + +theorem machineCertificateDimensionUnary_mem_FP : + machineCertificateDimensionUnary ∈ Complexity.FP := by + simpa only [machineCertificateDimensionUnary] using! + machineCompose_mem_FP machineOptimizerMatrixWord_mem_FP + machineMatrixDimensionUnary_mem_FP + +theorem machineCertificateLogPrecisionRuler_mem_FP : + machineCertificateLogPrecisionRuler ∈ Complexity.FP := by + exact machineAppend_mem_FP machineCertificateDimensionUnary_mem_FP + (machineConst_mem_FP (List.replicate 400 true)) + +theorem machineCertificateDimensionRawCode_mem_FP : + machineCertificateDimensionRawCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineCertificateDimensionBits_mem_FP + machineNaturalIntegerCode_mem_FP + exact machinePair_mem_FP hnum (machineConst_mem_FP [true]) + +theorem machineCertificateFourDimensionRawCode_mem_FP : + machineCertificateFourDimensionRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawCertificateFour)) + machineCertificateDimensionRawCode_mem_FP + simpa only [machineCertificateFourDimensionRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineCertificateRegularizationScaleRawCode_mem_FP : + machineCertificateRegularizationScaleRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawExplicitXi)) + machineCertificateFourDimensionRawCode_mem_FP + simpa only [machineCertificateRegularizationScaleRawCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineCertificateKKTPenaltyRawCode_mem_FP : + machineCertificateKKTPenaltyRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawExplicitKKTError)) + machineCertificateDimensionRawCode_mem_FP + simpa only [machineCertificateKKTPenaltyRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineCertificateExpLossRawCode_mem_FP : + machineCertificateExpLossRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP + (rawRatBinaryCode rawExplicitExpEvaluationLoss)) + machineCertificateDimensionRawCode_mem_FP + simpa only [machineCertificateExpLossRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +@[simp] theorem machineCertificateDimensionBits_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateDimensionBits + (rationalOptimizerOutputCode ⟨X, R, C⟩) = n.bits := by + simp [machineCertificateDimensionBits] + +@[simp] theorem machineCertificateDimensionUnary_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateDimensionUnary + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + List.replicate n true := by + simp [machineCertificateDimensionUnary] + +@[simp] theorem machineCertificateLogPrecisionRuler_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateLogPrecisionRuler + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + List.replicate (directedCertificatePrecision n) true := by + rw [machineCertificateLogPrecisionRuler, + machineCertificateDimensionUnary_encode] + change List.replicate n true ++ List.replicate 400 true = + List.replicate (n + 400) true + exact (List.replicate_add n 400 true).symm + +@[simp] theorem machineCertificateDimensionRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateDimensionRawCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (RawRat.ofNat n) := by + rw [machineCertificateDimensionRawCode, + machineCertificateDimensionBits_encode, + machineNaturalIntegerCode_natBits] + simp [RawRat.ofNat, rawRatBinaryCode] + +/-- The raw-rational product of four and the natural dimension. -/ +def rawCertificateFourDimension (n : β„•) : RawRat := + rawCertificateFour.mul (RawRat.ofNat n) + +/-- The raw-rational regularization scale obtained by dividing the fixed gain by `4*n`. -/ +def rawCertificateRegularizationScale (n : β„•) : RawRat := + rawExplicitXi.div (rawCertificateFourDimension n) + +/-- The raw-rational KKT penalty, equal to the dimension times the fixed error allowance. -/ +def rawCertificateKKTPenalty (n : β„•) : RawRat := + rawExplicitKKTError.mul (RawRat.ofNat n) + +/-- The raw-rational exponential loss scaled by the dimension. -/ +def rawCertificateExpLoss (n : β„•) : RawRat := + rawExplicitExpEvaluationLoss.mul (RawRat.ofNat n) + +@[simp] theorem machineCertificateFourDimensionRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateFourDimensionRawCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (rawCertificateFourDimension n) := by + rw [machineCertificateFourDimensionRawCode, + machineCertificateDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineCertificateRegularizationScaleRawCode_encode + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) + (R C : Fin n β†’ β„š) : + machineCertificateRegularizationScaleRawCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (rawCertificateRegularizationScale n) := by + rw [machineCertificateRegularizationScaleRawCode, + machineCertificateFourDimensionRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineCertificateKKTPenaltyRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateKKTPenaltyRawCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (rawCertificateKKTPenalty n) := by + rw [machineCertificateKKTPenaltyRawCode, + machineCertificateDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineCertificateExpLossRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineCertificateExpLossRawCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode (rawCertificateExpLoss n) := by + rw [machineCertificateExpLossRawCode, + machineCertificateDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem rawCertificateFour_value : rawCertificateFour.value = 4 := by + simp [rawCertificateFour] + +theorem rawCertificateRegularizationScale_value (n : β„•) : + (rawCertificateRegularizationScale n).value = + explicitRegularizationScale n := by + simp [rawCertificateRegularizationScale, rawCertificateFourDimension, + rawExplicitXi, explicitRegularizationScale, + binaryRatDiv_eq_div, binaryRatMul_eq_mul] + +theorem rawCertificateKKTPenalty_value (n : β„•) : + (rawCertificateKKTPenalty n).value = explicitKKTError * n := by + simp [rawCertificateKKTPenalty, rawExplicitKKTError, + binaryRatMul_eq_mul] + +theorem rawCertificateExpLoss_value (n : β„•) : + (rawCertificateExpLoss n).value = explicitExpEvaluationLoss * n := by + simp [rawCertificateExpLoss, rawExplicitExpEvaluationLoss, + binaryRatMul_eq_mul] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCertifiedPairEligibility.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCertifiedPairEligibility.lean new file mode 100644 index 0000000000..4504ef0da4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCertifiedPairEligibility.lean @@ -0,0 +1,1061 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineFourCoreCost +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryRange +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits + +/-! +# Executable column-pair eligibility + +For a fixed row pair, the certificate asks whether two distinct columns pass +the directed four-core test. This file implements the two bounded scans: +first over the second column for a fixed first column, and then over the first +column. Both loops are driven by the unary matrix dimension, and all state is +clamped on arbitrary bitstrings. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw-rational representation of the fixed pair-eligibility threshold. -/ +def rawExplicitKappa : RawRat := rawRatOfRat explicitKappa + +/-- The constant machine returning the encoded pair-eligibility threshold, independently of its +input. -/ +def machineExplicitKappaRawCode (_word : List Bool) : List Bool := + rawRatBinaryCode rawExplicitKappa + +theorem machineExplicitKappaRawCode_mem_FP : + machineExplicitKappaRawCode ∈ FP := + machineConst_mem_FP (rawRatBinaryCode rawExplicitKappa) + +/-! ## The inner scan: second columns for a fixed first column -/ + +/-- Extract the unary first-row index from a fixed-first-column eligibility query. -/ +def machineFixedAFirstRowRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- The eligibility-query payload following the first-row index. -/ +def machineFixedARest₁ (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the unary second-row index from the eligibility query. -/ +def machineFixedASecondRowRuler (word : List Bool) : List Bool := + machinePairFirst (machineFixedARest₁ word) + +/-- The eligibility-query payload following both row indices. -/ +def machineFixedARestβ‚‚ (word : List Bool) : List Bool := + machinePairSecond (machineFixedARest₁ word) + +/-- Extract the unary first-column index held fixed during the scan. -/ +def machineFixedAFirstColumnRuler (word : List Bool) : List Bool := + machinePairFirst (machineFixedARestβ‚‚ word) + +/-- Extract the optimizer result carried by the eligibility query. -/ +def machineFixedAOptimizerWord (word : List Bool) : List Bool := + machinePairSecond (machineFixedARestβ‚‚ word) + +/-- Recover the matrix-dimension ruler from the query's optimizer result. -/ +def machineFixedADimensionRuler (word : List Bool) : List Bool := + machineCertificateDimensionUnary (machineFixedAOptimizerWord word) + +/-- Encode the range of possible second-column indices using the dimension ruler. -/ +def machineFixedAColumnRange (word : List Bool) : List Bool := + machineUnaryRangeCode (machineFixedADimensionRuler word) + +/-- Package the unprocessed column-list code, found flag, and original eligibility query. -/ +def machineFixedAPack + (remaining found source : List Bool) : List Bool := + pair remaining (pair found source) + +/-- Extract the encoded list of unprocessed second-column candidates. -/ +def machineFixedARemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the accumulated flag recording whether an eligible column pair has been found. -/ +def machineFixedAFound (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the immutable source query from the scan state. -/ +def machineFixedASource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Read the first unprocessed second-column index from the encoded candidate list. -/ +def machineFixedACurrentSecondColumn (state : List Bool) : List Bool := + machineListHead (machineFixedARemaining state) + +/-- Compare the fixed and current column indices by converting their unary lengths to binary +naturals. -/ +def machineFixedAColumnsEqualBit (state : List Bool) : List Bool := + machineBinaryNatEqBit + (pair (machineLengthBits + (machineFixedAFirstColumnRuler (machineFixedASource state))) + (machineLengthBits (machineFixedACurrentSecondColumn state))) + +/-- Negate the equality test for the fixed and current column indices. -/ +def machineFixedAColumnsDistinctBit (state : List Bool) : List Bool := + machineNotBit (machineFixedAColumnsEqualBit state) + +/-- Package both fixed row indices, the fixed and current column indices, and the optimizer +result for four-core cost evaluation. -/ +def machineFixedAFourCoreInput (state : List Bool) : List Bool := + pair (machineFixedAFirstRowRuler (machineFixedASource state)) + (pair (machineFixedASecondRowRuler (machineFixedASource state)) + (pair (machineFixedAFirstColumnRuler (machineFixedASource state)) + (pair (machineFixedACurrentSecondColumn state) + (machineFixedAOptimizerWord (machineFixedASource state))))) + +/-- Compute the directed raw-rational upper bound on the current four-core transfer cost. -/ +def machineFixedAFourCoreRawCode (state : List Bool) : List Bool := + machineDirectedFourCoreCostUpperRawCode + (machineFixedAFourCoreInput state) + +/-- Test whether the computed four-core cost upper bound is at most the fixed eligibility +threshold. -/ +def machineFixedACostPassesBit (state : List Bool) : List Bool := + machineRawRatLeBit + (pair (machineFixedAFourCoreRawCode state) + (rawRatBinaryCode rawExplicitKappa)) + +/-- Accept the current candidate exactly when its column differs from the fixed column and its +cost passes the threshold test. -/ +def machineFixedACandidateBit (state : List Bool) : List Bool := + machineAndBit (machineFixedAColumnsDistinctBit state) + (machineFixedACostPassesBit state) + +/-- A scan-length bound word obtained by pairing the source query with its encoded column range. -/ +def machineFixedAInputBound (word : List Bool) : List Bool := + pair word (machineFixedAColumnRange word) + +/-- Accumulate the current eligibility result by Boolean OR, truncating the result to the +source-derived bound length. -/ +def machineFixedANextFound (state : List Bool) : List Bool := + (machineOrBit (machineFixedAFound state) + (machineFixedACandidateBit state)).take + (machineFixedAInputBound (machineFixedASource state)).length + +/-- Consume one second-column candidate and update the found flag while preserving the source +query. -/ +def machineFixedAProcess (state : List Bool) : List Bool := + machineFixedAPack (machineListTail (machineFixedARemaining state)) + (machineFixedANextFound state) (machineFixedASource state) + +/-- Leave a state with no remaining candidates fixed; otherwise process its next column. -/ +def machineFixedAStep (state : List Bool) : List Bool := + machineIfEmpty (machineFixedARemaining state) state + (machineFixedAProcess state) + +/-- Initialize the eligibility scan with the full column range and a false found flag. -/ +def machineFixedAInit (word : List Bool) : List Bool := + machineFixedAPack (machineFixedAColumnRange word) [false] word + +/-- A uniform scan-state width envelope formed from three copies of the source-derived bound +word. -/ +def machineFixedAWidth (word : List Bool) : List Bool := + let bound := machineFixedAInputBound word + machineFixedAPack bound bound bound + +/-- Run the eligibility scan for the number of columns indicated by the dimension ruler. -/ +def machineFixedAFinalState (word : List Bool) : List Bool := + (machineFixedAStep)^[(machineFixedADimensionRuler word).length] + (machineFixedAInit word) + +/-- One bit indicating whether some second column completes a certified pair +with the fixed first column. -/ +def machineFixedAEligibilityBit (word : List Bool) : List Bool := + machineFixedAFound (machineFixedAFinalState word) + +theorem machineFixedAFirstRowRuler_mem_FP : + machineFixedAFirstRowRuler ∈ FP := machinePairFirst_mem_FP + +theorem machineFixedARest₁_mem_FP : machineFixedARest₁ ∈ FP := + machinePairSecond_mem_FP + +theorem machineFixedASecondRowRuler_mem_FP : + machineFixedASecondRowRuler ∈ FP := by + simpa only [machineFixedASecondRowRuler] using! machineCompose_mem_FP + machineFixedARest₁_mem_FP machinePairFirst_mem_FP + +theorem machineFixedARestβ‚‚_mem_FP : machineFixedARestβ‚‚ ∈ FP := by + simpa only [machineFixedARestβ‚‚] using! machineCompose_mem_FP + machineFixedARest₁_mem_FP machinePairSecond_mem_FP + +theorem machineFixedAFirstColumnRuler_mem_FP : + machineFixedAFirstColumnRuler ∈ FP := by + simpa only [machineFixedAFirstColumnRuler] using! machineCompose_mem_FP + machineFixedARestβ‚‚_mem_FP machinePairFirst_mem_FP + +theorem machineFixedAOptimizerWord_mem_FP : + machineFixedAOptimizerWord ∈ FP := by + simpa only [machineFixedAOptimizerWord] using! machineCompose_mem_FP + machineFixedARestβ‚‚_mem_FP machinePairSecond_mem_FP + +theorem machineFixedADimensionRuler_mem_FP : + machineFixedADimensionRuler ∈ FP := by + simpa only [machineFixedADimensionRuler] using! machineCompose_mem_FP + machineFixedAOptimizerWord_mem_FP machineCertificateDimensionUnary_mem_FP + +theorem machineFixedAColumnRange_mem_FP : machineFixedAColumnRange ∈ FP := by + simpa only [machineFixedAColumnRange] using! machineCompose_mem_FP + machineFixedADimensionRuler_mem_FP machineUnaryRangeCode_mem_FP + +theorem machineFixedARemaining_mem_FP : machineFixedARemaining ∈ FP := + machinePairFirst_mem_FP + +theorem machineFixedAFound_mem_FP : machineFixedAFound ∈ FP := by + simpa only [machineFixedAFound] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineFixedASource_mem_FP : machineFixedASource ∈ FP := by + simpa only [machineFixedASource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineFixedACurrentSecondColumn_mem_FP : + machineFixedACurrentSecondColumn ∈ FP := by + simpa only [machineFixedACurrentSecondColumn] using! machineCompose_mem_FP + machineFixedARemaining_mem_FP machineListHead_mem_FP + +theorem machineFixedAColumnsEqualBit_mem_FP : + machineFixedAColumnsEqualBit ∈ FP := by + have hfirst := machineCompose_mem_FP + (machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedAFirstColumnRuler_mem_FP) machineLengthBits_mem_FP + have hsecond := machineCompose_mem_FP + machineFixedACurrentSecondColumn_mem_FP machineLengthBits_mem_FP + have hinput := machinePair_mem_FP hfirst hsecond + simpa only [machineFixedAColumnsEqualBit] using! machineCompose_mem_FP hinput + machineBinaryNatEqBit_mem_FP + +theorem machineFixedAColumnsDistinctBit_mem_FP : + machineFixedAColumnsDistinctBit ∈ FP := by + exact machineNotBit_mem_FP machineFixedAColumnsEqualBit_mem_FP + +theorem machineFixedAFourCoreInput_mem_FP : + machineFixedAFourCoreInput ∈ FP := by + have hsourceFirst := machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedAFirstRowRuler_mem_FP + have hsourceSecond := machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedASecondRowRuler_mem_FP + have hsourceA := machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedAFirstColumnRuler_mem_FP + have hsourceOptimizer := machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedAOptimizerWord_mem_FP + exact machinePair_mem_FP hsourceFirst + (machinePair_mem_FP hsourceSecond + (machinePair_mem_FP hsourceA + (machinePair_mem_FP machineFixedACurrentSecondColumn_mem_FP + hsourceOptimizer))) + +theorem machineFixedAFourCoreRawCode_mem_FP : + machineFixedAFourCoreRawCode ∈ FP := by + simpa only [machineFixedAFourCoreRawCode] using! machineCompose_mem_FP + machineFixedAFourCoreInput_mem_FP + machineDirectedFourCoreCostUpperRawCode_mem_FP + +theorem machineFixedACostPassesBit_mem_FP : + machineFixedACostPassesBit ∈ FP := by + have hinput := machinePair_mem_FP machineFixedAFourCoreRawCode_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawExplicitKappa)) + simpa only [machineFixedACostPassesBit] using! machineCompose_mem_FP hinput + machineRawRatLeBit_mem_FP + +theorem machineFixedACandidateBit_mem_FP : + machineFixedACandidateBit ∈ FP := + machineAndBit_mem_FP machineFixedAColumnsDistinctBit_mem_FP + machineFixedACostPassesBit_mem_FP + +theorem machineFixedAInputBound_mem_FP : machineFixedAInputBound ∈ FP := + machinePair_mem_FP id_mem_FP machineFixedAColumnRange_mem_FP + +theorem machineFixedANextFound_mem_FP : machineFixedANextFound ∈ FP := by + have hdata := machineOrBit_mem_FP machineFixedAFound_mem_FP + machineFixedACandidateBit_mem_FP + have hbound := machineCompose_mem_FP machineFixedASource_mem_FP + machineFixedAInputBound_mem_FP + simpa only [machineFixedANextFound] using! machineTake_mem_FP hbound hdata + +theorem machineFixedAProcess_mem_FP : machineFixedAProcess ∈ FP := by + have htail := machineCompose_mem_FP machineFixedARemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineFixedANextFound_mem_FP + machineFixedASource_mem_FP) + +theorem machineFixedAStep_mem_FP : machineFixedAStep ∈ FP := by + simpa only [machineFixedAStep] using! machineIfEmpty_mem_FP + machineFixedARemaining_mem_FP id_mem_FP machineFixedAProcess_mem_FP + +theorem machineFixedAInit_mem_FP : machineFixedAInit ∈ FP := + machinePair_mem_FP machineFixedAColumnRange_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP) + +theorem machineFixedAWidth_mem_FP : machineFixedAWidth ∈ FP := by + exact machinePair_mem_FP machineFixedAInputBound_mem_FP + (machinePair_mem_FP machineFixedAInputBound_mem_FP + machineFixedAInputBound_mem_FP) + +@[simp] theorem machineFixedARemaining_pack (remaining found source) : + machineFixedARemaining (machineFixedAPack remaining found source) = + remaining := by simp [machineFixedARemaining, machineFixedAPack] + +@[simp] theorem machineFixedAFound_pack (remaining found source) : + machineFixedAFound (machineFixedAPack remaining found source) = found := by + simp [machineFixedAFound, machineFixedAPack] + +@[simp] theorem machineFixedASource_pack (remaining found source) : + machineFixedASource (machineFixedAPack remaining found source) = source := by + simp [machineFixedASource, machineFixedAPack] + +/-- The scan has its canonical three-field layout, bounded remaining and found words, and the +original source query unchanged. -/ +def MachineFixedAStateBound (word state : List Bool) : Prop := + let B := (machineFixedAInputBound word).length + state = machineFixedAPack (machineFixedARemaining state) + (machineFixedAFound state) (machineFixedASource state) ∧ + (machineFixedARemaining state).length ≀ B ∧ + (machineFixedAFound state).length ≀ B ∧ + machineFixedASource state = word + +theorem machineFixedAInput_le_bound (word : List Bool) : + word.length ≀ (machineFixedAInputBound word).length := by + simpa only [machineFixedAInputBound, machinePairFirst_pair] using! + machinePairFirst_length_le (pair word (machineFixedAColumnRange word)) + +theorem machineFixedARange_le_bound (word : List Bool) : + (machineFixedAColumnRange word).length ≀ + (machineFixedAInputBound word).length := by + simpa only [machineFixedAInputBound, machinePairSecond_pair] using! + machinePairSecond_length_le (pair word (machineFixedAColumnRange word)) + +theorem machineFixedA_one_le_bound (word : List Bool) : + 1 ≀ (machineFixedAInputBound word).length := by + simp only [machineFixedAInputBound, pair_length] + omega + +theorem machineFixedAInit_bound (word : List Bool) : + MachineFixedAStateBound word (machineFixedAInit word) := by + simp only [MachineFixedAStateBound, machineFixedAInit, + machineFixedARemaining_pack, machineFixedAFound_pack, + machineFixedASource_pack] + exact ⟨trivial, machineFixedARange_le_bound word, + machineFixedA_one_le_bound word, trivial⟩ + +theorem machineFixedAStep_bound {word state : List Bool} + (hstate : MachineFixedAStateBound word state) : + MachineFixedAStateBound word (machineFixedAStep state) := by + rcases hstate with ⟨hpack, hremaining, hfound, hsource⟩ + by_cases hrem : machineFixedARemaining state = [] + Β· rw [machineFixedAStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hfound, hsource⟩ + Β· rw [machineFixedAStep] + cases hcode : machineFixedARemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineFixedAProcess] + simp only [MachineFixedAStateBound, machineFixedARemaining_pack, + machineFixedAFound_pack, machineFixedASource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineFixedARemaining state)).trans hremaining + Β· simp only [machineFixedANextFound, List.length_take] + rw [hsource] + exact Nat.min_le_left _ _ + +theorem machineFixedAIterate_bound (word : List Bool) : βˆ€ k, + MachineFixedAStateBound word + ((machineFixedAStep)^[k] (machineFixedAInit word)) := by + intro k + induction k with + | zero => exact machineFixedAInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineFixedAStep_bound ih + +theorem machineFixedAIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineFixedADimensionRuler word).length) : + ((machineFixedAStep)^[iterations] (machineFixedAInit word)).length ≀ + (machineFixedAWidth word).length := by + have h := machineFixedAIterate_bound word iterations + rcases h with ⟨hpack, hremaining, hfound, hsource⟩ + rw [hpack] + simp only [machineFixedAPack, machineFixedAWidth, pair_length] + have hsourceLength : (machineFixedASource + ((machineFixedAStep)^[iterations] (machineFixedAInit word))).length ≀ + (machineFixedAInputBound word).length := by + rw [hsource] + exact machineFixedAInput_le_bound word + omega + +theorem machineFixedAFinalState_mem_FP : machineFixedAFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineFixedAStep_mem_FP + machineFixedAInit_mem_FP machineFixedADimensionRuler_mem_FP + machineFixedAWidth_mem_FP machineFixedAIterate_length_le_width + +theorem machineFixedAEligibilityBit_mem_FP : + machineFixedAEligibilityBit ∈ FP := by + simpa only [machineFixedAEligibilityBit] using! machineCompose_mem_FP + machineFixedAFinalState_mem_FP machineFixedAFound_mem_FP + +/-! ## Exact inner-scan semantics -/ + +/-- Encode a fixed-column eligibility query from the rational optimizer data and three unary +row/column indices. -/ +def fixedAMachineInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) : List Bool := + pair (finUnaryCode r) + (pair (finUnaryCode s) + (pair (finUnaryCode a) (rationalOptimizerOutputCode ⟨X, R, C⟩))) + +/-- The semantic Boolean test for distinct columns whose directed four-core cost upper bound is +at most `explicitKappa`. -/ +def certifiedColumnPairTest {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s a b : Fin n) : Bool := + decide (a β‰  b ∧ + directedFourCoreCostUpper (explicitRegularizationScale n) X r s a b + (directedPairCostPrecision n) ≀ explicitKappa) + +@[simp] theorem machineFixedAColumnsDistinctBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) (found : Bool) (bs : List (Fin n)) : + machineFixedAColumnsDistinctBit + (machineFixedAPack (binaryListCode finUnaryCode (b :: bs)) [found] + (fixedAMachineInput X R C r s a)) = + [decide (a β‰  b)] := by + rw [machineFixedAColumnsDistinctBit, machineFixedAColumnsEqualBit] + simp only [machineFixedASource_pack, machineFixedARemaining_pack, + machineFixedACurrentSecondColumn, machineListHead_cons, + machineFixedAFirstColumnRuler, fixedAMachineInput, + machineFixedARest₁, machineFixedARestβ‚‚, + machinePairFirst_pair, machinePairSecond_pair, + machineLengthBits_encode, finUnaryCode, List.length_replicate, + machineBinaryNatEqBit_pair_natBits, machineNotBit_one] + by_cases hval : a.1 = b.1 + Β· have hab : a = b := Fin.ext hval + simp [hval, hab] + Β· have hab : a β‰  b := fun h ↦ hval (congrArg Fin.val h) + simp [hval, hab] + +@[simp] theorem machineFixedAFourCoreRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) (found : Bool) (bs : List (Fin n)) : + machineFixedAFourCoreRawCode + (machineFixedAPack (binaryListCode finUnaryCode (b :: bs)) [found] + (fixedAMachineInput X R C r s a)) = + rawRatBinaryCode (rawDirectedFourCoreCostUpper X r s a b) := by + simp [machineFixedAFourCoreRawCode, machineFixedAFourCoreInput, + machineFixedASource, machineFixedARemaining, + machineFixedACurrentSecondColumn, machineFixedAFirstRowRuler, + machineFixedASecondRowRuler, machineFixedAFirstColumnRuler, + machineFixedAOptimizerWord, machineFixedARest₁, machineFixedARestβ‚‚, + machineFixedAPack, fixedAMachineInput] + change machineDirectedFourCoreCostUpperRawCode + (fourCoreMachineInput X R C r s a b) = _ + exact machineDirectedFourCoreCostUpperRawCode_encode X R C r s a b + +@[simp] theorem machineFixedACostPassesBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) (found : Bool) (bs : List (Fin n)) : + machineFixedACostPassesBit + (machineFixedAPack (binaryListCode finUnaryCode (b :: bs)) [found] + (fixedAMachineInput X R C r s a)) = + [decide (directedFourCoreCostUpper (explicitRegularizationScale n) X + r s a b (directedPairCostPrecision n) ≀ explicitKappa)] := by + rw [machineFixedACostPassesBit, + machineFixedAFourCoreRawCode_encode] + change machineRawRatLeBit + (pair (rawRatBinaryCode (rawDirectedFourCoreCostUpper X r s a b)) + (rawRatBinaryCode rawExplicitKappa)) = _ + rw [machineRawRatLeBit_encode, rawDirectedFourCoreCostUpper_value] + simp only [rawExplicitKappa, rawRatOfRat_value] + +@[simp] theorem machineFixedADimensionRuler_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) : + machineFixedADimensionRuler (fixedAMachineInput X R C r s a) = + List.replicate n true := by + simp [machineFixedADimensionRuler, fixedAMachineInput, + machineFixedAOptimizerWord, machineFixedARest₁, machineFixedARestβ‚‚] + +@[simp] theorem machineFixedAColumnRange_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) : + machineFixedAColumnRange (fixedAMachineInput X R C r s a) = + finRangeUnaryCode n := by + rw [machineFixedAColumnRange, machineFixedADimensionRuler_encode, + machineUnaryRangeCode_encode] + +@[simp] theorem machineFixedACandidateBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) (found : Bool) (bs : List (Fin n)) : + machineFixedACandidateBit + (machineFixedAPack (binaryListCode finUnaryCode (b :: bs)) [found] + (fixedAMachineInput X R C r s a)) = + [certifiedColumnPairTest X r s a b] := by + rw [machineFixedACandidateBit, machineFixedAColumnsDistinctBit_encode, + machineFixedACostPassesBit_encode, machineAndBit_one] + simp only [certifiedColumnPairTest] + by_cases hdistinct : a β‰  b <;> + by_cases hcost : directedFourCoreCostUpper (explicitRegularizationScale n) + X r s a b (directedPairCostPrecision n) ≀ explicitKappa <;> + simp [hdistinct, hcost] + +/-- Test whether any of the first `k` columns in the canonical finite enumeration passes the +fixed-column eligibility test. -/ +def fixedAScanFound {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s a : Fin n) (k : β„•) : Bool := + ((List.finRange n).take k).any (certifiedColumnPairTest X r s a) + +/-- The canonical scan state after `k` candidates: the remaining column suffix, the accumulated +semantic test result, and the original query. -/ +def machineFixedASemanticState {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) (k : β„•) : List Bool := + machineFixedAPack + (binaryListCode finUnaryCode ((List.finRange n).drop k)) + [fixedAScanFound X r s a k] (fixedAMachineInput X R C r s a) + +@[simp] theorem machineFixedASemanticState_zero {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) : + machineFixedASemanticState X R C r s a 0 = + machineFixedAInit (fixedAMachineInput X R C r s a) := by + simp [machineFixedASemanticState, machineFixedAInit, fixedAScanFound, + machineFixedAColumnRange_encode, finRangeUnaryCode] + +theorem machineFixedASemanticState_step {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) (k : β„•) (hk : k < n) : + machineFixedAStep (machineFixedASemanticState X R C r s a k) = + machineFixedASemanticState X R C r s a (k + 1) := by + have hklen : k < (List.finRange n).length := by simpa using! hk + rw [machineFixedASemanticState, + List.drop_eq_getElem_cons hklen] + rw [machineFixedAStep] + simp only [machineFixedARemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil finUnaryCode (List.finRange n)[k] + ((List.finRange n).drop (k + 1)))] + rw [machineFixedAProcess] + simp only [machineFixedARemaining_pack, machineListTail_cons, + machineFixedASource_pack, machineFixedANextFound, + machineFixedAFound_pack, machineFixedACandidateBit_encode, + machineOrBit_one] + have hbound : 1 ≀ + (machineFixedAInputBound (fixedAMachineInput X R C r s a)).length := + machineFixedA_one_le_bound _ + rw [(List.take_eq_self_iff _).2 (by simpa using! hbound)] + rw [machineFixedASemanticState] + apply congrArg (fun z : Bool ↦ + machineFixedAPack + (binaryListCode finUnaryCode ((List.finRange n).drop (k + 1))) [z] + (fixedAMachineInput X R C r s a)) + rw [fixedAScanFound, fixedAScanFound, + ← List.take_concat_get hklen, List.concat_eq_append, List.any_append] + simp + +theorem machineFixedAIterate_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) (k : β„•) (hk : k ≀ n) : + (machineFixedAStep)^[k] (machineFixedAInit + (fixedAMachineInput X R C r s a)) = + machineFixedASemanticState X R C r s a k := by + induction k with + | zero => exact (machineFixedASemanticState_zero X R C r s a).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega), + machineFixedASemanticState_step X R C r s a k (by omega)] + +@[simp] theorem machineFixedAEligibilityBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) : + machineFixedAEligibilityBit (fixedAMachineInput X R C r s a) = + [(List.finRange n).any (certifiedColumnPairTest X r s a)] := by + rw [machineFixedAEligibilityBit, machineFixedAFinalState, + machineFixedADimensionRuler_encode, List.length_replicate, + machineFixedAIterate_semantics X R C r s a n le_rfl, + machineFixedASemanticState, machineFixedAFound_pack, fixedAScanFound] + rw [(List.take_eq_self_iff _).2 (by simp)] + +/-! ## The outer scan: first columns for a fixed row pair -/ + +/-- Extracts the unary first-row index from a row-pair eligibility query. -/ +def machineRowPairFirstRowRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the second-row index and optimizer payload from the row-pair query. -/ +def machineRowPairRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary second-row index from the eligibility query. -/ +def machineRowPairSecondRowRuler (word : List Bool) : List Bool := + machinePairFirst (machineRowPairRest word) + +/-- Extracts the optimizer matrix and potentials carried by the row-pair query. -/ +def machineRowPairOptimizerWord (word : List Bool) : List Bool := + machinePairSecond (machineRowPairRest word) + +/-- Recovers the matrix-dimension ruler from the query's optimizer result. -/ +def machineRowPairDimensionRuler (word : List Bool) : List Bool := + machineCertificateDimensionUnary (machineRowPairOptimizerWord word) + +/-- Encodes the range of possible first-column indices for the outer eligibility scan. -/ +def machineRowPairColumnRange (word : List Bool) : List Bool := + machineUnaryRangeCode (machineRowPairDimensionRuler word) + +/-- Encodes an outer scan state as remaining first-column candidates, found flag, and source +query. -/ +def machineRowPairScanPack + (remaining found source : List Bool) : List Bool := + pair remaining (pair found source) + +/-- Extracts the encoded list of unprocessed first-column candidates. -/ +def machineRowPairScanRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the flag recording whether an eligible column pair has been found. -/ +def machineRowPairScanFound (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the immutable row-pair query from the scan state. -/ +def machineRowPairScanSource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the first unprocessed first-column index from the encoded candidate list. -/ +def machineRowPairCurrentFirstColumn (state : List Bool) : List Bool := + machineListHead (machineRowPairScanRemaining state) + +/-- Builds the inner eligibility query with the current first column fixed. -/ +def machineRowPairFixedAInput (state : List Bool) : List Bool := + pair (machineRowPairFirstRowRuler (machineRowPairScanSource state)) + (pair (machineRowPairSecondRowRuler (machineRowPairScanSource state)) + (pair (machineRowPairCurrentFirstColumn state) + (machineRowPairOptimizerWord (machineRowPairScanSource state)))) + +/-- Runs the fixed-first-column eligibility test for the current outer-scan candidate. -/ +def machineRowPairCandidateBit (state : List Bool) : List Bool := + machineFixedAEligibilityBit (machineRowPairFixedAInput state) + +/-- Pairs the row-pair query with its encoded column range to bound the scan state. -/ +def machineRowPairInputBound (word : List Bool) : List Bool := + pair word (machineRowPairColumnRange word) + +/-- Combines the previous found flag with the current result and truncates to the source-derived +bound. -/ +def machineRowPairNextFound (state : List Bool) : List Bool := + (machineOrBit (machineRowPairScanFound state) + (machineRowPairCandidateBit state)).take + (machineRowPairInputBound (machineRowPairScanSource state)).length + +/-- Consumes the current first-column candidate and updates the found flag. -/ +def machineRowPairProcess (state : List Bool) : List Bool := + machineRowPairScanPack + (machineListTail (machineRowPairScanRemaining state)) + (machineRowPairNextFound state) (machineRowPairScanSource state) + +/-- Processes the next first-column candidate, leaving an exhausted scan state fixed. -/ +def machineRowPairScanStep (state : List Bool) : List Bool := + machineIfEmpty (machineRowPairScanRemaining state) state + (machineRowPairProcess state) + +/-- Initializes the outer eligibility scan with all first-column candidates and a false found +flag. -/ +def machineRowPairScanInit (word : List Bool) : List Bool := + machineRowPairScanPack (machineRowPairColumnRange word) [false] word + +/-- Packs three copies of the source-derived bound to bound the encoded outer scan state. -/ +def machineRowPairScanWidth (word : List Bool) : List Bool := + let bound := machineRowPairInputBound word + machineRowPairScanPack bound bound bound + +/-- Runs the outer scan for the number of columns specified by the dimension ruler. -/ +def machineRowPairScanFinalState (word : List Bool) : List Bool := + (machineRowPairScanStep)^[(machineRowPairDimensionRuler word).length] + (machineRowPairScanInit word) + +/-- One-bit result of the complete existential column-pair scan. -/ +def machineCertifiedRowPairEligibilityBit (word : List Bool) : List Bool := + machineRowPairScanFound (machineRowPairScanFinalState word) + +theorem machineRowPairFirstRowRuler_mem_FP : + machineRowPairFirstRowRuler ∈ FP := machinePairFirst_mem_FP + +theorem machineRowPairRest_mem_FP : machineRowPairRest ∈ FP := + machinePairSecond_mem_FP + +theorem machineRowPairSecondRowRuler_mem_FP : + machineRowPairSecondRowRuler ∈ FP := by + simpa only [machineRowPairSecondRowRuler] using! machineCompose_mem_FP + machineRowPairRest_mem_FP machinePairFirst_mem_FP + +theorem machineRowPairOptimizerWord_mem_FP : + machineRowPairOptimizerWord ∈ FP := by + simpa only [machineRowPairOptimizerWord] using! machineCompose_mem_FP + machineRowPairRest_mem_FP machinePairSecond_mem_FP + +theorem machineRowPairDimensionRuler_mem_FP : + machineRowPairDimensionRuler ∈ FP := by + simpa only [machineRowPairDimensionRuler] using! machineCompose_mem_FP + machineRowPairOptimizerWord_mem_FP machineCertificateDimensionUnary_mem_FP + +theorem machineRowPairColumnRange_mem_FP : machineRowPairColumnRange ∈ FP := by + simpa only [machineRowPairColumnRange] using! machineCompose_mem_FP + machineRowPairDimensionRuler_mem_FP machineUnaryRangeCode_mem_FP + +theorem machineRowPairScanRemaining_mem_FP : + machineRowPairScanRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineRowPairScanFound_mem_FP : machineRowPairScanFound ∈ FP := by + simpa only [machineRowPairScanFound] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRowPairScanSource_mem_FP : machineRowPairScanSource ∈ FP := by + simpa only [machineRowPairScanSource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRowPairCurrentFirstColumn_mem_FP : + machineRowPairCurrentFirstColumn ∈ FP := by + simpa only [machineRowPairCurrentFirstColumn] using! machineCompose_mem_FP + machineRowPairScanRemaining_mem_FP machineListHead_mem_FP + +theorem machineRowPairFixedAInput_mem_FP : + machineRowPairFixedAInput ∈ FP := by + have hfirst := machineCompose_mem_FP machineRowPairScanSource_mem_FP + machineRowPairFirstRowRuler_mem_FP + have hsecond := machineCompose_mem_FP machineRowPairScanSource_mem_FP + machineRowPairSecondRowRuler_mem_FP + have hoptimizer := machineCompose_mem_FP machineRowPairScanSource_mem_FP + machineRowPairOptimizerWord_mem_FP + exact machinePair_mem_FP hfirst + (machinePair_mem_FP hsecond + (machinePair_mem_FP machineRowPairCurrentFirstColumn_mem_FP hoptimizer)) + +theorem machineRowPairCandidateBit_mem_FP : + machineRowPairCandidateBit ∈ FP := by + simpa only [machineRowPairCandidateBit] using! machineCompose_mem_FP + machineRowPairFixedAInput_mem_FP machineFixedAEligibilityBit_mem_FP + +theorem machineRowPairInputBound_mem_FP : machineRowPairInputBound ∈ FP := + machinePair_mem_FP id_mem_FP machineRowPairColumnRange_mem_FP + +theorem machineRowPairNextFound_mem_FP : machineRowPairNextFound ∈ FP := by + have hdata := machineOrBit_mem_FP machineRowPairScanFound_mem_FP + machineRowPairCandidateBit_mem_FP + have hbound := machineCompose_mem_FP machineRowPairScanSource_mem_FP + machineRowPairInputBound_mem_FP + simpa only [machineRowPairNextFound] using! machineTake_mem_FP hbound hdata + +theorem machineRowPairProcess_mem_FP : machineRowPairProcess ∈ FP := by + have htail := machineCompose_mem_FP machineRowPairScanRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRowPairNextFound_mem_FP + machineRowPairScanSource_mem_FP) + +theorem machineRowPairScanStep_mem_FP : machineRowPairScanStep ∈ FP := by + simpa only [machineRowPairScanStep] using! machineIfEmpty_mem_FP + machineRowPairScanRemaining_mem_FP id_mem_FP machineRowPairProcess_mem_FP + +theorem machineRowPairScanInit_mem_FP : machineRowPairScanInit ∈ FP := + machinePair_mem_FP machineRowPairColumnRange_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP) + +theorem machineRowPairScanWidth_mem_FP : machineRowPairScanWidth ∈ FP := + machinePair_mem_FP machineRowPairInputBound_mem_FP + (machinePair_mem_FP machineRowPairInputBound_mem_FP + machineRowPairInputBound_mem_FP) + +@[simp] theorem machineRowPairScanRemaining_pack (remaining found source) : + machineRowPairScanRemaining + (machineRowPairScanPack remaining found source) = remaining := by + simp [machineRowPairScanRemaining, machineRowPairScanPack] + +@[simp] theorem machineRowPairScanFound_pack (remaining found source) : + machineRowPairScanFound + (machineRowPairScanPack remaining found source) = found := by + simp [machineRowPairScanFound, machineRowPairScanPack] + +@[simp] theorem machineRowPairScanSource_pack (remaining found source) : + machineRowPairScanSource + (machineRowPairScanPack remaining found source) = source := by + simp [machineRowPairScanSource, machineRowPairScanPack] + +/-- Bounds the packed state's remaining-candidate and flag lengths while preserving the source +query. -/ +def MachineRowPairScanStateBound (word state : List Bool) : Prop := + let B := (machineRowPairInputBound word).length + state = machineRowPairScanPack (machineRowPairScanRemaining state) + (machineRowPairScanFound state) (machineRowPairScanSource state) ∧ + (machineRowPairScanRemaining state).length ≀ B ∧ + (machineRowPairScanFound state).length ≀ B ∧ + machineRowPairScanSource state = word + +theorem machineRowPairInput_le_bound (word : List Bool) : + word.length ≀ (machineRowPairInputBound word).length := by + simpa only [machineRowPairInputBound, machinePairFirst_pair] using! + machinePairFirst_length_le (pair word (machineRowPairColumnRange word)) + +theorem machineRowPairRange_le_bound (word : List Bool) : + (machineRowPairColumnRange word).length ≀ + (machineRowPairInputBound word).length := by + simpa only [machineRowPairInputBound, machinePairSecond_pair] using! + machinePairSecond_length_le (pair word (machineRowPairColumnRange word)) + +theorem machineRowPair_one_le_bound (word : List Bool) : + 1 ≀ (machineRowPairInputBound word).length := by + simp only [machineRowPairInputBound, pair_length] + omega + +theorem machineRowPairScanInit_bound (word : List Bool) : + MachineRowPairScanStateBound word (machineRowPairScanInit word) := by + simp only [MachineRowPairScanStateBound, machineRowPairScanInit, + machineRowPairScanRemaining_pack, machineRowPairScanFound_pack, + machineRowPairScanSource_pack] + exact ⟨trivial, machineRowPairRange_le_bound word, + machineRowPair_one_le_bound word, trivial⟩ + +theorem machineRowPairScanStep_bound {word state : List Bool} + (hstate : MachineRowPairScanStateBound word state) : + MachineRowPairScanStateBound word (machineRowPairScanStep state) := by + rcases hstate with ⟨hpack, hremaining, hfound, hsource⟩ + by_cases hrem : machineRowPairScanRemaining state = [] + Β· rw [machineRowPairScanStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hfound, hsource⟩ + Β· rw [machineRowPairScanStep] + cases hcode : machineRowPairScanRemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineRowPairProcess] + simp only [MachineRowPairScanStateBound, + machineRowPairScanRemaining_pack, machineRowPairScanFound_pack, + machineRowPairScanSource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineRowPairScanRemaining state)).trans hremaining + Β· simp only [machineRowPairNextFound, List.length_take] + rw [hsource] + exact Nat.min_le_left _ _ + +theorem machineRowPairScanIterate_bound (word : List Bool) : βˆ€ k, + MachineRowPairScanStateBound word + ((machineRowPairScanStep)^[k] (machineRowPairScanInit word)) := by + intro k + induction k with + | zero => exact machineRowPairScanInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRowPairScanStep_bound ih + +theorem machineRowPairScanIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineRowPairDimensionRuler word).length) : + ((machineRowPairScanStep)^[iterations] + (machineRowPairScanInit word)).length ≀ + (machineRowPairScanWidth word).length := by + have h := machineRowPairScanIterate_bound word iterations + rcases h with ⟨hpack, hremaining, hfound, hsource⟩ + have hsourceLength : (machineRowPairScanSource + ((machineRowPairScanStep)^[iterations] + (machineRowPairScanInit word))).length ≀ + (machineRowPairInputBound word).length := by + rw [hsource] + exact machineRowPairInput_le_bound word + rw [hpack] + simp only [machineRowPairScanPack, machineRowPairScanWidth, pair_length] + omega + +theorem machineRowPairScanFinalState_mem_FP : + machineRowPairScanFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRowPairScanStep_mem_FP + machineRowPairScanInit_mem_FP machineRowPairDimensionRuler_mem_FP + machineRowPairScanWidth_mem_FP + machineRowPairScanIterate_length_le_width + +theorem machineCertifiedRowPairEligibilityBit_mem_FP : + machineCertifiedRowPairEligibilityBit ∈ FP := by + simpa only [machineCertifiedRowPairEligibilityBit] using! + machineCompose_mem_FP machineRowPairScanFinalState_mem_FP + machineRowPairScanFound_mem_FP + +/-! ## Exact outer-scan semantics -/ + +/-- Encodes a matrix, its row and column potentials, and the two row indices for eligibility +testing. -/ +def certifiedRowPairMachineInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) : List Bool := + pair (finUnaryCode r) + (pair (finUnaryCode s) (rationalOptimizerOutputCode ⟨X, R, C⟩)) + +/-- Tests whether some distinct second column meets the certified cost threshold for a fixed +first column. -/ +def certifiedFirstColumnTest {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s a : Fin n) : Bool := + (List.finRange n).any (certifiedColumnPairTest X r s a) + +/-- Tests whether some column pair meets the certified cost threshold for the two given rows. -/ +def certifiedRowPairEligibilityTest {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s : Fin n) : Bool := + (List.finRange n).any (certifiedFirstColumnTest X r s) + +@[simp] theorem machineRowPairDimensionRuler_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) : + machineRowPairDimensionRuler (certifiedRowPairMachineInput X R C r s) = + List.replicate n true := by + simp [machineRowPairDimensionRuler, machineRowPairOptimizerWord, + machineRowPairRest, certifiedRowPairMachineInput] + +@[simp] theorem machineRowPairColumnRange_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) : + machineRowPairColumnRange (certifiedRowPairMachineInput X R C r s) = + finRangeUnaryCode n := by + rw [machineRowPairColumnRange, machineRowPairDimensionRuler_encode, + machineUnaryRangeCode_encode] + +@[simp] theorem machineRowPairCandidateBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a : Fin n) (found : Bool) (as : List (Fin n)) : + machineRowPairCandidateBit + (machineRowPairScanPack + (binaryListCode finUnaryCode (a :: as)) [found] + (certifiedRowPairMachineInput X R C r s)) = + [certifiedFirstColumnTest X r s a] := by + simp [machineRowPairCandidateBit, machineRowPairFixedAInput, + machineRowPairScanSource, machineRowPairScanRemaining, + machineRowPairCurrentFirstColumn, machineRowPairFirstRowRuler, + machineRowPairSecondRowRuler, machineRowPairOptimizerWord, + machineRowPairRest, machineRowPairScanPack, + certifiedRowPairMachineInput, + certifiedFirstColumnTest] + change machineFixedAEligibilityBit (fixedAMachineInput X R C r s a) = _ + exact machineFixedAEligibilityBit_encode X R C r s a + +/-- Tests whether any of the first `k` first-column candidates yields an eligible column pair. -/ +def outerScanFound {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s : Fin n) (k : β„•) : Bool := + ((List.finRange n).take k).any (certifiedFirstColumnTest X r s) + +/-- Encodes the outer scan after `k` candidates with the remaining columns and accumulated test +result. -/ +def machineRowPairSemanticState {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) (k : β„•) : List Bool := + machineRowPairScanPack + (binaryListCode finUnaryCode ((List.finRange n).drop k)) + [outerScanFound X r s k] (certifiedRowPairMachineInput X R C r s) + +@[simp] theorem machineRowPairSemanticState_zero {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) : + machineRowPairSemanticState X R C r s 0 = + machineRowPairScanInit (certifiedRowPairMachineInput X R C r s) := by + simp [machineRowPairSemanticState, machineRowPairScanInit, outerScanFound, + machineRowPairColumnRange_encode, finRangeUnaryCode] + +theorem machineRowPairSemanticState_step {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) (k : β„•) (hk : k < n) : + machineRowPairScanStep (machineRowPairSemanticState X R C r s k) = + machineRowPairSemanticState X R C r s (k + 1) := by + have hklen : k < (List.finRange n).length := by simpa using! hk + rw [machineRowPairSemanticState, List.drop_eq_getElem_cons hklen, + machineRowPairScanStep] + simp only [machineRowPairScanRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil finUnaryCode (List.finRange n)[k] + ((List.finRange n).drop (k + 1)))] + rw [machineRowPairProcess] + simp only [machineRowPairScanRemaining_pack, machineListTail_cons, + machineRowPairScanSource_pack, machineRowPairNextFound, + machineRowPairScanFound_pack, machineRowPairCandidateBit_encode, + machineOrBit_one] + have hbound : 1 ≀ (machineRowPairInputBound + (certifiedRowPairMachineInput X R C r s)).length := + machineRowPair_one_le_bound _ + rw [(List.take_eq_self_iff _).2 (by simpa using! hbound), + machineRowPairSemanticState] + apply congrArg (fun z : Bool ↦ + machineRowPairScanPack + (binaryListCode finUnaryCode ((List.finRange n).drop (k + 1))) [z] + (certifiedRowPairMachineInput X R C r s)) + rw [outerScanFound, outerScanFound, + ← List.take_concat_get hklen, List.concat_eq_append, List.any_append] + simp + +theorem machineRowPairScanIterate_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) (k : β„•) (hk : k ≀ n) : + (machineRowPairScanStep)^[k] (machineRowPairScanInit + (certifiedRowPairMachineInput X R C r s)) = + machineRowPairSemanticState X R C r s k := by + induction k with + | zero => exact (machineRowPairSemanticState_zero X R C r s).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega), + machineRowPairSemanticState_step X R C r s k (by omega)] + +@[simp] theorem machineCertifiedRowPairEligibilityBit_rows_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s : Fin n) : + machineCertifiedRowPairEligibilityBit + (certifiedRowPairMachineInput X R C r s) = + [certifiedRowPairEligibilityTest X r s] := by + rw [machineCertifiedRowPairEligibilityBit, machineRowPairScanFinalState, + machineRowPairDimensionRuler_encode, List.length_replicate, + machineRowPairScanIterate_semantics X R C r s n le_rfl, + machineRowPairSemanticState, machineRowPairScanFound_pack, outerScanFound, + (List.take_eq_self_iff _).2 (by simp)] + rfl + +theorem certifiedRowPairEligibilityTest_eq_true_iff {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s : Fin n) : + certifiedRowPairEligibilityTest X r s = true ↔ + βˆƒ a b : Fin n, a β‰  b ∧ + directedFourCoreCostUpper (explicitRegularizationScale n) X r s a b + (directedPairCostPrecision n) ≀ explicitKappa := by + rw [certifiedRowPairEligibilityTest, List.any_eq_true] + constructor + Β· rintro ⟨a, ha, hinner⟩ + rw [certifiedFirstColumnTest, List.any_eq_true] at hinner + obtain ⟨b, hb, htest⟩ := hinner + refine ⟨a, b, ?_⟩ + simpa only [certifiedColumnPairTest, decide_eq_true_eq] using! htest + Β· rintro ⟨a, b, hab, hcost⟩ + refine ⟨a, by simp, ?_⟩ + rw [certifiedFirstColumnTest, List.any_eq_true] + refine ⟨b, by simp, ?_⟩ + simp [certifiedColumnPairTest, hab, hcost] + +/-- Builds an eligibility query from the two rows of a `RowPair` and the optimizer result. -/ +def certifiedRowPairEligibilityMachineInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (q : RowPair n) : List Bool := + certifiedRowPairMachineInput X R C (rowPairRow q 0) (rowPairRow q 1) + +@[simp] theorem machineCertifiedRowPairEligibilityBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (q : RowPair n) : + machineCertifiedRowPairEligibilityBit + (certifiedRowPairEligibilityMachineInput X R C q) = + [decide (HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) q)] := by + rw [certifiedRowPairEligibilityMachineInput, + machineCertifiedRowPairEligibilityBit_rows_encode] + apply congrArg List.singleton + apply (Bool.eq_iff_iff).2 + rw [certifiedRowPairEligibilityTest_eq_true_iff, decide_eq_true_eq] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineCompletedAlgorithm.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineCompletedAlgorithm.lean new file mode 100644 index 0000000000..6cf7f259e8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineCompletedAlgorithm.lean @@ -0,0 +1,476 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineFinalScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachinePerfectMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothedMatrix +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales + +/-! +# Finite-word outer wrapper for the completed permanent algorithm + +This module closes every branch and final scalar operation in +`completedAlgorithm`. It is parameterized by one internal machine for the +positive-matrix routine. That internal machine returns an unreduced rational +word, allowing the verified rational arithmetic layer to consume its result. +The executable development later supplies this parameter with the concrete +regularized-Bethe optimizer and certificate machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Internal realization relation for a rational-matrix algorithm whose +machine output is a raw numerator/denominator pair rather than the public +one-natural rational encoding. -/ +def RawStringRealizes + (F : List Bool β†’ List Bool) + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) : Prop := + βˆ€ x : RationalMatrixInput, + F (rationalMatrixBinaryEncoding.encode x) = + rawRatBinaryCode (rawRatOfRat (bundledAlgorithm alg x)) + +/-- Correctness relation needed of an internal positive-matrix routine. The +outer smoothing wrapper calls it only on strictly positive matrices, so no +semantic requirement is imposed on its totalized behavior elsewhere. -/ +def PositiveRawStringRealizes + (F : List Bool β†’ List Bool) + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) : Prop := + βˆ€ (n : β„•) (A : Matrix (Fin n) (Fin n) β„š), + Matrix.Positive (fun i j ↦ (A i j : ℝ)) β†’ + F (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawRatOfRat (alg n A)) + +/-- Tests whether the encoded matrix dimension is less than two. -/ +def machineCompletedDimensionLtTwoBit (word : List Bool) : List Bool := + machineBinaryNatLtBit + (pair (machineMatrixDimensionWord word) (2 : β„•).bits) + +/-- Encodes the matrix obtained by smoothing the input with rational parameter `Ο‡`. -/ +def machineCompletedSmoothedMatrixCode (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineSmoothedMatrixCode + (pair (rawRatBinaryCode (rawRatOfRat Ο‡)) word) + +/-- Runs the supplied positive-input machine on the encoded smoothed matrix. -/ +def machineCompletedPositiveRawCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + positiveMachine (machineCompletedSmoothedMatrixCode Ο‡ word) + +/-- Obtains the raw-rational dimension code through the smoothing input format. -/ +def machineCompletedDimensionRawCode (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineSmoothingDimensionRawCode + (pair (rawRatBinaryCode (rawRatOfRat Ο‡)) word) + +/-- Computes the encoded product of `Ο‡` and the matrix dimension. -/ +def machineCompletedChiTimesDimensionRawCode (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode (rawRatOfRat Ο‡)) + (machineCompletedDimensionRawCode Ο‡ word)) + +/-- Computes the encoded smoothing correction term `Ο‡ * n / 2`. -/ +def machineCompletedHalfChiDimensionRawCode (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineCompletedChiTimesDimensionRawCode Ο‡ word) + (rawRatBinaryCode (RawRat.ofNat 2))) + +/-- Computes the encoded denominator correction `1 + Ο‡ * n / 2`. -/ +def machineCompletedCorrectionRawCode (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode RawRat.one) + (machineCompletedHalfChiDimensionRawCode Ο‡ word)) + +/-- Multiplies the positive-machine output by the matrix normalization scale raised to its +dimension. -/ +def machineCompletedLargeNumeratorRawCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineMatrixNormalizationScalePowerRawCode word) + (machineCompletedPositiveRawCode positiveMachine Ο‡ word)) + +/-- Divides the scaled positive-machine output by the smoothing correction `1 + Ο‡ * n / 2`. -/ +def machineCompletedLargeRawCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineCompletedLargeNumeratorRawCode positiveMachine Ο‡ word) + (machineCompletedCorrectionRawCode Ο‡ word)) + +/-- Normalizes the raw-rational result of the large-dimension branch. -/ +def machineCompletedLargeCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode + (machineCompletedLargeRawCode positiveMachine Ο‡ word) + +/-- Runs the corrected positive branch when the support has a perfect matching, returning zero +otherwise. -/ +def machineCompletedMatchingBranchCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineIfHead (machineKuhnPerfectMatchingBit word) + (machineCompletedLargeCode positiveMachine Ο‡ word) + (rationalBinaryCode 0) + +/-- Handles dimensions below two directly and otherwise dispatches to the perfect-matching +branch. -/ +def machineCompletedNonnegativeBranchCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineIfHead (machineCompletedDimensionLtTwoBit word) + (machineSmallDimensionPermanentCode word) + (machineCompletedMatchingBranchCode positiveMachine Ο‡ word) + +/-- Dispatches nonnegative matrices to the completed algorithm and returns zero for a failed +sign test. -/ +def machineCompletedAlgorithmCode + (positiveMachine : List Bool β†’ List Bool) (Ο‡ : β„š) + (word : List Bool) : List Bool := + machineIfHead (machineMatrixNonnegativeBit word) + (machineCompletedNonnegativeBranchCode positiveMachine Ο‡ word) + (rationalBinaryCode 0) + +theorem machineCompletedDimensionLtTwoBit_mem_FP : + machineCompletedDimensionLtTwoBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixDimensionWord_mem_FP + (machineConst_mem_FP (2 : β„•).bits) + simpa only [machineCompletedDimensionLtTwoBit] using! + machineCompose_mem_FP hpair machineBinaryNatLtBit_mem_FP + +theorem machineCompletedSmoothedMatrixCode_mem_FP (Ο‡ : β„š) : + machineCompletedSmoothedMatrixCode Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (rawRatOfRat Ο‡))) id_mem_FP + simpa only [machineCompletedSmoothedMatrixCode] using! + machineCompose_mem_FP hpair machineSmoothedMatrixCode_mem_FP + +theorem machineCompletedPositiveRawCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedPositiveRawCode positiveMachine Ο‡ ∈ Complexity.FP := by + simpa only [machineCompletedPositiveRawCode] using! + machineCompose_mem_FP (machineCompletedSmoothedMatrixCode_mem_FP Ο‡) + hpositive + +theorem machineCompletedDimensionRawCode_mem_FP (Ο‡ : β„š) : + machineCompletedDimensionRawCode Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (rawRatOfRat Ο‡))) id_mem_FP + simpa only [machineCompletedDimensionRawCode] using! + machineCompose_mem_FP hpair machineSmoothingDimensionRawCode_mem_FP + +theorem machineCompletedChiTimesDimensionRawCode_mem_FP (Ο‡ : β„š) : + machineCompletedChiTimesDimensionRawCode Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (rawRatOfRat Ο‡))) + (machineCompletedDimensionRawCode_mem_FP Ο‡) + simpa only [machineCompletedChiTimesDimensionRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineCompletedHalfChiDimensionRawCode_mem_FP (Ο‡ : β„š) : + machineCompletedHalfChiDimensionRawCode Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineCompletedChiTimesDimensionRawCode_mem_FP Ο‡) + (machineConst_mem_FP (rawRatBinaryCode (RawRat.ofNat 2))) + simpa only [machineCompletedHalfChiDimensionRawCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineCompletedCorrectionRawCode_mem_FP (Ο‡ : β„š) : + machineCompletedCorrectionRawCode Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + (machineCompletedHalfChiDimensionRawCode_mem_FP Ο‡) + simpa only [machineCompletedCorrectionRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineCompletedLargeNumeratorRawCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedLargeNumeratorRawCode positiveMachine Ο‡ ∈ + Complexity.FP := by + have hpair := machinePair_mem_FP + machineMatrixNormalizationScalePowerRawCode_mem_FP + (machineCompletedPositiveRawCode_mem_FP hpositive Ο‡) + simpa only [machineCompletedLargeNumeratorRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineCompletedLargeRawCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedLargeRawCode positiveMachine Ο‡ ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineCompletedLargeNumeratorRawCode_mem_FP hpositive Ο‡) + (machineCompletedCorrectionRawCode_mem_FP Ο‡) + simpa only [machineCompletedLargeRawCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineCompletedLargeCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedLargeCode positiveMachine Ο‡ ∈ Complexity.FP := by + simpa only [machineCompletedLargeCode] using! + machineCompose_mem_FP + (machineCompletedLargeRawCode_mem_FP hpositive Ο‡) + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineCompletedMatchingBranchCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedMatchingBranchCode positiveMachine Ο‡ ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineKuhnPerfectMatchingBit_mem_FP + (machineCompletedLargeCode_mem_FP hpositive Ο‡) + (machineConst_mem_FP (rationalBinaryCode 0)) + +theorem machineCompletedNonnegativeBranchCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedNonnegativeBranchCode positiveMachine Ο‡ ∈ + Complexity.FP := by + exact machineIfHead_mem_FP machineCompletedDimensionLtTwoBit_mem_FP + machineSmallDimensionPermanentCode_mem_FP + (machineCompletedMatchingBranchCode_mem_FP hpositive Ο‡) + +theorem machineCompletedAlgorithmCode_mem_FP + {positiveMachine : List Bool β†’ List Bool} + (hpositive : positiveMachine ∈ Complexity.FP) (Ο‡ : β„š) : + machineCompletedAlgorithmCode positiveMachine Ο‡ ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineMatrixNonnegativeBit_mem_FP + (machineCompletedNonnegativeBranchCode_mem_FP hpositive Ο‡) + (machineConst_mem_FP (rationalBinaryCode 0)) + +/-! ## Exact semantics -/ + +@[simp] theorem machineCompletedDimensionLtTwoBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineCompletedDimensionLtTwoBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [decide (n < 2)] := by + rw [machineCompletedDimensionLtTwoBit, + machineMatrixDimensionWord_encode, + machineBinaryNatLtBit_pair_natBits] + +@[simp] theorem machineCompletedCorrectionRawCode_encode {n : β„•} + (Ο‡ : β„š) (A : Matrix (Fin n) (Fin n) β„š) : + machineCompletedCorrectionRawCode Ο‡ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (RawRat.one.add + (((rawRatOfRat Ο‡).mul (RawRat.ofNat n)).div + (RawRat.ofNat 2))) := by + simp only [machineCompletedCorrectionRawCode, + machineCompletedHalfChiDimensionRawCode, + machineCompletedChiTimesDimensionRawCode, + machineCompletedDimensionRawCode] + rw [machineSmoothingDimensionRawCode_encode A (rawRatOfRat Ο‡), + machineRawRatMulCode_encode, machineRawRatDivCode_encode, + machineRawRatAddCode_encode] + +theorem machineKuhnPerfectMatchingBit_finalDecision {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnPerfectMatchingBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [kuhnSupportMatchingDecision A] := by + rw [machineKuhnPerfectMatchingBit_encode] + apply congrArg singleton + apply Bool.eq_iff_iff.mpr + rw [kuhnColumnMate_all_isSome_eq_true_iff, + kuhnSupportMatchingDecision_eq_true_iff] + +theorem machineCompletedLargeCode_encode + {positiveMachine : List Bool β†’ List Bool} + {positiveAlg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š} + (hrealizes : RawStringRealizes positiveMachine positiveAlg) + (Ο‡ : β„š) {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineCompletedLargeCode positiveMachine Ο‡ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode + (rationalNormalizationScale A ^ n * + positiveAlg n (smoothedRationalMatrix A Ο‡) / + (1 + Ο‡ * n / 2)) := by + have hpositive := hrealizes + ⟨n, smoothedRationalMatrix A Ο‡βŸ© + change positiveMachine + (rationalMatrixBinaryEncoding.encode + ⟨n, smoothedRationalMatrix A Ο‡βŸ©) = + rawRatBinaryCode + (rawRatOfRat (positiveAlg n (smoothedRationalMatrix A Ο‡))) at hpositive + simp only [machineCompletedLargeCode, + machineCompletedLargeRawCode, + machineCompletedLargeNumeratorRawCode, + machineCompletedPositiveRawCode, + machineCompletedSmoothedMatrixCode, + machineSmoothedMatrixCode_rational, + hpositive, + machineMatrixNormalizationScalePowerRawCode_encode, + machineCompletedCorrectionRawCode_encode, + machineRawRatMulCode_encode, machineRawRatDivCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_div, RawRat.value_pow, + RawRat.value_mul, RawRat.value_add, RawRat.value_one, + RawRat.value_ofNat, rawRatOfRat_value, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum, rationalNormalizationScale] + congr 1 + +/-- The large branch only invokes the internal routine on the strictly +positive smoothed matrix. This version records precisely that domain instead +of requiring arbitrary behavior from the internal machine away from it. -/ +theorem machineCompletedLargeCode_encode_onPositive + {positiveMachine : List Bool β†’ List Bool} + {positiveAlg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š} + (hrealizes : PositiveRawStringRealizes positiveMachine positiveAlg) + (Ο‡ : β„š) (hΟ‡ : 0 < (Ο‡ : ℝ)) {n : β„•} (hn : 0 < n) + (A : Matrix (Fin n) (Fin n) β„š) (hA : Matrix.Nonnegative A) : + machineCompletedLargeCode positiveMachine Ο‡ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode + (rationalNormalizationScale A ^ n * + positiveAlg n (smoothedRationalMatrix A Ο‡) / + (1 + Ο‡ * n / 2)) := by + have hpositive := hrealizes n (smoothedRationalMatrix A Ο‡) + (cast_smoothedRationalMatrix_positive hn A hA Ο‡ hΟ‡) + simp only [machineCompletedLargeCode, + machineCompletedLargeRawCode, + machineCompletedLargeNumeratorRawCode, + machineCompletedPositiveRawCode, + machineCompletedSmoothedMatrixCode, + machineSmoothedMatrixCode_rational, + hpositive, + machineMatrixNormalizationScalePowerRawCode_encode, + machineCompletedCorrectionRawCode_encode, + machineRawRatMulCode_encode, machineRawRatDivCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_div, RawRat.value_pow, + RawRat.value_mul, RawRat.value_add, RawRat.value_one, + RawRat.value_ofNat, rawRatOfRat_value, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum, rationalNormalizationScale] + congr 1 + +theorem machineCompletedAlgorithmCode_encode + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) + {positiveMachine : List Bool β†’ List Bool} + (hrealizes : RawStringRealizes positiveMachine routine.alg) + (Ο‡ : β„š) {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineCompletedAlgorithmCode positiveMachine Ο‡ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (completedAlgorithm routine Ο‡ n A) := by + rw [machineCompletedAlgorithmCode, + machineMatrixNonnegativeBit_finalDecision] + by_cases hnonnegative : rationalMatrixNonnegativeDecision A = true + Β· rw [show [rationalMatrixNonnegativeDecision A] = [true] by simp [hnonnegative], + machineIfHead_true] + rw [machineCompletedNonnegativeBranchCode, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true, + machineSmallDimensionPermanentCode_encode hsmall] + simp [completedAlgorithm, hnonnegative, hsmall] + Β· rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false, + machineCompletedMatchingBranchCode, + machineKuhnPerfectMatchingBit_finalDecision] + by_cases hmatching : kuhnSupportMatchingDecision A = true + Β· rw [show [kuhnSupportMatchingDecision A] = [true] by simp [hmatching], + machineIfHead_true, + machineCompletedLargeCode_encode hrealizes] + simp [completedAlgorithm, hnonnegative, hsmall, hmatching] + Β· rw [show [kuhnSupportMatchingDecision A] = [false] by + simp [Bool.eq_false_iff.mpr hmatching], + machineIfHead_false] + simp [completedAlgorithm, hnonnegative, hsmall, hmatching] + Β· rw [show [rationalMatrixNonnegativeDecision A] = [false] by + simp [Bool.eq_false_iff.mpr hnonnegative], + machineIfHead_false] + simp [completedAlgorithm, hnonnegative] + +/-- Exact semantics of the total outer machine from correctness of its +internal routine only on positive matrices. Positivity is discharged by the +verified smoothing step at the unique call site. -/ +theorem machineCompletedAlgorithmCode_encode_onPositive + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) + {positiveMachine : List Bool β†’ List Bool} + (hrealizes : PositiveRawStringRealizes positiveMachine routine.alg) + (Ο‡ : β„š) (hΟ‡ : 0 < (Ο‡ : ℝ)) {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineCompletedAlgorithmCode positiveMachine Ο‡ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (completedAlgorithm routine Ο‡ n A) := by + rw [machineCompletedAlgorithmCode, + machineMatrixNonnegativeBit_finalDecision] + by_cases hnonnegative : rationalMatrixNonnegativeDecision A = true + Β· have hA : Matrix.Nonnegative A := + (rationalMatrixNonnegativeDecision_eq_true_iff A).1 hnonnegative + rw [show [rationalMatrixNonnegativeDecision A] = [true] by simp [hnonnegative], + machineIfHead_true] + rw [machineCompletedNonnegativeBranchCode, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true, + machineSmallDimensionPermanentCode_encode hsmall] + simp [completedAlgorithm, hnonnegative, hsmall] + Β· have hn : 0 < n := by omega + rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false, + machineCompletedMatchingBranchCode, + machineKuhnPerfectMatchingBit_finalDecision] + by_cases hmatching : kuhnSupportMatchingDecision A = true + Β· rw [show [kuhnSupportMatchingDecision A] = [true] by simp [hmatching], + machineIfHead_true, + machineCompletedLargeCode_encode_onPositive hrealizes Ο‡ hΟ‡ hn A hA] + simp [completedAlgorithm, hnonnegative, hsmall, hmatching] + Β· rw [show [kuhnSupportMatchingDecision A] = [false] by + simp [Bool.eq_false_iff.mpr hmatching], + machineIfHead_false] + simp [completedAlgorithm, hnonnegative, hsmall, hmatching] + Β· rw [show [rationalMatrixNonnegativeDecision A] = [false] by + simp [Bool.eq_false_iff.mpr hnonnegative], + machineIfHead_false] + simp [completedAlgorithm, hnonnegative] + +theorem completedAlgorithm_runsInPolynomialTime_of_rawMachine + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) + {positiveMachine : List Bool β†’ List Bool} + (hpositiveFP : positiveMachine ∈ Complexity.FP) + (hrealizes : RawStringRealizes positiveMachine routine.alg) + (Ο‡ : β„š) : + RunsInPolynomialTime (completedAlgorithm routine Ο‡) := by + refine ⟨machineCompletedAlgorithmCode positiveMachine Ο‡, + machineCompletedAlgorithmCode_mem_FP hpositiveFP Ο‡, ?_⟩ + intro x + obtain ⟨n, A⟩ := x + exact machineCompletedAlgorithmCode_encode routine hrealizes Ο‡ A + +/-- Polynomial time of the completed algorithm from a total polynomial-time +internal machine whose semantic contract is restricted to positive inputs. -/ +theorem completedAlgorithm_runsInPolynomialTime_of_positive_rawMachine + {Ξ΅ : ℝ} (routine : CertifiedPositiveRoutine Ξ΅) + {positiveMachine : List Bool β†’ List Bool} + (hpositiveFP : positiveMachine ∈ Complexity.FP) + (hrealizes : PositiveRawStringRealizes positiveMachine routine.alg) + (Ο‡ : β„š) (hΟ‡ : 0 < (Ο‡ : ℝ)) : + RunsInPolynomialTime (completedAlgorithm routine Ο‡) := by + refine ⟨machineCompletedAlgorithmCode positiveMachine Ο‡, + machineCompletedAlgorithmCode_mem_FP hpositiveFP Ο‡, ?_⟩ + intro x + obtain ⟨n, A⟩ := x + exact machineCompletedAlgorithmCode_encode_onPositive + routine hrealizes Ο‡ hΟ‡ A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientEntry.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientEntry.lean new file mode 100644 index 0000000000..dfc4445076 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientEntry.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientEntry + +/-! +# Finite-word entries of the directed affine gradient + +For an upper-left base coordinate `(a,b)`, the affine pullback is the signed +four-corner combination + +`G(a,b) - G(a,last) - G(last,b) + G(last,last)`. + +This file evaluates those four full-gradient entries with the common verified +entry machine and performs the three exact rational operations explicitly. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary row index of an affine-gradient coordinate query. -/ +def machineDirectedAffineGradientEntryRow + (word : List Bool) : List Bool := machinePairFirst word + +/-- Extracts the column index and objective-evaluation payload of the gradient query. -/ +def machineDirectedAffineGradientEntryRest + (word : List Bool) : List Bool := machinePairSecond word + +/-- Extracts the unary column index of an affine-gradient coordinate query. -/ +def machineDirectedAffineGradientEntryColumn + (word : List Bool) : List Bool := + machinePairFirst (machineDirectedAffineGradientEntryRest word) + +/-- Extracts the shared objective-evaluation payload from the gradient query. -/ +def machineDirectedAffineGradientEntryPayload + (word : List Bool) : List Bool := + machinePairSecond (machineDirectedAffineGradientEntryRest word) + +/-- Recovers the affine dimension parameter from the gradient query's objective payload. -/ +def machineDirectedAffineGradientEntryDimension + (word : List Bool) : List Bool := + machineDirectedObjectiveSumDimension + (machineDirectedAffineGradientEntryPayload word) + +/-- Uses the original query for the interior matrix entry in the affine-gradient formula. -/ +def machineDirectedAffineGradientUpperLeftInput + (word : List Bool) : List Bool := word + +/-- Builds the gradient query at the given row and the last matrix column. -/ +def machineDirectedAffineGradientUpperRightInput + (word : List Bool) : List Bool := + pair (machineDirectedAffineGradientEntryRow word) + (pair (machineDirectedAffineGradientEntryDimension word) + (machineDirectedAffineGradientEntryPayload word)) + +/-- Builds the gradient query at the last matrix row and the given column. -/ +def machineDirectedAffineGradientLowerLeftInput + (word : List Bool) : List Bool := + pair (machineDirectedAffineGradientEntryDimension word) + (pair (machineDirectedAffineGradientEntryColumn word) + (machineDirectedAffineGradientEntryPayload word)) + +/-- Builds the gradient query at the last row and last column. -/ +def machineDirectedAffineGradientLowerRightInput + (word : List Bool) : List Bool := + pair (machineDirectedAffineGradientEntryDimension word) + (pair (machineDirectedAffineGradientEntryDimension word) + (machineDirectedAffineGradientEntryPayload word)) + +/-- Computes the directed negative-gradient value at the interior matrix entry. -/ +def machineDirectedAffineGradientUpperLeftRaw + (word : List Bool) : List Bool := + machineDirectedNegativeGradientEntryRawCode + (machineDirectedAffineGradientUpperLeftInput word) + +/-- Computes the directed negative-gradient value at the given row and last column. -/ +def machineDirectedAffineGradientUpperRightRaw + (word : List Bool) : List Bool := + machineDirectedNegativeGradientEntryRawCode + (machineDirectedAffineGradientUpperRightInput word) + +/-- Computes the directed negative-gradient value at the last row and given column. -/ +def machineDirectedAffineGradientLowerLeftRaw + (word : List Bool) : List Bool := + machineDirectedNegativeGradientEntryRawCode + (machineDirectedAffineGradientLowerLeftInput word) + +/-- Computes the directed negative-gradient value at the last row and last column. -/ +def machineDirectedAffineGradientLowerRightRaw + (word : List Bool) : List Bool := + machineDirectedNegativeGradientEntryRawCode + (machineDirectedAffineGradientLowerRightInput word) + +/-- Subtracts the last-column gradient value from the interior gradient value. -/ +def machineDirectedAffineGradientFirstDifference + (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (machineDirectedAffineGradientUpperLeftRaw word) + (machineDirectedAffineGradientUpperRightRaw word)) + +/-- Subtracts the last-row gradient value from the interior-minus-last-column difference. -/ +def machineDirectedAffineGradientSecondDifference + (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (machineDirectedAffineGradientFirstDifference word) + (machineDirectedAffineGradientLowerLeftRaw word)) + +/-- Forms the affine-gradient entry by adding the corner value to the two successive +differences. -/ +def machineDirectedAffineGradientEntryRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedAffineGradientSecondDifference word) + (machineDirectedAffineGradientLowerRightRaw word)) + +theorem machineDirectedAffineGradientEntryRow_mem_FP : + machineDirectedAffineGradientEntryRow ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectedAffineGradientEntryRest_mem_FP : + machineDirectedAffineGradientEntryRest ∈ FP := machinePairSecond_mem_FP + +theorem machineDirectedAffineGradientEntryColumn_mem_FP : + machineDirectedAffineGradientEntryColumn ∈ FP := by + simpa only [machineDirectedAffineGradientEntryColumn] using! + machineCompose_mem_FP machineDirectedAffineGradientEntryRest_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedAffineGradientEntryPayload_mem_FP : + machineDirectedAffineGradientEntryPayload ∈ FP := by + simpa only [machineDirectedAffineGradientEntryPayload] using! + machineCompose_mem_FP machineDirectedAffineGradientEntryRest_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedAffineGradientEntryDimension_mem_FP : + machineDirectedAffineGradientEntryDimension ∈ FP := by + simpa only [machineDirectedAffineGradientEntryDimension] using! + machineCompose_mem_FP machineDirectedAffineGradientEntryPayload_mem_FP + machineDirectedObjectiveSumDimension_mem_FP + +theorem machineDirectedAffineGradientUpperLeftInput_mem_FP : + machineDirectedAffineGradientUpperLeftInput ∈ FP := by + simpa only [machineDirectedAffineGradientUpperLeftInput] using! + (Complexity.id_mem_FP : (fun x : List Bool => x) ∈ FP) + +theorem machineDirectedAffineGradientUpperRightInput_mem_FP : + machineDirectedAffineGradientUpperRightInput ∈ FP := + machinePair_mem_FP machineDirectedAffineGradientEntryRow_mem_FP + (machinePair_mem_FP machineDirectedAffineGradientEntryDimension_mem_FP + machineDirectedAffineGradientEntryPayload_mem_FP) + +theorem machineDirectedAffineGradientLowerLeftInput_mem_FP : + machineDirectedAffineGradientLowerLeftInput ∈ FP := + machinePair_mem_FP machineDirectedAffineGradientEntryDimension_mem_FP + (machinePair_mem_FP machineDirectedAffineGradientEntryColumn_mem_FP + machineDirectedAffineGradientEntryPayload_mem_FP) + +theorem machineDirectedAffineGradientLowerRightInput_mem_FP : + machineDirectedAffineGradientLowerRightInput ∈ FP := + machinePair_mem_FP machineDirectedAffineGradientEntryDimension_mem_FP + (machinePair_mem_FP machineDirectedAffineGradientEntryDimension_mem_FP + machineDirectedAffineGradientEntryPayload_mem_FP) + +theorem machineDirectedAffineGradientUpperLeftRaw_mem_FP : + machineDirectedAffineGradientUpperLeftRaw ∈ FP := by + simpa only [machineDirectedAffineGradientUpperLeftRaw] using! + machineCompose_mem_FP machineDirectedAffineGradientUpperLeftInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + +theorem machineDirectedAffineGradientUpperRightRaw_mem_FP : + machineDirectedAffineGradientUpperRightRaw ∈ FP := by + simpa only [machineDirectedAffineGradientUpperRightRaw] using! + machineCompose_mem_FP machineDirectedAffineGradientUpperRightInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + +theorem machineDirectedAffineGradientLowerLeftRaw_mem_FP : + machineDirectedAffineGradientLowerLeftRaw ∈ FP := by + simpa only [machineDirectedAffineGradientLowerLeftRaw] using! + machineCompose_mem_FP machineDirectedAffineGradientLowerLeftInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + +theorem machineDirectedAffineGradientLowerRightRaw_mem_FP : + machineDirectedAffineGradientLowerRightRaw ∈ FP := by + simpa only [machineDirectedAffineGradientLowerRightRaw] using! + machineCompose_mem_FP machineDirectedAffineGradientLowerRightInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + +theorem machineDirectedAffineGradientFirstDifference_mem_FP : + machineDirectedAffineGradientFirstDifference ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedAffineGradientUpperLeftRaw_mem_FP + machineDirectedAffineGradientUpperRightRaw_mem_FP + simpa only [machineDirectedAffineGradientFirstDifference] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineDirectedAffineGradientSecondDifference_mem_FP : + machineDirectedAffineGradientSecondDifference ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedAffineGradientFirstDifference_mem_FP + machineDirectedAffineGradientLowerLeftRaw_mem_FP + simpa only [machineDirectedAffineGradientSecondDifference] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineDirectedAffineGradientEntryRawCode_mem_FP : + machineDirectedAffineGradientEntryRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedAffineGradientSecondDifference_mem_FP + machineDirectedAffineGradientLowerRightRaw_mem_FP + simpa only [machineDirectedAffineGradientEntryRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +/-- Encodes affine coordinate indices together with regularization, matrix, point, and precision +data. -/ +def machineDirectedAffineGradientEntryCanonicalWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : List Bool := + pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p)) + +/-- Forms the raw affine-gradient entry `G(a,b) - G(a,m) - G(m,b) + G(m,m)`. -/ +def rawDirectedAffineGradientEntry {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : RawRat := + let G := fun i j => rawDirectedNegativeGradientLower tau (A i j) + (betheAffineMatrixQ y i j) p + ((G a.castSucc b.castSucc).sub (G a.castSucc (Fin.last m))).sub + (G (Fin.last m) b.castSucc) |>.add + (G (Fin.last m) (Fin.last m)) + +@[simp] theorem machineDirectedAffineGradientEntryDimension_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientEntryDimension + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + List.replicate m true := by + simp [machineDirectedAffineGradientEntryDimension, + machineDirectedAffineGradientEntryPayload, + machineDirectedAffineGradientEntryRest, + machineDirectedAffineGradientEntryCanonicalWord] + +@[simp] theorem machineDirectedAffineGradientUpperLeftInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientUpperLeftInput + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + machineDirectedGradientEntryCanonicalWord tau A y p + a.castSucc b.castSucc := by + rfl + +@[simp] theorem machineDirectedAffineGradientUpperRightInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientUpperRightInput + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + machineDirectedGradientEntryCanonicalWord tau A y p + a.castSucc (Fin.last m) := by + rw [machineDirectedAffineGradientUpperRightInput, + machineDirectedAffineGradientEntryDimension_encode] + simp [ + machineDirectedAffineGradientEntryRow, + machineDirectedAffineGradientEntryRest, + machineDirectedAffineGradientEntryPayload, + machineDirectedAffineGradientEntryCanonicalWord, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineDirectedAffineGradientLowerLeftInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientLowerLeftInput + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + machineDirectedGradientEntryCanonicalWord tau A y p + (Fin.last m) b.castSucc := by + rw [machineDirectedAffineGradientLowerLeftInput, + machineDirectedAffineGradientEntryDimension_encode] + simp [ + machineDirectedAffineGradientEntryColumn, + machineDirectedAffineGradientEntryRest, + machineDirectedAffineGradientEntryPayload, + machineDirectedAffineGradientEntryCanonicalWord, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineDirectedAffineGradientLowerRightInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientLowerRightInput + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + machineDirectedGradientEntryCanonicalWord tau A y p + (Fin.last m) (Fin.last m) := by + rw [machineDirectedAffineGradientLowerRightInput, + machineDirectedAffineGradientEntryDimension_encode] + simp [ + machineDirectedAffineGradientEntryRest, + machineDirectedAffineGradientEntryPayload, + machineDirectedAffineGradientEntryCanonicalWord, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineDirectedAffineGradientUpperLeftRaw_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientUpperLeftRaw + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rawRatBinaryCode + (rawDirectedNegativeGradientLower tau (A a.castSucc b.castSucc) + (betheAffineMatrixQ y a.castSucc b.castSucc) p) := by + rw [machineDirectedAffineGradientUpperLeftRaw, + machineDirectedAffineGradientUpperLeftInput_encode, + machineDirectedNegativeGradientEntryRawCode_encode] + +@[simp] theorem machineDirectedAffineGradientUpperRightRaw_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientUpperRightRaw + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rawRatBinaryCode + (rawDirectedNegativeGradientLower tau (A a.castSucc (Fin.last m)) + (betheAffineMatrixQ y a.castSucc (Fin.last m)) p) := by + rw [machineDirectedAffineGradientUpperRightRaw, + machineDirectedAffineGradientUpperRightInput_encode, + machineDirectedNegativeGradientEntryRawCode_encode] + +@[simp] theorem machineDirectedAffineGradientLowerLeftRaw_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientLowerLeftRaw + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rawRatBinaryCode + (rawDirectedNegativeGradientLower tau (A (Fin.last m) b.castSucc) + (betheAffineMatrixQ y (Fin.last m) b.castSucc) p) := by + rw [machineDirectedAffineGradientLowerLeftRaw, + machineDirectedAffineGradientLowerLeftInput_encode, + machineDirectedNegativeGradientEntryRawCode_encode] + +@[simp] theorem machineDirectedAffineGradientLowerRightRaw_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientLowerRightRaw + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rawRatBinaryCode + (rawDirectedNegativeGradientLower tau (A (Fin.last m) (Fin.last m)) + (betheAffineMatrixQ y (Fin.last m) (Fin.last m)) p) := by + rw [machineDirectedAffineGradientLowerRightRaw, + machineDirectedAffineGradientLowerRightInput_encode, + machineDirectedNegativeGradientEntryRawCode_encode] + +@[simp] theorem machineDirectedAffineGradientEntryRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientEntryRawCode + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rawRatBinaryCode (rawDirectedAffineGradientEntry tau A y p a b) := by + simp only [machineDirectedAffineGradientEntryRawCode, + machineDirectedAffineGradientSecondDifference, + machineDirectedAffineGradientFirstDifference, + machineDirectedAffineGradientUpperLeftRaw_encode, + machineDirectedAffineGradientUpperRightRaw_encode, + machineDirectedAffineGradientLowerLeftRaw_encode, + machineDirectedAffineGradientLowerRightRaw_encode] + rw [ + machineRawRatSubCode_encode, machineRawRatSubCode_encode, + machineRawRatAddCode_encode] + rfl + +theorem rawDirectedAffineGradientEntry_value {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + (rawDirectedAffineGradientEntry tau A y p a b).value = + affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p) a b := by + simp [rawDirectedAffineGradientEntry, affinePullbackGradient, + directedNegativeGradientLowerMatrix, + RawRat.value_add, RawRat.value_sub, + rawDirectedNegativeGradientLower_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientVector.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientVector.lean new file mode 100644 index 0000000000..040bd84765 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedAffineGradientVector.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator + +/-! +# Finite-word directed affine-gradient vectors + +This file instantiates the reusable unary grid generator with the verified +four-corner gradient entry. It also proves an explicit ordinary-binary size +bound for the complete `m^2`-coordinate vector, so the generator's totalizing +accumulator clamp is inactive on every canonical input. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Normalizes the raw affine-gradient entry into an encoded rational vector entry. -/ +def machineDirectedAffineGradientEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineDirectedAffineGradientEntryRawCode word) + +theorem machineDirectedAffineGradientEntryCode_mem_FP : + machineDirectedAffineGradientEntryCode ∈ FP := by + simpa only [machineDirectedAffineGradientEntryCode] using! + machineCompose_mem_FP machineDirectedAffineGradientEntryRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +@[simp] theorem machineDirectedAffineGradientEntryCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + machineDirectedAffineGradientEntryCode + (machineDirectedAffineGradientEntryCanonicalWord tau A y p a b) = + rationalEntryBinaryCode + (affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p) a b) := by + rw [machineDirectedAffineGradientEntryCode, + machineDirectedAffineGradientEntryRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawDirectedAffineGradientEntry_value] + +/-- Uses six binary-width iterations to bound generated affine-gradient entries. -/ +def machineDirectedAffineGradientVectorBound (word : List Bool) : List Bool := + machineIteratedBinaryWidth 6 word + +/-- Packages the dimension ruler, entry-width bound, and objective payload for gradient +generation. -/ +def machineDirectedAffineGradientVectorGeneratorInput + (word : List Bool) : List Bool := + pair (machineDirectedObjectiveSumDimension word) + (pair (machineDirectedAffineGradientVectorBound word) word) + +/-- Generates the encoded vector of directed affine-gradient entries over the coordinate grid. -/ +def machineDirectedAffineGradientVectorCode (word : List Bool) : List Bool := + machineUnaryGridGeneratorCode machineDirectedAffineGradientEntryCode + (machineDirectedAffineGradientVectorGeneratorInput word) + +theorem machineDirectedAffineGradientVectorBound_mem_FP : + machineDirectedAffineGradientVectorBound ∈ FP := + machineIteratedBinaryWidth_mem_FP 6 + +theorem machineDirectedAffineGradientVectorGeneratorInput_mem_FP : + machineDirectedAffineGradientVectorGeneratorInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumDimension_mem_FP + (machinePair_mem_FP machineDirectedAffineGradientVectorBound_mem_FP + id_mem_FP) + +theorem machineDirectedAffineGradientVectorCode_mem_FP : + machineDirectedAffineGradientVectorCode ∈ FP := by + have hgenerator := machineUnaryGridGeneratorCode_mem_FP + machineDirectedAffineGradientEntryCode_mem_FP + simpa only [machineDirectedAffineGradientVectorCode] using! + machineCompose_mem_FP + machineDirectedAffineGradientVectorGeneratorInput_mem_FP hgenerator + +/-- Flattens the affine pullback of the directed negative-gradient matrix into a coordinate +vector. -/ +def directedAffineGradientVector {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : Fin (m * m) β†’ β„š := + squareMatrixToVector + (affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p)) + +/-- Budgets raw-rational coordinate width using the regularization and three directed logarithm +widths. -/ +def rawDirectedGradientCoordinateWidthBudget + (tau a x : β„š) (p : β„•) : β„• := + 2 * rawRatWidth (rawRatOfRat tau) + + rawRatWidth (rawScheduledLogUpper a p) + + rawRatWidth (rawScheduledLogLower x p) + + rawRatWidth (rawScheduledLogLower (1 - x) p) + 9 + +theorem rawDirectedNegativeGradientLower_width_le + (tau a x : β„š) (p : β„•) : + rawRatWidth (rawDirectedNegativeGradientLower tau a x p) ≀ + rawDirectedGradientCoordinateWidthBudget tau a x p := by + let rawTau := rawRatOfRat tau + let logA := rawScheduledLogUpper a p + let logX := rawScheduledLogLower x p + let logComplement := rawScheduledLogLower (1 - x) p + have hone : rawRatWidth RawRat.one = 1 := rawRatWidth_one + have honeTau := rawRatWidth_add_le RawRat.one rawTau + rw [hone] at honeTau + have hscaled := rawRatWidth_mul_le (RawRat.one.add rawTau) logX + have hnegA : rawRatWidth logA.neg = rawRatWidth logA := + rawRatWidth_neg logA + have hfirst := rawRatWidth_add_le logA.neg + ((RawRat.one.add rawTau).mul logX) + rw [hnegA] at hfirst + have hthree := rawRatWidth_add_le + (logA.neg.add ((RawRat.one.add rawTau).mul logX)) logComplement + have htwoTauInner := rawRatWidth_add_le RawRat.one rawTau + rw [hone] at htwoTauInner + have htwoTau := rawRatWidth_add_le RawRat.one + (RawRat.one.add rawTau) + rw [hone] at htwoTau + have htotal := rawRatWidth_add_le + ((logA.neg.add ((RawRat.one.add rawTau).mul logX)).add logComplement) + (RawRat.one.add (RawRat.one.add rawTau)) + have honeTau' : rawRatWidth (RawRat.one.add rawTau) ≀ + rawRatWidth rawTau + 2 := by omega + have hscaled' : + rawRatWidth ((RawRat.one.add rawTau).mul logX) ≀ + rawRatWidth rawTau + rawRatWidth logX + 2 := by omega + have hfirst' : + rawRatWidth (logA.neg.add + ((RawRat.one.add rawTau).mul logX)) ≀ + rawRatWidth logA + rawRatWidth rawTau + + rawRatWidth logX + 3 := by omega + have hthree' : + rawRatWidth + ((logA.neg.add ((RawRat.one.add rawTau).mul logX)).add + logComplement) ≀ + rawRatWidth logA + rawRatWidth rawTau + + rawRatWidth logX + rawRatWidth logComplement + 4 := by + omega + have htwoTau' : + rawRatWidth (RawRat.one.add (RawRat.one.add rawTau)) ≀ + rawRatWidth rawTau + 4 := by omega + have htotal' : + rawRatWidth + (((logA.neg.add ((RawRat.one.add rawTau).mul logX)).add + logComplement).add + (RawRat.one.add (RawRat.one.add rawTau))) ≀ + 2 * rawRatWidth rawTau + rawRatWidth logA + + rawRatWidth logX + rawRatWidth logComplement + 9 := by + omega + simp only [rawDirectedGradientCoordinateWidthBudget] + simpa only [rawDirectedNegativeGradientLower, rawTau, logA, logX, + logComplement] using! htotal' + +theorem rawDirectedNegativeGradientEntry_width_le_word_budget {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + rawRatWidth + (rawDirectedNegativeGradientLower tau (A i j) + (betheAffineMatrixQ y i j) p) ≀ + rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let x := betheAffineMatrixQ y i j + let WX := rawDirectedObjectiveCoordinateWordXBudget m L + let WC := rawDirectedObjectiveCoordinateWordComplementBudget m L + have hp : p ≀ L := directedObjectiveSum_precision_le_word tau A y p + have htau : rawRatWidth (rawRatOfRat tau) ≀ L := + rawDirectedObjectiveSum_tau_width_le_word tau A y p + have ha : rawRatWidth (rawRatOfRat (A i j)) ≀ L := + rawDirectedObjectiveSum_A_width_le_word tau A y p i j + have hx : rawRatWidth (rawRatOfRat x) ≀ WX := by + simpa only [x, WX, L, + rawDirectedObjectiveCoordinateWordXBudget] using! + rawBetheAffineMatrixQ_width_le_word tau A y p i j + have hc0 := rawRatWidth_complement_le x + have hc : rawRatWidth (rawRatOfRat (1 - x)) ≀ WC := by + simp only [WC, rawDirectedObjectiveCoordinateWordComplementBudget] + omega + have hlogA := rawRatWidth_scheduledLogUpper_of_bounds_le + (A i j) hp ha + have hlogX := rawRatWidth_scheduledLogLower_of_bounds_le x hp hx + have hlogC := rawRatWidth_scheduledLogLower_of_bounds_le (1 - x) hp hc + have hraw := rawDirectedNegativeGradientLower_width_le tau (A i j) x p + simp only [rawDirectedGradientCoordinateWidthBudget] at hraw + have hLX : L + 116 ≀ WX := by + simp only [WX, rawDirectedObjectiveCoordinateWordXBudget, + rawBetheAffineEntryWidthBudget] + omega + have hfinal : + rawRatWidth + (rawDirectedNegativeGradientLower tau (A i j) x p) ≀ + 2 * WX + L + WC + + rawScheduledLogWordBudget L L + + rawScheduledLogWordBudget L WX + + rawScheduledLogWordBudget L WC + 4 := by + simp only [rawScheduledLogWordBudget] + omega + simp only [rawDirectedObjectiveCoordinateWordBudget] + exact hfinal + +theorem rawDirectedAffineGradientEntry_width_le_word_budget {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + rawRatWidth (rawDirectedAffineGradientEntry tau A y p a b) ≀ + 4 * rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + 3 := by + let G := fun i j => rawDirectedNegativeGradientLower tau (A i j) + (betheAffineMatrixQ y i j) p + let B := rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + have h₁ : rawRatWidth (G a.castSucc b.castSucc) ≀ B := + rawDirectedNegativeGradientEntry_width_le_word_budget tau A y p _ _ + have hβ‚‚ : rawRatWidth (G a.castSucc (Fin.last m)) ≀ B := + rawDirectedNegativeGradientEntry_width_le_word_budget tau A y p _ _ + have h₃ : rawRatWidth (G (Fin.last m) b.castSucc) ≀ B := + rawDirectedNegativeGradientEntry_width_le_word_budget tau A y p _ _ + have hβ‚„ : rawRatWidth (G (Fin.last m) (Fin.last m)) ≀ B := + rawDirectedNegativeGradientEntry_width_le_word_budget tau A y p _ _ + have hsubOne := rawRatWidth_sub_le + (G a.castSucc b.castSucc) (G a.castSucc (Fin.last m)) + have hsubTwo := rawRatWidth_sub_le + ((G a.castSucc b.castSucc).sub (G a.castSucc (Fin.last m))) + (G (Fin.last m) b.castSucc) + have hadd := rawRatWidth_add_le + (((G a.castSucc b.castSucc).sub (G a.castSucc (Fin.last m))).sub + (G (Fin.last m) b.castSucc)) + (G (Fin.last m) (Fin.last m)) + simpa only [rawDirectedAffineGradientEntry, G, B] using! hadd.trans (by omega) + +theorem directedAffineGradient_entry_code_length_le {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (a b : Fin m) : + (rationalEntryBinaryCode + (affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p) a b)).length ≀ + 172 + 144 * rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let raw := rawDirectedAffineGradientEntry tau A y p a b + have hcanonical := rationalEntryBinaryCode_binaryNormalizeRawRat_length_le raw + rw [binaryNormalizeRawRat_eq_value, + rawDirectedAffineGradientEntry_value] at hcanonical + have hraw := rawDirectedAffineGradientEntry_width_le_word_budget + tau A y p a b + calc + _ ≀ 64 + 36 * rawRatWidth raw := hcanonical + _ ≀ 64 + 36 * + (4 * rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + 3) := + Nat.add_le_add_left (Nat.mul_le_mul_left 36 hraw) 64 + _ = 172 + 144 * rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by ring + +theorem directedAffineGradient_vector_code_length_le_bound {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + (rationalFiniteVectorCode + (directedAffineGradientVector tau A y p)).length ≀ + (machineDirectedAffineGradientVectorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length := by + let word := machineDirectedObjectiveSumCanonicalWord tau A y p + let L := word.length + let T := L + 16 + let B := rawDirectedObjectiveCoordinateWordBudget m L + let E := 172 + 144 * B + have hmL : m ≀ L := by + simp only [L, word, machineDirectedObjectiveSumCanonicalWord, + pair_length, List.length_replicate] + omega + have hB : B ≀ T ^ 20 := by + simpa only [B, T] using! + rawDirectedObjectiveCoordinateWordBudget_le_pow hmL + have hE : E ≀ 316 * T ^ 20 := by + have hpow : 1 ≀ T ^ 20 := one_le_powβ‚€ (by simp [T]) + dsimp only [E] + omega + have heach : βˆ€ q ∈ List.ofFn (directedAffineGradientVector tau A y p), + (rationalEntryBinaryCode q).length ≀ E := by + intro q hq + obtain ⟨k, rfl⟩ := List.mem_ofFn.mp hq + let ij := finProdFinEquiv.symm k + simpa only [directedAffineGradientVector, squareMatrixToVector, ij, E, + B, L, word] using! + directedAffineGradient_entry_code_length_le tau A y p ij.1 ij.2 + have hsum := List.sum_le_card_nsmul + ((List.ofFn (directedAffineGradientVector tau A y p)).map + fun q => 2 * (rationalEntryBinaryCode q).length + 2) + (2 * E + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + have hmT : m ≀ T := hmL.trans (by simp [T]) + have hlenCoarse : + (rationalFiniteVectorCode + (directedAffineGradientVector tau A y p)).length ≀ + 634 * T ^ 22 := by + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum] + simp only [List.length_map, List.length_ofFn, Nat.nsmul_eq_mul] at hsum + have hmm := Nat.mul_le_mul hmT hmT + have hfactor : 2 * E + 2 ≀ 634 * T ^ 20 := by + have hpow : 1 ≀ T ^ 20 := one_le_powβ‚€ (by simp [T]) + omega + have hmul := Nat.mul_le_mul hmm hfactor + calc + _ ≀ m * m * (2 * E + 2) := hsum + _ ≀ T * T * (634 * T ^ 20) := hmul + _ = 634 * T ^ 22 := by ring + have hcoeff : 634 ≀ T ^ 42 := by + have hbase : 16 ≀ T := by simp [T] + have hpow := Nat.pow_le_pow_left hbase 42 + exact (by norm_num : 634 ≀ 16 ^ 42).trans hpow + have hmul := Nat.mul_le_mul_right (T ^ 22) hcoeff + have hpower : + (rationalFiniteVectorCode + (directedAffineGradientVector tau A y p)).length ≀ T ^ 64 := by + calc + _ ≀ 634 * T ^ 22 := hlenCoarse + _ ≀ T ^ 42 * T ^ 22 := hmul + _ = T ^ 64 := by ring + rw [machineDirectedAffineGradientVectorBound, + machineIteratedBinaryWidth_length] + exact hpower.trans (by + simpa only [T, L, word] using! + certificateExpGuardWidth_pow_lower 5 + (machineDirectedObjectiveSumCanonicalWord tau A y p).length) + +theorem unaryGridValues_directedAffineGradient {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + unaryGridValues + (fun a b => affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p) a b) = + List.ofFn (directedAffineGradientVector tau A y p) := by + rfl + +@[simp] theorem machineDirectedAffineGradientVectorCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedAffineGradientVectorCode + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rationalFiniteVectorCode (directedAffineGradientVector tau A y p) := by + let payload := machineDirectedObjectiveSumCanonicalWord tau A y p + let bound := machineDirectedAffineGradientVectorBound payload + let f := fun a b => affinePullbackGradient + (directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p) a b + have hinput : machineDirectedAffineGradientVectorGeneratorInput payload = + machineUnaryGridGeneratorCanonicalWord m bound payload := by + simp [machineDirectedAffineGradientVectorGeneratorInput, payload, bound, + machineUnaryGridGeneratorCanonicalWord] + rw [machineDirectedAffineGradientVectorCode, hinput] + have hentry : βˆ€ a b, + machineDirectedAffineGradientEntryCode + (pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) payload)) = + rationalEntryBinaryCode (f a b) := by + intro a b + simpa only [payload, f, + machineDirectedAffineGradientEntryCanonicalWord] using! + machineDirectedAffineGradientEntryCode_encode tau A y p a b + have hbound : + (binaryListCode rationalEntryBinaryCode (unaryGridValues f)).length ≀ + bound.length := by + rw [unaryGridValues_directedAffineGradient] + simpa only [rationalFiniteVectorCode, f, bound, payload] using! + directedAffineGradient_vector_code_length_le_bound tau A y p + rw [machineUnaryGridGeneratorCode_encode_of_bound + machineDirectedAffineGradientEntryCode f bound payload hentry hbound, + unaryGridValues_directedAffineGradient] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedEpigraphNormal.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedEpigraphNormal.lean new file mode 100644 index 0000000000..4b1c525255 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedEpigraphNormal.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedAffineGradientVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryListSnoc + +/-! +# Finite-word directed epigraph normals + +The nonlinear oracle returns the affine-gradient vector followed by the +height coefficient `-1`. This file performs that final append explicitly +and identifies the result with the canonical code of `epigraphNormal`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Pairs the encoded height coefficient `-1` with the directed affine-gradient vector. -/ +def machineDirectedEpigraphNormalSnocInput + (word : List Bool) : List Bool := + pair (rationalEntryBinaryCode (-1)) + (machineDirectedAffineGradientVectorCode word) + +/-- Appends `-1` to the directed affine-gradient vector to encode an epigraph-cut normal. -/ +def machineDirectedEpigraphNormalVectorCode + (word : List Bool) : List Bool := + machineBinaryListSnoc (machineDirectedEpigraphNormalSnocInput word) + +theorem machineDirectedEpigraphNormalSnocInput_mem_FP : + machineDirectedEpigraphNormalSnocInput ∈ FP := + machinePair_mem_FP (machineConst_mem_FP (rationalEntryBinaryCode (-1))) + machineDirectedAffineGradientVectorCode_mem_FP + +theorem machineDirectedEpigraphNormalVectorCode_mem_FP : + machineDirectedEpigraphNormalVectorCode ∈ FP := by + simpa only [machineDirectedEpigraphNormalVectorCode] using! + machineCompose_mem_FP machineDirectedEpigraphNormalSnocInput_mem_FP + machineBinaryListSnoc_mem_FP + +theorem ofFn_directedEpigraphNormal {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + List.ofFn + (epigraphNormal (directedAffineGradientVector tau A y p)) = + List.ofFn (directedAffineGradientVector tau A y p) ++ [-1] := by + rw [List.ofFn_succ'] + simp [epigraphNormal] + +@[simp] theorem machineDirectedEpigraphNormalVectorCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedEpigraphNormalVectorCode + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rationalFiniteVectorCode + (epigraphNormal (directedAffineGradientVector tau A y p)) := by + rw [machineDirectedEpigraphNormalVectorCode, + machineDirectedEpigraphNormalSnocInput, + machineDirectedAffineGradientVectorCode_encode] + change machineBinaryListSnoc + (pair (rationalEntryBinaryCode (-1)) + (binaryListCode rationalEntryBinaryCode + (List.ofFn (directedAffineGradientVector tau A y p)))) = + binaryListCode rationalEntryBinaryCode + (List.ofFn + (epigraphNormal (directedAffineGradientVector tau A y p))) + rw [machineBinaryListSnoc_encode, ofFn_directedEpigraphNormal] + +@[simp] theorem machineDirectedEpigraphNormalVectorCode_encode_oracleNormal + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedEpigraphNormalVectorCode + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rationalFiniteVectorCode + (epigraphNormal ((betheDirectedEpigraphData tau A p).gradient y)) := by + simpa only [betheDirectedEpigraphData, directedAffineGradientVector] using! + machineDirectedEpigraphNormalVectorCode_encode tau A y p + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedLog.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedLog.lean new file mode 100644 index 0000000000..d781b3e7e3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedLog.lean @@ -0,0 +1,1079 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare + +/-! +# Polynomial-time directed rational logarithm + +This file assembles the exact odd-series loop into the full dyadically +range-reduced lower and upper logarithms. The precision is supplied as a +unary ruler. Leading binary positions are read from word lengths, powers of +two are constructed directly as bitstrings, and all rational arithmetic is +performed by the verified unreduced-rational machines. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The binary encoding of the raw-rational constant two. -/ +def rawRatTwoCode : List Bool := rawRatBinaryCode (RawRat.ofNat 2) + +/-- Extracts the unary series-length ruler from a directed-logarithm input. -/ +def machineDirectedLogRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded raw-rational argument of the directed logarithm. -/ +def machineDirectedLogArgumentCode (word : List Bool) : List Bool := + machinePairSecond word + +/-- Computes the numerator `y - 1` of the logarithmic series parameter. -/ +def machineDirectedLogParameterNumeratorCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedLogArgumentCode word) + (machineRawRatNegCode rawRatOneCode)) + +/-- Computes the denominator `y + 1` of the logarithmic series parameter. -/ +def machineDirectedLogParameterDenominatorCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedLogArgumentCode word) rawRatOneCode) + +/-- Computes the raw-rational logarithmic series parameter `(y - 1) / (y + 1)`. -/ +def machineDirectedLogParameterCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineDirectedLogParameterNumeratorCode word) + (machineDirectedLogParameterDenominatorCode word)) + +/-- Evaluates the rational logarithmic series at the transformed argument for the supplied ruler +length. -/ +def machineDirectedLogSeriesSumCode (word : List Bool) : List Bool := + machineRawRationalLogSeriesSumCode + (pair (machineDirectedLogRuler word) + (machineDirectedLogParameterCode word)) + +/-- Doubles the truncated series sum to produce the unit-logarithm lower approximation. -/ +def machineDirectedLogUnitLowerRawCode (word : List Bool) : List Bool := + machineRawRatMulCode (pair rawRatTwoCode + (machineDirectedLogSeriesSumCode word)) + +/-- Builds a unary ruler of length `2 * N + 1` from the series-length ruler. -/ +def machineDirectedLogOddPowerRuler (word : List Bool) : List Bool := + true :: (machineDirectedLogRuler word ++ machineDirectedLogRuler word) + +/-- Raises the logarithmic series parameter to the odd power `2 * N + 1`. -/ +def machineDirectedLogOddPowerCode (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineDirectedLogOddPowerRuler word) + (machineDirectedLogParameterCode word)) + +/-- Computes the square of the logarithmic series parameter. -/ +def machineDirectedLogParameterSquareCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedLogParameterCode word) + (machineDirectedLogParameterCode word)) + +/-- Computes the tail-estimate denominator `1 - x^2` for the series parameter `x`. -/ +def machineDirectedLogErrorDenominatorCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair rawRatOneCode + (machineRawRatNegCode (machineDirectedLogParameterSquareCode word))) + +/-- Computes the geometric tail expression `2 * x^(2*N+1) / (1 - x^2)`. -/ +def machineDirectedLogSeriesErrorCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair rawRatTwoCode + (machineRawRatDivCode + (pair (machineDirectedLogOddPowerCode word) + (machineDirectedLogErrorDenominatorCode word)))) + +/-- Adds the geometric tail expression to the unit-logarithm lower approximation. -/ +def machineDirectedLogUnitUpperRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedLogUnitLowerRawCode word) + (machineDirectedLogSeriesErrorCode word)) + +theorem machineDirectedLogRuler_mem_FP : + machineDirectedLogRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineDirectedLogArgumentCode_mem_FP : + machineDirectedLogArgumentCode ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineDirectedLogParameterNumeratorCode_mem_FP : + machineDirectedLogParameterNumeratorCode ∈ Complexity.FP := by + have hnegOne : (fun _ : List Bool => machineRawRatNegCode rawRatOneCode) ∈ + Complexity.FP := machineConst_mem_FP _ + have hpair := machinePair_mem_FP machineDirectedLogArgumentCode_mem_FP hnegOne + simpa only [machineDirectedLogParameterNumeratorCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineDirectedLogParameterDenominatorCode_mem_FP : + machineDirectedLogParameterDenominatorCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogArgumentCode_mem_FP + (machineConst_mem_FP rawRatOneCode) + simpa only [machineDirectedLogParameterDenominatorCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineDirectedLogParameterCode_mem_FP : + machineDirectedLogParameterCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineDirectedLogParameterNumeratorCode_mem_FP + machineDirectedLogParameterDenominatorCode_mem_FP + simpa only [machineDirectedLogParameterCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineDirectedLogSeriesSumCode_mem_FP : + machineDirectedLogSeriesSumCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogRuler_mem_FP + machineDirectedLogParameterCode_mem_FP + simpa only [machineDirectedLogSeriesSumCode] using! + machineCompose_mem_FP hpair machineRawRationalLogSeriesSumCode_mem_FP + +theorem machineDirectedLogUnitLowerRawCode_mem_FP : + machineDirectedLogUnitLowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatTwoCode) + machineDirectedLogSeriesSumCode_mem_FP + simpa only [machineDirectedLogUnitLowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineDirectedLogOddPowerRuler_mem_FP : + machineDirectedLogOddPowerRuler ∈ Complexity.FP := by + have hdouble := machineAppend_mem_FP machineDirectedLogRuler_mem_FP + machineDirectedLogRuler_mem_FP + simpa only [machineDirectedLogOddPowerRuler] using! + machineCompose_mem_FP hdouble (machinePrepend_mem_FP true) + +theorem machineDirectedLogOddPowerCode_mem_FP : + machineDirectedLogOddPowerCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogOddPowerRuler_mem_FP + machineDirectedLogParameterCode_mem_FP + simpa only [machineDirectedLogOddPowerCode] using! + machineCompose_mem_FP hpair machineRawRatPowerCode_mem_FP + +theorem machineDirectedLogParameterSquareCode_mem_FP : + machineDirectedLogParameterSquareCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogParameterCode_mem_FP + machineDirectedLogParameterCode_mem_FP + simpa only [machineDirectedLogParameterSquareCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineDirectedLogErrorDenominatorCode_mem_FP : + machineDirectedLogErrorDenominatorCode ∈ Complexity.FP := by + have hneg := machineCompose_mem_FP + machineDirectedLogParameterSquareCode_mem_FP machineRawRatNegCode_mem_FP + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) hneg + simpa only [machineDirectedLogErrorDenominatorCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineDirectedLogSeriesErrorCode_mem_FP : + machineDirectedLogSeriesErrorCode ∈ Complexity.FP := by + have hratioPair := machinePair_mem_FP machineDirectedLogOddPowerCode_mem_FP + machineDirectedLogErrorDenominatorCode_mem_FP + have hratio := machineCompose_mem_FP hratioPair machineRawRatDivCode_mem_FP + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatTwoCode) hratio + simpa only [machineDirectedLogSeriesErrorCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineDirectedLogUnitUpperRawCode_mem_FP : + machineDirectedLogUnitUpperRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogUnitLowerRawCode_mem_FP + machineDirectedLogSeriesErrorCode_mem_FP + simpa only [machineDirectedLogUnitUpperRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +/-! ## Dyadic range reduction -/ + +/-- Extracts the absolute numerator bits of the encoded logarithm argument. -/ +def machineDirectedLogNumeratorAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machinePairFirst (machineDirectedLogArgumentCode word)) + +/-- Extracts the denominator bits of the encoded logarithm argument. -/ +def machineDirectedLogDenominatorBits (word : List Bool) : List Bool := + machinePairSecond (machineDirectedLogArgumentCode word) + +/-- Drops one numerator bit to form the ruler for its binary logarithmic scale. -/ +def machineDirectedLogNumeratorLogRuler (word : List Bool) : List Bool := + (machineDirectedLogNumeratorAbsBits word).tail + +/-- Drops one denominator bit to form the ruler for its binary logarithmic scale. -/ +def machineDirectedLogDenominatorLogRuler (word : List Bool) : List Bool := + (machineDirectedLogDenominatorBits word).tail + +/-- Encodes the length of the numerator's logarithmic ruler in binary. -/ +def machineDirectedLogNumeratorLogBits (word : List Bool) : List Bool := + machineLengthBits (machineDirectedLogNumeratorLogRuler word) + +/-- Encodes the length of the denominator's logarithmic ruler in binary. -/ +def machineDirectedLogDenominatorLogBits (word : List Bool) : List Bool := + machineLengthBits (machineDirectedLogDenominatorLogRuler word) + +/-- Encodes the signed difference between numerator and denominator binary logarithmic scales. -/ +def machineDirectedLogExponentIntegerCode (word : List Bool) : List Bool := + machineIntegerAddCode + (pair (machineNaturalIntegerCode (machineDirectedLogNumeratorLogBits word)) + (machineIntegerNegCode + (machineNaturalIntegerCode (machineDirectedLogDenominatorLogBits word)))) + +/-- Encodes `2^ruler.length` as a binary natural number. -/ +def machineDirectedLogPowerTwoBits (ruler : List Bool) : List Bool := + List.replicate ruler.length false ++ [true] + +/-- Encodes the ratio of the numerator and denominator powers of two used for logarithmic +scaling. -/ +def machineDirectedLogScaleCode (word : List Bool) : List Bool := + pair + (machineNaturalIntegerCode + (machineDirectedLogPowerTwoBits + (machineDirectedLogNumeratorLogRuler word))) + (machineDirectedLogPowerTwoBits + (machineDirectedLogDenominatorLogRuler word)) + +/-- Divides the logarithm argument by its encoded power-of-two scale. -/ +def machineDirectedLogResidualCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineDirectedLogArgumentCode word) + (machineDirectedLogScaleCode word)) + +/-- Tests whether the scaled residual is at least one. -/ +def machineDirectedLogResidualAtLeastOne (word : List Bool) : List Bool := + machineRawRatLeBit (pair rawRatOneCode (machineDirectedLogResidualCode word)) + +/-- Chooses the residual or its reciprocal according to whether the residual is at least one. -/ +def machineDirectedLogUnitCode (word : List Bool) : List Bool := + machineIfHead (machineDirectedLogResidualAtLeastOne word) + (machineDirectedLogResidualCode word) + (machineRawRatInvCode (machineDirectedLogResidualCode word)) + +/-- Builds a logarithm-series query for two with the original series-length ruler. -/ +def machineDirectedLogTwoInput (word : List Bool) : List Bool := + pair (machineDirectedLogRuler word) rawRatTwoCode + +/-- Builds a logarithm-series query for the chosen unit residual with the original ruler. -/ +def machineDirectedLogUnitInput (word : List Bool) : List Bool := + pair (machineDirectedLogRuler word) (machineDirectedLogUnitCode word) + +/-- Encodes the signed binary scaling exponent as a raw rational with denominator one. -/ +def machineDirectedLogExponentRawRatCode (word : List Bool) : List Bool := + pair (machineDirectedLogExponentIntegerCode word) [true] + +/-- Computes the lower approximation to the exponent times `log 2`, reversing bounds for +negative exponents. -/ +def machineDirectedLogIntegerLowerCode (word : List Bool) : List Bool := + let lo := machineDirectedLogUnitLowerRawCode (machineDirectedLogTwoInput word) + let hi := machineDirectedLogUnitUpperRawCode (machineDirectedLogTwoInput word) + let factor := machineIfHead (machineHeadBit + (machineDirectedLogExponentIntegerCode word)) hi lo + machineRawRatMulCode + (pair (machineDirectedLogExponentRawRatCode word) factor) + +/-- Computes the upper approximation to the exponent times `log 2`, reversing bounds for +negative exponents. -/ +def machineDirectedLogIntegerUpperCode (word : List Bool) : List Bool := + let lo := machineDirectedLogUnitLowerRawCode (machineDirectedLogTwoInput word) + let hi := machineDirectedLogUnitUpperRawCode (machineDirectedLogTwoInput word) + let factor := machineIfHead (machineHeadBit + (machineDirectedLogExponentIntegerCode word)) lo hi + machineRawRatMulCode + (pair (machineDirectedLogExponentRawRatCode word) factor) + +/-- Chooses the unit-log lower approximation or negated upper approximation for the residual +term. -/ +def machineDirectedLogResidualLowerCode (word : List Bool) : List Bool := + let lo := machineDirectedLogUnitLowerRawCode (machineDirectedLogUnitInput word) + let hi := machineDirectedLogUnitUpperRawCode (machineDirectedLogUnitInput word) + machineIfHead (machineDirectedLogResidualAtLeastOne word) lo + (machineRawRatNegCode hi) + +/-- Chooses the unit-log upper approximation or negated lower approximation for the residual +term. -/ +def machineDirectedLogResidualUpperCode (word : List Bool) : List Bool := + let lo := machineDirectedLogUnitLowerRawCode (machineDirectedLogUnitInput word) + let hi := machineDirectedLogUnitUpperRawCode (machineDirectedLogUnitInput word) + machineIfHead (machineDirectedLogResidualAtLeastOne word) hi + (machineRawRatNegCode lo) + +/-- Adds the scaling and residual lower approximations to encode a directed logarithm result. -/ +def machineDirectedLogLowerRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedLogIntegerLowerCode word) + (machineDirectedLogResidualLowerCode word)) + +/-- Adds the scaling and residual upper approximations to encode a directed logarithm result. -/ +def machineDirectedLogUpperRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedLogIntegerUpperCode word) + (machineDirectedLogResidualUpperCode word)) + +/-- Normalizes the raw lower logarithm approximation into canonical rational encoding. -/ +def machineDirectedLogLowerCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineDirectedLogLowerRawCode word) + +/-- Normalizes the raw upper logarithm approximation into canonical rational encoding. -/ +def machineDirectedLogUpperCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineDirectedLogUpperRawCode word) + +theorem machineDirectedLogNumeratorAbsBits_mem_FP : + machineDirectedLogNumeratorAbsBits ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineDirectedLogArgumentCode_mem_FP + machinePairFirst_mem_FP + simpa only [machineDirectedLogNumeratorAbsBits] using! + machineCompose_mem_FP hnum machineIntegerNatAbsBits_mem_FP + +theorem machineDirectedLogDenominatorBits_mem_FP : + machineDirectedLogDenominatorBits ∈ Complexity.FP := by + simpa only [machineDirectedLogDenominatorBits] using! + machineCompose_mem_FP machineDirectedLogArgumentCode_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedLogNumeratorLogRuler_mem_FP : + machineDirectedLogNumeratorLogRuler ∈ Complexity.FP := by + simpa only [machineDirectedLogNumeratorLogRuler] using! + machineCompose_mem_FP machineDirectedLogNumeratorAbsBits_mem_FP + machineTail_mem_FP + +theorem machineDirectedLogDenominatorLogRuler_mem_FP : + machineDirectedLogDenominatorLogRuler ∈ Complexity.FP := by + simpa only [machineDirectedLogDenominatorLogRuler] using! + machineCompose_mem_FP machineDirectedLogDenominatorBits_mem_FP + machineTail_mem_FP + +theorem machineDirectedLogNumeratorLogBits_mem_FP : + machineDirectedLogNumeratorLogBits ∈ Complexity.FP := by + simpa only [machineDirectedLogNumeratorLogBits] using! + machineCompose_mem_FP machineDirectedLogNumeratorLogRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineDirectedLogDenominatorLogBits_mem_FP : + machineDirectedLogDenominatorLogBits ∈ Complexity.FP := by + simpa only [machineDirectedLogDenominatorLogBits] using! + machineCompose_mem_FP machineDirectedLogDenominatorLogRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineDirectedLogExponentIntegerCode_mem_FP : + machineDirectedLogExponentIntegerCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineDirectedLogNumeratorLogBits_mem_FP + (machinePrepend_mem_FP false) + have hdenNat := machineCompose_mem_FP + machineDirectedLogDenominatorLogBits_mem_FP (machinePrepend_mem_FP false) + have hden := machineCompose_mem_FP hdenNat machineIntegerNegCode_mem_FP + have hpair := machinePair_mem_FP hnum hden + simpa only [machineDirectedLogExponentIntegerCode] using! + machineCompose_mem_FP hpair machineIntegerAddCode_mem_FP + +theorem machineDirectedLogPowerTwoBits_mem_FP : + machineDirectedLogPowerTwoBits ∈ Complexity.FP := by + have hzero := machineZeroBlock_mem_FP + have hone : (fun _ : List Bool => [true]) ∈ Complexity.FP := + machineConst_mem_FP [true] + simpa only [machineDirectedLogPowerTwoBits] using! + machineAppend_mem_FP hzero hone + +theorem machineDirectedLogScaleCode_mem_FP : + machineDirectedLogScaleCode ∈ Complexity.FP := by + have hnumBits := machineCompose_mem_FP + machineDirectedLogNumeratorLogRuler_mem_FP + machineDirectedLogPowerTwoBits_mem_FP + have hnum := machineCompose_mem_FP hnumBits (machinePrepend_mem_FP false) + have hden := machineCompose_mem_FP + machineDirectedLogDenominatorLogRuler_mem_FP + machineDirectedLogPowerTwoBits_mem_FP + exact machinePair_mem_FP hnum hden + +theorem machineDirectedLogResidualCode_mem_FP : + machineDirectedLogResidualCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogArgumentCode_mem_FP + machineDirectedLogScaleCode_mem_FP + simpa only [machineDirectedLogResidualCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineDirectedLogResidualAtLeastOne_mem_FP : + machineDirectedLogResidualAtLeastOne ∈ Complexity.FP := by + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) + machineDirectedLogResidualCode_mem_FP + simpa only [machineDirectedLogResidualAtLeastOne] using! + machineCompose_mem_FP hpair machineRawRatLeBit_mem_FP + +theorem machineDirectedLogUnitCode_mem_FP : + machineDirectedLogUnitCode ∈ Complexity.FP := by + have hinv := machineCompose_mem_FP machineDirectedLogResidualCode_mem_FP + machineRawRatInvCode_mem_FP + simpa only [machineDirectedLogUnitCode] using! + machineIfHead_mem_FP machineDirectedLogResidualAtLeastOne_mem_FP + machineDirectedLogResidualCode_mem_FP hinv + +theorem machineDirectedLogTwoInput_mem_FP : + machineDirectedLogTwoInput ∈ Complexity.FP := + machinePair_mem_FP machineDirectedLogRuler_mem_FP + (machineConst_mem_FP rawRatTwoCode) + +theorem machineDirectedLogUnitInput_mem_FP : + machineDirectedLogUnitInput ∈ Complexity.FP := + machinePair_mem_FP machineDirectedLogRuler_mem_FP + machineDirectedLogUnitCode_mem_FP + +theorem machineDirectedLogExponentRawRatCode_mem_FP : + machineDirectedLogExponentRawRatCode ∈ Complexity.FP := + machinePair_mem_FP machineDirectedLogExponentIntegerCode_mem_FP + (machineConst_mem_FP [true]) + +theorem machineDirectedLogIntegerLowerCode_mem_FP : + machineDirectedLogIntegerLowerCode ∈ Complexity.FP := by + have hlo := machineCompose_mem_FP machineDirectedLogTwoInput_mem_FP + machineDirectedLogUnitLowerRawCode_mem_FP + have hhi := machineCompose_mem_FP machineDirectedLogTwoInput_mem_FP + machineDirectedLogUnitUpperRawCode_mem_FP + have hsign := machineCompose_mem_FP + machineDirectedLogExponentIntegerCode_mem_FP machineHeadBit_mem_FP + have hfactor := machineIfHead_mem_FP hsign hhi hlo + have hpair := machinePair_mem_FP + machineDirectedLogExponentRawRatCode_mem_FP hfactor + simpa only [machineDirectedLogIntegerLowerCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineDirectedLogIntegerUpperCode_mem_FP : + machineDirectedLogIntegerUpperCode ∈ Complexity.FP := by + have hlo := machineCompose_mem_FP machineDirectedLogTwoInput_mem_FP + machineDirectedLogUnitLowerRawCode_mem_FP + have hhi := machineCompose_mem_FP machineDirectedLogTwoInput_mem_FP + machineDirectedLogUnitUpperRawCode_mem_FP + have hsign := machineCompose_mem_FP + machineDirectedLogExponentIntegerCode_mem_FP machineHeadBit_mem_FP + have hfactor := machineIfHead_mem_FP hsign hlo hhi + have hpair := machinePair_mem_FP + machineDirectedLogExponentRawRatCode_mem_FP hfactor + simpa only [machineDirectedLogIntegerUpperCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineDirectedLogResidualLowerCode_mem_FP : + machineDirectedLogResidualLowerCode ∈ Complexity.FP := by + have hlo := machineCompose_mem_FP machineDirectedLogUnitInput_mem_FP + machineDirectedLogUnitLowerRawCode_mem_FP + have hhi := machineCompose_mem_FP machineDirectedLogUnitInput_mem_FP + machineDirectedLogUnitUpperRawCode_mem_FP + have hnegHi := machineCompose_mem_FP hhi machineRawRatNegCode_mem_FP + simpa only [machineDirectedLogResidualLowerCode] using! + machineIfHead_mem_FP machineDirectedLogResidualAtLeastOne_mem_FP + hlo hnegHi + +theorem machineDirectedLogResidualUpperCode_mem_FP : + machineDirectedLogResidualUpperCode ∈ Complexity.FP := by + have hlo := machineCompose_mem_FP machineDirectedLogUnitInput_mem_FP + machineDirectedLogUnitLowerRawCode_mem_FP + have hhi := machineCompose_mem_FP machineDirectedLogUnitInput_mem_FP + machineDirectedLogUnitUpperRawCode_mem_FP + have hnegLo := machineCompose_mem_FP hlo machineRawRatNegCode_mem_FP + simpa only [machineDirectedLogResidualUpperCode] using! + machineIfHead_mem_FP machineDirectedLogResidualAtLeastOne_mem_FP + hhi hnegLo + +theorem machineDirectedLogLowerRawCode_mem_FP : + machineDirectedLogLowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogIntegerLowerCode_mem_FP + machineDirectedLogResidualLowerCode_mem_FP + simpa only [machineDirectedLogLowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineDirectedLogUpperRawCode_mem_FP : + machineDirectedLogUpperRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDirectedLogIntegerUpperCode_mem_FP + machineDirectedLogResidualUpperCode_mem_FP + simpa only [machineDirectedLogUpperRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineDirectedLogLowerCode_mem_FP : + machineDirectedLogLowerCode ∈ Complexity.FP := by + simpa only [machineDirectedLogLowerCode] using! + machineCompose_mem_FP machineDirectedLogLowerRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineDirectedLogUpperCode_mem_FP : + machineDirectedLogUpperCode ∈ Complexity.FP := by + simpa only [machineDirectedLogUpperCode] using! + machineCompose_mem_FP machineDirectedLogUpperRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +/-! ## Exact unit-interval semantics -/ + +namespace RawRat + +/-- The raw-rational series parameter `(y - 1) / (y + 1)` for logarithm evaluation. -/ +def logUnitParameter (y : RawRat) : RawRat := + (y.add one.neg).div (y.add one) + +/-- Twice the truncated logarithmic series at the transformed argument. -/ +def logUnitLower (y : RawRat) (N : β„•) : RawRat := + (ofNat 2).mul (logSeriesSum (logUnitParameter y) N) + +/-- The raw-rational geometric tail expression `2 * x^(2*N+1) / (1 - x^2)` for the transformed +argument. -/ +def logSeriesError (y : RawRat) (N : β„•) : RawRat := + let x := logUnitParameter y + (ofNat 2).mul ((x.pow (2 * N + 1)).div (one.add (x.mul x).neg)) + +/-- The unit-logarithm lower approximation plus its geometric tail expression. -/ +def logUnitUpper (y : RawRat) (N : β„•) : RawRat := + (logUnitLower y N).add (logSeriesError y N) + +@[simp] theorem value_logUnitParameter (y : RawRat) : + (logUnitParameter y).value = binaryRationalLogUnitParameter y.value := by + simp [logUnitParameter, binaryRationalLogUnitParameter, + binaryRatDiv_eq_div, binaryRatSub_eq_sub, binaryRatAdd_eq_add, + sub_eq_add_neg] + +@[simp] theorem value_logUnitLower (y : RawRat) (N : β„•) : + (logUnitLower y N).value = binaryDirectedLogUnitLower y.value N := by + simp [logUnitLower, binaryDirectedLogUnitLower, + binaryRationalLogSeries, binaryRatMul_eq_mul, + RawRat.value_logSeriesSum] + +@[simp] theorem value_logSeriesError (y : RawRat) (N : β„•) : + (logSeriesError y N).value = + binaryRationalLogSeriesError (binaryRationalLogUnitParameter y.value) N := by + simp [logSeriesError, binaryRationalLogSeriesError, + binaryRatMul_eq_mul, binaryRatDiv_eq_div, binaryRatSub_eq_sub, + binaryRatPow_eq_pow] + ring + +@[simp] theorem value_logUnitUpper (y : RawRat) (N : β„•) : + (logUnitUpper y N).value = binaryDirectedLogUnitUpper y.value N := by + simp [logUnitUpper, binaryDirectedLogUnitUpper, + binaryDirectedLogUnitLower, binaryRatAdd_eq_add] + +end RawRat + +@[simp] theorem machineDirectedLogParameterCode_encode + (ruler : List Bool) (y : RawRat) : + machineDirectedLogParameterCode (pair ruler (rawRatBinaryCode y)) = + rawRatBinaryCode (RawRat.logUnitParameter y) := by + rw [machineDirectedLogParameterCode, + machineDirectedLogParameterNumeratorCode, + machineDirectedLogParameterDenominatorCode] + simp only [machineDirectedLogArgumentCode, machinePairSecond_pair, + rawRatOneCode, machineRawRatNegCode_encode, + machineRawRatAddCode_encode, machineRawRatDivCode_encode, + RawRat.logUnitParameter] + +@[simp] theorem machineDirectedLogSeriesSumCode_encode + (y : RawRat) (N : β„•) : + machineDirectedLogSeriesSumCode + (pair (List.replicate N true) (rawRatBinaryCode y)) = + rawRatBinaryCode + (RawRat.logSeriesSum (RawRat.logUnitParameter y) N) := by + rw [machineDirectedLogSeriesSumCode] + simp only [machineDirectedLogRuler, machinePairFirst_pair, + machineDirectedLogParameterCode_encode, + machineRawRationalLogSeriesSumCode_encode] + +@[simp] theorem machineDirectedLogUnitLowerRawCode_encode + (y : RawRat) (N : β„•) : + machineDirectedLogUnitLowerRawCode + (pair (List.replicate N true) (rawRatBinaryCode y)) = + rawRatBinaryCode (RawRat.logUnitLower y N) := by + rw [machineDirectedLogUnitLowerRawCode] + simp only [rawRatTwoCode, machineDirectedLogSeriesSumCode_encode, + machineRawRatMulCode_encode, RawRat.logUnitLower] + +theorem machineDirectedLogOddPowerRuler_encode + (y : RawRat) (N : β„•) : + machineDirectedLogOddPowerRuler + (pair (List.replicate N true) (rawRatBinaryCode y)) = + List.replicate (2 * N + 1) true := by + rw [machineDirectedLogOddPowerRuler] + simp only [machineDirectedLogRuler, machinePairFirst_pair] + rw [← List.replicate_add] + rw [show 2 * N + 1 = (N + N) + 1 by omega, List.replicate_succ] + +@[simp] theorem machineDirectedLogOddPowerCode_encode + (y : RawRat) (N : β„•) : + machineDirectedLogOddPowerCode + (pair (List.replicate N true) (rawRatBinaryCode y)) = + rawRatBinaryCode + ((RawRat.logUnitParameter y).pow (2 * N + 1)) := by + rw [machineDirectedLogOddPowerCode, + machineDirectedLogOddPowerRuler_encode, + machineDirectedLogParameterCode_encode, + machineRawRatPowerCode_encode] + +@[simp] theorem machineDirectedLogParameterSquareCode_encode + (ruler : List Bool) (y : RawRat) : + machineDirectedLogParameterSquareCode + (pair ruler (rawRatBinaryCode y)) = + rawRatBinaryCode + ((RawRat.logUnitParameter y).mul (RawRat.logUnitParameter y)) := by + rw [machineDirectedLogParameterSquareCode] + simp only [machineDirectedLogParameterCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedLogErrorDenominatorCode_encode + (ruler : List Bool) (y : RawRat) : + machineDirectedLogErrorDenominatorCode + (pair ruler (rawRatBinaryCode y)) = + rawRatBinaryCode + (RawRat.one.add + ((RawRat.logUnitParameter y).mul + (RawRat.logUnitParameter y)).neg) := by + rw [machineDirectedLogErrorDenominatorCode] + simp only [rawRatOneCode, machineDirectedLogParameterSquareCode_encode, + machineRawRatNegCode_encode, machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedLogSeriesErrorCode_encode + (y : RawRat) (N : β„•) : + machineDirectedLogSeriesErrorCode + (pair (List.replicate N true) (rawRatBinaryCode y)) = + rawRatBinaryCode (RawRat.logSeriesError y N) := by + rw [machineDirectedLogSeriesErrorCode] + simp only [rawRatTwoCode, machineDirectedLogOddPowerCode_encode, + machineDirectedLogErrorDenominatorCode_encode, + machineRawRatDivCode_encode, machineRawRatMulCode_encode, + RawRat.logSeriesError] + +@[simp] theorem machineDirectedLogUnitUpperRawCode_encode + (y : RawRat) (N : β„•) : + machineDirectedLogUnitUpperRawCode + (pair (List.replicate N true) (rawRatBinaryCode y)) = + rawRatBinaryCode (RawRat.logUnitUpper y N) := by + rw [machineDirectedLogUnitUpperRawCode] + simp only [machineDirectedLogUnitLowerRawCode_encode, + machineDirectedLogSeriesErrorCode_encode, + machineRawRatAddCode_encode, RawRat.logUnitUpper] + +@[simp] theorem machineDirectedLogTwoLowerRawCode_encode (N : β„•) : + machineDirectedLogUnitLowerRawCode + (pair (List.replicate N true) rawRatTwoCode) = + rawRatBinaryCode (RawRat.logUnitLower (RawRat.ofNat 2) N) := by + simpa only [rawRatTwoCode] using! + machineDirectedLogUnitLowerRawCode_encode (RawRat.ofNat 2) N + +@[simp] theorem machineDirectedLogTwoUpperRawCode_encode (N : β„•) : + machineDirectedLogUnitUpperRawCode + (pair (List.replicate N true) rawRatTwoCode) = + rawRatBinaryCode (RawRat.logUnitUpper (RawRat.ofNat 2) N) := by + simpa only [rawRatTwoCode] using! + machineDirectedLogUnitUpperRawCode_encode (RawRat.ofNat 2) N + +private theorem directedLogPowerTwoBits_value : βˆ€ k : β„•, + Nat.fromBitsLE (List.replicate k false ++ [true]) = 2 ^ k := by + intro k + induction k with + | zero => rfl + | succ k ih => + simp only [List.replicate_succ, List.cons_append, + Nat.fromBitsLE_cons, Bool.false_eq, ih, + pow_succ] + norm_num + ring + +@[simp] theorem machineDirectedLogPowerTwoBits_encode (ruler : List Bool) : + machineDirectedLogPowerTwoBits ruler = (2 ^ ruler.length).bits := by + apply Nat.fromBitsLE_inj_of_length_eq + Β· simp [machineDirectedLogPowerTwoBits, Nat.size_eq_bits_len, + Nat.size_pow] + Β· rw [machineDirectedLogPowerTwoBits, directedLogPowerTwoBits_value, + Nat.fromBitsLE_bits] + +@[simp] theorem machineDirectedLogNumeratorAbsBits_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogNumeratorAbsBits + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = q.num.natAbs.bits := by + rw [machineDirectedLogNumeratorAbsBits] + simp only [machineDirectedLogArgumentCode, machinePairSecond_pair, + rawRatBinaryCode, machinePairFirst_pair, + machineIntegerNatAbsBits_encode, rawRatOfRat] + +@[simp] theorem machineDirectedLogDenominatorBits_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogDenominatorBits + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = q.den.bits := by + simp [machineDirectedLogDenominatorBits, machineDirectedLogArgumentCode, + rawRatBinaryCode, rawRatOfRat] + +theorem machineDirectedLogNumeratorLogRuler_length + (ruler : List Bool) (q : β„š) : + (machineDirectedLogNumeratorLogRuler + (pair ruler (rawRatBinaryCode (rawRatOfRat q)))).length = + binaryNatLog2 q.num.natAbs := by + rw [machineDirectedLogNumeratorLogRuler, + machineDirectedLogNumeratorAbsBits_encode] + simp [binaryNatLog2, Nat.size_eq_bits_len] + +theorem machineDirectedLogDenominatorLogRuler_length + (ruler : List Bool) (q : β„š) : + (machineDirectedLogDenominatorLogRuler + (pair ruler (rawRatBinaryCode (rawRatOfRat q)))).length = + binaryNatLog2 q.den := by + rw [machineDirectedLogDenominatorLogRuler, + machineDirectedLogDenominatorBits_encode] + simp [binaryNatLog2, Nat.size_eq_bits_len] + +@[simp] theorem machineDirectedLogNumeratorLogBits_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogNumeratorLogBits + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + (binaryNatLog2 q.num.natAbs).bits := by + rw [machineDirectedLogNumeratorLogBits, machineLengthBits_encode, + machineDirectedLogNumeratorLogRuler_length] + +@[simp] theorem machineDirectedLogDenominatorLogBits_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogDenominatorLogBits + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + (binaryNatLog2 q.den).bits := by + rw [machineDirectedLogDenominatorLogBits, machineLengthBits_encode, + machineDirectedLogDenominatorLogRuler_length] + +@[simp] theorem machineDirectedLogExponentIntegerCode_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogExponentIntegerCode + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + integerBinaryCode (binaryRationalBinaryExponent q) := by + rw [machineDirectedLogExponentIntegerCode] + simp only [machineDirectedLogNumeratorLogBits_encode, + machineDirectedLogDenominatorLogBits_encode, + machineNaturalIntegerCode_natBits, machineIntegerNegCode_encode, + machineIntegerAddCode_encode, binaryRationalBinaryExponent] + congr 1 + +namespace RawRat + +/-- The ratio of powers of two determined by the binary logarithms of the numerator and +denominator. -/ +def logScale (q : β„š) : RawRat := + ⟨(2 ^ binaryNatLog2 q.num.natAbs : β„•), + 2 ^ binaryNatLog2 q.den, by positivity⟩ + +/-- The raw-rational residual obtained by dividing `q` by its power-of-two scale. -/ +def logResidual (q : β„š) : RawRat := + (rawRatOfRat q).div (logScale q) + +/-- Selects the scaled residual or its reciprocal according to whether the residual is at least +one. -/ +def logUnit (q : β„š) : RawRat := + if 1 ≀ (logResidual q).value then logResidual q else (logResidual q).inv + +@[simp] theorem value_logScale (q : β„š) : + (logScale q).value = binaryRationalBinaryScale q := by + simp [logScale, binaryRationalBinaryScale, binaryRatDiv_eq_div, + binaryRatPow_eq_pow, value] + +@[simp] theorem value_logResidual (q : β„š) : + (logResidual q).value = binaryRationalBinaryResidual q := by + simp [logResidual, binaryRationalBinaryResidual, + binaryRatDiv_eq_div] + +@[simp] theorem value_logUnit (q : β„š) : + (logUnit q).value = binaryRationalLogUnit q := by + rw [logUnit, binaryRationalLogUnit] + by_cases h : binaryRationalBinaryResidual q < 1 + Β· have hnot : Β¬ 1 ≀ (logResidual q).value := by simpa using! h + rw [ite_eq_left ((binaryRatLt_eq_true_iff _ _).2 h), ite_eq_right hnot] + simp [binaryRatInv_eq_inv] + Β· have hle : 1 ≀ (logResidual q).value := by + simpa using! (le_of_not_gt h) + have hflag : Β¬ binaryRatLt (binaryRationalBinaryResidual q) 1 = true := + fun htrue => h ((binaryRatLt_eq_true_iff _ _).1 htrue) + rw [ite_eq_right hflag, ite_eq_left hle] + exact RawRat.value_logResidual q + +end RawRat + +@[simp] theorem machineDirectedLogScaleCode_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogScaleCode + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logScale q) := by + rw [machineDirectedLogScaleCode] + rw [machineDirectedLogPowerTwoBits_encode, + machineDirectedLogPowerTwoBits_encode, + machineDirectedLogNumeratorLogRuler_length, + machineDirectedLogDenominatorLogRuler_length, + machineNaturalIntegerCode_natBits] + rfl + +@[simp] theorem machineDirectedLogResidualCode_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogResidualCode + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logResidual q) := by + rw [machineDirectedLogResidualCode] + simp only [machineDirectedLogArgumentCode, machinePairSecond_pair, + machineDirectedLogScaleCode_encode, + machineRawRatDivCode_encode, RawRat.logResidual] + +@[simp] theorem machineDirectedLogResidualAtLeastOne_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogResidualAtLeastOne + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + [decide (1 ≀ binaryRationalBinaryResidual q)] := by + rw [machineDirectedLogResidualAtLeastOne] + simp only [rawRatOneCode, machineDirectedLogResidualCode_encode, + machineRawRatLeBit_encode, RawRat.value_one, + RawRat.value_logResidual] + +@[simp] theorem machineDirectedLogUnitCode_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogUnitCode + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logUnit q) := by + rw [machineDirectedLogUnitCode] + simp only [machineDirectedLogResidualAtLeastOne_encode, + machineDirectedLogResidualCode_encode] + by_cases h : 1 ≀ binaryRationalBinaryResidual q + Β· simp [h, RawRat.logUnit] + Β· rw [show decide (1 ≀ binaryRationalBinaryResidual q) = false by simp [h]] + simp only [machineIfHead_false, machineRawRatInvCode_encode] + simp [RawRat.logUnit, h] + +namespace RawRat + +/-- Embeds an integer as a raw rational with denominator one. -/ +def ofInt (z : β„€) : RawRat := ⟨z, 1, by omega⟩ + +@[simp] theorem value_ofInt (z : β„€) : (ofInt z).value = z := by + simp [ofInt, value] + +/-- Approximates the binary exponent times `log 2` from below, with bound choice determined by +its sign. -/ +def logIntegerLower (q : β„š) (N : β„•) : RawRat := + let k := binaryRationalBinaryExponent q + (ofInt k).mul + (if 0 ≀ k then logUnitLower (ofNat 2) N + else logUnitUpper (ofNat 2) N) + +/-- Approximates the binary exponent times `log 2` from above, with bound choice determined by +its sign. -/ +def logIntegerUpper (q : β„š) (N : β„•) : RawRat := + let k := binaryRationalBinaryExponent q + (ofInt k).mul + (if 0 ≀ k then logUnitUpper (ofNat 2) N + else logUnitLower (ofNat 2) N) + +/-- Selects the unit-log lower approximation or negated upper approximation for the scaled +residual. -/ +def logResidualLower (q : β„š) (N : β„•) : RawRat := + if 1 ≀ (logResidual q).value then logUnitLower (logUnit q) N + else (logUnitUpper (logUnit q) N).neg + +/-- Selects the unit-log upper approximation or negated lower approximation for the scaled +residual. -/ +def logResidualUpper (q : β„š) (N : β„•) : RawRat := + if 1 ≀ (logResidual q).value then logUnitUpper (logUnit q) N + else (logUnitLower (logUnit q) N).neg + +/-- Adds the lower approximations for the binary scaling and residual logarithms. -/ +def logLower (q : β„š) (N : β„•) : RawRat := + (logIntegerLower q N).add (logResidualLower q N) + +/-- Adds the upper approximations for the binary scaling and residual logarithms. -/ +def logUpper (q : β„š) (N : β„•) : RawRat := + (logIntegerUpper q N).add (logResidualUpper q N) + +@[simp] theorem value_logIntegerLower (q : β„š) (N : β„•) : + (logIntegerLower q N).value = + binaryDirectedIntMulLower (binaryRationalBinaryExponent q) + (binaryDirectedLogUnitLower 2 N) + (binaryDirectedLogUnitUpper 2 N) := by + rw [logIntegerLower, value_mul, value_ofInt, + binaryDirectedIntMulLower] + split_ifs <;> simp [binaryRatMul_eq_mul] + +@[simp] theorem value_logIntegerUpper (q : β„š) (N : β„•) : + (logIntegerUpper q N).value = + binaryDirectedIntMulUpper (binaryRationalBinaryExponent q) + (binaryDirectedLogUnitLower 2 N) + (binaryDirectedLogUnitUpper 2 N) := by + rw [logIntegerUpper, value_mul, value_ofInt, + binaryDirectedIntMulUpper] + split_ifs <;> simp [binaryRatMul_eq_mul] + +@[simp] theorem value_logResidualLower (q : β„š) (N : β„•) : + (logResidualLower q N).value = + if binaryRatLt (binaryRationalBinaryResidual q) 1 then + binaryRatNeg (binaryDirectedLogUnitUpper (binaryRationalLogUnit q) N) + else binaryDirectedLogUnitLower (binaryRationalLogUnit q) N := by + rw [logResidualLower] + by_cases h : binaryRationalBinaryResidual q < 1 + Β· have hnot : Β¬ 1 ≀ (logResidual q).value := by simpa using! h + rw [ite_eq_right hnot, + ite_eq_left ((binaryRatLt_eq_true_iff _ _).2 h)] + simp [binaryRatNeg_eq_neg] + Β· have hle : 1 ≀ (logResidual q).value := by + simpa using! (le_of_not_gt h) + have hflag : Β¬ binaryRatLt (binaryRationalBinaryResidual q) 1 = true := + fun htrue => h ((binaryRatLt_eq_true_iff _ _).1 htrue) + rw [ite_eq_left hle, ite_eq_right hflag] + simpa only [value_logUnit] using! value_logUnitLower (logUnit q) N + +@[simp] theorem value_logResidualUpper (q : β„š) (N : β„•) : + (logResidualUpper q N).value = + if binaryRatLt (binaryRationalBinaryResidual q) 1 then + binaryRatNeg (binaryDirectedLogUnitLower (binaryRationalLogUnit q) N) + else binaryDirectedLogUnitUpper (binaryRationalLogUnit q) N := by + rw [logResidualUpper] + by_cases h : binaryRationalBinaryResidual q < 1 + Β· have hnot : Β¬ 1 ≀ (logResidual q).value := by simpa using! h + rw [ite_eq_right hnot, + ite_eq_left ((binaryRatLt_eq_true_iff _ _).2 h)] + simp [binaryRatNeg_eq_neg] + Β· have hle : 1 ≀ (logResidual q).value := by + simpa using! (le_of_not_gt h) + have hflag : Β¬ binaryRatLt (binaryRationalBinaryResidual q) 1 = true := + fun htrue => h ((binaryRatLt_eq_true_iff _ _).1 htrue) + rw [ite_eq_left hle, ite_eq_right hflag] + simpa only [value_logUnit] using! value_logUnitUpper (logUnit q) N + +@[simp] theorem value_logLower (q : β„š) (N : β„•) : + (logLower q N).value = binaryDirectedLogLower q N := by + simp [logLower, binaryDirectedLogLower, binaryRatAdd_eq_add] + +@[simp] theorem value_logUpper (q : β„š) (N : β„•) : + (logUpper q N).value = binaryDirectedLogUpper q N := by + simp [logUpper, binaryDirectedLogUpper, binaryRatAdd_eq_add] + +end RawRat + +@[simp] theorem machineDirectedLogExponentRawRatCode_encode + (ruler : List Bool) (q : β„š) : + machineDirectedLogExponentRawRatCode + (pair ruler (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode + (RawRat.ofInt (binaryRationalBinaryExponent q)) := by + rw [machineDirectedLogExponentRawRatCode, + machineDirectedLogExponentIntegerCode_encode] + simp [rawRatBinaryCode, RawRat.ofInt] + +@[simp] theorem machineDirectedLogTwoInput_encode (q : β„š) (N : β„•) : + machineDirectedLogTwoInput + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + pair (List.replicate N true) rawRatTwoCode := by + simp [machineDirectedLogTwoInput, machineDirectedLogRuler] + +@[simp] theorem machineDirectedLogUnitInput_encode (q : β„š) (N : β„•) : + machineDirectedLogUnitInput + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + pair (List.replicate N true) (rawRatBinaryCode (RawRat.logUnit q)) := by + simp [machineDirectedLogUnitInput, machineDirectedLogRuler] + +@[simp] theorem machineDirectedLogIntegerLowerCode_encode (q : β„š) (N : β„•) : + machineDirectedLogIntegerLowerCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logIntegerLower q N) := by + cases hk : binaryRationalBinaryExponent q with + | ofNat k => + simp [machineDirectedLogIntegerLowerCode, + machineDirectedLogTwoInput_encode, + machineDirectedLogExponentIntegerCode_encode, + machineDirectedLogExponentRawRatCode_encode, + machineDirectedLogTwoLowerRawCode_encode, + machineDirectedLogTwoUpperRawCode_encode, + machineRawRatMulCode_encode, RawRat.logIntegerLower, hk, + integerBinaryCode] + | negSucc k => + simp [machineDirectedLogIntegerLowerCode, + machineDirectedLogTwoInput_encode, + machineDirectedLogExponentIntegerCode_encode, + machineDirectedLogExponentRawRatCode_encode, + machineDirectedLogTwoLowerRawCode_encode, + machineDirectedLogTwoUpperRawCode_encode, + machineRawRatMulCode_encode, RawRat.logIntegerLower, hk, + integerBinaryCode] + +@[simp] theorem machineDirectedLogIntegerUpperCode_encode (q : β„š) (N : β„•) : + machineDirectedLogIntegerUpperCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logIntegerUpper q N) := by + cases hk : binaryRationalBinaryExponent q with + | ofNat k => + simp [machineDirectedLogIntegerUpperCode, + machineDirectedLogTwoInput_encode, + machineDirectedLogExponentIntegerCode_encode, + machineDirectedLogExponentRawRatCode_encode, + machineDirectedLogTwoLowerRawCode_encode, + machineDirectedLogTwoUpperRawCode_encode, + machineRawRatMulCode_encode, RawRat.logIntegerUpper, hk, + integerBinaryCode] + | negSucc k => + simp [machineDirectedLogIntegerUpperCode, + machineDirectedLogTwoInput_encode, + machineDirectedLogExponentIntegerCode_encode, + machineDirectedLogExponentRawRatCode_encode, + machineDirectedLogTwoLowerRawCode_encode, + machineDirectedLogTwoUpperRawCode_encode, + machineRawRatMulCode_encode, RawRat.logIntegerUpper, hk, + integerBinaryCode] + +@[simp] theorem machineDirectedLogResidualLowerCode_encode (q : β„š) (N : β„•) : + machineDirectedLogResidualLowerCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logResidualLower q N) := by + rw [machineDirectedLogResidualLowerCode] + simp only [machineDirectedLogUnitInput_encode, + machineDirectedLogUnitLowerRawCode_encode, + machineDirectedLogUnitUpperRawCode_encode, + machineDirectedLogResidualAtLeastOne_encode] + by_cases h : 1 ≀ binaryRationalBinaryResidual q + Β· simp [h, RawRat.logResidualLower] + Β· rw [show decide (1 ≀ binaryRationalBinaryResidual q) = false by simp [h]] + simp only [machineIfHead_false, machineRawRatNegCode_encode] + simp [RawRat.logResidualLower, h] + +@[simp] theorem machineDirectedLogResidualUpperCode_encode (q : β„š) (N : β„•) : + machineDirectedLogResidualUpperCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logResidualUpper q N) := by + rw [machineDirectedLogResidualUpperCode] + simp only [machineDirectedLogUnitInput_encode, + machineDirectedLogUnitLowerRawCode_encode, + machineDirectedLogUnitUpperRawCode_encode, + machineDirectedLogResidualAtLeastOne_encode] + by_cases h : 1 ≀ binaryRationalBinaryResidual q + Β· simp [h, RawRat.logResidualUpper] + Β· rw [show decide (1 ≀ binaryRationalBinaryResidual q) = false by simp [h]] + simp only [machineIfHead_false, machineRawRatNegCode_encode] + simp [RawRat.logResidualUpper, h] + +@[simp] theorem machineDirectedLogLowerRawCode_encode (q : β„š) (N : β„•) : + machineDirectedLogLowerRawCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logLower q N) := by + rw [machineDirectedLogLowerRawCode] + simp only [machineDirectedLogIntegerLowerCode_encode, + machineDirectedLogResidualLowerCode_encode, + machineRawRatAddCode_encode, RawRat.logLower] + +@[simp] theorem machineDirectedLogUpperRawCode_encode (q : β„š) (N : β„•) : + machineDirectedLogUpperRawCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (RawRat.logUpper q N) := by + rw [machineDirectedLogUpperRawCode] + simp only [machineDirectedLogIntegerUpperCode_encode, + machineDirectedLogResidualUpperCode_encode, + machineRawRatAddCode_encode, RawRat.logUpper] + +theorem machineDirectedLogLowerCode_encode (q : β„š) (N : β„•) : + machineDirectedLogLowerCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rationalBinaryCode (binaryDirectedLogLower q N) := by + rw [machineDirectedLogLowerCode, + machineDirectedLogLowerRawCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_logLower] + +theorem machineDirectedLogUpperCode_encode (q : β„š) (N : β„•) : + machineDirectedLogUpperCode + (pair (List.replicate N true) (rawRatBinaryCode (rawRatOfRat q))) = + rationalBinaryCode (binaryDirectedLogUpper q N) := by + rw [machineDirectedLogUpperCode, + machineDirectedLogUpperRawCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_logUpper] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientCoordinate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientCoordinate.lean new file mode 100644 index 0000000000..c88a1106f1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientCoordinate.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveCoordinate + +/-! +# Finite-word lower endpoint for one directed Bethe gradient coordinate + +This file compiles the lower endpoint + +`-logUpper(a) + (1+tau) logLower(x) + logLower(1-x) + (2+tau)` + +into an ordinary finite-word machine. It deliberately reuses the canonical +input parser and normalized complement from the objective-coordinate machine, +so the two implementations cannot silently disagree about input layout or +about the representation of `1-x`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Negates the directed upper approximation to the logarithm of the matrix coefficient. -/ +def machineDirectedGradientCoordinateNegLogA + (word : List Bool) : List Bool := + machineRawRatNegCode + (machineDirectedObjectiveCoordinateLogAUpper word) + +/-- Multiplies the directed lower approximation to `log x` by `1 + tau`. -/ +def machineDirectedGradientCoordinateScaledLogX + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedObjectiveCoordinateOnePlusTau word) + (machineDirectedObjectiveCoordinateLogXLower word)) + +/-- Computes the directed lower logarithm approximation for the complementary coordinate `1 - +x`. -/ +def machineDirectedGradientCoordinateLogComplementLower + (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (machineDirectedObjectiveCoordinateLogComplementInput word) + +/-- Adds the negated coefficient logarithm and the scaled coordinate logarithm. -/ +def machineDirectedGradientCoordinateFirstTwo + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedGradientCoordinateNegLogA word) + (machineDirectedGradientCoordinateScaledLogX word)) + +/-- Adds the complementary-coordinate logarithm to the first two gradient terms. -/ +def machineDirectedGradientCoordinateFirstThree + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedGradientCoordinateFirstTwo word) + (machineDirectedGradientCoordinateLogComplementLower word)) + +/-- Computes the raw-rational constant term `2 + tau` in the negative-gradient formula. -/ +def machineDirectedGradientCoordinateTwoPlusTau + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode RawRat.one) + (machineDirectedObjectiveCoordinateOnePlusTau word)) + +/-- Combines the three directed logarithm terms with `2 + tau` into a negative-gradient +approximation. -/ +def machineDirectedNegativeGradientLowerRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedGradientCoordinateFirstThree word) + (machineDirectedGradientCoordinateTwoPlusTau word)) + +theorem machineDirectedGradientCoordinateNegLogA_mem_FP : + machineDirectedGradientCoordinateNegLogA ∈ FP := by + simpa only [machineDirectedGradientCoordinateNegLogA] using! + machineCompose_mem_FP machineDirectedObjectiveCoordinateLogAUpper_mem_FP + machineRawRatNegCode_mem_FP + +theorem machineDirectedGradientCoordinateScaledLogX_mem_FP : + machineDirectedGradientCoordinateScaledLogX ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateOnePlusTau_mem_FP + machineDirectedObjectiveCoordinateLogXLower_mem_FP + simpa only [machineDirectedGradientCoordinateScaledLogX] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectedGradientCoordinateLogComplementLower_mem_FP : + machineDirectedGradientCoordinateLogComplementLower ∈ FP := by + simpa only [machineDirectedGradientCoordinateLogComplementLower] using! + machineCompose_mem_FP + machineDirectedObjectiveCoordinateLogComplementInput_mem_FP + machineScheduledLogLowerRawCode_mem_FP + +theorem machineDirectedGradientCoordinateFirstTwo_mem_FP : + machineDirectedGradientCoordinateFirstTwo ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedGradientCoordinateNegLogA_mem_FP + machineDirectedGradientCoordinateScaledLogX_mem_FP + simpa only [machineDirectedGradientCoordinateFirstTwo] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedGradientCoordinateFirstThree_mem_FP : + machineDirectedGradientCoordinateFirstThree ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedGradientCoordinateFirstTwo_mem_FP + machineDirectedGradientCoordinateLogComplementLower_mem_FP + simpa only [machineDirectedGradientCoordinateFirstThree] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedGradientCoordinateTwoPlusTau_mem_FP : + machineDirectedGradientCoordinateTwoPlusTau ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineDirectedObjectiveCoordinateOnePlusTau_mem_FP + simpa only [machineDirectedGradientCoordinateTwoPlusTau] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedNegativeGradientLowerRawCode_mem_FP : + machineDirectedNegativeGradientLowerRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedGradientCoordinateFirstThree_mem_FP + machineDirectedGradientCoordinateTwoPlusTau_mem_FP + simpa only [machineDirectedNegativeGradientLowerRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +/-- The raw formula `-logUpper(a) + (1+tau)*logLower(x) + logLower(1-x) + 2+tau` at precision +`p`. -/ +def rawDirectedNegativeGradientLower + (tau a x : β„š) (p : β„•) : RawRat := + let rawTau := rawRatOfRat tau + let negLogA := (rawScheduledLogUpper a p).neg + let scaledLogX := (RawRat.one.add rawTau).mul + (rawScheduledLogLower x p) + let logComplement := rawScheduledLogLower (1 - x) p + let twoPlusTau := RawRat.one.add (RawRat.one.add rawTau) + ((negLogA.add scaledLogX).add logComplement).add twoPlusTau + +@[simp] theorem machineDirectedGradientCoordinateNegLogA_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateNegLogA + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawScheduledLogUpper a p).neg := by + rw [machineDirectedGradientCoordinateNegLogA, + machineDirectedObjectiveCoordinateLogAUpper_encode, + machineRawRatNegCode_encode] + +@[simp] theorem machineDirectedGradientCoordinateScaledLogX_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateScaledLogX + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((RawRat.one.add (rawRatOfRat tau)).mul + (rawScheduledLogLower x p)) := by + rw [machineDirectedGradientCoordinateScaledLogX, + machineDirectedObjectiveCoordinateOnePlusTau_encode, + machineDirectedObjectiveCoordinateLogXLower_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedGradientCoordinateLogComplementLower_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateLogComplementLower + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawScheduledLogLower (1 - x) p) := by + rw [machineDirectedGradientCoordinateLogComplementLower, + machineDirectedObjectiveCoordinateLogComplementInput, + machineDirectedObjectiveCoordinatePrecision_encode, + machineDirectedObjectiveCoordinateComplement_encode, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineDirectedGradientCoordinateFirstTwo_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateFirstTwo + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((rawScheduledLogUpper a p).neg.add + ((RawRat.one.add (rawRatOfRat tau)).mul + (rawScheduledLogLower x p))) := by + rw [machineDirectedGradientCoordinateFirstTwo, + machineDirectedGradientCoordinateNegLogA_encode, + machineDirectedGradientCoordinateScaledLogX_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedGradientCoordinateFirstThree_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateFirstThree + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + (((rawScheduledLogUpper a p).neg.add + ((RawRat.one.add (rawRatOfRat tau)).mul + (rawScheduledLogLower x p))).add + (rawScheduledLogLower (1 - x) p)) := by + rw [machineDirectedGradientCoordinateFirstThree, + machineDirectedGradientCoordinateFirstTwo_encode, + machineDirectedGradientCoordinateLogComplementLower_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedGradientCoordinateTwoPlusTau_encode + (tau a x : β„š) (p : β„•) : + machineDirectedGradientCoordinateTwoPlusTau + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + (RawRat.one.add (RawRat.one.add (rawRatOfRat tau))) := by + rw [machineDirectedGradientCoordinateTwoPlusTau, + machineDirectedObjectiveCoordinateOnePlusTau_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedNegativeGradientLowerRawCode_encode + (tau a x : β„š) (p : β„•) : + machineDirectedNegativeGradientLowerRawCode + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawDirectedNegativeGradientLower tau a x p) := by + rw [machineDirectedNegativeGradientLowerRawCode, + machineDirectedGradientCoordinateFirstThree_encode, + machineDirectedGradientCoordinateTwoPlusTau_encode, + machineRawRatAddCode_encode] + rfl + +theorem rawDirectedNegativeGradientLower_value + (tau a x : β„š) (p : β„•) : + (rawDirectedNegativeGradientLower tau a x p).value = + directedNegativeGradientLower tau a x p := by + simp [rawDirectedNegativeGradientLower, + directedNegativeGradientLower, RawRat.value_add, RawRat.value_mul, + RawRat.value_neg, RawRat.value_one, rawRatOfRat_value, + rawScheduledLogLower_value, rawScheduledLogUpper_value] + ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientEntry.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientEntry.lean new file mode 100644 index 0000000000..537996579a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeGradientEntry.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeGradientCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveSum + +/-! +# Finite-word entries of the directed full gradient + +The adapter in this file adds a queried row and column to the canonical +directed-objective payload. It then reuses the already verified matrix-entry +and affine-entry recovery path of the row-major objective machine and sends +the resulting scalar input to the directed gradient machine. This keeps the +objective and gradient implementations on one common interpretation of `A` +and of the recovered Birkhoff matrix. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary row index from a negative-gradient entry query. -/ +def machineDirectedGradientEntryRow (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the column index and payload from a negative-gradient entry query. -/ +def machineDirectedGradientEntryRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary column index from a negative-gradient entry query. -/ +def machineDirectedGradientEntryColumn (word : List Bool) : List Bool := + machinePairFirst (machineDirectedGradientEntryRest word) + +/-- Extracts the encoded objective payload following the row and column of a gradient-entry +request. -/ +def machineDirectedGradientEntryPayload (word : List Bool) : List Bool := + machinePairSecond (machineDirectedGradientEntryRest word) + +/-- Builds an objective-sum state for the requested gradient entry, with zero accumulator, empty +bound word, and an unset completion bit. -/ +def machineDirectedGradientEntryAsObjectiveState + (word : List Bool) : List Bool := + machineDirectedObjectiveSumPack + (machineDirectedGradientEntryRow word) + (machineDirectedGradientEntryColumn word) + (rawRatBinaryCode RawRat.zero) [] [false] + (machineDirectedGradientEntryPayload word) + +/-- Assembles precision, regularization parameter, matrix entry, and affine entry for the +requested gradient coordinate. -/ +def machineDirectedGradientEntryScalarInput + (word : List Bool) : List Bool := + machineDirectedObjectiveSumCoordinateInput + (machineDirectedGradientEntryAsObjectiveState word) + +/-- Computes the encoded directed lower approximation to the negative gradient at the requested +matrix entry. -/ +def machineDirectedNegativeGradientEntryRawCode + (word : List Bool) : List Bool := + machineDirectedNegativeGradientLowerRawCode + (machineDirectedGradientEntryScalarInput word) + +theorem machineDirectedGradientEntryRow_mem_FP : + machineDirectedGradientEntryRow ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectedGradientEntryRest_mem_FP : + machineDirectedGradientEntryRest ∈ FP := machinePairSecond_mem_FP + +theorem machineDirectedGradientEntryColumn_mem_FP : + machineDirectedGradientEntryColumn ∈ FP := by + simpa only [machineDirectedGradientEntryColumn] using! + machineCompose_mem_FP machineDirectedGradientEntryRest_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedGradientEntryPayload_mem_FP : + machineDirectedGradientEntryPayload ∈ FP := by + simpa only [machineDirectedGradientEntryPayload] using! + machineCompose_mem_FP machineDirectedGradientEntryRest_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedGradientEntryAsObjectiveState_mem_FP : + machineDirectedGradientEntryAsObjectiveState ∈ FP := by + have hacc : (fun _ : List Bool => rawRatBinaryCode RawRat.zero) ∈ FP := + machineConst_mem_FP _ + have hbound : (fun _ : List Bool => ([] : List Bool)) ∈ FP := + machineConst_mem_FP _ + have hdone : (fun _ : List Bool => [false]) ∈ FP := + machineConst_mem_FP _ + have htail := machinePair_mem_FP hdone + machineDirectedGradientEntryPayload_mem_FP + have hwithBound := machinePair_mem_FP hbound htail + have hwithAcc := machinePair_mem_FP hacc hwithBound + have hwithColumn := machinePair_mem_FP + machineDirectedGradientEntryColumn_mem_FP hwithAcc + simpa only [machineDirectedGradientEntryAsObjectiveState, + machineDirectedObjectiveSumPack] using! + machinePair_mem_FP machineDirectedGradientEntryRow_mem_FP hwithColumn + +theorem machineDirectedGradientEntryScalarInput_mem_FP : + machineDirectedGradientEntryScalarInput ∈ FP := by + simpa only [machineDirectedGradientEntryScalarInput] using! + machineCompose_mem_FP + machineDirectedGradientEntryAsObjectiveState_mem_FP + machineDirectedObjectiveSumCoordinateInput_mem_FP + +theorem machineDirectedNegativeGradientEntryRawCode_mem_FP : + machineDirectedNegativeGradientEntryRawCode ∈ FP := by + simpa only [machineDirectedNegativeGradientEntryRawCode] using! + machineCompose_mem_FP machineDirectedGradientEntryScalarInput_mem_FP + machineDirectedNegativeGradientLowerRawCode_mem_FP + +/-- Encodes row and column as unary rulers preceding the canonical objective payload for `tau`, +`A`, `y`, and precision `p`. -/ +def machineDirectedGradientEntryCanonicalWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : List Bool := + pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p)) + +@[simp] theorem machineDirectedGradientEntryAsObjectiveState_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + machineDirectedGradientEntryAsObjectiveState + (machineDirectedGradientEntryCanonicalWord tau A y p i j) = + machineDirectedObjectiveSumCanonicalState tau A y p i j + RawRat.zero false [] := by + simp [machineDirectedGradientEntryAsObjectiveState, + machineDirectedGradientEntryCanonicalWord, + machineDirectedGradientEntryRow, + machineDirectedGradientEntryColumn, + machineDirectedGradientEntryRest, + machineDirectedGradientEntryPayload, + machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedGradientEntryScalarInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + machineDirectedGradientEntryScalarInput + (machineDirectedGradientEntryCanonicalWord tau A y p i j) = + machineDirectedObjectiveCoordinateCanonicalWord tau (A i j) + (betheAffineMatrixQ y i j) p := by + rw [machineDirectedGradientEntryScalarInput, + machineDirectedGradientEntryAsObjectiveState_encode, + machineDirectedObjectiveSumCoordinateInput_canonicalState] + +@[simp] theorem machineDirectedNegativeGradientEntryRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + machineDirectedNegativeGradientEntryRawCode + (machineDirectedGradientEntryCanonicalWord tau A y p i j) = + rawRatBinaryCode + (rawDirectedNegativeGradientLower tau (A i j) + (betheAffineMatrixQ y i j) p) := by + rw [machineDirectedNegativeGradientEntryRawCode, + machineDirectedGradientEntryScalarInput_encode, + machineDirectedNegativeGradientLowerRawCode_encode] + +theorem machineDirectedNegativeGradientEntry_value {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + (rawDirectedNegativeGradientLower tau (A i j) + (betheAffineMatrixQ y i j) p).value = + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i j := by + rw [rawDirectedNegativeGradientLower_value] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveCoordinate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveCoordinate.lean new file mode 100644 index 0000000000..df73485c8e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveCoordinate.lean @@ -0,0 +1,537 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorCutEntry +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization + +/-! +# Finite-word lower endpoint for one directed Bethe objective coordinate + +This file compiles the three scheduled logarithms and the exact rational +arithmetic in `directedNegativeObjectiveCoordinateLower` into one ordinary +bitstring machine. The complement `1-x` is normalized before it is passed +to the logarithm routine, so the scheduled-log correctness theorem applies +to the canonical reduced rational rather than an unreduced subtraction. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary precision field from an objective-coordinate request. -/ +def machineDirectedObjectiveCoordinatePrecision + (word : List Bool) : List Bool := machinePairFirst word + +/-- Extracts the objective-coordinate payload after its precision field. -/ +def machineDirectedObjectiveCoordinateRest + (word : List Bool) : List Bool := machinePairSecond word + +/-- Extracts the encoded regularization parameter from an objective-coordinate request. -/ +def machineDirectedObjectiveCoordinateTau + (word : List Bool) : List Bool := + machinePairFirst (machineDirectedObjectiveCoordinateRest word) + +/-- Extracts the encoded matrix coefficient from an objective-coordinate request. -/ +def machineDirectedObjectiveCoordinateA + (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machineDirectedObjectiveCoordinateRest word)) + +/-- Extracts the encoded affine coordinate from an objective-coordinate request. -/ +def machineDirectedObjectiveCoordinateX + (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond + (machineDirectedObjectiveCoordinateRest word)) + +/-- Computes the raw rational code for one minus the requested affine coordinate. -/ +def machineDirectedObjectiveCoordinateComplementRaw + (word : List Bool) : List Bool := + machineRawRatSubCode + (pair (rawRatBinaryCode RawRat.one) + (machineDirectedObjectiveCoordinateX word)) + +/-- Normalizes the raw code for the complement of the requested affine coordinate. -/ +def machineDirectedObjectiveCoordinateComplement + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineDirectedObjectiveCoordinateComplementRaw word) + +/-- Pairs the requested unary precision with the matrix coefficient for directed logarithm +evaluation. -/ +def machineDirectedObjectiveCoordinateLogAInput + (word : List Bool) : List Bool := + pair (machineDirectedObjectiveCoordinatePrecision word) + (machineDirectedObjectiveCoordinateA word) + +/-- Pairs the requested unary precision with the affine coordinate for directed logarithm +evaluation. -/ +def machineDirectedObjectiveCoordinateLogXInput + (word : List Bool) : List Bool := + pair (machineDirectedObjectiveCoordinatePrecision word) + (machineDirectedObjectiveCoordinateX word) + +/-- Pairs the requested unary precision with the normalized coordinate complement for directed +logarithm evaluation. -/ +def machineDirectedObjectiveCoordinateLogComplementInput + (word : List Bool) : List Bool := + pair (machineDirectedObjectiveCoordinatePrecision word) + (machineDirectedObjectiveCoordinateComplement word) + +/-- Computes the encoded scheduled upper approximation to the logarithm of the matrix +coefficient. -/ +def machineDirectedObjectiveCoordinateLogAUpper + (word : List Bool) : List Bool := + machineScheduledLogUpperRawCode + (machineDirectedObjectiveCoordinateLogAInput word) + +/-- Computes the encoded scheduled lower approximation to the logarithm of the affine +coordinate. -/ +def machineDirectedObjectiveCoordinateLogXLower + (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (machineDirectedObjectiveCoordinateLogXInput word) + +/-- Computes the encoded scheduled upper approximation to the logarithm of the coordinate +complement. -/ +def machineDirectedObjectiveCoordinateLogComplementUpper + (word : List Bool) : List Bool := + machineScheduledLogUpperRawCode + (machineDirectedObjectiveCoordinateLogComplementInput word) + +/-- Negates the encoded affine coordinate for the first objective summand. -/ +def machineDirectedObjectiveCoordinateNegX + (word : List Bool) : List Bool := + machineRawRatNegCode (machineDirectedObjectiveCoordinateX word) + +/-- Computes the raw code for minus the affine coordinate times the upper logarithm +approximation of the matrix coefficient. -/ +def machineDirectedObjectiveCoordinateFirstTerm + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedObjectiveCoordinateNegX word) + (machineDirectedObjectiveCoordinateLogAUpper word)) + +/-- Computes the raw rational code for one plus the regularization parameter. -/ +def machineDirectedObjectiveCoordinateOnePlusTau + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode RawRat.one) + (machineDirectedObjectiveCoordinateTau word)) + +/-- Computes the raw code for the affine coordinate multiplied by one plus the regularization +parameter. -/ +def machineDirectedObjectiveCoordinateMiddleScale + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedObjectiveCoordinateOnePlusTau word) + (machineDirectedObjectiveCoordinateX word)) + +/-- Computes the middle objective summand by multiplying the scaled affine coordinate by its +lower logarithm approximation. -/ +def machineDirectedObjectiveCoordinateMiddleTerm + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedObjectiveCoordinateMiddleScale word) + (machineDirectedObjectiveCoordinateLogXLower word)) + +/-- Computes the raw code for the coordinate complement times its upper logarithm approximation. -/ +def machineDirectedObjectiveCoordinateComplementProduct + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectedObjectiveCoordinateComplement word) + (machineDirectedObjectiveCoordinateLogComplementUpper word)) + +/-- Negates the complement-logarithm product to obtain the last objective summand. -/ +def machineDirectedObjectiveCoordinateLastTerm + (word : List Bool) : List Bool := + machineRawRatNegCode + (machineDirectedObjectiveCoordinateComplementProduct word) + +/-- Adds the first and middle directed objective summands in raw rational code. -/ +def machineDirectedObjectiveCoordinateFirstTwo + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedObjectiveCoordinateFirstTerm word) + (machineDirectedObjectiveCoordinateMiddleTerm word)) + +/-- Adds all three directed summands to encode the lower approximation of one negative-objective +coordinate. -/ +def machineDirectedNegativeObjectiveCoordinateLowerRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedObjectiveCoordinateFirstTwo word) + (machineDirectedObjectiveCoordinateLastTerm word)) + +theorem machineDirectedObjectiveCoordinatePrecision_mem_FP : + machineDirectedObjectiveCoordinatePrecision ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectedObjectiveCoordinateRest_mem_FP : + machineDirectedObjectiveCoordinateRest ∈ FP := machinePairSecond_mem_FP + +theorem machineDirectedObjectiveCoordinateTau_mem_FP : + machineDirectedObjectiveCoordinateTau ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateTau] using! + machineCompose_mem_FP machineDirectedObjectiveCoordinateRest_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedObjectiveCoordinateA_mem_FP : + machineDirectedObjectiveCoordinateA ∈ FP := by + have htail := machineCompose_mem_FP + machineDirectedObjectiveCoordinateRest_mem_FP machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveCoordinateA] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineDirectedObjectiveCoordinateX_mem_FP : + machineDirectedObjectiveCoordinateX ∈ FP := by + have htail := machineCompose_mem_FP + machineDirectedObjectiveCoordinateRest_mem_FP machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveCoordinateX] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineDirectedObjectiveCoordinateComplementRaw_mem_FP : + machineDirectedObjectiveCoordinateComplementRaw ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineDirectedObjectiveCoordinateX_mem_FP + simpa only [machineDirectedObjectiveCoordinateComplementRaw] using! + machineCompose_mem_FP hinput machineRawRatSubCode_mem_FP + +theorem machineDirectedObjectiveCoordinateComplement_mem_FP : + machineDirectedObjectiveCoordinateComplement ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateComplement] using! + machineCompose_mem_FP + machineDirectedObjectiveCoordinateComplementRaw_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineDirectedObjectiveCoordinateLogAInput_mem_FP : + machineDirectedObjectiveCoordinateLogAInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveCoordinatePrecision_mem_FP + machineDirectedObjectiveCoordinateA_mem_FP + +theorem machineDirectedObjectiveCoordinateLogXInput_mem_FP : + machineDirectedObjectiveCoordinateLogXInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveCoordinatePrecision_mem_FP + machineDirectedObjectiveCoordinateX_mem_FP + +theorem machineDirectedObjectiveCoordinateLogComplementInput_mem_FP : + machineDirectedObjectiveCoordinateLogComplementInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveCoordinatePrecision_mem_FP + machineDirectedObjectiveCoordinateComplement_mem_FP + +theorem machineDirectedObjectiveCoordinateLogAUpper_mem_FP : + machineDirectedObjectiveCoordinateLogAUpper ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateLogAUpper] using! + machineCompose_mem_FP machineDirectedObjectiveCoordinateLogAInput_mem_FP + machineScheduledLogUpperRawCode_mem_FP + +theorem machineDirectedObjectiveCoordinateLogXLower_mem_FP : + machineDirectedObjectiveCoordinateLogXLower ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateLogXLower] using! + machineCompose_mem_FP machineDirectedObjectiveCoordinateLogXInput_mem_FP + machineScheduledLogLowerRawCode_mem_FP + +theorem machineDirectedObjectiveCoordinateLogComplementUpper_mem_FP : + machineDirectedObjectiveCoordinateLogComplementUpper ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateLogComplementUpper] using! + machineCompose_mem_FP + machineDirectedObjectiveCoordinateLogComplementInput_mem_FP + machineScheduledLogUpperRawCode_mem_FP + +theorem machineDirectedObjectiveCoordinateNegX_mem_FP : + machineDirectedObjectiveCoordinateNegX ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateNegX] using! + machineCompose_mem_FP machineDirectedObjectiveCoordinateX_mem_FP + machineRawRatNegCode_mem_FP + +theorem machineDirectedObjectiveCoordinateFirstTerm_mem_FP : + machineDirectedObjectiveCoordinateFirstTerm ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateNegX_mem_FP + machineDirectedObjectiveCoordinateLogAUpper_mem_FP + simpa only [machineDirectedObjectiveCoordinateFirstTerm] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectedObjectiveCoordinateOnePlusTau_mem_FP : + machineDirectedObjectiveCoordinateOnePlusTau ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineDirectedObjectiveCoordinateTau_mem_FP + simpa only [machineDirectedObjectiveCoordinateOnePlusTau] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedObjectiveCoordinateMiddleScale_mem_FP : + machineDirectedObjectiveCoordinateMiddleScale ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateOnePlusTau_mem_FP + machineDirectedObjectiveCoordinateX_mem_FP + simpa only [machineDirectedObjectiveCoordinateMiddleScale] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectedObjectiveCoordinateMiddleTerm_mem_FP : + machineDirectedObjectiveCoordinateMiddleTerm ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateMiddleScale_mem_FP + machineDirectedObjectiveCoordinateLogXLower_mem_FP + simpa only [machineDirectedObjectiveCoordinateMiddleTerm] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectedObjectiveCoordinateComplementProduct_mem_FP : + machineDirectedObjectiveCoordinateComplementProduct ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateComplement_mem_FP + machineDirectedObjectiveCoordinateLogComplementUpper_mem_FP + simpa only [machineDirectedObjectiveCoordinateComplementProduct] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectedObjectiveCoordinateLastTerm_mem_FP : + machineDirectedObjectiveCoordinateLastTerm ∈ FP := by + simpa only [machineDirectedObjectiveCoordinateLastTerm] using! + machineCompose_mem_FP + machineDirectedObjectiveCoordinateComplementProduct_mem_FP + machineRawRatNegCode_mem_FP + +theorem machineDirectedObjectiveCoordinateFirstTwo_mem_FP : + machineDirectedObjectiveCoordinateFirstTwo ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateFirstTerm_mem_FP + machineDirectedObjectiveCoordinateMiddleTerm_mem_FP + simpa only [machineDirectedObjectiveCoordinateFirstTwo] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedNegativeObjectiveCoordinateLowerRawCode_mem_FP : + machineDirectedNegativeObjectiveCoordinateLowerRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectedObjectiveCoordinateFirstTwo_mem_FP + machineDirectedObjectiveCoordinateLastTerm_mem_FP + simpa only [machineDirectedNegativeObjectiveCoordinateLowerRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +/-- Encodes precision `p` as a unary ruler followed by the raw rational codes for `tau`, `a`, +and `x`. -/ +def machineDirectedObjectiveCoordinateCanonicalWord + (tau a x : β„š) (p : β„•) : List Bool := + pair (List.replicate p true) + (pair (rawRatBinaryCode (rawRatOfRat tau)) + (pair (rawRatBinaryCode (rawRatOfRat a)) + (rawRatBinaryCode (rawRatOfRat x)))) + +/-- Forms the raw rational expression `-x * logUpper(a) + (1 + tau) * x * logLower(x) - (1 - x) +* logUpper(1 - x)` at precision `p`. -/ +def rawDirectedNegativeObjectiveCoordinateLower + (tau a x : β„š) (p : β„•) : RawRat := + let rawTau := rawRatOfRat tau + let rawX := rawRatOfRat x + let rawComplement := rawRatOfRat (1 - x) + let first := rawX.neg.mul (rawScheduledLogUpper a p) + let middle := (RawRat.one.add rawTau).mul rawX |>.mul + (rawScheduledLogLower x p) + let last := (rawComplement.mul + (rawScheduledLogUpper (1 - x) p)).neg + (first.add middle).add last + +@[simp] theorem machineDirectedObjectiveCoordinatePrecision_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinatePrecision + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + List.replicate p true := by + simp [machineDirectedObjectiveCoordinatePrecision, + machineDirectedObjectiveCoordinateCanonicalWord] + +@[simp] theorem machineDirectedObjectiveCoordinateTau_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateTau + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawRatOfRat tau) := by + simp [machineDirectedObjectiveCoordinateTau, + machineDirectedObjectiveCoordinateRest, + machineDirectedObjectiveCoordinateCanonicalWord] + +@[simp] theorem machineDirectedObjectiveCoordinateA_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateA + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawRatOfRat a) := by + simp [machineDirectedObjectiveCoordinateA, + machineDirectedObjectiveCoordinateRest, + machineDirectedObjectiveCoordinateCanonicalWord] + +@[simp] theorem machineDirectedObjectiveCoordinateX_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateX + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawRatOfRat x) := by + simp [machineDirectedObjectiveCoordinateX, + machineDirectedObjectiveCoordinateRest, + machineDirectedObjectiveCoordinateCanonicalWord] + +@[simp] theorem machineDirectedObjectiveCoordinateComplement_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateComplement + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawRatOfRat (1 - x)) := by + rw [machineDirectedObjectiveCoordinateComplement, + machineDirectedObjectiveCoordinateComplementRaw, + machineDirectedObjectiveCoordinateX, + machineDirectedObjectiveCoordinateRest, + machineDirectedObjectiveCoordinateCanonicalWord] + simp only [machinePairSecond_pair, + machineRawRatSubCode_encode, + machineNormalizeRawRatEntryCode_encode] + rw [rawRatBinaryCode_rawRatOfRat] + congr 1 + simp [binaryNormalizeRawRat_eq_value, RawRat.value_sub, + rawRatOfRat_value] + +@[simp] theorem machineDirectedObjectiveCoordinateLogAUpper_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateLogAUpper + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawScheduledLogUpper a p) := by + rw [machineDirectedObjectiveCoordinateLogAUpper, + machineDirectedObjectiveCoordinateLogAInput, + machineDirectedObjectiveCoordinatePrecision_encode, + machineDirectedObjectiveCoordinateA_encode, + machineScheduledLogUpperRawCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateLogXLower_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateLogXLower + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawScheduledLogLower x p) := by + rw [machineDirectedObjectiveCoordinateLogXLower, + machineDirectedObjectiveCoordinateLogXInput, + machineDirectedObjectiveCoordinatePrecision_encode, + machineDirectedObjectiveCoordinateX_encode, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateLogComplementUpper_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateLogComplementUpper + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawScheduledLogUpper (1 - x) p) := by + rw [machineDirectedObjectiveCoordinateLogComplementUpper, + machineDirectedObjectiveCoordinateLogComplementInput, + machineDirectedObjectiveCoordinatePrecision_encode, + machineDirectedObjectiveCoordinateComplement_encode, + machineScheduledLogUpperRawCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateNegX_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateNegX + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (rawRatOfRat x).neg := by + rw [machineDirectedObjectiveCoordinateNegX, + machineDirectedObjectiveCoordinateX_encode, + machineRawRatNegCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateFirstTerm_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateFirstTerm + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((rawRatOfRat x).neg.mul (rawScheduledLogUpper a p)) := by + rw [machineDirectedObjectiveCoordinateFirstTerm, + machineDirectedObjectiveCoordinateNegX_encode, + machineDirectedObjectiveCoordinateLogAUpper_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateOnePlusTau_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateOnePlusTau + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode (RawRat.one.add (rawRatOfRat tau)) := by + rw [machineDirectedObjectiveCoordinateOnePlusTau, + machineDirectedObjectiveCoordinateTau_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateMiddleScale_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateMiddleScale + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((RawRat.one.add (rawRatOfRat tau)).mul (rawRatOfRat x)) := by + rw [machineDirectedObjectiveCoordinateMiddleScale, + machineDirectedObjectiveCoordinateOnePlusTau_encode, + machineDirectedObjectiveCoordinateX_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateMiddleTerm_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateMiddleTerm + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + (((RawRat.one.add (rawRatOfRat tau)).mul (rawRatOfRat x)).mul + (rawScheduledLogLower x p)) := by + rw [machineDirectedObjectiveCoordinateMiddleTerm, + machineDirectedObjectiveCoordinateMiddleScale_encode, + machineDirectedObjectiveCoordinateLogXLower_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateComplementProduct_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateComplementProduct + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((rawRatOfRat (1 - x)).mul + (rawScheduledLogUpper (1 - x) p)) := by + rw [machineDirectedObjectiveCoordinateComplementProduct, + machineDirectedObjectiveCoordinateComplement_encode, + machineDirectedObjectiveCoordinateLogComplementUpper_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateLastTerm_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateLastTerm + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + ((rawRatOfRat (1 - x)).mul + (rawScheduledLogUpper (1 - x) p)).neg := by + rw [machineDirectedObjectiveCoordinateLastTerm, + machineDirectedObjectiveCoordinateComplementProduct_encode, + machineRawRatNegCode_encode] + +@[simp] theorem machineDirectedObjectiveCoordinateFirstTwo_encode + (tau a x : β„š) (p : β„•) : + machineDirectedObjectiveCoordinateFirstTwo + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + (((rawRatOfRat x).neg.mul (rawScheduledLogUpper a p)).add + (((RawRat.one.add (rawRatOfRat tau)).mul (rawRatOfRat x)).mul + (rawScheduledLogLower x p))) := by + rw [machineDirectedObjectiveCoordinateFirstTwo, + machineDirectedObjectiveCoordinateFirstTerm_encode, + machineDirectedObjectiveCoordinateMiddleTerm_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineDirectedNegativeObjectiveCoordinateLowerRawCode_encode + (tau a x : β„š) (p : β„•) : + machineDirectedNegativeObjectiveCoordinateLowerRawCode + (machineDirectedObjectiveCoordinateCanonicalWord tau a x p) = + rawRatBinaryCode + (rawDirectedNegativeObjectiveCoordinateLower tau a x p) := by + rw [machineDirectedNegativeObjectiveCoordinateLowerRawCode, + machineDirectedObjectiveCoordinateFirstTwo_encode, + machineDirectedObjectiveCoordinateLastTerm_encode, + machineRawRatAddCode_encode] + rfl + +theorem rawDirectedNegativeObjectiveCoordinateLower_value + (tau a x : β„š) (p : β„•) : + (rawDirectedNegativeObjectiveCoordinateLower tau a x p).value = + directedNegativeObjectiveCoordinateLower tau a x p := by + simp [rawDirectedNegativeObjectiveCoordinateLower, + directedNegativeObjectiveCoordinateLower, + RawRat.value_add, RawRat.value_mul, RawRat.value_neg, + RawRat.value_one, rawRatOfRat_value, + rawScheduledLogLower_value, rawScheduledLogUpper_value] + ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveSum.lean new file mode 100644 index 0000000000..94692562df --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedNegativeObjectiveSum.lean @@ -0,0 +1,2567 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveCoordinate +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFloorScan +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLogWidth +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard + +/-! +# Finite-word evaluation of the complete directed Bethe objective + +This module scans all `(m+1)^2` recovered Birkhoff entries in row-major +order. At each entry it reads the corresponding input-matrix coordinate, +recovers and normalizes the affine Birkhoff coordinate, invokes the directed +coordinate evaluator, and adds its rational lower endpoint to an unreduced +accumulator. + +The concrete state machine is total on arbitrary bitstrings. Its counters +and accumulator are clamped by an explicit polynomial word. The semantic +proof below is kept separate from this global finite-word bound; on canonical +inputs the clamp is proved inactive. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Public input layout -/ + +/-- Input layout: +`pair mUnary (pair precisionUnary (pair tauRaw (pair matrixCode yCode)))`. -/ +def machineDirectedObjectiveSumDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the objective-sum input payload after its dimension field. -/ +def machineDirectedObjectiveSumRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary precision field from an objective-sum input. -/ +def machineDirectedObjectiveSumPrecision (word : List Bool) : List Bool := + machinePairFirst (machineDirectedObjectiveSumRest word) + +/-- Extracts the objective-sum payload after its dimension and precision fields. -/ +def machineDirectedObjectiveSumAfterPrecision (word : List Bool) : List Bool := + machinePairSecond (machineDirectedObjectiveSumRest word) + +/-- Extracts the encoded regularization parameter from an objective-sum input. -/ +def machineDirectedObjectiveSumTau (word : List Bool) : List Bool := + machinePairFirst (machineDirectedObjectiveSumAfterPrecision word) + +/-- Extracts the matrix-and-vector payload following the regularization parameter. -/ +def machineDirectedObjectiveSumAfterTau (word : List Bool) : List Bool := + machinePairSecond (machineDirectedObjectiveSumAfterPrecision word) + +/-- Extracts the encoded matrix from an objective-sum input. -/ +def machineDirectedObjectiveSumMatrix (word : List Bool) : List Bool := + machinePairFirst (machineDirectedObjectiveSumAfterTau word) + +/-- Extracts the encoded free-coordinate vector from an objective-sum input. -/ +def machineDirectedObjectiveSumVector (word : List Bool) : List Bool := + machinePairSecond (machineDirectedObjectiveSumAfterTau word) + +/-! ## Row-major state and one coordinate evaluation -/ + +/-- Packs the row, column, accumulator, length bound, completion bit, and fixed payload into an +objective-sum state. -/ +def machineDirectedObjectiveSumPack + (row column acc bound done payload : List Bool) : List Bool := + pair row (pair column (pair acc (pair bound (pair done payload)))) + +/-- Extracts the unary row index from an objective-sum state. -/ +def machineDirectedObjectiveSumRow (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unary column index from an objective-sum state. -/ +def machineDirectedObjectiveSumColumn (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated raw rational code from an objective-sum state. -/ +def machineDirectedObjectiveSumAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the word whose length bounds objective-sum accumulator and index updates. -/ +def machineDirectedObjectiveSumBound (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the completion-bit word from an objective-sum state. -/ +def machineDirectedObjectiveSumDone (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Extracts the fixed dimension, precision, parameter, matrix, and vector payload from an +objective-sum state. -/ +def machineDirectedObjectiveSumPayload (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Reads the unary dimension field from the fixed payload of an objective-sum state. -/ +def machineDirectedObjectiveSumStateDimension + (state : List Bool) : List Bool := + machineDirectedObjectiveSumDimension + (machineDirectedObjectiveSumPayload state) + +/-- Reads the unary precision field from the fixed payload of an objective-sum state. -/ +def machineDirectedObjectiveSumStatePrecision + (state : List Bool) : List Bool := + machineDirectedObjectiveSumPrecision + (machineDirectedObjectiveSumPayload state) + +/-- Reads the encoded regularization parameter from the fixed payload of an objective-sum state. -/ +def machineDirectedObjectiveSumStateTau + (state : List Bool) : List Bool := + machineDirectedObjectiveSumTau + (machineDirectedObjectiveSumPayload state) + +/-- Reads the encoded matrix from the fixed payload of an objective-sum state. -/ +def machineDirectedObjectiveSumStateMatrix + (state : List Bool) : List Bool := + machineDirectedObjectiveSumMatrix + (machineDirectedObjectiveSumPayload state) + +/-- Reads the encoded free-coordinate vector from the fixed payload of an objective-sum state. -/ +def machineDirectedObjectiveSumStateVector + (state : List Bool) : List Bool := + machineDirectedObjectiveSumVector + (machineDirectedObjectiveSumPayload state) + +/-- Tests whether the current unary row ruler equals the dimension ruler, identifying the final +matrix row on canonical states. -/ +def machineDirectedObjectiveSumLastRowBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineDirectedObjectiveSumRow state) + (machineDirectedObjectiveSumStateDimension state) + +/-- Tests whether the current unary column ruler equals the dimension ruler, identifying the +final matrix column on canonical states. -/ +def machineDirectedObjectiveSumLastColumnBit + (state : List Bool) : List Bool := + machineUnaryRulersEqualBit (machineDirectedObjectiveSumColumn state) + (machineDirectedObjectiveSumStateDimension state) + +/-- Pairs the current row and column rulers with the encoded matrix to request one matrix +coefficient. -/ +def machineDirectedObjectiveSumMatrixEntryInput + (state : List Bool) : List Bool := + pair (machineDirectedObjectiveSumRow state) + (pair (machineDirectedObjectiveSumColumn state) + (machineDirectedObjectiveSumStateMatrix state)) + +/-- Looks up the current matrix coefficient and normalizes its raw rational code. -/ +def machineDirectedObjectiveSumMatrixEntryRaw + (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineMatrixEntryAtUnary + (machineDirectedObjectiveSumMatrixEntryInput state)) + +/-- Packages the dimension, current row and column, and free-coordinate vector for affine-entry +evaluation. -/ +def machineDirectedObjectiveSumAffineEntryInput + (state : List Bool) : List Bool := + pair (machineDirectedObjectiveSumStateDimension state) + (pair (machineDirectedObjectiveSumRow state) + (pair (machineDirectedObjectiveSumColumn state) + (machineDirectedObjectiveSumStateVector state))) + +/-- Evaluates the current affine matrix entry and normalizes its raw rational code. -/ +def machineDirectedObjectiveSumAffineEntryRaw + (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineBetheAffineEntryRawCode + (machineDirectedObjectiveSumAffineEntryInput state)) + +/-- Packages the precision, regularization parameter, normalized matrix coefficient, and +normalized affine entry for one objective summand. -/ +def machineDirectedObjectiveSumCoordinateInput + (state : List Bool) : List Bool := + pair (machineDirectedObjectiveSumStatePrecision state) + (pair (machineDirectedObjectiveSumStateTau state) + (pair (machineDirectedObjectiveSumMatrixEntryRaw state) + (machineDirectedObjectiveSumAffineEntryRaw state))) + +/-- Computes the directed lower approximation of the negative-objective summand at the current +row and column. -/ +def machineDirectedObjectiveSumCoordinateRawCode + (state : List Bool) : List Bool := + machineDirectedNegativeObjectiveCoordinateLowerRawCode + (machineDirectedObjectiveSumCoordinateInput state) + +/-- Adds the current directed objective summand to the accumulated raw rational code. -/ +def machineDirectedObjectiveSumCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineDirectedObjectiveSumAcc state) + (machineDirectedObjectiveSumCoordinateRawCode state)) + +/-- Truncates the updated accumulator to the length of the state bound word. -/ +def machineDirectedObjectiveSumNextAcc (state : List Bool) : List Bool := + (machineDirectedObjectiveSumCandidate state).take + (machineDirectedObjectiveSumBound state).length + +/-- Increments the unary row ruler and truncates it to the length of the state bound word. -/ +def machineDirectedObjectiveSumNextRow (state : List Bool) : List Bool := + (machineDirectedObjectiveSumRow state ++ [true]).take + (machineDirectedObjectiveSumBound state).length + +/-- Increments the unary column ruler and truncates it to the length of the state bound word. -/ +def machineDirectedObjectiveSumNextColumn (state : List Bool) : List Bool := + (machineDirectedObjectiveSumColumn state ++ [true]).take + (machineDirectedObjectiveSumBound state).length + +/-- Includes the current summand in the bounded accumulator and marks the objective scan +complete, retaining its final indices. -/ +def machineDirectedObjectiveSumFinish (state : List Bool) : List Bool := + machineDirectedObjectiveSumPack + (machineDirectedObjectiveSumRow state) + (machineDirectedObjectiveSumColumn state) + (machineDirectedObjectiveSumNextAcc state) + (machineDirectedObjectiveSumBound state) [true] + (machineDirectedObjectiveSumPayload state) + +/-- Includes the current summand, advances the row, and resets the column ruler for the next +row. -/ +def machineDirectedObjectiveSumAdvanceRow (state : List Bool) : List Bool := + machineDirectedObjectiveSumPack + (machineDirectedObjectiveSumNextRow state) [] + (machineDirectedObjectiveSumNextAcc state) + (machineDirectedObjectiveSumBound state) + (machineDirectedObjectiveSumDone state) + (machineDirectedObjectiveSumPayload state) + +/-- Includes the current summand and advances the column while retaining the current row and +fixed payload. -/ +def machineDirectedObjectiveSumAdvanceColumn + (state : List Bool) : List Bool := + machineDirectedObjectiveSumPack + (machineDirectedObjectiveSumRow state) + (machineDirectedObjectiveSumNextColumn state) + (machineDirectedObjectiveSumNextAcc state) + (machineDirectedObjectiveSumBound state) + (machineDirectedObjectiveSumDone state) + (machineDirectedObjectiveSumPayload state) + +/-- Processes one matrix entry, finishing at the last row and column, advancing rows at other +row ends, and otherwise advancing the column. -/ +def machineDirectedObjectiveSumProcess (state : List Bool) : List Bool := + machineIfHead (machineHeadBit + (machineDirectedObjectiveSumLastColumnBit state)) + (machineIfHead (machineHeadBit + (machineDirectedObjectiveSumLastRowBit state)) + (machineDirectedObjectiveSumFinish state) + (machineDirectedObjectiveSumAdvanceRow state)) + (machineDirectedObjectiveSumAdvanceColumn state) + +/-- Leaves completed objective-sum states unchanged and otherwise processes one matrix entry. -/ +def machineDirectedObjectiveSumStep (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineDirectedObjectiveSumDone state)) + state (machineDirectedObjectiveSumProcess state) + +/-! ## Explicit iteration and state bounds -/ + +/-- Builds the accumulator length-bound word by applying the binary-width construction six times +to the input. -/ +def machineDirectedObjectiveSumAccumulatorBound + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 6 word + +/-- Builds a common field envelope by applying the binary-width construction seven times to the +input. -/ +def machineDirectedObjectiveSumStateEnvelope + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 7 word + +/-- Initializes the objective scan at row and column zero with a zero raw accumulator, its +computed bound, and an unset completion bit. -/ +def machineDirectedObjectiveSumInit (word : List Bool) : List Bool := + machineDirectedObjectiveSumPack [] [] + (rawRatBinaryCode RawRat.zero) + (machineDirectedObjectiveSumAccumulatorBound word) [false] word + +/-- The floor scanner already provides the exact bounded-unary construction +for `(m+1)^2`; it depends only on the first component of the word. -/ +def machineDirectedObjectiveSumRuler (word : List Bool) : List Bool := + machineBetheFloorScanRuler word + +/-- Packs six copies of the common field envelope to bound the encoded objective-sum state. -/ +def machineDirectedObjectiveSumWidth (word : List Bool) : List Bool := + let envelope := machineDirectedObjectiveSumStateEnvelope word + machineDirectedObjectiveSumPack envelope envelope envelope envelope + envelope envelope + +/-- Iterates the bounded objective scan for the number of steps specified by its scan ruler. -/ +def machineDirectedObjectiveSumFinalState (word : List Bool) : List Bool := + (machineDirectedObjectiveSumStep)^[(machineDirectedObjectiveSumRuler word).length] + (machineDirectedObjectiveSumInit word) + +/-- Extracts the encoded raw accumulator after the scheduled objective-sum iteration. -/ +def machineDirectedNegativeObjectiveSumRawCode + (word : List Bool) : List Bool := + machineDirectedObjectiveSumAcc + (machineDirectedObjectiveSumFinalState word) + +/-! ## Polynomial-time closure -/ + +theorem machineDirectedObjectiveSumDimension_mem_FP : + machineDirectedObjectiveSumDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumRest_mem_FP : + machineDirectedObjectiveSumRest ∈ FP := machinePairSecond_mem_FP + +theorem machineDirectedObjectiveSumPrecision_mem_FP : + machineDirectedObjectiveSumPrecision ∈ FP := by + simpa only [machineDirectedObjectiveSumPrecision] using! + machineCompose_mem_FP machineDirectedObjectiveSumRest_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumAfterPrecision_mem_FP : + machineDirectedObjectiveSumAfterPrecision ∈ FP := by + simpa only [machineDirectedObjectiveSumAfterPrecision] using! + machineCompose_mem_FP machineDirectedObjectiveSumRest_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedObjectiveSumTau_mem_FP : + machineDirectedObjectiveSumTau ∈ FP := by + simpa only [machineDirectedObjectiveSumTau] using! + machineCompose_mem_FP machineDirectedObjectiveSumAfterPrecision_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumAfterTau_mem_FP : + machineDirectedObjectiveSumAfterTau ∈ FP := by + simpa only [machineDirectedObjectiveSumAfterTau] using! + machineCompose_mem_FP machineDirectedObjectiveSumAfterPrecision_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedObjectiveSumMatrix_mem_FP : + machineDirectedObjectiveSumMatrix ∈ FP := by + simpa only [machineDirectedObjectiveSumMatrix] using! + machineCompose_mem_FP machineDirectedObjectiveSumAfterTau_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumVector_mem_FP : + machineDirectedObjectiveSumVector ∈ FP := by + simpa only [machineDirectedObjectiveSumVector] using! + machineCompose_mem_FP machineDirectedObjectiveSumAfterTau_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectedObjectiveSumRow_mem_FP : + machineDirectedObjectiveSumRow ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumColumn_mem_FP : + machineDirectedObjectiveSumColumn ∈ FP := by + simpa only [machineDirectedObjectiveSumColumn] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumAcc_mem_FP : + machineDirectedObjectiveSumAcc ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveSumAcc] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumBound_mem_FP : + machineDirectedObjectiveSumBound ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveSumBound] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumDone_mem_FP : + machineDirectedObjectiveSumDone ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + have htailFour := machineCompose_mem_FP htailThree machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveSumDone] using! + machineCompose_mem_FP htailFour machinePairFirst_mem_FP + +theorem machineDirectedObjectiveSumPayload_mem_FP : + machineDirectedObjectiveSumPayload ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + have htailFour := machineCompose_mem_FP htailThree machinePairSecond_mem_FP + simpa only [machineDirectedObjectiveSumPayload] using! + machineCompose_mem_FP htailFour machinePairSecond_mem_FP + +theorem machineDirectedObjectiveSumStateDimension_mem_FP : + machineDirectedObjectiveSumStateDimension ∈ FP := by + simpa only [machineDirectedObjectiveSumStateDimension] using! + machineCompose_mem_FP machineDirectedObjectiveSumPayload_mem_FP + machineDirectedObjectiveSumDimension_mem_FP + +theorem machineDirectedObjectiveSumStatePrecision_mem_FP : + machineDirectedObjectiveSumStatePrecision ∈ FP := by + simpa only [machineDirectedObjectiveSumStatePrecision] using! + machineCompose_mem_FP machineDirectedObjectiveSumPayload_mem_FP + machineDirectedObjectiveSumPrecision_mem_FP + +theorem machineDirectedObjectiveSumStateTau_mem_FP : + machineDirectedObjectiveSumStateTau ∈ FP := by + simpa only [machineDirectedObjectiveSumStateTau] using! + machineCompose_mem_FP machineDirectedObjectiveSumPayload_mem_FP + machineDirectedObjectiveSumTau_mem_FP + +theorem machineDirectedObjectiveSumStateMatrix_mem_FP : + machineDirectedObjectiveSumStateMatrix ∈ FP := by + simpa only [machineDirectedObjectiveSumStateMatrix] using! + machineCompose_mem_FP machineDirectedObjectiveSumPayload_mem_FP + machineDirectedObjectiveSumMatrix_mem_FP + +theorem machineDirectedObjectiveSumStateVector_mem_FP : + machineDirectedObjectiveSumStateVector ∈ FP := by + simpa only [machineDirectedObjectiveSumStateVector] using! + machineCompose_mem_FP machineDirectedObjectiveSumPayload_mem_FP + machineDirectedObjectiveSumVector_mem_FP + +theorem machineDirectedObjectiveSumLastRowBit_mem_FP : + machineDirectedObjectiveSumLastRowBit ∈ FP := + machineUnaryRulersEqualBit_mem_FP machineDirectedObjectiveSumRow_mem_FP + machineDirectedObjectiveSumStateDimension_mem_FP + +theorem machineDirectedObjectiveSumLastColumnBit_mem_FP : + machineDirectedObjectiveSumLastColumnBit ∈ FP := + machineUnaryRulersEqualBit_mem_FP machineDirectedObjectiveSumColumn_mem_FP + machineDirectedObjectiveSumStateDimension_mem_FP + +theorem machineDirectedObjectiveSumMatrixEntryInput_mem_FP : + machineDirectedObjectiveSumMatrixEntryInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumRow_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumColumn_mem_FP + machineDirectedObjectiveSumStateMatrix_mem_FP) + +theorem machineDirectedObjectiveSumMatrixEntryRaw_mem_FP : + machineDirectedObjectiveSumMatrixEntryRaw ∈ FP := by + have hentry := machineCompose_mem_FP + machineDirectedObjectiveSumMatrixEntryInput_mem_FP + machineMatrixEntryAtUnary_mem_FP + simpa only [machineDirectedObjectiveSumMatrixEntryRaw] using! + machineCompose_mem_FP hentry machineNormalizeRawRatEntryCode_mem_FP + +theorem machineDirectedObjectiveSumAffineEntryInput_mem_FP : + machineDirectedObjectiveSumAffineEntryInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumStateDimension_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumRow_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumColumn_mem_FP + machineDirectedObjectiveSumStateVector_mem_FP)) + +theorem machineDirectedObjectiveSumAffineEntryRaw_mem_FP : + machineDirectedObjectiveSumAffineEntryRaw ∈ FP := by + have hentry := machineCompose_mem_FP + machineDirectedObjectiveSumAffineEntryInput_mem_FP + machineBetheAffineEntryRawCode_mem_FP + simpa only [machineDirectedObjectiveSumAffineEntryRaw] using! + machineCompose_mem_FP hentry machineNormalizeRawRatEntryCode_mem_FP + +theorem machineDirectedObjectiveSumCoordinateInput_mem_FP : + machineDirectedObjectiveSumCoordinateInput ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumStatePrecision_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumStateTau_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumMatrixEntryRaw_mem_FP + machineDirectedObjectiveSumAffineEntryRaw_mem_FP)) + +theorem machineDirectedObjectiveSumCoordinateRawCode_mem_FP : + machineDirectedObjectiveSumCoordinateRawCode ∈ FP := by + simpa only [machineDirectedObjectiveSumCoordinateRawCode] using! + machineCompose_mem_FP machineDirectedObjectiveSumCoordinateInput_mem_FP + machineDirectedNegativeObjectiveCoordinateLowerRawCode_mem_FP + +theorem machineDirectedObjectiveSumCandidate_mem_FP : + machineDirectedObjectiveSumCandidate ∈ FP := by + have hinput := machinePair_mem_FP machineDirectedObjectiveSumAcc_mem_FP + machineDirectedObjectiveSumCoordinateRawCode_mem_FP + simpa only [machineDirectedObjectiveSumCandidate] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedObjectiveSumNextAcc_mem_FP : + machineDirectedObjectiveSumNextAcc ∈ FP := by + simpa only [machineDirectedObjectiveSumNextAcc] using! + machineTake_mem_FP machineDirectedObjectiveSumBound_mem_FP + machineDirectedObjectiveSumCandidate_mem_FP + +theorem machineDirectedObjectiveSumNextRow_mem_FP : + machineDirectedObjectiveSumNextRow ∈ FP := by + have happend := machineAppend_mem_FP machineDirectedObjectiveSumRow_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineDirectedObjectiveSumNextRow] using! + machineTake_mem_FP machineDirectedObjectiveSumBound_mem_FP happend + +theorem machineDirectedObjectiveSumNextColumn_mem_FP : + machineDirectedObjectiveSumNextColumn ∈ FP := by + have happend := machineAppend_mem_FP + machineDirectedObjectiveSumColumn_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineDirectedObjectiveSumNextColumn] using! + machineTake_mem_FP machineDirectedObjectiveSumBound_mem_FP happend + +theorem machineDirectedObjectiveSumFinish_mem_FP : + machineDirectedObjectiveSumFinish ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumRow_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumColumn_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumNextAcc_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineDirectedObjectiveSumPayload_mem_FP)))) + +theorem machineDirectedObjectiveSumAdvanceRow_mem_FP : + machineDirectedObjectiveSumAdvanceRow ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumNextRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineDirectedObjectiveSumNextAcc_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumBound_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumDone_mem_FP + machineDirectedObjectiveSumPayload_mem_FP)))) + +theorem machineDirectedObjectiveSumAdvanceColumn_mem_FP : + machineDirectedObjectiveSumAdvanceColumn ∈ FP := + machinePair_mem_FP machineDirectedObjectiveSumRow_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumNextColumn_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumNextAcc_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumBound_mem_FP + (machinePair_mem_FP machineDirectedObjectiveSumDone_mem_FP + machineDirectedObjectiveSumPayload_mem_FP)))) + +theorem machineDirectedObjectiveSumProcess_mem_FP : + machineDirectedObjectiveSumProcess ∈ FP := by + have hlastColumn := machineCompose_mem_FP + machineDirectedObjectiveSumLastColumnBit_mem_FP machineHeadBit_mem_FP + have hlastRow := machineCompose_mem_FP + machineDirectedObjectiveSumLastRowBit_mem_FP machineHeadBit_mem_FP + have hlast := machineIfHead_mem_FP hlastRow + machineDirectedObjectiveSumFinish_mem_FP + machineDirectedObjectiveSumAdvanceRow_mem_FP + exact machineIfHead_mem_FP hlastColumn hlast + machineDirectedObjectiveSumAdvanceColumn_mem_FP + +theorem machineDirectedObjectiveSumStep_mem_FP : + machineDirectedObjectiveSumStep ∈ FP := by + have hdone := machineCompose_mem_FP machineDirectedObjectiveSumDone_mem_FP + machineHeadBit_mem_FP + exact machineIfHead_mem_FP hdone id_mem_FP + machineDirectedObjectiveSumProcess_mem_FP + +theorem machineDirectedObjectiveSumAccumulatorBound_mem_FP : + machineDirectedObjectiveSumAccumulatorBound ∈ FP := by + simpa only [machineDirectedObjectiveSumAccumulatorBound] using! + machineIteratedBinaryWidth_mem_FP 6 + +theorem machineDirectedObjectiveSumStateEnvelope_mem_FP : + machineDirectedObjectiveSumStateEnvelope ∈ FP := by + simpa only [machineDirectedObjectiveSumStateEnvelope] using! + machineIteratedBinaryWidth_mem_FP 7 + +theorem machineDirectedObjectiveSumInit_mem_FP : + machineDirectedObjectiveSumInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + (machinePair_mem_FP + machineDirectedObjectiveSumAccumulatorBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP)))) + +theorem machineDirectedObjectiveSumRuler_mem_FP : + machineDirectedObjectiveSumRuler ∈ FP := by + simpa only [machineDirectedObjectiveSumRuler] using! + machineBetheFloorScanRuler_mem_FP + +theorem machineDirectedObjectiveSumWidth_mem_FP : + machineDirectedObjectiveSumWidth ∈ FP := by + have h := machineDirectedObjectiveSumStateEnvelope_mem_FP + exact machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h (machinePair_mem_FP h h)))) + +/-! ## A global state envelope for the bounded iteration -/ + +@[simp] theorem machineDirectedObjectiveSumRow_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumRow + (machineDirectedObjectiveSumPack row column acc bound done payload) = + row := by + simp [machineDirectedObjectiveSumRow, machineDirectedObjectiveSumPack] + +@[simp] theorem machineDirectedObjectiveSumColumn_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumColumn + (machineDirectedObjectiveSumPack row column acc bound done payload) = + column := by + simp [machineDirectedObjectiveSumColumn, machineDirectedObjectiveSumPack] + +@[simp] theorem machineDirectedObjectiveSumAcc_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumAcc + (machineDirectedObjectiveSumPack row column acc bound done payload) = + acc := by + simp [machineDirectedObjectiveSumAcc, machineDirectedObjectiveSumPack] + +@[simp] theorem machineDirectedObjectiveSumBound_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumBound + (machineDirectedObjectiveSumPack row column acc bound done payload) = + bound := by + simp [machineDirectedObjectiveSumBound, machineDirectedObjectiveSumPack] + +@[simp] theorem machineDirectedObjectiveSumDone_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumDone + (machineDirectedObjectiveSumPack row column acc bound done payload) = + done := by + simp [machineDirectedObjectiveSumDone, machineDirectedObjectiveSumPack] + +@[simp] theorem machineDirectedObjectiveSumPayload_pack + (row column acc bound done payload) : + machineDirectedObjectiveSumPayload + (machineDirectedObjectiveSumPack row column acc bound done payload) = + payload := by + simp [machineDirectedObjectiveSumPayload, machineDirectedObjectiveSumPack] + +/-- Requires a correctly packed scan state with bounded row, column, and accumulator lengths, +the prescribed bound and payload, and at most one completion bit. -/ +def MachineDirectedObjectiveSumStateBound + (word state : List Bool) : Prop := + state = machineDirectedObjectiveSumPack + (machineDirectedObjectiveSumRow state) + (machineDirectedObjectiveSumColumn state) + (machineDirectedObjectiveSumAcc state) + (machineDirectedObjectiveSumBound state) + (machineDirectedObjectiveSumDone state) + (machineDirectedObjectiveSumPayload state) ∧ + (machineDirectedObjectiveSumRow state).length ≀ + (machineDirectedObjectiveSumAccumulatorBound word).length ∧ + (machineDirectedObjectiveSumColumn state).length ≀ + (machineDirectedObjectiveSumAccumulatorBound word).length ∧ + (machineDirectedObjectiveSumAcc state).length ≀ + (machineDirectedObjectiveSumAccumulatorBound word).length ∧ + machineDirectedObjectiveSumBound state = + machineDirectedObjectiveSumAccumulatorBound word ∧ + (machineDirectedObjectiveSumDone state).length ≀ 1 ∧ + machineDirectedObjectiveSumPayload state = word + +theorem machineDirectedObjectiveSumInit_bound (word : List Bool) : + MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumInit word) := by + simp only [MachineDirectedObjectiveSumStateBound, + machineDirectedObjectiveSumInit, + machineDirectedObjectiveSumRow_pack, + machineDirectedObjectiveSumColumn_pack, + machineDirectedObjectiveSumAcc_pack, + machineDirectedObjectiveSumBound_pack, + machineDirectedObjectiveSumDone_pack, + machineDirectedObjectiveSumPayload_pack] + refine ⟨trivial, by simp, by simp, ?_, trivial, by simp, trivial⟩ + have hzero : (rawRatBinaryCode RawRat.zero).length = 5 := by decide + rw [hzero] + rw [machineDirectedObjectiveSumAccumulatorBound, + machineIteratedBinaryWidth_length] + have hbase : 16 ≀ word.length + 16 := by omega + have hpow : 16 ^ (2 ^ (5 + 1)) ≀ + (word.length + 16) ^ (2 ^ (5 + 1)) := + Nat.pow_le_pow_left hbase _ + exact (by norm_num : 5 ≀ 16 ^ (2 ^ (5 + 1))).trans + (hpow.trans (certificateExpGuardWidth_pow_lower 5 word.length)) + +theorem machineDirectedObjectiveSumStep_bound {word state : List Bool} + (hstate : MachineDirectedObjectiveSumStateBound word state) : + MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumStep state) := by + rcases hstate with + ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + have hfinish : MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumFinish state) := by + rw [machineDirectedObjectiveSumFinish] + simp only [MachineDirectedObjectiveSumStateBound, + machineDirectedObjectiveSumRow_pack, + machineDirectedObjectiveSumColumn_pack, + machineDirectedObjectiveSumAcc_pack, + machineDirectedObjectiveSumBound_pack, + machineDirectedObjectiveSumDone_pack, + machineDirectedObjectiveSumPayload_pack] + refine ⟨trivial, hrow, hcolumn, ?_, hbound, by simp, hpayload⟩ + rw [machineDirectedObjectiveSumNextAcc, hbound] + exact List.length_take_le _ _ + have hadvanceRow : MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumAdvanceRow state) := by + rw [machineDirectedObjectiveSumAdvanceRow] + simp only [MachineDirectedObjectiveSumStateBound, + machineDirectedObjectiveSumRow_pack, + machineDirectedObjectiveSumColumn_pack, + machineDirectedObjectiveSumAcc_pack, + machineDirectedObjectiveSumBound_pack, + machineDirectedObjectiveSumDone_pack, + machineDirectedObjectiveSumPayload_pack] + refine ⟨trivial, ?_, by simp, ?_, hbound, hdone, hpayload⟩ + Β· rw [machineDirectedObjectiveSumNextRow, hbound] + exact List.length_take_le _ _ + Β· rw [machineDirectedObjectiveSumNextAcc, hbound] + exact List.length_take_le _ _ + have hadvanceColumn : MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumAdvanceColumn state) := by + rw [machineDirectedObjectiveSumAdvanceColumn] + simp only [MachineDirectedObjectiveSumStateBound, + machineDirectedObjectiveSumRow_pack, + machineDirectedObjectiveSumColumn_pack, + machineDirectedObjectiveSumAcc_pack, + machineDirectedObjectiveSumBound_pack, + machineDirectedObjectiveSumDone_pack, + machineDirectedObjectiveSumPayload_pack] + refine ⟨trivial, hrow, ?_, ?_, hbound, hdone, hpayload⟩ + Β· rw [machineDirectedObjectiveSumNextColumn, hbound] + exact List.length_take_le _ _ + Β· rw [machineDirectedObjectiveSumNextAcc, hbound] + exact List.length_take_le _ _ + have hprocess : MachineDirectedObjectiveSumStateBound word + (machineDirectedObjectiveSumProcess state) := by + cases hcolumnCode : machineDirectedObjectiveSumLastColumnBit state with + | nil => + rw [machineDirectedObjectiveSumProcess, hcolumnCode, + machineHeadBit_nil, machineIfHead_false] + exact hadvanceColumn + | cons columnBit columnTail => + cases columnBit with + | false => + rw [machineDirectedObjectiveSumProcess, hcolumnCode, + machineHeadBit_cons, machineIfHead_false] + exact hadvanceColumn + | true => + cases hrowCode : machineDirectedObjectiveSumLastRowBit state with + | nil => + rw [machineDirectedObjectiveSumProcess, hcolumnCode, + machineHeadBit_cons, machineIfHead_true, hrowCode, + machineHeadBit_nil, machineIfHead_false] + exact hadvanceRow + | cons rowBit rowTail => + cases rowBit with + | false => + rw [machineDirectedObjectiveSumProcess, hcolumnCode, + machineHeadBit_cons, machineIfHead_true, hrowCode, + machineHeadBit_cons, machineIfHead_false] + exact hadvanceRow + | true => + rw [machineDirectedObjectiveSumProcess, hcolumnCode, + machineHeadBit_cons, machineIfHead_true, hrowCode, + machineHeadBit_cons, machineIfHead_true] + exact hfinish + cases hdoneCode : machineDirectedObjectiveSumDone state with + | nil => + rw [machineDirectedObjectiveSumStep, hdoneCode, + machineHeadBit_nil, machineIfHead_false] + exact hprocess + | cons doneBit doneTail => + cases doneBit with + | false => + rw [machineDirectedObjectiveSumStep, hdoneCode, + machineHeadBit_cons, machineIfHead_false] + exact hprocess + | true => + rw [machineDirectedObjectiveSumStep, hdoneCode, + machineHeadBit_cons, machineIfHead_true] + exact ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + +theorem machineDirectedObjectiveSumIterate_bound (word : List Bool) : βˆ€ k, + MachineDirectedObjectiveSumStateBound word + ((machineDirectedObjectiveSumStep)^[k] + (machineDirectedObjectiveSumInit word)) := by + intro k + induction k with + | zero => exact machineDirectedObjectiveSumInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineDirectedObjectiveSumStep_bound ih + +theorem certificateExpGuardWidth_self_le (k L : β„•) : + L ≀ certificateExpGuardWidth k L := by + induction k with + | zero => rfl + | succ k ih => + rw [certificateExpGuardWidth] + exact ih.trans (by + nlinarith [sq_nonneg (certificateExpGuardWidth k L)]) + +theorem machineDirectedObjectiveSumAccumulatorBound_le_envelope + (word : List Bool) : + (machineDirectedObjectiveSumAccumulatorBound word).length ≀ + (machineDirectedObjectiveSumStateEnvelope word).length := by + rw [machineDirectedObjectiveSumAccumulatorBound, + machineDirectedObjectiveSumStateEnvelope, + machineIteratedBinaryWidth_length, + machineIteratedBinaryWidth_length] + change certificateExpGuardWidth 6 word.length ≀ + (certificateExpGuardWidth 6 word.length + 16) ^ 2 + nlinarith [sq_nonneg (certificateExpGuardWidth 6 word.length)] + +theorem machineDirectedObjectiveSumWord_le_envelope (word : List Bool) : + word.length ≀ + (machineDirectedObjectiveSumStateEnvelope word).length := by + rw [machineDirectedObjectiveSumStateEnvelope, + machineIteratedBinaryWidth_length] + exact certificateExpGuardWidth_self_le 7 word.length + +theorem machineDirectedObjectiveSumEnvelope_pos (word : List Bool) : + 1 ≀ (machineDirectedObjectiveSumStateEnvelope word).length := by + rw [machineDirectedObjectiveSumStateEnvelope, + machineIteratedBinaryWidth_length] + have hbase : 16 ≀ word.length + 16 := by omega + have hpow : 16 ^ (2 ^ (6 + 1)) ≀ + (word.length + 16) ^ (2 ^ (6 + 1)) := + Nat.pow_le_pow_left hbase _ + exact (by norm_num : 1 ≀ 16 ^ (2 ^ (6 + 1))).trans + (hpow.trans (certificateExpGuardWidth_pow_lower 6 word.length)) + +theorem machineDirectedObjectiveSumIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineDirectedObjectiveSumRuler word).length) : + ((machineDirectedObjectiveSumStep)^[iterations] + (machineDirectedObjectiveSumInit word)).length ≀ + (machineDirectedObjectiveSumWidth word).length := by + rcases machineDirectedObjectiveSumIterate_bound word iterations with + ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + have hbe := machineDirectedObjectiveSumAccumulatorBound_le_envelope word + have hwe := machineDirectedObjectiveSumWord_le_envelope word + have hepos := machineDirectedObjectiveSumEnvelope_pos word + rw [hdecomp, hbound, hpayload] + simp only [machineDirectedObjectiveSumPack, + machineDirectedObjectiveSumWidth, pair_length] + omega + +theorem machineDirectedObjectiveSumFinalState_mem_FP : + machineDirectedObjectiveSumFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineDirectedObjectiveSumStep_mem_FP + machineDirectedObjectiveSumInit_mem_FP + machineDirectedObjectiveSumRuler_mem_FP + machineDirectedObjectiveSumWidth_mem_FP + machineDirectedObjectiveSumIterate_length_le_width + +theorem machineDirectedNegativeObjectiveSumRawCode_mem_FP : + machineDirectedNegativeObjectiveSumRawCode ∈ FP := by + simpa only [machineDirectedNegativeObjectiveSumRawCode] using! + machineCompose_mem_FP machineDirectedObjectiveSumFinalState_mem_FP + machineDirectedObjectiveSumAcc_mem_FP + +/-! ## Canonical inputs and exact coordinate semantics -/ + +/-- Encodes dimension `m`, precision `p`, regularization parameter, the `(m + 1)` square matrix, +and the free-coordinate vector for the objective scan. -/ +def machineDirectedObjectiveSumCanonicalWord {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : List Bool := + pair (List.replicate m true) + (pair (List.replicate p true) + (pair (rawRatBinaryCode (rawRatOfRat tau)) + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) + (rationalFiniteVectorCode y)))) + +@[simp] theorem machineDirectedObjectiveSumDimension_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumDimension + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + List.replicate m true := by + simp [machineDirectedObjectiveSumDimension, + machineDirectedObjectiveSumCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumPrecision_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumPrecision + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + List.replicate p true := by + simp [machineDirectedObjectiveSumPrecision, + machineDirectedObjectiveSumRest, + machineDirectedObjectiveSumCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumTau_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumTau + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rawRatBinaryCode (rawRatOfRat tau) := by + simp [machineDirectedObjectiveSumTau, + machineDirectedObjectiveSumAfterPrecision, + machineDirectedObjectiveSumRest, + machineDirectedObjectiveSumCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumMatrix_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumMatrix + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ := by + simp [machineDirectedObjectiveSumMatrix, + machineDirectedObjectiveSumAfterTau, + machineDirectedObjectiveSumAfterPrecision, + machineDirectedObjectiveSumRest, + machineDirectedObjectiveSumCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumVector_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumVector + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rationalFiniteVectorCode y := by + simp [machineDirectedObjectiveSumVector, + machineDirectedObjectiveSumAfterTau, + machineDirectedObjectiveSumAfterPrecision, + machineDirectedObjectiveSumRest, + machineDirectedObjectiveSumCanonicalWord] + +/-- Encodes a semantic scan position, raw accumulator, completion flag, and bound together with +the fixed objective payload. -/ +def machineDirectedObjectiveSumCanonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : List Bool := + machineDirectedObjectiveSumPack + (List.replicate i.1 true) (List.replicate j.1 true) + (rawRatBinaryCode acc) bound [done] + (machineDirectedObjectiveSumCanonicalWord tau A y p) + +@[simp] theorem machineDirectedObjectiveSumRow_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumRow + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate i.1 true := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumColumn_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumColumn + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate j.1 true := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumAcc_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumAcc + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode acc := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumBound_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumBound + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = bound := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumDone_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumDone + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = [done] := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumPayload_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumPayload + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineDirectedObjectiveSumCanonicalWord tau A y p := by + simp [machineDirectedObjectiveSumCanonicalState] + +@[simp] theorem machineDirectedObjectiveSumStateDimension_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumStateDimension + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate m true := by + rw [machineDirectedObjectiveSumStateDimension, + machineDirectedObjectiveSumPayload_canonicalState, + machineDirectedObjectiveSumDimension_encode] + +@[simp] theorem machineDirectedObjectiveSumStatePrecision_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumStatePrecision + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate p true := by + rw [machineDirectedObjectiveSumStatePrecision, + machineDirectedObjectiveSumPayload_canonicalState, + machineDirectedObjectiveSumPrecision_encode] + +@[simp] theorem machineDirectedObjectiveSumStateTau_canonicalState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumStateTau + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode (rawRatOfRat tau) := by + rw [machineDirectedObjectiveSumStateTau, + machineDirectedObjectiveSumPayload_canonicalState, + machineDirectedObjectiveSumTau_encode] + +@[simp] theorem machineDirectedObjectiveSumStateMatrix_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumStateMatrix + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ := by + rw [machineDirectedObjectiveSumStateMatrix, + machineDirectedObjectiveSumPayload_canonicalState, + machineDirectedObjectiveSumMatrix_encode] + +@[simp] theorem machineDirectedObjectiveSumStateVector_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumStateVector + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rationalFiniteVectorCode y := by + rw [machineDirectedObjectiveSumStateVector, + machineDirectedObjectiveSumPayload_canonicalState, + machineDirectedObjectiveSumVector_encode] + +@[simp] theorem machineDirectedObjectiveSumMatrixEntryInput_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumMatrixEntryInput + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩)) := by + simp [machineDirectedObjectiveSumMatrixEntryInput] + +@[simp] theorem machineDirectedObjectiveSumMatrixEntryRaw_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumMatrixEntryRaw + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode (rawRatOfRat (A i j)) := by + rw [machineDirectedObjectiveSumMatrixEntryRaw, + machineDirectedObjectiveSumMatrixEntryInput_canonicalState, + machineMatrixEntryAtUnary_encode] + rw [← rawRatBinaryCode_rawRatOfRat, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + congr 1 + simp [binaryNormalizeRawRat_eq_value, rawRatOfRat_value] + +@[simp] theorem machineDirectedObjectiveSumAffineEntryInput_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumAffineEntryInput + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineBetheAffineEntryCanonicalWord i j y := by + simp [machineDirectedObjectiveSumAffineEntryInput, + machineBetheAffineEntryCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumAffineEntryRaw_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumAffineEntryRaw + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode (rawRatOfRat (betheAffineMatrixQ y i j)) := by + rw [machineDirectedObjectiveSumAffineEntryRaw, + machineDirectedObjectiveSumAffineEntryInput_canonicalState, + machineBetheAffineEntryRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + congr 1 + rw [binaryNormalizeRawRat_eq_value, + rawBetheAffineEntry_value] + +@[simp] theorem machineDirectedObjectiveSumCoordinateInput_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumCoordinateInput + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineDirectedObjectiveCoordinateCanonicalWord tau (A i j) + (betheAffineMatrixQ y i j) p := by + simp [machineDirectedObjectiveSumCoordinateInput, + machineDirectedObjectiveCoordinateCanonicalWord] + +@[simp] theorem machineDirectedObjectiveSumCoordinateRawCode_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumCoordinateRawCode + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode + (rawDirectedNegativeObjectiveCoordinateLower tau (A i j) + (betheAffineMatrixQ y i j) p) := by + rw [machineDirectedObjectiveSumCoordinateRawCode, + machineDirectedObjectiveSumCoordinateInput_canonicalState, + machineDirectedNegativeObjectiveCoordinateLowerRawCode_encode] + +/-! ## Exact `(m+1)^2` iteration ruler on canonical inputs -/ + +@[simp] theorem machineDirectedObjectiveSumWorkBits_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineBetheFloorScanWorkBits + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + ((m + 1) * (m + 1)).bits := by + rw [machineBetheFloorScanWorkBits, machineBetheFloorScanOrderBits, + machineBetheFloorScanDimensionBits, + machineBetheFloorScanDimension, + machineDirectedObjectiveSumCanonicalWord, machinePairFirst_pair, + machineLengthBits_encode, List.length_replicate] + have hone : ([true] : List Bool) = (1 : β„•).bits := rfl + rw [hone, machineBinaryAddBits_pair_natBits, + machineBinaryMulBits_pair_natBits] + +theorem machineDirectedObjectiveSumWork_le_guard {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + (m + 1) * (m + 1) ≀ + (machineBetheFloorScanGuard + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length := by + have hm : m ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + simp only [machineDirectedObjectiveSumCanonicalWord, pair_length, + List.length_replicate] + omega + simp only [machineBetheFloorScanGuard, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +@[simp] theorem machineDirectedObjectiveSumRuler_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumRuler + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + List.replicate ((m + 1) * (m + 1)) true := by + rw [machineDirectedObjectiveSumRuler, + machineBetheFloorScanRuler, + machineDirectedObjectiveSumWorkBits_encode, + machineBoundedUnary_encode_of_le] + exact machineDirectedObjectiveSumWork_le_guard tau A y p + +/-! ## Typed row-major semantics -/ + +/-- Evaluates the raw directed negative-objective summand using matrix coefficient `A i j` and +the corresponding affine entry of `y`. -/ +def rawDirectedBetheObjectiveCoordinate {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : RawRat := + rawDirectedNegativeObjectiveCoordinateLower tau (A i j) + (betheAffineMatrixQ y i j) p + +/-- Bounds a raw directed coordinate expression by adding the widths of its inputs and three +logarithm approximations, counting the coordinate width twice. -/ +def rawDirectedNegativeObjectiveCoordinateWidthBudget + (tau a x : β„š) (p : β„•) : β„• := + 2 * rawRatWidth (rawRatOfRat x) + + rawRatWidth (rawRatOfRat tau) + + rawRatWidth (rawRatOfRat (1 - x)) + + rawRatWidth (rawScheduledLogUpper a p) + + rawRatWidth (rawScheduledLogLower x p) + + rawRatWidth (rawScheduledLogUpper (1 - x) p) + 4 + +theorem rawDirectedNegativeObjectiveCoordinateLower_width_le + (tau a x : β„š) (p : β„•) : + rawRatWidth + (rawDirectedNegativeObjectiveCoordinateLower tau a x p) ≀ + rawDirectedNegativeObjectiveCoordinateWidthBudget tau a x p := by + let rawTau := rawRatOfRat tau + let rawX := rawRatOfRat x + let rawComplement := rawRatOfRat (1 - x) + let logA := rawScheduledLogUpper a p + let logX := rawScheduledLogLower x p + let logComplement := rawScheduledLogUpper (1 - x) p + have hone : rawRatWidth RawRat.one = 1 := rawRatWidth_one + have hfirst := rawRatWidth_mul_le rawX.neg logA + rw [rawRatWidth_neg] at hfirst + have honeTau := rawRatWidth_add_le RawRat.one rawTau + rw [hone] at honeTau + have hmiddleScale := rawRatWidth_mul_le + (RawRat.one.add rawTau) rawX + have hmiddle := rawRatWidth_mul_le + ((RawRat.one.add rawTau).mul rawX) logX + have hlastProduct := rawRatWidth_mul_le rawComplement logComplement + have hfirstMiddle := rawRatWidth_add_le + (rawX.neg.mul logA) + (((RawRat.one.add rawTau).mul rawX).mul logX) + have htotal := rawRatWidth_add_le + ((rawX.neg.mul logA).add + (((RawRat.one.add rawTau).mul rawX).mul logX)) + (rawComplement.mul logComplement).neg + rw [rawRatWidth_neg] at htotal + have honeTauBound : + rawRatWidth (RawRat.one.add rawTau) ≀ + rawRatWidth rawTau + 2 := by omega + have hmiddleScaleBound : + rawRatWidth ((RawRat.one.add rawTau).mul rawX) ≀ + rawRatWidth rawTau + rawRatWidth rawX + 2 := by omega + have hmiddleBound : + rawRatWidth (((RawRat.one.add rawTau).mul rawX).mul logX) ≀ + rawRatWidth rawTau + rawRatWidth rawX + + rawRatWidth logX + 2 := by omega + have hfirstMiddleBound : + rawRatWidth + ((rawX.neg.mul logA).add + (((RawRat.one.add rawTau).mul rawX).mul logX)) ≀ + 2 * rawRatWidth rawX + rawRatWidth rawTau + + rawRatWidth logA + rawRatWidth logX + 3 := by omega + have htotalBound : + rawRatWidth + (((rawX.neg.mul logA).add + (((RawRat.one.add rawTau).mul rawX).mul logX)).add + (rawComplement.mul logComplement).neg) ≀ + 2 * rawRatWidth rawX + rawRatWidth rawTau + + rawRatWidth rawComplement + rawRatWidth logA + + rawRatWidth logX + rawRatWidth logComplement + 4 := by omega + simpa [rawDirectedNegativeObjectiveCoordinateLower, + rawDirectedNegativeObjectiveCoordinateWidthBudget, + rawTau, rawX, rawComplement, logA, logX, logComplement] using! + htotalBound + +theorem rawRatListCost_le_uniform_width {W : β„•} : βˆ€ xs : List β„š, + (βˆ€ q ∈ xs, rawRatWidth (rawRatOfRat q) ≀ W) β†’ + rawRatListCost xs ≀ xs.length * (W + 1) := by + intro xs hwidth + induction xs with + | nil => simp [rawRatListCost] + | cons q qs ih => + have hq := hwidth q (by simp) + have hqs : βˆ€ r ∈ qs, rawRatWidth (rawRatOfRat r) ≀ W := by + intro r hr + exact hwidth r (by simp [hr]) + have ih' := ih hqs + simp only [rawRatListCost] at ih' + simp only [rawRatListCost, List.map_cons, List.sum_cons, + List.length_cons] + rw [Nat.succ_mul] + omega + +theorem rawDirectedObjectiveSum_y_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (k : Fin (m * m)) : + rawRatWidth (rawRatOfRat (y k)) ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let word := machineDirectedObjectiveSumCanonicalWord tau A y p + have hk : y k ∈ List.ofFn y := by + rw [List.mem_ofFn'] + exact ⟨k, rfl⟩ + have hentry := binaryListCode_element_length_le + rationalEntryBinaryCode hk + have hvector : (rationalFiniteVectorCode y).length ≀ word.length := by + simp only [word, machineDirectedObjectiveSumCanonicalWord, + rationalFiniteVectorCode, pair_length, List.length_replicate] + omega + have hcode : (rawRatBinaryCode (rawRatOfRat (y k))).length ≀ + word.length := by + rw [rawRatBinaryCode_rawRatOfRat] + exact hentry.trans hvector + exact (rawRatWidth_le_binaryCode_length _).trans hcode + +theorem rawDirectedObjectiveSum_A_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + rawRatWidth (rawRatOfRat (A i j)) ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let rows := rationalMatrixRows A + let matrixWord := rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ + let word := machineDirectedObjectiveSumCanonicalWord tau A y p + have hrow : List.ofFn (A i) ∈ rows := by + change List.ofFn (A i) ∈ rationalMatrixRows A + rw [rationalMatrixRows, List.mem_ofFn'] + exact ⟨i, rfl⟩ + have hentryMem : A i j ∈ List.ofFn (A i) := by + rw [List.mem_ofFn'] + exact ⟨j, rfl⟩ + have hentry := binaryListCode_element_length_le + rationalEntryBinaryCode hentryMem + have hrowCode := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hrow + have hrowsMatrix : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + matrixWord.length := by + calc + _ = (machineMatrixRowsWord matrixWord).length := by + simpa only [rows, matrixWord] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ matrixWord.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le matrixWord + have hmatrixWord : matrixWord.length ≀ word.length := by + simp only [matrixWord, word, machineDirectedObjectiveSumCanonicalWord, + pair_length, List.length_replicate] + omega + have hcode : (rawRatBinaryCode (rawRatOfRat (A i j))).length ≀ + word.length := by + rw [rawRatBinaryCode_rawRatOfRat] + exact hentry.trans (hrowCode.trans (hrowsMatrix.trans hmatrixWord)) + exact (rawRatWidth_le_binaryCode_length _).trans hcode + +theorem rawDirectedObjectiveSum_tau_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + rawRatWidth (rawRatOfRat tau) ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + have hcode : (rawRatBinaryCode (rawRatOfRat tau)).length ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + simp only [machineDirectedObjectiveSumCanonicalWord, pair_length, + List.length_replicate] + omega + exact (rawRatWidth_le_binaryCode_length _).trans hcode + +theorem rawBetheDimensionMinusOne_width_le (m : β„•) : + rawRatWidth (rawBetheDimensionMinusOne m) ≀ m + 2 := by + rw [rawBetheDimensionMinusOne, rawRatWidth] + cases m with + | zero => norm_num + | succ k => + norm_num only [Int.natCast_add, Int.natCast_one, + add_sub_cancel_right, Nat.size_one] + have hsize : k.size ≀ k + 1 := by + rw [Nat.size_le] + exact (Nat.lt_two_pow_self (n := k)).trans_le + (Nat.pow_le_pow_right (by decide) (Nat.le_succ _)) + exact max_le (hsize.trans (by omega)) (by omega) + +theorem rawBetheAffineLineSum_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (rowMode : Bool) (fixed : Fin m) : + rawRatWidth (rawBetheAffineLineSum rowMode fixed y) ≀ + 1 + m * + ((machineDirectedObjectiveSumCanonicalWord tau A y p).length + 1) := by + let values := betheAffineLineValues rowMode fixed y + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + have hvalueWidth : βˆ€ q ∈ values, + rawRatWidth (rawRatOfRat q) ≀ L := by + intro q hq + simp only [values, betheAffineLineValues, List.mem_ofFn'] at hq + rcases hq with ⟨k, rfl⟩ + split + Β· exact rawDirectedObjectiveSum_y_width_le_word tau A y p _ + Β· exact rawDirectedObjectiveSum_y_width_le_word tau A y p _ + have hcost := rawRatListCost_le_uniform_width values hvalueWidth + have hsum := rawRatWidth_listSum_le RawRat.zero values + have hzero : rawRatWidth RawRat.zero = 1 := rawRatWidth_zero + rw [hzero] at hsum + have hlen : values.length = m := by + simp [values] + rw [hlen] at hcost + have hfinal : rawRatWidth (rawRatListSum RawRat.zero values) ≀ + 1 + m * (L + 1) := hsum.trans (by omega) + simpa only [rawBetheAffineLineSum, values, L] using! hfinal + +theorem rawBetheAffineTotal_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + rawRatWidth (rawRatListSum RawRat.zero (List.ofFn y)) ≀ + 1 + m * m * + ((machineDirectedObjectiveSumCanonicalWord tau A y p).length + 1) := by + let values := List.ofFn y + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + have hvalueWidth : βˆ€ q ∈ values, + rawRatWidth (rawRatOfRat q) ≀ L := by + intro q hq + simp only [values, List.mem_ofFn'] at hq + rcases hq with ⟨k, rfl⟩ + exact rawDirectedObjectiveSum_y_width_le_word tau A y p k + have hcost := rawRatListCost_le_uniform_width values hvalueWidth + have hsum := rawRatWidth_listSum_le RawRat.zero values + have hzero : rawRatWidth RawRat.zero = 1 := rawRatWidth_zero + rw [hzero] at hsum + have hlen : values.length = m * m := by simp [values] + rw [hlen] at hcost + have hfinal : rawRatWidth (rawRatListSum RawRat.zero values) ≀ + 1 + m * m * (L + 1) := hsum.trans (by omega) + simpa only [values, L] using! hfinal + +/-- Provides the polynomial affine-entry width budget `m * m * (L + 1) + m + L + 8`. -/ +def rawBetheAffineEntryWidthBudget (m L : β„•) : β„• := + m * m * (L + 1) + m + L + 8 + +theorem rawBetheAffineEntry_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + rawRatWidth (rawBetheAffineEntry y i j) ≀ + rawBetheAffineEntryWidthBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + have hlineRow := fun fixed : Fin m ↦ + rawBetheAffineLineSum_width_le_word tau A y p true fixed + have hlineColumn := fun fixed : Fin m ↦ + rawBetheAffineLineSum_width_le_word tau A y p false fixed + have htotal := rawBetheAffineTotal_width_le_word tau A y p + have hdimension := rawBetheDimensionMinusOne_width_le m + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last] + have hsub := rawRatWidth_sub_le + (rawRatListSum RawRat.zero (List.ofFn y)) + (rawBetheDimensionMinusOne m) + simp only [rawBetheAffineEntryWidthBudget] + change m * m * + ((machineDirectedObjectiveSumCanonicalWord tau A y p).length + 1) + + m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + 8 β‰₯ + rawRatWidth + ((rawRatListSum RawRat.zero (List.ofFn y)).sub + (rawBetheDimensionMinusOne m)) + omega + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last, + Fin.lastCases_castSucc] + have hsub := rawRatWidth_sub_le RawRat.one + (rawBetheAffineLineSum false j y) + rw [rawRatWidth_one] at hsub + have hline := hlineColumn j + have hmpos : 0 < m := Nat.zero_lt_of_lt j.isLt + have hmm : m ≀ m * m := Nat.le_mul_of_pos_left m hmpos + have hquad := Nat.mul_le_mul_right + ((machineDirectedObjectiveSumCanonicalWord tau A y p).length + 1) hmm + simp only [rawBetheAffineEntryWidthBudget] + omega + Β· simp only [rawBetheAffineEntry, Fin.lastCases_last, + Fin.lastCases_castSucc] + have hsub := rawRatWidth_sub_le RawRat.one + (rawBetheAffineLineSum true i y) + rw [rawRatWidth_one] at hsub + have hline := hlineRow i + have hmpos : 0 < m := Nat.zero_lt_of_lt i.isLt + have hmm : m ≀ m * m := Nat.le_mul_of_pos_left m hmpos + have hquad := Nat.mul_le_mul_right + ((machineDirectedObjectiveSumCanonicalWord tau A y p).length + 1) hmm + simp only [rawBetheAffineEntryWidthBudget] + omega + Β· simp only [rawBetheAffineEntry, Fin.lastCases_castSucc] + have hy := rawDirectedObjectiveSum_y_width_le_word tau A y p + (finProdFinEquiv (i, j)) + simp only [rawBetheAffineEntryWidthBudget] + omega + +theorem rawBetheAffineMatrixQ_width_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + rawRatWidth (rawRatOfRat (betheAffineMatrixQ y i j)) ≀ + 20 + 12 * rawBetheAffineEntryWidthBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let raw := rawBetheAffineEntry y i j + have hvalue : binaryNormalizeRawRat raw = betheAffineMatrixQ y i j := by + rw [binaryNormalizeRawRat_eq_value, rawBetheAffineEntry_value] + have hcanonical := rawRatOfRat_width_le_encodedBitLength + (binaryNormalizeRawRat raw) + have hnormalize := binaryNormalizeRawRat_encodedBitLength_le raw + have hraw := rawBetheAffineEntry_width_le_word tau A y p i j + have hraw' : rawRatWidth raw ≀ rawBetheAffineEntryWidthBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + simpa only [raw] using! hraw + have hscaled := Nat.mul_le_mul_left 12 hraw' + calc + rawRatWidth (rawRatOfRat (betheAffineMatrixQ y i j)) = + rawRatWidth (rawRatOfRat (binaryNormalizeRawRat raw)) := by rw [hvalue] + _ ≀ encodedBitLength β„š (binaryNormalizeRawRat raw) := hcanonical + _ ≀ 20 + 12 * rawRatWidth raw := hnormalize + _ ≀ 20 + 12 * rawBetheAffineEntryWidthBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + omega + +/-- Provides the encoded coordinate budget `20 + 12 * rawBetheAffineEntryWidthBudget m L`. -/ +def rawDirectedObjectiveCoordinateWordXBudget (m L : β„•) : β„• := + 20 + 12 * rawBetheAffineEntryWidthBudget m L + +/-- Provides the encoded complement budget by scaling the coordinate budget by twelve and adding +forty-four. -/ +def rawDirectedObjectiveCoordinateWordComplementBudget + (m L : β„•) : β„• := + 44 + 12 * rawDirectedObjectiveCoordinateWordXBudget m L + +/-- Provides the polynomial scheduled-logarithm word budget `64 * (L + 2 * W + 4)^2 * (W + 2)`. -/ +def rawScheduledLogWordBudget (L W : β„•) : β„• := + 64 * (L + 2 * W + 4) ^ 2 * (W + 2) + +/-- Combines coordinate, complement, parameter, and three scheduled-logarithm budgets into a +bound for one encoded objective summand. -/ +def rawDirectedObjectiveCoordinateWordBudget (m L : β„•) : β„• := + let WX := rawDirectedObjectiveCoordinateWordXBudget m L + let WC := rawDirectedObjectiveCoordinateWordComplementBudget m L + 2 * WX + L + WC + + rawScheduledLogWordBudget L L + + rawScheduledLogWordBudget L WX + + rawScheduledLogWordBudget L WC + 4 + +theorem directedObjectiveSum_precision_le_word {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + p ≀ (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + simp only [machineDirectedObjectiveSumCanonicalWord, pair_length, + List.length_replicate] + omega + +theorem rawDirectedBetheObjectiveCoordinate_width_le_word_budget {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) : + rawRatWidth (rawDirectedBetheObjectiveCoordinate tau A y p i j) ≀ + rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let x := betheAffineMatrixQ y i j + let WX := rawDirectedObjectiveCoordinateWordXBudget m L + let WC := rawDirectedObjectiveCoordinateWordComplementBudget m L + have hp : p ≀ L := directedObjectiveSum_precision_le_word tau A y p + have htau : rawRatWidth (rawRatOfRat tau) ≀ L := + rawDirectedObjectiveSum_tau_width_le_word tau A y p + have ha : rawRatWidth (rawRatOfRat (A i j)) ≀ L := + rawDirectedObjectiveSum_A_width_le_word tau A y p i j + have hx : rawRatWidth (rawRatOfRat x) ≀ WX := by + simpa only [x, WX, L, + rawDirectedObjectiveCoordinateWordXBudget] using! + rawBetheAffineMatrixQ_width_le_word tau A y p i j + have hc0 := rawRatWidth_complement_le x + have hc : rawRatWidth (rawRatOfRat (1 - x)) ≀ WC := by + simp only [WC, rawDirectedObjectiveCoordinateWordComplementBudget] + omega + have hlogA := rawRatWidth_scheduledLogUpper_of_bounds_le + (A i j) hp ha + have hlogX := rawRatWidth_scheduledLogLower_of_bounds_le x hp hx + have hlogC := rawRatWidth_scheduledLogUpper_of_bounds_le (1 - x) hp hc + have hraw := rawDirectedNegativeObjectiveCoordinateLower_width_le + tau (A i j) x p + have hfinal : + rawRatWidth + (rawDirectedNegativeObjectiveCoordinateLower tau (A i j) x p) ≀ + 2 * WX + L + WC + + 64 * (L + 2 * L + 4) ^ 2 * (L + 2) + + 64 * (L + 2 * WX + 4) ^ 2 * (WX + 2) + + 64 * (L + 2 * WC + 4) ^ 2 * (WC + 2) + 4 := by + simp only [rawDirectedNegativeObjectiveCoordinateWidthBudget] at hraw + omega + simpa only [rawDirectedBetheObjectiveCoordinate, + rawDirectedObjectiveCoordinateWordBudget, rawScheduledLogWordBudget, + WX, WC, L, x] using! hfinal + +structure DirectedObjectiveSumSemanticState (m : β„•) where + /-- The current matrix row of the semantic objective scan. -/ + row : Fin (m + 1) + /-- The current matrix column of the semantic objective scan. -/ + column : Fin (m + 1) + /-- The raw rational accumulator of the semantic objective scan. -/ + acc : RawRat + /-- Whether the semantic objective scan has included its last matrix entry. -/ + done : Bool + +/-- Initializes the semantic scan at the first matrix entry with zero accumulator and an unset +completion flag. -/ +def directedObjectiveSumSemanticInit (m : β„•) : + DirectedObjectiveSumSemanticState m where + row := ⟨0, by omega⟩ + column := ⟨0, by omega⟩ + acc := RawRat.zero + done := false + +/-- Adds one directed objective summand and advances in row-major order, setting the completion +flag after the final entry and fixing completed states. -/ +def directedObjectiveSumSemanticStep {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (state : DirectedObjectiveSumSemanticState m) : + DirectedObjectiveSumSemanticState m := + if state.done then state + else + let nextAcc := state.acc.add + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) + if hcolumn : state.column = Fin.last m then + if hrow : state.row = Fin.last m then + { state with acc := nextAcc, done := true } + else + { state with + row := betheFloorScanNextFin state.row + column := ⟨0, by omega⟩ + acc := nextAcc } + else + { state with + column := betheFloorScanNextFin state.column + acc := nextAcc } + +theorem directedObjectiveSumSemanticStep_acc_width {m B C : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (state : DirectedObjectiveSumSemanticState m) + (hacc : rawRatWidth state.acc ≀ C) + (hcoordinate : rawRatWidth + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) ≀ B) : + rawRatWidth (directedObjectiveSumSemanticStep tau A y p state).acc ≀ + C + B + 1 := by + rcases state with ⟨i, j, acc, done⟩ + dsimp only [DirectedObjectiveSumSemanticState.acc, + DirectedObjectiveSumSemanticState.row, + DirectedObjectiveSumSemanticState.column] at hacc hcoordinate ⊒ + cases done + Β· have hadd := rawRatWidth_add_le acc + (rawDirectedBetheObjectiveCoordinate tau A y p i j) + by_cases hcolumn : j = Fin.last m + Β· by_cases hrow : i = Fin.last m + Β· simpa [directedObjectiveSumSemanticStep, hcolumn, hrow] using! + hadd.trans (by omega) + Β· simpa [directedObjectiveSumSemanticStep, hcolumn, hrow] using! + hadd.trans (by omega) + Β· simpa [directedObjectiveSumSemanticStep, hcolumn] using! + hadd.trans (by omega) + Β· simpa [directedObjectiveSumSemanticStep] using! + hacc.trans (by omega) + +/-- Encodes a semantic objective-sum state with the supplied bound and fixed problem parameters. -/ +def machineDirectedObjectiveSumSemanticCode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (bound : List Bool) + (state : DirectedObjectiveSumSemanticState m) : List Bool := + machineDirectedObjectiveSumCanonicalState tau A y p + state.row state.column state.acc state.done bound + +@[simp] theorem machineDirectedObjectiveSumLastRowBit_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumLastRowBit + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + [decide (i = Fin.last m)] := by + rw [machineDirectedObjectiveSumLastRowBit, + machineDirectedObjectiveSumRow_canonicalState, + machineDirectedObjectiveSumStateDimension_canonicalState, + machineUnaryRulersEqualBit_replicate] + by_cases hi : i = Fin.last m + Β· simp [hi] + Β· have hval : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + simp [hi, hval] + +@[simp] theorem machineDirectedObjectiveSumLastColumnBit_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumLastColumnBit + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + [decide (j = Fin.last m)] := by + rw [machineDirectedObjectiveSumLastColumnBit, + machineDirectedObjectiveSumColumn_canonicalState, + machineDirectedObjectiveSumStateDimension_canonicalState, + machineUnaryRulersEqualBit_replicate] + by_cases hj : j = Fin.last m + Β· simp [hj] + Β· have hval : j.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + simp [hj, hval] + +@[simp] theorem machineDirectedObjectiveSumCandidate_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) : + machineDirectedObjectiveSumCandidate + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j)) := by + rw [machineDirectedObjectiveSumCandidate, + machineDirectedObjectiveSumAcc_canonicalState, + machineDirectedObjectiveSumCoordinateRawCode_canonicalState, + machineRawRatAddCode_encode] + rfl + +theorem machineDirectedObjectiveSumNextAcc_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) + (hlarge : + (rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j))).length + ≀ bound.length) : + machineDirectedObjectiveSumNextAcc + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j)) := by + rw [machineDirectedObjectiveSumNextAcc, + machineDirectedObjectiveSumCandidate_canonicalState, + machineDirectedObjectiveSumBound_canonicalState] + exact (List.take_eq_self_iff _).mpr hlarge + +theorem machineDirectedObjectiveSumNextRow_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) (hi : i β‰  Fin.last m) + (hbound : m ≀ bound.length) : + machineDirectedObjectiveSumNextRow + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate (betheFloorScanNextFin i).1 true := by + rw [machineDirectedObjectiveSumNextRow, + machineDirectedObjectiveSumRow_canonicalState, + machineDirectedObjectiveSumBound_canonicalState, + betheFloorScanNextFin_val i hi, + List.replicate_succ'] + apply (List.take_eq_self_iff _).mpr + simp only [List.length_append, List.length_replicate, + List.length_singleton] + have hval : i.1 β‰  m := by + intro h + apply hi + apply Fin.ext + simpa using! h + have : i.1 + 1 ≀ m := by omega + omega + +theorem machineDirectedObjectiveSumNextColumn_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) (hj : j β‰  Fin.last m) + (hbound : m ≀ bound.length) : + machineDirectedObjectiveSumNextColumn + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + List.replicate (betheFloorScanNextFin j).1 true := by + rw [machineDirectedObjectiveSumNextColumn, + machineDirectedObjectiveSumColumn_canonicalState, + machineDirectedObjectiveSumBound_canonicalState, + betheFloorScanNextFin_val j hj, + List.replicate_succ'] + apply (List.take_eq_self_iff _).mpr + simp only [List.length_append, List.length_replicate, + List.length_singleton] + have hval : j.1 β‰  m := by + intro h + apply hj + apply Fin.ext + simpa using! h + have : j.1 + 1 ≀ m := by omega + omega + +theorem machineDirectedObjectiveSumFinish_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) + (hlarge : + (rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j))).length + ≀ bound.length) : + machineDirectedObjectiveSumFinish + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineDirectedObjectiveSumCanonicalState tau A y p i j + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j)) + true bound := by + rw [machineDirectedObjectiveSumFinish] + simp only [machineDirectedObjectiveSumRow_canonicalState, + machineDirectedObjectiveSumColumn_canonicalState, + machineDirectedObjectiveSumNextAcc_canonicalState + tau A y p i j acc done bound hlarge, + machineDirectedObjectiveSumBound_canonicalState, + machineDirectedObjectiveSumPayload_canonicalState] + rfl + +theorem machineDirectedObjectiveSumAdvanceRow_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) (hi : i β‰  Fin.last m) + (hbound : m ≀ bound.length) + (hlarge : + (rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j))).length + ≀ bound.length) : + machineDirectedObjectiveSumAdvanceRow + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineDirectedObjectiveSumCanonicalState tau A y p + (betheFloorScanNextFin i) ⟨0, by omega⟩ + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j)) + done bound := by + rw [machineDirectedObjectiveSumAdvanceRow] + simp only [machineDirectedObjectiveSumNextRow_canonicalState + tau A y p i j acc done bound hi hbound, + machineDirectedObjectiveSumNextAcc_canonicalState + tau A y p i j acc done bound hlarge, + machineDirectedObjectiveSumBound_canonicalState, + machineDirectedObjectiveSumDone_canonicalState, + machineDirectedObjectiveSumPayload_canonicalState] + rfl + +theorem machineDirectedObjectiveSumAdvanceColumn_canonicalState + {m : β„•} (tau : β„š) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (i j : Fin (m + 1)) (acc : RawRat) (done : Bool) + (bound : List Bool) (hj : j β‰  Fin.last m) + (hbound : m ≀ bound.length) + (hlarge : + (rawRatBinaryCode + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j))).length + ≀ bound.length) : + machineDirectedObjectiveSumAdvanceColumn + (machineDirectedObjectiveSumCanonicalState + tau A y p i j acc done bound) = + machineDirectedObjectiveSumCanonicalState tau A y p i + (betheFloorScanNextFin j) + (acc.add (rawDirectedBetheObjectiveCoordinate tau A y p i j)) + done bound := by + rw [machineDirectedObjectiveSumAdvanceColumn] + simp only [machineDirectedObjectiveSumRow_canonicalState, + machineDirectedObjectiveSumNextColumn_canonicalState + tau A y p i j acc done bound hj hbound, + machineDirectedObjectiveSumNextAcc_canonicalState + tau A y p i j acc done bound hlarge, + machineDirectedObjectiveSumBound_canonicalState, + machineDirectedObjectiveSumDone_canonicalState, + machineDirectedObjectiveSumPayload_canonicalState] + rfl + +theorem machineDirectedObjectiveSumStep_semanticCode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (bound : List Bool) + (state : DirectedObjectiveSumSemanticState m) + (hbound : m ≀ bound.length) + (hlarge : + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ bound.length) : + machineDirectedObjectiveSumStep + (machineDirectedObjectiveSumSemanticCode tau A y p bound state) = + machineDirectedObjectiveSumSemanticCode tau A y p bound + (directedObjectiveSumSemanticStep tau A y p state) := by + rcases state with ⟨i, j, acc, done⟩ + cases done + Β· dsimp only [DirectedObjectiveSumSemanticState.row, + DirectedObjectiveSumSemanticState.column, + DirectedObjectiveSumSemanticState.acc, + DirectedObjectiveSumSemanticState.done] at hlarge ⊒ + by_cases hcolumn : j = Fin.last m + Β· by_cases hrow : i = Fin.last m + Β· rw [machineDirectedObjectiveSumStep, + machineDirectedObjectiveSumSemanticCode, + machineDirectedObjectiveSumDone_canonicalState, + machineHeadBit_cons, machineIfHead_false, + machineDirectedObjectiveSumProcess, + machineDirectedObjectiveSumLastColumnBit_canonicalState, + machineHeadBit_cons] + have hc : decide (j = Fin.last m) = true := by simp [hcolumn] + have hr : decide (i = Fin.last m) = true := by simp [hrow] + rw [hc, machineIfHead_true, + machineDirectedObjectiveSumLastRowBit_canonicalState, + machineHeadBit_cons, hr, machineIfHead_true, + machineDirectedObjectiveSumFinish_canonicalState + tau A y p i j acc false bound hlarge] + simp [machineDirectedObjectiveSumSemanticCode, + directedObjectiveSumSemanticStep, hcolumn, hrow] + Β· rw [machineDirectedObjectiveSumStep, + machineDirectedObjectiveSumSemanticCode, + machineDirectedObjectiveSumDone_canonicalState, + machineHeadBit_cons, machineIfHead_false, + machineDirectedObjectiveSumProcess, + machineDirectedObjectiveSumLastColumnBit_canonicalState, + machineHeadBit_cons] + have hc : decide (j = Fin.last m) = true := by simp [hcolumn] + have hr : decide (i = Fin.last m) = false := by simp [hrow] + rw [hc, machineIfHead_true, + machineDirectedObjectiveSumLastRowBit_canonicalState, + machineHeadBit_cons, hr, machineIfHead_false, + machineDirectedObjectiveSumAdvanceRow_canonicalState + tau A y p i j acc false bound hrow hbound hlarge] + simp [machineDirectedObjectiveSumSemanticCode, + directedObjectiveSumSemanticStep, hcolumn, hrow] + Β· rw [machineDirectedObjectiveSumStep, + machineDirectedObjectiveSumSemanticCode, + machineDirectedObjectiveSumDone_canonicalState, + machineHeadBit_cons, machineIfHead_false, + machineDirectedObjectiveSumProcess, + machineDirectedObjectiveSumLastColumnBit_canonicalState, + machineHeadBit_cons] + have hc : decide (j = Fin.last m) = false := by simp [hcolumn] + rw [hc, machineIfHead_false, + machineDirectedObjectiveSumAdvanceColumn_canonicalState + tau A y p i j acc false bound hcolumn hbound hlarge] + simp [machineDirectedObjectiveSumSemanticCode, + directedObjectiveSumSemanticStep, hcolumn] + Β· dsimp only [DirectedObjectiveSumSemanticState.row, + DirectedObjectiveSumSemanticState.column, + DirectedObjectiveSumSemanticState.acc, + DirectedObjectiveSumSemanticState.done] at hlarge ⊒ + rw [machineDirectedObjectiveSumStep, + machineDirectedObjectiveSumSemanticCode, + machineDirectedObjectiveSumDone_canonicalState, + machineHeadBit_cons, machineIfHead_true] + simp [machineDirectedObjectiveSumSemanticCode, + directedObjectiveSumSemanticStep] + +@[simp] theorem machineDirectedObjectiveSumInit_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedObjectiveSumInit + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + machineDirectedObjectiveSumSemanticCode tau A y p + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)) + (directedObjectiveSumSemanticInit m) := by + simp [machineDirectedObjectiveSumInit, + machineDirectedObjectiveSumSemanticCode, + machineDirectedObjectiveSumCanonicalState, + directedObjectiveSumSemanticInit] + +/-- Runs the semantic objective scan for `(m + 1)^2` steps, one per matrix entry. -/ +def finalDirectedObjectiveSumSemanticState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + DirectedObjectiveSumSemanticState m := + (directedObjectiveSumSemanticStep tau A y p)^[(m + 1) * (m + 1)] + (directedObjectiveSumSemanticInit m) + +/-- Runs the semantic objective scan for exactly `k` steps from its initial state. -/ +def directedObjectiveSumSemanticStateAt {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) : + DirectedObjectiveSumSemanticState m := + (directedObjectiveSumSemanticStep tau A y p)^[k] + (directedObjectiveSumSemanticInit m) + +@[simp] theorem directedObjectiveSumSemanticStateAt_zero {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + directedObjectiveSumSemanticStateAt tau A y p 0 = + directedObjectiveSumSemanticInit m := rfl + +theorem directedObjectiveSumSemanticStateAt_succ {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) : + directedObjectiveSumSemanticStateAt tau A y p (k + 1) = + directedObjectiveSumSemanticStep tau A y p + (directedObjectiveSumSemanticStateAt tau A y p k) := by + simp only [directedObjectiveSumSemanticStateAt, + Function.iterate_succ_apply'] + +theorem directedObjectiveSumSemanticStateAt_acc_width {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) : + let B := rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + rawRatWidth + (directedObjectiveSumSemanticStateAt tau A y p k).acc ≀ + 1 + k * (B + 1) := by + let B := rawDirectedObjectiveCoordinateWordBudget m + (machineDirectedObjectiveSumCanonicalWord tau A y p).length + induction k with + | zero => + simp [directedObjectiveSumSemanticStateAt, + directedObjectiveSumSemanticInit, rawRatWidth_zero] + | succ k ih => + let state := directedObjectiveSumSemanticStateAt tau A y p k + have ih' : rawRatWidth state.acc ≀ 1 + k * (B + 1) := by + simpa only [state, B] using! ih + have hcoordinate : rawRatWidth + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) ≀ B := by + simpa only [B] using! + rawDirectedBetheObjectiveCoordinate_width_le_word_budget + tau A y p state.row state.column + have hstep := directedObjectiveSumSemanticStep_acc_width + (B := B) (C := 1 + k * (B + 1)) tau A y p state ih' hcoordinate + rw [directedObjectiveSumSemanticStateAt_succ] + change rawRatWidth + (directedObjectiveSumSemanticStep tau A y p state).acc ≀ + 1 + (k + 1) * (B + 1) + simpa only [Nat.succ_eq_add_one] using! hstep.trans (by + ring_nf + omega) + +theorem rawDirectedObjectiveCoordinateWordBudget_le_pow + {m L : β„•} (hm : m ≀ L) : + rawDirectedObjectiveCoordinateWordBudget m L ≀ (L + 16) ^ 20 := by + let T := L + 16 + have hT16 : 16 ≀ T := by simp [T] + have hTpos : 0 < T := by omega + have hmT : m ≀ T := hm.trans (by simp [T]) + have hLT : L ≀ T := by simp [T] + have hL1T : L + 1 ≀ T := by simp [T] + have hmm := Nat.mul_le_mul hmT hmT + have hcube0 := Nat.mul_le_mul hmm hL1T + have hcube : m * m * (L + 1) ≀ T ^ 3 := by + simpa [pow_succ, mul_assoc] using! hcube0 + have haff : rawBetheAffineEntryWidthBudget m L ≀ 2 * T ^ 3 := by + simp only [rawBetheAffineEntryWidthBudget] + nlinarith [sq_nonneg T] + have hX : rawDirectedObjectiveCoordinateWordXBudget m L ≀ + 26 * T ^ 3 := by + simp only [rawDirectedObjectiveCoordinateWordXBudget] + nlinarith [sq_nonneg T] + have hC : rawDirectedObjectiveCoordinateWordComplementBudget m L ≀ + 315 * T ^ 3 := by + simp only [rawDirectedObjectiveCoordinateWordComplementBudget] + nlinarith [sq_nonneg T] + have hlogA : rawScheduledLogWordBudget L L ≀ 2048 * T ^ 3 := by + have hinner : L + 2 * L + 4 ≀ 4 * T := by omega + have hsquare := Nat.pow_le_pow_left hinner 2 + have hlast : L + 2 ≀ 2 * T := by omega + have hmul := Nat.mul_le_mul (Nat.mul_le_mul_left 64 hsquare) hlast + calc + rawScheduledLogWordBudget L L = + 64 * (L + 2 * L + 4) ^ 2 * (L + 2) := rfl + _ ≀ 64 * (4 * T) ^ 2 * (2 * T) := hmul + _ = 2048 * T ^ 3 := by ring + have hinnerX : L + + 2 * rawDirectedObjectiveCoordinateWordXBudget m L + 4 ≀ + 54 * T ^ 3 := by + nlinarith [sq_nonneg T] + have hlastX : rawDirectedObjectiveCoordinateWordXBudget m L + 2 ≀ + 28 * T ^ 3 := by + nlinarith [sq_nonneg T] + have hlogX : rawScheduledLogWordBudget L + (rawDirectedObjectiveCoordinateWordXBudget m L) ≀ + 5225472 * T ^ 9 := by + have hsquare := Nat.pow_le_pow_left hinnerX 2 + have hmul := Nat.mul_le_mul (Nat.mul_le_mul_left 64 hsquare) hlastX + calc + rawScheduledLogWordBudget L + (rawDirectedObjectiveCoordinateWordXBudget m L) = + 64 * (L + + 2 * rawDirectedObjectiveCoordinateWordXBudget m L + 4) ^ 2 * + (rawDirectedObjectiveCoordinateWordXBudget m L + 2) := rfl + _ ≀ 64 * (54 * T ^ 3) ^ 2 * (28 * T ^ 3) := hmul + _ = 5225472 * T ^ 9 := by ring + have hinnerC : L + + 2 * rawDirectedObjectiveCoordinateWordComplementBudget m L + 4 ≀ + 632 * T ^ 3 := by + nlinarith [sq_nonneg T] + have hlastC : rawDirectedObjectiveCoordinateWordComplementBudget m L + 2 ≀ + 317 * T ^ 3 := by + nlinarith [sq_nonneg T] + have hlogC : rawScheduledLogWordBudget L + (rawDirectedObjectiveCoordinateWordComplementBudget m L) ≀ + 8103514112 * T ^ 9 := by + have hsquare := Nat.pow_le_pow_left hinnerC 2 + have hmul := Nat.mul_le_mul (Nat.mul_le_mul_left 64 hsquare) hlastC + calc + rawScheduledLogWordBudget L + (rawDirectedObjectiveCoordinateWordComplementBudget m L) = + 64 * (L + + 2 * rawDirectedObjectiveCoordinateWordComplementBudget m L + 4) ^ 2 * + (rawDirectedObjectiveCoordinateWordComplementBudget m L + 2) := rfl + _ ≀ 64 * (632 * T ^ 3) ^ 2 * (317 * T ^ 3) := hmul + _ = 8103514112 * T ^ 9 := by ring + have hpow39 : T ^ 3 ≀ T ^ 9 := + Nat.pow_le_pow_right hTpos (by omega) + have hbudget : rawDirectedObjectiveCoordinateWordBudget m L ≀ + 8200000000 * T ^ 9 := by + simp only [rawDirectedObjectiveCoordinateWordBudget] + nlinarith + have hconstant : 8200000000 ≀ 16 ^ 11 := by norm_num + have hbasePow : 16 ^ 11 ≀ T ^ 11 := Nat.pow_le_pow_left hT16 11 + have hcoeff : 8200000000 ≀ T ^ 11 := hconstant.trans hbasePow + have hmul := Nat.mul_le_mul_right (T ^ 9) hcoeff + calc + rawDirectedObjectiveCoordinateWordBudget m L ≀ + 8200000000 * T ^ 9 := hbudget + _ ≀ T ^ 11 * T ^ 9 := hmul + _ = (L + 16) ^ 20 := by simp only [T]; ring + +theorem machineDirectedObjectiveSumDimension_le_accumulatorBound {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + m ≀ (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length := by + have hm : m ≀ + (machineDirectedObjectiveSumCanonicalWord tau A y p).length := by + simp only [machineDirectedObjectiveSumCanonicalWord, pair_length, + List.length_replicate] + omega + rw [machineDirectedObjectiveSumAccumulatorBound, + machineIteratedBinaryWidth_length] + exact hm.trans (certificateExpGuardWidth_self_le 6 _) + +theorem machineDirectedObjectiveSumAccumulatorBound_dominates_next {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) + (hk : k < (m + 1) * (m + 1)) : + let state := directedObjectiveSumSemanticStateAt tau A y p k + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length := by + let word := machineDirectedObjectiveSumCanonicalWord tau A y p + let L := word.length + let T := L + 16 + let B := rawDirectedObjectiveCoordinateWordBudget m L + let state := directedObjectiveSumSemanticStateAt tau A y p k + have hmL : m ≀ L := by + simp only [L, word, machineDirectedObjectiveSumCanonicalWord, + pair_length, List.length_replicate] + omega + have hT16 : 16 ≀ T := by simp [T] + have hTpos : 0 < T := by omega + have hm1T : m + 1 ≀ T := by + dsimp only [T] + omega + have hworkSquare := Nat.mul_le_mul hm1T hm1T + have hkT : k + 1 ≀ T ^ 2 := by + have hk' : k + 1 ≀ (m + 1) * (m + 1) := by omega + exact hk'.trans (by simpa only [pow_two] using! hworkSquare) + have hB : B ≀ T ^ 20 := by + simpa only [B, T] using! + rawDirectedObjectiveCoordinateWordBudget_le_pow hmL + have hacc : rawRatWidth state.acc ≀ 1 + k * (B + 1) := by + simpa only [state, B, L, word] using! + directedObjectiveSumSemanticStateAt_acc_width tau A y p k + have hcoordinate : rawRatWidth + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) ≀ B := by + simpa only [state, B, L, word] using! + rawDirectedBetheObjectiveCoordinate_width_le_word_budget + tau A y p state.row state.column + have hadd := rawRatWidth_add_le state.acc + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) + have hnext : rawRatWidth + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column)) ≀ 1 + (k + 1) * (B + 1) := by + calc + _ ≀ rawRatWidth state.acc + + rawRatWidth (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) + 1 := hadd + _ ≀ (1 + k * (B + 1)) + B + 1 := + Nat.add_le_add_right (Nat.add_le_add hacc hcoordinate) 1 + _ = 1 + (k + 1) * (B + 1) := by ring + have hpow20pos : 1 ≀ T ^ 20 := by + have hbase : 1 ≀ T := by omega + exact one_le_powβ‚€ hbase + have hB1 : B + 1 ≀ 2 * T ^ 20 := by omega + have hproduct := Nat.mul_le_mul hkT hB1 + have hproductEq : T ^ 2 * (2 * T ^ 20) = 2 * T ^ 22 := by ring + have hwidthMajor : rawRatWidth + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column)) ≀ 3 * T ^ 22 := by + calc + _ ≀ 1 + (k + 1) * (B + 1) := hnext + _ ≀ 1 + T ^ 2 * (2 * T ^ 20) := + Nat.add_le_add_left hproduct 1 + _ = 1 + 2 * T ^ 22 := by rw [hproductEq] + _ ≀ 3 * T ^ 22 := by + have hpow22 : 1 ≀ T ^ 22 := one_le_powβ‚€ (by omega) + omega + have hcode := rawRatBinaryCode_length_le_width + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column)) + have hcodeMajor : + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ 10 * T ^ 22 := by + have hpow22 : 4 ≀ T ^ 22 := by + have hbasePow := Nat.pow_le_pow_left hT16 22 + exact (by norm_num : 4 ≀ 16 ^ 22).trans hbasePow + omega + have hten : 10 ≀ T ^ 42 := by + have hbasePow := Nat.pow_le_pow_left hT16 42 + exact (by norm_num : 10 ≀ 16 ^ 42).trans hbasePow + have hmul := Nat.mul_le_mul_right (T ^ 22) hten + have hcodePower : + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ T ^ 64 := by + calc + _ ≀ 10 * T ^ 22 := hcodeMajor + _ ≀ T ^ 42 * T ^ 22 := hmul + _ = T ^ 64 := by ring + rw [machineDirectedObjectiveSumAccumulatorBound, + machineIteratedBinaryWidth_length] + exact hcodePower.trans (by + simpa only [T, L, word] using! + certificateExpGuardWidth_pow_lower 5 + (machineDirectedObjectiveSumCanonicalWord tau A y p).length) + +theorem machineDirectedObjectiveSumIterate_semanticCode_of_large {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (bound : List Bool) + (hbound : m ≀ bound.length) + (hlarge : βˆ€ k, k < (m + 1) * (m + 1) β†’ + let state := directedObjectiveSumSemanticStateAt tau A y p k + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ bound.length) : + βˆ€ k, k ≀ (m + 1) * (m + 1) β†’ + (machineDirectedObjectiveSumStep)^[k] + (machineDirectedObjectiveSumSemanticCode tau A y p bound + (directedObjectiveSumSemanticInit m)) = + machineDirectedObjectiveSumSemanticCode tau A y p bound + (directedObjectiveSumSemanticStateAt tau A y p k) := by + intro k hk + induction k with + | zero => rfl + | succ k ih => + have hklt : k < (m + 1) * (m + 1) := by omega + rw [Function.iterate_succ_apply', ih (by omega)] + have hstep := machineDirectedObjectiveSumStep_semanticCode tau A y p bound + (directedObjectiveSumSemanticStateAt tau A y p k) hbound + (hlarge k hklt) + simpa only [directedObjectiveSumSemanticStateAt, + Function.iterate_succ_apply'] using! hstep + +theorem machineDirectedObjectiveSumFinalState_encode_of_large {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (hlarge : βˆ€ k, k < (m + 1) * (m + 1) β†’ + let state := directedObjectiveSumSemanticStateAt tau A y p k + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length) : + machineDirectedObjectiveSumFinalState + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + machineDirectedObjectiveSumSemanticCode tau A y p + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)) + (finalDirectedObjectiveSumSemanticState tau A y p) := by + rw [machineDirectedObjectiveSumFinalState, + machineDirectedObjectiveSumRuler_encode, List.length_replicate, + machineDirectedObjectiveSumInit_encode] + have hiterate := machineDirectedObjectiveSumIterate_semanticCode_of_large + tau A y p + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)) + (machineDirectedObjectiveSumDimension_le_accumulatorBound tau A y p) + hlarge ((m + 1) * (m + 1)) (by omega) + simpa only [directedObjectiveSumSemanticStateAt, + finalDirectedObjectiveSumSemanticState] using! hiterate + +/-- Returns the raw rational accumulator after scanning all matrix entries. -/ +def rawDirectedNegativeObjectiveSum {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : RawRat := + (finalDirectedObjectiveSumSemanticState tau A y p).acc + +theorem machineDirectedNegativeObjectiveSumRawCode_encode_of_large {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (hlarge : βˆ€ k, k < (m + 1) * (m + 1) β†’ + let state := directedObjectiveSumSemanticStateAt tau A y p k + (rawRatBinaryCode + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column))).length ≀ + (machineDirectedObjectiveSumAccumulatorBound + (machineDirectedObjectiveSumCanonicalWord tau A y p)).length) : + machineDirectedNegativeObjectiveSumRawCode + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rawRatBinaryCode (rawDirectedNegativeObjectiveSum tau A y p) := by + rw [machineDirectedNegativeObjectiveSumRawCode, + machineDirectedObjectiveSumFinalState_encode_of_large tau A y p hlarge] + simp [machineDirectedObjectiveSumSemanticCode, + rawDirectedNegativeObjectiveSum] + +@[simp] theorem machineDirectedNegativeObjectiveSumRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + machineDirectedNegativeObjectiveSumRawCode + (machineDirectedObjectiveSumCanonicalWord tau A y p) = + rawRatBinaryCode (rawDirectedNegativeObjectiveSum tau A y p) := by + apply machineDirectedNegativeObjectiveSumRawCode_encode_of_large + intro k hk + exact machineDirectedObjectiveSumAccumulatorBound_dominates_next + tau A y p k hk + +/-! ## Mathematical value of the row-major sum -/ + +/-- Evaluates the rational directed negative-objective summand at a pair of matrix indices. -/ +def directedNegativeObjectivePairValue {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (ij : Fin (m + 1) Γ— Fin (m + 1)) : β„š := + directedNegativeObjectiveCoordinateLower tau (A ij.1 ij.2) + (betheAffineMatrixQ y ij.1 ij.2) p + +/-- Sums the directed negative-objective summands whose row-major scan ordinals are less than +`k`. -/ +def directedNegativeObjectivePrefix {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) : β„š := + βˆ‘ ij ∈ Finset.univ.filter + (fun ij : Fin (m + 1) Γ— Fin (m + 1) => + betheFloorScanOrdinal ij.1 ij.2 < k), + directedNegativeObjectivePairValue tau A y p ij + +theorem directedNegativeObjectivePrefix_succ_of_ordinal {m k : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (row column : Fin (m + 1)) + (hordinal : betheFloorScanOrdinal row column = k) : + directedNegativeObjectivePrefix tau A y p (k + 1) = + directedNegativeObjectivePrefix tau A y p k + + directedNegativeObjectiveCoordinateLower tau (A row column) + (betheAffineMatrixQ y row column) p := by + classical + let current : Fin (m + 1) Γ— Fin (m + 1) := (row, column) + let prior := Finset.univ.filter + (fun ij : Fin (m + 1) Γ— Fin (m + 1) => + betheFloorScanOrdinal ij.1 ij.2 < k) + have hcurrentNotMem : current βˆ‰ prior := by + simp only [current, prior, Finset.mem_filter, Finset.mem_univ, + true_and, not_lt] + omega + have hfilter : + Finset.univ.filter + (fun ij : Fin (m + 1) Γ— Fin (m + 1) => + betheFloorScanOrdinal ij.1 ij.2 < k + 1) = + insert current prior := by + ext ij + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_insert, current, prior] + constructor + Β· intro hlt + by_cases hprior : betheFloorScanOrdinal ij.1 ij.2 < k + Β· exact Or.inr hprior + Β· left + apply betheFloorScanOrdinal_injective m + have heq : betheFloorScanOrdinal ij.1 ij.2 = k := by omega + exact heq.trans hordinal.symm + Β· intro hmem + rcases hmem with hij | hprior + Β· subst ij + simpa only [Prod.fst, Prod.snd, hordinal] using! Nat.lt_succ_self k + Β· omega + rw [directedNegativeObjectivePrefix, hfilter, + Finset.sum_insert hcurrentNotMem] + simp only [directedNegativeObjectivePrefix, prior, + directedNegativeObjectivePairValue] + ring + +theorem directedNegativeObjectivePrefix_zero {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + directedNegativeObjectivePrefix tau A y p 0 = 0 := by + simp [directedNegativeObjectivePrefix] + +theorem directedNegativeObjectivePrefix_full {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + directedNegativeObjectivePrefix tau A y p + ((m + 1) * (m + 1)) = + directedNegativeObjectiveLower tau A (betheAffineMatrixQ y) p := by + classical + have hfilter : + Finset.univ.filter + (fun ij : Fin (m + 1) Γ— Fin (m + 1) => + betheFloorScanOrdinal ij.1 ij.2 < (m + 1) * (m + 1)) = + Finset.univ := by + ext ij + simp [betheFloorScanOrdinal_lt_square] + rw [directedNegativeObjectivePrefix, hfilter, + Fintype.sum_prod_type] + rfl + +/-- Relates a completed scan to the full directed objective sum, or an unfinished scan at +ordinal `k` to the corresponding prefix sum. -/ +def DirectedObjectiveSumValueInvariant {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p k : β„•) + (state : DirectedObjectiveSumSemanticState m) : Prop := + (state.done = true ∧ (m + 1) * (m + 1) ≀ k ∧ + state.acc.value = + directedNegativeObjectiveLower tau A (betheAffineMatrixQ y) p) ∨ + (state.done = false ∧ + betheFloorScanOrdinal state.row state.column = k ∧ + state.acc.value = directedNegativeObjectivePrefix tau A y p k) + +theorem directedObjectiveSumSemanticInit_valueInvariant {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + DirectedObjectiveSumValueInvariant tau A y p 0 + (directedObjectiveSumSemanticInit m) := by + right + refine ⟨rfl, ?_, ?_⟩ + Β· simp [directedObjectiveSumSemanticInit, betheFloorScanOrdinal] + Β· rw [directedNegativeObjectivePrefix_zero] + simp [directedObjectiveSumSemanticInit] + +theorem directedObjectiveSumSemanticStep_valueInvariant {m k : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (state : DirectedObjectiveSumSemanticState m) + (hinvariant : DirectedObjectiveSumValueInvariant tau A y p k state) : + DirectedObjectiveSumValueInvariant tau A y p (k + 1) + (directedObjectiveSumSemanticStep tau A y p state) := by + rcases hinvariant with hdone | hactive + Β· rcases hdone with ⟨hdone, hwork, hvalue⟩ + have hstep : directedObjectiveSumSemanticStep tau A y p state = state := by + simp [directedObjectiveSumSemanticStep, hdone] + rw [hstep] + left + exact ⟨hdone, hwork.trans (by omega), hvalue⟩ + Β· rcases hactive with ⟨hdone, hordinal, hvalue⟩ + have hnextValue : + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column)).value = + directedNegativeObjectivePrefix tau A y p (k + 1) := by + rw [RawRat.value_add, hvalue, + rawDirectedBetheObjectiveCoordinate, + rawDirectedNegativeObjectiveCoordinateLower_value] + exact (directedNegativeObjectivePrefix_succ_of_ordinal + tau A y p state.row state.column hordinal).symm + by_cases hcolumn : state.column = Fin.last m + Β· by_cases hrow : state.row = Fin.last m + Β· have hstep : directedObjectiveSumSemanticStep tau A y p state = + { state with + acc := state.acc.add + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) + done := true } := by + simp [directedObjectiveSumSemanticStep, hdone, hcolumn, hrow] + rw [hstep] + left + refine ⟨rfl, ?_, ?_⟩ + Β· rw [hrow, hcolumn] at hordinal + rw [← hordinal, betheFloorScanOrdinal_last_last] + Β· change + (state.acc.add (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column)).value = _ + rw [hnextValue] + have htotal : k + 1 = (m + 1) * (m + 1) := by + rw [← hordinal, hrow, hcolumn, + betheFloorScanOrdinal_last_last] + rw [htotal, directedNegativeObjectivePrefix_full] + Β· have hstep : directedObjectiveSumSemanticStep tau A y p state = + { state with + row := betheFloorScanNextFin state.row + column := ⟨0, by omega⟩ + acc := state.acc.add + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) } := by + simp [directedObjectiveSumSemanticStep, hdone, hcolumn, hrow] + rw [hstep] + right + refine ⟨hdone, ?_, hnextValue⟩ + rw [betheFloorScanOrdinal_nextRow state.row hrow, + ← hcolumn, hordinal] + Β· have hstep : directedObjectiveSumSemanticStep tau A y p state = + { state with + column := betheFloorScanNextFin state.column + acc := state.acc.add + (rawDirectedBetheObjectiveCoordinate tau A y p + state.row state.column) } := by + simp [directedObjectiveSumSemanticStep, hdone, hcolumn] + rw [hstep] + right + refine ⟨hdone, ?_, hnextValue⟩ + rw [betheFloorScanOrdinal_nextColumn state.row state.column hcolumn, + hordinal] + +theorem directedObjectiveSumSemanticStateAt_valueInvariant {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : βˆ€ k, + DirectedObjectiveSumValueInvariant tau A y p k + (directedObjectiveSumSemanticStateAt tau A y p k) := by + intro k + induction k with + | zero => exact directedObjectiveSumSemanticInit_valueInvariant tau A y p + | succ k ih => + rw [directedObjectiveSumSemanticStateAt, + Function.iterate_succ_apply'] + exact directedObjectiveSumSemanticStep_valueInvariant tau A y p _ ih + +theorem rawDirectedNegativeObjectiveSum_value {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + (rawDirectedNegativeObjectiveSum tau A y p).value = + directedNegativeObjectiveLower tau A (betheAffineMatrixQ y) p := by + have hinvariant := directedObjectiveSumSemanticStateAt_valueInvariant + tau A y p ((m + 1) * (m + 1)) + rcases hinvariant with hdone | hactive + Β· exact hdone.2.2 + Β· have hord := hactive.2.1 + have hlt := betheFloorScanOrdinal_lt_square + (directedObjectiveSumSemanticStateAt tau A y p + ((m + 1) * (m + 1))).row + (directedObjectiveSumSemanticStateAt tau A y p + ((m + 1) * (m + 1))).column + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedTransferCost.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedTransferCost.lean new file mode 100644 index 0000000000..ff059a6bc5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDirectedTransferCost.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowComplementUpperSum + +/-! +# One directed transfer-cost endpoint as a finite-word function + +The input is `pair rowUnary (pair columnUnary optimizerWord)`. The output is +the unreduced rational endpoint `directedTransferCostUpper` at the fixed +certificate precision and regularization scale. The only row traversal is +the separately verified complement-log upper sum. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary row ruler from a directed transfer-cost request. -/ +def machineTransferRowRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the transfer-cost payload following its row ruler. -/ +def machineTransferRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary column ruler from a directed transfer-cost request. -/ +def machineTransferColumnRuler (word : List Bool) : List Bool := + machinePairFirst (machineTransferRest word) + +/-- Extracts the optimizer input following the requested transfer row and column. -/ +def machineTransferOptimizerWord (word : List Bool) : List Bool := + machinePairSecond (machineTransferRest word) + +/-- Reads the encoded matrix from the optimizer input of a transfer-cost request. -/ +def machineTransferMatrixWord (word : List Bool) : List Bool := + machineOptimizerMatrixWord (machineTransferOptimizerWord word) + +/-- Looks up the encoded matrix coefficient at the transfer request's row and column. -/ +def machineTransferEntryCode (word : List Bool) : List Bool := + machineMatrixEntryAtUnary + (pair (machineTransferRowRuler word) + (pair (machineTransferColumnRuler word) + (machineTransferMatrixWord word))) + +/-- Packages the certificate precision, zero reference value, and selected coefficient for +complement evaluation. -/ +def machineTransferComplementInput (word : List Bool) : List Bool := + pair (machineCertificateLogPrecisionRuler + (machineTransferOptimizerWord word)) + (pair (rawRatBinaryCode RawRat.zero) (machineTransferEntryCode word)) + +/-- Computes the encoded complement of the selected transfer coefficient through the +nearby-coordinate complement machine. -/ +def machineTransferComplementCode (word : List Bool) : List Bool := + machineNearbyCoordinateComplementCode (machineTransferComplementInput word) + +/-- Computes the raw scheduled lower logarithm approximation of the selected transfer +coefficient at certificate precision. -/ +def machineTransferLogXRawCode (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (pair (machineCertificateLogPrecisionRuler + (machineTransferOptimizerWord word)) + (machineTransferEntryCode word)) + +/-- Computes the raw scheduled lower logarithm approximation of the selected coefficient's +complement at certificate precision. -/ +def machineTransferLogComplementRawCode (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (pair (machineCertificateLogPrecisionRuler + (machineTransferOptimizerWord word)) + (machineTransferComplementCode word)) + +/-- Computes the raw code for one plus the certificate regularization scale. -/ +def machineTransferOnePlusTauRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair rawRatOneCode + (machineCertificateRegularizationScaleRawCode + (machineTransferOptimizerWord word))) + +/-- Multiplies the lower logarithm approximation of the selected coefficient by one plus the +regularization scale. -/ +def machineTransferWeightedLogXRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineTransferOnePlusTauRawCode word) + (machineTransferLogXRawCode word)) + +/-- Adds the negated weighted coefficient logarithm and negated complement logarithm for the +distinguished transfer entry. -/ +def machineTransferNegativeDistinguishedRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineRawRatNegCode (machineTransferWeightedLogXRawCode word)) + (machineRawRatNegCode (machineTransferLogComplementRawCode word))) + +/-- Computes the directed upper sum of complement terms along the selected matrix row. -/ +def machineTransferRowUpperRawCode (word : List Bool) : List Bool := + machineRowComplementUpperSumRawCode + (pair (machineTransferRowRuler word) + (machineTransferOptimizerWord word)) + +/-- Unreduced raw-rational code for one directed transfer cost. -/ +def machineDirectedTransferCostUpperRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineTransferNegativeDistinguishedRawCode word) + (machineTransferRowUpperRawCode word)) + +theorem machineTransferRowRuler_mem_FP : machineTransferRowRuler ∈ FP := + machinePairFirst_mem_FP + +theorem machineTransferRest_mem_FP : machineTransferRest ∈ FP := + machinePairSecond_mem_FP + +theorem machineTransferColumnRuler_mem_FP : + machineTransferColumnRuler ∈ FP := by + simpa only [machineTransferColumnRuler] using! machineCompose_mem_FP + machineTransferRest_mem_FP machinePairFirst_mem_FP + +theorem machineTransferOptimizerWord_mem_FP : + machineTransferOptimizerWord ∈ FP := by + simpa only [machineTransferOptimizerWord] using! machineCompose_mem_FP + machineTransferRest_mem_FP machinePairSecond_mem_FP + +theorem machineTransferMatrixWord_mem_FP : machineTransferMatrixWord ∈ FP := by + simpa only [machineTransferMatrixWord] using! machineCompose_mem_FP + machineTransferOptimizerWord_mem_FP machineOptimizerMatrixWord_mem_FP + +theorem machineTransferEntryCode_mem_FP : machineTransferEntryCode ∈ FP := by + have hinput := machinePair_mem_FP machineTransferRowRuler_mem_FP + (machinePair_mem_FP machineTransferColumnRuler_mem_FP + machineTransferMatrixWord_mem_FP) + simpa only [machineTransferEntryCode] using! machineCompose_mem_FP hinput + machineMatrixEntryAtUnary_mem_FP + +theorem machineTransferComplementInput_mem_FP : + machineTransferComplementInput ∈ FP := by + have hp := machineCompose_mem_FP machineTransferOptimizerWord_mem_FP + machineCertificateLogPrecisionRuler_mem_FP + exact machinePair_mem_FP hp + (machinePair_mem_FP (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineTransferEntryCode_mem_FP) + +theorem machineTransferComplementCode_mem_FP : + machineTransferComplementCode ∈ FP := by + simpa only [machineTransferComplementCode] using! machineCompose_mem_FP + machineTransferComplementInput_mem_FP + machineNearbyCoordinateComplementCode_mem_FP + +theorem machineTransferLogXRawCode_mem_FP : + machineTransferLogXRawCode ∈ FP := by + have hp := machineCompose_mem_FP machineTransferOptimizerWord_mem_FP + machineCertificateLogPrecisionRuler_mem_FP + have hinput := machinePair_mem_FP hp machineTransferEntryCode_mem_FP + simpa only [machineTransferLogXRawCode] using! machineCompose_mem_FP hinput + machineScheduledLogLowerRawCode_mem_FP + +theorem machineTransferLogComplementRawCode_mem_FP : + machineTransferLogComplementRawCode ∈ FP := by + have hp := machineCompose_mem_FP machineTransferOptimizerWord_mem_FP + machineCertificateLogPrecisionRuler_mem_FP + have hinput := machinePair_mem_FP hp machineTransferComplementCode_mem_FP + simpa only [machineTransferLogComplementRawCode] using! + machineCompose_mem_FP hinput machineScheduledLogLowerRawCode_mem_FP + +theorem machineTransferOnePlusTauRawCode_mem_FP : + machineTransferOnePlusTauRawCode ∈ FP := by + have htau := machineCompose_mem_FP machineTransferOptimizerWord_mem_FP + machineCertificateRegularizationScaleRawCode_mem_FP + have hinput := machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) htau + simpa only [machineTransferOnePlusTauRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineTransferWeightedLogXRawCode_mem_FP : + machineTransferWeightedLogXRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineTransferOnePlusTauRawCode_mem_FP + machineTransferLogXRawCode_mem_FP + simpa only [machineTransferWeightedLogXRawCode] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineTransferNegativeDistinguishedRawCode_mem_FP : + machineTransferNegativeDistinguishedRawCode ∈ FP := by + have hfirst := machineCompose_mem_FP + machineTransferWeightedLogXRawCode_mem_FP machineRawRatNegCode_mem_FP + have hsecond := machineCompose_mem_FP + machineTransferLogComplementRawCode_mem_FP machineRawRatNegCode_mem_FP + have hinput := machinePair_mem_FP hfirst hsecond + simpa only [machineTransferNegativeDistinguishedRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineTransferRowUpperRawCode_mem_FP : + machineTransferRowUpperRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineTransferRowRuler_mem_FP + machineTransferOptimizerWord_mem_FP + simpa only [machineTransferRowUpperRawCode] using! machineCompose_mem_FP hinput + machineRowComplementUpperSumRawCode_mem_FP + +theorem machineDirectedTransferCostUpperRawCode_mem_FP : + machineDirectedTransferCostUpperRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineTransferNegativeDistinguishedRawCode_mem_FP + machineTransferRowUpperRawCode_mem_FP + simpa only [machineDirectedTransferCostUpperRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +/-- Forms the raw upper transfer-cost expression from the negated distinguished logarithm terms +and the directed upper complement sum over row `i`. -/ +def rawDirectedTransferCostUpper {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : RawRat := + let p := directedCertificatePrecision n + let tau := rawCertificateRegularizationScale n + let x := X i j + (((RawRat.one.add tau).mul (rawScheduledLogLower x p)).neg.add + (rawScheduledLogLower (1 - x) p).neg).add + (rawRowComplementUpperSum p RawRat.zero (List.ofFn (X i))) + +@[simp] theorem machineTransferEntryCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferEntryCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rationalEntryBinaryCode (X i j) := by + simp [machineTransferEntryCode, machineTransferRowRuler, + machineTransferColumnRuler, machineTransferRest, + machineTransferMatrixWord, machineTransferOptimizerWord] + +@[simp] theorem machineTransferComplementCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferComplementCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode (rawRatOfRat (1 - X i j)) := by + rw [machineTransferComplementCode, machineTransferComplementInput] + simp only [machineTransferOptimizerWord, machineTransferRest, + machinePairSecond_pair, machineCertificateLogPrecisionRuler_encode, + machineTransferEntryCode_encode, + machineNearbyCoordinateComplementCode_encode] + +@[simp] theorem machineTransferLogXRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferLogXRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode + (rawScheduledLogLower (X i j) (directedCertificatePrecision n)) := by + rw [machineTransferLogXRawCode] + simp only [machineTransferOptimizerWord, machineTransferRest, + machinePairSecond_pair, machineCertificateLogPrecisionRuler_encode, + machineTransferEntryCode_encode, ← rawRatBinaryCode_rawRatOfRat, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineTransferLogComplementRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferLogComplementRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode + (rawScheduledLogLower (1 - X i j) + (directedCertificatePrecision n)) := by + rw [machineTransferLogComplementRawCode] + simp only [machineTransferOptimizerWord, machineTransferRest, + machinePairSecond_pair, machineCertificateLogPrecisionRuler_encode, + machineTransferComplementCode_encode, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineTransferOnePlusTauRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferOnePlusTauRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode + (RawRat.one.add (rawCertificateRegularizationScale n)) := by + rw [machineTransferOnePlusTauRawCode] + simp only [machineTransferOptimizerWord, machineTransferRest, + machinePairSecond_pair, + machineCertificateRegularizationScaleRawCode_encode, rawRatOneCode, + machineRawRatAddCode_encode] + +@[simp] theorem machineTransferRowUpperRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineTransferRowUpperRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode + (rawRowComplementUpperSum (directedCertificatePrecision n) + RawRat.zero (List.ofFn (X i))) := by + simp [machineTransferRowUpperRawCode, machineTransferRowRuler, + machineTransferOptimizerWord, machineTransferRest] + +@[simp] theorem machineDirectedTransferCostUpperRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i j : Fin n) : + machineDirectedTransferCostUpperRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩))) = + rawRatBinaryCode (rawDirectedTransferCostUpper X i j) := by + rw [machineDirectedTransferCostUpperRawCode, + machineTransferNegativeDistinguishedRawCode, + machineTransferWeightedLogXRawCode, + machineTransferOnePlusTauRawCode_encode, + machineTransferLogXRawCode_encode, machineRawRatMulCode_encode, + machineRawRatNegCode_encode, + machineTransferLogComplementRawCode_encode, + machineRawRatNegCode_encode, machineRawRatAddCode_encode, + machineTransferRowUpperRawCode_encode, machineRawRatAddCode_encode] + rfl + +theorem rawDirectedTransferCostUpper_value {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : + (rawDirectedTransferCostUpper X i j).value = + directedTransferCostUpper (explicitRegularizationScale n) X i j + (directedCertificatePrecision n) := by + rw [rawDirectedTransferCostUpper, directedTransferCostUpper, + RawRat.value_add, RawRat.value_add, RawRat.value_neg, + RawRat.value_neg, RawRat.value_mul, RawRat.value_add, + RawRat.value_one, rawCertificateRegularizationScale_value, + rawScheduledLogLower_value, rawScheduledLogLower_value, + rawRowComplementUpperSum_matrix_value] + ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloor.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloor.lean new file mode 100644 index 0000000000..eee2f534f3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloor.lean @@ -0,0 +1,426 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BinaryRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic + +/-! +# Polynomial-time dyadic floor + +The precision is represented by a unary ruler: its value is the ruler's +length. This is essential for an honest `FP` statement, since a dyadic output +with denominator `2^p` has `p + 1` denominator bits. The machine shifts the +absolute numerator by the ruler length, performs verified long division, and +implements Euclidean flooring explicitly for negative inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary precision ruler from a dyadic-rounding request. -/ +def machineDyadicPrecisionRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the raw rational code from a dyadic-rounding request. -/ +def machineDyadicRawCode (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the signed numerator code from the raw rational payload of a dyadic-rounding +request. -/ +def machineDyadicNumeratorCode (word : List Bool) : List Bool := + machinePairFirst (machineDyadicRawCode word) + +/-- Extracts the denominator bits from the raw rational payload of a dyadic-rounding request. -/ +def machineDyadicDenominatorBits (word : List Bool) : List Bool := + machinePairSecond (machineDyadicRawCode word) + +/-- Reads the sign bit of the encoded numerator in a dyadic-rounding request. -/ +def machineDyadicNumeratorSign (word : List Bool) : List Bool := + machineHeadBit (machineDyadicNumeratorCode word) + +/-- Computes the binary absolute value of the numerator in a dyadic-rounding request. -/ +def machineDyadicNumeratorAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machineDyadicNumeratorCode word) + +/-- Builds a zero-bit word whose length equals the requested unary precision. -/ +def machineDyadicPrecisionZeroBits (word : List Bool) : List Bool := + List.replicate (machineDyadicPrecisionRuler word).length false + +/-- Scales the numerator magnitude by the requested power of two using leading low-order zero +bits, preserving the empty zero encoding. -/ +def machineDyadicScaledAbsBits (word : List Bool) : List Bool := + machineIfEmpty (machineDyadicNumeratorAbsBits word) [] + (machineDyadicPrecisionZeroBits word ++ + machineDyadicNumeratorAbsBits word) + +/-- Divides the scaled numerator magnitude by the denominator and returns the encoded +quotient-remainder pair. -/ +def machineDyadicDivModBits (word : List Bool) : List Bool := + machineBinaryDivModBits + (pair (machineDyadicScaledAbsBits word) + (machineDyadicDenominatorBits word)) + +/-- Extracts the binary quotient from scaled numerator division. -/ +def machineDyadicQuotientBits (word : List Bool) : List Bool := + machinePairFirst (machineDyadicDivModBits word) + +/-- Extracts the binary remainder from scaled numerator division. -/ +def machineDyadicRemainderBits (word : List Bool) : List Bool := + machinePairSecond (machineDyadicDivModBits word) + +/-- Adds one to the binary quotient from scaled numerator division. -/ +def machineDyadicQuotientSuccBits (word : List Bool) : List Bool := + machineBinaryAddBits (pair (machineDyadicQuotientBits word) [true]) + +/-- Uses the quotient magnitude for exact negative division and its successor when a nonzero +remainder requires rounding downward. -/ +def machineDyadicNegativeFloorAbsBits (word : List Bool) : List Bool := + machineIfEmpty (machineDyadicRemainderBits word) + (machineDyadicQuotientBits word) + (machineDyadicQuotientSuccBits word) + +/-- Selects the adjusted negative magnitude or ordinary quotient according to the numerator +sign. -/ +def machineDyadicFloorAbsBits (word : List Bool) : List Bool := + machineIfHead (machineDyadicNumeratorSign word) + (machineDyadicNegativeFloorAbsBits word) + (machineDyadicQuotientBits word) + +/-- Combines the original numerator sign and the selected floor magnitude into a canonical +integer code. -/ +def machineDyadicFloorIntegerCode (word : List Bool) : List Bool := + machineCanonicalIntegerFromSignedAbs + (pair (machineDyadicNumeratorSign word) + (machineDyadicFloorAbsBits word)) + +/-- Encodes the denominator `2^p` as `p` low-order zero bits followed by one. -/ +def machineDyadicPowerDenominatorBits (word : List Bool) : List Bool := + machineDyadicPrecisionZeroBits word ++ [true] + +/-- Unreduced dyadic-floor output, with denominator `2^p`. -/ +def machineRawDyadicFloorCode (word : List Bool) : List Bool := + pair (machineDyadicFloorIntegerCode word) + (machineDyadicPowerDenominatorBits word) + +/-- Canonical public rational encoding of the dyadic floor. -/ +def machineDyadicFloorCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawDyadicFloorCode word) + +theorem machineDyadicPrecisionRuler_mem_FP : + machineDyadicPrecisionRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineDyadicRawCode_mem_FP : + machineDyadicRawCode ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineDyadicNumeratorCode_mem_FP : + machineDyadicNumeratorCode ∈ Complexity.FP := by + simpa only [machineDyadicNumeratorCode] using! + machineCompose_mem_FP machineDyadicRawCode_mem_FP machinePairFirst_mem_FP + +theorem machineDyadicDenominatorBits_mem_FP : + machineDyadicDenominatorBits ∈ Complexity.FP := by + simpa only [machineDyadicDenominatorBits] using! + machineCompose_mem_FP machineDyadicRawCode_mem_FP machinePairSecond_mem_FP + +theorem machineDyadicNumeratorSign_mem_FP : + machineDyadicNumeratorSign ∈ Complexity.FP := by + simpa only [machineDyadicNumeratorSign] using! + machineCompose_mem_FP machineDyadicNumeratorCode_mem_FP + machineHeadBit_mem_FP + +theorem machineDyadicNumeratorAbsBits_mem_FP : + machineDyadicNumeratorAbsBits ∈ Complexity.FP := by + simpa only [machineDyadicNumeratorAbsBits] using! + machineCompose_mem_FP machineDyadicNumeratorCode_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineDyadicPrecisionZeroBits_mem_FP : + machineDyadicPrecisionZeroBits ∈ Complexity.FP := by + simpa only [machineDyadicPrecisionZeroBits, + machineDyadicPrecisionRuler] using! + machineCompose_mem_FP machinePairFirst_mem_FP machineZeroBlock_mem_FP + +theorem machineDyadicScaledAbsBits_mem_FP : + machineDyadicScaledAbsBits ∈ Complexity.FP := by + have happend := machineAppend_mem_FP machineDyadicPrecisionZeroBits_mem_FP + machineDyadicNumeratorAbsBits_mem_FP + exact machineIfEmpty_mem_FP machineDyadicNumeratorAbsBits_mem_FP + (machineConst_mem_FP []) happend + +theorem machineDyadicDivModBits_mem_FP : + machineDyadicDivModBits ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDyadicScaledAbsBits_mem_FP + machineDyadicDenominatorBits_mem_FP + simpa only [machineDyadicDivModBits] using! + machineCompose_mem_FP hpair machineBinaryDivModBits_mem_FP + +theorem machineDyadicQuotientBits_mem_FP : + machineDyadicQuotientBits ∈ Complexity.FP := by + simpa only [machineDyadicQuotientBits] using! + machineCompose_mem_FP machineDyadicDivModBits_mem_FP + machinePairFirst_mem_FP + +theorem machineDyadicRemainderBits_mem_FP : + machineDyadicRemainderBits ∈ Complexity.FP := by + simpa only [machineDyadicRemainderBits] using! + machineCompose_mem_FP machineDyadicDivModBits_mem_FP + machinePairSecond_mem_FP + +theorem machineDyadicQuotientSuccBits_mem_FP : + machineDyadicQuotientSuccBits ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDyadicQuotientBits_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineDyadicQuotientSuccBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineDyadicNegativeFloorAbsBits_mem_FP : + machineDyadicNegativeFloorAbsBits ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineDyadicRemainderBits_mem_FP + machineDyadicQuotientBits_mem_FP machineDyadicQuotientSuccBits_mem_FP + +theorem machineDyadicFloorAbsBits_mem_FP : + machineDyadicFloorAbsBits ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineDyadicNumeratorSign_mem_FP + machineDyadicNegativeFloorAbsBits_mem_FP + machineDyadicQuotientBits_mem_FP + +theorem machineDyadicFloorIntegerCode_mem_FP : + machineDyadicFloorIntegerCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineDyadicNumeratorSign_mem_FP + machineDyadicFloorAbsBits_mem_FP + simpa only [machineDyadicFloorIntegerCode] using! + machineCompose_mem_FP hpair machineCanonicalIntegerFromSignedAbs_mem_FP + +theorem machineDyadicPowerDenominatorBits_mem_FP : + machineDyadicPowerDenominatorBits ∈ Complexity.FP := by + exact machineAppend_mem_FP machineDyadicPrecisionZeroBits_mem_FP + (machineConst_mem_FP [true]) + +theorem machineRawDyadicFloorCode_mem_FP : + machineRawDyadicFloorCode ∈ Complexity.FP := by + exact machinePair_mem_FP machineDyadicFloorIntegerCode_mem_FP + machineDyadicPowerDenominatorBits_mem_FP + +theorem machineDyadicFloorCode_mem_FP : machineDyadicFloorCode ∈ Complexity.FP := by + simpa only [machineDyadicFloorCode] using! + machineCompose_mem_FP machineRawDyadicFloorCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +private theorem natBits_mul_pow_two_of_ne_zero (n p : β„•) (hn : n β‰  0) : + (n * 2 ^ p).bits = List.replicate p false ++ n.bits := by + induction p with + | zero => simp + | succ p ih => + have hproduct : n * 2 ^ p β‰  0 := mul_ne_zero hn (pow_ne_zero _ (by decide)) + have hrearrange : n * 2 ^ (p + 1) = 2 * (n * 2 ^ p) := by ring + rw [hrearrange, Nat.bit0_bits _ hproduct, ih] + simp [List.replicate_succ] + +private theorem shiftedNatBits (n p : β„•) : + (if n.bits = [] then [] else List.replicate p false ++ n.bits) = + (n * 2 ^ p).bits := by + by_cases hn : n = 0 + Β· subst n + simp + Β· rw [ite_eq_right (natBits_ne_nil_of_ne_zero hn), + natBits_mul_pow_two_of_ne_zero n p hn] + +/-- Computes the integer floor of the scaled raw rational using binary long division, increasing +the negative magnitude when the remainder is nonzero. -/ +def binaryRawDyadicFloorInt (p : β„•) (q : RawRat) : β„€ := + let qr := binaryLongDiv (q.num.natAbs * 2 ^ p) q.den + match q.num with + | .ofNat _ => (qr.1 : β„€) + | .negSucc _ => + if qr.2 = 0 then -(qr.1 : β„€) + else -((qr.1 + 1 : β„•) : β„€) + +/-- Pairs the binary-computed floor of `2^p * q` with the positive denominator `2^p`. -/ +def binaryRawDyadicFloor (p : β„•) (q : RawRat) : RawRat := + ⟨binaryRawDyadicFloorInt p q, 2 ^ p, by positivity⟩ + +theorem binaryRawDyadicFloorInt_eq_ediv (p : β„•) (q : RawRat) : + binaryRawDyadicFloorInt p q = + (q.num * (2 ^ p : β„•)) / (q.den : β„€) := by + rw [binaryRawDyadicFloorInt, binaryLongDiv_eq_div_mod] + simp only [Prod.fst, Prod.snd] + cases hnum : q.num with + | ofNat n => + simp [hnum, Int.ediv] + | negSucc n => + have hden : 0 < q.den := q.den_pos + let a := (n + 1) * 2 ^ p + have hrepr : Int.negSucc n * (2 ^ p : β„•) = -((a : β„•) : β„€) := by + have hnrepr : Int.negSucc n = -((n + 1 : β„•) : β„€) := by omega + rw [hnrepr] + simp only [a] + push_cast + ring + by_cases hrem : a % q.den = 0 + Β· simp only [hnum, Int.natAbs_negSucc] + change (if a % q.den = 0 then -((a / q.den : β„•) : β„€) + else -(((a / q.den : β„•) + 1 : β„•) : β„€)) = _ + rw [ite_eq_left hrem, hrepr] + have hdvdNat : q.den ∣ a := Nat.dvd_of_mod_eq_zero hrem + have hdvdInt : (q.den : β„€) ∣ (a : β„€) := by + exact_mod_cast hdvdNat + rw [Int.neg_ediv_of_dvd hdvdInt] + norm_num + Β· simp only [hnum, Int.natAbs_negSucc] + change (if a % q.den = 0 then -((a / q.den : β„•) : β„€) + else -(((a / q.den : β„•) + 1 : β„•) : β„€)) = _ + rw [ite_eq_right hrem, hrepr] + have hndvdNat : Β¬ q.den ∣ a := by + rwa [Nat.dvd_iff_mod_eq_zero] + have hndvdInt : Β¬ (q.den : β„€) ∣ (a : β„€) := by + exact_mod_cast hndvdNat + rw [Int.neg_ediv, ite_eq_right hndvdInt, + Int.sign_eq_one_of_pos (by exact_mod_cast hden)] + norm_num [Nat.add_comm] + ring + +theorem binaryRawDyadicFloorInt_eq_floor (p : β„•) (q : RawRat) : + binaryRawDyadicFloorInt p q = Int.floor (q.value * (2 : β„š) ^ p) := by + rw [binaryRawDyadicFloorInt_eq_ediv] + have hvalue : q.value * (2 : β„š) ^ p = + ((q.num * (2 ^ p : β„•) : β„€) : β„š) / (q.den : β„š) := by + rw [RawRat.value] + push_cast + ring + rw [hvalue, Rat.floor_intCast_div_natCast] + +theorem binaryRawDyadicFloor_value (p : β„•) (q : RawRat) : + (binaryRawDyadicFloor p q).value = binaryDyadicFloor p q.value := by + simp only [binaryRawDyadicFloor, RawRat.value] + rw [binaryDyadicFloor, binaryRatFloor_eq_floor] + have hfloor := binaryRawDyadicFloorInt_eq_floor p q + simp only [RawRat.value] at hfloor + rw [← hfloor] + norm_num + +theorem machineDyadicScaledAbsBits_encode (p : β„•) (q : RawRat) : + machineDyadicScaledAbsBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + (q.num.natAbs * 2 ^ p).bits := by + simp only [machineDyadicScaledAbsBits, machineDyadicNumeratorAbsBits, + machineDyadicNumeratorCode, machineDyadicRawCode, + machineDyadicPrecisionZeroBits, machineDyadicPrecisionRuler, + machinePairFirst_pair, machinePairSecond_pair, rawRatBinaryCode, + machineIntegerNatAbsBits_encode, List.length_replicate] + cases hbits : q.num.natAbs.bits with + | nil => simpa [hbits] using! shiftedNatBits q.num.natAbs p + | cons bit rest => simpa [hbits] using! shiftedNatBits q.num.natAbs p + +theorem machineDyadicDivModBits_encode (p : β„•) (q : RawRat) : + machineDyadicDivModBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + pair + ((q.num.natAbs * 2 ^ p) / q.den).bits + ((q.num.natAbs * 2 ^ p) % q.den).bits := by + rw [machineDyadicDivModBits, machineDyadicScaledAbsBits_encode] + simp only [machineDyadicDenominatorBits, machineDyadicRawCode, + machinePairSecond_pair, rawRatBinaryCode] + rw [machineBinaryDivModBits_pair_natBits] + +theorem machineDyadicFloorIntegerCode_encode (p : β„•) (q : RawRat) : + machineDyadicFloorIntegerCode + (pair (List.replicate p true) (rawRatBinaryCode q)) = + integerBinaryCode (binaryRawDyadicFloorInt p q) := by + have hsign : machineDyadicNumeratorSign + (pair (List.replicate p true) (rawRatBinaryCode q)) = + match q.num with + | .ofNat _ => [false] + | .negSucc _ => [true] := by + simp only [machineDyadicNumeratorSign, machineDyadicNumeratorCode, + machineDyadicRawCode, machinePairFirst_pair, machinePairSecond_pair, + rawRatBinaryCode] + cases q.num <;> simp [integerBinaryCode] + have hquot : machineDyadicQuotientBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + ((q.num.natAbs * 2 ^ p) / q.den).bits := by + rw [machineDyadicQuotientBits, machineDyadicDivModBits_encode] + simp only [machinePairFirst_pair] + have hrembits : machineDyadicRemainderBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + ((q.num.natAbs * 2 ^ p) % q.den).bits := by + rw [machineDyadicRemainderBits, machineDyadicDivModBits_encode] + simp only [machinePairSecond_pair] + have hsucc : machineDyadicQuotientSuccBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + (((q.num.natAbs * 2 ^ p) / q.den) + 1).bits := by + rw [machineDyadicQuotientSuccBits, hquot] + simpa using! machineBinaryAddBits_pair_natBits + ((q.num.natAbs * 2 ^ p) / q.den) 1 + rw [machineDyadicFloorIntegerCode] + cases hnum : q.num with + | ofNat n => + have hsignFalse : machineDyadicNumeratorSign + (pair (List.replicate p true) (rawRatBinaryCode q)) = [false] := by + simpa [hnum] using! hsign + simp only [machineDyadicFloorAbsBits, hsignFalse, + machineIfHead_false, hquot] + rw [machineCanonicalIntegerFromSignedAbs_pair] + simp [binaryRawDyadicFloorInt, hnum, binaryLongDiv_eq_div_mod, + signedMagnitudeValue] + | negSucc n => + have hsignTrue : machineDyadicNumeratorSign + (pair (List.replicate p true) (rawRatBinaryCode q)) = [true] := by + simpa [hnum] using! hsign + simp only [machineDyadicFloorAbsBits, hsignTrue, machineIfHead_true, + machineDyadicNegativeFloorAbsBits, hrembits, hquot, hsucc, + hnum, Int.natAbs_negSucc] + by_cases hrem : (n + 1) * 2 ^ p % q.den = 0 + Β· rw [show ((n + 1) * 2 ^ p % q.den).bits = [] by simp [hrem]] + simp only [machineIfEmpty_nil] + rw [machineCanonicalIntegerFromSignedAbs_pair] + simp [binaryRawDyadicFloorInt, hnum, binaryLongDiv_eq_div_mod, + hrem, signedMagnitudeValue] + Β· rw [machineIfEmpty_of_ne_nil + (((n + 1) * 2 ^ p % q.den).bits) + (((n + 1) * 2 ^ p / q.den).bits) + ((((n + 1) * 2 ^ p / q.den) + 1).bits) + (natBits_ne_nil_of_ne_zero hrem)] + rw [machineCanonicalIntegerFromSignedAbs_pair] + simp [binaryRawDyadicFloorInt, hnum, binaryLongDiv_eq_div_mod, + hrem, signedMagnitudeValue] + +theorem machineDyadicPowerDenominatorBits_encode (p : β„•) (q : RawRat) : + machineDyadicPowerDenominatorBits + (pair (List.replicate p true) (rawRatBinaryCode q)) = + (2 ^ p).bits := by + simp [machineDyadicPowerDenominatorBits, + machineDyadicPrecisionZeroBits, machineDyadicPrecisionRuler, + show List.replicate p false ++ [true] = (2 ^ p).bits by + simpa using! (natBits_mul_pow_two_of_ne_zero 1 p (by decide)).symm] + +theorem machineRawDyadicFloorCode_encode (p : β„•) (q : RawRat) : + machineRawDyadicFloorCode + (pair (List.replicate p true) (rawRatBinaryCode q)) = + rawRatBinaryCode (binaryRawDyadicFloor p q) := by + rw [machineRawDyadicFloorCode, machineDyadicFloorIntegerCode_encode, + machineDyadicPowerDenominatorBits_encode] + rfl + +theorem machineDyadicFloorCode_encode (p : β„•) (q : RawRat) : + machineDyadicFloorCode + (pair (List.replicate p true) (rawRatBinaryCode q)) = + rationalBinaryCode (binaryNormalizeRawRat (binaryRawDyadicFloor p q)) := by + rw [machineDyadicFloorCode, machineRawDyadicFloorCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +theorem machineDyadicFloorCode_binaryDyadicFloor (p : β„•) (q : RawRat) : + machineDyadicFloorCode + (pair (List.replicate p true) (rawRatBinaryCode q)) = + rationalBinaryCode (binaryDyadicFloor p q.value) := by + rw [machineDyadicFloorCode_encode, + binaryNormalizeRawRat_eq_value, binaryRawDyadicFloor_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorMatrix.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorMatrix.lean new file mode 100644 index 0000000000..61687e7e98 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorMatrix.lean @@ -0,0 +1,589 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorVector + +/-! +# Polynomial-time coordinatewise matrix dyadic floor + +The outer scan maps the verified vector-floor machine over the encoded rows +of a square rational matrix. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes unary precision `p` followed by the rows of the rational square matrix to round. -/ +def dyadicFloorMatrixCanonicalWord {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : List Bool := + pair (List.replicate p true) (rationalSquareMatrixRowsCode A) + +theorem dyadicFloorMatrix_entry_code_length_le {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : + (rationalEntryBinaryCode (dyadicFloorMatrix p A i j)).length ≀ + 100 + 72 * (dyadicFloorMatrixCanonicalWord p A).length := by + let word := dyadicFloorMatrixCanonicalWord p A + let q := rawRatOfRat (A i j) + have hq0 := rawRatWidth_le_binaryCode_length q + rw [rawRatBinaryCode_rawRatOfRat] at hq0 + let row := List.ofFn fun k : Fin d ↦ A i k + have hentry := binaryListCode_element_length_le rationalEntryBinaryCode + (show A i j ∈ row by simp [row]) + have hrow := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) + (show row ∈ rationalMatrixRows A by + simp [rationalMatrixRows, row]) + have hq : rawRatWidth q ≀ word.length := by + apply hq0.trans + apply hentry.trans + apply hrow.trans + simp only [word, dyadicFloorMatrixCanonicalWord, + rationalSquareMatrixRowsCode, pair_length, List.length_replicate] + omega + have hp : p ≀ word.length := by + simp only [word, dyadicFloorMatrixCanonicalWord, pair_length, + List.length_replicate] + omega + have hraw := binaryRawDyadicFloor_width_le p q + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (binaryRawDyadicFloor p q) + rw [binaryNormalizeRawRat_eq_value, binaryRawDyadicFloor_value, + binaryDyadicFloor_eq_dyadicFloor, rawRatOfRat_value] at hcanonical + exact hcanonical.trans (by nlinarith) + +/-- Reuses the rational transpose-vector input bound to bound the dyadic matrix scan. -/ +def machineDyadicFloorMatrixInputBound (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineDyadicFloorMatrixInputBound_mem_FP : + machineDyadicFloorMatrixInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem dyadicFloorMatrix_code_length_le_cubic {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + (rationalSquareMatrixRowsCode (dyadicFloorMatrix p A)).length ≀ + d * (2 * (d * + (2 * (100 + 72 * (dyadicFloorMatrixCanonicalWord p A).length) + + 2)) + 2) := by + let L := 100 + 72 * (dyadicFloorMatrixCanonicalWord p A).length + have hentry : βˆ€ i j : Fin d, + (rationalEntryBinaryCode (dyadicFloorMatrix p A i j)).length ≀ L := by + intro i j + exact dyadicFloorMatrix_entry_code_length_le p A i j + rw [rationalSquareMatrixRowsCode, binaryListCode_length_eq_sum] + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply] + calc + (βˆ‘ i : Fin d, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ dyadicFloorMatrix p A i j)).length + 2)) ≀ + βˆ‘ _i : Fin d, (2 * (d * (2 * L + 2)) + 2) := by + apply Finset.sum_le_sum + intro i _ + gcongr + rw [binaryListCode_length_eq_sum] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + calc + (βˆ‘ j : Fin d, + (2 * (rationalEntryBinaryCode + (dyadicFloorMatrix p A i j)).length + 2)) ≀ + βˆ‘ _j : Fin d, (2 * L + 2) := by + apply Finset.sum_le_sum + intro j _ + have h := hentry i j + omega + _ = d * (2 * L + 2) := by simp + _ = d * (2 * (d * (2 * L + 2)) + 2) := by simp + +theorem dyadicFloorMatrix_code_length_le_bound {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + (rationalSquareMatrixRowsCode (dyadicFloorMatrix p A)).length ≀ + (machineDyadicFloorMatrixInputBound + (dyadicFloorMatrixCanonicalWord p A)).length := by + let word := dyadicFloorMatrixCanonicalWord p A + let n := word.length + let x := 16 + n + let y := 16 + x ^ 2 + let z := 16 + y ^ 2 + have hd : d ≀ word.length := by + have hrows := binaryListCode_listLength_le + (binaryListCode rationalEntryBinaryCode) (rationalMatrixRows A) + have hmatrix : (rationalSquareMatrixRowsCode A).length ≀ word.length := by + simp only [word, dyadicFloorMatrixCanonicalWord, pair_length, + List.length_replicate] + omega + simpa only [rationalSquareMatrixRowsCode, rationalMatrixRows, + List.length_ofFn] using! hrows.trans hmatrix + have hn2 : 2 ≀ n := by + simp only [n, word, dyadicFloorMatrixCanonicalWord, pair_length, + List.length_replicate] + omega + have hcubic := dyadicFloorMatrix_code_length_le_cubic p A + have hd' : d ≀ n := by simpa only [n] using! hd + have hdd : d * d ≀ n * n := Nat.mul_le_mul hd' hd' + have hddn : (d * d) * n ≀ (n * n) * n := + Nat.mul_le_mul hdd le_rfl + have hpoly : + d * (2 * (d * (2 * (100 + 72 * n) + 2)) + 2) ≀ + 1000 * n ^ 3 := by + nlinarith + have hout : + (rationalSquareMatrixRowsCode (dyadicFloorMatrix p A)).length ≀ + 1000 * n ^ 3 := by + apply hcubic.trans + simpa only [n, word] using! hpoly + have hnx : n ≀ x := by simp [x] + have hxpos : 0 < x := by omega + have h1000 : 1000 ≀ x ^ 3 := by + dsimp only [x] + nlinarith + have hnx3 : n ^ 3 ≀ x ^ 3 := Nat.pow_le_pow_left hnx 3 + have hto6 : 1000 * n ^ 3 ≀ x ^ 6 := by + have h := Nat.mul_le_mul h1000 hnx3 + simpa only [← pow_add] using! h + have hto8 : x ^ 6 ≀ x ^ 8 := + Nat.pow_le_pow_right hxpos (by omega) + have hxy : x ^ 2 ≀ y := by simp [y] + have hx4y2 : x ^ 4 ≀ y ^ 2 := by + have h := Nat.pow_le_pow_left hxy 2 + simpa only [← pow_mul] using! h + have hyz : y ^ 2 ≀ z := by simp [z] + have hx4z : x ^ 4 ≀ z := hx4y2.trans hyz + have hx8z2 : x ^ 8 ≀ z ^ 2 := by + have h := Nat.pow_le_pow_left hx4z 2 + simpa only [← pow_mul] using! h + apply hout.trans + apply hto6.trans + apply hto8.trans + apply hx8z2.trans_eq + simp only [machineDyadicFloorMatrixInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, n, x, y, z, word, pow_two] + +/-! ## Bounded outer row scan -/ + +/-- Extracts the unary rounding precision from a dyadic matrix request. -/ +def machineDyadicFloorMatrixPrecision (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded matrix rows from a dyadic matrix request. -/ +def machineDyadicFloorMatrixRows (word : List Bool) : List Bool := + machinePairSecond word + +/-- Rounds every entry of the next unprocessed matrix row using the precision stored in the scan +payload. -/ +def machineDyadicFloorMatrixCurrentRow (state : List Bool) : List Bool := + machineDyadicFloorVectorCode + (pair (machineRationalTransposeMulVectorStatePayload state) + (machineListHead + (machineRationalTransposeMulVectorRemaining state))) + +/-- Prepends the newly rounded row to the encoded reverse-order accumulator. -/ +def machineDyadicFloorMatrixCandidate (state : List Bool) : List Bool := + pair (machineDyadicFloorMatrixCurrentRow state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate row accumulator to the length of the scan bound word. -/ +def machineDyadicFloorMatrixNextAccumulator + (state : List Bool) : List Bool := + (machineDyadicFloorMatrixCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Drops the processed matrix row and stores the bounded updated accumulator while preserving +precision and bound. -/ +def machineDyadicFloorMatrixAdvance (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineDyadicFloorMatrixNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Fixes a matrix scan with no remaining rows and otherwise processes its next row. -/ +def machineDyadicFloorMatrixStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineDyadicFloorMatrixAdvance state) + +/-- Initializes the matrix scan with all input rows, an empty accumulator, the requested +precision, and its input bound. -/ +def machineDyadicFloorMatrixInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineDyadicFloorMatrixRows word) [] + (machineDyadicFloorMatrixPrecision word) + (machineDyadicFloorMatrixInputBound word) + +/-- Packs four copies of the input bound to bound the encoded matrix scan state. -/ +def machineDyadicFloorMatrixWidth (word : List Bool) : List Bool := + let bound := machineDyadicFloorMatrixInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs the dyadic matrix scan for as many steps as there are bits in the input word. -/ +def machineDyadicFloorMatrixFinalState (word : List Bool) : List Bool := + (machineDyadicFloorMatrixStep)^[word.length] + (machineDyadicFloorMatrixInit word) + +/-- Extracts the reversed encoded rounded rows from the final matrix scan state. -/ +def machineDyadicFloorMatrixReversedCode (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineDyadicFloorMatrixFinalState word) + +/-- Reverses the accumulated rounded rows to recover the original matrix row order. -/ +def machineDyadicFloorMatrixCode (word : List Bool) : List Bool := + machineListReverse (machineDyadicFloorMatrixReversedCode word) + +theorem machineDyadicFloorMatrixPrecision_mem_FP : + machineDyadicFloorMatrixPrecision ∈ FP := machinePairFirst_mem_FP + +theorem machineDyadicFloorMatrixRows_mem_FP : + machineDyadicFloorMatrixRows ∈ FP := machinePairSecond_mem_FP + +theorem machineDyadicFloorMatrixCurrentRow_mem_FP : + machineDyadicFloorMatrixCurrentRow ∈ FP := by + have hhead := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListHead_mem_FP + have hinput := machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP hhead + simpa only [machineDyadicFloorMatrixCurrentRow] using! + machineCompose_mem_FP hinput machineDyadicFloorVectorCode_mem_FP + +theorem machineDyadicFloorMatrixCandidate_mem_FP : + machineDyadicFloorMatrixCandidate ∈ FP := + machinePair_mem_FP machineDyadicFloorMatrixCurrentRow_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineDyadicFloorMatrixNextAccumulator_mem_FP : + machineDyadicFloorMatrixNextAccumulator ∈ FP := by + simpa only [machineDyadicFloorMatrixNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineDyadicFloorMatrixCandidate_mem_FP + +theorem machineDyadicFloorMatrixAdvance_mem_FP : + machineDyadicFloorMatrixAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineDyadicFloorMatrixNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineDyadicFloorMatrixStep_mem_FP : + machineDyadicFloorMatrixStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineDyadicFloorMatrixAdvance_mem_FP + +theorem machineDyadicFloorMatrixInit_mem_FP : + machineDyadicFloorMatrixInit ∈ FP := + machinePair_mem_FP machineDyadicFloorMatrixRows_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineDyadicFloorMatrixPrecision_mem_FP + machineDyadicFloorMatrixInputBound_mem_FP)) + +theorem machineDyadicFloorMatrixWidth_mem_FP : + machineDyadicFloorMatrixWidth ∈ FP := by + have hbound := machineDyadicFloorMatrixInputBound_mem_FP + exact machinePair_mem_FP hbound + (machinePair_mem_FP hbound (machinePair_mem_FP hbound hbound)) + +theorem machineDyadicFloorMatrixInit_bound (word : List Bool) : + MachineRationalTransposeMulVectorStateBound word + (machineDyadicFloorMatrixInit word) := by + simp only [MachineRationalTransposeMulVectorStateBound, + machineDyadicFloorMatrixInit, + machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineDyadicFloorMatrixInputBound] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· exact (machinePairSecond_length_le word).trans + (machineRationalTransposeMulVector_word_le_bound word) + Β· exact (machinePairFirst_length_le word).trans + (machineRationalTransposeMulVector_word_le_bound word) + +theorem machineDyadicFloorMatrixStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineDyadicFloorMatrixStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineDyadicFloorMatrixStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineDyadicFloorMatrixStep, hcode, machineIfEmpty_cons, + machineDyadicFloorMatrixAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineDyadicFloorMatrixNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineDyadicFloorMatrixIterate_bound (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineDyadicFloorMatrixStep)^[k] + (machineDyadicFloorMatrixInit word)) := by + intro k + induction k with + | zero => exact machineDyadicFloorMatrixInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineDyadicFloorMatrixStep_bound ih + +theorem machineDyadicFloorMatrixIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineDyadicFloorMatrixStep)^[iterations] + (machineDyadicFloorMatrixInit word)).length ≀ + (machineDyadicFloorMatrixWidth word).length := by + rcases machineDyadicFloorMatrixIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineDyadicFloorMatrixWidth, machineDyadicFloorMatrixInputBound, + pair_length] + omega + +theorem machineDyadicFloorMatrixFinalState_mem_FP : + machineDyadicFloorMatrixFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineDyadicFloorMatrixStep_mem_FP + machineDyadicFloorMatrixInit_mem_FP id_mem_FP + machineDyadicFloorMatrixWidth_mem_FP + machineDyadicFloorMatrixIterate_length_le_width + +theorem machineDyadicFloorMatrixReversedCode_mem_FP : + machineDyadicFloorMatrixReversedCode ∈ FP := by + simpa only [machineDyadicFloorMatrixReversedCode] using! + machineCompose_mem_FP machineDyadicFloorMatrixFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineDyadicFloorMatrixCode_mem_FP : + machineDyadicFloorMatrixCode ∈ FP := by + simpa only [machineDyadicFloorMatrixCode] using! + machineCompose_mem_FP machineDyadicFloorMatrixReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact scan semantics -/ + +/-- Takes the first `k` rational matrix rows and applies dyadic floor at precision `p` to every +entry. -/ +def dyadicFloorMatrixRowsPrefix {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) (k : β„•) : List (List β„š) := + (rationalMatrixRows A).take k |>.map + (List.map (dyadicFloor p)) + +/-- Encodes the remaining matrix rows and reversed rounded prefix after `k` rows, retaining the +canonical precision and input bound. -/ +def machineDyadicFloorMatrixSemanticState {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) (k : β„•) : List Bool := + let word := dyadicFloorMatrixCanonicalWord p A + machineRationalTransposeMulVectorPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + ((rationalMatrixRows A).drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A k).reverse) + (List.replicate p true) (machineDyadicFloorMatrixInputBound word) + +theorem machineDyadicFloorMatrixInit_semantics {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + machineDyadicFloorMatrixInit (dyadicFloorMatrixCanonicalWord p A) = + machineDyadicFloorMatrixSemanticState p A 0 := by + simp [machineDyadicFloorMatrixInit, + machineDyadicFloorMatrixSemanticState, machineDyadicFloorMatrixRows, + machineDyadicFloorMatrixPrecision, dyadicFloorMatrixCanonicalWord, + rationalSquareMatrixRowsCode, dyadicFloorMatrixRowsPrefix, + binaryListCode] + +theorem dyadicFloorMatrixRowsPrefix_succ {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) + (k : β„•) (hk : k < d) : + dyadicFloorMatrixRowsPrefix p A (k + 1) = + dyadicFloorMatrixRowsPrefix p A k ++ + [List.ofFn fun j ↦ dyadicFloor p (A ⟨k, hk⟩ j)] := by + simp only [dyadicFloorMatrixRowsPrefix, List.map_take] + have hkm : k < (rationalMatrixRows A).length := by + simp [rationalMatrixRows, hk] + simpa [rationalMatrixRows, List.map_ofFn] using! + congrArg (List.map (List.map (dyadicFloor p))) + (List.take_concat_get hkm).symm + +theorem machineDyadicFloorMatrixStep_semantics {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) + (k : β„•) (hk : k < d) : + machineDyadicFloorMatrixStep + (machineDyadicFloorMatrixSemanticState p A k) = + machineDyadicFloorMatrixSemanticState p A (k + 1) := by + let word := dyadicFloorMatrixCanonicalWord p A + let row := List.ofFn fun j : Fin d ↦ A ⟨k, hk⟩ j + have hdrop : (rationalMatrixRows A).drop k = + row :: (rationalMatrixRows A).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (rationalMatrixRows A).length by + simp [rationalMatrixRows, hk]) using 1 + simp [rationalMatrixRows, row] + have hprefix := dyadicFloorMatrixRowsPrefix_succ p A k hk + let roundedRow := List.ofFn fun j : Fin d ↦ dyadicFloor p (A ⟨k, hk⟩ j) + have hreverse : (dyadicFloorMatrixRowsPrefix p A (k + 1)).reverse = + roundedRow :: (dyadicFloorMatrixRowsPrefix p A k).reverse := by + rw [hprefix, List.reverse_append] + simp [roundedRow] + have hcand : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A (k + 1)).reverse).length ≀ + (machineDyadicFloorMatrixInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (dyadicFloorMatrix p A)) (k + 1) + have hprefixEq : dyadicFloorMatrixRowsPrefix p A (k + 1) = + (rationalMatrixRows (dyadicFloorMatrix p A)).take (k + 1) := by + apply List.ext_getElem + Β· simp [dyadicFloorMatrixRowsPrefix, rationalMatrixRows] + Β· intro r hrLeft hrRight + simp [dyadicFloorMatrixRowsPrefix, rationalMatrixRows, + List.map_ofFn] + funext j + rfl + rw [hprefixEq] + exact hprefixBound.trans (dyadicFloorMatrix_code_length_le_bound p A) + have hcandPair : + (pair (binaryListCode rationalEntryBinaryCode roundedRow) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A k).reverse)).length ≀ + (machineDyadicFloorMatrixInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode (binaryListCode rationalEntryBinaryCode) + ((rationalMatrixRows A).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil + (binaryListCode rationalEntryBinaryCode) row + ((rationalMatrixRows A).drop (k + 1)) + rw [machineDyadicFloorMatrixStep] + simp only [machineDyadicFloorMatrixSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineDyadicFloorMatrixAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineDyadicFloorMatrixNextAccumulator, + machineDyadicFloorMatrixCandidate, + machineDyadicFloorMatrixCurrentRow] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineDyadicFloorVectorCode + (pair (List.replicate p true) + (binaryListCode rationalEntryBinaryCode row))) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A k).reverse)).take + (machineDyadicFloorMatrixInputBound word).length) _ _ = _ + let rowFn : Fin d β†’ β„š := fun j ↦ A ⟨k, hk⟩ j + change machineRationalTransposeMulVectorPack _ + ((pair (machineDyadicFloorVectorCode + (dyadicFloorVectorCanonicalWord p rowFn)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A k).reverse)).take + (machineDyadicFloorMatrixInputBound word).length) _ _ = _ + rw [machineDyadicFloorVectorCode_encode] + change machineRationalTransposeMulVectorPack _ + ((pair (binaryListCode rationalEntryBinaryCode roundedRow) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (dyadicFloorMatrixRowsPrefix p A k).reverse)).take + (machineDyadicFloorMatrixInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineDyadicFloorMatrixIterate_semantics {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : βˆ€ k ≀ d, + (machineDyadicFloorMatrixStep)^[k] + (machineDyadicFloorMatrixInit + (dyadicFloorMatrixCanonicalWord p A)) = + machineDyadicFloorMatrixSemanticState p A k := by + intro k hk + induction k with + | zero => exact machineDyadicFloorMatrixInit_semantics p A + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineDyadicFloorMatrixStep_semantics p A k (by omega) + +theorem machineDyadicFloorMatrix_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineDyadicFloorMatrixStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineDyadicFloorMatrixStep] + +theorem dyadicFloorMatrixRowsPrefix_all {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + dyadicFloorMatrixRowsPrefix p A d = + rationalMatrixRows (dyadicFloorMatrix p A) := by + apply List.ext_getElem + Β· simp [dyadicFloorMatrixRowsPrefix, rationalMatrixRows] + Β· intro i hiLeft hiRight + simp [dyadicFloorMatrixRowsPrefix, rationalMatrixRows, List.map_ofFn] + funext j + rfl + +theorem machineDyadicFloorMatrixReversedCode_encode {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + machineDyadicFloorMatrixReversedCode + (dyadicFloorMatrixCanonicalWord p A) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (dyadicFloorMatrix p A)).reverse := by + let word := dyadicFloorMatrixCanonicalWord p A + have hd : d ≀ word.length := by + have hrows := binaryListCode_listLength_le + (binaryListCode rationalEntryBinaryCode) (rationalMatrixRows A) + have hmatrix : (rationalSquareMatrixRowsCode A).length ≀ word.length := by + simp only [word, dyadicFloorMatrixCanonicalWord, pair_length, + List.length_replicate] + omega + simpa only [rationalSquareMatrixRowsCode, rationalMatrixRows, + List.length_ofFn] using! hrows.trans hmatrix + have hsplit : word.length = (word.length - d) + d := by omega + change machineDyadicFloorMatrixReversedCode word = _ + rw [machineDyadicFloorMatrixReversedCode, + machineDyadicFloorMatrixFinalState, hsplit, + Function.iterate_add_apply, + machineDyadicFloorMatrixIterate_semantics p A d le_rfl] + simp only [machineDyadicFloorMatrixSemanticState] + rw [show binaryListCode (binaryListCode rationalEntryBinaryCode) + ((rationalMatrixRows A).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp [rationalMatrixRows])] + rfl] + rw [machineDyadicFloorMatrix_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [dyadicFloorMatrixRowsPrefix_all] + +@[simp] theorem machineDyadicFloorMatrixCode_encode {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) : + machineDyadicFloorMatrixCode + (dyadicFloorMatrixCanonicalWord p A) = + rationalSquareMatrixRowsCode (dyadicFloorMatrix p A) := by + rw [machineDyadicFloorMatrixCode, + machineDyadicFloorMatrixReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorVector.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorVector.lean new file mode 100644 index 0000000000..ba13817b68 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineDyadicFloorVector.lean @@ -0,0 +1,559 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidUpdate + +/-! +# Polynomial-time coordinatewise dyadic floor + +The scalar dyadic-floor machine returns the public one-natural rational code. +Ellipsoid memory instead uses the self-delimiting numerator--denominator entry +code. We therefore normalize the same raw result into entry format and map +that exact operation over a bounded encoded vector. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Normalizes the raw dyadic-floor result to obtain the rational entry encoding. -/ +def machineDyadicFloorEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineRawDyadicFloorCode word) + +theorem machineDyadicFloorEntryCode_mem_FP : + machineDyadicFloorEntryCode ∈ FP := by + simpa only [machineDyadicFloorEntryCode] using! + machineCompose_mem_FP machineRawDyadicFloorCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +@[simp] theorem machineDyadicFloorEntryCode_encode + (p : β„•) (q : RawRat) : + machineDyadicFloorEntryCode + (pair (List.replicate p true) (rawRatBinaryCode q)) = + rationalEntryBinaryCode (dyadicFloor p q.value) := by + rw [machineDyadicFloorEntryCode, machineRawDyadicFloorCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, binaryRawDyadicFloor_value, + binaryDyadicFloor_eq_dyadicFloor] + +theorem binaryRawDyadicFloorInt_natAbs_le + (p : β„•) (q : RawRat) : + (binaryRawDyadicFloorInt p q).natAbs ≀ + q.num.natAbs * 2 ^ p + 1 := by + rw [binaryRawDyadicFloorInt, binaryLongDiv_eq_div_mod] + simp only [Prod.fst, Prod.snd] + cases hnum : q.num with + | ofNat n => + simp only [hnum, Int.natAbs_ofNat'] + exact (Nat.div_le_self _ _).trans (by omega) + | negSucc n => + simp only [hnum, Int.natAbs_negSucc] + split + Β· simp only [Int.natAbs_neg] + exact (Nat.div_le_self _ _).trans (by omega) + Β· simp only [Int.natAbs_neg] + have hdiv := Nat.div_le_self ((n + 1) * 2 ^ p) q.den + simpa only [Nat.succ_eq_add_one] using! Nat.add_le_add_right hdiv 1 + +theorem binaryRawDyadicFloor_width_le + (p : β„•) (q : RawRat) : + rawRatWidth (binaryRawDyadicFloor p q) ≀ + rawRatWidth q + p + 1 := by + let w := rawRatWidth q + have hnumLt := rawRat_num_lt_two_pow_width q + have hmulLt : q.num.natAbs * 2 ^ p < 2 ^ (w + p) := by + rw [pow_add] + exact Nat.mul_lt_mul_of_pos_right hnumLt (by positivity) + have hfloor := binaryRawDyadicFloorInt_natAbs_le p q + have hfloorPow : (binaryRawDyadicFloorInt p q).natAbs ≀ + 2 ^ (w + p) := by omega + have hfloorSize := nat_size_le_succ_of_le_two_pow hfloorPow + have hdenSize : (2 ^ p).size = p + 1 := Nat.size_pow + simp only [binaryRawDyadicFloor, rawRatWidth] + rw [hdenSize] + refine max_le (by simpa only [w] using! hfloorSize) ?_ + omega + +/-- Encodes unary precision `p` followed by the rational vector to round. -/ +def dyadicFloorVectorCanonicalWord {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : List Bool := + pair (List.replicate p true) (rationalFiniteVectorCode v) + +theorem dyadicFloorVector_entry_code_length_le {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) (i : Fin d) : + (rationalEntryBinaryCode (dyadicFloor p (v i))).length ≀ + 100 + 72 * (dyadicFloorVectorCanonicalWord p v).length := by + let word := dyadicFloorVectorCanonicalWord p v + let q := rawRatOfRat (v i) + have hq0 := rawRatWidth_le_binaryCode_length q + rw [rawRatBinaryCode_rawRatOfRat] at hq0 + have helem := binaryListCode_element_length_le rationalEntryBinaryCode + (show v i ∈ List.ofFn v by simp) + have hq : rawRatWidth q ≀ word.length := by + have helem' : (rationalEntryBinaryCode (v i)).length ≀ + (rationalFiniteVectorCode v).length := by + simpa only [rationalFiniteVectorCode] using! helem + apply hq0.trans + apply helem'.trans + simp only [word, dyadicFloorVectorCanonicalWord, pair_length, + List.length_replicate] + omega + have hp : p ≀ word.length := by + simp only [word, dyadicFloorVectorCanonicalWord, pair_length, + List.length_replicate] + omega + have hraw := binaryRawDyadicFloor_width_le p q + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (binaryRawDyadicFloor p q) + rw [binaryNormalizeRawRat_eq_value, binaryRawDyadicFloor_value, + binaryDyadicFloor_eq_dyadicFloor, rawRatOfRat_value] at hcanonical + exact hcanonical.trans (by nlinarith) + +/-- Reuses the rational transpose-vector input bound to bound the dyadic vector scan. -/ +def machineDyadicFloorVectorInputBound (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineDyadicFloorVectorInputBound_mem_FP : + machineDyadicFloorVectorInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem dyadicFloorVector_code_length_le_bound {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : + (rationalFiniteVectorCode (dyadicFloorVector p v)).length ≀ + (machineDyadicFloorVectorInputBound + (dyadicFloorVectorCanonicalWord p v)).length := by + let word := dyadicFloorVectorCanonicalWord p v + let L := 100 + 72 * word.length + have hd : d ≀ word.length := by + have hlist := binaryListCode_listLength_le rationalEntryBinaryCode + (List.ofFn v) + have hvector : (rationalFiniteVectorCode v).length ≀ word.length := by + simp only [word, dyadicFloorVectorCanonicalWord, pair_length, + List.length_replicate] + omega + simpa only [rationalFiniteVectorCode, List.length_ofFn] using! + hlist.trans hvector + have heach : βˆ€ q ∈ List.ofFn (dyadicFloorVector p v), + (rationalEntryBinaryCode q).length ≀ L := by + intro q hq + obtain ⟨i, rfl⟩ := List.mem_ofFn.mp hq + exact dyadicFloorVector_entry_code_length_le p v i + have hsum := List.sum_le_card_nsmul + ((List.ofFn (dyadicFloorVector p v)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + (2 * L + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum] + simp only [machineDyadicFloorVectorInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, List.length_map, List.length_ofFn, + Nat.nsmul_eq_mul] at hsum ⊒ + dsimp only [L, word] at hsum hd ⊒ + nlinarith [sq_nonneg (dyadicFloorVectorCanonicalWord p v).length] + +/-! ## Bounded encoded-list scan -/ + +/-- Extracts the unary rounding precision from a dyadic vector request. -/ +def machineDyadicFloorVectorPrecision (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded entries from a dyadic vector request. -/ +def machineDyadicFloorVectorEntries (word : List Bool) : List Bool := + machinePairSecond word + +/-- Rounds the next unprocessed vector entry using the precision stored in the scan payload. -/ +def machineDyadicFloorVectorCurrentEntry + (state : List Bool) : List Bool := + machineDyadicFloorEntryCode + (pair (machineRationalTransposeMulVectorStatePayload state) + (machineListHead + (machineRationalTransposeMulVectorRemaining state))) + +/-- Prepends the newly rounded entry to the encoded reverse-order accumulator. -/ +def machineDyadicFloorVectorCandidate (state : List Bool) : List Bool := + pair (machineDyadicFloorVectorCurrentEntry state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate entry accumulator to the length of the scan bound word. -/ +def machineDyadicFloorVectorNextAccumulator + (state : List Bool) : List Bool := + (machineDyadicFloorVectorCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Drops the processed vector entry and stores the bounded updated accumulator while preserving +precision and bound. -/ +def machineDyadicFloorVectorAdvance (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineDyadicFloorVectorNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Fixes a vector scan with no remaining entries and otherwise processes its next entry. -/ +def machineDyadicFloorVectorStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineDyadicFloorVectorAdvance state) + +/-- Initializes the vector scan with all input entries, an empty accumulator, the requested +precision, and its input bound. -/ +def machineDyadicFloorVectorInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineDyadicFloorVectorEntries word) [] + (machineDyadicFloorVectorPrecision word) + (machineDyadicFloorVectorInputBound word) + +/-- Packs four copies of the input bound to bound the encoded vector scan state. -/ +def machineDyadicFloorVectorWidth (word : List Bool) : List Bool := + let bound := machineDyadicFloorVectorInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs the dyadic vector scan for as many steps as there are bits in the input word. -/ +def machineDyadicFloorVectorFinalState (word : List Bool) : List Bool := + (machineDyadicFloorVectorStep)^[word.length] + (machineDyadicFloorVectorInit word) + +/-- Extracts the reversed encoded rounded entries from the final vector scan state. -/ +def machineDyadicFloorVectorReversedCode (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineDyadicFloorVectorFinalState word) + +/-- Reverses the accumulated rounded entries to recover the original vector order. -/ +def machineDyadicFloorVectorCode (word : List Bool) : List Bool := + machineListReverse (machineDyadicFloorVectorReversedCode word) + +theorem machineDyadicFloorVectorPrecision_mem_FP : + machineDyadicFloorVectorPrecision ∈ FP := machinePairFirst_mem_FP + +theorem machineDyadicFloorVectorEntries_mem_FP : + machineDyadicFloorVectorEntries ∈ FP := machinePairSecond_mem_FP + +theorem machineDyadicFloorVectorCurrentEntry_mem_FP : + machineDyadicFloorVectorCurrentEntry ∈ FP := by + have hhead := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListHead_mem_FP + have hinput := machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP hhead + simpa only [machineDyadicFloorVectorCurrentEntry] using! + machineCompose_mem_FP hinput machineDyadicFloorEntryCode_mem_FP + +theorem machineDyadicFloorVectorCandidate_mem_FP : + machineDyadicFloorVectorCandidate ∈ FP := + machinePair_mem_FP machineDyadicFloorVectorCurrentEntry_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineDyadicFloorVectorNextAccumulator_mem_FP : + machineDyadicFloorVectorNextAccumulator ∈ FP := by + simpa only [machineDyadicFloorVectorNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineDyadicFloorVectorCandidate_mem_FP + +theorem machineDyadicFloorVectorAdvance_mem_FP : + machineDyadicFloorVectorAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineDyadicFloorVectorNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineDyadicFloorVectorStep_mem_FP : + machineDyadicFloorVectorStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineDyadicFloorVectorAdvance_mem_FP + +theorem machineDyadicFloorVectorInit_mem_FP : + machineDyadicFloorVectorInit ∈ FP := + machinePair_mem_FP machineDyadicFloorVectorEntries_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineDyadicFloorVectorPrecision_mem_FP + machineDyadicFloorVectorInputBound_mem_FP)) + +theorem machineDyadicFloorVectorWidth_mem_FP : + machineDyadicFloorVectorWidth ∈ FP := by + have hbound := machineDyadicFloorVectorInputBound_mem_FP + exact machinePair_mem_FP hbound + (machinePair_mem_FP hbound (machinePair_mem_FP hbound hbound)) + +theorem machineDyadicFloorVectorInit_bound (word : List Bool) : + MachineRationalTransposeMulVectorStateBound word + (machineDyadicFloorVectorInit word) := by + simp only [MachineRationalTransposeMulVectorStateBound, + machineDyadicFloorVectorInit, + machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineDyadicFloorVectorInputBound] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· exact (machinePairSecond_length_le word).trans + (machineRationalTransposeMulVector_word_le_bound word) + Β· exact (machinePairFirst_length_le word).trans + (machineRationalTransposeMulVector_word_le_bound word) + +theorem machineDyadicFloorVectorStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineDyadicFloorVectorStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineDyadicFloorVectorStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineDyadicFloorVectorStep, hcode, machineIfEmpty_cons, + machineDyadicFloorVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineDyadicFloorVectorNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineDyadicFloorVectorIterate_bound (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineDyadicFloorVectorStep)^[k] + (machineDyadicFloorVectorInit word)) := by + intro k + induction k with + | zero => exact machineDyadicFloorVectorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineDyadicFloorVectorStep_bound ih + +theorem machineDyadicFloorVectorIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineDyadicFloorVectorStep)^[iterations] + (machineDyadicFloorVectorInit word)).length ≀ + (machineDyadicFloorVectorWidth word).length := by + rcases machineDyadicFloorVectorIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineDyadicFloorVectorWidth, machineDyadicFloorVectorInputBound, + pair_length] + omega + +theorem machineDyadicFloorVectorFinalState_mem_FP : + machineDyadicFloorVectorFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineDyadicFloorVectorStep_mem_FP + machineDyadicFloorVectorInit_mem_FP id_mem_FP + machineDyadicFloorVectorWidth_mem_FP + machineDyadicFloorVectorIterate_length_le_width + +theorem machineDyadicFloorVectorReversedCode_mem_FP : + machineDyadicFloorVectorReversedCode ∈ FP := by + simpa only [machineDyadicFloorVectorReversedCode] using! + machineCompose_mem_FP machineDyadicFloorVectorFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineDyadicFloorVectorCode_mem_FP : + machineDyadicFloorVectorCode ∈ FP := by + simpa only [machineDyadicFloorVectorCode] using! + machineCompose_mem_FP machineDyadicFloorVectorReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact scan semantics -/ + +/-- Takes the first `k` vector entries and applies dyadic floor at precision `p` to each. -/ +def dyadicFloorVectorPrefix {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) (k : β„•) : List β„š := + (List.ofFn v).take k |>.map (dyadicFloor p) + +/-- Encodes the remaining vector entries and reversed rounded prefix after `k` entries, +retaining the canonical precision and input bound. -/ +def machineDyadicFloorVectorSemanticState {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) (k : β„•) : List Bool := + let word := dyadicFloorVectorCanonicalWord p v + machineRationalTransposeMulVectorPack + (binaryListCode rationalEntryBinaryCode ((List.ofFn v).drop k)) + (binaryListCode rationalEntryBinaryCode + (dyadicFloorVectorPrefix p v k).reverse) + (List.replicate p true) (machineDyadicFloorVectorInputBound word) + +theorem machineDyadicFloorVectorInit_semantics {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : + machineDyadicFloorVectorInit (dyadicFloorVectorCanonicalWord p v) = + machineDyadicFloorVectorSemanticState p v 0 := by + simp [machineDyadicFloorVectorInit, + machineDyadicFloorVectorSemanticState, + machineDyadicFloorVectorEntries, + machineDyadicFloorVectorPrecision, + dyadicFloorVectorCanonicalWord, + rationalFiniteVectorCode, dyadicFloorVectorPrefix, binaryListCode] + +theorem dyadicFloorVectorPrefix_succ {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + dyadicFloorVectorPrefix p v (k + 1) = + dyadicFloorVectorPrefix p v k ++ + [dyadicFloor p (v ⟨k, hk⟩)] := by + simp only [dyadicFloorVectorPrefix, List.map_take] + have hkm : k < (List.ofFn v).length := by simpa + simpa using! congrArg (List.map (dyadicFloor p)) + (List.take_concat_get hkm).symm + +theorem machineDyadicFloorVectorStep_semantics {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + machineDyadicFloorVectorStep + (machineDyadicFloorVectorSemanticState p v k) = + machineDyadicFloorVectorSemanticState p v (k + 1) := by + let word := dyadicFloorVectorCanonicalWord p v + let i : Fin d := ⟨k, hk⟩ + have hdrop : (List.ofFn v).drop k = + v i :: (List.ofFn v).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.ofFn v).length by simpa) using 1 + simp [i] + have hprefix := dyadicFloorVectorPrefix_succ p v k hk + have hreverse : (dyadicFloorVectorPrefix p v (k + 1)).reverse = + dyadicFloor p (v i) :: (dyadicFloorVectorPrefix p v k).reverse := by + rw [hprefix, List.reverse_append] + simp [i] + have hcand : + (binaryListCode rationalEntryBinaryCode + (dyadicFloorVectorPrefix p v (k + 1)).reverse).length ≀ + (machineDyadicFloorVectorInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode (List.ofFn (dyadicFloorVector p v)) (k + 1) + have hprefixEq : dyadicFloorVectorPrefix p v (k + 1) = + (List.ofFn (dyadicFloorVector p v)).take (k + 1) := by + rw [dyadicFloorVectorPrefix, List.map_take, List.map_ofFn] + rfl + rw [hprefixEq] + exact hprefixBound.trans (dyadicFloorVector_code_length_le_bound p v) + have hcandPair : + (pair (rationalEntryBinaryCode (dyadicFloor p (v i))) + (binaryListCode rationalEntryBinaryCode + (dyadicFloorVectorPrefix p v k).reverse)).length ≀ + (machineDyadicFloorVectorInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode rationalEntryBinaryCode ((List.ofFn v).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil rationalEntryBinaryCode (v i) + ((List.ofFn v).drop (k + 1)) + rw [machineDyadicFloorVectorStep] + simp only [machineDyadicFloorVectorSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineDyadicFloorVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineDyadicFloorVectorNextAccumulator, + machineDyadicFloorVectorCandidate, + machineDyadicFloorVectorCurrentEntry] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineDyadicFloorEntryCode + (pair (List.replicate p true) + (rationalEntryBinaryCode (v i)))) + (binaryListCode rationalEntryBinaryCode + (dyadicFloorVectorPrefix p v k).reverse)).take + (machineDyadicFloorVectorInputBound word).length) _ _ = _ + rw [← rawRatBinaryCode_rawRatOfRat, + machineDyadicFloorEntryCode_encode, rawRatOfRat_value] + change machineRationalTransposeMulVectorPack _ + ((pair (rationalEntryBinaryCode (dyadicFloor p (v i))) + (binaryListCode rationalEntryBinaryCode + (dyadicFloorVectorPrefix p v k).reverse)).take + (machineDyadicFloorVectorInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineDyadicFloorVectorIterate_semantics {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : βˆ€ k ≀ d, + (machineDyadicFloorVectorStep)^[k] + (machineDyadicFloorVectorInit + (dyadicFloorVectorCanonicalWord p v)) = + machineDyadicFloorVectorSemanticState p v k := by + intro k hk + induction k with + | zero => exact machineDyadicFloorVectorInit_semantics p v + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineDyadicFloorVectorStep_semantics p v k (by omega) + +theorem machineDyadicFloorVector_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineDyadicFloorVectorStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineDyadicFloorVectorStep] + +theorem dyadicFloorVectorPrefix_all {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : + dyadicFloorVectorPrefix p v d = + List.ofFn (dyadicFloorVector p v) := by + rw [dyadicFloorVectorPrefix, + List.take_of_length_le (by simp), List.map_ofFn] + rfl + +theorem machineDyadicFloorVectorReversedCode_encode {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : + machineDyadicFloorVectorReversedCode + (dyadicFloorVectorCanonicalWord p v) = + binaryListCode rationalEntryBinaryCode + (List.ofFn (dyadicFloorVector p v)).reverse := by + let word := dyadicFloorVectorCanonicalWord p v + have hd : d ≀ word.length := by + have hlist := binaryListCode_listLength_le rationalEntryBinaryCode + (List.ofFn v) + have hvector : (rationalFiniteVectorCode v).length ≀ word.length := by + simp only [word, dyadicFloorVectorCanonicalWord, pair_length, + List.length_replicate] + omega + simpa only [rationalFiniteVectorCode, List.length_ofFn] using! + hlist.trans hvector + have hsplit : word.length = (word.length - d) + d := by omega + change machineDyadicFloorVectorReversedCode word = _ + rw [machineDyadicFloorVectorReversedCode, + machineDyadicFloorVectorFinalState, hsplit, + Function.iterate_add_apply, + machineDyadicFloorVectorIterate_semantics p v d le_rfl] + simp only [machineDyadicFloorVectorSemanticState] + rw [show binaryListCode rationalEntryBinaryCode + ((List.ofFn v).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineDyadicFloorVector_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [dyadicFloorVectorPrefix_all] + +@[simp] theorem machineDyadicFloorVectorCode_encode {d : β„•} + (p : β„•) (v : Fin d β†’ β„š) : + machineDyadicFloorVectorCode + (dyadicFloorVectorCanonicalWord p v) = + rationalFiniteVectorCode (dyadicFloorVector p v) := by + rw [machineDyadicFloorVectorCode, + machineDyadicFloorVectorReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineEncoding.lean new file mode 100644 index 0000000000..d9065810f5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineEncoding.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal + +/-! +# Machine access to the canonical binary encodings + +The public theorem uses right-nested `Complexity.pair` codes. This file +records both their exact behavior on well-formed inputs and the already +verified Complexitylib machines that split them in polynomial time. No +semantic decoder or choice function occurs in these accessors. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- First component of a machine pair. On a matrix code this is `n.bits`. -/ +def machinePairFirst (word : List Bool) : List Bool := Cobham.fstBlock word + +/-- Second component of a machine pair. On a matrix code this is the encoded +row list. -/ +def machinePairSecond (word : List Bool) : List Bool := Cobham.sndBlock word + +theorem machinePairFirst_mem_FP : machinePairFirst ∈ Complexity.FP := by + simpa only [machinePairFirst] using! Cobham.fstBlock_mem_FP + +theorem machinePairSecond_mem_FP : machinePairSecond ∈ Complexity.FP := by + simpa only [machinePairSecond] using! Cobham.sndBlock_mem_FP + +@[simp] theorem machinePairFirst_pair (left right : List Bool) : + machinePairFirst (pair left right) = left := by + simp [machinePairFirst] + +@[simp] theorem machinePairSecond_pair (left right : List Bool) : + machinePairSecond (pair left right) = right := by + simp [machinePairSecond] + +/-- The dimension word extracted from a canonical matrix input. -/ +def machineMatrixDimensionWord (word : List Bool) : List Bool := + machinePairFirst word + +/-- The nested row-list word extracted from a canonical matrix input. -/ +def machineMatrixRowsWord (word : List Bool) : List Bool := + machinePairSecond word + +theorem machineMatrixDimensionWord_mem_FP : + machineMatrixDimensionWord ∈ Complexity.FP := by + simpa only [machineMatrixDimensionWord] using! machinePairFirst_mem_FP + +theorem machineMatrixRowsWord_mem_FP : + machineMatrixRowsWord ∈ Complexity.FP := by + simpa only [machineMatrixRowsWord] using! machinePairSecond_mem_FP + +@[simp] theorem machineMatrixDimensionWord_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixDimensionWord + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = n.bits := by + simp [rationalMatrixBinaryEncoding, rationalMatrixBinaryCode, + machineMatrixDimensionWord] + +@[simp] theorem machineMatrixRowsWord_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixRowsWord + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A) := by + simp [rationalMatrixBinaryEncoding, rationalMatrixBinaryCode, + machineMatrixRowsWord] + +/-- A nonempty right-nested list exposes its head through `fstBlock`. -/ +def machineListHead (word : List Bool) : List Bool := machinePairFirst word + +/-- A nonempty right-nested list exposes its tail through `sndBlock`. -/ +def machineListTail (word : List Bool) : List Bool := machinePairSecond word + +theorem machineListHead_mem_FP : machineListHead ∈ Complexity.FP := by + simpa only [machineListHead] using! machinePairFirst_mem_FP + +theorem machineListTail_mem_FP : machineListTail ∈ Complexity.FP := by + simpa only [machineListTail] using! machinePairSecond_mem_FP + +@[simp] theorem machineListHead_cons {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) (x : Ξ±) (xs : List Ξ±) : + machineListHead (binaryListCode encode (x :: xs)) = encode x := by + simp [machineListHead, binaryListCode] + +@[simp] theorem machineListTail_cons {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) (x : Ξ±) (xs : List Ξ±) : + machineListTail (binaryListCode encode (x :: xs)) = + binaryListCode encode xs := by + simp [machineListTail, binaryListCode] + +/-- Signed numerator word of a canonical matrix-entry code. -/ +def machineRationalEntryNumeratorWord (word : List Bool) : List Bool := + machinePairFirst word + +/-- Positive denominator word of a canonical matrix-entry code. -/ +def machineRationalEntryDenominatorWord (word : List Bool) : List Bool := + machinePairSecond word + +theorem machineRationalEntryNumeratorWord_mem_FP : + machineRationalEntryNumeratorWord ∈ Complexity.FP := by + simpa only [machineRationalEntryNumeratorWord] using! machinePairFirst_mem_FP + +theorem machineRationalEntryDenominatorWord_mem_FP : + machineRationalEntryDenominatorWord ∈ Complexity.FP := by + simpa only [machineRationalEntryDenominatorWord] using! machinePairSecond_mem_FP + +@[simp] theorem machineRationalEntryNumeratorWord_encode (q : β„š) : + machineRationalEntryNumeratorWord (rationalEntryBinaryCode q) = + integerBinaryCode q.num := by + simp [rationalEntryBinaryCode, machineRationalEntryNumeratorWord] + +@[simp] theorem machineRationalEntryDenominatorWord_encode (q : β„š) : + machineRationalEntryDenominatorWord (rationalEntryBinaryCode q) = + q.den.bits := by + simp [rationalEntryBinaryCode, machineRationalEntryDenominatorWord] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableCertificate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableCertificate.lean new file mode 100644 index 0000000000..56b27d64d7 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableCertificate.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableCertificateMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableScannedOptimizerOutput +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatchingGain + +/-! +# The certificate evaluator for the executable row-major optimizer + +The arithmetic transducer is the same verified directed-certificate machine +used elsewhere. This file proves its contract for the concrete row-major +optimizer output, using only the executable optimizer's proved certificate-log +magnitude bound. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +theorem executableOptimizerCertificate_expApproxSteps_le_sourceBound + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + explicitCertificateExpStepBound + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩).length := by + exact certificate_expApproxSteps_le_sourceBound_of_abs_le m B _ + (executableOptimizerCertificateLog_abs_le m B hBpos hBupper) + +theorem machineExecutableOptimizerCertificateExpGuard_fits + (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hBpos : βˆ€ i j, 0 < B i j) + (hBupper : βˆ€ i j, B i j ≀ 1) : + RawRat.expApproxSteps + (rawRatOfRat + (explicitDirectedCertificateLog + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B))) + (rawCertificateExpLoss (m + 2)) ≀ + (machineOptimizerCertificateExpGuard + (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode + (executableLargeOptimizerOutput m B)))).length := by + let source := rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩ + have hsource : 2 ≀ source.length := + (show 2 ≀ m + 2 by omega).trans (matrix_dimension_le_code_length B) + exact + (executableOptimizerCertificate_expApproxSteps_le_sourceBound + m B hBpos hBupper).trans + (by simpa only [machineOptimizerCertificateExpGuard, + machineCertificateSourceWord_pair, + machineIteratedBinaryWidth_length, source] using! + explicitCertificateExpStepBound_le_guardWidth hsource) + +/-- Correctness of a raw certificate transducer on the concrete outputs of +the executable row-major optimizer. -/ +def ExecutableCertificateEvaluatorStringRealizesOnPositiveNormalized + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + F (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode (executableLargeOptimizerOutput m B))) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B))) + +/-- Instantiates the certificate-value machine with the explicit matching-gain code and +executable exponential guard. -/ +def machineExecutableCertificateValueRawCode : List Bool β†’ List Bool := + machineCertificateValueRawCode machineExplicitMatchingGainRawCode + machineOptimizerCertificateExpGuard + +theorem machineExecutableCertificateValueRawCode_mem_FP : + machineExecutableCertificateValueRawCode ∈ FP := by + simpa only [machineExecutableCertificateValueRawCode] using! + machineCertificateValueRawCode_mem_FP + machineExplicitMatchingGainRawCode_mem_FP + machineOptimizerCertificateExpGuard_mem_FP + +theorem machineExecutableCertificateValueRawCode_realizes_onPositive : + ExecutableCertificateEvaluatorStringRealizesOnPositiveNormalized + machineExecutableCertificateValueRawCode := by + intro m B hBpos hBupper + simpa only [machineExecutableCertificateValueRawCode, + executableLargeOptimizerOutput, executableScannedOptimizerOutput, + Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using! + machineCertificateValueRawCode_encode + (gainMachine := machineExplicitMatchingGainRawCode) + (guardMachine := machineOptimizerCertificateExpGuard) + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B) + (machineExplicitMatchingGainRawCode_encode + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B)) + (machineExecutableOptimizerCertificateExpGuard_fits + m B hBpos hBupper) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineExecutablePositiveAlgorithm.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutablePositiveAlgorithm.lean new file mode 100644 index 0000000000..e351f34eed --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutablePositiveAlgorithm.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutablePositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutableCertificate +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm + +/-! +# Finite-word realization of the executable positive-matrix routine + +This file composes the concrete row-major optimizer, the concrete certificate +evaluator, normalization, and scale restoration. Correctness is required only +on positive inputs, exactly the domain used by the smoothing reduction. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Returns zero in dimensions zero and one; in larger dimensions evaluates the directed +certificate using the executable scanned optimizer matrix and its row and column potentials. -/ +def executableNormalizedCertificateAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + | 0, _ => 0 + | 1, _ => 0 + | m + 2, B => + explicitDirectedCertificateValue + (executableScannedBetheOptimizerMatrix (m := m + 1) B) + (executableScannedBetheOptimizerRowPotential (m := m + 1) B) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) B) + +/-- Requires a string function to return the exact raw code of the normalized certificate +algorithm on every positive matrix of dimension at least two with entries at most one. -/ +def ExecutableNormalizedCertificateStringRealizesOnPositive + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + F (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) = + rawRatBinaryCode + (rawRatOfRat (executableNormalizedCertificateAlgorithm (m + 2) B)) + +/-- Combines the executable scanned optimizer output with the executable certificate-value +machine to produce a normalized certificate code. -/ +def machineExecutableNormalizedCertificateRawCode : List Bool β†’ List Bool := + machineNormalizedCertificateFromParts + machineExecutableScannedOptimizerOutputCode + machineExecutableCertificateValueRawCode + +theorem machineExecutableNormalizedCertificateRawCode_mem_FP : + machineExecutableNormalizedCertificateRawCode ∈ FP := by + simpa only [machineExecutableNormalizedCertificateRawCode] using! + machineNormalizedCertificateFromParts_mem_FP + machineExecutableScannedOptimizerOutputCode_mem_FP + machineExecutableCertificateValueRawCode_mem_FP + +theorem machineExecutableNormalizedCertificateRawCode_realizes_onPositive : + ExecutableNormalizedCertificateStringRealizesOnPositive + machineExecutableNormalizedCertificateRawCode := by + intro m B hBpos hBupper + rw [machineExecutableNormalizedCertificateRawCode, + machineNormalizedCertificateFromParts, + machineCompletedDimensionLtTwoBit_encode, + show [decide (m + 2 < 2)] = [false] by simp, + machineIfHead_false, + machineExecutableScannedOptimizerOutputCode_realizes m B hBpos hBupper, + machineExecutableCertificateValueRawCode_realizes_onPositive + m B hBpos hBupper] + rfl + +theorem machineExecutablePositiveLargeRawCode_encode_onPositive + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : + ExecutableNormalizedCertificateStringRealizesOnPositive + certificateMachine) + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hA : Matrix.Positive (fun i j ↦ (A i j : ℝ))) : + machinePositiveLargeRawCode certificateMachine + (rationalMatrixBinaryEncoding.encode ⟨m + 2, A⟩) = + rawRatBinaryCode + (rawRatOfRat (executablePositiveAlgorithm (m + 2) A)) := by + have hAq : βˆ€ i j, 0 < A i j := fun i j ↦ Rat.cast_pos.mp (hA i j) + have hA0 : Matrix.Nonnegative A := fun i j ↦ (hAq i j).le + have hBpos : βˆ€ i j, 0 < normalizedRationalMatrix A i j := by + intro i j + rw [normalizedRationalMatrix] + exact div_pos (hAq i j) (rationalNormalizationScale_pos hA0) + have hBupper : βˆ€ i j, normalizedRationalMatrix A i j ≀ 1 := + normalizedRationalMatrix_le_one hA0 + have hcertificate := hrealizes m (normalizedRationalMatrix A) + hBpos hBupper + change certificateMachine + (rationalMatrixBinaryEncoding.encode + ⟨m + 2, normalizedRationalMatrix A⟩) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (executableScannedBetheOptimizerMatrix (m := m + 1) + (normalizedRationalMatrix A)) + (executableScannedBetheOptimizerRowPotential (m := m + 1) + (normalizedRationalMatrix A)) + (executableScannedBetheOptimizerColumnPotential (m := m + 1) + (normalizedRationalMatrix A)))) at hcertificate + simp only [machinePositiveLargeRawCode, + machinePositiveLargeProductRawCode, + machinePositiveCertificateRawCode, + machinePositiveNormalizedMatrixCode, + machineMatrixNormalizeEntries_encode, + hcertificate, + machineMatrixNormalizationScalePowerRawCode_encode, + machineRawRatMulCode_encode, + machineNormalizeRawRatEntryCode_encode, + ← rawRatBinaryCode_rawRatOfRat] + apply congrArg rawRatBinaryCode + apply congrArg rawRatOfRat + rw [binaryNormalizeRawRat_eq_value, RawRat.value_mul, + RawRat.value_pow, RawRat.value_add, RawRat.value_one, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum, rawRatOfRat_value] + rfl + +theorem machinePositiveAlgorithmRawCode_realizes_executable_onPositive + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : + ExecutableNormalizedCertificateStringRealizesOnPositive + certificateMachine) : + PositiveRawStringRealizes + (machinePositiveAlgorithmRawCode certificateMachine) + executablePositiveAlgorithm := by + intro n A hA + rw [machinePositiveAlgorithmRawCode, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true, + machinePositiveSmallRawCode_encode hsmall] + interval_cases n <;> rfl + Β· rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false] + obtain ⟨m, rfl⟩ : βˆƒ m, n = m + 2 := by + use n - 2 + omega + exact machineExecutablePositiveLargeRawCode_encode_onPositive + hrealizes m A hA + +/-- Instantiates the positive-matrix algorithm machine with the executable normalized +certificate code. -/ +def machineExecutablePositiveAlgorithmRawCode : List Bool β†’ List Bool := + machinePositiveAlgorithmRawCode + machineExecutableNormalizedCertificateRawCode + +theorem machineExecutablePositiveAlgorithmRawCode_mem_FP : + machineExecutablePositiveAlgorithmRawCode ∈ FP := by + simpa only [machineExecutablePositiveAlgorithmRawCode] using! + machinePositiveAlgorithmRawCode_mem_FP + machineExecutableNormalizedCertificateRawCode_mem_FP + +theorem machineExecutablePositiveAlgorithmRawCode_realizes_onPositive : + PositiveRawStringRealizes + machineExecutablePositiveAlgorithmRawCode + executablePositiveAlgorithm := by + simpa only [machineExecutablePositiveAlgorithmRawCode] using! + machinePositiveAlgorithmRawCode_realizes_executable_onPositive + machineExecutableNormalizedCertificateRawCode_realizes_onPositive + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableScannedOptimizerOutput.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableScannedOptimizerOutput.lean new file mode 100644 index 0000000000..aaca43eb16 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineExecutableScannedOptimizerOutput.lean @@ -0,0 +1,1324 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ExecutableScannedBetheOptimizer +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryMatrixGenerator +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerMatrixBitBound +public import LeanPool.BeyondBethe.BeyondBethe.OptimizerOutputEncoding + +/-! +# Finite-word output of the executable scanned optimizer + +This file turns the accepted epigraph point into the canonical matrix and +potential words consumed by the certificate evaluator. The first stage is +the complete recovered Birkhoff matrix. Its entries are generated directly +in row-major order and normalized before being inserted into the nested row +encoding. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## A normalized recovered-matrix entry -/ + +/-- Extracts the unary row ruler from an executable affine matrix-entry request. -/ +def machineExecutableMatrixEntryRow (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the payload following the row ruler of an executable matrix-entry request. -/ +def machineExecutableMatrixEntryRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary column ruler from an executable matrix-entry request. -/ +def machineExecutableMatrixEntryColumn (word : List Bool) : List Bool := + machinePairFirst (machineExecutableMatrixEntryRest word) + +/-- Extracts the base dimension and point payload following the requested matrix indices. -/ +def machineExecutableMatrixEntryPayload (word : List Bool) : List Bool := + machinePairSecond (machineExecutableMatrixEntryRest word) + +/-- Extracts the base-dimension ruler from an executable matrix-entry payload. -/ +def machineExecutableMatrixEntryBaseDimension + (word : List Bool) : List Bool := + machinePairFirst (machineExecutableMatrixEntryPayload word) + +/-- Extracts the encoded free-coordinate point from an executable matrix-entry payload. -/ +def machineExecutableMatrixEntryPoint (word : List Bool) : List Bool := + machinePairSecond (machineExecutableMatrixEntryPayload word) + +/-- Reorders the base dimension, row, column, and point into the input layout expected by the +affine-entry machine. -/ +def machineExecutableMatrixEntryRawInput (word : List Bool) : List Bool := + pair (machineExecutableMatrixEntryBaseDimension word) + (pair (machineExecutableMatrixEntryRow word) + (pair (machineExecutableMatrixEntryColumn word) + (machineExecutableMatrixEntryPoint word))) + +/-- Evaluates the requested affine matrix entry and normalizes its raw rational code. -/ +def machineExecutableMatrixEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineBetheAffineEntryRawCode + (machineExecutableMatrixEntryRawInput word)) + +theorem machineExecutableMatrixEntryRow_mem_FP : + machineExecutableMatrixEntryRow ∈ FP := machinePairFirst_mem_FP + +theorem machineExecutableMatrixEntryRest_mem_FP : + machineExecutableMatrixEntryRest ∈ FP := machinePairSecond_mem_FP + +theorem machineExecutableMatrixEntryColumn_mem_FP : + machineExecutableMatrixEntryColumn ∈ FP := by + simpa only [machineExecutableMatrixEntryColumn] using! + machineCompose_mem_FP machineExecutableMatrixEntryRest_mem_FP + machinePairFirst_mem_FP + +theorem machineExecutableMatrixEntryPayload_mem_FP : + machineExecutableMatrixEntryPayload ∈ FP := by + simpa only [machineExecutableMatrixEntryPayload] using! + machineCompose_mem_FP machineExecutableMatrixEntryRest_mem_FP + machinePairSecond_mem_FP + +theorem machineExecutableMatrixEntryBaseDimension_mem_FP : + machineExecutableMatrixEntryBaseDimension ∈ FP := by + simpa only [machineExecutableMatrixEntryBaseDimension] using! + machineCompose_mem_FP machineExecutableMatrixEntryPayload_mem_FP + machinePairFirst_mem_FP + +theorem machineExecutableMatrixEntryPoint_mem_FP : + machineExecutableMatrixEntryPoint ∈ FP := by + simpa only [machineExecutableMatrixEntryPoint] using! + machineCompose_mem_FP machineExecutableMatrixEntryPayload_mem_FP + machinePairSecond_mem_FP + +theorem machineExecutableMatrixEntryRawInput_mem_FP : + machineExecutableMatrixEntryRawInput ∈ FP := + machinePair_mem_FP machineExecutableMatrixEntryBaseDimension_mem_FP + (machinePair_mem_FP machineExecutableMatrixEntryRow_mem_FP + (machinePair_mem_FP machineExecutableMatrixEntryColumn_mem_FP + machineExecutableMatrixEntryPoint_mem_FP)) + +theorem machineExecutableMatrixEntryCode_mem_FP : + machineExecutableMatrixEntryCode ∈ FP := by + have hraw := machineCompose_mem_FP + machineExecutableMatrixEntryRawInput_mem_FP + machineBetheAffineEntryRawCode_mem_FP + simpa only [machineExecutableMatrixEntryCode] using! + machineCompose_mem_FP hraw machineNormalizeRawRatEntryCode_mem_FP + +@[simp] theorem machineExecutableMatrixEntryCode_encode {m : β„•} + (y : Fin (m * m) β†’ β„š) (i j : Fin (m + 1)) : + machineExecutableMatrixEntryCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (pair (List.replicate m true) + (rationalFiniteVectorCode y)))) = + rationalEntryBinaryCode (betheAffineMatrixQ y i j) := by + rw [machineExecutableMatrixEntryCode, + machineExecutableMatrixEntryRawInput] + simp only [machineExecutableMatrixEntryBaseDimension, + machineExecutableMatrixEntryPoint, + machineExecutableMatrixEntryPayload, + machineExecutableMatrixEntryRow, + machineExecutableMatrixEntryColumn, + machineExecutableMatrixEntryRest, + machinePairFirst_pair, machinePairSecond_pair] + change machineNormalizeRawRatEntryCode + (machineBetheAffineEntryRawCode + (machineBetheAffineEntryCanonicalWord i j y)) = _ + rw [machineBetheAffineEntryRawCode_encode, + machineNormalizeRawRatEntryCode_encode] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, rawBetheAffineEntry_value] + +/-! ## Uniform matrix-output program -/ + +/-- Removes one element from the matrix dimension ruler to obtain the optimizer base dimension. -/ +def machineExecutableOptimizerBaseDimensionUnary + (word : List Bool) : List Bool := + (machineMatrixDimensionUnary word).tail + +/-- Runs the explicit Bethe optimizer point machine on the input matrix word. -/ +def machineExecutableOptimizerPointCode + (word : List Bool) : List Bool := + machineExplicitBetheOptimizerPointCode word + +/-- Drops the final encoded coordinate from the optimizer point to obtain the base point used +for affine matrix reconstruction. -/ +def machineExecutableOptimizerBasePointCode + (word : List Bool) : List Bool := + machineBinaryListInit (machineExecutableOptimizerPointCode word) + +/-- Packages the affine dimension ruler and optimizer base-point vector for matrix +reconstruction. -/ +def machineExecutableOptimizerMatrixPayload + (word : List Bool) : List Bool := + pair (machineExecutableOptimizerBaseDimensionUnary word) + (machineExecutableOptimizerBasePointCode word) + +/-- The seed is exactly the canonical directed-objective word at `tau = 0` +and precision zero. Reusing that word lets the existing raw-entry width proof +serve as the matrix generator's bit analysis. -/ +def machineExecutableOptimizerMatrixSeed + (word : List Bool) : List Bool := + pair (machineExecutableOptimizerBaseDimensionUnary word) + (pair [] (pair (rawRatBinaryCode (rawRatOfRat 0)) + (pair word (machineExecutableOptimizerBasePointCode word)))) + +/-- Bounds reconstructed matrix entries by twice expanding a seed padded with 1024 bits. -/ +def machineExecutableOptimizerMatrixBound + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 + (machineExecutableOptimizerMatrixSeed word ++ + List.replicate 1024 false) + +/-- Packages the matrix-order ruler, entry bound, and reconstruction payload for matrix +generation. -/ +def machineExecutableOptimizerMatrixGeneratorInput + (word : List Bool) : List Bool := + pair (machineMatrixDimensionUnary word) + (pair (machineExecutableOptimizerMatrixBound word) + (machineExecutableOptimizerMatrixPayload word)) + +/-- Generates the encoded rows of the optimizer's reconstructed matrix. -/ +def machineExecutableOptimizerMatrixRowsCode + (word : List Bool) : List Bool := + machineUnaryMatrixGeneratorRowsCode machineExecutableMatrixEntryCode + (machineExecutableOptimizerMatrixGeneratorInput word) + +/-- Pairs the binary matrix dimension with the generated matrix rows. -/ +def machineExecutableOptimizerMatrixCode + (word : List Bool) : List Bool := + pair (machineMatrixDimensionWord word) + (machineExecutableOptimizerMatrixRowsCode word) + +theorem machineExecutableOptimizerBaseDimensionUnary_mem_FP : + machineExecutableOptimizerBaseDimensionUnary ∈ FP := by + simpa only [machineExecutableOptimizerBaseDimensionUnary] using! + machineCompose_mem_FP machineMatrixDimensionUnary_mem_FP + machineTail_mem_FP + +theorem machineExecutableOptimizerPointCode_mem_FP : + machineExecutableOptimizerPointCode ∈ FP := by + simpa only [machineExecutableOptimizerPointCode] using! + machineExplicitBetheOptimizerPointCode_mem_FP + +theorem machineExecutableOptimizerBasePointCode_mem_FP : + machineExecutableOptimizerBasePointCode ∈ FP := by + simpa only [machineExecutableOptimizerBasePointCode] using! + machineCompose_mem_FP machineExecutableOptimizerPointCode_mem_FP + machineBinaryListInit_mem_FP + +theorem machineExecutableOptimizerMatrixPayload_mem_FP : + machineExecutableOptimizerMatrixPayload ∈ FP := + machinePair_mem_FP machineExecutableOptimizerBaseDimensionUnary_mem_FP + machineExecutableOptimizerBasePointCode_mem_FP + +theorem machineExecutableOptimizerMatrixSeed_mem_FP : + machineExecutableOptimizerMatrixSeed ∈ FP := + machinePair_mem_FP machineExecutableOptimizerBaseDimensionUnary_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (rawRatOfRat 0))) + (machinePair_mem_FP id_mem_FP + machineExecutableOptimizerBasePointCode_mem_FP))) + +theorem machineExecutableOptimizerMatrixBound_mem_FP : + machineExecutableOptimizerMatrixBound ∈ FP := by + have hpadded := machineAppend_mem_FP + machineExecutableOptimizerMatrixSeed_mem_FP + (machineConst_mem_FP (List.replicate 1024 false)) + simpa only [machineExecutableOptimizerMatrixBound] using! + machineCompose_mem_FP hpadded (machineIteratedBinaryWidth_mem_FP 2) + +theorem machineExecutableOptimizerMatrixGeneratorInput_mem_FP : + machineExecutableOptimizerMatrixGeneratorInput ∈ FP := + machinePair_mem_FP machineMatrixDimensionUnary_mem_FP + (machinePair_mem_FP machineExecutableOptimizerMatrixBound_mem_FP + machineExecutableOptimizerMatrixPayload_mem_FP) + +theorem machineExecutableOptimizerMatrixRowsCode_mem_FP : + machineExecutableOptimizerMatrixRowsCode ∈ FP := by + have hgenerator := machineUnaryMatrixGeneratorRowsCode_mem_FP + machineExecutableMatrixEntryCode_mem_FP + simpa only [machineExecutableOptimizerMatrixRowsCode] using! + machineCompose_mem_FP + machineExecutableOptimizerMatrixGeneratorInput_mem_FP hgenerator + +theorem machineExecutableOptimizerMatrixCode_mem_FP : + machineExecutableOptimizerMatrixCode ∈ FP := + machinePair_mem_FP machineMatrixDimensionWord_mem_FP + machineExecutableOptimizerMatrixRowsCode_mem_FP + +/-! ## Canonical semantics and the explicit output bound -/ + +@[simp] theorem machineExecutableOptimizerBaseDimensionUnary_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineExecutableOptimizerBaseDimensionUnary + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + List.replicate m true := by + rw [machineExecutableOptimizerBaseDimensionUnary, + machineMatrixDimensionUnary_encode] + simp + +@[simp] theorem machineExecutableOptimizerMatrixSeed_encode + {m : β„•} (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) + (hpoint : machineExecutableOptimizerBasePointCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalFiniteVectorCode y) : + machineExecutableOptimizerMatrixSeed + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + machineDirectedObjectiveSumCanonicalWord 0 A y 0 := by + simp [machineExecutableOptimizerMatrixSeed, hpoint, + machineDirectedObjectiveSumCanonicalWord] + +theorem unaryMatrixCode_length_le_of_entry_bound {n E : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (hentry : βˆ€ i j, (rationalEntryBinaryCode (X i j)).length ≀ E) : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows X)).length ≀ + n * (2 * (n * (2 * E + 2)) + 2) := by + rw [binaryListCode_length_eq_sum] + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply] + calc + βˆ‘ i : Fin n, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j => X i j)).length + 2) ≀ + βˆ‘ _i : Fin n, (2 * (n * (2 * E + 2)) + 2) := by + apply Finset.sum_le_sum + intro i _hi + rw [binaryListCode_length_eq_sum] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + have hrow : + βˆ‘ j : Fin n, + (2 * (rationalEntryBinaryCode (X i j)).length + 2) ≀ + βˆ‘ _j : Fin n, (2 * E + 2) := by + apply Finset.sum_le_sum + intro j _hj + have hij := hentry i j + omega + have hrow' : + βˆ‘ j : Fin n, + (2 * (rationalEntryBinaryCode (X i j)).length + 2) ≀ + n * (2 * E + 2) := by simpa using! hrow + omega + _ = n * (2 * (n * (2 * E + 2)) + 2) := by simp + +theorem executableOptimizerMatrix_entryCode_length_le {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (i j : Fin (m + 1)) : + let L := (machineDirectedObjectiveSumCanonicalWord 0 A y 0).length + (rationalEntryBinaryCode (betheAffineMatrixQ y i j)).length ≀ + 64 + 36 * rawBetheAffineEntryWidthBudget m L := by + intro L + rw [← rawRatBinaryCode_rawRatOfRat] + have hcode := rawRatBinaryCode_length_le_width + (rawRatOfRat (betheAffineMatrixQ y i j)) + have hwidth := rawBetheAffineMatrixQ_width_le_word + (tau := (0 : β„š)) A y 0 i j + exact hcode.trans (by + simp only [L] + omega) + +theorem executableOptimizerMatrix_rowsCode_fits_bound {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) : + let seed := machineDirectedObjectiveSumCanonicalWord 0 A y 0 + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (betheAffineMatrixQ y))).length ≀ + (machineIteratedBinaryWidth 2 + (seed ++ List.replicate 1024 false)).length := by + intro seed + let L := seed.length + let E := 64 + 36 * rawBetheAffineEntryWidthBudget m L + have hentry : βˆ€ i j, + (rationalEntryBinaryCode (betheAffineMatrixQ y i j)).length ≀ E := by + intro i j + simpa only [E, L, seed] using! + executableOptimizerMatrix_entryCode_length_le A y i j + have hmatrix := unaryMatrixCode_length_le_of_entry_bound + (betheAffineMatrixQ y) hentry + have hsource : + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩).length ≀ L := by + simp [L, seed, machineDirectedObjectiveSumCanonicalWord] + omega + have hsquare : (m + 1) ^ 2 ≀ L := by + have hcount : + ((rationalMatrixRows A).map List.length).sum = (m + 1) ^ 2 := by + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply, List.length_ofFn] + simp + ring + rw [← hcount] + apply (rationalRowsEntryCount_le_codeLength + (rationalMatrixRows A)).trans + have hrows : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length ≀ + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩).length := by + change _ ≀ (pair (m + 1).bits + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A))).length + simpa only [machinePairSecond_pair] using! + machinePairSecond_length_le + (pair (m + 1).bits + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A))) + exact hrows.trans hsource + have hm2 : m * m ≀ L := by nlinarith + have hm : m ≀ L := by nlinarith + have hE : E ≀ 512 * (L + 16) ^ 2 := by + simp only [E, rawBetheAffineEntryWidthBudget] + nlinarith [sq_nonneg (L + 16)] + have hmatrix' : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (betheAffineMatrixQ y))).length ≀ + 4096 * (L + 16) ^ 3 := by + apply hmatrix.trans + have hn2 : (m + 1) * (m + 1) ≀ L := by + simpa [pow_two] using! hsquare + have hbase : 1 ≀ L + 16 := by omega + nlinarith [Nat.mul_le_mul_left (4 * L) hE, + sq_nonneg (L + 16)] + have hpow : 4096 * (L + 16) ^ 3 ≀ + (L + 1024 + 16) ^ 4 := by + nlinarith [sq_nonneg (L + 16), sq_nonneg (L + 1040)] + calc + _ ≀ 4096 * (L + 16) ^ 3 := hmatrix' + _ ≀ (L + 1024 + 16) ^ 4 := hpow + _ ≀ certificateExpGuardWidth 2 (L + 1024) := by + simpa only [show 2 ^ (1 + 1) = 4 by norm_num] using! + certificateExpGuardWidth_pow_lower 1 (L + 1024) + _ = _ := by + rw [machineIteratedBinaryWidth_length] + simp only [List.length_append, List.length_replicate, L] + +@[simp] theorem machineExecutableOptimizerMatrixRowsCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerMatrixRowsCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows + (executableScannedBetheOptimizerMatrix A)) := by + let word := rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ + let q := executableScannedBetheOptimizerPoint A + let y := epigraphBase q + have hpointFull : machineExecutableOptimizerPointCode word = + rationalFiniteVectorCode q := by + simpa only [machineExecutableOptimizerPointCode, word, q] using! + machineExplicitBetheOptimizerPointCode_encode hm A hApos hAupper + have hpoint : machineExecutableOptimizerBasePointCode word = + rationalFiniteVectorCode y := by + rw [machineExecutableOptimizerBasePointCode, hpointFull, + rationalFiniteVectorCode, ofFn_epigraph_center_split, + machineBinaryListInit_encode] + rfl + have hseed := machineExecutableOptimizerMatrixSeed_encode A y hpoint + rw [machineExecutableOptimizerMatrixRowsCode, + machineExecutableOptimizerMatrixGeneratorInput] + have hdimension : machineMatrixDimensionUnary word = + List.replicate (m + 1) true := machineMatrixDimensionUnary_encode A + have hpayload : machineExecutableOptimizerMatrixPayload word = + pair (List.replicate m true) (rationalFiniteVectorCode y) := by + simp [machineExecutableOptimizerMatrixPayload, hpoint, word] + have hbound : machineExecutableOptimizerMatrixBound word = + machineIteratedBinaryWidth 2 + (machineDirectedObjectiveSumCanonicalWord 0 A y 0 ++ + List.replicate 1024 false) := by + rw [machineExecutableOptimizerMatrixBound] + rw [show machineExecutableOptimizerMatrixSeed word = + machineDirectedObjectiveSumCanonicalWord 0 A y 0 by + simpa only [word] using! hseed] + rw [hdimension, hpayload, hbound] + change machineUnaryMatrixGeneratorRowsCode machineExecutableMatrixEntryCode + (machineUnaryMatrixGeneratorCanonicalWord (m + 1) + (machineIteratedBinaryWidth 2 + (machineDirectedObjectiveSumCanonicalWord 0 A y 0 ++ + List.replicate 1024 false)) + (pair (List.replicate m true) (rationalFiniteVectorCode y))) = _ + rw [machineUnaryMatrixGeneratorRowsCode_encode_of_bound + machineExecutableMatrixEntryCode (betheAffineMatrixQ y) + (machineIteratedBinaryWidth 2 + (machineDirectedObjectiveSumCanonicalWord 0 A y 0 ++ + List.replicate 1024 false)) + (pair (List.replicate m true) (rationalFiniteVectorCode y))] + Β· rfl + Β· intro i j + exact machineExecutableMatrixEntryCode_encode y i j + Β· simpa only [unaryMatrixRows, rationalMatrixRows] using! + executableOptimizerMatrix_rowsCode_fits_bound A y + +@[simp] theorem machineExecutableOptimizerMatrixCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerMatrixCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalMatrixBinaryEncoding.encode + ⟨m + 1, executableScannedBetheOptimizerMatrix A⟩ := by + rw [machineExecutableOptimizerMatrixCode, + machineMatrixDimensionWord_encode, + machineExecutableOptimizerMatrixRowsCode_encode hm A hApos hAupper] + rfl + +/-! ## Normalized potential entries -/ + +/-- The matrix generator supplies a dummy row, the vector coordinate as its +column, and then the immutable directed-objective seed. -/ +def machineExecutablePotentialIndex (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond word) + +/-- Extracts the objective-evaluation payload from a potential-entry query. -/ +def machineExecutablePotentialPayload (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond word) + +/-- Builds a gradient-entry query from supplied row and column extractors and the common +payload. -/ +def machineExecutablePotentialGradientInput + (row column : List Bool β†’ List Bool) (word : List Bool) : List Bool := + pair (row word) + (pair (column word) (machineExecutablePotentialPayload word)) + +/-- Queries the negative gradient at the requested row and column zero for row-potential +recovery. -/ +def machineExecutableRowPotentialGradientInput + (word : List Bool) : List Bool := + machineExecutablePotentialGradientInput machineExecutablePotentialIndex + (fun _ => []) word + +/-- Queries the negative gradient at row zero and the requested column for column-potential +recovery. -/ +def machineExecutableColumnPotentialGradientInput + (word : List Bool) : List Bool := + machineExecutablePotentialGradientInput (fun _ => []) + machineExecutablePotentialIndex word + +/-- Queries the negative gradient at matrix entry `(0, 0)`. -/ +def machineExecutableOriginGradientInput + (word : List Bool) : List Bool := + machineExecutablePotentialGradientInput (fun _ => []) (fun _ => []) word + +/-- Computes the encoded constant `2 + tau` from the potential-evaluation payload. -/ +def machineExecutableTwoPlusTauRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineDirectedObjectiveSumTau + (machineExecutablePotentialPayload word))) + +/-- Computes the raw row potential as `2 + tau` minus the directed gradient value in column +zero. -/ +def machineExecutableRowPotentialRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair + (machineRawRatNegCode + (machineDirectedNegativeGradientEntryRawCode + (machineExecutableRowPotentialGradientInput word))) + (machineExecutableTwoPlusTauRawCode word)) + +/-- Computes the raw column potential as the origin gradient minus the gradient in row zero. -/ +def machineExecutableColumnPotentialRawCode (word : List Bool) : List Bool := + machineRawRatSubCode + (pair + (machineDirectedNegativeGradientEntryRawCode + (machineExecutableOriginGradientInput word)) + (machineDirectedNegativeGradientEntryRawCode + (machineExecutableColumnPotentialGradientInput word))) + +/-- Normalizes a raw row potential into a rational vector-entry code. -/ +def machineExecutableRowPotentialEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineExecutableRowPotentialRawCode word) + +/-- Normalizes a raw column potential into a rational vector-entry code. -/ +def machineExecutableColumnPotentialEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineExecutableColumnPotentialRawCode word) + +theorem machineExecutablePotentialIndex_mem_FP : + machineExecutablePotentialIndex ∈ FP := by + simpa only [machineExecutablePotentialIndex] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineExecutablePotentialPayload_mem_FP : + machineExecutablePotentialPayload ∈ FP := by + simpa only [machineExecutablePotentialPayload] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineExecutablePotentialGradientInput_mem_FP + {row column : List Bool β†’ List Bool} + (hrow : row ∈ FP) (hcolumn : column ∈ FP) : + machineExecutablePotentialGradientInput row column ∈ FP := + machinePair_mem_FP hrow + (machinePair_mem_FP hcolumn machineExecutablePotentialPayload_mem_FP) + +theorem machineExecutableRowPotentialGradientInput_mem_FP : + machineExecutableRowPotentialGradientInput ∈ FP := by + simpa only [machineExecutableRowPotentialGradientInput] using! + machineExecutablePotentialGradientInput_mem_FP + machineExecutablePotentialIndex_mem_FP (machineConst_mem_FP []) + +theorem machineExecutableColumnPotentialGradientInput_mem_FP : + machineExecutableColumnPotentialGradientInput ∈ FP := by + simpa only [machineExecutableColumnPotentialGradientInput] using! + machineExecutablePotentialGradientInput_mem_FP (machineConst_mem_FP []) + machineExecutablePotentialIndex_mem_FP + +theorem machineExecutableOriginGradientInput_mem_FP : + machineExecutableOriginGradientInput ∈ FP := by + simpa only [machineExecutableOriginGradientInput] using! + machineExecutablePotentialGradientInput_mem_FP + (machineConst_mem_FP []) (machineConst_mem_FP []) + +theorem machineExecutableTwoPlusTauRawCode_mem_FP : + machineExecutableTwoPlusTauRawCode ∈ FP := by + have htau := machineCompose_mem_FP + machineExecutablePotentialPayload_mem_FP + machineDirectedObjectiveSumTau_mem_FP + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) htau + simpa only [machineExecutableTwoPlusTauRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineExecutableRowPotentialRawCode_mem_FP : + machineExecutableRowPotentialRawCode ∈ FP := by + have hgradient := machineCompose_mem_FP + machineExecutableRowPotentialGradientInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + have hneg := machineCompose_mem_FP hgradient machineRawRatNegCode_mem_FP + have hpair := machinePair_mem_FP hneg + machineExecutableTwoPlusTauRawCode_mem_FP + simpa only [machineExecutableRowPotentialRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineExecutableColumnPotentialRawCode_mem_FP : + machineExecutableColumnPotentialRawCode ∈ FP := by + have horigin := machineCompose_mem_FP + machineExecutableOriginGradientInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + have hcolumn := machineCompose_mem_FP + machineExecutableColumnPotentialGradientInput_mem_FP + machineDirectedNegativeGradientEntryRawCode_mem_FP + have hpair := machinePair_mem_FP horigin hcolumn + simpa only [machineExecutableColumnPotentialRawCode] using! + machineCompose_mem_FP hpair machineRawRatSubCode_mem_FP + +theorem machineExecutableRowPotentialEntryCode_mem_FP : + machineExecutableRowPotentialEntryCode ∈ FP := by + simpa only [machineExecutableRowPotentialEntryCode] using! + machineCompose_mem_FP machineExecutableRowPotentialRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExecutableColumnPotentialEntryCode_mem_FP : + machineExecutableColumnPotentialEntryCode ∈ FP := by + simpa only [machineExecutableColumnPotentialEntryCode] using! + machineCompose_mem_FP machineExecutableColumnPotentialRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +@[simp] theorem machineExecutableRowPotentialGradientInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy i : Fin (m + 1)) : + machineExecutableRowPotentialGradientInput + (pair (List.replicate dummy.1 true) + (pair (List.replicate i.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + machineDirectedGradientEntryCanonicalWord tau A y p i 0 := by + simp [machineExecutableRowPotentialGradientInput, + machineExecutablePotentialGradientInput, + machineExecutablePotentialIndex, machineExecutablePotentialPayload, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineExecutableColumnPotentialGradientInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy j : Fin (m + 1)) : + machineExecutableColumnPotentialGradientInput + (pair (List.replicate dummy.1 true) + (pair (List.replicate j.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + machineDirectedGradientEntryCanonicalWord tau A y p 0 j := by + simp [machineExecutableColumnPotentialGradientInput, + machineExecutablePotentialGradientInput, + machineExecutablePotentialIndex, machineExecutablePotentialPayload, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineExecutableOriginGradientInput_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy j : Fin (m + 1)) : + machineExecutableOriginGradientInput + (pair (List.replicate dummy.1 true) + (pair (List.replicate j.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + machineDirectedGradientEntryCanonicalWord tau A y p 0 0 := by + simp [machineExecutableOriginGradientInput, + machineExecutablePotentialGradientInput, + machineExecutablePotentialPayload, + machineDirectedGradientEntryCanonicalWord] + +@[simp] theorem machineExecutableTwoPlusTauRawCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy i : Fin (m + 1)) : + machineExecutableTwoPlusTauRawCode + (pair (List.replicate dummy.1 true) + (pair (List.replicate i.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + rawRatBinaryCode + (rawOptimizerTwo.add (rawRatOfRat tau)) := by + rw [machineExecutableTwoPlusTauRawCode] + simp only [machineExecutablePotentialPayload, machinePairSecond_pair, + machineDirectedObjectiveSumTau_encode, machineRawRatAddCode_encode] + +@[simp] theorem machineExecutableRowPotentialEntryCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy i : Fin (m + 1)) : + machineExecutableRowPotentialEntryCode + (pair (List.replicate dummy.1 true) + (pair (List.replicate i.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + rationalEntryBinaryCode + (-directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i 0 + (2 + tau)) := by + rw [machineExecutableRowPotentialEntryCode, + machineExecutableRowPotentialRawCode, + machineExecutableRowPotentialGradientInput_encode, + machineExecutableTwoPlusTauRawCode_encode, + machineDirectedNegativeGradientEntryRawCode_encode, + machineRawRatNegCode_encode, machineRawRatAddCode_encode, + machineNormalizeRawRatEntryCode_encode] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, RawRat.value_add, + RawRat.value_neg, machineDirectedNegativeGradientEntry_value, + RawRat.value_add, rawRatOfRat_value] + norm_num [rawOptimizerTwo, RawRat.ofNat, RawRat.value] + +@[simp] theorem machineExecutableColumnPotentialEntryCode_encode {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (dummy j : Fin (m + 1)) : + machineExecutableColumnPotentialEntryCode + (pair (List.replicate dummy.1 true) + (pair (List.replicate j.1 true) + (machineDirectedObjectiveSumCanonicalWord tau A y p))) = + rationalEntryBinaryCode + (-(directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 j - + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 0)) := by + rw [machineExecutableColumnPotentialEntryCode, + machineExecutableColumnPotentialRawCode, + machineExecutableOriginGradientInput_encode, + machineExecutableColumnPotentialGradientInput_encode, + machineDirectedNegativeGradientEntryRawCode_encode, + machineDirectedNegativeGradientEntryRawCode_encode, + machineRawRatSubCode_encode, machineNormalizeRawRatEntryCode_encode] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, RawRat.value_sub, + machineDirectedNegativeGradientEntry_value, + machineDirectedNegativeGradientEntry_value] + ring + +/-! ## Canonical directed-gradient seed -/ + +/-- Normalizes the optimizer's regularization parameter into a rational entry code. -/ +def machineExecutableOptimizerTauCanonicalCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineOptimizerTauRawCode word) + +/-- Packages dimension, precision, regularization, source matrix, and base point for gradient +evaluation. -/ +def machineExecutableOptimizerGradientSeed + (word : List Bool) : List Bool := + pair (machineExecutableOptimizerBaseDimensionUnary word) + (pair (machineExplicitOptimizerPrecisionRuler word) + (pair (machineExecutableOptimizerTauCanonicalCode word) + (pair word (machineExecutableOptimizerBasePointCode word)))) + +theorem machineExecutableOptimizerTauCanonicalCode_mem_FP : + machineExecutableOptimizerTauCanonicalCode ∈ FP := by + simpa only [machineExecutableOptimizerTauCanonicalCode] using! + machineCompose_mem_FP machineOptimizerTauRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExecutableOptimizerGradientSeed_mem_FP : + machineExecutableOptimizerGradientSeed ∈ FP := + machinePair_mem_FP machineExecutableOptimizerBaseDimensionUnary_mem_FP + (machinePair_mem_FP machineExplicitOptimizerPrecisionRuler_mem_FP + (machinePair_mem_FP + machineExecutableOptimizerTauCanonicalCode_mem_FP + (machinePair_mem_FP id_mem_FP + machineExecutableOptimizerBasePointCode_mem_FP))) + +@[simp] theorem machineExecutableOptimizerTauCanonicalCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineExecutableOptimizerTauCanonicalCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawRatOfRat (explicitRegularizationScale n)) := by + rw [machineExecutableOptimizerTauCanonicalCode, + machineOptimizerTauRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, rawOptimizerTau_value] + +@[simp] theorem machineExecutableOptimizerBasePointCode_encode {m : β„•} + (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerBasePointCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalFiniteVectorCode + (epigraphBase (executableScannedBetheOptimizerPoint A)) := by + let q := executableScannedBetheOptimizerPoint A + have hpointFull : machineExecutableOptimizerPointCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalFiniteVectorCode q := by + simpa only [machineExecutableOptimizerPointCode, q] using! + machineExplicitBetheOptimizerPointCode_encode hm A hApos hAupper + rw [machineExecutableOptimizerBasePointCode, hpointFull, + rationalFiniteVectorCode, ofFn_epigraph_center_split, + machineBinaryListInit_encode] + rfl + +@[simp] theorem machineExecutableOptimizerGradientSeed_encode {m : β„•} + (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerGradientSeed + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + machineDirectedObjectiveSumCanonicalWord + (explicitRegularizationScale (m + 1)) A + (epigraphBase (executableScannedBetheOptimizerPoint A)) + (explicitOptimizerPrecision A) := by + simp [machineExecutableOptimizerGradientSeed, + machineDirectedObjectiveSumCanonicalWord, + machineExecutableOptimizerBasePointCode_encode hm A hApos hAupper] + +/-! ## Bounded repeated-row generators for the potential vectors -/ + +/-- Bounds potential entries by six width expansions of a gradient seed padded with 4096 bits. -/ +def machineExecutableOptimizerPotentialBound + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 6 + (machineExecutableOptimizerGradientSeed word ++ + List.replicate 4096 false) + +/-- Packages the matrix-order ruler, potential-width bound, and gradient seed for potential +generation. -/ +def machineExecutableOptimizerPotentialGeneratorInput + (word : List Bool) : List Bool := + pair (machineMatrixDimensionUnary word) + (pair (machineExecutableOptimizerPotentialBound word) + (machineExecutableOptimizerGradientSeed word)) + +/-- Generates encoded rows using the row-potential entry evaluator. -/ +def machineExecutableOptimizerRowPotentialRowsCode + (word : List Bool) : List Bool := + machineUnaryMatrixGeneratorRowsCode + machineExecutableRowPotentialEntryCode + (machineExecutableOptimizerPotentialGeneratorInput word) + +/-- Generates encoded rows using the column-potential entry evaluator. -/ +def machineExecutableOptimizerColumnPotentialRowsCode + (word : List Bool) : List Bool := + machineUnaryMatrixGeneratorRowsCode + machineExecutableColumnPotentialEntryCode + (machineExecutableOptimizerPotentialGeneratorInput word) + +/-- Extracts the first generated row as the encoded vector of row potentials. -/ +def machineExecutableOptimizerRowPotentialCode + (word : List Bool) : List Bool := + machineListHead (machineExecutableOptimizerRowPotentialRowsCode word) + +/-- Extracts the first generated row as the encoded vector of column potentials. -/ +def machineExecutableOptimizerColumnPotentialCode + (word : List Bool) : List Bool := + machineListHead (machineExecutableOptimizerColumnPotentialRowsCode word) + +theorem machineExecutableOptimizerPotentialBound_mem_FP : + machineExecutableOptimizerPotentialBound ∈ FP := by + have hpadded := machineAppend_mem_FP + machineExecutableOptimizerGradientSeed_mem_FP + (machineConst_mem_FP (List.replicate 4096 false)) + simpa only [machineExecutableOptimizerPotentialBound] using! + machineCompose_mem_FP hpadded (machineIteratedBinaryWidth_mem_FP 6) + +theorem machineExecutableOptimizerPotentialGeneratorInput_mem_FP : + machineExecutableOptimizerPotentialGeneratorInput ∈ FP := + machinePair_mem_FP machineMatrixDimensionUnary_mem_FP + (machinePair_mem_FP machineExecutableOptimizerPotentialBound_mem_FP + machineExecutableOptimizerGradientSeed_mem_FP) + +theorem machineExecutableOptimizerRowPotentialRowsCode_mem_FP : + machineExecutableOptimizerRowPotentialRowsCode ∈ FP := by + have hgenerator := machineUnaryMatrixGeneratorRowsCode_mem_FP + machineExecutableRowPotentialEntryCode_mem_FP + simpa only [machineExecutableOptimizerRowPotentialRowsCode] using! + machineCompose_mem_FP + machineExecutableOptimizerPotentialGeneratorInput_mem_FP hgenerator + +theorem machineExecutableOptimizerColumnPotentialRowsCode_mem_FP : + machineExecutableOptimizerColumnPotentialRowsCode ∈ FP := by + have hgenerator := machineUnaryMatrixGeneratorRowsCode_mem_FP + machineExecutableColumnPotentialEntryCode_mem_FP + simpa only [machineExecutableOptimizerColumnPotentialRowsCode] using! + machineCompose_mem_FP + machineExecutableOptimizerPotentialGeneratorInput_mem_FP hgenerator + +theorem machineExecutableOptimizerRowPotentialCode_mem_FP : + machineExecutableOptimizerRowPotentialCode ∈ FP := by + simpa only [machineExecutableOptimizerRowPotentialCode] using! + machineCompose_mem_FP + machineExecutableOptimizerRowPotentialRowsCode_mem_FP + machineListHead_mem_FP + +theorem machineExecutableOptimizerColumnPotentialCode_mem_FP : + machineExecutableOptimizerColumnPotentialCode ∈ FP := by + simpa only [machineExecutableOptimizerColumnPotentialCode] using! + machineCompose_mem_FP + machineExecutableOptimizerColumnPotentialRowsCode_mem_FP + machineListHead_mem_FP + +/-! ## Ordinary bit bounds for the potential output -/ + +/-- The raw row potential `2 + tau - G(i,0)` obtained from the directed negative-gradient +approximation. -/ +def rawExecutableRowPotential {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (i : Fin (m + 1)) : RawRat := + (rawDirectedNegativeGradientLower tau (A i 0) + (betheAffineMatrixQ y i 0) p).neg.add + (rawOptimizerTwo.add (rawRatOfRat tau)) + +/-- The raw column potential `G(0,0) - G(0,j)` obtained from the directed negative-gradient +approximation. -/ +def rawExecutableColumnPotential {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (j : Fin (m + 1)) : RawRat := + (rawDirectedNegativeGradientLower tau (A 0 0) + (betheAffineMatrixQ y 0 0) p).sub + (rawDirectedNegativeGradientLower tau (A 0 j) + (betheAffineMatrixQ y 0 j) p) + +@[simp] theorem rawExecutableRowPotential_value {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (i : Fin (m + 1)) : + (rawExecutableRowPotential tau A y p i).value = + -directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i 0 + (2 + tau) := by + rw [rawExecutableRowPotential, RawRat.value_add, RawRat.value_neg, + machineDirectedNegativeGradientEntry_value, RawRat.value_add, + rawRatOfRat_value] + norm_num [rawOptimizerTwo, RawRat.ofNat, RawRat.value] + +@[simp] theorem rawExecutableColumnPotential_value {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (j : Fin (m + 1)) : + (rawExecutableColumnPotential tau A y p j).value = + -(directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 j - + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 0) := by + rw [rawExecutableColumnPotential, RawRat.value_sub, + machineDirectedNegativeGradientEntry_value, + machineDirectedNegativeGradientEntry_value] + ring + +theorem rawExecutableRowPotential_width_le_word_budget {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (i : Fin (m + 1)) : + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let B := rawDirectedObjectiveCoordinateWordBudget m L + rawRatWidth (rawExecutableRowPotential tau A y p i) ≀ + B + L + 4 := by + intro L B + have hgradient := rawDirectedNegativeGradientEntry_width_le_word_budget + tau A y p i 0 + have htau := rawDirectedObjectiveSum_tau_width_le_word tau A y p + have htwo : rawRatWidth rawOptimizerTwo = 2 := by + decide + have htwoTau := rawRatWidth_add_le rawOptimizerTwo (rawRatOfRat tau) + rw [htwo] at htwoTau + have hsum := rawRatWidth_add_le + (rawDirectedNegativeGradientLower tau (A i 0) + (betheAffineMatrixQ y i 0) p).neg + (rawOptimizerTwo.add (rawRatOfRat tau)) + rw [rawRatWidth_neg] at hsum + simpa only [rawExecutableRowPotential, L, B] using! hsum.trans (by omega) + +theorem rawExecutableColumnPotential_width_le_word_budget {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (j : Fin (m + 1)) : + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let B := rawDirectedObjectiveCoordinateWordBudget m L + rawRatWidth (rawExecutableColumnPotential tau A y p j) ≀ + 2 * B + 1 := by + intro L B + have horigin := rawDirectedNegativeGradientEntry_width_le_word_budget + tau A y p 0 0 + have hcolumn := rawDirectedNegativeGradientEntry_width_le_word_budget + tau A y p 0 j + have hsub := rawRatWidth_sub_le + (rawDirectedNegativeGradientLower tau (A 0 0) + (betheAffineMatrixQ y 0 0) p) + (rawDirectedNegativeGradientLower tau (A 0 j) + (betheAffineMatrixQ y 0 j) p) + simpa only [rawExecutableColumnPotential, L, B] using! hsub.trans (by omega) + +theorem executableRowPotential_entryCode_length_le {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (i : Fin (m + 1)) : + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let B := rawDirectedObjectiveCoordinateWordBudget m L + (rationalEntryBinaryCode + (-directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i 0 + (2 + tau))).length ≀ + 208 + 36 * B + 36 * L := by + intro L B + let raw := rawExecutableRowPotential tau A y p i + have hcanonical := rationalEntryBinaryCode_binaryNormalizeRawRat_length_le raw + rw [binaryNormalizeRawRat_eq_value, + rawExecutableRowPotential_value] at hcanonical + have hraw := rawExecutableRowPotential_width_le_word_budget tau A y p i + calc + _ ≀ 64 + 36 * rawRatWidth raw := hcanonical + _ ≀ 64 + 36 * (B + L + 4) := + Nat.add_le_add_left (Nat.mul_le_mul_left 36 hraw) 64 + _ = 208 + 36 * B + 36 * L := by ring + +theorem executableColumnPotential_entryCode_length_le {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) (j : Fin (m + 1)) : + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let B := rawDirectedObjectiveCoordinateWordBudget m L + (rationalEntryBinaryCode + (-(directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 j - + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 0))).length ≀ + 100 + 72 * B := by + intro L B + let raw := rawExecutableColumnPotential tau A y p j + have hcanonical := rationalEntryBinaryCode_binaryNormalizeRawRat_length_le raw + rw [binaryNormalizeRawRat_eq_value, + rawExecutableColumnPotential_value] at hcanonical + have hraw := rawExecutableColumnPotential_width_le_word_budget tau A y p j + calc + _ ≀ 64 + 36 * rawRatWidth raw := hcanonical + _ ≀ 64 + 36 * (2 * B + 1) := + Nat.add_le_add_left (Nat.mul_le_mul_left 36 hraw) 64 + _ = 100 + 72 * B := by ring + +theorem executableRepeatedPotential_rowsCode_fits_bound {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) + (v : Fin (m + 1) β†’ β„š) + (hentry : βˆ€ j, + let L := (machineDirectedObjectiveSumCanonicalWord tau A y p).length + let B := rawDirectedObjectiveCoordinateWordBudget m L + (rationalEntryBinaryCode (v j)).length ≀ + 208 + 72 * B + 36 * L) : + let seed := machineDirectedObjectiveSumCanonicalWord tau A y p + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows (fun _ j ↦ v j))).length ≀ + (machineIteratedBinaryWidth 6 + (seed ++ List.replicate 4096 false)).length := by + intro seed + let L := seed.length + let T := L + 16 + let B := rawDirectedObjectiveCoordinateWordBudget m L + let E := 208 + 72 * B + 36 * L + have hmL : m ≀ L := by + simp only [L, seed, machineDirectedObjectiveSumCanonicalWord, + pair_length, List.length_replicate] + omega + have hnL : m + 1 ≀ L := by + simp only [L, seed, machineDirectedObjectiveSumCanonicalWord, + pair_length, List.length_replicate] + omega + have hB : B ≀ T ^ 20 := by + simpa only [B, T] using! + rawDirectedObjectiveCoordinateWordBudget_le_pow hmL + have hTpos : 0 < T := by simp [T] + have hpow19 : 1 ≀ T ^ 19 := one_le_powβ‚€ (by omega) + have hTpow20 : T ≀ T ^ 20 := by + rw [show 20 = 19 + 1 by omega, pow_succ] + nlinarith + have hLpow20 : L ≀ T ^ 20 := + (by simp [T] : L ≀ T).trans hTpow20 + have hpow20 : 1 ≀ T ^ 20 := one_le_powβ‚€ (by omega) + have hE : E ≀ 128 * T ^ 20 := by + dsimp only [E] + omega + have hmatrix := unaryMatrixCode_length_le_of_entry_bound + (X := fun _ j ↦ v j) (E := E) (by + intro i j + simpa only [E, B, L, seed] using! hentry j) + have hnT : m + 1 ≀ T := hnL.trans (by simp [T]) + have hfactor : 2 * E + 2 ≀ 258 * T ^ 20 := by omega + have hn2 := Nat.mul_le_mul hnT hnT + have hmain := Nat.mul_le_mul hn2 hfactor + have hTpow22 : T ≀ T ^ 22 := by + have hpow21 : 1 ≀ T ^ 21 := one_le_powβ‚€ (by omega) + rw [show 22 = 21 + 1 by omega, pow_succ] + nlinarith + have hcoarse : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows (fun _ j ↦ v j))).length ≀ + 518 * T ^ 22 := by + apply hmatrix.trans + have hmain' : + (m + 1) * (m + 1) * (2 * E + 2) ≀ + 258 * T ^ 22 := by + calc + _ ≀ T * T * (258 * T ^ 20) := hmain + _ = 258 * T ^ 22 := by ring + calc + (m + 1) * (2 * ((m + 1) * (2 * E + 2)) + 2) = + 2 * ((m + 1) * (m + 1) * (2 * E + 2)) + + 2 * (m + 1) := by ring + _ ≀ 2 * (258 * T ^ 22) + 2 * T ^ 22 := by omega + _ = 518 * T ^ 22 := by ring + have hcoeff : 518 ≀ T ^ 3 := by + have hbase : 16 ≀ T := by simp [T] + have hpow := Nat.pow_le_pow_left hbase 3 + exact (by norm_num : 518 ≀ 16 ^ 3).trans hpow + have hpower25 : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows (fun _ j ↦ v j))).length ≀ T ^ 25 := by + calc + _ ≀ 518 * T ^ 22 := hcoarse + _ ≀ T ^ 3 * T ^ 22 := Nat.mul_le_mul_right _ hcoeff + _ = T ^ 25 := by ring + have hpower : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows (fun _ j ↦ v j))).length ≀ T ^ 64 := + hpower25.trans (Nat.pow_le_pow_right hTpos (by omega)) + rw [machineIteratedBinaryWidth_length] + apply hpower.trans + have hbase : L + 16 ≀ L + 4096 + 16 := by omega + have hpowBase := Nat.pow_le_pow_left hbase 64 + exact hpowBase.trans (by + simpa only [show 2 ^ (5 + 1) = 64 by norm_num, + List.length_append, List.length_replicate, T, L, seed] using! + certificateExpGuardWidth_pow_lower 5 (L + 4096)) + +theorem executableRowPotential_rowsCode_fits_bound {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + let seed := machineDirectedObjectiveSumCanonicalWord tau A y p + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows + (fun _ i ↦ -directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i 0 + (2 + tau)))).length ≀ + (machineIteratedBinaryWidth 6 + (seed ++ List.replicate 4096 false)).length := by + apply executableRepeatedPotential_rowsCode_fits_bound + intro i L B + have h := executableRowPotential_entryCode_length_le tau A y p i + simpa only [L, B] using! h.trans (by omega) + +theorem executableColumnPotential_rowsCode_fits_bound {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (y : Fin (m * m) β†’ β„š) (p : β„•) : + let seed := machineDirectedObjectiveSumCanonicalWord tau A y p + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows + (fun _ j ↦ -(directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 j - + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 0)))).length ≀ + (machineIteratedBinaryWidth 6 + (seed ++ List.replicate 4096 false)).length := by + apply executableRepeatedPotential_rowsCode_fits_bound + intro j L B + have h := executableColumnPotential_entryCode_length_le tau A y p j + simpa only [L, B] using! h.trans (by omega) + +@[simp] theorem machineListHead_unaryMatrixRows_repeated {n : β„•} + (hn : 0 < n) (v : Fin n β†’ β„š) : + machineListHead + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows (fun _ j ↦ v j))) = + rationalVectorBinaryCode v := by + cases n with + | zero => omega + | succ n => + simp [unaryMatrixRows, rationalVectorBinaryCode, + List.ofFn_succ, machineListHead_cons] + +@[simp] theorem machineExecutableOptimizerRowPotentialCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerRowPotentialCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalVectorBinaryCode + (executableScannedBetheOptimizerRowPotential A) := by + let word := rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ + let tau := explicitRegularizationScale (m + 1) + let p := explicitOptimizerPrecision A + let y := epigraphBase (executableScannedBetheOptimizerPoint A) + let seed := machineDirectedObjectiveSumCanonicalWord tau A y p + let bound := machineIteratedBinaryWidth 6 + (seed ++ List.replicate 4096 false) + let f : Fin (m + 1) β†’ Fin (m + 1) β†’ β„š := + fun _ i ↦ -directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p i 0 + (2 + tau) + have hseed : machineExecutableOptimizerGradientSeed word = seed := by + simpa only [word, seed, tau, y, p] using! + machineExecutableOptimizerGradientSeed_encode hm A hApos hAupper + have hinput : machineExecutableOptimizerPotentialGeneratorInput word = + machineUnaryMatrixGeneratorCanonicalWord (m + 1) bound seed := by + rw [machineExecutableOptimizerPotentialGeneratorInput] + rw [show machineMatrixDimensionUnary word = + List.replicate (m + 1) true by + simpa only [word] using! machineMatrixDimensionUnary_encode A] + rw [machineExecutableOptimizerPotentialBound, hseed] + rfl + have hentry : βˆ€ i j, + machineExecutableRowPotentialEntryCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) seed)) = + rationalEntryBinaryCode (f i j) := by + intro i j + simpa only [seed, tau, y, p, f] using! + machineExecutableRowPotentialEntryCode_encode tau A y p i j + have hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length := by + simpa only [f, bound, seed] using! + executableRowPotential_rowsCode_fits_bound tau A y p + rw [machineExecutableOptimizerRowPotentialCode, + machineExecutableOptimizerRowPotentialRowsCode, hinput, + machineUnaryMatrixGeneratorRowsCode_encode_of_bound + machineExecutableRowPotentialEntryCode f bound seed hentry hbound, + machineListHead_unaryMatrixRows_repeated (by omega)] + rfl + +@[simp] theorem machineExecutableOptimizerColumnPotentialCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableOptimizerColumnPotentialCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalVectorBinaryCode + (executableScannedBetheOptimizerColumnPotential A) := by + let word := rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ + let tau := explicitRegularizationScale (m + 1) + let p := explicitOptimizerPrecision A + let y := epigraphBase (executableScannedBetheOptimizerPoint A) + let seed := machineDirectedObjectiveSumCanonicalWord tau A y p + let bound := machineIteratedBinaryWidth 6 + (seed ++ List.replicate 4096 false) + let f : Fin (m + 1) β†’ Fin (m + 1) β†’ β„š := + fun _ j ↦ -(directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 j - + directedNegativeGradientLowerMatrix tau A + (betheAffineMatrixQ y) p 0 0) + have hseed : machineExecutableOptimizerGradientSeed word = seed := by + simpa only [word, seed, tau, y, p] using! + machineExecutableOptimizerGradientSeed_encode hm A hApos hAupper + have hinput : machineExecutableOptimizerPotentialGeneratorInput word = + machineUnaryMatrixGeneratorCanonicalWord (m + 1) bound seed := by + rw [machineExecutableOptimizerPotentialGeneratorInput] + rw [show machineMatrixDimensionUnary word = + List.replicate (m + 1) true by + simpa only [word] using! machineMatrixDimensionUnary_encode A] + rw [machineExecutableOptimizerPotentialBound, hseed] + rfl + have hentry : βˆ€ i j, + machineExecutableColumnPotentialEntryCode + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) seed)) = + rationalEntryBinaryCode (f i j) := by + intro i j + simpa only [seed, tau, y, p, f] using! + machineExecutableColumnPotentialEntryCode_encode tau A y p i j + have hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length := by + simpa only [f, bound, seed] using! + executableColumnPotential_rowsCode_fits_bound tau A y p + rw [machineExecutableOptimizerColumnPotentialCode, + machineExecutableOptimizerColumnPotentialRowsCode, hinput, + machineUnaryMatrixGeneratorRowsCode_encode_of_bound + machineExecutableColumnPotentialEntryCode f bound seed hentry hbound, + machineListHead_unaryMatrixRows_repeated (by omega)] + rfl + +/-! ## Complete optimizer output word -/ + +/-- Collects the scanned optimizer's matrix, row potentials, and column potentials into one +output. -/ +def executableScannedOptimizerOutput {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + RationalOptimizerOutput (m + 1) where + matrix := executableScannedBetheOptimizerMatrix A + rowPotential := executableScannedBetheOptimizerRowPotential A + columnPotential := executableScannedBetheOptimizerColumnPotential A + +/-- Encodes the executable scanned optimizer's matrix and both potential vectors. -/ +def machineExecutableScannedOptimizerOutputCode + (word : List Bool) : List Bool := + pair (machineExecutableOptimizerMatrixCode word) + (pair (machineExecutableOptimizerRowPotentialCode word) + (machineExecutableOptimizerColumnPotentialCode word)) + +theorem machineExecutableScannedOptimizerOutputCode_mem_FP : + machineExecutableScannedOptimizerOutputCode ∈ FP := + machinePair_mem_FP machineExecutableOptimizerMatrixCode_mem_FP + (machinePair_mem_FP machineExecutableOptimizerRowPotentialCode_mem_FP + machineExecutableOptimizerColumnPotentialCode_mem_FP) + +@[simp] theorem machineExecutableScannedOptimizerOutputCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) : + machineExecutableScannedOptimizerOutputCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rationalOptimizerOutputCode (executableScannedOptimizerOutput A) := by + rw [machineExecutableScannedOptimizerOutputCode, + machineExecutableOptimizerMatrixCode_encode hm A hApos hAupper, + machineExecutableOptimizerRowPotentialCode_encode hm A hApos hAupper, + machineExecutableOptimizerColumnPotentialCode_encode hm A hApos hAupper] + rfl + +/-- Dimension-at-least-two specialization used by the positive routine. -/ +def executableLargeOptimizerOutput (m : β„•) + (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) : + RationalOptimizerOutput (m + 2) := + executableScannedOptimizerOutput (m := m + 1) B + +/-- Requires a string function to encode the specified optimizer output on positive matrices of +order at least two. -/ +def ExecutableLargeOptimizerStringRealizes + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + F (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) = + rationalOptimizerOutputCode (executableLargeOptimizerOutput m B) + +theorem machineExecutableScannedOptimizerOutputCode_realizes : + ExecutableLargeOptimizerStringRealizes + machineExecutableScannedOptimizerOutputCode := by + intro m B hBpos hBupper + simpa only [executableLargeOptimizerOutput, Nat.add_assoc, + Nat.add_comm, Nat.add_left_comm] using! + machineExecutableScannedOptimizerOutputCode_encode + (m := m + 1) (by omega) B hBpos hBupper + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineExplicitCertificate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineExplicitCertificate.lean new file mode 100644 index 0000000000..9eef639dc8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineExplicitCertificate.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatchingGain + +/-! +# The complete finite-word certificate evaluator + +This module composes the verified fixed-gain greedy matching transducer, the +directed logarithmic certificate arithmetic, and the polynomial exponential +guard. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- The explicit certificate evaluator using the matching gain and bounded exponential guard. -/ +def machineExplicitCertificateValueRawCode : List Bool β†’ List Bool := + machineCertificateValueRawCode machineExplicitMatchingGainRawCode + machineOptimizerCertificateExpGuard + +theorem machineExplicitCertificateValueRawCode_mem_FP : + machineExplicitCertificateValueRawCode ∈ Complexity.FP := by + simpa only [machineExplicitCertificateValueRawCode] using! + machineCertificateValueRawCode_mem_FP + machineExplicitMatchingGainRawCode_mem_FP + machineOptimizerCertificateExpGuard_mem_FP + +theorem machineExplicitCertificateValueRawCode_realizes_onPositive : + CertificateEvaluatorStringRealizesOnPositiveNormalized + machineExplicitCertificateValueRawCode := by + simpa only [machineExplicitCertificateValueRawCode] using! + machineCertificateValueRawCode_realizes_onPositive + machineExplicitMatchingGainRawCode_realizes + machineOptimizerCertificateExpGuard_fits_onPositiveNormalized + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineFPBasics.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineFPBasics.lean new file mode 100644 index 0000000000..a2f7a024d4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineFPBasics.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineEncoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reverse + +/-! +# Small verified polynomial-time bitstring combinators + +These lemmas are a thin project-local surface over Complexitylib's concrete +Turing machines and Cobham soundness theorem. They are used to assemble the +arithmetic and dynamic-state machines below without appealing to a semantic +"all Lean programs are efficient" principle. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +theorem machineConst_mem_FP (word : List Bool) : + (fun _ : List Bool => word) ∈ Complexity.FP := by + exact CobhamFP_subset_FP (Cobham.const word) + +theorem machinePrepend_mem_FP (bit : Bool) : + (fun word : List Bool => bit :: word) ∈ Complexity.FP := by + exact Cobham.cons_mem_FP bit + +theorem machineTail_mem_FP : + (fun word : List Bool => word.tail) ∈ Complexity.FP := by + exact CobhamFP_subset_FP Cobham.tail + +theorem machineReverse_mem_FP : + List.reverse ∈ Complexity.FP := by + exact reverse_mem_FP + +/-- Replace every input bit by zero while preserving the input length. -/ +theorem machineZeroBlock_mem_FP : + (fun word : List Bool => List.replicate word.length false) ∈ + Complexity.FP := by + exact CobhamFP_subset_FP Cobham.lengthPad + +theorem machineCompose_mem_FP {f g : List Bool β†’ List Bool} + (hf : f ∈ Complexity.FP) (hg : g ∈ Complexity.FP) : + (fun word => g (f word)) ∈ Complexity.FP := by + simpa only [Function.comp_apply] using! mem_FP_comp hf hg + +theorem machinePair_mem_FP {left right : List Bool β†’ List Bool} + (hleft : left ∈ Complexity.FP) (hright : right ∈ Complexity.FP) : + (fun word => pair (left word) (right word)) ∈ Complexity.FP := by + exact Cobham.pairFn_mem_FP hleft hright + +theorem machineAppend_mem_FP {left right : List Bool β†’ List Bool} + (hleft : left ∈ Complexity.FP) (hright : right ∈ Complexity.FP) : + (fun word => left word ++ right word) ∈ Complexity.FP := by + exact Cobham.appendFn_mem_FP hleft hright + +/-- Take a prefix of one computed word whose length is another computed word. -/ +theorem machineTake_mem_FP {ruler data : List Bool β†’ List Bool} + (hruler : ruler ∈ Complexity.FP) (hdata : data ∈ Complexity.FP) : + (fun word => (data word).take (ruler word).length) ∈ Complexity.FP := by + exact CobhamFP_subset_FP + (Cobham.takeFn (FP_subset_CobhamFP hruler) (FP_subset_CobhamFP hdata)) + +/-- Select by the leading bit of a verified bitstring computation. -/ +def machineIfHead (flag whenTrue whenFalse : List Bool) : List Bool := + Cobham.selectHead flag whenTrue whenFalse + +theorem machineIfHead_mem_FP + {flag whenTrue whenFalse : List Bool β†’ List Bool} + (hflag : flag ∈ Complexity.FP) + (htrue : whenTrue ∈ Complexity.FP) + (hfalse : whenFalse ∈ Complexity.FP) : + (fun word => machineIfHead (flag word) + (whenTrue word) (whenFalse word)) ∈ Complexity.FP := by + exact Cobham.selectHeadFn_mem_FP hflag htrue hfalse + +@[simp] theorem machineIfHead_true (tail whenTrue whenFalse : List Bool) : + machineIfHead (true :: tail) whenTrue whenFalse = whenTrue := by + simp [machineIfHead, Cobham.selectHead] + +@[simp] theorem machineIfHead_false (tail whenTrue whenFalse : List Bool) : + machineIfHead (false :: tail) whenTrue whenFalse = whenFalse := by + simp [machineIfHead, Cobham.selectHead] + +/-- Select the first branch exactly when `test` is empty. -/ +def machineIfEmpty (test whenEmpty whenNonempty : List Bool) : List Bool := + Cobham.selectHead (Cobham.emptyFlag test) whenEmpty whenNonempty + +theorem machineIfEmpty_mem_FP + {test whenEmpty whenNonempty : List Bool β†’ List Bool} + (htest : test ∈ Complexity.FP) + (hempty : whenEmpty ∈ Complexity.FP) + (hnonempty : whenNonempty ∈ Complexity.FP) : + (fun word => machineIfEmpty (test word) + (whenEmpty word) (whenNonempty word)) ∈ Complexity.FP := by + exact Cobham.selectHeadFn_mem_FP (Cobham.emptyFlag_mem_FP htest) + hempty hnonempty + +@[simp] theorem machineIfEmpty_nil (whenEmpty whenNonempty : List Bool) : + machineIfEmpty [] whenEmpty whenNonempty = whenEmpty := by + exact Cobham.selectHead_emptyFlag_nil _ _ + +@[simp] theorem machineIfEmpty_cons (bit : Bool) (tail whenEmpty whenNonempty : List Bool) : + machineIfEmpty (bit :: tail) whenEmpty whenNonempty = whenNonempty := by + exact Cobham.selectHead_emptyFlag_cons bit tail _ _ + +/-- One-bit word equal to the head of `word`, defaulting to `false` on the +empty word. -/ +def machineHeadBit (word : List Bool) : List Bool := + machineIfEmpty word [false] + (machineIfHead word [true] [false]) + +theorem machineHeadBit_mem_FP : machineHeadBit ∈ Complexity.FP := by + apply machineIfEmpty_mem_FP id_mem_FP + (machineConst_mem_FP [false]) + exact machineIfHead_mem_FP id_mem_FP + (machineConst_mem_FP [true]) (machineConst_mem_FP [false]) + +@[simp] theorem machineHeadBit_nil : machineHeadBit [] = [false] := by + rfl + +@[simp] theorem machineHeadBit_cons (bit : Bool) (tail : List Bool) : + machineHeadBit (bit :: tail) = [bit] := by + cases bit <;> simp [machineHeadBit] + +@[simp] theorem machineHeadBit_length (word : List Bool) : + (machineHeadBit word).length = 1 := by + cases word <;> simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineFactorial.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineFactorial.lean new file mode 100644 index 0000000000..b7efc812a0 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineFactorial.lean @@ -0,0 +1,331 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries + +/-! +# Unary-input factorial in the finite-word machine model + +The input length is the natural number whose factorial is required. The +state stores the current factorial, the next multiplier, and a quadratic +clamp. Both evolving fields are clamped on malformed inputs; the ordinary +binary-size proof shows that neither clamp fires on a unary ruler. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes factorial state as accumulated product, next factor, and width bound. -/ +def machineFactorialPack (acc next bound : List Bool) : List Bool := + pair acc (pair next bound) + +/-- Extracts the accumulated product from a factorial state. -/ +def machineFactorialAcc (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the next factor from a factorial state. -/ +def machineFactorialNext (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the width-bound ruler stored in a factorial state. -/ +def machineFactorialBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Increments the next factorial factor in binary. -/ +def machineFactorialSuccessor (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineFactorialNext state) (1 : β„•).bits) + +/-- Multiplies the accumulated product by the next factorial factor. -/ +def machineFactorialCandidate (state : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineFactorialAcc state) (machineFactorialNext state)) + +/-- Truncates the candidate factorial product to the stored width bound. -/ +def machineFactorialNextAcc (state : List Bool) : List Bool := + (machineFactorialCandidate state).take (machineFactorialBound state).length + +/-- Truncates the incremented factorial counter to the stored width bound. -/ +def machineFactorialNextCounter (state : List Bool) : List Bool := + (machineFactorialSuccessor state).take (machineFactorialBound state).length + +/-- Updates the bounded factorial product and counter while retaining the width ruler. -/ +def machineFactorialStep (state : List Bool) : List Bool := + machineFactorialPack (machineFactorialNextAcc state) + (machineFactorialNextCounter state) (machineFactorialBound state) + +/-- Uses the binary-multiplication width constructor to bound factorial state components. -/ +def machineFactorialInputBound (ruler : List Bool) : List Bool := + machineBinaryMulWidth ruler + +/-- Initializes the factorial accumulator and next factor to one with the input-derived width +bound. -/ +def machineFactorialInit (ruler : List Bool) : List Bool := + machineFactorialPack (1 : β„•).bits (1 : β„•).bits + (machineFactorialInputBound ruler) + +/-- Packs three copies of the input bound to bound the encoded factorial state. -/ +def machineFactorialWidth (ruler : List Bool) : List Bool := + let bound := machineFactorialInputBound ruler + machineFactorialPack bound bound bound + +/-- Runs one factorial step per bit of the unary input ruler. -/ +def machineFactorialFinalState (ruler : List Bool) : List Bool := + (machineFactorialStep)^[ruler.length] (machineFactorialInit ruler) + +/-- Extracts the factorial accumulator after all ruler-specified iterations. -/ +def machineFactorialBits (ruler : List Bool) : List Bool := + machineFactorialAcc (machineFactorialFinalState ruler) + +/-- Encodes the final factorial accumulator as a nonnegative raw rational with denominator one. -/ +def machineFactorialRawRatCode (ruler : List Bool) : List Bool := + pair (false :: machineFactorialBits ruler) (1 : β„•).bits + +theorem machineFactorialAcc_mem_FP : + machineFactorialAcc ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineFactorialNext_mem_FP : + machineFactorialNext ∈ Complexity.FP := by + simpa only [machineFactorialNext] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineFactorialBound_mem_FP : + machineFactorialBound ∈ Complexity.FP := by + simpa only [machineFactorialBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineFactorialSuccessor_mem_FP : + machineFactorialSuccessor ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineFactorialNext_mem_FP + (machineConst_mem_FP (1 : β„•).bits) + simpa only [machineFactorialSuccessor] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineFactorialCandidate_mem_FP : + machineFactorialCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineFactorialAcc_mem_FP + machineFactorialNext_mem_FP + simpa only [machineFactorialCandidate] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineFactorialNextAcc_mem_FP : + machineFactorialNextAcc ∈ Complexity.FP := by + simpa only [machineFactorialNextAcc] using! + machineTake_mem_FP machineFactorialBound_mem_FP + machineFactorialCandidate_mem_FP + +theorem machineFactorialNextCounter_mem_FP : + machineFactorialNextCounter ∈ Complexity.FP := by + simpa only [machineFactorialNextCounter] using! + machineTake_mem_FP machineFactorialBound_mem_FP + machineFactorialSuccessor_mem_FP + +theorem machineFactorialStep_mem_FP : + machineFactorialStep ∈ Complexity.FP := by + exact machinePair_mem_FP machineFactorialNextAcc_mem_FP + (machinePair_mem_FP machineFactorialNextCounter_mem_FP + machineFactorialBound_mem_FP) + +theorem machineFactorialInputBound_mem_FP : + machineFactorialInputBound ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineFactorialInit_mem_FP : + machineFactorialInit ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP (1 : β„•).bits) + (machinePair_mem_FP (machineConst_mem_FP (1 : β„•).bits) + machineFactorialInputBound_mem_FP) + +theorem machineFactorialWidth_mem_FP : + machineFactorialWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineFactorialInputBound_mem_FP + (machinePair_mem_FP machineFactorialInputBound_mem_FP + machineFactorialInputBound_mem_FP) + +@[simp] theorem machineFactorialAcc_pack (acc next bound) : + machineFactorialAcc (machineFactorialPack acc next bound) = acc := by + simp [machineFactorialAcc, machineFactorialPack] + +@[simp] theorem machineFactorialNext_pack (acc next bound) : + machineFactorialNext (machineFactorialPack acc next bound) = next := by + simp [machineFactorialNext, machineFactorialPack] + +@[simp] theorem machineFactorialBound_pack (acc next bound) : + machineFactorialBound (machineFactorialPack acc next bound) = bound := by + simp [machineFactorialBound, machineFactorialPack] + +/-- Bounds all three components of a canonically packed factorial state by the input-derived +width. -/ +def MachineFactorialStateBound (ruler state : List Bool) : Prop := + let B := (machineFactorialInputBound ruler).length + state = machineFactorialPack (machineFactorialAcc state) + (machineFactorialNext state) (machineFactorialBound state) ∧ + (machineFactorialAcc state).length ≀ B ∧ + (machineFactorialNext state).length ≀ B ∧ + (machineFactorialBound state).length ≀ B + +theorem machineFactorial_one_le_bound (ruler : List Bool) : + (1 : β„•).bits.length ≀ (machineFactorialInputBound ruler).length := by + simp [machineFactorialInputBound, machineBinaryMulWidth] + +theorem machineFactorialInit_bound (ruler : List Bool) : + MachineFactorialStateBound ruler (machineFactorialInit ruler) := by + simp only [MachineFactorialStateBound, machineFactorialInit, + machineFactorialAcc_pack, machineFactorialNext_pack, + machineFactorialBound_pack] + exact ⟨trivial, machineFactorial_one_le_bound ruler, + machineFactorial_one_le_bound ruler, le_rfl⟩ + +theorem machineFactorialStep_bound {ruler state : List Bool} + (hstate : MachineFactorialStateBound ruler state) : + MachineFactorialStateBound ruler (machineFactorialStep state) := by + dsimp only [MachineFactorialStateBound] at hstate ⊒ + rcases hstate with ⟨hpack, hacc, hnext, hbound⟩ + simp only [machineFactorialStep, machineFactorialAcc_pack, + machineFactorialNext_pack, machineFactorialBound_pack] + refine ⟨trivial, ?_, ?_, hbound⟩ + Β· exact (List.length_take_le _ _).trans hbound + Β· exact (List.length_take_le _ _).trans hbound + +theorem machineFactorialIterate_bound (ruler : List Bool) : βˆ€ k, + MachineFactorialStateBound ruler + ((machineFactorialStep)^[k] (machineFactorialInit ruler)) := by + intro k + induction k with + | zero => exact machineFactorialInit_bound ruler + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineFactorialStep_bound ih + +theorem machineFactorialIterate_length_le_width + (ruler : List Bool) (iterations : β„•) (_ : iterations ≀ ruler.length) : + ((machineFactorialStep)^[iterations] + (machineFactorialInit ruler)).length ≀ + (machineFactorialWidth ruler).length := by + have hstate := machineFactorialIterate_bound ruler iterations + dsimp only [MachineFactorialStateBound] at hstate + rcases hstate with ⟨hpack, hacc, hnext, hbound⟩ + rw [hpack] + simp only [machineFactorialPack, machineFactorialWidth, pair_length] + omega + +theorem machineFactorialFinalState_mem_FP : + machineFactorialFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineFactorialStep_mem_FP + machineFactorialInit_mem_FP id_mem_FP machineFactorialWidth_mem_FP + machineFactorialIterate_length_le_width + +theorem machineFactorialBits_mem_FP : + machineFactorialBits ∈ Complexity.FP := by + simpa only [machineFactorialBits] using! + machineCompose_mem_FP machineFactorialFinalState_mem_FP + machineFactorialAcc_mem_FP + +theorem machineFactorialRawRatCode_mem_FP : + machineFactorialRawRatCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineFactorialBits_mem_FP + (machinePrepend_mem_FP false) + exact machinePair_mem_FP hnum (machineConst_mem_FP (1 : β„•).bits) + +/-! ## Exact semantics on unary rulers -/ + +theorem factorial_bits_length_le_bound {n k : β„•} (hk : k ≀ n) : + k.factorial.bits.length ≀ + (machineFactorialInputBound (List.replicate n true)).length := by + rw [Nat.size_eq_bits_len, Nat.size_le] + have hfac : k.factorial ≀ 2 ^ (k ^ 2) := by + calc + k.factorial ≀ k ^ k := Nat.factorial_le_pow k + _ ≀ (2 ^ k) ^ k := Nat.pow_le_pow_left k.lt_two_pow_self.le k + _ = 2 ^ (k ^ 2) := by simp [pow_mul, pow_two] + have hsq : k ^ 2 ≀ n ^ 2 := Nat.pow_le_pow_left hk 2 + have hpow : 2 ^ (k ^ 2) ≀ 2 ^ (n ^ 2) := + Nat.pow_le_pow_right (by decide) hsq + have hexponent : n ^ 2 < (16 + n) * (16 + n) := by + nlinarith + have hstrict : 2 ^ (n ^ 2) < 2 ^ ((16 + n) * (16 + n)) := + (Nat.pow_lt_pow_iff_right (by omega)).2 hexponent + have hlength : + (machineFactorialInputBound (List.replicate n true)).length = + (16 + n) * (16 + n) := by + simp only [machineFactorialInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + rw [hlength] + exact hfac.trans_lt (hpow.trans_lt hstrict) + +theorem factorial_counter_bits_length_le_bound {n k : β„•} + (hk : k ≀ n + 1) : + k.bits.length ≀ + (machineFactorialInputBound (List.replicate n true)).length := by + have hbits : k.bits.length ≀ k := by + rw [Nat.size_eq_bits_len, Nat.size_le] + exact k.lt_two_pow_self + have hlength : + (machineFactorialInputBound (List.replicate n true)).length = + (16 + n) * (16 + n) := by + simp only [machineFactorialInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + rw [hlength] + exact hbits.trans <| by nlinarith + +/-- Encodes the semantic state after `k` factorial steps, with product `k!` and next factor `k + +1`. -/ +def machineFactorialSemanticState (n k : β„•) : List Bool := + machineFactorialPack k.factorial.bits (k + 1).bits + (machineFactorialInputBound (List.replicate n true)) + +@[simp] theorem machineFactorialSemanticState_zero (n : β„•) : + machineFactorialSemanticState n 0 = + machineFactorialInit (List.replicate n true) := by + simp [machineFactorialSemanticState, machineFactorialInit] + +theorem machineFactorialSemanticState_step (n k : β„•) (hk : k < n) : + machineFactorialStep (machineFactorialSemanticState n k) = + machineFactorialSemanticState n (k + 1) := by + have hfac := factorial_bits_length_le_bound (show k + 1 ≀ n by omega) + have hcounter := factorial_counter_bits_length_le_bound + (show k + 2 ≀ n + 1 by omega) + simp only [machineFactorialStep, machineFactorialSemanticState, + machineFactorialNextAcc, machineFactorialCandidate, + machineFactorialAcc_pack, machineFactorialNext_pack, + machineFactorialBound_pack, machineBinaryMulBits_pair_natBits, + machineFactorialNextCounter, machineFactorialSuccessor, + machineBinaryAddBits_pair_natBits] + rw [(List.take_eq_self_iff _).2 (by + simpa [Nat.factorial_succ, Nat.mul_comm] using! hfac), + (List.take_eq_self_iff _).2 hcounter] + simp [Nat.factorial_succ, Nat.mul_comm, Nat.add_assoc] + +theorem machineFactorialIterate_semantics (n : β„•) : βˆ€ k ≀ n, + (machineFactorialStep)^[k] + (machineFactorialInit (List.replicate n true)) = + machineFactorialSemanticState n k := by + intro k hk + induction k with + | zero => exact (machineFactorialSemanticState_zero n).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineFactorialSemanticState_step n k (by omega) + +@[simp] theorem machineFactorialBits_encode (n : β„•) : + machineFactorialBits (List.replicate n true) = n.factorial.bits := by + rw [machineFactorialBits, machineFactorialFinalState] + simp only [List.length_replicate] + rw [machineFactorialIterate_semantics n n le_rfl] + simp [machineFactorialSemanticState] + +@[simp] theorem machineFactorialRawRatCode_encode (n : β„•) : + machineFactorialRawRatCode (List.replicate n true) = + rawRatBinaryCode (RawRat.ofNat n.factorial) := by + simp [machineFactorialRawRatCode, rawRatBinaryCode, RawRat.ofNat, + integerBinaryCode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineFinalScalars.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineFinalScalars.lean new file mode 100644 index 0000000000..fed8e454d5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineFinalScalars.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalization +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmallDimension +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly + +/-! +# Connections between scalar machines and the completed algorithm +-/ + +@[expose] public section + +namespace BeyondBethe + +@[simp] theorem machineMatrixNonnegativeBit_finalDecision {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNonnegativeBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [rationalMatrixNonnegativeDecision A] := by + rw [machineMatrixNonnegativeBit_encode] + apply congrArg singleton + apply Bool.eq_iff_iff.mpr + simp [rationalMatrixNonnegativeDecision, Matrix.Nonnegative] + +@[simp] theorem machineMatrixNormalizationScaleOutputCode_final {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScaleOutputCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (rationalNormalizationScale A) := by + simpa only [rationalNormalizationScale] using! + machineMatrixNormalizationScaleOutputCode_encode A + +@[simp] theorem machineMatrixNormalizationScalePowerOutputCode_final {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScalePowerOutputCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (rationalNormalizationScale A ^ n) := by + simpa only [rationalNormalizationScale] using! + machineMatrixNormalizationScalePowerOutputCode_encode A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineFourCoreCost.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineFourCoreCost.lean new file mode 100644 index 0000000000..e9f6601479 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineFourCoreCost.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedTransferCost + +/-! +# The four-core directed cost as a finite-word function + +The input is +`pair rUnary (pair sUnary (pair aUnary (pair bUnary optimizerWord)))`. +The output is the unreduced rational sum of the four directed transfer-cost +endpoints used by the executable row-pair certificate. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary first-row index from a four-core cost query. -/ +def machineFourCoreFirstRowRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the four-core query payload following the first-row index. -/ +def machineFourCoreRest₁ (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary second-row index from a four-core cost query. -/ +def machineFourCoreSecondRowRuler (word : List Bool) : List Bool := + machinePairFirst (machineFourCoreRest₁ word) + +/-- Extracts the four-core query payload following both row indices. -/ +def machineFourCoreRestβ‚‚ (word : List Bool) : List Bool := + machinePairSecond (machineFourCoreRest₁ word) + +/-- Extracts the unary first-column index from a four-core cost query. -/ +def machineFourCoreFirstColumnRuler (word : List Bool) : List Bool := + machinePairFirst (machineFourCoreRestβ‚‚ word) + +/-- Extracts the four-core query payload following the first-column index. -/ +def machineFourCoreRest₃ (word : List Bool) : List Bool := + machinePairSecond (machineFourCoreRestβ‚‚ word) + +/-- Extracts the unary second-column index from a four-core cost query. -/ +def machineFourCoreSecondColumnRuler (word : List Bool) : List Bool := + machinePairFirst (machineFourCoreRest₃ word) + +/-- Extracts the optimizer matrix and potentials from the four-core query. -/ +def machineFourCoreOptimizerWord (word : List Bool) : List Bool := + machinePairSecond (machineFourCoreRest₃ word) + +/-- Packages a row index, column index, and optimizer result for transfer-cost evaluation. -/ +def machineFourCoreTransferInput + (row column optimizer : List Bool) : List Bool := + pair row (pair column optimizer) + +/-- Computes the directed transfer-cost upper approximation at the first row and first column. -/ +def machineFourCoreRACostRawCode (word : List Bool) : List Bool := + machineDirectedTransferCostUpperRawCode + (machineFourCoreTransferInput + (machineFourCoreFirstRowRuler word) + (machineFourCoreFirstColumnRuler word) + (machineFourCoreOptimizerWord word)) + +/-- Computes the directed transfer-cost upper approximation at the first row and second column. -/ +def machineFourCoreRBCostRawCode (word : List Bool) : List Bool := + machineDirectedTransferCostUpperRawCode + (machineFourCoreTransferInput + (machineFourCoreFirstRowRuler word) + (machineFourCoreSecondColumnRuler word) + (machineFourCoreOptimizerWord word)) + +/-- Computes the directed transfer-cost upper approximation at the second row and first column. -/ +def machineFourCoreSACostRawCode (word : List Bool) : List Bool := + machineDirectedTransferCostUpperRawCode + (machineFourCoreTransferInput + (machineFourCoreSecondRowRuler word) + (machineFourCoreFirstColumnRuler word) + (machineFourCoreOptimizerWord word)) + +/-- Computes the directed transfer-cost upper approximation at the second row and second column. -/ +def machineFourCoreSBCostRawCode (word : List Bool) : List Bool := + machineDirectedTransferCostUpperRawCode + (machineFourCoreTransferInput + (machineFourCoreSecondRowRuler word) + (machineFourCoreSecondColumnRuler word) + (machineFourCoreOptimizerWord word)) + +/-- Adds the two directed transfer-cost approximations in the first selected row. -/ +def machineFourCoreFirstRowSumRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineFourCoreRACostRawCode word) + (machineFourCoreRBCostRawCode word)) + +/-- Adds the two directed transfer-cost approximations in the second selected row. -/ +def machineFourCoreSecondRowSumRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineFourCoreSACostRawCode word) + (machineFourCoreSBCostRawCode word)) + +/-- Unreduced raw-rational code for the directed four-core cost. -/ +def machineDirectedFourCoreCostUpperRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineFourCoreFirstRowSumRawCode word) + (machineFourCoreSecondRowSumRawCode word)) + +theorem machineFourCoreFirstRowRuler_mem_FP : + machineFourCoreFirstRowRuler ∈ FP := machinePairFirst_mem_FP + +theorem machineFourCoreRest₁_mem_FP : machineFourCoreRest₁ ∈ FP := + machinePairSecond_mem_FP + +theorem machineFourCoreSecondRowRuler_mem_FP : + machineFourCoreSecondRowRuler ∈ FP := by + simpa only [machineFourCoreSecondRowRuler] using! machineCompose_mem_FP + machineFourCoreRest₁_mem_FP machinePairFirst_mem_FP + +theorem machineFourCoreRestβ‚‚_mem_FP : machineFourCoreRestβ‚‚ ∈ FP := by + simpa only [machineFourCoreRestβ‚‚] using! machineCompose_mem_FP + machineFourCoreRest₁_mem_FP machinePairSecond_mem_FP + +theorem machineFourCoreFirstColumnRuler_mem_FP : + machineFourCoreFirstColumnRuler ∈ FP := by + simpa only [machineFourCoreFirstColumnRuler] using! machineCompose_mem_FP + machineFourCoreRestβ‚‚_mem_FP machinePairFirst_mem_FP + +theorem machineFourCoreRest₃_mem_FP : machineFourCoreRest₃ ∈ FP := by + simpa only [machineFourCoreRest₃] using! machineCompose_mem_FP + machineFourCoreRestβ‚‚_mem_FP machinePairSecond_mem_FP + +theorem machineFourCoreSecondColumnRuler_mem_FP : + machineFourCoreSecondColumnRuler ∈ FP := by + simpa only [machineFourCoreSecondColumnRuler] using! machineCompose_mem_FP + machineFourCoreRest₃_mem_FP machinePairFirst_mem_FP + +theorem machineFourCoreOptimizerWord_mem_FP : + machineFourCoreOptimizerWord ∈ FP := by + simpa only [machineFourCoreOptimizerWord] using! machineCompose_mem_FP + machineFourCoreRest₃_mem_FP machinePairSecond_mem_FP + +theorem machineFourCoreTransferInput_mem_FP + {row column optimizer : List Bool β†’ List Bool} + (hrow : row ∈ FP) (hcolumn : column ∈ FP) (hoptimizer : optimizer ∈ FP) : + (fun word ↦ machineFourCoreTransferInput + (row word) (column word) (optimizer word)) ∈ FP := by + exact machinePair_mem_FP hrow (machinePair_mem_FP hcolumn hoptimizer) + +theorem machineFourCoreRACostRawCode_mem_FP : + machineFourCoreRACostRawCode ∈ FP := by + have hinput := machineFourCoreTransferInput_mem_FP + machineFourCoreFirstRowRuler_mem_FP machineFourCoreFirstColumnRuler_mem_FP + machineFourCoreOptimizerWord_mem_FP + simpa only [machineFourCoreRACostRawCode] using! machineCompose_mem_FP hinput + machineDirectedTransferCostUpperRawCode_mem_FP + +theorem machineFourCoreRBCostRawCode_mem_FP : + machineFourCoreRBCostRawCode ∈ FP := by + have hinput := machineFourCoreTransferInput_mem_FP + machineFourCoreFirstRowRuler_mem_FP machineFourCoreSecondColumnRuler_mem_FP + machineFourCoreOptimizerWord_mem_FP + simpa only [machineFourCoreRBCostRawCode] using! machineCompose_mem_FP hinput + machineDirectedTransferCostUpperRawCode_mem_FP + +theorem machineFourCoreSACostRawCode_mem_FP : + machineFourCoreSACostRawCode ∈ FP := by + have hinput := machineFourCoreTransferInput_mem_FP + machineFourCoreSecondRowRuler_mem_FP machineFourCoreFirstColumnRuler_mem_FP + machineFourCoreOptimizerWord_mem_FP + simpa only [machineFourCoreSACostRawCode] using! machineCompose_mem_FP hinput + machineDirectedTransferCostUpperRawCode_mem_FP + +theorem machineFourCoreSBCostRawCode_mem_FP : + machineFourCoreSBCostRawCode ∈ FP := by + have hinput := machineFourCoreTransferInput_mem_FP + machineFourCoreSecondRowRuler_mem_FP machineFourCoreSecondColumnRuler_mem_FP + machineFourCoreOptimizerWord_mem_FP + simpa only [machineFourCoreSBCostRawCode] using! machineCompose_mem_FP hinput + machineDirectedTransferCostUpperRawCode_mem_FP + +theorem machineFourCoreFirstRowSumRawCode_mem_FP : + machineFourCoreFirstRowSumRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineFourCoreRACostRawCode_mem_FP + machineFourCoreRBCostRawCode_mem_FP + simpa only [machineFourCoreFirstRowSumRawCode] using! machineCompose_mem_FP + hinput machineRawRatAddCode_mem_FP + +theorem machineFourCoreSecondRowSumRawCode_mem_FP : + machineFourCoreSecondRowSumRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineFourCoreSACostRawCode_mem_FP + machineFourCoreSBCostRawCode_mem_FP + simpa only [machineFourCoreSecondRowSumRawCode] using! machineCompose_mem_FP + hinput machineRawRatAddCode_mem_FP + +theorem machineDirectedFourCoreCostUpperRawCode_mem_FP : + machineDirectedFourCoreCostUpperRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineFourCoreFirstRowSumRawCode_mem_FP + machineFourCoreSecondRowSumRawCode_mem_FP + simpa only [machineDirectedFourCoreCostUpperRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +/-- Adds the four raw directed transfer-cost approximations at the selected row-column corners. -/ +def rawDirectedFourCoreCostUpper {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s a b : Fin n) : RawRat := + ((rawDirectedTransferCostUpper X r a).add + (rawDirectedTransferCostUpper X r b)).add + ((rawDirectedTransferCostUpper X s a).add + (rawDirectedTransferCostUpper X s b)) + +/-- Encodes four unary indices together with a matrix and its potentials for four-core +evaluation. -/ +def fourCoreMachineInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : List Bool := + pair (List.replicate r.1 true) + (pair (List.replicate s.1 true) + (pair (List.replicate a.1 true) + (pair (List.replicate b.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)))) + +@[simp] theorem machineFourCoreRACostRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : + machineFourCoreRACostRawCode (fourCoreMachineInput X R C r s a b) = + rawRatBinaryCode (rawDirectedTransferCostUpper X r a) := by + simp [machineFourCoreRACostRawCode, machineFourCoreTransferInput, + fourCoreMachineInput, machineFourCoreFirstRowRuler, + machineFourCoreFirstColumnRuler, machineFourCoreOptimizerWord, + machineFourCoreRest₁, machineFourCoreRestβ‚‚, machineFourCoreRest₃] + +@[simp] theorem machineFourCoreRBCostRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : + machineFourCoreRBCostRawCode (fourCoreMachineInput X R C r s a b) = + rawRatBinaryCode (rawDirectedTransferCostUpper X r b) := by + simp [machineFourCoreRBCostRawCode, machineFourCoreTransferInput, + fourCoreMachineInput, machineFourCoreFirstRowRuler, + machineFourCoreSecondColumnRuler, machineFourCoreOptimizerWord, + machineFourCoreRest₁, machineFourCoreRestβ‚‚, machineFourCoreRest₃] + +@[simp] theorem machineFourCoreSACostRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : + machineFourCoreSACostRawCode (fourCoreMachineInput X R C r s a b) = + rawRatBinaryCode (rawDirectedTransferCostUpper X s a) := by + simp [machineFourCoreSACostRawCode, machineFourCoreTransferInput, + fourCoreMachineInput, machineFourCoreSecondRowRuler, + machineFourCoreFirstColumnRuler, machineFourCoreOptimizerWord, + machineFourCoreRest₁, machineFourCoreRestβ‚‚, machineFourCoreRest₃] + +@[simp] theorem machineFourCoreSBCostRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : + machineFourCoreSBCostRawCode (fourCoreMachineInput X R C r s a b) = + rawRatBinaryCode (rawDirectedTransferCostUpper X s b) := by + simp [machineFourCoreSBCostRawCode, machineFourCoreTransferInput, + fourCoreMachineInput, machineFourCoreSecondRowRuler, + machineFourCoreSecondColumnRuler, machineFourCoreOptimizerWord, + machineFourCoreRest₁, machineFourCoreRestβ‚‚, machineFourCoreRest₃] + +@[simp] theorem machineDirectedFourCoreCostUpperRawCode_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (r s a b : Fin n) : + machineDirectedFourCoreCostUpperRawCode + (fourCoreMachineInput X R C r s a b) = + rawRatBinaryCode (rawDirectedFourCoreCostUpper X r s a b) := by + rw [machineDirectedFourCoreCostUpperRawCode, + machineFourCoreFirstRowSumRawCode, machineFourCoreSecondRowSumRawCode, + machineFourCoreRACostRawCode_encode, machineFourCoreRBCostRawCode_encode, + machineRawRatAddCode_encode, machineFourCoreSACostRawCode_encode, + machineFourCoreSBCostRawCode_encode, machineRawRatAddCode_encode, + machineRawRatAddCode_encode] + rfl + +theorem rawDirectedFourCoreCostUpper_value {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (r s a b : Fin n) : + (rawDirectedFourCoreCostUpper X r s a b).value = + directedFourCoreCostUpper (explicitRegularizationScale n) X r s a b + (directedPairCostPrecision n) := by + simp only [rawDirectedFourCoreCostUpper, directedFourCoreCostUpper, + RawRat.value_add, rawDirectedTransferCostUpper_value, + directedCertificatePrecision_eq_pairCostPrecision] + ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineGreedyRowMatching.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineGreedyRowMatching.lean new file mode 100644 index 0000000000..58bc902e36 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineGreedyRowMatching.lean @@ -0,0 +1,1913 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRowPairDisjoint + +/-! +# The deterministic greedy row matcher as a finite-word function + +The matcher scans rows and columns in reverse lexicographic order, exactly the +order induced by `greedyRowMatchingList`. Its state stores the selected +ordered row pairs as a self-delimiting list. Disjointness is delegated to the +verified list scanner, avoiding a separate mutable-memory invariant. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the matrix-dimension ruler from the optimizer result for greedy row matching. -/ +def machineMatchingDimensionRuler (optimizer : List Bool) : List Bool := + machineCertificateDimensionUnary optimizer + +/-- Encodes all candidate row indices in increasing order. -/ +def machineMatchingForwardRange (optimizer : List Bool) : List Bool := + machineUnaryRangeCode (machineMatchingDimensionRuler optimizer) + +/-- Reverses the candidate-row list for the greedy scan order. -/ +def machineMatchingReverseRange (optimizer : List Bool) : List Bool := + machineListReverse (machineMatchingForwardRange optimizer) + +theorem machineMatchingDimensionRuler_mem_FP : + machineMatchingDimensionRuler ∈ FP := + machineCertificateDimensionUnary_mem_FP + +theorem machineMatchingForwardRange_mem_FP : + machineMatchingForwardRange ∈ FP := by + simpa only [machineMatchingForwardRange] using! machineCompose_mem_FP + machineMatchingDimensionRuler_mem_FP machineUnaryRangeCode_mem_FP + +theorem machineMatchingReverseRange_mem_FP : + machineMatchingReverseRange ∈ FP := by + simpa only [machineMatchingReverseRange] using! machineCompose_mem_FP + machineMatchingForwardRange_mem_FP machineListReverse_mem_FP + +@[simp] theorem machineMatchingDimensionRuler_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineMatchingDimensionRuler (rationalOptimizerOutputCode ⟨X, R, C⟩) = + List.replicate n true := by + exact machineCertificateDimensionUnary_encode X R C + +@[simp] theorem machineMatchingForwardRange_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineMatchingForwardRange (rationalOptimizerOutputCode ⟨X, R, C⟩) = + finRangeUnaryCode n := by + rw [machineMatchingForwardRange, machineMatchingDimensionRuler_encode, + machineUnaryRangeCode_encode] + +@[simp] theorem machineMatchingReverseRange_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineMatchingReverseRange (rationalOptimizerOutputCode ⟨X, R, C⟩) = + binaryListCode finUnaryCode (List.finRange n).reverse := by + rw [machineMatchingReverseRange, machineMatchingForwardRange_encode] + exact machineListReverse_encode finUnaryCode (List.finRange n) + +/-! ## The inner scan over second rows -/ + +/-- Inner input: `pair iUnary (pair selectedList optimizerWord)`. -/ +def machineMatchingInnerFirstRow (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the initial selected pairs and optimizer payload from an inner matching query. -/ +def machineMatchingInnerRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the initially selected row pairs from an inner matching query. -/ +def machineMatchingInnerSelectedInput (word : List Bool) : List Bool := + machinePairFirst (machineMatchingInnerRest word) + +/-- Extracts the optimizer result from an inner matching query. -/ +def machineMatchingInnerOptimizer (word : List Bool) : List Bool := + machinePairSecond (machineMatchingInnerRest word) + +/-- Encodes an inner matching state as remaining candidates, selected pairs, and source query. -/ +def machineMatchingInnerPack + (remaining selected source : List Bool) : List Bool := + pair remaining (pair selected source) + +/-- Extracts the unprocessed second-row candidates from the inner matching state. -/ +def machineMatchingInnerRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the currently selected row pairs from the inner matching state. -/ +def machineMatchingInnerSelected (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the original inner matching query from the state. -/ +def machineMatchingInnerSource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the first unprocessed second-row candidate. -/ +def machineMatchingInnerCurrentSecondRow (state : List Bool) : List Bool := + machineListHead (machineMatchingInnerRemaining state) + +/-- Tests whether the fixed first-row index is smaller than the current second-row index. -/ +def machineMatchingInnerFirstLessSecondBit (state : List Bool) : List Bool := + machineBinaryNatLtBit + (pair (machineLengthBits + (machineMatchingInnerFirstRow (machineMatchingInnerSource state))) + (machineLengthBits (machineMatchingInnerCurrentSecondRow state))) + +/-- Packages the current row pair and optimizer result for certified eligibility testing. -/ +def machineMatchingInnerEligibilityInput (state : List Bool) : List Bool := + pair (machineMatchingInnerFirstRow (machineMatchingInnerSource state)) + (pair (machineMatchingInnerCurrentSecondRow state) + (machineMatchingInnerOptimizer (machineMatchingInnerSource state))) + +/-- Tests certified eligibility of the current row pair. -/ +def machineMatchingInnerEligibleBit (state : List Bool) : List Bool := + machineCertifiedRowPairEligibilityBit + (machineMatchingInnerEligibilityInput state) + +/-- Packages the current row pair and selected pairs for a disjointness test. -/ +def machineMatchingInnerDisjointInput (state : List Bool) : List Bool := + pair (machineMatchingInnerFirstRow (machineMatchingInnerSource state)) + (pair (machineMatchingInnerCurrentSecondRow state) + (machineMatchingInnerSelected state)) + +/-- Tests whether the current row pair is disjoint from all selected pairs. -/ +def machineMatchingInnerDisjointBit (state : List Bool) : List Bool := + machineRowPairDisjointBit (machineMatchingInnerDisjointInput state) + +/-- Selects a candidate only when its rows are ordered, it is certified eligible, and it is +disjoint. -/ +def machineMatchingInnerSelectBit (state : List Bool) : List Bool := + machineAndBit (machineMatchingInnerFirstLessSecondBit state) + (machineAndBit (machineMatchingInnerEligibleBit state) + (machineMatchingInnerDisjointBit state)) + +/-- Prepends the current row pair to the encoded selected-pair list. -/ +def machineMatchingInnerSelectedCandidate (state : List Bool) : List Bool := + pair (pair (machineMatchingInnerFirstRow (machineMatchingInnerSource state)) + (machineMatchingInnerCurrentSecondRow state)) + (machineMatchingInnerSelected state) + +/-- Bounds inner matching state by twice expanding the query paired with its reverse row range. -/ +def machineMatchingInnerInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth + (pair word (machineMatchingReverseRange + (machineMatchingInnerOptimizer word)))) + +/-- Reads the inner state bound derived from the stored source query. -/ +def machineMatchingInnerBound (state : List Bool) : List Bool := + machineMatchingInnerInputBound (machineMatchingInnerSource state) + +/-- Truncates the candidate selected-pair list to the inner state bound. -/ +def machineMatchingInnerSelectedCandidateClamped + (state : List Bool) : List Bool := + (machineMatchingInnerSelectedCandidate state).take + (machineMatchingInnerBound state).length + +/-- Uses the bounded candidate list when the selection test succeeds, retaining the old list +otherwise. -/ +def machineMatchingInnerNextSelected (state : List Bool) : List Bool := + machineIfHead (machineMatchingInnerSelectBit state) + (machineMatchingInnerSelectedCandidateClamped state) + (machineMatchingInnerSelected state) + +/-- Consumes one second-row candidate and conditionally updates the selected pairs. -/ +def machineMatchingInnerProcess (state : List Bool) : List Bool := + machineMatchingInnerPack + (machineListTail (machineMatchingInnerRemaining state)) + (machineMatchingInnerNextSelected state) + (machineMatchingInnerSource state) + +/-- Processes the next second-row candidate, leaving an exhausted inner scan fixed. -/ +def machineMatchingInnerStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatchingInnerRemaining state) state + (machineMatchingInnerProcess state) + +/-- Initializes the inner scan with reverse-ordered candidates and the supplied selected pairs. -/ +def machineMatchingInnerInit (word : List Bool) : List Bool := + machineMatchingInnerPack + (machineMatchingReverseRange (machineMatchingInnerOptimizer word)) + (machineMatchingInnerSelectedInput word) word + +/-- Packs three copies of the inner bound to bound the complete encoded state. -/ +def machineMatchingInnerWidth (word : List Bool) : List Bool := + let bound := machineMatchingInnerInputBound word + machineMatchingInnerPack bound bound bound + +/-- Runs the inner matching scan once per row of the optimizer matrix. -/ +def machineMatchingInnerFinalState (word : List Bool) : List Bool := + (machineMatchingInnerStep)^[(machineMatchingDimensionRuler + (machineMatchingInnerOptimizer word)).length] + (machineMatchingInnerInit word) + +/-- Extracts the selected-pair list after the complete inner scan. -/ +def machineMatchingInnerOutputSelected (word : List Bool) : List Bool := + machineMatchingInnerSelected (machineMatchingInnerFinalState word) + +theorem machineMatchingInnerFirstRow_mem_FP : + machineMatchingInnerFirstRow ∈ FP := machinePairFirst_mem_FP + +theorem machineMatchingInnerRest_mem_FP : machineMatchingInnerRest ∈ FP := + machinePairSecond_mem_FP + +theorem machineMatchingInnerSelectedInput_mem_FP : + machineMatchingInnerSelectedInput ∈ FP := by + simpa only [machineMatchingInnerSelectedInput] using! machineCompose_mem_FP + machineMatchingInnerRest_mem_FP machinePairFirst_mem_FP + +theorem machineMatchingInnerOptimizer_mem_FP : + machineMatchingInnerOptimizer ∈ FP := by + simpa only [machineMatchingInnerOptimizer] using! machineCompose_mem_FP + machineMatchingInnerRest_mem_FP machinePairSecond_mem_FP + +theorem machineMatchingInnerRemaining_mem_FP : + machineMatchingInnerRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineMatchingInnerSelected_mem_FP : + machineMatchingInnerSelected ∈ FP := by + simpa only [machineMatchingInnerSelected] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatchingInnerSource_mem_FP : machineMatchingInnerSource ∈ FP := by + simpa only [machineMatchingInnerSource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineMatchingInnerCurrentSecondRow_mem_FP : + machineMatchingInnerCurrentSecondRow ∈ FP := by + simpa only [machineMatchingInnerCurrentSecondRow] using! machineCompose_mem_FP + machineMatchingInnerRemaining_mem_FP machineListHead_mem_FP + +theorem machineMatchingInnerFirstLessSecondBit_mem_FP : + machineMatchingInnerFirstLessSecondBit ∈ FP := by + have hfirst := machineCompose_mem_FP + (machineCompose_mem_FP machineMatchingInnerSource_mem_FP + machineMatchingInnerFirstRow_mem_FP) machineLengthBits_mem_FP + have hsecond := machineCompose_mem_FP + machineMatchingInnerCurrentSecondRow_mem_FP machineLengthBits_mem_FP + have hinput := machinePair_mem_FP hfirst hsecond + simpa only [machineMatchingInnerFirstLessSecondBit] using! + machineCompose_mem_FP hinput machineBinaryNatLtBit_mem_FP + +theorem machineMatchingInnerEligibilityInput_mem_FP : + machineMatchingInnerEligibilityInput ∈ FP := by + have hfirst := machineCompose_mem_FP machineMatchingInnerSource_mem_FP + machineMatchingInnerFirstRow_mem_FP + have hoptimizer := machineCompose_mem_FP machineMatchingInnerSource_mem_FP + machineMatchingInnerOptimizer_mem_FP + exact machinePair_mem_FP hfirst + (machinePair_mem_FP machineMatchingInnerCurrentSecondRow_mem_FP hoptimizer) + +theorem machineMatchingInnerEligibleBit_mem_FP : + machineMatchingInnerEligibleBit ∈ FP := by + simpa only [machineMatchingInnerEligibleBit] using! machineCompose_mem_FP + machineMatchingInnerEligibilityInput_mem_FP + machineCertifiedRowPairEligibilityBit_mem_FP + +theorem machineMatchingInnerDisjointInput_mem_FP : + machineMatchingInnerDisjointInput ∈ FP := by + have hfirst := machineCompose_mem_FP machineMatchingInnerSource_mem_FP + machineMatchingInnerFirstRow_mem_FP + exact machinePair_mem_FP hfirst + (machinePair_mem_FP machineMatchingInnerCurrentSecondRow_mem_FP + machineMatchingInnerSelected_mem_FP) + +theorem machineMatchingInnerDisjointBit_mem_FP : + machineMatchingInnerDisjointBit ∈ FP := by + simpa only [machineMatchingInnerDisjointBit] using! machineCompose_mem_FP + machineMatchingInnerDisjointInput_mem_FP machineRowPairDisjointBit_mem_FP + +theorem machineMatchingInnerSelectBit_mem_FP : + machineMatchingInnerSelectBit ∈ FP := + machineAndBit_mem_FP machineMatchingInnerFirstLessSecondBit_mem_FP + (machineAndBit_mem_FP machineMatchingInnerEligibleBit_mem_FP + machineMatchingInnerDisjointBit_mem_FP) + +theorem machineMatchingInnerSelectedCandidate_mem_FP : + machineMatchingInnerSelectedCandidate ∈ FP := by + have hfirst := machineCompose_mem_FP machineMatchingInnerSource_mem_FP + machineMatchingInnerFirstRow_mem_FP + exact machinePair_mem_FP + (machinePair_mem_FP hfirst machineMatchingInnerCurrentSecondRow_mem_FP) + machineMatchingInnerSelected_mem_FP + +theorem machineMatchingInnerInputBound_mem_FP : + machineMatchingInnerInputBound ∈ FP := by + have hoptimizerRange := machineCompose_mem_FP + machineMatchingInnerOptimizer_mem_FP machineMatchingReverseRange_mem_FP + have hbase := machinePair_mem_FP id_mem_FP hoptimizerRange + have hfirstWidth : + (fun word => machineBinaryMulWidth + (pair word (machineMatchingReverseRange + (machineMatchingInnerOptimizer word)))) ∈ FP := + machineCompose_mem_FP hbase machineBinaryMulWidth_mem_FP + simpa only [machineMatchingInnerInputBound] using! + machineCompose_mem_FP hfirstWidth machineBinaryMulWidth_mem_FP + +theorem machineMatchingInnerBound_mem_FP : machineMatchingInnerBound ∈ FP := by + simpa only [machineMatchingInnerBound] using! machineCompose_mem_FP + machineMatchingInnerSource_mem_FP machineMatchingInnerInputBound_mem_FP + +theorem machineMatchingInnerSelectedCandidateClamped_mem_FP : + machineMatchingInnerSelectedCandidateClamped ∈ FP := by + simpa only [machineMatchingInnerSelectedCandidateClamped] using! + machineTake_mem_FP machineMatchingInnerBound_mem_FP + machineMatchingInnerSelectedCandidate_mem_FP + +theorem machineMatchingInnerNextSelected_mem_FP : + machineMatchingInnerNextSelected ∈ FP := by + exact machineIfHead_mem_FP machineMatchingInnerSelectBit_mem_FP + machineMatchingInnerSelectedCandidateClamped_mem_FP + machineMatchingInnerSelected_mem_FP + +theorem machineMatchingInnerProcess_mem_FP : + machineMatchingInnerProcess ∈ FP := by + have htail := machineCompose_mem_FP machineMatchingInnerRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineMatchingInnerNextSelected_mem_FP + machineMatchingInnerSource_mem_FP) + +theorem machineMatchingInnerStep_mem_FP : machineMatchingInnerStep ∈ FP := by + simpa only [machineMatchingInnerStep] using! machineIfEmpty_mem_FP + machineMatchingInnerRemaining_mem_FP id_mem_FP + machineMatchingInnerProcess_mem_FP + +theorem machineMatchingInnerInit_mem_FP : machineMatchingInnerInit ∈ FP := by + have hrange := machineCompose_mem_FP machineMatchingInnerOptimizer_mem_FP + machineMatchingReverseRange_mem_FP + exact machinePair_mem_FP hrange + (machinePair_mem_FP machineMatchingInnerSelectedInput_mem_FP id_mem_FP) + +theorem machineMatchingInnerWidth_mem_FP : machineMatchingInnerWidth ∈ FP := + machinePair_mem_FP machineMatchingInnerInputBound_mem_FP + (machinePair_mem_FP machineMatchingInnerInputBound_mem_FP + machineMatchingInnerInputBound_mem_FP) + +@[simp] theorem machineMatchingInnerRemaining_pack (remaining selected source) : + machineMatchingInnerRemaining + (machineMatchingInnerPack remaining selected source) = remaining := by + simp [machineMatchingInnerRemaining, machineMatchingInnerPack] + +@[simp] theorem machineMatchingInnerSelected_pack (remaining selected source) : + machineMatchingInnerSelected + (machineMatchingInnerPack remaining selected source) = selected := by + simp [machineMatchingInnerSelected, machineMatchingInnerPack] + +@[simp] theorem machineMatchingInnerSource_pack (remaining selected source) : + machineMatchingInnerSource + (machineMatchingInnerPack remaining selected source) = source := by + simp [machineMatchingInnerSource, machineMatchingInnerPack] + +/-- Bounds the inner scan's remaining and selected lists while preserving its source query. -/ +def MachineMatchingInnerStateBound (word state : List Bool) : Prop := + let B := (machineMatchingInnerInputBound word).length + state = machineMatchingInnerPack (machineMatchingInnerRemaining state) + (machineMatchingInnerSelected state) (machineMatchingInnerSource state) ∧ + (machineMatchingInnerRemaining state).length ≀ B ∧ + (machineMatchingInnerSelected state).length ≀ B ∧ + machineMatchingInnerSource state = word + +theorem machineMatchingInner_base_le_bound (word : List Bool) : + (pair word (machineMatchingReverseRange + (machineMatchingInnerOptimizer word))).length ≀ + (machineMatchingInnerInputBound word).length := by + simp only [machineMatchingInnerInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineMatchingInner_word_le_bound (word : List Bool) : + word.length ≀ (machineMatchingInnerInputBound word).length := by + simpa only [machinePairFirst_pair] using! (machinePairFirst_length_le + (pair word (machineMatchingReverseRange + (machineMatchingInnerOptimizer word)))).trans + (machineMatchingInner_base_le_bound word) + +theorem machineMatchingInner_range_le_bound (word : List Bool) : + (machineMatchingReverseRange + (machineMatchingInnerOptimizer word)).length ≀ + (machineMatchingInnerInputBound word).length := by + simpa only [machinePairSecond_pair] using! (machinePairSecond_length_le + (pair word (machineMatchingReverseRange + (machineMatchingInnerOptimizer word)))).trans + (machineMatchingInner_base_le_bound word) + +theorem machineMatchingInner_selectedInput_le_bound (word : List Bool) : + (machineMatchingInnerSelectedInput word).length ≀ + (machineMatchingInnerInputBound word).length := by + exact ((machinePairFirst_length_le (machineMatchingInnerRest word)).trans + (machinePairSecond_length_le word)).trans + (machineMatchingInner_word_le_bound word) + +theorem machineMatchingInnerInit_bound (word : List Bool) : + MachineMatchingInnerStateBound word (machineMatchingInnerInit word) := by + simp only [MachineMatchingInnerStateBound, machineMatchingInnerInit, + machineMatchingInnerRemaining_pack, machineMatchingInnerSelected_pack, + machineMatchingInnerSource_pack] + exact ⟨trivial, machineMatchingInner_range_le_bound word, + machineMatchingInner_selectedInput_le_bound word, trivial⟩ + +theorem machineMatchingInnerStep_bound {word state : List Bool} + (hstate : MachineMatchingInnerStateBound word state) : + MachineMatchingInnerStateBound word (machineMatchingInnerStep state) := by + rcases hstate with ⟨hpack, hremaining, hselected, hsource⟩ + by_cases hrem : machineMatchingInnerRemaining state = [] + Β· rw [machineMatchingInnerStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hselected, hsource⟩ + Β· rw [machineMatchingInnerStep] + cases hcode : machineMatchingInnerRemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatchingInnerProcess] + simp only [MachineMatchingInnerStateBound, + machineMatchingInnerRemaining_pack, machineMatchingInnerSelected_pack, + machineMatchingInnerSource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineMatchingInnerRemaining state)).trans hremaining + Β· rw [machineMatchingInnerNextSelected] + cases hs : machineMatchingInnerSelectBit state with + | nil => + simpa [machineIfHead, Cobham.selectHead] using! hselected + | cons select rest => + cases select with + | false => + simpa using! hselected + | true => + simp only [machineIfHead_true, + machineMatchingInnerSelectedCandidateClamped, + List.length_take] + rw [machineMatchingInnerBound, hsource] + exact Nat.min_le_left _ _ + +theorem machineMatchingInnerIterate_bound (word : List Bool) : βˆ€ k, + MachineMatchingInnerStateBound word + ((machineMatchingInnerStep)^[k] (machineMatchingInnerInit word)) := by + intro k + induction k with + | zero => exact machineMatchingInnerInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatchingInnerStep_bound ih + +theorem machineMatchingInnerIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineMatchingDimensionRuler + (machineMatchingInnerOptimizer word)).length) : + ((machineMatchingInnerStep)^[iterations] + (machineMatchingInnerInit word)).length ≀ + (machineMatchingInnerWidth word).length := by + rcases machineMatchingInnerIterate_bound word iterations with + ⟨hpack, hremaining, hselected, hsource⟩ + have hsourceLength : (machineMatchingInnerSource + ((machineMatchingInnerStep)^[iterations] + (machineMatchingInnerInit word))).length ≀ + (machineMatchingInnerInputBound word).length := by + rw [hsource] + exact machineMatchingInner_word_le_bound word + rw [hpack] + simp only [machineMatchingInnerPack, machineMatchingInnerWidth, pair_length] + omega + +theorem machineMatchingInnerFinalState_mem_FP : + machineMatchingInnerFinalState ∈ FP := by + have hruler := machineCompose_mem_FP machineMatchingInnerOptimizer_mem_FP + machineMatchingDimensionRuler_mem_FP + exact Cobham.iterate_mem_FP machineMatchingInnerStep_mem_FP + machineMatchingInnerInit_mem_FP hruler machineMatchingInnerWidth_mem_FP + machineMatchingInnerIterate_length_le_width + +theorem machineMatchingInnerOutputSelected_mem_FP : + machineMatchingInnerOutputSelected ∈ FP := by + simpa only [machineMatchingInnerOutputSelected] using! machineCompose_mem_FP + machineMatchingInnerFinalState_mem_FP machineMatchingInnerSelected_mem_FP + +/-! ## Canonical one-step facts -/ + +/-- Encodes the fixed first row, initial selected pairs, matrix, and potentials for an inner +scan. -/ +def matchingInnerMachineInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (selected : List (Fin n Γ— Fin n)) : List Bool := + pair (finUnaryCode i) + (pair (binaryListCode orderedRowPairCode selected) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) + +@[simp] theorem machineMatchingInnerOptimizer_matchingInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineMatchingInnerOptimizer + (matchingInnerMachineInput X R C i selected) = + rationalOptimizerOutputCode ⟨X, R, C⟩ := by + simp [machineMatchingInnerOptimizer, machineMatchingInnerRest, + matchingInnerMachineInput] + +@[simp] theorem machineMatchingInnerSelectedInput_matchingInput {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineMatchingInnerSelectedInput + (matchingInnerMachineInput X R C i selected) = + binaryListCode orderedRowPairCode selected := by + simp [machineMatchingInnerSelectedInput, machineMatchingInnerRest, + matchingInnerMachineInput] + +@[simp] theorem machineMatchingInnerFirstRow_canonical {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) + (remaining stateSelected : List Bool) : + machineMatchingInnerFirstRow (machineMatchingInnerSource + (machineMatchingInnerPack remaining + stateSelected + (matchingInnerMachineInput X R C i sourceSelected))) = + finUnaryCode i := by + simp [machineMatchingInnerFirstRow, machineMatchingInnerSource, + machineMatchingInnerPack, matchingInnerMachineInput] + +@[simp] theorem machineMatchingInnerOptimizer_canonical {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) + (remaining stateSelected : List Bool) : + machineMatchingInnerOptimizer (machineMatchingInnerSource + (machineMatchingInnerPack remaining + stateSelected + (matchingInnerMachineInput X R C i sourceSelected))) = + rationalOptimizerOutputCode ⟨X, R, C⟩ := by + simp [machineMatchingInnerOptimizer, machineMatchingInnerRest, + machineMatchingInnerSource, machineMatchingInnerPack, + matchingInnerMachineInput] + +@[simp] theorem machineMatchingInnerCurrentSecondRow_canonical {n : β„•} + (j : Fin n) (js : List (Fin n)) (selected source : List Bool) : + machineMatchingInnerCurrentSecondRow + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + selected source) = finUnaryCode j := by + simp [machineMatchingInnerCurrentSecondRow, + machineMatchingInnerRemaining, machineMatchingInnerPack] + +@[simp] theorem machineMatchingInnerSelected_canonical {n : β„•} + (j : Fin n) (js : List (Fin n)) + (selected : List (Fin n Γ— Fin n)) (source : List Bool) : + machineMatchingInnerSelected + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) source) = + binaryListCode orderedRowPairCode selected := by + simp [machineMatchingInnerSelected, machineMatchingInnerPack] + +@[simp] theorem machineMatchingInnerFirstLessSecondBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerFirstLessSecondBit + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + [decide (i < j)] := by + rw [machineMatchingInnerFirstLessSecondBit] + simp only [machineMatchingInnerFirstRow_canonical, + machineMatchingInnerCurrentSecondRow_canonical, + machineLengthBits_encode, finUnaryCode, List.length_replicate] + exact machineBinaryNatLtBit_pair_natBits i.val j.val + +@[simp] theorem machineMatchingInnerEligibilityInput_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerEligibilityInput + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + certifiedRowPairMachineInput X R C i j := by + simp only [machineMatchingInnerEligibilityInput, + machineMatchingInnerFirstRow_canonical, + machineMatchingInnerCurrentSecondRow_canonical, + machineMatchingInnerOptimizer_canonical, + certifiedRowPairMachineInput] + +@[simp] theorem machineMatchingInnerEligibleBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) + (hij : i < j) : + machineMatchingInnerEligibleBit + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + [decide (HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) + (rowPairOfLT i j hij))] := by + rw [machineMatchingInnerEligibleBit, + machineMatchingInnerEligibilityInput_encode] + have hinput : certifiedRowPairMachineInput X R C i j = + certifiedRowPairEligibilityMachineInput X R C + (rowPairOfLT i j hij) := by + simp [certifiedRowPairEligibilityMachineInput, + rowPairRow_rowPairOfLT_zero, rowPairRow_rowPairOfLT_one] + rw [hinput, machineCertifiedRowPairEligibilityBit_encode] + +@[simp] theorem machineMatchingInnerDisjointInput_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerDisjointInput + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + machineDisjointInput i j selected := by + simp only [machineMatchingInnerDisjointInput, + machineMatchingInnerFirstRow_canonical, + machineMatchingInnerCurrentSecondRow_canonical, + machineMatchingInnerSelected_canonical, machineDisjointInput] + +@[simp] theorem machineMatchingInnerDisjointBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerDisjointBit + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + [!orderedPairsConflict i j selected] := by + rw [machineMatchingInnerDisjointBit, + machineMatchingInnerDisjointInput_encode] + exact machineRowPairDisjointBit_encode i j selected + +/-! ## Pure semantics of one inner pass -/ + +/-- The mathematical update performed on one ordered candidate. The first +test fixes the canonical orientation, the second is the certified four-core +test, and the third says that neither endpoint has already been selected. -/ +def certifiedGreedyOrderedStep {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (Fin n Γ— Fin n)) (j : Fin n) : + List (Fin n Γ— Fin n) := + if hij : i < j then + if HasCertifiedCorePair (explicitRegularizationScale n) X explicitKappa + (directedPairCostPrecision n) (rowPairOfLT i j hij) ∧ + orderedPairsConflict i j selected = false then + (i, j) :: selected + else selected + else selected + +@[simp] theorem machineMatchingInnerSelectBit_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerSelectBit + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + [if hij : i < j then + decide (HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) + (rowPairOfLT i j hij) ∧ + orderedPairsConflict i j selected = false) + else false] := by + by_cases hij : i < j + Β· rw [machineMatchingInnerSelectBit, + machineMatchingInnerFirstLessSecondBit_encode, + machineMatchingInnerEligibleBit_encode X R C i j sourceSelected + selected js hij, + machineMatchingInnerDisjointBit_encode, + machineAndBit_one, machineAndBit_one] + simp [hij] + Β· rw [machineMatchingInnerSelectBit, + machineMatchingInnerFirstLessSecondBit_encode] + simp [hij, machineAndBit, machineIfHead, Cobham.selectHead] + +theorem orderedRowPairCode_length_lt_three_mul {n : β„•} + (i j : Fin n) : + (orderedRowPairCode (i, j)).length < 3 * n := by + simp only [orderedRowPairCode, pair_length, finUnaryCode, + List.length_replicate] + omega + +theorem binaryListCode_ordered_cons_length_le {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : + (binaryListCode orderedRowPairCode ((i, j) :: selected)).length ≀ + (binaryListCode orderedRowPairCode selected).length + 6 * n := by + rw [binaryListCode, pair_length] + have h := orderedRowPairCode_length_lt_three_mul i j + omega + +/-- Fold the one-candidate update over a list of possible second rows. -/ +def certifiedGreedyOrderedScan {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (Fin n Γ— Fin n)) (js : List (Fin n)) : + List (Fin n Γ— Fin n) := + js.foldl (certifiedGreedyOrderedStep X i) selected + +theorem certifiedGreedyOrderedScan_code_length_le {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (Fin n Γ— Fin n)) (js : List (Fin n)) : + (binaryListCode orderedRowPairCode + (certifiedGreedyOrderedScan X i selected js)).length ≀ + (binaryListCode orderedRowPairCode selected).length + + js.length * (6 * n) := by + induction js generalizing selected with + | nil => simp [certifiedGreedyOrderedScan] + | cons j js ih => + rw [certifiedGreedyOrderedScan, List.foldl_cons] + change (binaryListCode orderedRowPairCode + (certifiedGreedyOrderedScan X i + (certifiedGreedyOrderedStep X i selected j) js)).length ≀ _ + have htail := ih (certifiedGreedyOrderedStep X i selected j) + have hstep : (binaryListCode orderedRowPairCode + (certifiedGreedyOrderedStep X i selected j)).length ≀ + (binaryListCode orderedRowPairCode selected).length + 6 * n := by + simp only [certifiedGreedyOrderedStep] + split_ifs + Β· exact binaryListCode_ordered_cons_length_le i j selected + Β· omega + Β· omega + simp only [List.length_cons] + calc + _ ≀ (binaryListCode orderedRowPairCode + (certifiedGreedyOrderedStep X i selected j)).length + + js.length * (6 * n) := htail + _ ≀ ((binaryListCode orderedRowPairCode selected).length + 6 * n) + + js.length * (6 * n) := Nat.add_le_add_right hstep _ + _ = (binaryListCode orderedRowPairCode selected).length + + (js.length + 1) * (6 * n) := by ring + +@[simp] theorem machineMatchingInnerSelectedCandidate_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) : + machineMatchingInnerSelectedCandidate + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + binaryListCode orderedRowPairCode ((i, j) :: selected) := by + rw [machineMatchingInnerSelectedCandidate, + machineMatchingInnerFirstRow_canonical, + machineMatchingInnerCurrentSecondRow_canonical, + machineMatchingInnerSelected_canonical] + rfl + +/-- The quadratic-of-quadratic clamp is inactive throughout a canonical inner +pass. The hypothesis allows at most `n` preceding insertions, each of encoded +length at most `6n`; this is the only size invariant used by the semantic +proof. -/ +theorem canonical_inner_candidate_length_le_bound {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (hselected : (binaryListCode orderedRowPairCode selected).length ≀ + (binaryListCode orderedRowPairCode sourceSelected).length + + n * (6 * n)) : + (binaryListCode orderedRowPairCode ((i, j) :: selected)).length ≀ + (machineMatchingInnerInputBound + (matchingInnerMachineInput X R C i sourceSelected)).length := by + let source := matchingInnerMachineInput X R C i sourceSelected + let range := machineMatchingReverseRange + (machineMatchingInnerOptimizer source) + let base := pair source range + let P := base.length + have hinitialSource : + (binaryListCode orderedRowPairCode sourceSelected).length ≀ + source.length := by + dsimp only [source, matchingInnerMachineInput] + simp only [pair_length] + omega + have hsourceP : source.length ≀ P := by + simpa only [P, base, machinePairFirst_pair] using! + machinePairFirst_length_le base + have hrangeP : range.length ≀ P := by + simpa only [P, base, machinePairSecond_pair] using! + machinePairSecond_length_le base + have hnrange : n ≀ range.length := by + have hop : machineMatchingInnerOptimizer source = + rationalOptimizerOutputCode ⟨X, R, C⟩ := by + simp [source, matchingInnerMachineInput, + machineMatchingInnerOptimizer, machineMatchingInnerRest] + dsimp only [range] + rw [hop, machineMatchingReverseRange_encode] + simpa using! binaryListCode_listLength_le finUnaryCode + (List.finRange n).reverse + have hnP : n ≀ P := hnrange.trans hrangeP + have hinitialP : + (binaryListCode orderedRowPairCode sourceSelected).length ≀ P := + hinitialSource.trans hsourceP + have hcandidate := binaryListCode_ordered_cons_length_le i j selected + have hnpos : 0 < n := by + have := i.isLt + omega + have hPpos : 0 < P := lt_of_lt_of_le hnpos hnP + have hcoarse : + (binaryListCode orderedRowPairCode ((i, j) :: selected)).length ≀ + 6 * P * P + 7 * P := by + calc + _ ≀ (binaryListCode orderedRowPairCode selected).length + 6 * n := + hcandidate + _ ≀ ((binaryListCode orderedRowPairCode sourceSelected).length + + n * (6 * n)) + 6 * n := Nat.add_le_add_right hselected _ + _ ≀ (P + P * (6 * P)) + 6 * P := by + exact Nat.add_le_add + (Nat.add_le_add hinitialP + (Nat.mul_le_mul hnP (Nat.mul_le_mul_left 6 hnP))) + (Nat.mul_le_mul_left 6 hnP) + _ = 6 * P * P + 7 * P := by ring + change (binaryListCode orderedRowPairCode ((i, j) :: selected)).length ≀ + (machineBinaryMulWidth (machineBinaryMulWidth base)).length + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] + let W := (16 + P) * (16 + P) + have hPone : 1 ≀ P := hPpos + have hfirst : 6 * P * P + 7 * P ≀ 13 * P * P := by + nlinarith + have hPW : P * P ≀ W := by + dsimp only [W] + nlinarith + have hsecond : 13 * P * P ≀ 16 * W := by + nlinarith + have hthird : 16 * W ≀ (16 + W) * (16 + W) := by + nlinarith + exact hcoarse.trans (hfirst.trans (hsecond.trans hthird)) + +theorem machineMatchingInnerNextSelected_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) (sourceSelected selected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) + (hcandidate : + (binaryListCode orderedRowPairCode ((i, j) :: selected)).length ≀ + (machineMatchingInnerInputBound + (matchingInnerMachineInput X R C i sourceSelected)).length) : + machineMatchingInnerNextSelected + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + binaryListCode orderedRowPairCode + (certifiedGreedyOrderedStep X i selected j) := by + rw [machineMatchingInnerNextSelected, + machineMatchingInnerSelectBit_encode] + by_cases hij : i < j + Β· by_cases haccept : + HasCertifiedCorePair (explicitRegularizationScale n) X explicitKappa + (directedPairCostPrecision n) (rowPairOfLT i j hij) ∧ + orderedPairsConflict i j selected = false + Β· have hclamp : machineMatchingInnerSelectedCandidateClamped + (machineMatchingInnerPack (binaryListCode finUnaryCode (j :: js)) + (binaryListCode orderedRowPairCode selected) + (matchingInnerMachineInput X R C i sourceSelected)) = + binaryListCode orderedRowPairCode ((i, j) :: selected) := by + rw [machineMatchingInnerSelectedCandidateClamped, + machineMatchingInnerSelectedCandidate_encode, + machineMatchingInnerBound, + machineMatchingInnerSource_pack, + (List.take_eq_self_iff _).2 hcandidate] + rw [hclamp] + simp [certifiedGreedyOrderedStep, hij, haccept] + Β· simp [certifiedGreedyOrderedStep, hij, haccept] + Β· simp only [dite_eq_right hij, machineIfHead_false, + certifiedGreedyOrderedStep, machineMatchingInnerSelected_pack] + +theorem certifiedGreedyOrderedScan_take_succ {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (Fin n Γ— Fin n)) (js : List (Fin n)) + (k : β„•) (hk : k < js.length) : + certifiedGreedyOrderedScan X i selected (js.take (k + 1)) = + certifiedGreedyOrderedStep X i + (certifiedGreedyOrderedScan X i selected (js.take k)) js[k] := by + have htake : js.take (k + 1) = js.take k ++ [js[k]] := by + simpa only [List.concat_eq_append] using! (List.take_concat_get hk).symm + unfold certifiedGreedyOrderedScan + calc + List.foldl (certifiedGreedyOrderedStep X i) selected (js.take (k + 1)) = + List.foldl (certifiedGreedyOrderedStep X i) selected + (js.take k ++ [js[k]]) := congrArg _ htake + _ = _ := by rw [List.foldl_append]; rfl + +/-- Canonical state after consuming the first `k` second-row candidates. -/ +def machineMatchingInnerSemanticState {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) (k : β„•) : List Bool := + machineMatchingInnerPack + (binaryListCode finUnaryCode (js.drop k)) + (binaryListCode orderedRowPairCode + (certifiedGreedyOrderedScan X i sourceSelected (js.take k))) + (matchingInnerMachineInput X R C i sourceSelected) + +theorem machineMatchingInnerSemanticState_step {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) + (js : List (Fin n)) (hjs : js.length ≀ n) + (k : β„•) (hk : k < js.length) : + machineMatchingInnerStep + (machineMatchingInnerSemanticState X R C i sourceSelected js k) = + machineMatchingInnerSemanticState X R C i sourceSelected js (k + 1) := by + rw [machineMatchingInnerSemanticState, List.drop_eq_getElem_cons hk, + machineMatchingInnerStep] + simp only [machineMatchingInnerRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil finUnaryCode js[k] (js.drop (k + 1))), + machineMatchingInnerProcess] + simp only [machineMatchingInnerRemaining_pack, machineListTail_cons, + machineMatchingInnerSource_pack] + let selected := certifiedGreedyOrderedScan X i sourceSelected (js.take k) + have hscan := certifiedGreedyOrderedScan_code_length_le + X i sourceSelected (js.take k) + have htake : (js.take k).length ≀ n := + by rw [List.length_take]; omega + have hselected : + (binaryListCode orderedRowPairCode selected).length ≀ + (binaryListCode orderedRowPairCode sourceSelected).length + + n * (6 * n) := by + dsimp only [selected] + exact hscan.trans (Nat.add_le_add_left + (Nat.mul_le_mul_right (6 * n) htake) _) + have hcandidate := canonical_inner_candidate_length_le_bound + X R C i js[k] sourceSelected selected hselected + rw [machineMatchingInnerNextSelected_encode + X R C i js[k] sourceSelected selected (js.drop (k + 1)) hcandidate] + rw [machineMatchingInnerSemanticState] + apply congrArg (fun chosen : List (Fin n Γ— Fin n) ↦ + machineMatchingInnerPack + (binaryListCode finUnaryCode (js.drop (k + 1))) + (binaryListCode orderedRowPairCode chosen) + (matchingInnerMachineInput X R C i sourceSelected)) + exact (certifiedGreedyOrderedScan_take_succ + X i sourceSelected js k hk).symm + +@[simp] theorem machineMatchingInnerSemanticState_zero {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) : + machineMatchingInnerSemanticState X R C i sourceSelected + (List.finRange n).reverse 0 = + machineMatchingInnerInit + (matchingInnerMachineInput X R C i sourceSelected) := by + simp [machineMatchingInnerSemanticState, machineMatchingInnerInit, + certifiedGreedyOrderedScan, machineMatchingReverseRange_encode] + +theorem machineMatchingInnerIterate_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) : βˆ€ k ≀ n, + (machineMatchingInnerStep)^[k] + (machineMatchingInnerInit + (matchingInnerMachineInput X R C i sourceSelected)) = + machineMatchingInnerSemanticState X R C i sourceSelected + (List.finRange n).reverse k := by + intro k hk + induction k with + | zero => exact (machineMatchingInnerSemanticState_zero + X R C i sourceSelected).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineMatchingInnerSemanticState_step X R C i sourceSelected + (List.finRange n).reverse (by simp) k (by simp; omega) + +@[simp] theorem machineMatchingInnerOutputSelected_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (sourceSelected : List (Fin n Γ— Fin n)) : + machineMatchingInnerOutputSelected + (matchingInnerMachineInput X R C i sourceSelected) = + binaryListCode orderedRowPairCode + (certifiedGreedyOrderedScan X i sourceSelected + (List.finRange n).reverse) := by + rw [machineMatchingInnerOutputSelected, + machineMatchingInnerFinalState, + machineMatchingInnerOptimizer_matchingInput, + machineMatchingDimensionRuler_encode, List.length_replicate, + machineMatchingInnerIterate_semantics X R C i sourceSelected n le_rfl] + simp only [machineMatchingInnerSemanticState, + machineMatchingInnerSelected_pack] + rw [(List.take_eq_self_iff _).2 (by simp)] + +/-! ## The outer scan over first rows -/ + +/-- Encodes an outer matching state as remaining first rows, selected pairs, and optimizer +source. -/ +def machineMatchingOuterPack + (remaining selected source : List Bool) : List Bool := + pair remaining (pair selected source) + +/-- Extracts the unprocessed first-row candidates from the outer matching state. -/ +def machineMatchingOuterRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the selected row pairs from the outer matching state. -/ +def machineMatchingOuterSelected (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the optimizer result stored in the outer matching state. -/ +def machineMatchingOuterSource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the first unprocessed first-row candidate. -/ +def machineMatchingOuterCurrentFirstRow (state : List Bool) : List Bool := + machineListHead (machineMatchingOuterRemaining state) + +/-- Builds an inner scan query from the current first row, selected pairs, and optimizer result. -/ +def machineMatchingOuterInnerInput (state : List Bool) : List Bool := + pair (machineMatchingOuterCurrentFirstRow state) + (pair (machineMatchingOuterSelected state) + (machineMatchingOuterSource state)) + +/-- Runs the inner scan to obtain the next untruncated selected-pair list. -/ +def machineMatchingOuterNextSelectedRaw (state : List Bool) : List Bool := + machineMatchingInnerOutputSelected (machineMatchingOuterInnerInput state) + +/-- Bounds the outer scan by three width expansions of the optimizer paired with its reverse row +range. -/ +def machineMatchingOuterInputBound (optimizer : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth (machineBinaryMulWidth + (pair optimizer (machineMatchingReverseRange optimizer)))) + +/-- Reads the outer state bound derived from the stored optimizer result. -/ +def machineMatchingOuterBound (state : List Bool) : List Bool := + machineMatchingOuterInputBound (machineMatchingOuterSource state) + +/-- Truncates the inner scan's selected-pair result to the outer state bound. -/ +def machineMatchingOuterNextSelected (state : List Bool) : List Bool := + (machineMatchingOuterNextSelectedRaw state).take + (machineMatchingOuterBound state).length + +/-- Consumes one first-row candidate and stores the bounded result of its inner scan. -/ +def machineMatchingOuterProcess (state : List Bool) : List Bool := + machineMatchingOuterPack + (machineListTail (machineMatchingOuterRemaining state)) + (machineMatchingOuterNextSelected state) + (machineMatchingOuterSource state) + +/-- Processes the next first row, leaving an exhausted outer scan fixed. -/ +def machineMatchingOuterStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatchingOuterRemaining state) state + (machineMatchingOuterProcess state) + +/-- Initializes the outer scan with reverse-ordered row candidates and no selected pairs. -/ +def machineMatchingOuterInit (optimizer : List Bool) : List Bool := + machineMatchingOuterPack (machineMatchingReverseRange optimizer) [] optimizer + +/-- Packs three copies of the outer bound to bound the complete encoded state. -/ +def machineMatchingOuterWidth (optimizer : List Bool) : List Bool := + let bound := machineMatchingOuterInputBound optimizer + machineMatchingOuterPack bound bound bound + +/-- Runs the outer matching scan once per row of the optimizer matrix. -/ +def machineMatchingOuterFinalState (optimizer : List Bool) : List Bool := + (machineMatchingOuterStep)^[(machineMatchingDimensionRuler optimizer).length] + (machineMatchingOuterInit optimizer) + +/-- Encoded selected ordered row pairs produced by the complete matcher. -/ +def machineGreedyMatchingSelected (optimizer : List Bool) : List Bool := + machineMatchingOuterSelected (machineMatchingOuterFinalState optimizer) + +theorem machineMatchingOuterRemaining_mem_FP : + machineMatchingOuterRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineMatchingOuterSelected_mem_FP : + machineMatchingOuterSelected ∈ FP := by + simpa only [machineMatchingOuterSelected] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatchingOuterSource_mem_FP : + machineMatchingOuterSource ∈ FP := by + simpa only [machineMatchingOuterSource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineMatchingOuterCurrentFirstRow_mem_FP : + machineMatchingOuterCurrentFirstRow ∈ FP := by + simpa only [machineMatchingOuterCurrentFirstRow] using! machineCompose_mem_FP + machineMatchingOuterRemaining_mem_FP machineListHead_mem_FP + +theorem machineMatchingOuterInnerInput_mem_FP : + machineMatchingOuterInnerInput ∈ FP := + machinePair_mem_FP machineMatchingOuterCurrentFirstRow_mem_FP + (machinePair_mem_FP machineMatchingOuterSelected_mem_FP + machineMatchingOuterSource_mem_FP) + +theorem machineMatchingOuterNextSelectedRaw_mem_FP : + machineMatchingOuterNextSelectedRaw ∈ FP := by + simpa only [machineMatchingOuterNextSelectedRaw] using! machineCompose_mem_FP + machineMatchingOuterInnerInput_mem_FP + machineMatchingInnerOutputSelected_mem_FP + +theorem machineMatchingOuterInputBound_mem_FP : + machineMatchingOuterInputBound ∈ FP := by + have hrange := machineCompose_mem_FP id_mem_FP + machineMatchingReverseRange_mem_FP + have hbase := machinePair_mem_FP id_mem_FP hrange + have h1 := machineCompose_mem_FP hbase machineBinaryMulWidth_mem_FP + have h2 := machineCompose_mem_FP h1 machineBinaryMulWidth_mem_FP + simpa only [machineMatchingOuterInputBound] using! + machineCompose_mem_FP h2 machineBinaryMulWidth_mem_FP + +theorem machineMatchingOuterBound_mem_FP : + machineMatchingOuterBound ∈ FP := by + simpa only [machineMatchingOuterBound] using! machineCompose_mem_FP + machineMatchingOuterSource_mem_FP machineMatchingOuterInputBound_mem_FP + +theorem machineMatchingOuterNextSelected_mem_FP : + machineMatchingOuterNextSelected ∈ FP := by + simpa only [machineMatchingOuterNextSelected] using! + machineTake_mem_FP machineMatchingOuterBound_mem_FP + machineMatchingOuterNextSelectedRaw_mem_FP + +theorem machineMatchingOuterProcess_mem_FP : + machineMatchingOuterProcess ∈ FP := by + have htail := machineCompose_mem_FP machineMatchingOuterRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineMatchingOuterNextSelected_mem_FP + machineMatchingOuterSource_mem_FP) + +theorem machineMatchingOuterStep_mem_FP : + machineMatchingOuterStep ∈ FP := by + simpa only [machineMatchingOuterStep] using! machineIfEmpty_mem_FP + machineMatchingOuterRemaining_mem_FP id_mem_FP + machineMatchingOuterProcess_mem_FP + +theorem machineMatchingOuterInit_mem_FP : + machineMatchingOuterInit ∈ FP := + machinePair_mem_FP machineMatchingReverseRange_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP) + +theorem machineMatchingOuterWidth_mem_FP : + machineMatchingOuterWidth ∈ FP := + machinePair_mem_FP machineMatchingOuterInputBound_mem_FP + (machinePair_mem_FP machineMatchingOuterInputBound_mem_FP + machineMatchingOuterInputBound_mem_FP) + +@[simp] theorem machineMatchingOuterRemaining_pack (remaining selected source) : + machineMatchingOuterRemaining + (machineMatchingOuterPack remaining selected source) = remaining := by + simp [machineMatchingOuterRemaining, machineMatchingOuterPack] + +@[simp] theorem machineMatchingOuterSelected_pack (remaining selected source) : + machineMatchingOuterSelected + (machineMatchingOuterPack remaining selected source) = selected := by + simp [machineMatchingOuterSelected, machineMatchingOuterPack] + +@[simp] theorem machineMatchingOuterSource_pack (remaining selected source) : + machineMatchingOuterSource + (machineMatchingOuterPack remaining selected source) = source := by + simp [machineMatchingOuterSource, machineMatchingOuterPack] + +/-- Bounds the outer scan's remaining and selected lists while preserving the optimizer source. -/ +def MachineMatchingOuterStateBound (optimizer state : List Bool) : Prop := + let B := (machineMatchingOuterInputBound optimizer).length + state = machineMatchingOuterPack (machineMatchingOuterRemaining state) + (machineMatchingOuterSelected state) (machineMatchingOuterSource state) ∧ + (machineMatchingOuterRemaining state).length ≀ B ∧ + (machineMatchingOuterSelected state).length ≀ B ∧ + machineMatchingOuterSource state = optimizer + +theorem machineMatchingOuter_base_le_bound (optimizer : List Bool) : + (pair optimizer (machineMatchingReverseRange optimizer)).length ≀ + (machineMatchingOuterInputBound optimizer).length := by + simp only [machineMatchingOuterInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineMatchingOuter_optimizer_le_bound (optimizer : List Bool) : + optimizer.length ≀ (machineMatchingOuterInputBound optimizer).length := by + simpa only [machinePairFirst_pair] using! + (machinePairFirst_length_le + (pair optimizer (machineMatchingReverseRange optimizer))).trans + (machineMatchingOuter_base_le_bound optimizer) + +theorem machineMatchingOuter_range_le_bound (optimizer : List Bool) : + (machineMatchingReverseRange optimizer).length ≀ + (machineMatchingOuterInputBound optimizer).length := by + simpa only [machinePairSecond_pair] using! + (machinePairSecond_length_le + (pair optimizer (machineMatchingReverseRange optimizer))).trans + (machineMatchingOuter_base_le_bound optimizer) + +theorem machineMatchingOuterInit_bound (optimizer : List Bool) : + MachineMatchingOuterStateBound optimizer + (machineMatchingOuterInit optimizer) := by + simp only [MachineMatchingOuterStateBound, machineMatchingOuterInit, + machineMatchingOuterRemaining_pack, machineMatchingOuterSelected_pack, + machineMatchingOuterSource_pack, List.length_nil] + exact ⟨trivial, machineMatchingOuter_range_le_bound optimizer, + Nat.zero_le _, trivial⟩ + +theorem machineMatchingOuterStep_bound {optimizer state : List Bool} + (hstate : MachineMatchingOuterStateBound optimizer state) : + MachineMatchingOuterStateBound optimizer + (machineMatchingOuterStep state) := by + rcases hstate with ⟨hpack, hremaining, hselected, hsource⟩ + by_cases hrem : machineMatchingOuterRemaining state = [] + Β· rw [machineMatchingOuterStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hselected, hsource⟩ + Β· rw [machineMatchingOuterStep] + cases hcode : machineMatchingOuterRemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatchingOuterProcess] + simp only [MachineMatchingOuterStateBound, + machineMatchingOuterRemaining_pack, + machineMatchingOuterSelected_pack, + machineMatchingOuterSource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineMatchingOuterRemaining state)).trans hremaining + Β· simp only [machineMatchingOuterNextSelected, + List.length_take, machineMatchingOuterBound, hsource] + exact Nat.min_le_left _ _ + +theorem machineMatchingOuterIterate_bound (optimizer : List Bool) : βˆ€ k, + MachineMatchingOuterStateBound optimizer + ((machineMatchingOuterStep)^[k] + (machineMatchingOuterInit optimizer)) := by + intro k + induction k with + | zero => exact machineMatchingOuterInit_bound optimizer + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatchingOuterStep_bound ih + +theorem machineMatchingOuterIterate_length_le_width + (optimizer : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineMatchingDimensionRuler optimizer).length) : + ((machineMatchingOuterStep)^[iterations] + (machineMatchingOuterInit optimizer)).length ≀ + (machineMatchingOuterWidth optimizer).length := by + rcases machineMatchingOuterIterate_bound optimizer iterations with + ⟨hpack, hremaining, hselected, hsource⟩ + have hsourceLength : (machineMatchingOuterSource + ((machineMatchingOuterStep)^[iterations] + (machineMatchingOuterInit optimizer))).length ≀ + (machineMatchingOuterInputBound optimizer).length := by + rw [hsource] + exact machineMatchingOuter_optimizer_le_bound optimizer + rw [hpack] + simp only [machineMatchingOuterPack, machineMatchingOuterWidth, pair_length] + omega + +theorem machineMatchingOuterFinalState_mem_FP : + machineMatchingOuterFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineMatchingOuterStep_mem_FP + machineMatchingOuterInit_mem_FP machineMatchingDimensionRuler_mem_FP + machineMatchingOuterWidth_mem_FP + machineMatchingOuterIterate_length_le_width + +theorem machineGreedyMatchingSelected_mem_FP : + machineGreedyMatchingSelected ∈ FP := by + simpa only [machineGreedyMatchingSelected] using! machineCompose_mem_FP + machineMatchingOuterFinalState_mem_FP + machineMatchingOuterSelected_mem_FP + +/-! ## Exact outer-scan semantics -/ + +/-- Scans second-row candidates in reverse order for a fixed first row and current selected +pairs. -/ +def certifiedGreedyOuterStep {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (Fin n Γ— Fin n)) (i : Fin n) : + List (Fin n Γ— Fin n) := + certifiedGreedyOrderedScan X i selected (List.finRange n).reverse + +/-- Folds the certified outer matching step over the supplied list of first-row candidates. -/ +def certifiedGreedyOuterScan {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (Fin n Γ— Fin n)) (is : List (Fin n)) : + List (Fin n Γ— Fin n) := + is.foldl (certifiedGreedyOuterStep X) selected + +theorem certifiedGreedyOuterStep_code_length_le {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (Fin n Γ— Fin n)) (i : Fin n) : + (binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected i)).length ≀ + (binaryListCode orderedRowPairCode selected).length + n * (6 * n) := by + simpa [certifiedGreedyOuterStep] using! + certifiedGreedyOrderedScan_code_length_le X i selected + (List.finRange n).reverse + +theorem certifiedGreedyOuterScan_code_length_le {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (Fin n Γ— Fin n)) (is : List (Fin n)) : + (binaryListCode orderedRowPairCode + (certifiedGreedyOuterScan X selected is)).length ≀ + (binaryListCode orderedRowPairCode selected).length + + is.length * (n * (6 * n)) := by + induction is generalizing selected with + | nil => simp [certifiedGreedyOuterScan] + | cons i is ih => + rw [certifiedGreedyOuterScan, List.foldl_cons] + change (binaryListCode orderedRowPairCode + (certifiedGreedyOuterScan X + (certifiedGreedyOuterStep X selected i) is)).length ≀ _ + have htail := ih (certifiedGreedyOuterStep X selected i) + have hstep := certifiedGreedyOuterStep_code_length_le X selected i + simp only [List.length_cons] + calc + _ ≀ (binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected i)).length + + is.length * (n * (6 * n)) := htail + _ ≀ ((binaryListCode orderedRowPairCode selected).length + + n * (6 * n)) + is.length * (n * (6 * n)) := + Nat.add_le_add_right hstep _ + _ = (binaryListCode orderedRowPairCode selected).length + + (is.length + 1) * (n * (6 * n)) := by ring + +@[simp] theorem machineMatchingOuterInnerInput_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (is : List (Fin n)) + (selected : List (Fin n Γ— Fin n)) : + machineMatchingOuterInnerInput + (machineMatchingOuterPack (binaryListCode finUnaryCode (i :: is)) + (binaryListCode orderedRowPairCode selected) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + matchingInnerMachineInput X R C i selected := by + simp [machineMatchingOuterInnerInput, + machineMatchingOuterCurrentFirstRow, + machineMatchingOuterRemaining, machineMatchingOuterSelected, + machineMatchingOuterSource, machineMatchingOuterPack, + matchingInnerMachineInput] + +@[simp] theorem machineMatchingOuterNextSelectedRaw_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (is : List (Fin n)) + (selected : List (Fin n Γ— Fin n)) : + machineMatchingOuterNextSelectedRaw + (machineMatchingOuterPack (binaryListCode finUnaryCode (i :: is)) + (binaryListCode orderedRowPairCode selected) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected i) := by + rw [machineMatchingOuterNextSelectedRaw, + machineMatchingOuterInnerInput_encode, + machineMatchingInnerOutputSelected_encode] + rfl + +theorem canonical_outer_selected_length_le_bound {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (selected : List (Fin n Γ— Fin n)) + (hselected : (binaryListCode orderedRowPairCode selected).length ≀ + n * (n * (6 * n))) : + (binaryListCode orderedRowPairCode selected).length ≀ + (machineMatchingOuterInputBound + (rationalOptimizerOutputCode ⟨X, R, C⟩)).length := by + let optimizer := rationalOptimizerOutputCode ⟨X, R, C⟩ + let range := machineMatchingReverseRange optimizer + let base := pair optimizer range + let P := base.length + have hrangeP : range.length ≀ P := by + simpa only [P, base, machinePairSecond_pair] using! + machinePairSecond_length_le base + have hnrange : n ≀ range.length := by + dsimp only [range, optimizer] + rw [machineMatchingReverseRange_encode] + simpa using! binaryListCode_listLength_le finUnaryCode + (List.finRange n).reverse + have hnP : n ≀ P := hnrange.trans hrangeP + have hcoarse : (binaryListCode orderedRowPairCode selected).length ≀ + P * (P * (6 * P)) := + hselected.trans (Nat.mul_le_mul hnP + (Nat.mul_le_mul hnP (Nat.mul_le_mul_left 6 hnP))) + change (binaryListCode orderedRowPairCode selected).length ≀ + (machineBinaryMulWidth + (machineBinaryMulWidth (machineBinaryMulWidth base))).length + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] + let W₁ := (16 + P) * (16 + P) + let Wβ‚‚ := (16 + W₁) * (16 + W₁) + have hPone : 1 ≀ P := by + dsimp only [P, base] + simp only [pair_length] + omega + have hPP : P * P ≀ W₁ := by + dsimp only [W₁] + nlinarith + have hfour : (P * P) * (P * P) ≀ W₁ * W₁ := + Nat.mul_le_mul hPP hPP + have hcube : P * (P * (6 * P)) ≀ + 6 * ((P * P) * (P * P)) := by + nlinarith + have hW₁sq : W₁ * W₁ ≀ Wβ‚‚ := by + dsimp only [Wβ‚‚] + nlinarith + have htoWβ‚‚ : P * (P * (6 * P)) ≀ 16 * Wβ‚‚ := by + calc + _ ≀ 6 * ((P * P) * (P * P)) := hcube + _ ≀ 6 * (W₁ * W₁) := Nat.mul_le_mul_left 6 hfour + _ ≀ 6 * Wβ‚‚ := Nat.mul_le_mul_left 6 hW₁sq + _ ≀ 16 * Wβ‚‚ := Nat.mul_le_mul_right Wβ‚‚ (by omega) + have hfinal : 16 * Wβ‚‚ ≀ (16 + Wβ‚‚) * (16 + Wβ‚‚) := by + nlinarith + exact hcoarse.trans (htoWβ‚‚.trans hfinal) + +theorem machineMatchingOuterNextSelected_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) (is : List (Fin n)) + (selected : List (Fin n Γ— Fin n)) + (hselected : (binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected i)).length ≀ + n * (n * (6 * n))) : + machineMatchingOuterNextSelected + (machineMatchingOuterPack (binaryListCode finUnaryCode (i :: is)) + (binaryListCode orderedRowPairCode selected) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected i) := by + rw [machineMatchingOuterNextSelected, + machineMatchingOuterNextSelectedRaw_encode, + machineMatchingOuterBound, machineMatchingOuterSource_pack, + (List.take_eq_self_iff _).2 + (canonical_outer_selected_length_le_bound X R C _ hselected)] + +theorem certifiedGreedyOuterScan_take_succ {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (Fin n Γ— Fin n)) (is : List (Fin n)) + (k : β„•) (hk : k < is.length) : + certifiedGreedyOuterScan X selected (is.take (k + 1)) = + certifiedGreedyOuterStep X + (certifiedGreedyOuterScan X selected (is.take k)) is[k] := by + have htake : is.take (k + 1) = is.take k ++ [is[k]] := by + simpa only [List.concat_eq_append] using! (List.take_concat_get hk).symm + unfold certifiedGreedyOuterScan + calc + List.foldl (certifiedGreedyOuterStep X) selected (is.take (k + 1)) = + List.foldl (certifiedGreedyOuterStep X) selected + (is.take k ++ [is[k]]) := congrArg _ htake + _ = _ := by rw [List.foldl_append]; rfl + +/-- Encodes the outer scan after `k` first rows with its remaining rows and greedily selected +pairs. -/ +def machineMatchingOuterSemanticState {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (is : List (Fin n)) (k : β„•) : List Bool := + machineMatchingOuterPack + (binaryListCode finUnaryCode (is.drop k)) + (binaryListCode orderedRowPairCode + (certifiedGreedyOuterScan X [] (is.take k))) + (rationalOptimizerOutputCode ⟨X, R, C⟩) + +theorem machineMatchingOuterSemanticState_step {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (is : List (Fin n)) (his : is.length ≀ n) + (k : β„•) (hk : k < is.length) : + machineMatchingOuterStep (machineMatchingOuterSemanticState X R C is k) = + machineMatchingOuterSemanticState X R C is (k + 1) := by + rw [machineMatchingOuterSemanticState, List.drop_eq_getElem_cons hk, + machineMatchingOuterStep] + simp only [machineMatchingOuterRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil finUnaryCode is[k] (is.drop (k + 1))), + machineMatchingOuterProcess] + simp only [machineMatchingOuterRemaining_pack, machineListTail_cons, + machineMatchingOuterSource_pack] + let selected := certifiedGreedyOuterScan X [] (is.take k) + have hscan := certifiedGreedyOuterScan_code_length_le X [] (is.take k) + have htake : (is.take k).length ≀ k := List.length_take_le _ _ + have hklt : k < n := lt_of_lt_of_le hk his + have hselectedCode : + (binaryListCode orderedRowPairCode selected).length ≀ + k * (n * (6 * n)) := by + dsimp only [selected] + simpa [binaryListCode] using! hscan.trans (Nat.add_le_add_left + (Nat.mul_le_mul_right (n * (6 * n)) htake) _) + have hstep := certifiedGreedyOuterStep_code_length_le X selected is[k] + have hcandidate : + (binaryListCode orderedRowPairCode + (certifiedGreedyOuterStep X selected is[k])).length ≀ + n * (n * (6 * n)) := by + calc + _ ≀ (binaryListCode orderedRowPairCode selected).length + + n * (6 * n) := hstep + _ ≀ k * (n * (6 * n)) + n * (6 * n) := + Nat.add_le_add_right hselectedCode _ + _ = (k + 1) * (n * (6 * n)) := by ring + _ ≀ n * (n * (6 * n)) := + Nat.mul_le_mul_right (n * (6 * n)) (by omega) + rw [machineMatchingOuterNextSelected_encode + X R C is[k] (is.drop (k + 1)) selected hcandidate] + rw [machineMatchingOuterSemanticState] + apply congrArg (fun chosen : List (Fin n Γ— Fin n) ↦ + machineMatchingOuterPack + (binaryListCode finUnaryCode (is.drop (k + 1))) + (binaryListCode orderedRowPairCode chosen) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) + exact (certifiedGreedyOuterScan_take_succ X [] is k hk).symm + +@[simp] theorem machineMatchingOuterSemanticState_zero {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineMatchingOuterSemanticState X R C (List.finRange n).reverse 0 = + machineMatchingOuterInit (rationalOptimizerOutputCode ⟨X, R, C⟩) := by + simp [machineMatchingOuterSemanticState, machineMatchingOuterInit, + certifiedGreedyOuterScan, machineMatchingReverseRange_encode, + binaryListCode] + +theorem machineMatchingOuterIterate_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : βˆ€ k ≀ n, + (machineMatchingOuterStep)^[k] + (machineMatchingOuterInit (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + machineMatchingOuterSemanticState X R C + (List.finRange n).reverse k := by + intro k hk + induction k with + | zero => exact (machineMatchingOuterSemanticState_zero X R C).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineMatchingOuterSemanticState_step X R C + (List.finRange n).reverse (by simp) k (by simp; omega) + +@[simp] theorem machineGreedyMatchingSelected_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineGreedyMatchingSelected (rationalOptimizerOutputCode ⟨X, R, C⟩) = + binaryListCode orderedRowPairCode + (certifiedGreedyOuterScan X [] (List.finRange n).reverse) := by + rw [machineGreedyMatchingSelected, machineMatchingOuterFinalState, + machineMatchingDimensionRuler_encode, List.length_replicate, + machineMatchingOuterIterate_semantics X R C n le_rfl] + simp only [machineMatchingOuterSemanticState, + machineMatchingOuterSelected_pack] + rw [(List.take_eq_self_iff _).2 (by simp)] + +/-! ## Identification with the mathematical greedy matching -/ + +/-- Extracts the two ordered endpoints of a typed row pair. -/ +def rowPairEndpoints {n : β„•} (q : RowPair n) : Fin n Γ— Fin n := + (rowPairRow q 0, rowPairRow q 1) + +theorem rowPair_eq_pair_rows {n : β„•} (q : RowPair n) : + q.1 = {rowPairRow q 0, rowPairRow q 1} := by + apply Finset.eq_of_subset_of_card_le + Β· intro x hx + obtain ⟨k, hk⟩ := (q.1.orderIsoOfFin q.2).surjective ⟨x, hx⟩ + have hxrow : x = rowPairRow q k := by + exact congrArg Subtype.val hk.symm + fin_cases k <;> simp [hxrow] + Β· simp [q.2, rowPairRow_ne q] + +@[simp] theorem rowPairEndpoints_rowPairOfLT {n : β„•} + (i j : Fin n) (hij : i < j) : + rowPairEndpoints (rowPairOfLT i j hij) = (i, j) := by + simp [rowPairEndpoints] + +theorem orderedPairsConflict_map_endpoints_eq_false_iff {n : β„•} + (i j : Fin n) (hij : i < j) (selected : List (RowPair n)) : + orderedPairsConflict i j (selected.map rowPairEndpoints) = false ↔ + βˆ€ q ∈ selected, Disjoint (rowPairOfLT i j hij).1 q.1 := by + induction selected with + | nil => simp [orderedPairsConflict] + | cons q selected ih => + rw [List.map_cons] + change (decide (i = (rowPairEndpoints q).1 ∨ + i = (rowPairEndpoints q).2 ∨ + j = (rowPairEndpoints q).1 ∨ j = (rowPairEndpoints q).2) || + orderedPairsConflict i j (selected.map rowPairEndpoints)) = false ↔ _ + rw [Bool.or_eq_false_iff, ih] + constructor + Β· rintro ⟨hhead, htail⟩ r hr + simp only [List.mem_cons] at hr + rcases hr with rfl | hr + Β· rw [rowPair_eq_pair_rows (rowPairOfLT i j hij), + rowPair_eq_pair_rows r, + rowPairRow_rowPairOfLT_zero, + rowPairRow_rowPairOfLT_one] + simpa [rowPairEndpoints, Finset.disjoint_left, and_assoc] using! + (of_decide_eq_false hhead) + Β· exact htail r hr + Β· intro hall + refine ⟨?_, fun r hr ↦ hall r (List.mem_cons_of_mem _ hr)⟩ + have hdisj := hall q (by simp) + rw [rowPair_eq_pair_rows (rowPairOfLT i j hij), + rowPair_eq_pair_rows q, + rowPairRow_rowPairOfLT_zero, + rowPairRow_rowPairOfLT_one] at hdisj + apply decide_eq_false + simpa [rowPairEndpoints, rowPairOfLT, + Finset.disjoint_left, and_assoc] using! hdisj + +/-- The same greedy update, now retaining the proof-carrying unordered row +pair. This is the bridge from the machine's endpoint representation to the +mathematical matching. -/ +def certifiedGreedyTypedStep {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (RowPair n)) (j : Fin n) : List (RowPair n) := + if hij : i < j then + let q := rowPairOfLT i j hij + if HasCertifiedCorePair (explicitRegularizationScale n) X explicitKappa + (directedPairCostPrecision n) q ∧ + βˆ€ r ∈ selected, Disjoint q.1 r.1 then + q :: selected + else selected + else selected + +theorem certifiedGreedyOrderedStep_map_endpoints {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) + (selected : List (RowPair n)) : + certifiedGreedyOrderedStep X i (selected.map rowPairEndpoints) j = + (certifiedGreedyTypedStep X i selected j).map rowPairEndpoints := by + by_cases hij : i < j + Β· rw [certifiedGreedyOrderedStep, dif_pos hij, + certifiedGreedyTypedStep, dif_pos hij] + have hiff := orderedPairsConflict_map_endpoints_eq_false_iff + i j hij selected + by_cases h : HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) (rowPairOfLT i j hij) ∧ + orderedPairsConflict i j (selected.map rowPairEndpoints) = false + Β· have htyped : HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) (rowPairOfLT i j hij) ∧ + βˆ€ r ∈ selected, Disjoint (rowPairOfLT i j hij).1 r.1 := + ⟨h.1, hiff.mp h.2⟩ + rw [ite_eq_left h, ite_eq_left htyped, List.map_cons, + rowPairEndpoints_rowPairOfLT] + Β· have htyped : Β¬(HasCertifiedCorePair + (explicitRegularizationScale n) X explicitKappa + (directedPairCostPrecision n) (rowPairOfLT i j hij) ∧ + βˆ€ r ∈ selected, Disjoint (rowPairOfLT i j hij).1 r.1) := by + intro ht + exact h ⟨ht.1, hiff.mpr ht.2⟩ + rw [ite_eq_right h, ite_eq_right htyped] + Β· simp [certifiedGreedyOrderedStep, certifiedGreedyTypedStep, hij] + +/-- Folds the typed greedy selection step over a list of second-row candidates. -/ +def certifiedGreedyTypedInnerScan {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (RowPair n)) (js : List (Fin n)) : List (RowPair n) := + js.foldl (certifiedGreedyTypedStep X i) selected + +theorem certifiedGreedyOrderedScan_map_endpoints {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (RowPair n)) (js : List (Fin n)) : + certifiedGreedyOrderedScan X i (selected.map rowPairEndpoints) js = + (certifiedGreedyTypedInnerScan X i selected js).map + rowPairEndpoints := by + induction js generalizing selected with + | nil => rfl + | cons j js ih => + rw [certifiedGreedyOrderedScan, certifiedGreedyTypedInnerScan, + List.foldl_cons, List.foldl_cons, + certifiedGreedyOrderedStep_map_endpoints] + exact ih (certifiedGreedyTypedStep X i selected j) + +/-- Runs the typed inner scan over all second rows in reverse order. -/ +def certifiedGreedyTypedOuterStep {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (i : Fin n) : List (RowPair n) := + certifiedGreedyTypedInnerScan X i selected (List.finRange n).reverse + +/-- Folds the typed outer scan over the supplied first-row candidates. -/ +def certifiedGreedyTypedOuterScan {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (is : List (Fin n)) : List (RowPair n) := + is.foldl (certifiedGreedyTypedOuterStep X) selected + +theorem certifiedGreedyOuterScan_map_endpoints {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (is : List (Fin n)) : + certifiedGreedyOuterScan X (selected.map rowPairEndpoints) is = + (certifiedGreedyTypedOuterScan X selected is).map + rowPairEndpoints := by + induction is generalizing selected with + | nil => rfl + | cons i is ih => + rw [certifiedGreedyOuterScan, certifiedGreedyTypedOuterScan, + List.foldl_cons, List.foldl_cons] + change certifiedGreedyOuterScan X + (certifiedGreedyOrderedScan X i + (selected.map rowPairEndpoints) (List.finRange n).reverse) is = _ + rw [certifiedGreedyOrderedScan_map_endpoints] + exact ih (certifiedGreedyTypedOuterStep X selected i) + +/-- Constructs a typed row pair when the first index is smaller, returning none otherwise. -/ +def canonicalRowPairCandidate {n : β„•} (i j : Fin n) : Option (RowPair n) := + if hij : i < j then some (rowPairOfLT i j hij) else none + +/-- Tests whether a typed row pair has a certified core pair at the explicit scale, threshold, +and precision. -/ +def certifiedRowPairEligibleBit {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (q : RowPair n) : Bool := + decide (HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) q) + +/-- Prepends a row pair when it is disjoint from every pair already selected. -/ +def greedyRowListStep {n : β„•} + (selected : List (RowPair n)) (q : RowPair n) : List (RowPair n) := + if βˆ€ r ∈ selected, Disjoint q.1 r.1 then q :: selected else selected + +/-- Adds a certified eligible row pair to the greedy list when disjointness permits. -/ +def certifiedGreedyEdgeStep {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (q : RowPair n) : List (RowPair n) := + if certifiedRowPairEligibleBit X q then greedyRowListStep selected q + else selected + +theorem certifiedGreedyTypedStep_eq_candidate {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) + (selected : List (RowPair n)) : + certifiedGreedyTypedStep X i selected j = + match canonicalRowPairCandidate i j with + | some q => certifiedGreedyEdgeStep X selected q + | none => selected := by + by_cases hij : i < j + Β· simp only [certifiedGreedyTypedStep, canonicalRowPairCandidate, + dif_pos hij, certifiedGreedyEdgeStep, certifiedRowPairEligibleBit, + greedyRowListStep] + by_cases heligible : HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) (rowPairOfLT i j hij) + Β· simp [heligible] + Β· simp [heligible] + Β· simp [certifiedGreedyTypedStep, canonicalRowPairCandidate, hij] + +theorem certifiedGreedyTypedInnerScan_eq_filterMap_fold {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + (selected : List (RowPair n)) (js : List (Fin n)) : + certifiedGreedyTypedInnerScan X i selected js = + (js.filterMap (canonicalRowPairCandidate i)).foldl + (certifiedGreedyEdgeStep X) selected := by + rw [List.foldl_filterMap] + unfold certifiedGreedyTypedInnerScan + congr 1 + funext acc j + by_cases hij : i < j + Β· by_cases heligible : HasCertifiedCorePair + (explicitRegularizationScale n) X explicitKappa + (directedPairCostPrecision n) (rowPairOfLT i j hij) + Β· by_cases hdisjoint : βˆ€ r ∈ acc, + Disjoint (rowPairOfLT i j hij).1 r.1 + Β· simp [certifiedGreedyTypedStep, canonicalRowPairCandidate, + certifiedGreedyEdgeStep, certifiedRowPairEligibleBit, + greedyRowListStep, hij, heligible, hdisjoint] + Β· simp [certifiedGreedyTypedStep, canonicalRowPairCandidate, + certifiedGreedyEdgeStep, certifiedRowPairEligibleBit, + greedyRowListStep, hij, heligible, hdisjoint] + Β· simp [certifiedGreedyTypedStep, canonicalRowPairCandidate, + certifiedGreedyEdgeStep, certifiedRowPairEligibleBit, + greedyRowListStep, hij, heligible] + Β· simp [certifiedGreedyTypedStep, canonicalRowPairCandidate, hij] + +theorem reverse_allRowPairsList {n : β„•} : + (allRowPairsList n).reverse = + (List.finRange n).reverse.flatMap fun i ↦ + (List.finRange n).reverse.filterMap + (canonicalRowPairCandidate i) := by + rw [allRowPairsList, List.reverse_flatMap] + apply congrArg (fun f ↦ (List.finRange n).reverse.flatMap f) + funext i + change ((List.finRange n).filterMap + (canonicalRowPairCandidate i)).reverse = + (List.finRange n).reverse.filterMap (canonicalRowPairCandidate i) + exact (List.filterMap_reverse).symm + +theorem certifiedGreedyTypedOuterScan_eq_edgeFold {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (is : List (Fin n)) : + certifiedGreedyTypedOuterScan X selected is = + (is.flatMap fun i ↦ (List.finRange n).reverse.filterMap + (canonicalRowPairCandidate i)).foldl + (certifiedGreedyEdgeStep X) selected := by + rw [List.foldl_flatMap] + unfold certifiedGreedyTypedOuterScan + congr 1 + funext acc i + exact certifiedGreedyTypedInnerScan_eq_filterMap_fold + X i acc (List.finRange n).reverse + +theorem certifiedGreedyTypedOuterScan_full_eq_edgeFold {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + certifiedGreedyTypedOuterScan X [] (List.finRange n).reverse = + (allRowPairsList n).reverse.foldl (certifiedGreedyEdgeStep X) [] := by + rw [certifiedGreedyTypedOuterScan_eq_edgeFold, + ← reverse_allRowPairsList] + +theorem certifiedGreedyEdgeFold_eq_filter {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + (selected : List (RowPair n)) (edges : List (RowPair n)) : + edges.foldl (certifiedGreedyEdgeStep X) selected = + (edges.filter (certifiedRowPairEligibleBit X)).foldl + greedyRowListStep selected := by + rw [List.foldl_filter] + congr 1 + +theorem explicitThresholdRowPairsList_eq_certifiedFilter {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + thresholdRowPairsList (explicitCertifiedRowWeight X) explicitGamma = + (allRowPairsList n).filter (certifiedRowPairEligibleBit X) := by + rw [thresholdRowPairsList] + apply List.filter_congr + intro q _ + by_cases h : HasCertifiedCorePair (explicitRegularizationScale n) X + explicitKappa (directedPairCostPrecision n) q + Β· simp [explicitCertifiedRowWeight, certifiedConstantRowWeight, + certifiedRowPairEligibleBit, h] + Β· simp [explicitCertifiedRowWeight, certifiedConstantRowWeight, + certifiedRowPairEligibleBit, explicitGamma, h] + +/-- Inserts a row pair into a finite matching when it is disjoint from every selected pair. -/ +def greedyRowFinsetStep {n : β„•} + (selected : Finset (RowPair n)) (q : RowPair n) : Finset (RowPair n) := + if βˆ€ r ∈ selected, Disjoint q.1 r.1 then insert q selected else selected + +@[simp] theorem greedyRowListStep_toFinset {n : β„•} + (selected : List (RowPair n)) (q : RowPair n) : + (greedyRowListStep selected q).toFinset = + greedyRowFinsetStep selected.toFinset q := by + by_cases h : βˆ€ r ∈ selected, Disjoint q.1 r.1 + Β· have hfin : βˆ€ r ∈ selected.toFinset, Disjoint q.1 r.1 := by + simpa using! h + rw [greedyRowListStep, ite_eq_left h, + greedyRowFinsetStep, ite_eq_left hfin] + simp + Β· have hfin : Β¬(βˆ€ r ∈ selected.toFinset, Disjoint q.1 r.1) := by + simpa using! h + rw [greedyRowListStep, ite_eq_right h, + greedyRowFinsetStep, ite_eq_right hfin] + +theorem greedyRowListFold_toFinset {n : β„•} + (selected : List (RowPair n)) (edges : List (RowPair n)) : + (edges.foldl greedyRowListStep selected).toFinset = + edges.foldl greedyRowFinsetStep selected.toFinset := by + induction edges generalizing selected with + | nil => rfl + | cons q edges ih => + rw [List.foldl_cons, List.foldl_cons, ih, + greedyRowListStep_toFinset] + +theorem greedyRowMatchingList_eq_finsetFoldReverse {n : β„•} + (edges : List (RowPair n)) : + greedyRowMatchingList edges = + edges.reverse.foldl greedyRowFinsetStep βˆ… := by + induction edges with + | nil => rfl + | cons q edges ih => + rw [greedyRowMatchingList, List.reverse_cons, + List.foldl_append, ih] + simp [greedyRowFinsetStep] + +theorem certifiedGreedyTypedOuterScan_toFinset {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + (certifiedGreedyTypedOuterScan X [] + (List.finRange n).reverse).toFinset = + greedyThresholdRowMatching (explicitCertifiedRowWeight X) + explicitGamma := by + rw [certifiedGreedyTypedOuterScan_full_eq_edgeFold, + certifiedGreedyEdgeFold_eq_filter, + List.filter_reverse, + ← explicitThresholdRowPairsList_eq_certifiedFilter, + greedyRowListFold_toFinset] + simp only [List.toFinset_nil] + rw [← greedyRowMatchingList_eq_finsetFoldReverse] + rfl + +theorem rowPair_not_disjoint_self {n : β„•} (q : RowPair n) : + Β¬Disjoint q.1 q.1 := by + apply Finset.not_disjoint_iff.mpr + exact ⟨rowPairRow q 0, rowPairRow_mem q 0, rowPairRow_mem q 0⟩ + +theorem certifiedGreedyTypedStep_nodup {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) + {selected : List (RowPair n)} (hselected : selected.Nodup) : + (certifiedGreedyTypedStep X i selected j).Nodup := by + by_cases hij : i < j + Β· rw [certifiedGreedyTypedStep, dif_pos hij] + dsimp only + split_ifs with haccept + Β· rw [List.nodup_cons] + refine ⟨?_, hselected⟩ + intro hmem + exact rowPair_not_disjoint_self _ (haccept.2 _ hmem) + Β· exact hselected + Β· rw [certifiedGreedyTypedStep, dite_eq_right hij] + exact hselected + +theorem certifiedGreedyTypedInnerScan_nodup {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) + {selected : List (RowPair n)} (hselected : selected.Nodup) + (js : List (Fin n)) : + (certifiedGreedyTypedInnerScan X i selected js).Nodup := by + induction js generalizing selected with + | nil => exact hselected + | cons j js ih => + rw [certifiedGreedyTypedInnerScan, List.foldl_cons] + exact ih (certifiedGreedyTypedStep_nodup X i j hselected) + +theorem certifiedGreedyTypedOuterStep_nodup {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + {selected : List (RowPair n)} (hselected : selected.Nodup) (i : Fin n) : + (certifiedGreedyTypedOuterStep X selected i).Nodup := by + exact certifiedGreedyTypedInnerScan_nodup X i hselected _ + +theorem certifiedGreedyTypedOuterScan_nodup {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) + {selected : List (RowPair n)} (hselected : selected.Nodup) + (is : List (Fin n)) : + (certifiedGreedyTypedOuterScan X selected is).Nodup := by + induction is generalizing selected with + | nil => exact hselected + | cons i is ih => + rw [certifiedGreedyTypedOuterScan, List.foldl_cons] + exact ih (certifiedGreedyTypedOuterStep_nodup X hselected i) + +theorem certifiedGreedyTypedOuterScan_full_nodup {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + (certifiedGreedyTypedOuterScan X [] + (List.finRange n).reverse).Nodup := + certifiedGreedyTypedOuterScan_nodup X (by simp) _ + +@[simp] theorem machineGreedyMatchingSelected_typed_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineGreedyMatchingSelected (rationalOptimizerOutputCode ⟨X, R, C⟩) = + binaryListCode orderedRowPairCode + ((certifiedGreedyTypedOuterScan X [] + (List.finRange n).reverse).map rowPairEndpoints) := by + rw [machineGreedyMatchingSelected_encode, + ← certifiedGreedyOuterScan_map_endpoints X [] + (List.finRange n).reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerArithmetic.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerArithmetic.lean new file mode 100644 index 0000000000..b37bfbb3fd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerArithmetic.lean @@ -0,0 +1,437 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization + +/-! +# Polynomial-time signed integer arithmetic + +The arithmetic core uses a pair `(sign, absolute value)`, with a one-bit sign. +Conversion back to `integerBinaryCode` forces the sign to be nonnegative when +the magnitude is zero, avoiding the `Int.negSucc` negative-zero pitfall. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Interprets a Boolean sign and natural magnitude as an integer. -/ +def signedMagnitudeValue (negative : Bool) (magnitude : β„•) : β„€ := + if negative then -(magnitude : β„€) else magnitude + +/-- Converts signed magnitude to canonical integer code, forcing the zero code for an empty +magnitude. -/ +def machineCanonicalIntegerFromSignedAbs (word : List Bool) : List Bool := + machineIfEmpty (machinePairSecond word) [false] + (machineIntegerCodeFromSignedAbs word) + +/-- Extracts the sign bit and absolute-value bits of an encoded integer as a pair. -/ +def machineIntegerSignedMagnitude (word : List Bool) : List Bool := + pair (machineHeadBit word) (machineIntegerNatAbsBits word) + +/-- Extracts the left operand's sign from a pair of signed-magnitude operands. -/ +def machineSignedLeftSign (word : List Bool) : List Bool := + machinePairFirst (machinePairFirst word) + +/-- Extracts the left operand's magnitude from a pair of signed-magnitude operands. -/ +def machineSignedLeftAbs (word : List Bool) : List Bool := + machinePairSecond (machinePairFirst word) + +/-- Extracts the right operand's sign from a pair of signed-magnitude operands. -/ +def machineSignedRightSign (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond word) + +/-- Extracts the right operand's magnitude from a pair of signed-magnitude operands. -/ +def machineSignedRightAbs (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond word) + +/-- Tests whether the two signed-magnitude inputs have equal sign bits. -/ +def machineSignedSameSign (word : List Bool) : List Bool := + machineNotBit + (machineXorBit (machineSignedLeftSign word) (machineSignedRightSign word)) + +/-- Adds the two input magnitudes using binary natural-number addition. -/ +def machineSignedAbsSum (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineSignedLeftAbs word) (machineSignedRightAbs word)) + +/-- Tests whether the left input magnitude is at least the right input magnitude. -/ +def machineSignedLeftAbsGe (word : List Bool) : List Bool := + machineBinaryNatLeBit + (pair (machineSignedRightAbs word) (machineSignedLeftAbs word)) + +/-- Subtracts the right magnitude from the left using truncated binary subtraction. -/ +def machineSignedAbsLeftDiff (word : List Bool) : List Bool := + machineBinarySubBits + (pair (machineSignedLeftAbs word) (machineSignedRightAbs word)) + +/-- Subtracts the left magnitude from the right using truncated binary subtraction. -/ +def machineSignedAbsRightDiff (word : List Bool) : List Bool := + machineBinarySubBits + (pair (machineSignedRightAbs word) (machineSignedLeftAbs word)) + +/-- Selects the larger magnitude minus the smaller for addition of inputs with different signs. -/ +def machineSignedDifferentAbs (word : List Bool) : List Bool := + machineIfHead (machineSignedLeftAbsGe word) + (machineSignedAbsLeftDiff word) (machineSignedAbsRightDiff word) + +/-- Selects the sign of the larger magnitude for different-sign addition, choosing the left sign +on a tie. -/ +def machineSignedDifferentSign (word : List Bool) : List Bool := + machineIfHead (machineSignedLeftAbsGe word) + (machineSignedLeftSign word) (machineSignedRightSign word) + +/-- Addition on two signed-magnitude pairs. -/ +def machineSignedMagnitudeAdd (word : List Bool) : List Bool := + let sign := machineIfHead (machineSignedSameSign word) + (machineSignedLeftSign word) (machineSignedDifferentSign word) + let magnitude := machineIfHead (machineSignedSameSign word) + (machineSignedAbsSum word) (machineSignedDifferentAbs word) + machineCanonicalIntegerFromSignedAbs (pair sign magnitude) + +/-- Addition on a pair of canonical `integerBinaryCode`s. -/ +def machineIntegerAddCode (word : List Bool) : List Bool := + machineSignedMagnitudeAdd + (pair (machineIntegerSignedMagnitude (machinePairFirst word)) + (machineIntegerSignedMagnitude (machinePairSecond word))) + +/-- Multiplies the two input magnitudes using binary multiplication. -/ +def machineSignedAbsProduct (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineSignedLeftAbs word) (machineSignedRightAbs word)) + +/-- Computes the product sign by exclusive-or of the input signs. -/ +def machineSignedProductSign (word : List Bool) : List Bool := + machineXorBit (machineSignedLeftSign word) (machineSignedRightSign word) + +/-- Combines the product sign and magnitude into a canonical integer code. -/ +def machineSignedMagnitudeMul (word : List Bool) : List Bool := + machineCanonicalIntegerFromSignedAbs + (pair (machineSignedProductSign word) (machineSignedAbsProduct word)) + +/-- Multiplication on a pair of canonical `integerBinaryCode`s. -/ +def machineIntegerMulCode (word : List Bool) : List Bool := + machineSignedMagnitudeMul + (pair (machineIntegerSignedMagnitude (machinePairFirst word)) + (machineIntegerSignedMagnitude (machinePairSecond word))) + +/-- Negation of one canonical `integerBinaryCode`. -/ +def machineIntegerNegCode (word : List Bool) : List Bool := + let signed := machineIntegerSignedMagnitude word + machineCanonicalIntegerFromSignedAbs + (pair (machineNotBit (machinePairFirst signed)) + (machinePairSecond signed)) + +theorem machineCanonicalIntegerFromSignedAbs_mem_FP : + machineCanonicalIntegerFromSignedAbs ∈ Complexity.FP := by + simpa only [machineCanonicalIntegerFromSignedAbs] using! + machineIfEmpty_mem_FP machinePairSecond_mem_FP + (machineConst_mem_FP [false]) machineIntegerCodeFromSignedAbs_mem_FP + +theorem machineIntegerSignedMagnitude_mem_FP : + machineIntegerSignedMagnitude ∈ Complexity.FP := by + simpa only [machineIntegerSignedMagnitude] using! + machinePair_mem_FP machineHeadBit_mem_FP machineIntegerNatAbsBits_mem_FP + +theorem machineSignedLeftSign_mem_FP : machineSignedLeftSign ∈ Complexity.FP := by + simpa only [machineSignedLeftSign] using! + machineCompose_mem_FP machinePairFirst_mem_FP machinePairFirst_mem_FP + +theorem machineSignedLeftAbs_mem_FP : machineSignedLeftAbs ∈ Complexity.FP := by + simpa only [machineSignedLeftAbs] using! + machineCompose_mem_FP machinePairFirst_mem_FP machinePairSecond_mem_FP + +theorem machineSignedRightSign_mem_FP : machineSignedRightSign ∈ Complexity.FP := by + simpa only [machineSignedRightSign] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineSignedRightAbs_mem_FP : machineSignedRightAbs ∈ Complexity.FP := by + simpa only [machineSignedRightAbs] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineSignedSameSign_mem_FP : machineSignedSameSign ∈ Complexity.FP := by + exact machineNotBit_mem_FP + (machineXorBit_mem_FP machineSignedLeftSign_mem_FP + machineSignedRightSign_mem_FP) + +theorem machineSignedAbsSum_mem_FP : machineSignedAbsSum ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedLeftAbs_mem_FP + machineSignedRightAbs_mem_FP + simpa only [machineSignedAbsSum] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineSignedLeftAbsGe_mem_FP : machineSignedLeftAbsGe ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedRightAbs_mem_FP + machineSignedLeftAbs_mem_FP + simpa only [machineSignedLeftAbsGe] using! + machineCompose_mem_FP hpair machineBinaryNatLeBit_mem_FP + +theorem machineSignedAbsLeftDiff_mem_FP : + machineSignedAbsLeftDiff ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedLeftAbs_mem_FP + machineSignedRightAbs_mem_FP + simpa only [machineSignedAbsLeftDiff] using! + machineCompose_mem_FP hpair machineBinarySubBits_mem_FP + +theorem machineSignedAbsRightDiff_mem_FP : + machineSignedAbsRightDiff ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedRightAbs_mem_FP + machineSignedLeftAbs_mem_FP + simpa only [machineSignedAbsRightDiff] using! + machineCompose_mem_FP hpair machineBinarySubBits_mem_FP + +theorem machineSignedDifferentAbs_mem_FP : + machineSignedDifferentAbs ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineSignedLeftAbsGe_mem_FP + machineSignedAbsLeftDiff_mem_FP machineSignedAbsRightDiff_mem_FP + +theorem machineSignedDifferentSign_mem_FP : + machineSignedDifferentSign ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineSignedLeftAbsGe_mem_FP + machineSignedLeftSign_mem_FP machineSignedRightSign_mem_FP + +theorem machineSignedMagnitudeAdd_mem_FP : + machineSignedMagnitudeAdd ∈ Complexity.FP := by + have hsign := machineIfHead_mem_FP machineSignedSameSign_mem_FP + machineSignedLeftSign_mem_FP machineSignedDifferentSign_mem_FP + have hmagnitude := machineIfHead_mem_FP machineSignedSameSign_mem_FP + machineSignedAbsSum_mem_FP machineSignedDifferentAbs_mem_FP + have hpair := machinePair_mem_FP hsign hmagnitude + simpa only [machineSignedMagnitudeAdd] using! + machineCompose_mem_FP hpair machineCanonicalIntegerFromSignedAbs_mem_FP + +theorem machineIntegerAddCode_mem_FP : machineIntegerAddCode ∈ Complexity.FP := by + have hleft := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerSignedMagnitude_mem_FP + have hright := machineCompose_mem_FP machinePairSecond_mem_FP + machineIntegerSignedMagnitude_mem_FP + have hpair := machinePair_mem_FP hleft hright + simpa only [machineIntegerAddCode] using! + machineCompose_mem_FP hpair machineSignedMagnitudeAdd_mem_FP + +theorem machineSignedAbsProduct_mem_FP : + machineSignedAbsProduct ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedLeftAbs_mem_FP + machineSignedRightAbs_mem_FP + simpa only [machineSignedAbsProduct] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineSignedProductSign_mem_FP : + machineSignedProductSign ∈ Complexity.FP := by + exact machineXorBit_mem_FP machineSignedLeftSign_mem_FP + machineSignedRightSign_mem_FP + +theorem machineSignedMagnitudeMul_mem_FP : + machineSignedMagnitudeMul ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSignedProductSign_mem_FP + machineSignedAbsProduct_mem_FP + simpa only [machineSignedMagnitudeMul] using! + machineCompose_mem_FP hpair machineCanonicalIntegerFromSignedAbs_mem_FP + +theorem machineIntegerMulCode_mem_FP : machineIntegerMulCode ∈ Complexity.FP := by + have hleft := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerSignedMagnitude_mem_FP + have hright := machineCompose_mem_FP machinePairSecond_mem_FP + machineIntegerSignedMagnitude_mem_FP + have hpair := machinePair_mem_FP hleft hright + simpa only [machineIntegerMulCode] using! + machineCompose_mem_FP hpair machineSignedMagnitudeMul_mem_FP + +theorem machineIntegerNegCode_mem_FP : machineIntegerNegCode ∈ Complexity.FP := by + have hsigned := machineIntegerSignedMagnitude_mem_FP + have hsignProjection := machineCompose_mem_FP hsigned machinePairFirst_mem_FP + have hsign := machineNotBit_mem_FP hsignProjection + have habs := machineCompose_mem_FP hsigned machinePairSecond_mem_FP + have hpair := machinePair_mem_FP hsign habs + simpa only [machineIntegerNegCode] using! + machineCompose_mem_FP hpair machineCanonicalIntegerFromSignedAbs_mem_FP + +@[simp] theorem machineCanonicalIntegerFromSignedAbs_pair + (negative : Bool) (magnitude : β„•) : + machineCanonicalIntegerFromSignedAbs (pair [negative] magnitude.bits) = + integerBinaryCode (signedMagnitudeValue negative magnitude) := by + cases negative with + | false => + cases magnitude with + | zero => + rfl + | succ k => + rw [machineCanonicalIntegerFromSignedAbs] + simp only [machinePairSecond_pair] + rw [machineIfEmpty_of_ne_nil (k + 1).bits [false] + (machineIntegerCodeFromSignedAbs (pair [false] (k + 1).bits)) + (natBits_ne_nil_of_ne_zero (by omega))] + simp only [machineIntegerCodeFromSignedAbs, machinePairFirst_pair, + machinePairSecond_pair, machineIfHead_false, + signedMagnitudeValue] + change false :: (k + 1).bits = + integerBinaryCode (Int.ofNat (k + 1)) + rfl + | true => + cases magnitude with + | zero => + rfl + | succ k => + rw [machineCanonicalIntegerFromSignedAbs] + simp only [machinePairSecond_pair] + rw [machineIfEmpty_of_ne_nil (k + 1).bits [false] + (machineIntegerCodeFromSignedAbs (pair [true] (k + 1).bits)) + (natBits_ne_nil_of_ne_zero (by omega))] + simp only [signedMagnitudeValue, if_true] + simpa only [show ([true] : List Bool) = + integerBinaryCode (Int.negSucc 0) by rfl] using + machineIntegerCodeFromSignedAbs_negSucc 0 (k + 1) (by omega) + +theorem machineIntegerSignedMagnitude_encode (z : β„€) : + machineIntegerSignedMagnitude (integerBinaryCode z) = + match z with + | .ofNat n => pair [false] n.bits + | .negSucc n => pair [true] (n + 1).bits := by + rw [machineIntegerSignedMagnitude] + cases z with + | ofNat n => + rw [machineIntegerNatAbsBits_encode] + simp [integerBinaryCode] + | negSucc n => + rw [machineIntegerNatAbsBits_encode] + simp [integerBinaryCode] + +theorem machineSignedMagnitudeAdd_pair + (leftNegative rightNegative : Bool) (leftAbs rightAbs : β„•) : + machineSignedMagnitudeAdd + (pair (pair [leftNegative] leftAbs.bits) + (pair [rightNegative] rightAbs.bits)) = + integerBinaryCode + (signedMagnitudeValue leftNegative leftAbs + + signedMagnitudeValue rightNegative rightAbs) := by + cases leftNegative <;> cases rightNegative + Β· simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedAbsSum, machineBinaryAddBits_pair_natBits, + signedMagnitudeValue] + Β· by_cases h : rightAbs ≀ leftAbs + Β· simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedLeftAbsGe, machineSignedAbsLeftDiff, + machineSignedAbsRightDiff, machineSignedDifferentAbs, + machineSignedDifferentSign, machineBinaryNatLeBit_pair_natBits, + machineBinarySubBits_pair_natBits, signedMagnitudeValue, h] + congr 1 + Β· have hlt : leftAbs < rightAbs := Nat.lt_of_not_ge h + simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedLeftAbsGe, machineSignedAbsLeftDiff, + machineSignedAbsRightDiff, machineSignedDifferentAbs, + machineSignedDifferentSign, machineBinaryNatLeBit_pair_natBits, + machineBinarySubBits_pair_natBits, signedMagnitudeValue, h] + congr 1 + omega + Β· by_cases h : rightAbs ≀ leftAbs + Β· simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedLeftAbsGe, machineSignedAbsLeftDiff, + machineSignedAbsRightDiff, machineSignedDifferentAbs, + machineSignedDifferentSign, machineBinaryNatLeBit_pair_natBits, + machineBinarySubBits_pair_natBits, signedMagnitudeValue, h] + congr 1 + omega + Β· have hlt : leftAbs < rightAbs := Nat.lt_of_not_ge h + simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedLeftAbsGe, machineSignedAbsLeftDiff, + machineSignedAbsRightDiff, machineSignedDifferentAbs, + machineSignedDifferentSign, machineBinaryNatLeBit_pair_natBits, + machineBinarySubBits_pair_natBits, signedMagnitudeValue, h] + congr 1 + omega + Β· simp [machineSignedMagnitudeAdd, machineSignedSameSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedAbsSum, machineBinaryAddBits_pair_natBits, + signedMagnitudeValue] + congr 1 + omega + +theorem machineIntegerAddCode_encode (z w : β„€) : + machineIntegerAddCode (pair (integerBinaryCode z) (integerBinaryCode w)) = + integerBinaryCode (z + w) := by + cases z with + | ofNat n => + cases w with + | ofNat m => + simp [machineIntegerAddCode, machineIntegerSignedMagnitude_encode, + machineSignedMagnitudeAdd_pair, signedMagnitudeValue] + | negSucc m => + rw [machineIntegerAddCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineIntegerSignedMagnitude_encode, + machineSignedMagnitudeAdd_pair, signedMagnitudeValue] + congr 1 + | negSucc n => + cases w with + | ofNat m => + rw [machineIntegerAddCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineIntegerSignedMagnitude_encode, + machineSignedMagnitudeAdd_pair, signedMagnitudeValue] + congr 1 + | negSucc m => + rw [machineIntegerAddCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineIntegerSignedMagnitude_encode, + machineSignedMagnitudeAdd_pair, signedMagnitudeValue] + congr 1 + +theorem machineSignedMagnitudeMul_pair + (leftNegative rightNegative : Bool) (leftAbs rightAbs : β„•) : + machineSignedMagnitudeMul + (pair (pair [leftNegative] leftAbs.bits) + (pair [rightNegative] rightAbs.bits)) = + integerBinaryCode + (signedMagnitudeValue leftNegative leftAbs * + signedMagnitudeValue rightNegative rightAbs) := by + cases leftNegative <;> cases rightNegative <;> + simp [machineSignedMagnitudeMul, machineSignedProductSign, + machineSignedLeftSign, machineSignedRightSign, + machineSignedLeftAbs, machineSignedRightAbs, + machineSignedAbsProduct, machineBinaryMulBits_pair_natBits, + signedMagnitudeValue] <;> + congr 1 <;> ring + +theorem machineIntegerMulCode_encode (z w : β„€) : + machineIntegerMulCode (pair (integerBinaryCode z) (integerBinaryCode w)) = + integerBinaryCode (z * w) := by + cases z <;> cases w <;> + rw [machineIntegerMulCode] <;> + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineIntegerSignedMagnitude_encode, + machineSignedMagnitudeMul_pair, signedMagnitudeValue] <;> + congr 1 <;> ring + +theorem machineIntegerNegCode_encode (z : β„€) : + machineIntegerNegCode (integerBinaryCode z) = integerBinaryCode (-z) := by + cases z with + | ofNat n => + simp [machineIntegerNegCode, machineIntegerSignedMagnitude_encode, + signedMagnitudeValue] + | negSucc n => + rw [Int.neg_negSucc] + rw [machineIntegerNegCode, machineIntegerSignedMagnitude_encode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineNotBit_one, Bool.not_true] + simpa only [signedMagnitudeValue, ite_false] using! + machineCanonicalIntegerFromSignedAbs_pair false (n + 1) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerCompare.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerCompare.lean new file mode 100644 index 0000000000..69f5c0fa6f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerCompare.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerArithmetic + +/-! +# Polynomial-time signed-integer comparison + +Canonical integer codes carry one sign bit followed by the `Int.negSucc` +payload. We first convert both operands to true absolute values. Equal-sign +comparisons then reduce to natural comparison; for two negative operands the +order of the magnitudes is reversed. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Reads the sign bit of the left encoded integer in a pair. -/ +def machineIntegerLeftSign (word : List Bool) : List Bool := + machineHeadBit (machinePairFirst word) + +/-- Reads the sign bit of the right encoded integer in a pair. -/ +def machineIntegerRightSign (word : List Bool) : List Bool := + machineHeadBit (machinePairSecond word) + +/-- Computes the binary absolute value of the left encoded integer. -/ +def machineIntegerLeftAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machinePairFirst word) + +/-- Computes the binary absolute value of the right encoded integer. -/ +def machineIntegerRightAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machinePairSecond word) + +/-- Compares the left absolute value with the right in the order used for nonnegative integer +comparison. -/ +def machineIntegerPositiveLeBit (word : List Bool) : List Bool := + machineBinaryNatLeBit + (pair (machineIntegerLeftAbsBits word) (machineIntegerRightAbsBits word)) + +/-- Compares the right absolute value with the left in the reversed order used for negative +integer comparison. -/ +def machineIntegerNegativeLeBit (word : List Bool) : List Bool := + machineBinaryNatLeBit + (pair (machineIntegerRightAbsBits word) (machineIntegerLeftAbsBits word)) + +/-- One-bit test for `z ≀ w` on a pair of canonical integer encodings. -/ +def machineIntegerLeCode (word : List Bool) : List Bool := + machineIfHead (machineIntegerLeftSign word) + (machineIfHead (machineIntegerRightSign word) + (machineIntegerNegativeLeBit word) [true]) + (machineIfHead (machineIntegerRightSign word) + [false] (machineIntegerPositiveLeBit word)) + +theorem machineIntegerLeftSign_mem_FP : + machineIntegerLeftSign ∈ Complexity.FP := by + simpa only [machineIntegerLeftSign] using! + machineCompose_mem_FP machinePairFirst_mem_FP machineHeadBit_mem_FP + +theorem machineIntegerRightSign_mem_FP : + machineIntegerRightSign ∈ Complexity.FP := by + simpa only [machineIntegerRightSign] using! + machineCompose_mem_FP machinePairSecond_mem_FP machineHeadBit_mem_FP + +theorem machineIntegerLeftAbsBits_mem_FP : + machineIntegerLeftAbsBits ∈ Complexity.FP := by + simpa only [machineIntegerLeftAbsBits] using! + machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineIntegerRightAbsBits_mem_FP : + machineIntegerRightAbsBits ∈ Complexity.FP := by + simpa only [machineIntegerRightAbsBits] using! + machineCompose_mem_FP machinePairSecond_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineIntegerPositiveLeBit_mem_FP : + machineIntegerPositiveLeBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineIntegerLeftAbsBits_mem_FP + machineIntegerRightAbsBits_mem_FP + simpa only [machineIntegerPositiveLeBit] using! + machineCompose_mem_FP hpair machineBinaryNatLeBit_mem_FP + +theorem machineIntegerNegativeLeBit_mem_FP : + machineIntegerNegativeLeBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineIntegerRightAbsBits_mem_FP + machineIntegerLeftAbsBits_mem_FP + simpa only [machineIntegerNegativeLeBit] using! + machineCompose_mem_FP hpair machineBinaryNatLeBit_mem_FP + +theorem machineIntegerLeCode_mem_FP : machineIntegerLeCode ∈ Complexity.FP := by + have hnegativeLeft := machineIfHead_mem_FP machineIntegerRightSign_mem_FP + machineIntegerNegativeLeBit_mem_FP (machineConst_mem_FP [true]) + have hpositiveLeft := machineIfHead_mem_FP machineIntegerRightSign_mem_FP + (machineConst_mem_FP [false]) machineIntegerPositiveLeBit_mem_FP + exact machineIfHead_mem_FP machineIntegerLeftSign_mem_FP + hnegativeLeft hpositiveLeft + +theorem machineIntegerLeCode_encode (z w : β„€) : + machineIntegerLeCode + (pair (integerBinaryCode z) (integerBinaryCode w)) = + [decide (z ≀ w)] := by + cases z <;> cases w <;> + simp only [machineIntegerLeCode, machineIntegerLeftSign, + machineIntegerRightSign, machineIntegerPositiveLeBit, + machineIntegerNegativeLeBit, machineIntegerLeftAbsBits, + machineIntegerRightAbsBits, machinePairFirst_pair, + machinePairSecond_pair, machineIntegerNatAbsBits_encode] <;> + simp [integerBinaryCode, machineBinaryNatLeBit_pair_natBits] <;> + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerSignedMagnitude.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerSignedMagnitude.lean new file mode 100644 index 0000000000..6e7584fd58 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineIntegerSignedMagnitude.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryGCD +public import LeanPool.BeyondBethe.BeyondBethe.MachineOutputEncoding +public import LeanPool.BeyondBethe.BeyondBethe.RawRational + +/-! +# Signed integers at the rational-arithmetic boundary + +The project encoding follows Lean's constructors: `Int.ofNat n` is +`false :: n.bits`, whereas `Int.negSucc n` is `true :: n.bits`. Thus the +payload of a negative integer is one less than its absolute value. The +machines below perform the required conversion explicitly. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Adds one to a negative integer payload to recover the magnitude represented by +`Int.negSucc`. -/ +def machineIntegerNegativeAbsBits (word : List Bool) : List Bool := + machineBinaryAddBits (pair word.tail [true]) + +/-- Canonical absolute-value bits from an `integerBinaryCode`. -/ +def machineIntegerNatAbsBits (word : List Bool) : List Bool := + machineIfHead word (machineIntegerNegativeAbsBits word) word.tail + +/-- Subtracts one from a magnitude to obtain the payload for `Int.negSucc`. -/ +def machineIntegerNegativePayloadBits (absBits : List Bool) : List Bool := + machineBinarySubBits (pair absBits [true]) + +/-- Input is `pair originalIntegerCode absoluteValueBits`. The output has the +sign of the original integer and the supplied absolute value. -/ +def machineIntegerCodeFromSignedAbs (word : List Bool) : List Bool := + let signCode := machinePairFirst word + let absBits := machinePairSecond word + machineIfHead signCode + (true :: machineIntegerNegativePayloadBits absBits) + (false :: absBits) + +theorem machineIntegerNegativeAbsBits_mem_FP : + machineIntegerNegativeAbsBits ∈ Complexity.FP := by + have hpair : (fun word : List Bool => pair word.tail [true]) ∈ + Complexity.FP := + machinePair_mem_FP machineTail_mem_FP (machineConst_mem_FP [true]) + simpa only [machineIntegerNegativeAbsBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineIntegerNatAbsBits_mem_FP : + machineIntegerNatAbsBits ∈ Complexity.FP := by + simpa only [machineIntegerNatAbsBits] using! + machineIfHead_mem_FP id_mem_FP machineIntegerNegativeAbsBits_mem_FP + machineTail_mem_FP + +theorem machineIntegerNegativePayloadBits_mem_FP : + machineIntegerNegativePayloadBits ∈ Complexity.FP := by + have hpair : (fun absBits : List Bool => pair absBits [true]) ∈ + Complexity.FP := + machinePair_mem_FP id_mem_FP (machineConst_mem_FP [true]) + simpa only [machineIntegerNegativePayloadBits] using! + machineCompose_mem_FP hpair machineBinarySubBits_mem_FP + +theorem machineIntegerCodeFromSignedAbs_mem_FP : + machineIntegerCodeFromSignedAbs ∈ Complexity.FP := by + have hnegativePayload := machineCompose_mem_FP machinePairSecond_mem_FP + machineIntegerNegativePayloadBits_mem_FP + have hnegative := machineCompose_mem_FP hnegativePayload + (machinePrepend_mem_FP true) + have hpositive := machineCompose_mem_FP machinePairSecond_mem_FP + (machinePrepend_mem_FP false) + simpa only [machineIntegerCodeFromSignedAbs] using! + machineIfHead_mem_FP machinePairFirst_mem_FP hnegative hpositive + +theorem machineIntegerNatAbsBits_encode (z : β„€) : + machineIntegerNatAbsBits (integerBinaryCode z) = z.natAbs.bits := by + cases z with + | ofNat n => simp [machineIntegerNatAbsBits, integerBinaryCode] + | negSucc n => + simp only [machineIntegerNatAbsBits, integerBinaryCode, + machineIfHead_true, machineIntegerNegativeAbsBits, List.tail_cons] + simpa using! machineBinaryAddBits_pair_natBits n 1 + +theorem machineIntegerCodeFromSignedAbs_ofNat (n magnitude : β„•) : + machineIntegerCodeFromSignedAbs + (pair (integerBinaryCode (Int.ofNat n)) magnitude.bits) = + integerBinaryCode (Int.ofNat magnitude) := by + simp [machineIntegerCodeFromSignedAbs, integerBinaryCode] + +theorem machineIntegerCodeFromSignedAbs_negSucc (n magnitude : β„•) + (hmagnitude : 0 < magnitude) : + machineIntegerCodeFromSignedAbs + (pair (integerBinaryCode (Int.negSucc n)) magnitude.bits) = + integerBinaryCode (-(magnitude : β„€)) := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hmagnitude.ne' + simp only [machineIntegerCodeFromSignedAbs, machinePairFirst_pair, + machinePairSecond_pair, integerBinaryCode, machineIfHead_true, + machineIntegerNegativePayloadBits] + rw [show ([true] : List Bool) = (1 : β„•).bits by rfl] + rw [machineBinarySubBits_pair_natBits] + have hneg : -((k + 1 : β„•) : β„€) = Int.negSucc k := by omega + rw [hneg] + rfl + +/-- Restoring the sign after exact division agrees with the semantic signed +division routine used by `binaryNormalizeRawRat`. -/ +theorem machineIntegerCodeFromSignedAbs_div (z : β„€) (d : β„•) + (hd : 0 < d) (hdvd : d ∣ z.natAbs) : + machineIntegerCodeFromSignedAbs + (pair (integerBinaryCode z) (z.natAbs / d).bits) = + integerBinaryCode (binaryIntDivNat z d) := by + cases z with + | ofNat n => + rw [machineIntegerCodeFromSignedAbs_ofNat] + by_cases hn : n = 0 + Β· subst n + simp [binaryIntDivNat, binaryLongDiv_eq_div_mod] + Β· obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn + simp [binaryIntDivNat, binaryLongDiv_eq_div_mod] + | negSucc n => + have hle : d ≀ n + 1 := Nat.le_of_dvd (by omega) hdvd + have hquotPos : 0 < (n + 1) / d := Nat.div_pos hle hd + change machineIntegerCodeFromSignedAbs + (pair (integerBinaryCode (Int.negSucc n)) ((n + 1) / d).bits) = _ + rw [machineIntegerCodeFromSignedAbs_negSucc n ((n + 1) / d) hquotPos] + simp [binaryIntDivNat, binaryLongDiv_eq_div_mod] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnEncoding.lean new file mode 100644 index 0000000000..cd943c434a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnEncoding.lean @@ -0,0 +1,702 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryRange + +/-! +# Finite-word encoding of the explicit Kuhn evaluator + +Every natural index is unary. Boolean visited sets and column-mate tables are +right-nested lists, and the recursive continuation is an explicit +right-nested stack. The rational matrix and the dimension-derived constant +words are carried unchanged beside the control word. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Semantic tables -/ + +/-- Lists the membership bits of the seen-column set in finite-index order. -/ +def seenBoolList {n : β„•} (seen : Finset (Fin n)) : List Bool := + List.ofFn fun i ↦ decide (i ∈ seen) + +/-- Lists each column's optional matched row, replacing finite row indices by natural numbers. -/ +def columnMateList {n : β„•} (mate : ColumnMate n) : List (Option β„•) := + List.ofFn fun j ↦ (mate j).map Fin.val + +/-- Encodes a list of finite indices using unary codes for its entries. -/ +def finListUnaryCode {n : β„•} (xs : List (Fin n)) : List Bool := + binaryListCode finUnaryCode xs + +@[simp] theorem seenBoolList_length {n : β„•} (seen : Finset (Fin n)) : + (seenBoolList seen).length = n := by + simp [seenBoolList] + +@[simp] theorem columnMateList_length {n : β„•} (mate : ColumnMate n) : + (columnMateList mate).length = n := by + simp [columnMateList] + +@[simp] theorem seenBoolList_getElem {n : β„•} (seen : Finset (Fin n)) + (i : β„•) (hi : i < (seenBoolList seen).length) : + (seenBoolList seen)[i] = decide (⟨i, by simpa using! hi⟩ ∈ seen) := by + simp [seenBoolList] + +@[simp] theorem columnMateList_getElem {n : β„•} (mate : ColumnMate n) + (i : β„•) (hi : i < (columnMateList mate).length) : + (columnMateList mate)[i] = + (mate ⟨i, by simpa using! hi⟩).map Fin.val := by + simp [columnMateList] + +theorem seenBoolList_insert {n : β„•} (seen : Finset (Fin n)) (col : Fin n) : + seenBoolList (insert col seen) = + (seenBoolList seen).set col.1 true := by + apply List.ext_get + Β· simp + Β· intro i hi hi' + simp only [seenBoolList_length] at hi hi' + by_cases h : i = col.1 + Β· subst i + simp [seenBoolList] + Β· have hfin : (⟨i, hi⟩ : Fin n) β‰  col := by + intro heq + exact h (congrArg Fin.val heq) + have hrev : col.1 β‰  i := by exact fun heq ↦ h heq.symm + simp [seenBoolList, List.getElem_set, h, hrev, hfin] + +theorem columnMateList_update {n : β„•} (mate : ColumnMate n) + (col : Fin n) (value : Option (Fin n)) : + columnMateList (Function.update mate col value) = + (columnMateList mate).set col.1 (value.map Fin.val) := by + apply List.ext_get + Β· simp + Β· intro i hi hi' + simp only [columnMateList_length] at hi hi' + by_cases h : i = col.1 + Β· subst i + simp [columnMateList, Function.update] + Β· have hfin : (⟨i, hi⟩ : Fin n) β‰  col := by + intro heq + exact h (congrArg Fin.val heq) + have hrev : col.1 β‰  i := by exact fun heq ↦ h heq.symm + simp [columnMateList, Function.update, List.getElem_set, h, hrev, hfin] + +/-! ## Frame codes -/ + +/-- Packs the search continuation's fuel, remaining columns, row, saved matching, and selected +column. -/ +def machineKuhnSearchFramePack + (fuel remaining row mate column : List Bool) : List Bool := + pair fuel (pair remaining (pair row (pair mate column))) + +/-- Packs the build continuation's remaining rows and fallback matching. -/ +def machineKuhnBuildFramePack (rows fallback : List Bool) : List Bool := + pair rows fallback + +/-- Encodes a semantic search frame with unary fuel and indices and the encoded column-mate +vector. -/ +def kuhnSearchFrameCode {n : β„•} (frame : KuhnSearchFrame n) : List Bool := + machineKuhnSearchFramePack (List.replicate frame.fuel true) + (finListUnaryCode frame.remaining) (finUnaryCode frame.row) + (mateVectorCode (columnMateList frame.mate)) + (finUnaryCode frame.column) + +/-- Encodes a semantic build frame using its remaining row list and fallback column-mate vector. -/ +def kuhnBuildFrameCode {n : β„•} (frame : KuhnBuildFrame n) : List Bool := + machineKuhnBuildFramePack (finListUnaryCode frame.rows) + (mateVectorCode (columnMateList frame.fallback)) + +/-- Encodes a Kuhn continuation frame with a false tag for search frames and a true tag for +build frames. -/ +def kuhnFrameCode {n : β„•} : KuhnFrame n β†’ List Bool + | .search frame => pair [false] (kuhnSearchFrameCode frame) + | .build frame => pair [true] (kuhnBuildFrameCode frame) + +/-- Encodes a stack of tagged Kuhn continuation frames as a binary list. -/ +def kuhnStackCode {n : β„•} (stack : List (KuhnFrame n)) : List Bool := + binaryListCode kuhnFrameCode stack + +/-- Extracts the search-or-build tag from an encoded Kuhn continuation frame. -/ +def machineKuhnFrameTag (frame : List Bool) : List Bool := + machinePairFirst frame + +/-- Extracts the fields following an encoded Kuhn frame's tag. -/ +def machineKuhnFramePayload (frame : List Bool) : List Bool := + machinePairSecond frame + +/-- Extracts the unary fuel field from a tagged search continuation. -/ +def machineKuhnSearchFrameFuel (frame : List Bool) : List Bool := + machinePairFirst (machineKuhnFramePayload frame) + +/-- Extracts the encoded remaining-column list from a tagged search continuation. -/ +def machineKuhnSearchFrameRemaining (frame : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineKuhnFramePayload frame)) + +/-- Extracts the unary row field from a tagged search continuation. -/ +def machineKuhnSearchFrameRow (frame : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machineKuhnFramePayload frame))) + +/-- Extracts the saved column-mate vector from a tagged search continuation. -/ +def machineKuhnSearchFrameMate (frame : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machinePairSecond (machinePairSecond (machineKuhnFramePayload frame)))) + +/-- Extracts the selected column ruler from a tagged search continuation. -/ +def machineKuhnSearchFrameColumn (frame : List Bool) : List Bool := + machinePairSecond (machinePairSecond + (machinePairSecond (machinePairSecond (machineKuhnFramePayload frame)))) + +/-- Extracts the remaining-row list from a tagged build continuation. -/ +def machineKuhnBuildFrameRows (frame : List Bool) : List Bool := + machinePairFirst (machineKuhnFramePayload frame) + +/-- Extracts the fallback matching from a tagged build continuation. -/ +def machineKuhnBuildFrameFallback (frame : List Bool) : List Bool := + machinePairSecond (machineKuhnFramePayload frame) + +/-- Reads the first encoded continuation frame from a Kuhn stack. -/ +def machineKuhnStackHead (stack : List Bool) : List Bool := + machineListHead stack + +/-- Removes the first encoded continuation frame from a Kuhn stack. -/ +def machineKuhnStackTail (stack : List Bool) : List Bool := + machineListTail stack + +/-- Prepends an encoded continuation frame to a Kuhn stack. -/ +def machineKuhnStackPush (frame stack : List Bool) : List Bool := + pair frame stack + +/-! ## Control codes -/ + +/-- Packs the fuel, remaining columns, row, seen bits, matching, and continuation stack of a +Kuhn search call. -/ +def machineKuhnCallPack (fuel remaining row seen mate stack : List Bool) : + List Bool := + pair fuel (pair remaining (pair row (pair seen (pair mate stack)))) + +/-- Packs the success flag, seen bits, matching, and continuation stack of a Kuhn return state. -/ +def machineKuhnReturnPack (success seen mate stack : List Bool) : List Bool := + pair success (pair seen (pair mate stack)) + +/-- Builds a Kuhn call control word with the false tag and the complete search-call payload. -/ +def machineKuhnControlCall + (fuel remaining row seen mate stack : List Bool) : List Bool := + pair [false] (machineKuhnCallPack fuel remaining row seen mate stack) + +/-- Builds a Kuhn return control word with tag `[true, false]` and its result payload. -/ +def machineKuhnControlReturn + (success seen mate stack : List Bool) : List Bool := + pair [true, false] (machineKuhnReturnPack success seen mate stack) + +/-- Builds a completed Kuhn control word with tag `[true, true]` and the resulting matching. -/ +def machineKuhnControlDone (mate : List Bool) : List Bool := + pair [true, true] mate + +/-- Extracts the call, return, or completion tag from a Kuhn control word. -/ +def machineKuhnControlTag (control : List Bool) : List Bool := + machinePairFirst control + +/-- Extracts the payload following a Kuhn control word's tag. -/ +def machineKuhnControlPayload (control : List Bool) : List Bool := + machinePairSecond control + +/-- Reads the second control-tag bit, which distinguishes completed states among the +return-or-done tags. -/ +def machineKuhnControlIsDoneBit (control : List Bool) : List Bool := + machineHeadBit (machineKuhnControlTag control).tail + +/-- Extracts the unary fuel field from a Kuhn call control word. -/ +def machineKuhnCallFuel (control : List Bool) : List Bool := + machinePairFirst (machineKuhnControlPayload control) + +/-- Extracts the remaining-column list from a Kuhn call control word. -/ +def machineKuhnCallRemaining (control : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineKuhnControlPayload control)) + +/-- Extracts the current row ruler from a Kuhn call control word. -/ +def machineKuhnCallRow (control : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machineKuhnControlPayload control))) + +/-- Extracts the seen-column bits from a Kuhn call control word. -/ +def machineKuhnCallSeen (control : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machinePairSecond (machinePairSecond (machineKuhnControlPayload control)))) + +/-- Extracts the column-mate vector from a Kuhn call control word. -/ +def machineKuhnCallMate (control : List Bool) : List Bool := + machinePairFirst + (machinePairSecond + (machinePairSecond + (machinePairSecond + (machinePairSecond (machineKuhnControlPayload control))))) + +/-- Extracts the continuation stack from a Kuhn call control word. -/ +def machineKuhnCallStack (control : List Bool) : List Bool := + machinePairSecond + (machinePairSecond + (machinePairSecond + (machinePairSecond + (machinePairSecond (machineKuhnControlPayload control))))) + +/-- Extracts the success flag from a Kuhn return control word. -/ +def machineKuhnReturnSuccess (control : List Bool) : List Bool := + machinePairFirst (machineKuhnControlPayload control) + +/-- Extracts the updated seen-column bits from a Kuhn return control word. -/ +def machineKuhnReturnSeen (control : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machineKuhnControlPayload control)) + +/-- Extracts the returned matching from a Kuhn return control word. -/ +def machineKuhnReturnMate (control : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machineKuhnControlPayload control))) + +/-- Extracts the continuation stack from a Kuhn return control word. -/ +def machineKuhnReturnStack (control : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machineKuhnControlPayload control))) + +/-- Extracts the final matching from a completed Kuhn control word. -/ +def machineKuhnDoneMate (control : List Bool) : List Bool := + machineKuhnControlPayload control + +/-- Encodes a search result's matching when present, using the empty word when the search +failed. -/ +def kuhnSearchResultMateCode {n : β„•} (result : KuhnSearchResult n) : List Bool := + match result.mate? with + | none => [] + | some mate => mateVectorCode (columnMateList mate) + +/-- Encodes semantic Kuhn call, return, and completed states, including unary indices, seen +bits, matching vectors, and continuation stacks. -/ +def kuhnControlCode {n : β„•} : KuhnEvalState n β†’ List Bool + | .call fuel remaining row seen mate stack => + machineKuhnControlCall (List.replicate fuel true) + (finListUnaryCode remaining) (finUnaryCode row) + (boolVectorCode (seenBoolList seen)) + (mateVectorCode (columnMateList mate)) (kuhnStackCode stack) + | .ret result stack => + machineKuhnControlReturn [result.mate?.isSome] + (boolVectorCode (seenBoolList result.seen)) + (kuhnSearchResultMateCode result) (kuhnStackCode stack) + | .done mate => + machineKuhnControlDone (mateVectorCode (columnMateList mate)) + +/-! ## Whole-state code and projections -/ + +/-- Packs a Kuhn control word with its fixed matrix, dimension, column list, all-false seen +vector, and length bound. -/ +def machineKuhnStatePack + (control matrix dimension columns falseSeen bound : List Bool) : List Bool := + pair control + (pair matrix (pair dimension (pair columns (pair falseSeen bound)))) + +/-- Extracts the control word from an encoded Kuhn machine state. -/ +def machineKuhnStateControl (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the fixed matrix word from an encoded Kuhn machine state. -/ +def machineKuhnStateMatrix (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the unary dimension from an encoded Kuhn machine state. -/ +def machineKuhnStateDimension (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the fixed complete column list from an encoded Kuhn machine state. -/ +def machineKuhnStateColumns (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the fixed all-false seen vector from an encoded Kuhn machine state. -/ +def machineKuhnStateFalseSeen (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Extracts the word that bounds the field lengths of a Kuhn machine state. -/ +def machineKuhnStateBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Applies the binary-multiplication width construction to the list-update input bound to +obtain the Kuhn field bound. -/ +def machineKuhnInputBound (matrix : List Bool) : List Bool := + machineBinaryMulWidth (machineListUpdateInputBound matrix) + +/-- Encodes a semantic Kuhn state with its rational matrix, unary dimension, complete index +list, all-false seen vector, and computed bound. -/ +def kuhnMachineStateCode {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) + (state : KuhnEvalState n) : List Bool := + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let dimension := List.replicate n true + machineKuhnStatePack (kuhnControlCode state) matrix dimension + (finRangeUnaryCode n) + (boolVectorCode (List.replicate n false)) + (machineKuhnInputBound matrix) + +@[simp] theorem machineKuhnStateControl_pack (a b c d e f) : + machineKuhnStateControl (machineKuhnStatePack a b c d e f) = a := by + simp [machineKuhnStateControl, machineKuhnStatePack] + +@[simp] theorem machineKuhnStateMatrix_pack (a b c d e f) : + machineKuhnStateMatrix (machineKuhnStatePack a b c d e f) = b := by + simp [machineKuhnStateMatrix, machineKuhnStatePack] + +@[simp] theorem machineKuhnStateDimension_pack (a b c d e f) : + machineKuhnStateDimension (machineKuhnStatePack a b c d e f) = c := by + simp [machineKuhnStateDimension, machineKuhnStatePack] + +@[simp] theorem machineKuhnStateColumns_pack (a b c d e f) : + machineKuhnStateColumns (machineKuhnStatePack a b c d e f) = d := by + simp [machineKuhnStateColumns, machineKuhnStatePack] + +@[simp] theorem machineKuhnStateFalseSeen_pack (a b c d e f) : + machineKuhnStateFalseSeen (machineKuhnStatePack a b c d e f) = e := by + simp [machineKuhnStateFalseSeen, machineKuhnStatePack] + +@[simp] theorem machineKuhnStateBound_pack (a b c d e f) : + machineKuhnStateBound (machineKuhnStatePack a b c d e f) = f := by + simp [machineKuhnStateBound, machineKuhnStatePack] + +@[simp] theorem machineKuhnControlTag_call (a b c d e f) : + machineKuhnControlTag (machineKuhnControlCall a b c d e f) = [false] := by + simp [machineKuhnControlTag, machineKuhnControlCall] + +@[simp] theorem machineKuhnControlTag_return (a b c d) : + machineKuhnControlTag (machineKuhnControlReturn a b c d) = + [true, false] := by + simp [machineKuhnControlTag, machineKuhnControlReturn] + +@[simp] theorem machineKuhnControlTag_done (a) : + machineKuhnControlTag (machineKuhnControlDone a) = [true, true] := by + simp [machineKuhnControlTag, machineKuhnControlDone] + +@[simp] theorem machineKuhnControlIsDoneBit_call (a b c d e f) : + machineKuhnControlIsDoneBit (machineKuhnControlCall a b c d e f) = + [false] := by + simp [machineKuhnControlIsDoneBit] + +@[simp] theorem machineKuhnControlIsDoneBit_return (a b c d) : + machineKuhnControlIsDoneBit (machineKuhnControlReturn a b c d) = + [false] := by + simp [machineKuhnControlIsDoneBit] + +@[simp] theorem machineKuhnControlIsDoneBit_done (a) : + machineKuhnControlIsDoneBit (machineKuhnControlDone a) = [true] := by + simp [machineKuhnControlIsDoneBit] + +@[simp] theorem machineKuhnCallFuel_pack (a b c d e f) : + machineKuhnCallFuel (machineKuhnControlCall a b c d e f) = a := by + simp [machineKuhnCallFuel, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnCallRemaining_pack (a b c d e f) : + machineKuhnCallRemaining (machineKuhnControlCall a b c d e f) = b := by + simp [machineKuhnCallRemaining, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnCallRow_pack (a b c d e f) : + machineKuhnCallRow (machineKuhnControlCall a b c d e f) = c := by + simp [machineKuhnCallRow, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnCallSeen_pack (a b c d e f) : + machineKuhnCallSeen (machineKuhnControlCall a b c d e f) = d := by + simp [machineKuhnCallSeen, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnCallMate_pack (a b c d e f) : + machineKuhnCallMate (machineKuhnControlCall a b c d e f) = e := by + simp [machineKuhnCallMate, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnCallStack_pack (a b c d e f) : + machineKuhnCallStack (machineKuhnControlCall a b c d e f) = f := by + simp [machineKuhnCallStack, machineKuhnControlCall, + machineKuhnControlPayload, machineKuhnCallPack] + +@[simp] theorem machineKuhnReturnSuccess_pack (a b c d) : + machineKuhnReturnSuccess (machineKuhnControlReturn a b c d) = a := by + simp [machineKuhnReturnSuccess, machineKuhnControlReturn, + machineKuhnControlPayload, machineKuhnReturnPack] + +@[simp] theorem machineKuhnReturnSeen_pack (a b c d) : + machineKuhnReturnSeen (machineKuhnControlReturn a b c d) = b := by + simp [machineKuhnReturnSeen, machineKuhnControlReturn, + machineKuhnControlPayload, machineKuhnReturnPack] + +@[simp] theorem machineKuhnReturnMate_pack (a b c d) : + machineKuhnReturnMate (machineKuhnControlReturn a b c d) = c := by + simp [machineKuhnReturnMate, machineKuhnControlReturn, + machineKuhnControlPayload, machineKuhnReturnPack] + +@[simp] theorem machineKuhnReturnStack_pack (a b c d) : + machineKuhnReturnStack (machineKuhnControlReturn a b c d) = d := by + simp [machineKuhnReturnStack, machineKuhnControlReturn, + machineKuhnControlPayload, machineKuhnReturnPack] + +@[simp] theorem machineKuhnDoneMate_pack (a) : + machineKuhnDoneMate (machineKuhnControlDone a) = a := by + simp [machineKuhnDoneMate, machineKuhnControlDone, + machineKuhnControlPayload] + +@[simp] theorem machineKuhnFrameTag_search (a b c d e) : + machineKuhnFrameTag + (pair [false] (machineKuhnSearchFramePack a b c d e)) = [false] := by + simp [machineKuhnFrameTag] + +@[simp] theorem machineKuhnFrameTag_build (a b) : + machineKuhnFrameTag + (pair [true] (machineKuhnBuildFramePack a b)) = [true] := by + simp [machineKuhnFrameTag] + +@[simp] theorem machineKuhnSearchFrameFuel_pack (a b c d e) : + machineKuhnSearchFrameFuel + (pair [false] (machineKuhnSearchFramePack a b c d e)) = a := by + simp [machineKuhnSearchFrameFuel, machineKuhnFramePayload, + machineKuhnSearchFramePack] + +@[simp] theorem machineKuhnSearchFrameRemaining_pack (a b c d e) : + machineKuhnSearchFrameRemaining + (pair [false] (machineKuhnSearchFramePack a b c d e)) = b := by + simp [machineKuhnSearchFrameRemaining, machineKuhnFramePayload, + machineKuhnSearchFramePack] + +@[simp] theorem machineKuhnSearchFrameRow_pack (a b c d e) : + machineKuhnSearchFrameRow + (pair [false] (machineKuhnSearchFramePack a b c d e)) = c := by + simp [machineKuhnSearchFrameRow, machineKuhnFramePayload, + machineKuhnSearchFramePack] + +@[simp] theorem machineKuhnSearchFrameMate_pack (a b c d e) : + machineKuhnSearchFrameMate + (pair [false] (machineKuhnSearchFramePack a b c d e)) = d := by + simp [machineKuhnSearchFrameMate, machineKuhnFramePayload, + machineKuhnSearchFramePack] + +@[simp] theorem machineKuhnSearchFrameColumn_pack (a b c d e) : + machineKuhnSearchFrameColumn + (pair [false] (machineKuhnSearchFramePack a b c d e)) = e := by + simp [machineKuhnSearchFrameColumn, machineKuhnFramePayload, + machineKuhnSearchFramePack] + +@[simp] theorem machineKuhnBuildFrameRows_pack (a b) : + machineKuhnBuildFrameRows + (pair [true] (machineKuhnBuildFramePack a b)) = a := by + simp [machineKuhnBuildFrameRows, machineKuhnFramePayload, + machineKuhnBuildFramePack] + +@[simp] theorem machineKuhnBuildFrameFallback_pack (a b) : + machineKuhnBuildFrameFallback + (pair [true] (machineKuhnBuildFramePack a b)) = b := by + simp [machineKuhnBuildFrameFallback, machineKuhnFramePayload, + machineKuhnBuildFramePack] + +@[simp] theorem machineKuhnStackHead_cons {n : β„•} + (frame : KuhnFrame n) (stack : List (KuhnFrame n)) : + machineKuhnStackHead (kuhnStackCode (frame :: stack)) = + kuhnFrameCode frame := by + exact machineListHead_cons kuhnFrameCode frame stack + +@[simp] theorem machineKuhnStackTail_cons {n : β„•} + (frame : KuhnFrame n) (stack : List (KuhnFrame n)) : + machineKuhnStackTail (kuhnStackCode (frame :: stack)) = + kuhnStackCode stack := by + exact machineListTail_cons kuhnFrameCode frame stack + +/-! The projections below are all constant-depth pairing operations. -/ + +theorem machineKuhnStateControl_mem_FP : + machineKuhnStateControl ∈ Complexity.FP := machinePairFirst_mem_FP +theorem machineKuhnStateMatrix_mem_FP : + machineKuhnStateMatrix ∈ Complexity.FP := by + simpa only [machineKuhnStateMatrix] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP +theorem machineKuhnStateDimension_mem_FP : + machineKuhnStateDimension ∈ Complexity.FP := by + have h := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineKuhnStateDimension] using! + machineCompose_mem_FP h machinePairFirst_mem_FP +theorem machineKuhnStateColumns_mem_FP : + machineKuhnStateColumns ∈ Complexity.FP := by + have h2 := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have h3 := machineCompose_mem_FP h2 machinePairSecond_mem_FP + simpa only [machineKuhnStateColumns] using! + machineCompose_mem_FP h3 machinePairFirst_mem_FP +theorem machineKuhnStateFalseSeen_mem_FP : + machineKuhnStateFalseSeen ∈ Complexity.FP := by + have h2 := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have h3 := machineCompose_mem_FP h2 machinePairSecond_mem_FP + have h4 := machineCompose_mem_FP h3 machinePairSecond_mem_FP + simpa only [machineKuhnStateFalseSeen] using! + machineCompose_mem_FP h4 machinePairFirst_mem_FP +theorem machineKuhnStateBound_mem_FP : + machineKuhnStateBound ∈ Complexity.FP := by + have h2 := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have h3 := machineCompose_mem_FP h2 machinePairSecond_mem_FP + have h4 := machineCompose_mem_FP h3 machinePairSecond_mem_FP + simpa only [machineKuhnStateBound] using! + machineCompose_mem_FP h4 machinePairSecond_mem_FP +theorem machineKuhnFrameTag_mem_FP : + machineKuhnFrameTag ∈ Complexity.FP := machinePairFirst_mem_FP +theorem machineKuhnFramePayload_mem_FP : + machineKuhnFramePayload ∈ Complexity.FP := machinePairSecond_mem_FP +theorem machineKuhnStackHead_mem_FP : + machineKuhnStackHead ∈ Complexity.FP := machineListHead_mem_FP +theorem machineKuhnStackTail_mem_FP : + machineKuhnStackTail ∈ Complexity.FP := machineListTail_mem_FP +theorem machineKuhnControlTag_mem_FP : + machineKuhnControlTag ∈ Complexity.FP := machinePairFirst_mem_FP +theorem machineKuhnControlPayload_mem_FP : + machineKuhnControlPayload ∈ Complexity.FP := machinePairSecond_mem_FP + +/-- Follows the second projection of a nested pair exactly `depth` times. -/ +def machinePairSecondN (depth : β„•) (word : List Bool) : List Bool := + (machinePairSecond)^[depth] word + +theorem machinePairSecondN_mem_FP (depth : β„•) : + machinePairSecondN depth ∈ Complexity.FP := by + induction depth with + | zero => simpa [machinePairSecondN] using! id_mem_FP + | succ depth ih => + simpa [machinePairSecondN, Function.iterate_succ_apply] using! + machineCompose_mem_FP machinePairSecond_mem_FP ih + +theorem machineKuhnControlIsDoneBit_mem_FP : + machineKuhnControlIsDoneBit ∈ Complexity.FP := by + have htagTail := machineCompose_mem_FP + (machineCompose_mem_FP machineKuhnControlTag_mem_FP machineTail_mem_FP) + machineHeadBit_mem_FP + simpa only [machineKuhnControlIsDoneBit] using! htagTail + +theorem machineKuhnCallFuel_mem_FP : + machineKuhnCallFuel ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 1) + machinePairFirst_mem_FP + simpa [machineKuhnCallFuel, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnCallRemaining_mem_FP : + machineKuhnCallRemaining ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 2) + machinePairFirst_mem_FP + simpa [machineKuhnCallRemaining, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnCallRow_mem_FP : + machineKuhnCallRow ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 3) + machinePairFirst_mem_FP + simpa [machineKuhnCallRow, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnCallSeen_mem_FP : + machineKuhnCallSeen ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 4) + machinePairFirst_mem_FP + simpa [machineKuhnCallSeen, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnCallMate_mem_FP : + machineKuhnCallMate ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 5) + machinePairFirst_mem_FP + simpa [machineKuhnCallMate, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnCallStack_mem_FP : + machineKuhnCallStack ∈ Complexity.FP := by + simpa [machineKuhnCallStack, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! + machinePairSecondN_mem_FP 6 + +theorem machineKuhnReturnSuccess_mem_FP : + machineKuhnReturnSuccess ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 1) + machinePairFirst_mem_FP + simpa [machineKuhnReturnSuccess, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnReturnSeen_mem_FP : + machineKuhnReturnSeen ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 2) + machinePairFirst_mem_FP + simpa [machineKuhnReturnSeen, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnReturnMate_mem_FP : + machineKuhnReturnMate ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 3) + machinePairFirst_mem_FP + simpa [machineKuhnReturnMate, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnReturnStack_mem_FP : + machineKuhnReturnStack ∈ Complexity.FP := by + simpa [machineKuhnReturnStack, machineKuhnControlPayload, + machinePairSecondN, Function.iterate_succ_apply'] using! + machinePairSecondN_mem_FP 4 + +theorem machineKuhnDoneMate_mem_FP : + machineKuhnDoneMate ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineKuhnSearchFrameFuel_mem_FP : + machineKuhnSearchFrameFuel ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 1) + machinePairFirst_mem_FP + simpa [machineKuhnSearchFrameFuel, machineKuhnFramePayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnSearchFrameRemaining_mem_FP : + machineKuhnSearchFrameRemaining ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 2) + machinePairFirst_mem_FP + simpa [machineKuhnSearchFrameRemaining, machineKuhnFramePayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnSearchFrameRow_mem_FP : + machineKuhnSearchFrameRow ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 3) + machinePairFirst_mem_FP + simpa [machineKuhnSearchFrameRow, machineKuhnFramePayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnSearchFrameMate_mem_FP : + machineKuhnSearchFrameMate ∈ Complexity.FP := by + have h := machineCompose_mem_FP (machinePairSecondN_mem_FP 4) + machinePairFirst_mem_FP + simpa [machineKuhnSearchFrameMate, machineKuhnFramePayload, + machinePairSecondN, Function.iterate_succ_apply'] using! h + +theorem machineKuhnSearchFrameColumn_mem_FP : + machineKuhnSearchFrameColumn ∈ Complexity.FP := by + simpa [machineKuhnSearchFrameColumn, machineKuhnFramePayload, + machinePairSecondN, Function.iterate_succ_apply'] using! + machinePairSecondN_mem_FP 5 + +theorem machineKuhnBuildFrameRows_mem_FP : + machineKuhnBuildFrameRows ∈ Complexity.FP := by + have h := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairFirst_mem_FP + simpa [machineKuhnBuildFrameRows, machineKuhnFramePayload] using! h + +theorem machineKuhnBuildFrameFallback_mem_FP : + machineKuhnBuildFrameFallback ∈ Complexity.FP := by + simpa [machineKuhnBuildFrameFallback, machineKuhnFramePayload] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnInvariant.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnInvariant.lean new file mode 100644 index 0000000000..9165e8dd7b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnInvariant.lean @@ -0,0 +1,599 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnSemantics +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import Mathlib.Tactic + +/-! +# Reachable-state bounds for the encoded Kuhn evaluator + +The finite-word transition clamps every dynamic field to one fixed word. This +file proves that the clamp is inactive along the canonical execution. We use +a deliberately generous octic envelope; its only purpose is to make the +polynomial-space estimate transparent. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## A semantic invariant -/ + +/-- Bounds search-frame fuel by `n + 1` and remaining columns by `n`, or build-frame remaining +rows by `n`. -/ +def KuhnFrameDataBound (n : β„•) : KuhnFrame n β†’ Prop + | .search frame => frame.fuel ≀ n + 1 ∧ frame.remaining.length ≀ n + | .build frame => frame.rows.length ≀ n + +/-- Requires every frame in a continuation stack to satisfy its frame-data bounds. -/ +def KuhnStackDataBound {n : β„•} (stack : List (KuhnFrame n)) : Prop := + βˆ€ frame ∈ stack, KuhnFrameDataBound n frame + +/-- Bounds active call data and every continuation frame, with stack length at most `steps + 1`; +completed states impose no further bound. -/ +def KuhnEvalReachableBound {n : β„•} (steps : β„•) : + KuhnEvalState n β†’ Prop + | .call fuel remaining _row _seen _mate stack => + fuel ≀ n + 1 ∧ remaining.length ≀ n ∧ + KuhnStackDataBound stack ∧ stack.length ≀ steps + 1 + | .ret _result stack => + KuhnStackDataBound stack ∧ stack.length ≀ steps + 1 + | .done _mate => True + +theorem kuhnStackDataBound_tail {n : β„•} {frame : KuhnFrame n} + {stack : List (KuhnFrame n)} + (h : KuhnStackDataBound (frame :: stack)) : + KuhnStackDataBound stack := by + intro next hnext + exact h next (by simp [hnext]) + +theorem kuhnEvalStep_reachableBound {n steps : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) + (hstate : KuhnEvalReachableBound steps state) : + KuhnEvalReachableBound (steps + 1) (kuhnEvalStep A state) := by + cases state with + | done mate => trivial + | call fuel remaining row seen mate stack => + rcases hstate with ⟨hfuel, hremaining, hstack, hlength⟩ + cases fuel with + | zero => + exact ⟨hstack, by omega⟩ + | succ fuel => + cases remaining with + | nil => + exact ⟨hstack, by omega⟩ + | cons col remaining => + simp only [List.length_cons] at hremaining + by_cases hskip : col ∈ seen ∨ A row col = 0 + Β· simp only [kuhnEvalStep, hskip, ↓reduceIte] + exact ⟨hfuel, by omega, hstack, by omega⟩ + Β· simp only [kuhnEvalStep, hskip, ↓reduceIte] + cases hmate : mate col with + | none => + exact ⟨hstack, by omega⟩ + | some oldRow => + refine ⟨by omega, by simp, ?_, by simp; omega⟩ + intro frame hframe + simp only [List.mem_cons] at hframe + rcases hframe with rfl | hframe + Β· change fuel + 1 ≀ n + 1 ∧ remaining.length ≀ n + exact ⟨hfuel, by omega⟩ + Β· exact hstack frame hframe + | ret result stack => + rcases hstate with ⟨hstack, hlength⟩ + cases stack with + | nil => exact ⟨by simp [KuhnStackDataBound], by omega⟩ + | cons frame stack => + have htail := kuhnStackDataBound_tail hstack + have hframe := hstack frame (by simp) + cases frame with + | search frame => + rcases hframe with ⟨hfuel, hremaining⟩ + cases hmate : result.mate? with + | none => + simp only [kuhnEvalStep, hmate] + exact ⟨hfuel, hremaining, htail, by simp at hlength ⊒; omega⟩ + | some mate => + simp only [kuhnEvalStep, hmate] + exact ⟨htail, by simp at hlength ⊒; omega⟩ + | build frame => + rcases frame with ⟨rows, fallback⟩ + change rows.length ≀ n at hframe + cases hmate : result.mate? with + | none => + cases rows with + | nil => simp [kuhnEvalStep, hmate, KuhnEvalReachableBound] + | cons row rows => + simp only [List.length_cons] at hframe + simp only [kuhnEvalStep, hmate] + refine ⟨by omega, by simp, ?_, by simp at hlength ⊒; omega⟩ + intro next hnext + simp only [List.mem_cons] at hnext + rcases hnext with rfl | hnext + Β· change rows.length ≀ n + omega + Β· exact htail next hnext + | some mate => + cases rows with + | nil => simp [kuhnEvalStep, hmate, KuhnEvalReachableBound] + | cons row rows => + simp only [List.length_cons] at hframe + simp only [kuhnEvalStep, hmate] + refine ⟨by omega, by simp, ?_, by simp at hlength ⊒; omega⟩ + intro next hnext + simp only [List.mem_cons] at hnext + rcases hnext with rfl | hnext + Β· change rows.length ≀ n + omega + Β· exact htail next hnext + +theorem kuhnBuildEvalState_reachableBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (rows : List (Fin n)) + (mate : ColumnMate n) (hrows : rows.length ≀ n) : + KuhnEvalReachableBound 0 (kuhnBuildEvalState A rows mate) := by + cases rows with + | nil => trivial + | cons row rows => + simp only [List.length_cons] at hrows + refine ⟨by omega, by simp, ?_, by simp⟩ + intro frame hframe + simp only [List.mem_singleton] at hframe + subst frame + change rows.length ≀ n + omega + +theorem kuhnFullBuildEvalState_reachableBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + KuhnEvalReachableBound 0 + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) := by + exact kuhnBuildEvalState_reachableBound A _ _ (by simp) + +theorem kuhnEvalIterate_reachableBound {n steps : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) + (hstate : KuhnEvalReachableBound 0 state) : + KuhnEvalReachableBound steps ((kuhnEvalStep A)^[steps] state) := by + induction steps with + | zero => simpa using! hstate + | succ steps ih => + rw [Function.iterate_succ_apply'] + simpa [Nat.succ_eq_add_one] using! + kuhnEvalStep_reachableBound A _ ih + +/-! ## Length of canonical control words -/ + +theorem finUnaryCode_length_le {n : β„•} (i : Fin n) : + (finUnaryCode i).length ≀ n := by + simp [finUnaryCode] + +theorem finListUnaryCode_length_le {n : β„•} (xs : List (Fin n)) : + (finListUnaryCode xs).length ≀ xs.length * (2 * n + 2) := by + induction xs with + | nil => simp [finListUnaryCode, binaryListCode] + | cons i xs ih => + simp only [finListUnaryCode, binaryListCode, pair_length, + List.length_cons] + have hi := finUnaryCode_length_le i + change 2 * (finUnaryCode i).length + 2 + + (binaryListCode finUnaryCode xs).length ≀ + (xs.length + 1) * (2 * n + 2) + change (binaryListCode finUnaryCode xs).length ≀ + xs.length * (2 * n + 2) at ih + nlinarith + +@[simp] theorem boolVectorCode_length (v : List Bool) : + (boolVectorCode v).length = 4 * v.length := by + induction v with + | nil => simp [boolVectorCode, binaryListCode] + | cons bit v ih => + change (binaryListCode boolElementCode v).length = 4 * v.length at ih + simp [boolVectorCode, binaryListCode, boolElementCode, ih] + omega + +theorem mateVectorCode_columnMate_length_le {n : β„•} + (mate : ColumnMate n) : + (mateVectorCode (columnMateList mate)).length ≀ n * (2 * n + 4) := by + rw [mateVectorCode, binaryListCode_length_eq_sum] + have heach : βˆ€ value ∈ columnMateList mate, + 2 * (mateValueCode value).length + 2 ≀ 2 * n + 4 := by + intro value hvalue + rw [columnMateList] at hvalue + obtain ⟨j, rfl⟩ := List.mem_ofFn.mp hvalue + cases hmate : mate j with + | none => simp [mateValueCode, hmate] + | some row => + simp [mateValueCode, hmate] + omega + calc + ((columnMateList mate).map + (fun value ↦ 2 * (mateValueCode value).length + 2)).sum ≀ + (columnMateList mate).length * (2 * n + 4) := by + simpa [Nat.nsmul_eq_mul] using! + List.sum_le_card_nsmul + ((columnMateList mate).map + (fun value ↦ 2 * (mateValueCode value).length + 2)) + (2 * n + 4) (by + intro value hvalue + obtain ⟨source, hsource, rfl⟩ := List.mem_map.mp hvalue + exact heach source hsource) + _ = n * (2 * n + 4) := by simp + +theorem kuhnFrameCode_length_le {n : β„•} (frame : KuhnFrame n) + (hframe : KuhnFrameDataBound n frame) : + (kuhnFrameCode frame).length ≀ 16 * (n + 1) ^ 2 := by + cases frame with + | search frame => + rcases hframe with ⟨hfuel, hremaining⟩ + have hrem := finListUnaryCode_length_le frame.remaining + have hrem' : (finListUnaryCode frame.remaining).length ≀ + n * (2 * n + 2) := by + exact hrem.trans (Nat.mul_le_mul_right (2 * n + 2) hremaining) + have hrow := finUnaryCode_length_le frame.row + have hcol := finUnaryCode_length_le frame.column + have hmate := mateVectorCode_columnMate_length_le frame.mate + simp only [kuhnFrameCode, kuhnSearchFrameCode, + machineKuhnSearchFramePack, pair_length] + simp only [List.length_singleton, List.length_replicate] + nlinarith [sq_nonneg (n : β„€)] + | build frame => + have hrem := finListUnaryCode_length_le frame.rows + have hrem' : (finListUnaryCode frame.rows).length ≀ + n * (2 * n + 2) := by + exact hrem.trans (Nat.mul_le_mul_right (2 * n + 2) hframe) + have hmate := mateVectorCode_columnMate_length_le frame.fallback + simp only [kuhnFrameCode, kuhnBuildFrameCode, + machineKuhnBuildFramePack, pair_length, List.length_singleton] + nlinarith [sq_nonneg (n : β„€)] + +theorem kuhnStackCode_length_le {n : β„•} (stack : List (KuhnFrame n)) + (hstack : KuhnStackDataBound stack) : + (kuhnStackCode stack).length ≀ + 34 * (n + 1) ^ 2 * stack.length := by + induction stack with + | nil => simp [kuhnStackCode, binaryListCode] + | cons frame stack ih => + have hframe := kuhnFrameCode_length_le frame (hstack frame (by simp)) + have htail : KuhnStackDataBound stack := + kuhnStackDataBound_tail hstack + have ih' := ih htail + simp only [kuhnStackCode, binaryListCode, pair_length, + List.length_cons] + change 2 * (kuhnFrameCode frame).length + 2 + + (binaryListCode kuhnFrameCode stack).length ≀ + 34 * (n + 1) ^ 2 * (stack.length + 1) + change (binaryListCode kuhnFrameCode stack).length ≀ + 34 * (n + 1) ^ 2 * stack.length at ih' + have hone : 1 ≀ (n + 1) ^ 2 := + Nat.one_le_pow 2 (n + 1) (by omega) + have hframeContribution : + 2 * (kuhnFrameCode frame).length + 2 ≀ + 34 * (n + 1) ^ 2 := by nlinarith + calc + 2 * (kuhnFrameCode frame).length + 2 + + (binaryListCode kuhnFrameCode stack).length ≀ + 34 * (n + 1) ^ 2 + + 34 * (n + 1) ^ 2 * stack.length := by omega + _ = 34 * (n + 1) ^ 2 * (stack.length + 1) := by ring + +theorem kuhnControlCode_length_le {n steps : β„•} + (state : KuhnEvalState n) + (hstate : KuhnEvalReachableBound steps state) : + (kuhnControlCode state).length ≀ + 50 * (steps + 1) * (n + 1) ^ 2 := by + cases state with + | call fuel remaining row seen mate stack => + rcases hstate with ⟨hfuel, hremaining, hstack, hstackLength⟩ + have hrem := finListUnaryCode_length_le remaining + have hrem' : (finListUnaryCode remaining).length ≀ + n * (2 * n + 2) := + hrem.trans (Nat.mul_le_mul_right (2 * n + 2) hremaining) + have hrow := finUnaryCode_length_le row + have hseen : (boolVectorCode (seenBoolList seen)).length = 4 * n := by + simp + have hmate := mateVectorCode_columnMate_length_le mate + have hstackCode := kuhnStackCode_length_le stack hstack + have hstackCode' : (kuhnStackCode stack).length ≀ + 34 * (n + 1) ^ 2 * (steps + 1) := + hstackCode.trans + (Nat.mul_le_mul_left (34 * (n + 1) ^ 2) hstackLength) + simp only [kuhnControlCode, machineKuhnControlCall, + machineKuhnCallPack, pair_length, List.length_singleton, + List.length_replicate] + nlinarith [sq_nonneg (n : β„€)] + | ret result stack => + rcases hstate with ⟨hstack, hstackLength⟩ + have hseen : (boolVectorCode (seenBoolList result.seen)).length = + 4 * n := by simp + have hmate : (kuhnSearchResultMateCode result).length ≀ + n * (2 * n + 4) := by + cases hmateEq : result.mate? with + | none => simp [kuhnSearchResultMateCode, hmateEq] + | some mate => simpa [kuhnSearchResultMateCode, hmateEq] using! + mateVectorCode_columnMate_length_le mate + have hstackCode := kuhnStackCode_length_le stack hstack + have hstackCode' : (kuhnStackCode stack).length ≀ + 34 * (n + 1) ^ 2 * (steps + 1) := + hstackCode.trans + (Nat.mul_le_mul_left (34 * (n + 1) ^ 2) hstackLength) + simp only [kuhnControlCode, machineKuhnControlReturn, + machineKuhnReturnPack, pair_length, List.length_cons, + List.length_nil] + nlinarith [sq_nonneg (n : β„€)] + | done mate => + have hmate := mateVectorCode_columnMate_length_le mate + simp only [kuhnControlCode, machineKuhnControlDone, pair_length, + List.length_cons, List.length_nil] + nlinarith [sq_nonneg (n : β„€)] + +/-! ## The fixed octic envelope -/ + +/-- Provides the semantic Kuhn step budget `3 * (n * (n + (n + 1) * n)) + 2 * n`. -/ +def kuhnMachineStepBudget (n : β„•) : β„• := + 3 * (n * (n + (n + 1) * n)) + 2 * n + +theorem kuhnFullBuildSteps_le_budget {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnBuildSteps A (List.finRange n) (emptyColumnMate n) ≀ + kuhnMachineStepBudget n := by + exact kuhnFullBuildSteps_le A + +theorem kuhnMachineInputBound_eighthPower (word : List Bool) : + (word.length + 16) ^ 8 ≀ (machineKuhnInputBound word).length := by + simp only [machineKuhnInputBound, machineListUpdateInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + ring_nf + omega + +theorem kuhnControlPolynomial_le_eighthPower (n : β„•) : + 50 * (kuhnMachineStepBudget n + 1) * (n + 1) ^ 2 ≀ + (n + 16) ^ 8 := by + simp only [kuhnMachineStepBudget] + ring_nf + omega + +theorem kuhnQuadraticContext_le_eighthPower (n : β„•) : + n * (2 * n + 2) ≀ (n + 16) ^ 8 := by + ring_nf + omega + +theorem kuhnLinearContext_le_eighthPower (n : β„•) : + 4 * n ≀ (n + 16) ^ 8 := by + ring_nf + omega + +theorem kuhnMatrixLength_le_eighthPower (length : β„•) : + length ≀ (length + 16) ^ 8 := by + ring_nf + omega + +theorem kuhnControlCode_length_le_inputBound {n steps : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) + (hstate : KuhnEvalReachableBound steps state) + (hsteps : steps ≀ kuhnMachineStepBudget n) : + (kuhnControlCode state).length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hcontrol := kuhnControlCode_length_le state hstate + have hstepFactor : + 50 * (steps + 1) * (n + 1) ^ 2 ≀ + 50 * (kuhnMachineStepBudget n + 1) * (n + 1) ^ 2 := by + have := Nat.mul_le_mul_left 50 (Nat.add_le_add_right hsteps 1) + exact Nat.mul_le_mul_right ((n + 1) ^ 2) this + have hn : n + 16 ≀ matrix.length + 16 := by + exact Nat.add_le_add_right (matrix_dimension_le_code_length A) 16 + exact hcontrol.trans <| hstepFactor.trans <| + (kuhnControlPolynomial_le_eighthPower n).trans <| + (Nat.pow_le_pow_left hn 8).trans <| + kuhnMachineInputBound_eighthPower matrix + +theorem kuhnMatrixCode_length_le_inputBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩).length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + exact (kuhnMatrixLength_le_eighthPower matrix.length).trans + (kuhnMachineInputBound_eighthPower matrix) + +theorem kuhnDimensionCode_length_le_inputBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (List.replicate n true).length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + have hn := matrix_dimension_le_code_length A + simpa using! hn.trans (kuhnMatrixCode_length_le_inputBound A) + +theorem kuhnColumnsCode_length_le_inputBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (finRangeUnaryCode n).length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hcolumns : (finRangeUnaryCode n).length ≀ n * (2 * n + 2) := by + simpa [finRangeUnaryCode, finListUnaryCode] using! + finListUnaryCode_length_le (List.finRange n) + have hn : n + 16 ≀ matrix.length + 16 := by + exact Nat.add_le_add_right (matrix_dimension_le_code_length A) 16 + exact hcolumns.trans <| (kuhnQuadraticContext_le_eighthPower n).trans <| + (Nat.pow_le_pow_left hn 8).trans <| + kuhnMachineInputBound_eighthPower matrix + +theorem kuhnFalseSeenCode_length_le_inputBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (boolVectorCode (List.replicate n false)).length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hfalse : (boolVectorCode (List.replicate n false)).length = 4 * n := by + simp + have hn : n + 16 ≀ matrix.length + 16 := by + exact Nat.add_le_add_right (matrix_dimension_le_code_length A) 16 + rw [hfalse] + exact (kuhnLinearContext_le_eighthPower n).trans <| + (Nat.pow_le_pow_left hn 8).trans <| + kuhnMachineInputBound_eighthPower matrix + +theorem machineKuhnClamp_stateCode_eq {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) + (candidate : List Bool) + (hcandidate : candidate.length ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length) : + machineKuhnClamp (kuhnMachineStateCode A state) candidate = candidate := by + simp only [machineKuhnClamp, machineKuhnBound_stateCode] + exact List.take_of_length_le hcandidate + +theorem machineKuhnStep_encode {n steps : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) + (hstate : KuhnEvalReachableBound steps state) + (hnextSteps : steps + 1 ≀ kuhnMachineStepBudget n) : + machineKuhnStep (kuhnMachineStateCode A state) = + kuhnMachineStateCode A (kuhnEvalStep A state) := by + have hnext := kuhnEvalStep_reachableBound A state hstate + have hcontrol := kuhnControlCode_length_le_inputBound A + (kuhnEvalStep A state) hnext hnextSteps + rw [machineKuhnStep, machineKuhnNextControl_encode] + simp only [machineKuhnWithControl] + rw [machineKuhnClamp_stateCode_eq A state _ hcontrol] + simp only [machineKuhnMatrix_stateCode, machineKuhnDimension_stateCode, + machineKuhnColumns_stateCode, machineKuhnFalseSeen_stateCode, + machineKuhnBound_stateCode] + rw [machineKuhnClamp_stateCode_eq A state _ + (kuhnMatrixCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A state _ + (kuhnDimensionCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A state _ + (kuhnColumnsCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A state _ + (kuhnFalseSeenCode_length_le_inputBound A)] + simp [kuhnMachineStateCode] + +/-! ## Exact bounded execution -/ + +theorem machineKuhnIterate_encode {n iterations : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (initial : KuhnEvalState n) + (hinitial : KuhnEvalReachableBound 0 initial) + (hiterations : iterations ≀ kuhnMachineStepBudget n) : + (machineKuhnStep^[iterations]) (kuhnMachineStateCode A initial) = + kuhnMachineStateCode A ((kuhnEvalStep A)^[iterations] initial) := by + induction iterations with + | zero => simp + | succ iterations ih => + have hprefix : iterations ≀ kuhnMachineStepBudget n := by omega + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', + ih hprefix] + apply machineKuhnStep_encode A + Β· exact kuhnEvalIterate_reachableBound A initial hinitial + Β· simpa [Nat.succ_eq_add_one] using! hiterations + +@[simp] theorem kuhnEvalIterate_done {n iterations : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) : + (kuhnEvalStep A)^[iterations] (.done mate) = .done mate := by + induction iterations with + | zero => rfl + | succ iterations ih => + rw [Function.iterate_succ_apply', ih] + rfl + +theorem kuhnFullEval_budget {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (kuhnEvalStep A)^[kuhnMachineStepBudget n] + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) = + .done (kuhnColumnMate A) := by + let exactSteps := + kuhnBuildSteps A (List.finRange n) (emptyColumnMate n) + have hexact : exactSteps ≀ kuhnMachineStepBudget n := + kuhnFullBuildSteps_le_budget A + rw [show kuhnMachineStepBudget n = + (kuhnMachineStepBudget n - exactSteps) + exactSteps by omega, + Function.iterate_add_apply] + rw [show (kuhnEvalStep A)^[exactSteps] + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) = + .done (kuhnColumnMate A) by + simpa [exactSteps] using! kuhnFullBuildEvalState_iterate A] + simp + +theorem machineKuhnFullIterate_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (machineKuhnStep^[kuhnMachineStepBudget n]) + (kuhnMachineStateCode A + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n))) = + kuhnMachineStateCode A (.done (kuhnColumnMate A)) := by + rw [machineKuhnIterate_encode A _ + (kuhnFullBuildEvalState_reachableBound A) (le_rfl), + kuhnFullEval_budget] + +theorem machineKuhnStep_done_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) : + machineKuhnStep (kuhnMachineStateCode A (.done mate)) = + kuhnMachineStateCode A (.done mate) := by + have hcontrol := kuhnControlCode_length_le_inputBound A (.done mate) + (by trivial) (Nat.zero_le _) + rw [machineKuhnStep, machineKuhnNextControl_encode] + simp only [kuhnEvalStep, machineKuhnWithControl] + rw [machineKuhnClamp_stateCode_eq A (.done mate) _ hcontrol] + simp only [machineKuhnMatrix_stateCode, machineKuhnDimension_stateCode, + machineKuhnColumns_stateCode, machineKuhnFalseSeen_stateCode, + machineKuhnBound_stateCode] + rw [machineKuhnClamp_stateCode_eq A (.done mate) _ + (kuhnMatrixCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A (.done mate) _ + (kuhnDimensionCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A (.done mate) _ + (kuhnColumnsCode_length_le_inputBound A)] + rw [machineKuhnClamp_stateCode_eq A (.done mate) _ + (kuhnFalseSeenCode_length_le_inputBound A)] + simp [kuhnMachineStateCode] + +theorem kuhnMachineStepBudget_le_inputBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + kuhnMachineStepBudget n ≀ + (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hsmall : kuhnMachineStepBudget n ≀ + 50 * (kuhnMachineStepBudget n + 1) * (n + 1) ^ 2 := by + have hone : 1 ≀ (n + 1) ^ 2 := + Nat.one_le_pow 2 (n + 1) (by omega) + nlinarith + have hn : n + 16 ≀ matrix.length + 16 := by + exact Nat.add_le_add_right (matrix_dimension_le_code_length A) 16 + exact hsmall.trans <| (kuhnControlPolynomial_le_eighthPower n).trans <| + (Nat.pow_le_pow_left hn 8).trans <| + kuhnMachineInputBound_eighthPower matrix + +theorem machineKuhnFullBoundIterate_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + let iterations := (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length + (machineKuhnStep^[iterations]) + (kuhnMachineStateCode A + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n))) = + kuhnMachineStateCode A (.done (kuhnColumnMate A)) := by + dsimp only + let iterations := (machineKuhnInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length + have hbudget : kuhnMachineStepBudget n ≀ iterations := + kuhnMachineStepBudget_le_inputBound A + change (machineKuhnStep^[iterations]) + (kuhnMachineStateCode A + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n))) = + kuhnMachineStateCode A (.done (kuhnColumnMate A)) + rw [show iterations = + (iterations - kuhnMachineStepBudget n) + kuhnMachineStepBudget n by + omega, + Function.iterate_add_apply, machineKuhnFullIterate_encode] + induction (iterations - kuhnMachineStepBudget n) with + | zero => rfl + | succ remaining ih => + rw [Function.iterate_succ_apply', ih, machineKuhnStep_done_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnRunner.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnRunner.lean new file mode 100644 index 0000000000..e233246ab1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnRunner.lean @@ -0,0 +1,469 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnInvariant +public import Mathlib.Tactic + +/-! +# A complete finite-word perfect-matching runner + +This file constructs the initial Kuhn state directly from a rational-matrix +word and iterates the verified transition for the length of its fixed octic +envelope. All definitions are total on malformed words; the correctness +theorems concern canonical matrix encodings. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Initializer -/ + +/-- Extracts the unary matrix dimension for Kuhn initialization. -/ +def machineKuhnInitDimension (matrix : List Bool) : List Bool := + machineMatrixDimensionUnary matrix + +/-- Builds the encoded complete index range from the unary input dimension. -/ +def machineKuhnInitColumns (matrix : List Bool) : List Bool := + machineUnaryRangeCode (machineKuhnInitDimension matrix) + +/-- Builds an all-false seen-column vector of the input dimension. -/ +def machineKuhnInitFalseSeen (matrix : List Bool) : List Bool := + machineFalseVectorCode (machineKuhnInitDimension matrix) + +/-- Builds the empty column-mate vector of the input dimension. -/ +def machineKuhnInitEmptyMate (matrix : List Bool) : List Bool := + machineEmptyMateVectorCode (machineKuhnInitDimension matrix) + +/-- Builds the initial tagged build continuation with all rows after the first and an empty +fallback matching. -/ +def machineKuhnInitBuildFrame (matrix : List Bool) : List Bool := + pair [true] + (machineKuhnBuildFramePack (machineListTail (machineKuhnInitColumns matrix)) + (machineKuhnInitEmptyMate matrix)) + +/-- Creates the initial one-frame continuation stack for the Kuhn matching builder. -/ +def machineKuhnInitStack (matrix : List Bool) : List Bool := + machineKuhnStackPush (machineKuhnInitBuildFrame matrix) [] + +/-- Initializes a nonempty-dimensional search at the first row with fuel `n + 1`, all columns, +empty seen and mate vectors, and the build continuation. -/ +def machineKuhnInitNonemptyControl (matrix : List Bool) : List Bool := + machineKuhnControlCall (true :: machineKuhnInitDimension matrix) + (machineKuhnInitColumns matrix) + (machineListHead (machineKuhnInitColumns matrix)) + (machineKuhnInitFalseSeen matrix) (machineKuhnInitEmptyMate matrix) + (machineKuhnInitStack matrix) + +/-- Returns a completed empty matching for dimension zero and initializes the first search +otherwise. -/ +def machineKuhnInitControl (matrix : List Bool) : List Bool := + machineIfEmpty (machineKuhnInitDimension matrix) + (machineKuhnControlDone (machineKuhnInitEmptyMate matrix)) + (machineKuhnInitNonemptyControl matrix) + +/-- Truncates a candidate word to the length of the Kuhn input bound. -/ +def machineKuhnInputClamp (matrix candidate : List Bool) : List Bool := + candidate.take (machineKuhnInputBound matrix).length + +/-- Initializes every Kuhn state field through the common input clamp and stores the computed +bound unchanged. -/ +def machineKuhnInit (matrix : List Bool) : List Bool := + machineKuhnStatePack + (machineKuhnInputClamp matrix (machineKuhnInitControl matrix)) + (machineKuhnInputClamp matrix matrix) + (machineKuhnInputClamp matrix (machineKuhnInitDimension matrix)) + (machineKuhnInputClamp matrix (machineKuhnInitColumns matrix)) + (machineKuhnInputClamp matrix (machineKuhnInitFalseSeen matrix)) + (machineKuhnInputBound matrix) + +theorem machineKuhnInitDimension_mem_FP : + machineKuhnInitDimension ∈ Complexity.FP := + machineMatrixDimensionUnary_mem_FP + +theorem machineKuhnInitColumns_mem_FP : + machineKuhnInitColumns ∈ Complexity.FP := by + simpa only [machineKuhnInitColumns] using! + machineCompose_mem_FP machineKuhnInitDimension_mem_FP + machineUnaryRangeCode_mem_FP + +theorem machineKuhnInitFalseSeen_mem_FP : + machineKuhnInitFalseSeen ∈ Complexity.FP := by + simpa only [machineKuhnInitFalseSeen] using! + machineCompose_mem_FP machineKuhnInitDimension_mem_FP + machineFalseVectorCode_mem_FP + +theorem machineKuhnInitEmptyMate_mem_FP : + machineKuhnInitEmptyMate ∈ Complexity.FP := by + simpa only [machineKuhnInitEmptyMate] using! + machineCompose_mem_FP machineKuhnInitDimension_mem_FP + machineEmptyMateVectorCode_mem_FP + +theorem machineKuhnInitBuildFrame_mem_FP : + machineKuhnInitBuildFrame ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineKuhnInitColumns_mem_FP + machineListTail_mem_FP + have hpayload := machinePair_mem_FP htail machineKuhnInitEmptyMate_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true]) hpayload + +theorem machineKuhnInitStack_mem_FP : + machineKuhnInitStack ∈ Complexity.FP := by + exact machinePair_mem_FP machineKuhnInitBuildFrame_mem_FP + (machineConst_mem_FP []) + +theorem machineKuhnInitNonemptyControl_mem_FP : + machineKuhnInitNonemptyControl ∈ Complexity.FP := by + have hfuel := machineCompose_mem_FP machineKuhnInitDimension_mem_FP + (machinePrepend_mem_FP true) + have hrow := machineCompose_mem_FP machineKuhnInitColumns_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP hfuel + (machinePair_mem_FP machineKuhnInitColumns_mem_FP + (machinePair_mem_FP hrow + (machinePair_mem_FP machineKuhnInitFalseSeen_mem_FP + (machinePair_mem_FP machineKuhnInitEmptyMate_mem_FP + machineKuhnInitStack_mem_FP))))) + +theorem machineKuhnInitControl_mem_FP : + machineKuhnInitControl ∈ Complexity.FP := by + have hdone := machinePair_mem_FP (machineConst_mem_FP [true, true]) + machineKuhnInitEmptyMate_mem_FP + exact machineIfEmpty_mem_FP machineKuhnInitDimension_mem_FP hdone + machineKuhnInitNonemptyControl_mem_FP + +theorem machineKuhnInputBound_mem_FP : + machineKuhnInputBound ∈ Complexity.FP := by + simpa only [machineKuhnInputBound] using! + machineCompose_mem_FP machineListUpdateInputBound_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineKuhnInputClamp_mem_FP + {candidate : List Bool β†’ List Bool} (hcandidate : candidate ∈ Complexity.FP) : + (fun matrix ↦ machineKuhnInputClamp matrix (candidate matrix)) ∈ + Complexity.FP := by + simpa only [machineKuhnInputClamp] using! + machineTake_mem_FP machineKuhnInputBound_mem_FP hcandidate + +theorem machineKuhnInit_mem_FP : machineKuhnInit ∈ Complexity.FP := by + exact machinePair_mem_FP + (machineKuhnInputClamp_mem_FP machineKuhnInitControl_mem_FP) + (machinePair_mem_FP (machineKuhnInputClamp_mem_FP id_mem_FP) + (machinePair_mem_FP + (machineKuhnInputClamp_mem_FP machineKuhnInitDimension_mem_FP) + (machinePair_mem_FP + (machineKuhnInputClamp_mem_FP machineKuhnInitColumns_mem_FP) + (machinePair_mem_FP + (machineKuhnInputClamp_mem_FP machineKuhnInitFalseSeen_mem_FP) + machineKuhnInputBound_mem_FP)))) + +/-! ## Generic length bounds needed by bounded iteration -/ + +theorem machineKuhnInitDimension_length_le (matrix : List Bool) : + (machineKuhnInitDimension matrix).length ≀ matrix.length := by + let word := pair matrix (machineMatrixDimensionWord matrix) + have hbound := machineBoundedUnaryIterate_bound word matrix.length + rcases hbound with ⟨_hpack, _hremaining, hacc⟩ + change (machineBoundedUnaryAcc + ((machineBoundedUnaryStep)^[matrix.length] + (machineBoundedUnaryInit word))).length ≀ matrix.length at hacc + simpa [machineKuhnInitDimension, machineMatrixDimensionUnary, + machineBoundedUnary, machineBoundedUnaryFinalState, + machineBoundedUnaryRuler, word] using! hacc + +theorem machineUnaryRangeCode_length_le_inputBound (ruler : List Bool) : + (machineUnaryRangeCode ruler).length ≀ + (machineUnaryRangeInputBound ruler).length := by + have hbound := machineUnaryRangeIterate_bound ruler ruler.length + dsimp only [MachineUnaryRangeStateBound] at hbound + rcases hbound with ⟨_hpack, _hremaining, hacc, _hbound⟩ + simpa [machineUnaryRangeCode, machineUnaryRangeFinalState] using! hacc + +@[simp] theorem machineFalseVectorCode_length (ruler : List Bool) : + (machineFalseVectorCode ruler).length = 4 * ruler.length := by + rw [machineFalseVectorCode, machineFalseVectorIterate_semantics] + simp + +@[simp] theorem machineEmptyMateVectorCode_length (ruler : List Bool) : + (machineEmptyMateVectorCode ruler).length = 4 * ruler.length := by + simp [machineEmptyMateVectorCode] + +theorem machineListUpdateInputBound_length_le_kuhnBound + (matrix : List Bool) : + (machineListUpdateInputBound matrix).length ≀ + (machineKuhnInputBound matrix).length := by + simp only [machineKuhnInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineKuhn_matrix_length_le_bound (matrix : List Bool) : + matrix.length ≀ (machineKuhnInputBound matrix).length := by + exact (machineListUpdate_word_length_le_bound matrix).trans + (machineListUpdateInputBound_length_le_kuhnBound matrix) + +theorem machineKuhnInitColumns_length_le_bound (matrix : List Bool) : + (machineKuhnInitColumns matrix).length ≀ + (machineKuhnInputBound matrix).length := by + have hdimension := machineKuhnInitDimension_length_le matrix + have hrange := machineUnaryRangeCode_length_le_inputBound + (machineKuhnInitDimension matrix) + have hmono := machineListUpdateInputBound_length_mono hdimension + exact hrange.trans <| hmono.trans <| + machineListUpdateInputBound_length_le_kuhnBound matrix + +theorem machineKuhnInitColumns_length_le_base (matrix : List Bool) : + (machineKuhnInitColumns matrix).length ≀ + (machineListUpdateInputBound matrix).length := by + have hdimension := machineKuhnInitDimension_length_le matrix + exact (machineUnaryRangeCode_length_le_inputBound + (machineKuhnInitDimension matrix)).trans + (machineListUpdateInputBound_length_mono hdimension) + +theorem machineKuhnInitFalseSeen_length_le_bound (matrix : List Bool) : + (machineKuhnInitFalseSeen matrix).length ≀ + (machineKuhnInputBound matrix).length := by + rw [machineKuhnInitFalseSeen, machineFalseVectorCode_length] + have hdimension := machineKuhnInitDimension_length_le matrix + have hlinear : 4 * matrix.length ≀ + (machineKuhnInputBound matrix).length := by + simp only [machineKuhnInputBound, machineListUpdateInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + ring_nf + omega + exact (Nat.mul_le_mul_left 4 hdimension).trans hlinear + +theorem machineKuhnInitEmptyMate_length_le_bound (matrix : List Bool) : + (machineKuhnInitEmptyMate matrix).length ≀ + (machineKuhnInputBound matrix).length := by + simpa [machineKuhnInitEmptyMate, machineKuhnInitFalseSeen, + machineEmptyMateVectorCode] using! + machineKuhnInitFalseSeen_length_le_bound matrix + +/-! ## A generic invariant for the outer bounded iteration -/ + +/-- Requires exact state packing, all five data fields bounded by the input-bound length, and +the prescribed bound word. -/ +def MachineKuhnRunStateBound (matrix state : List Bool) : Prop := + let B := (machineKuhnInputBound matrix).length + state = machineKuhnStatePack (machineKuhnStateControl state) + (machineKuhnStateMatrix state) (machineKuhnStateDimension state) + (machineKuhnStateColumns state) (machineKuhnStateFalseSeen state) + (machineKuhnStateBound state) ∧ + (machineKuhnStateControl state).length ≀ B ∧ + (machineKuhnStateMatrix state).length ≀ B ∧ + (machineKuhnStateDimension state).length ≀ B ∧ + (machineKuhnStateColumns state).length ≀ B ∧ + (machineKuhnStateFalseSeen state).length ≀ B ∧ + machineKuhnStateBound state = machineKuhnInputBound matrix + +theorem machineKuhnInit_bound (matrix : List Bool) : + MachineKuhnRunStateBound matrix (machineKuhnInit matrix) := by + dsimp only [MachineKuhnRunStateBound] + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· simp [machineKuhnInit] + Β· simp [machineKuhnInit, machineKuhnInputClamp] + Β· simp [machineKuhnInit, machineKuhnInputClamp] + Β· simp [machineKuhnInit, machineKuhnInputClamp] + Β· simp [machineKuhnInit, machineKuhnInputClamp] + Β· simp [machineKuhnInit, machineKuhnInputClamp] + Β· simp [machineKuhnInit] + +theorem machineKuhnStep_bound {matrix state : List Bool} + (hstate : MachineKuhnRunStateBound matrix state) : + MachineKuhnRunStateBound matrix (machineKuhnStep state) := by + dsimp only [MachineKuhnRunStateBound] at hstate ⊒ + rcases hstate with + ⟨hpack, hcontrol, hmatrix, hdimension, hcolumns, hfalse, hbound⟩ + rw [machineKuhnStep, machineKuhnWithControl] + refine ⟨by simp, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· simp only [machineKuhnStateControl_pack, machineKuhnClamp, + List.length_take, hbound] + exact Nat.min_le_left _ _ + Β· simp only [machineKuhnStateMatrix_pack, machineKuhnClamp, + List.length_take, hbound] + exact Nat.min_le_left _ _ + Β· simp only [machineKuhnStateDimension_pack, machineKuhnClamp, + List.length_take, hbound] + exact Nat.min_le_left _ _ + Β· simp only [machineKuhnStateColumns_pack, machineKuhnClamp, + List.length_take, hbound] + exact Nat.min_le_left _ _ + Β· simp only [machineKuhnStateFalseSeen_pack, machineKuhnClamp, + List.length_take, hbound] + exact Nat.min_le_left _ _ + Β· simp [hbound] + +theorem machineKuhnIterate_bound (matrix : List Bool) : βˆ€ iterations, + MachineKuhnRunStateBound matrix + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix)) := by + intro iterations + induction iterations with + | zero => simpa using! machineKuhnInit_bound matrix + | succ iterations ih => + rw [Function.iterate_succ_apply'] + exact machineKuhnStep_bound ih + +/-- Applies the binary-multiplication width construction once more to the Kuhn input bound to +bound the full run state. -/ +def machineKuhnRunWidth (matrix : List Bool) : List Bool := + machineBinaryMulWidth (machineKuhnInputBound matrix) + +theorem machineKuhnRunWidth_mem_FP : + machineKuhnRunWidth ∈ Complexity.FP := by + simpa only [machineKuhnRunWidth] using! + machineCompose_mem_FP machineKuhnInputBound_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineKuhnIterate_length_le_width + (matrix : List Bool) (iterations : β„•) + (_hiterations : iterations ≀ (machineKuhnInputBound matrix).length) : + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix)).length ≀ + (machineKuhnRunWidth matrix).length := by + have hstate := machineKuhnIterate_bound matrix iterations + dsimp only [MachineKuhnRunStateBound] at hstate + rcases hstate with + ⟨hpack, hcontrol, hmatrix, hdimension, hcolumns, hfalse, hbound⟩ + rw [hpack] + simp only [machineKuhnStatePack, pair_length] + have hlinear : + 2 * (machineKuhnStateControl + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length + 2 + + 2 * (machineKuhnStateMatrix + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length + 2 + + 2 * (machineKuhnStateDimension + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length + 2 + + 2 * (machineKuhnStateColumns + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length + 2 + + 2 * (machineKuhnStateFalseSeen + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length + 2 + + (machineKuhnStateBound + ((machineKuhnStep^[iterations]) (machineKuhnInit matrix))).length ≀ + 11 * (machineKuhnInputBound matrix).length + 10 := by + rw [hbound] + omega + have hwidth : 11 * (machineKuhnInputBound matrix).length + 10 ≀ + (machineKuhnRunWidth matrix).length := by + simp only [machineKuhnRunWidth, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + omega + +/-- Runs the Kuhn step machine for the length of its input-bound word from the bounded initial +state. -/ +def machineKuhnFinalState (matrix : List Bool) : List Bool := + (machineKuhnStep^[(machineKuhnInputBound matrix).length]) + (machineKuhnInit matrix) + +theorem machineKuhnFinalState_mem_FP : + machineKuhnFinalState ∈ Complexity.FP := by + simpa only [machineKuhnFinalState] using! + Cobham.iterate_mem_FP machineKuhnStep_mem_FP machineKuhnInit_mem_FP + machineKuhnInputBound_mem_FP machineKuhnRunWidth_mem_FP + machineKuhnIterate_length_le_width + +/-! ## Exact semantics on canonical matrix words -/ + +@[simp] theorem columnMateList_emptyColumnMate (n : β„•) : + columnMateList (emptyColumnMate n) = List.replicate n none := by + apply List.ext_get + Β· simp + Β· intro i hi hi' + simp [columnMateList, emptyColumnMate] + +@[simp] theorem machineKuhnInitDimension_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInitDimension + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate n true := by + exact machineMatrixDimensionUnary_encode A + +@[simp] theorem machineKuhnInitColumns_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInitColumns + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + finRangeUnaryCode n := by + simp [machineKuhnInitColumns] + +@[simp] theorem machineKuhnInitFalseSeen_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInitFalseSeen + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + boolVectorCode (List.replicate n false) := by + simp [machineKuhnInitFalseSeen] + +@[simp] theorem machineKuhnInitEmptyMate_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInitEmptyMate + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + mateVectorCode (columnMateList (emptyColumnMate n)) := by + simp [machineKuhnInitEmptyMate] + +theorem machineKuhnInitControl_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInitControl + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + kuhnControlCode + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) := by + cases n with + | zero => + simp [machineKuhnInitControl, machineKuhnInitNonemptyControl, + kuhnBuildEvalState, kuhnControlCode, finRangeUnaryCode, + finListUnaryCode, binaryListCode] + | succ n => + simp [machineKuhnInitControl, machineKuhnInitNonemptyControl, + machineKuhnInitStack, machineKuhnInitBuildFrame, + kuhnBuildEvalState, kuhnControlCode, kuhnStackCode, + kuhnFrameCode, kuhnBuildFrameCode, finRangeUnaryCode, + finListUnaryCode, binaryListCode, machineKuhnStackPush, + List.finRange_succ, machineListHead, machineListTail, + finUnaryCode, List.replicate_succ] + +theorem machineKuhnInputClamp_eq (matrix candidate : List Bool) + (hcandidate : candidate.length ≀ (machineKuhnInputBound matrix).length) : + machineKuhnInputClamp matrix candidate = candidate := by + exact List.take_of_length_le hcandidate + +@[simp] theorem machineKuhnInit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnInit (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + kuhnMachineStateCode A + (kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n)) := by + let matrix := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let initial := kuhnBuildEvalState A (List.finRange n) (emptyColumnMate n) + have hinitial := kuhnFullBuildEvalState_reachableBound A + have hcontrol : (machineKuhnInitControl matrix).length ≀ + (machineKuhnInputBound matrix).length := by + rw [machineKuhnInitControl_encode] + exact kuhnControlCode_length_le_inputBound A initial hinitial + (Nat.zero_le _) + rw [machineKuhnInit] + rw [machineKuhnInputClamp_eq matrix _ hcontrol] + rw [machineKuhnInputClamp_eq matrix _ + (kuhnMatrixCode_length_le_inputBound A)] + simp only [machineKuhnInitDimension_encode, + machineKuhnInitColumns_encode, machineKuhnInitFalseSeen_encode] + rw [machineKuhnInputClamp_eq matrix _ + (kuhnDimensionCode_length_le_inputBound A)] + rw [machineKuhnInputClamp_eq matrix _ + (kuhnColumnsCode_length_le_inputBound A)] + rw [machineKuhnInputClamp_eq matrix _ + (kuhnFalseSeenCode_length_le_inputBound A)] + simp [kuhnMachineStateCode, machineKuhnInitControl_encode, + matrix, initial] + +@[simp] theorem machineKuhnFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnFinalState + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + kuhnMachineStateCode A (.done (kuhnColumnMate A)) := by + rw [machineKuhnFinalState, machineKuhnInit_encode] + exact machineKuhnFullBoundIterate_encode A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnSemantics.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnSemantics.lean new file mode 100644 index 0000000000..bbafb95291 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnSemantics.lean @@ -0,0 +1,435 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnStep +public import Mathlib.Tactic + +/-! +# Correctness of one encoded Kuhn transition + +The main theorem in this file shows that the un-clamped control computation is +exactly `kuhnEvalStep`. Clamp inactivity and the bounded full run are proved +after the semantic size invariant. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +@[simp] theorem machineIfEmpty_binaryListCode_cons {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) (x : Ξ±) (xs : List Ξ±) + (whenEmpty whenNonempty : List Bool) : + machineIfEmpty (binaryListCode encode (x :: xs)) + whenEmpty whenNonempty = whenNonempty := by + exact machineIfEmpty_of_ne_nil _ _ _ + (binaryListCode_cons_ne_nil encode x xs) + +@[simp] theorem machineIfEmpty_replicate_succ + (n : β„•) (bit : Bool) (whenEmpty whenNonempty : List Bool) : + machineIfEmpty (List.replicate (n + 1) bit) + whenEmpty whenNonempty = whenNonempty := by + rw [show n + 1 = Nat.succ n by omega, List.replicate_succ] + simp + +@[simp] theorem machineIfEmpty_pair + (left right whenEmpty whenNonempty : List Bool) : + machineIfEmpty (pair left right) whenEmpty whenNonempty = + whenNonempty := by + apply machineIfEmpty_of_ne_nil + intro h + have hlen := congrArg List.length h + simp at hlen + +@[simp] theorem machineMateVectorUpdateSomeAtUnary_encode + (mate : List (Option β„•)) (column row : β„•) + (hcolumn : column < mate.length) : + machineMateVectorUpdateAtUnary + (pair (List.replicate column true) + (pair (true :: List.replicate row true) (mateVectorCode mate))) = + mateVectorCode (mate.set column (some row)) := by + simpa [mateValueCode] using! + machineMateVectorUpdateAtUnary_encode mate column (some row) hcolumn + +@[simp] theorem seenBoolList_empty {n : β„•} : + seenBoolList (βˆ… : Finset (Fin n)) = List.replicate n false := by + apply List.ext_get + Β· simp + Β· intro i hi hi' + simp [seenBoolList] + +/-! ## Exact projections from semantic state codes -/ + +@[simp] theorem machineKuhnControl_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnControl (kuhnMachineStateCode A state) = + kuhnControlCode state := by + simp [machineKuhnControl, kuhnMachineStateCode] + +@[simp] theorem machineKuhnMatrix_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnStateMatrix (kuhnMachineStateCode A state) = + rationalMatrixBinaryEncoding.encode ⟨n, A⟩ := by + simp [kuhnMachineStateCode] + +@[simp] theorem machineKuhnDimension_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnStateDimension (kuhnMachineStateCode A state) = + List.replicate n true := by + simp [kuhnMachineStateCode] + +@[simp] theorem machineKuhnColumns_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnStateColumns (kuhnMachineStateCode A state) = + finRangeUnaryCode n := by + simp [kuhnMachineStateCode] + +@[simp] theorem machineKuhnFalseSeen_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnStateFalseSeen (kuhnMachineStateCode A state) = + boolVectorCode (List.replicate n false) := by + simp [kuhnMachineStateCode] + +@[simp] theorem machineKuhnBound_stateCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnStateBound (kuhnMachineStateCode A state) = + machineKuhnInputBound (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) := by + simp [kuhnMachineStateCode] + +@[simp] theorem machineKuhnFuel_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnFuel (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = + List.replicate fuel true := by + simp [machineKuhnFuel, kuhnControlCode] + +@[simp] theorem machineKuhnRemaining_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnRemaining (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = + finListUnaryCode remaining := by + simp [machineKuhnRemaining, kuhnControlCode] + +@[simp] theorem machineKuhnRow_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnRow (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = finUnaryCode row := by + simp [machineKuhnRow, kuhnControlCode] + +@[simp] theorem machineKuhnSeen_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnSeen (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = + boolVectorCode (seenBoolList seen) := by + simp [machineKuhnSeen, kuhnControlCode] + +@[simp] theorem machineKuhnMate_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnMate (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = + mateVectorCode (columnMateList mate) := by + simp [machineKuhnMate, kuhnControlCode] + +@[simp] theorem machineKuhnStack_encode_call {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnStack (kuhnMachineStateCode A + (.call fuel remaining row seen mate stack)) = kuhnStackCode stack := by + simp [machineKuhnStack, kuhnControlCode] + +@[simp] theorem machineKuhnReturnFields_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (result : KuhnSearchResult n) + (stack : List (KuhnFrame n)) : + machineKuhnRetSuccess (kuhnMachineStateCode A (.ret result stack)) = + [result.mate?.isSome] ∧ + machineKuhnRetSeen (kuhnMachineStateCode A (.ret result stack)) = + boolVectorCode (seenBoolList result.seen) ∧ + machineKuhnRetMate (kuhnMachineStateCode A (.ret result stack)) = + kuhnSearchResultMateCode result ∧ + machineKuhnRetStack (kuhnMachineStateCode A (.ret result stack)) = + kuhnStackCode stack := by + simp [machineKuhnRetSuccess, machineKuhnRetSeen, machineKuhnRetMate, + machineKuhnRetStack, kuhnControlCode] + +@[simp] theorem machineKuhnTopFrame_encode_ret_cons {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (result : KuhnSearchResult n) + (frame : KuhnFrame n) (stack : List (KuhnFrame n)) : + machineKuhnTopFrame + (kuhnMachineStateCode A (.ret result (frame :: stack))) = + kuhnFrameCode frame := by + simp [machineKuhnTopFrame] + +@[simp] theorem machineKuhnRestStack_encode_ret_cons {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (result : KuhnSearchResult n) + (frame : KuhnFrame n) (stack : List (KuhnFrame n)) : + machineKuhnRestStack + (kuhnMachineStateCode A (.ret result (frame :: stack))) = + kuhnStackCode stack := by + simp [machineKuhnRestStack] + +@[simp] theorem machineKuhnCurrentColumn_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnCurrentColumn (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + finUnaryCode col := by + simp [machineKuhnCurrentColumn, finListUnaryCode] + +@[simp] theorem machineKuhnRemainingTail_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnRemainingTail (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + finListUnaryCode remaining := by + simp [machineKuhnRemainingTail, finListUnaryCode] + +/-! ## Exact memory operations -/ + +@[simp] theorem machineKuhnSeenBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnSeenBit (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + [decide (col ∈ seen)] := by + rw [machineKuhnSeenBit, machineKuhnCurrentColumn_encode, + machineKuhnSeen_encode_call, finUnaryCode, + machineBoolVectorEntryAtUnary_encode (seenBoolList seen) col.1 + (by simp)] + congr 2 + exact seenBoolList_getElem seen col.1 (by simp) + +@[simp] theorem machineKuhnSupportBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnSupportBit (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + [decide (A row col β‰  0)] := by + rw [machineKuhnSupportBit, machineKuhnRow_encode_call, + machineKuhnCurrentColumn_encode, machineKuhnMatrix_stateCode] + simp only [finUnaryCode] + rw [machineRationalSupportBitAtUnary_encode] + +@[simp] theorem machineKuhnSeenUpdated_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnSeenUpdated (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + boolVectorCode (seenBoolList (insert col seen)) := by + rw [machineKuhnSeenUpdated, machineKuhnCurrentColumn_encode, + machineKuhnSeen_encode_call, finUnaryCode, + machineBoolVectorUpdateAtUnary_encode (seenBoolList seen) col.1 true + (by simp), ← seenBoolList_insert] + +@[simp] theorem machineKuhnMateValue_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnMateValue (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + mateValueCode ((mate col).map Fin.val) := by + rw [machineKuhnMateValue, machineKuhnCurrentColumn_encode, + machineKuhnMate_encode_call, finUnaryCode, + machineMateVectorGetAtUnary_encode (columnMateList mate) col.1 (by simp)] + congr 1 + exact columnMateList_getElem mate col.1 (by simp) + +@[simp] theorem machineKuhnMateSetCurrent_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnMateSetCurrent (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + mateVectorCode + (columnMateList (Function.update mate col (some row))) := by + rw [machineKuhnMateSetCurrent, machineKuhnCurrentColumn_encode, + machineKuhnSomeCurrentRow, machineKuhnRow_encode_call, + machineKuhnMate_encode_call] + simp only [finUnaryCode] + change machineMateVectorUpdateAtUnary + (pair (List.replicate col.1 true) + (pair (mateValueCode (some row.1)) + (mateVectorCode (columnMateList mate)))) = _ + rw [machineMateVectorUpdateAtUnary_encode (columnMateList mate) col.1 + (some row.1) (by simp), columnMateList_update] + simp + +@[simp] theorem machineKuhnMateClearCurrent_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (fuel : β„•) (col : Fin n) + (remaining : List (Fin n)) (row : Fin n) (seen : Finset (Fin n)) + (mate : ColumnMate n) (stack : List (KuhnFrame n)) : + machineKuhnMateClearCurrent (kuhnMachineStateCode A + (.call fuel (col :: remaining) row seen mate stack)) = + mateVectorCode (columnMateList (Function.update mate col none)) := by + rw [machineKuhnMateClearCurrent, machineKuhnCurrentColumn_encode, + machineKuhnMate_encode_call] + simp only [finUnaryCode] + change machineMateVectorUpdateAtUnary + (pair (List.replicate col.1 true) + (pair (mateValueCode none) (mateVectorCode (columnMateList mate)))) = _ + rw [machineMateVectorUpdateAtUnary_encode (columnMateList mate) col.1 none + (by simp), columnMateList_update] + simp + +/-! ## Un-clamped transition correctness -/ + +theorem machineKuhnNextControl_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (state : KuhnEvalState n) : + machineKuhnNextControl (kuhnMachineStateCode A state) = + kuhnControlCode (kuhnEvalStep A state) := by + cases state with + | done mate => + simp [machineKuhnNextControl, machineKuhnDoneControl, + kuhnControlCode, kuhnEvalStep] + | call fuel remaining row seen mate stack => + cases fuel with + | zero => + simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnFailureControl, kuhnControlCode, kuhnEvalStep, + kuhnSearchResultMateCode] + | succ fuel => + cases remaining with + | nil => + simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnFailureControl, kuhnControlCode, + kuhnEvalStep, kuhnSearchResultMateCode, + finListUnaryCode, binaryListCode] + | cons col remaining => + by_cases hskip : col ∈ seen ∨ A row col = 0 + Β· rcases hskip with hseen | hzero + Β· simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnNonterminalCallControl, machineKuhnSkipBit, + machineKuhnSkipControl, kuhnControlCode, + kuhnEvalStep, hseen, finListUnaryCode, binaryListCode] + Β· have hsupport : decide (A row col β‰  0) = false := by + simp [hzero] + simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnNonterminalCallControl, machineKuhnSkipBit, + machineKuhnSkipControl, kuhnControlCode, + kuhnEvalStep, hzero, + finListUnaryCode, binaryListCode] + Β· have hnotSeen : col βˆ‰ seen := by aesop + have hsupport : A row col β‰  0 := by aesop + cases hmate : mate col with + | none => + simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnNonterminalCallControl, machineKuhnSkipBit, + machineKuhnProceedControl, machineKuhnMateIsNoneBit, + machineKuhnFreeColumnControl, kuhnControlCode, + kuhnEvalStep, kuhnSearchResultMateCode, + hnotSeen, hsupport, hmate, + finListUnaryCode, binaryListCode] + | some oldRow => + simp [machineKuhnNextControl, machineKuhnCallControl, + machineKuhnNonterminalCallControl, machineKuhnSkipBit, + machineKuhnProceedControl, machineKuhnMateIsNoneBit, + machineKuhnOccupiedColumnControl, + machineKuhnPushedSearchStack, + machineKuhnSearchFrameCurrent, kuhnControlCode, + kuhnEvalStep, + kuhnStackCode, hnotSeen, hsupport, hmate, + finRangeUnaryCode, finListUnaryCode, finUnaryCode, + machineKuhnStackPush, binaryListCode] + rfl + | ret result stack => + cases stack with + | nil => + simp [machineKuhnNextControl, machineKuhnReturnControl, + kuhnControlCode, kuhnEvalStep, kuhnStackCode, binaryListCode] + | cons frame stack => + cases frame with + | search frame => + cases hmate : result.mate? with + | none => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnSearchReturnControl, + machineKuhnSearchReturnFailureControl, + kuhnControlCode, kuhnSearchResultMateCode, + kuhnFrameCode, kuhnStackCode, kuhnSearchFrameCode, + kuhnEvalStep, hmate, finListUnaryCode, + binaryListCode] + | some mate' => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnSearchReturnControl, + machineKuhnSearchReturnSuccessControl, + kuhnControlCode, kuhnSearchResultMateCode, + kuhnFrameCode, kuhnStackCode, kuhnSearchFrameCode, + kuhnEvalStep, hmate, columnMateList_update, + finUnaryCode, binaryListCode] + | build frame => + rcases frame with ⟨rows, fallback⟩ + cases hmate : result.mate? with + | none => + cases rows with + | nil => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnBuildReturnControl, + machineKuhnBuildRows, machineKuhnBuildChosenMate, + kuhnControlCode, kuhnSearchResultMateCode, + kuhnFrameCode, kuhnStackCode, kuhnBuildFrameCode, + kuhnEvalStep, hmate, finListUnaryCode, + binaryListCode] + | cons row rows => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnBuildReturnControl, + machineKuhnBuildContinueControl, + machineKuhnBuildNextStack, + machineKuhnBuildNextFrame, machineKuhnBuildRows, + machineKuhnBuildChosenMate, kuhnControlCode, + kuhnSearchResultMateCode, kuhnFrameCode, + kuhnStackCode, kuhnBuildFrameCode, + kuhnEvalStep, hmate, finRangeUnaryCode, + finListUnaryCode, machineListHead, machineListTail, + machineKuhnStackPush, List.replicate_succ, + binaryListCode] + | some mate' => + cases rows with + | nil => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnBuildReturnControl, + machineKuhnBuildRows, machineKuhnBuildChosenMate, + kuhnControlCode, kuhnSearchResultMateCode, + kuhnFrameCode, kuhnStackCode, kuhnBuildFrameCode, + kuhnEvalStep, hmate, finListUnaryCode, + binaryListCode] + | cons row rows => + simp [machineKuhnNextControl, machineKuhnReturnControl, + machineKuhnNonemptyReturnControl, + machineKuhnBuildReturnControl, + machineKuhnBuildContinueControl, + machineKuhnBuildNextStack, + machineKuhnBuildNextFrame, machineKuhnBuildRows, + machineKuhnBuildChosenMate, kuhnControlCode, + kuhnSearchResultMateCode, kuhnFrameCode, + kuhnStackCode, kuhnBuildFrameCode, + kuhnEvalStep, hmate, finRangeUnaryCode, + finListUnaryCode, machineListHead, machineListTail, + machineKuhnStackPush, List.replicate_succ, + binaryListCode] +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnStep.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnStep.lean new file mode 100644 index 0000000000..d9db2c3d37 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineKuhnStep.lean @@ -0,0 +1,625 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnEncoding + +/-! +# One finite-word transition of the Kuhn evaluator + +This is the bit-level implementation of `kuhnEvalStep`. Every branch uses +only pairing, list access/update, Boolean gates, and the rational support +query already shown to lie in `FP`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## State-level field access -/ + +/-- Reads the control word used by the Kuhn transition functions. -/ +def machineKuhnControl (state : List Bool) : List Bool := + machineKuhnStateControl state + +/-- Reads the active call's unary fuel from a Kuhn machine state. -/ +def machineKuhnFuel (state : List Bool) : List Bool := + machineKuhnCallFuel (machineKuhnControl state) + +/-- Reads the active call's remaining-column list from a Kuhn machine state. -/ +def machineKuhnRemaining (state : List Bool) : List Bool := + machineKuhnCallRemaining (machineKuhnControl state) + +/-- Reads the active call's current row from a Kuhn machine state. -/ +def machineKuhnRow (state : List Bool) : List Bool := + machineKuhnCallRow (machineKuhnControl state) + +/-- Reads the active call's seen-column vector from a Kuhn machine state. -/ +def machineKuhnSeen (state : List Bool) : List Bool := + machineKuhnCallSeen (machineKuhnControl state) + +/-- Reads the active call's current matching from a Kuhn machine state. -/ +def machineKuhnMate (state : List Bool) : List Bool := + machineKuhnCallMate (machineKuhnControl state) + +/-- Reads the active call's continuation stack from a Kuhn machine state. -/ +def machineKuhnStack (state : List Bool) : List Bool := + machineKuhnCallStack (machineKuhnControl state) + +/-- Reads the return success flag from a Kuhn machine state. -/ +def machineKuhnRetSuccess (state : List Bool) : List Bool := + machineKuhnReturnSuccess (machineKuhnControl state) + +/-- Reads the returned seen-column vector from a Kuhn machine state. -/ +def machineKuhnRetSeen (state : List Bool) : List Bool := + machineKuhnReturnSeen (machineKuhnControl state) + +/-- Reads the returned matching from a Kuhn machine state. -/ +def machineKuhnRetMate (state : List Bool) : List Bool := + machineKuhnReturnMate (machineKuhnControl state) + +/-- Reads the return continuation stack from a Kuhn machine state. -/ +def machineKuhnRetStack (state : List Bool) : List Bool := + machineKuhnReturnStack (machineKuhnControl state) + +/-- Reads the top continuation frame of the return stack. -/ +def machineKuhnTopFrame (state : List Bool) : List Bool := + machineKuhnStackHead (machineKuhnRetStack state) + +/-- Removes the top continuation frame from the return stack. -/ +def machineKuhnRestStack (state : List Bool) : List Bool := + machineKuhnStackTail (machineKuhnRetStack state) + +theorem machineKuhnControl_mem_FP : machineKuhnControl ∈ Complexity.FP := + machineKuhnStateControl_mem_FP + +theorem machineKuhnFuel_mem_FP : machineKuhnFuel ∈ Complexity.FP := by + simpa only [machineKuhnFuel] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnCallFuel_mem_FP +theorem machineKuhnRemaining_mem_FP : machineKuhnRemaining ∈ Complexity.FP := by + simpa only [machineKuhnRemaining] using! + machineCompose_mem_FP machineKuhnControl_mem_FP + machineKuhnCallRemaining_mem_FP +theorem machineKuhnRow_mem_FP : machineKuhnRow ∈ Complexity.FP := by + simpa only [machineKuhnRow] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnCallRow_mem_FP +theorem machineKuhnSeen_mem_FP : machineKuhnSeen ∈ Complexity.FP := by + simpa only [machineKuhnSeen] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnCallSeen_mem_FP +theorem machineKuhnMate_mem_FP : machineKuhnMate ∈ Complexity.FP := by + simpa only [machineKuhnMate] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnCallMate_mem_FP +theorem machineKuhnStack_mem_FP : machineKuhnStack ∈ Complexity.FP := by + simpa only [machineKuhnStack] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnCallStack_mem_FP +theorem machineKuhnRetSuccess_mem_FP : machineKuhnRetSuccess ∈ Complexity.FP := by + simpa only [machineKuhnRetSuccess] using! + machineCompose_mem_FP machineKuhnControl_mem_FP + machineKuhnReturnSuccess_mem_FP +theorem machineKuhnRetSeen_mem_FP : machineKuhnRetSeen ∈ Complexity.FP := by + simpa only [machineKuhnRetSeen] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnReturnSeen_mem_FP +theorem machineKuhnRetMate_mem_FP : machineKuhnRetMate ∈ Complexity.FP := by + simpa only [machineKuhnRetMate] using! + machineCompose_mem_FP machineKuhnControl_mem_FP machineKuhnReturnMate_mem_FP +theorem machineKuhnRetStack_mem_FP : machineKuhnRetStack ∈ Complexity.FP := by + simpa only [machineKuhnRetStack] using! + machineCompose_mem_FP machineKuhnControl_mem_FP + machineKuhnReturnStack_mem_FP +theorem machineKuhnTopFrame_mem_FP : machineKuhnTopFrame ∈ Complexity.FP := by + simpa only [machineKuhnTopFrame] using! + machineCompose_mem_FP machineKuhnRetStack_mem_FP + machineKuhnStackHead_mem_FP +theorem machineKuhnRestStack_mem_FP : machineKuhnRestStack ∈ Complexity.FP := by + simpa only [machineKuhnRestStack] using! + machineCompose_mem_FP machineKuhnRetStack_mem_FP + machineKuhnStackTail_mem_FP + +/-! ## Repacking with a fixed global clamp -/ + +/-- Truncates a candidate word to the length of the bound stored in the current Kuhn state. -/ +def machineKuhnClamp (state candidate : List Bool) : List Bool := + candidate.take (machineKuhnStateBound state).length + +/-- Replaces a Kuhn state's control while clamping all data fields to its stored bound and +preserving that bound. -/ +def machineKuhnWithControl (state control : List Bool) : List Bool := + machineKuhnStatePack (machineKuhnClamp state control) + (machineKuhnClamp state (machineKuhnStateMatrix state)) + (machineKuhnClamp state (machineKuhnStateDimension state)) + (machineKuhnClamp state (machineKuhnStateColumns state)) + (machineKuhnClamp state (machineKuhnStateFalseSeen state)) + (machineKuhnStateBound state) + +theorem machineKuhnClamp_mem_FP + {candidate : List Bool β†’ List Bool} (hcandidate : candidate ∈ Complexity.FP) : + (fun state ↦ machineKuhnClamp state (candidate state)) ∈ Complexity.FP := by + simpa only [machineKuhnClamp] using! + machineTake_mem_FP machineKuhnStateBound_mem_FP hcandidate + +theorem machineKuhnWithControl_mem_FP + {control : List Bool β†’ List Bool} (hcontrol : control ∈ Complexity.FP) : + (fun state ↦ machineKuhnWithControl state (control state)) ∈ + Complexity.FP := by + have hc := machineKuhnClamp_mem_FP hcontrol + have hm := machineKuhnClamp_mem_FP machineKuhnStateMatrix_mem_FP + have hd := machineKuhnClamp_mem_FP machineKuhnStateDimension_mem_FP + have hcols := machineKuhnClamp_mem_FP machineKuhnStateColumns_mem_FP + have hfalse := machineKuhnClamp_mem_FP machineKuhnStateFalseSeen_mem_FP + exact machinePair_mem_FP hc + (machinePair_mem_FP hm + (machinePair_mem_FP hd + (machinePair_mem_FP hcols + (machinePair_mem_FP hfalse machineKuhnStateBound_mem_FP)))) + +/-! ## Call transition -/ + +/-- Reads the first remaining column of the active Kuhn call. -/ +def machineKuhnCurrentColumn (state : List Bool) : List Bool := + machineListHead (machineKuhnRemaining state) + +/-- Removes the current column from the active call's remaining-column list. -/ +def machineKuhnRemainingTail (state : List Bool) : List Bool := + machineListTail (machineKuhnRemaining state) + +/-- Looks up whether the current search column has already been seen. -/ +def machineKuhnSeenBit (state : List Bool) : List Bool := + machineBoolVectorEntryAtUnary + (pair (machineKuhnCurrentColumn state) (machineKuhnSeen state)) + +/-- Tests whether the input matrix supports the edge from the current row to the current column. -/ +def machineKuhnSupportBit (state : List Bool) : List Bool := + machineRationalSupportBitAtUnary + (pair (machineKuhnRow state) + (pair (machineKuhnCurrentColumn state) + (machineKuhnStateMatrix state))) + +/-- Marks the current column for skipping when it was already seen or the current matrix edge is +unsupported. -/ +def machineKuhnSkipBit (state : List Bool) : List Bool := + machineOrBit (machineKuhnSeenBit state) + (machineNotBit (machineKuhnSupportBit state)) + +/-- Sets the current column's seen bit to true. -/ +def machineKuhnSeenUpdated (state : List Bool) : List Bool := + machineBoolVectorUpdateAtUnary + (pair (machineKuhnCurrentColumn state) + (pair [true] (machineKuhnSeen state))) + +/-- Looks up the current column's optional matched row. -/ +def machineKuhnMateValue (state : List Bool) : List Bool := + machineMateVectorGetAtUnary + (pair (machineKuhnCurrentColumn state) (machineKuhnMate state)) + +/-- Tests whether the current column is unmatched. -/ +def machineKuhnMateIsNoneBit (state : List Bool) : List Bool := + machineMateValueIsNoneBit (machineKuhnMateValue state) + +/-- Encodes the current row as a present optional mate value. -/ +def machineKuhnSomeCurrentRow (state : List Bool) : List Bool := + true :: machineKuhnRow state + +/-- Updates the current column's mate to the current search row. -/ +def machineKuhnMateSetCurrent (state : List Bool) : List Bool := + machineMateVectorUpdateAtUnary + (pair (machineKuhnCurrentColumn state) + (pair (machineKuhnSomeCurrentRow state) (machineKuhnMate state))) + +/-- Clears the current column's mate before recursively relocating its matched row. -/ +def machineKuhnMateClearCurrent (state : List Bool) : List Bool := + machineMateVectorUpdateAtUnary + (pair (machineKuhnCurrentColumn state) + (pair [false] (machineKuhnMate state))) + +/-- Returns a failed search with the current seen bits and continuation stack. -/ +def machineKuhnFailureControl (state : List Bool) : List Bool := + machineKuhnControlReturn [false] (machineKuhnSeen state) [] + (machineKuhnStack state) + +/-- Continues the active search after dropping the skipped column, retaining fuel, seen bits, +matching, and stack. -/ +def machineKuhnSkipControl (state : List Bool) : List Bool := + machineKuhnControlCall (machineKuhnFuel state) + (machineKuhnRemainingTail state) (machineKuhnRow state) + (machineKuhnSeen state) (machineKuhnMate state) (machineKuhnStack state) + +/-- Returns success after marking a free column seen and matching it to the current row. -/ +def machineKuhnFreeColumnControl (state : List Bool) : List Bool := + machineKuhnControlReturn [true] (machineKuhnSeenUpdated state) + (machineKuhnMateSetCurrent state) (machineKuhnStack state) + +/-- Saves a search continuation containing the current fuel, remaining columns, row, matching, +and selected column. -/ +def machineKuhnSearchFrameCurrent (state : List Bool) : List Bool := + pair [false] + (machineKuhnSearchFramePack (machineKuhnFuel state) + (machineKuhnRemainingTail state) (machineKuhnRow state) + (machineKuhnMate state) (machineKuhnCurrentColumn state)) + +/-- Pushes the current search continuation onto the active stack. -/ +def machineKuhnPushedSearchStack (state : List Bool) : List Bool := + machineKuhnStackPush (machineKuhnSearchFrameCurrent state) + (machineKuhnStack state) + +/-- Recursively searches for the occupied column's former row with decremented fuel, all +columns, updated seen bits, that column cleared, and a saved continuation. -/ +def machineKuhnOccupiedColumnControl (state : List Bool) : List Bool := + machineKuhnControlCall (machineKuhnFuel state).tail + (machineKuhnStateColumns state) + (machineMateValueRowUnary (machineKuhnMateValue state)) + (machineKuhnSeenUpdated state) (machineKuhnMateClearCurrent state) + (machineKuhnPushedSearchStack state) + +/-- Returns an immediate match for a free column or recursively relocates an occupied column's +mate. -/ +def machineKuhnProceedControl (state : List Bool) : List Bool := + machineIfHead (machineKuhnMateIsNoneBit state) + (machineKuhnFreeColumnControl state) + (machineKuhnOccupiedColumnControl state) + +/-- Skips a seen or unsupported column and otherwise processes it as free or occupied. -/ +def machineKuhnNonterminalCallControl (state : List Bool) : List Bool := + machineIfHead (machineKuhnSkipBit state) + (machineKuhnSkipControl state) (machineKuhnProceedControl state) + +/-- Returns failure when fuel or columns are exhausted and otherwise executes the next search +transition. -/ +def machineKuhnCallControl (state : List Bool) : List Bool := + machineIfEmpty (machineKuhnFuel state) (machineKuhnFailureControl state) + (machineIfEmpty (machineKuhnRemaining state) + (machineKuhnFailureControl state) + (machineKuhnNonterminalCallControl state)) + +/-! ## Return transition -/ + +/-- After a successful recursive search, matches the saved column to the saved row and returns +success through the remaining stack. -/ +def machineKuhnSearchReturnSuccessControl (state : List Bool) : List Bool := + let frame := machineKuhnTopFrame state + let mate := machineMateVectorUpdateAtUnary + (pair (machineKuhnSearchFrameColumn frame) + (pair (true :: machineKuhnSearchFrameRow frame) + (machineKuhnRetMate state))) + machineKuhnControlReturn [true] (machineKuhnRetSeen state) mate + (machineKuhnRestStack state) + +/-- After a failed recursive search, resumes the saved row and remaining columns with the saved +matching and returned seen bits. -/ +def machineKuhnSearchReturnFailureControl (state : List Bool) : List Bool := + let frame := machineKuhnTopFrame state + machineKuhnControlCall (machineKuhnSearchFrameFuel frame) + (machineKuhnSearchFrameRemaining frame) + (machineKuhnSearchFrameRow frame) (machineKuhnRetSeen state) + (machineKuhnSearchFrameMate frame) (machineKuhnRestStack state) + +/-- Chooses the search-continuation success or failure transition using the return success bit. -/ +def machineKuhnSearchReturnControl (state : List Bool) : List Bool := + machineIfHead (machineKuhnRetSuccess state) + (machineKuhnSearchReturnSuccessControl state) + (machineKuhnSearchReturnFailureControl state) + +/-- Uses the returned matching after success and the build continuation's fallback matching +after failure. -/ +def machineKuhnBuildChosenMate (state : List Bool) : List Bool := + let frame := machineKuhnTopFrame state + machineIfHead (machineKuhnRetSuccess state) (machineKuhnRetMate state) + (machineKuhnBuildFrameFallback frame) + +/-- Reads the remaining rows from the top build continuation. -/ +def machineKuhnBuildRows (state : List Bool) : List Bool := + machineKuhnBuildFrameRows (machineKuhnTopFrame state) + +/-- Builds the next continuation with the remaining-row tail and the selected matching as +fallback. -/ +def machineKuhnBuildNextFrame (state : List Bool) : List Bool := + pair [true] + (machineKuhnBuildFramePack (machineListTail (machineKuhnBuildRows state)) + (machineKuhnBuildChosenMate state)) + +/-- Replaces the completed build continuation with its successor on the remaining stack. -/ +def machineKuhnBuildNextStack (state : List Bool) : List Bool := + machineKuhnStackPush (machineKuhnBuildNextFrame state) + (machineKuhnRestStack state) + +/-- Starts searching the next build row with fuel `n + 1`, all columns, fresh seen bits, the +selected matching, and the next build continuation. -/ +def machineKuhnBuildContinueControl (state : List Bool) : List Bool := + machineKuhnControlCall (true :: machineKuhnStateDimension state) + (machineKuhnStateColumns state) + (machineListHead (machineKuhnBuildRows state)) + (machineKuhnStateFalseSeen state) (machineKuhnBuildChosenMate state) + (machineKuhnBuildNextStack state) + +/-- Completes matching construction when no build rows remain and otherwise starts the next row +search. -/ +def machineKuhnBuildReturnControl (state : List Bool) : List Bool := + machineIfEmpty (machineKuhnBuildRows state) + (machineKuhnControlDone (machineKuhnBuildChosenMate state)) + (machineKuhnBuildContinueControl state) + +/-- Dispatches a nonempty return stack to its build or search continuation using the top frame +tag. -/ +def machineKuhnNonemptyReturnControl (state : List Bool) : List Bool := + machineIfHead (machineKuhnFrameTag (machineKuhnTopFrame state)) + (machineKuhnBuildReturnControl state) + (machineKuhnSearchReturnControl state) + +/-- Preserves a return with empty stack and otherwise processes its top continuation frame. -/ +def machineKuhnReturnControl (state : List Bool) : List Bool := + machineIfEmpty (machineKuhnRetStack state) (machineKuhnControl state) + (machineKuhnNonemptyReturnControl state) + +/-- Preserves the control word of a completed Kuhn machine state. -/ +def machineKuhnDoneControl (state : List Bool) : List Bool := + machineKuhnControl state + +/-- The un-clamped next control word. -/ +def machineKuhnNextControl (state : List Bool) : List Bool := + machineIfHead (machineKuhnControlTag (machineKuhnControl state)) + (machineIfHead (machineKuhnControlIsDoneBit (machineKuhnControl state)) + (machineKuhnDoneControl state) (machineKuhnReturnControl state)) + (machineKuhnCallControl state) + +/-- One total finite-word transition. Every variable field is clamped to the +fixed bound carried by the input state. -/ +def machineKuhnStep (state : List Bool) : List Bool := + machineKuhnWithControl state (machineKuhnNextControl state) + +/-! ## Polynomial-time closure proof -/ + +theorem machineKuhnCurrentColumn_mem_FP : + machineKuhnCurrentColumn ∈ Complexity.FP := by + simpa only [machineKuhnCurrentColumn] using! + machineCompose_mem_FP machineKuhnRemaining_mem_FP machineListHead_mem_FP + +theorem machineKuhnRemainingTail_mem_FP : + machineKuhnRemainingTail ∈ Complexity.FP := by + simpa only [machineKuhnRemainingTail] using! + machineCompose_mem_FP machineKuhnRemaining_mem_FP machineListTail_mem_FP + +theorem machineKuhnSeenBit_mem_FP : machineKuhnSeenBit ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + machineKuhnSeen_mem_FP + simpa only [machineKuhnSeenBit] using! + machineCompose_mem_FP hp machineBoolVectorEntryAtUnary_mem_FP + +theorem machineKuhnSupportBit_mem_FP : + machineKuhnSupportBit ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnRow_mem_FP + (machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + machineKuhnStateMatrix_mem_FP) + simpa only [machineKuhnSupportBit] using! + machineCompose_mem_FP hp machineRationalSupportBitAtUnary_mem_FP + +theorem machineKuhnSkipBit_mem_FP : machineKuhnSkipBit ∈ Complexity.FP := by + have hnot := machineNotBit_mem_FP machineKuhnSupportBit_mem_FP + exact machineOrBit_mem_FP machineKuhnSeenBit_mem_FP hnot + +theorem machineKuhnSeenUpdated_mem_FP : + machineKuhnSeenUpdated ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) machineKuhnSeen_mem_FP) + simpa only [machineKuhnSeenUpdated] using! + machineCompose_mem_FP hp machineBoolVectorUpdateAtUnary_mem_FP + +theorem machineKuhnMateValue_mem_FP : machineKuhnMateValue ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + machineKuhnMate_mem_FP + simpa only [machineKuhnMateValue] using! + machineCompose_mem_FP hp machineMateVectorGetAtUnary_mem_FP + +theorem machineKuhnMateIsNoneBit_mem_FP : + machineKuhnMateIsNoneBit ∈ Complexity.FP := by + simpa only [machineKuhnMateIsNoneBit] using! + machineCompose_mem_FP machineKuhnMateValue_mem_FP + machineMateValueIsNoneBit_mem_FP + +theorem machineKuhnSomeCurrentRow_mem_FP : + machineKuhnSomeCurrentRow ∈ Complexity.FP := by + simpa only [machineKuhnSomeCurrentRow] using! + machineCompose_mem_FP machineKuhnRow_mem_FP (machinePrepend_mem_FP true) + +theorem machineKuhnMateSetCurrent_mem_FP : + machineKuhnMateSetCurrent ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + (machinePair_mem_FP machineKuhnSomeCurrentRow_mem_FP machineKuhnMate_mem_FP) + simpa only [machineKuhnMateSetCurrent] using! + machineCompose_mem_FP hp machineMateVectorUpdateAtUnary_mem_FP + +theorem machineKuhnMateClearCurrent_mem_FP : + machineKuhnMateClearCurrent ∈ Complexity.FP := by + have hp := machinePair_mem_FP machineKuhnCurrentColumn_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) machineKuhnMate_mem_FP) + simpa only [machineKuhnMateClearCurrent] using! + machineCompose_mem_FP hp machineMateVectorUpdateAtUnary_mem_FP + +theorem machineKuhnFailureControl_mem_FP : + machineKuhnFailureControl ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP [true, false]) + (machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP machineKuhnSeen_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) machineKuhnStack_mem_FP))) + +theorem machineKuhnSkipControl_mem_FP : machineKuhnSkipControl ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP machineKuhnFuel_mem_FP + (machinePair_mem_FP machineKuhnRemainingTail_mem_FP + (machinePair_mem_FP machineKuhnRow_mem_FP + (machinePair_mem_FP machineKuhnSeen_mem_FP + (machinePair_mem_FP machineKuhnMate_mem_FP + machineKuhnStack_mem_FP))))) + +theorem machineKuhnFreeColumnControl_mem_FP : + machineKuhnFreeColumnControl ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP [true, false]) + (machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineKuhnSeenUpdated_mem_FP + (machinePair_mem_FP machineKuhnMateSetCurrent_mem_FP + machineKuhnStack_mem_FP))) + +theorem machineKuhnSearchFrameCurrent_mem_FP : + machineKuhnSearchFrameCurrent ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP machineKuhnFuel_mem_FP + (machinePair_mem_FP machineKuhnRemainingTail_mem_FP + (machinePair_mem_FP machineKuhnRow_mem_FP + (machinePair_mem_FP machineKuhnMate_mem_FP + machineKuhnCurrentColumn_mem_FP)))) + +theorem machineKuhnPushedSearchStack_mem_FP : + machineKuhnPushedSearchStack ∈ Complexity.FP := + machinePair_mem_FP machineKuhnSearchFrameCurrent_mem_FP + machineKuhnStack_mem_FP + +theorem machineKuhnOccupiedColumnControl_mem_FP : + machineKuhnOccupiedColumnControl ∈ Complexity.FP := by + have hfuelTail := machineCompose_mem_FP machineKuhnFuel_mem_FP + machineTail_mem_FP + have holdRow := machineCompose_mem_FP machineKuhnMateValue_mem_FP + machineMateValueRowUnary_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP hfuelTail + (machinePair_mem_FP machineKuhnStateColumns_mem_FP + (machinePair_mem_FP holdRow + (machinePair_mem_FP machineKuhnSeenUpdated_mem_FP + (machinePair_mem_FP machineKuhnMateClearCurrent_mem_FP + machineKuhnPushedSearchStack_mem_FP))))) + +theorem machineKuhnProceedControl_mem_FP : + machineKuhnProceedControl ∈ Complexity.FP := + machineIfHead_mem_FP machineKuhnMateIsNoneBit_mem_FP + machineKuhnFreeColumnControl_mem_FP machineKuhnOccupiedColumnControl_mem_FP + +theorem machineKuhnNonterminalCallControl_mem_FP : + machineKuhnNonterminalCallControl ∈ Complexity.FP := + machineIfHead_mem_FP machineKuhnSkipBit_mem_FP machineKuhnSkipControl_mem_FP + machineKuhnProceedControl_mem_FP + +theorem machineKuhnCallControl_mem_FP : machineKuhnCallControl ∈ Complexity.FP := by + have hinner := machineIfEmpty_mem_FP machineKuhnRemaining_mem_FP + machineKuhnFailureControl_mem_FP machineKuhnNonterminalCallControl_mem_FP + exact machineIfEmpty_mem_FP machineKuhnFuel_mem_FP + machineKuhnFailureControl_mem_FP hinner + +theorem machineKuhnSearchReturnSuccessControl_mem_FP : + machineKuhnSearchReturnSuccessControl ∈ Complexity.FP := by + have hcol := machineCompose_mem_FP machineKuhnTopFrame_mem_FP + machineKuhnSearchFrameColumn_mem_FP + have hrow := machineCompose_mem_FP machineKuhnTopFrame_mem_FP + machineKuhnSearchFrameRow_mem_FP + have hsome := machineCompose_mem_FP hrow (machinePrepend_mem_FP true) + have hp := machinePair_mem_FP hcol + (machinePair_mem_FP hsome machineKuhnRetMate_mem_FP) + have hmate := machineCompose_mem_FP hp machineMateVectorUpdateAtUnary_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true, false]) + (machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP machineKuhnRetSeen_mem_FP + (machinePair_mem_FP hmate machineKuhnRestStack_mem_FP))) + +theorem machineKuhnSearchReturnFailureControl_mem_FP : + machineKuhnSearchReturnFailureControl ∈ Complexity.FP := by + have hfield (f : List Bool β†’ List Bool) (hf : f ∈ Complexity.FP) : + (fun state ↦ f (machineKuhnTopFrame state)) ∈ Complexity.FP := + by simpa only using! + machineCompose_mem_FP machineKuhnTopFrame_mem_FP hf + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP + (hfield machineKuhnSearchFrameFuel machineKuhnSearchFrameFuel_mem_FP) + (machinePair_mem_FP + (hfield machineKuhnSearchFrameRemaining + machineKuhnSearchFrameRemaining_mem_FP) + (machinePair_mem_FP + (hfield machineKuhnSearchFrameRow machineKuhnSearchFrameRow_mem_FP) + (machinePair_mem_FP machineKuhnRetSeen_mem_FP + (machinePair_mem_FP + (hfield machineKuhnSearchFrameMate + machineKuhnSearchFrameMate_mem_FP) + machineKuhnRestStack_mem_FP))))) + +theorem machineKuhnSearchReturnControl_mem_FP : + machineKuhnSearchReturnControl ∈ Complexity.FP := + machineIfHead_mem_FP machineKuhnRetSuccess_mem_FP + machineKuhnSearchReturnSuccessControl_mem_FP + machineKuhnSearchReturnFailureControl_mem_FP + +theorem machineKuhnBuildChosenMate_mem_FP : + machineKuhnBuildChosenMate ∈ Complexity.FP := by + have hfallback := machineCompose_mem_FP machineKuhnTopFrame_mem_FP + machineKuhnBuildFrameFallback_mem_FP + exact machineIfHead_mem_FP machineKuhnRetSuccess_mem_FP + machineKuhnRetMate_mem_FP hfallback + +theorem machineKuhnBuildRows_mem_FP : machineKuhnBuildRows ∈ Complexity.FP := by + simpa only [machineKuhnBuildRows] using! + machineCompose_mem_FP machineKuhnTopFrame_mem_FP + machineKuhnBuildFrameRows_mem_FP + +theorem machineKuhnBuildNextFrame_mem_FP : + machineKuhnBuildNextFrame ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineKuhnBuildRows_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [true]) + (machinePair_mem_FP htail machineKuhnBuildChosenMate_mem_FP) + +theorem machineKuhnBuildNextStack_mem_FP : + machineKuhnBuildNextStack ∈ Complexity.FP := + machinePair_mem_FP machineKuhnBuildNextFrame_mem_FP + machineKuhnRestStack_mem_FP + +theorem machineKuhnBuildContinueControl_mem_FP : + machineKuhnBuildContinueControl ∈ Complexity.FP := by + have hfuel := machineCompose_mem_FP machineKuhnStateDimension_mem_FP + (machinePrepend_mem_FP true) + have hrow := machineCompose_mem_FP machineKuhnBuildRows_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP (machineConst_mem_FP [false]) + (machinePair_mem_FP hfuel + (machinePair_mem_FP machineKuhnStateColumns_mem_FP + (machinePair_mem_FP hrow + (machinePair_mem_FP machineKuhnStateFalseSeen_mem_FP + (machinePair_mem_FP machineKuhnBuildChosenMate_mem_FP + machineKuhnBuildNextStack_mem_FP))))) + +theorem machineKuhnBuildReturnControl_mem_FP : + machineKuhnBuildReturnControl ∈ Complexity.FP := by + have hdone := machinePair_mem_FP (machineConst_mem_FP [true, true]) + machineKuhnBuildChosenMate_mem_FP + exact machineIfEmpty_mem_FP machineKuhnBuildRows_mem_FP hdone + machineKuhnBuildContinueControl_mem_FP + +theorem machineKuhnNonemptyReturnControl_mem_FP : + machineKuhnNonemptyReturnControl ∈ Complexity.FP := by + have htag := machineCompose_mem_FP machineKuhnTopFrame_mem_FP + machineKuhnFrameTag_mem_FP + exact machineIfHead_mem_FP htag machineKuhnBuildReturnControl_mem_FP + machineKuhnSearchReturnControl_mem_FP + +theorem machineKuhnReturnControl_mem_FP : + machineKuhnReturnControl ∈ Complexity.FP := + machineIfEmpty_mem_FP machineKuhnRetStack_mem_FP machineKuhnControl_mem_FP + machineKuhnNonemptyReturnControl_mem_FP + +theorem machineKuhnDoneControl_mem_FP : + machineKuhnDoneControl ∈ Complexity.FP := machineKuhnControl_mem_FP + +theorem machineKuhnNextControl_mem_FP : + machineKuhnNextControl ∈ Complexity.FP := by + have htag := machineCompose_mem_FP machineKuhnControl_mem_FP + machineKuhnControlTag_mem_FP + have hdoneBit := machineCompose_mem_FP machineKuhnControl_mem_FP + machineKuhnControlIsDoneBit_mem_FP + have hretOrDone := machineIfHead_mem_FP hdoneBit + machineKuhnDoneControl_mem_FP machineKuhnReturnControl_mem_FP + exact machineIfHead_mem_FP htag hretOrDone machineKuhnCallControl_mem_FP + +theorem machineKuhnStep_mem_FP : machineKuhnStep ∈ Complexity.FP := by + simpa only [machineKuhnStep] using! + machineKuhnWithControl_mem_FP machineKuhnNextControl_mem_FP + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineLengthBits.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineLengthBits.lean new file mode 100644 index 0000000000..4ecef17096 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineLengthBits.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryAddSemantics + +/-! +# Binary encoding of an input length + +This bounded counter converts the length of a bitstring to ordinary +little-endian binary. It is useful whenever a later machine needs the value +of a unary ruler without expanding an unrestricted binary integer. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Increments a binary accumulator by one for the word-length counter. -/ +def machineLengthBitsStep (acc : List Bool) : List Bool := + machineBinaryAddBits (pair acc [true]) + +/-- Uses the original input word as the width bound for its binary length counter. -/ +def machineLengthBitsWidth (word : List Bool) : List Bool := word + +/-- Computes the binary word length by iterating increment from zero once per input bit. -/ +def machineLengthBits (word : List Bool) : List Bool := + (machineLengthBitsStep)^[word.length] [] + +theorem machineLengthBitsStep_mem_FP : + machineLengthBitsStep ∈ Complexity.FP := by + have hpair := machinePair_mem_FP id_mem_FP (machineConst_mem_FP [true]) + simpa only [machineLengthBitsStep] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineLengthBitsWidth_mem_FP : + machineLengthBitsWidth ∈ Complexity.FP := id_mem_FP + +theorem machineLengthBitsIterate_encode : βˆ€ k, + (machineLengthBitsStep)^[k] [] = k.bits := by + intro k + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih, machineLengthBitsStep] + have hone : ([true] : List Bool) = (1 : β„•).bits := by rfl + rw [hone, machineBinaryAddBits_pair_natBits] + +private theorem lengthBits_natBits_length_le_self (k : β„•) : + k.bits.length ≀ k := by + rw [Nat.size_eq_bits_len] + exact Nat.size_le.mpr k.lt_two_pow_self + +theorem machineLengthBitsIterate_length_le_width + (word : List Bool) (iterations : β„•) (hiterations : iterations ≀ word.length) : + ((machineLengthBitsStep)^[iterations] []).length ≀ + (machineLengthBitsWidth word).length := by + rw [machineLengthBitsIterate_encode] + exact (lengthBits_natBits_length_le_self iterations).trans hiterations + +theorem machineLengthBits_mem_FP : machineLengthBits ∈ Complexity.FP := by + simpa only [machineLengthBits] using! + Cobham.iterate_mem_FP machineLengthBitsStep_mem_FP + (machineConst_mem_FP []) id_mem_FP machineLengthBitsWidth_mem_FP + machineLengthBitsIterate_length_le_width + +@[simp] theorem machineLengthBits_encode (word : List Bool) : + machineLengthBits word = word.length.bits := by + rw [machineLengthBits, machineLengthBitsIterate_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineListIndex.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineListIndex.lean new file mode 100644 index 0000000000..e54427b1e5 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineListIndex.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension + +/-! +# Indexed access to right-nested machine lists + +The index is supplied in unary. This is the representation used by all +bounded row, column, and coordinate loops below: its length is the number of +list tails to take. The routine is total on arbitrary strings and its state +only shrinks, so its global polynomial-time bound does not depend on the input +being a well-formed list code. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary index ruler from a list-index request. -/ +def machineListIndexRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded list from a list-index request. -/ +def machineListIndexData (word : List Bool) : List Bool := + machinePairSecond word + +/-- Drops as many encoded list entries as the length of the unary index ruler. -/ +def machineListIndexFinalState (word : List Bool) : List Bool := + (machineListTail)^[(machineListIndexRuler word).length] + (machineListIndexData word) + +/-- Return the code of the element at the unary index, or the empty word if +the index is outside the encoded list. -/ +def machineListIndex (word : List Bool) : List Bool := + machineListHead (machineListIndexFinalState word) + +theorem machineListIndexRuler_mem_FP : + machineListIndexRuler ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineListIndexData_mem_FP : + machineListIndexData ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineListTail_length_le (word : List Bool) : + (machineListTail word).length ≀ word.length := by + simpa only [machineListTail] using! machinePairSecond_length_le word + +theorem machineListTail_iterate_length_le (word : List Bool) : βˆ€ k, + ((machineListTail)^[k] word).length ≀ word.length := by + intro k + induction k with + | zero => simp + | succ k ih => + rw [Function.iterate_succ_apply'] + exact (machineListTail_length_le _).trans ih + +theorem machineListIndexIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineListIndexRuler word).length) : + ((machineListTail)^[iterations] + (machineListIndexData word)).length ≀ word.length := by + exact (machineListTail_iterate_length_le + (machineListIndexData word) iterations).trans + (machinePairSecond_length_le word) + +theorem machineListIndexFinalState_mem_FP : + machineListIndexFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineListTail_mem_FP + machineListIndexData_mem_FP machineListIndexRuler_mem_FP id_mem_FP + machineListIndexIterate_length_le_width + +theorem machineListIndex_mem_FP : + machineListIndex ∈ Complexity.FP := by + simpa only [machineListIndex] using! + machineCompose_mem_FP machineListIndexFinalState_mem_FP + machineListHead_mem_FP + +theorem machineListIndex_length_le_data (word : List Bool) : + (machineListIndex word).length ≀ (machineListIndexData word).length := by + rw [machineListIndex] + exact (machinePairFirst_length_le (machineListIndexFinalState word)).trans + (machineListTail_iterate_length_le (machineListIndexData word) + (machineListIndexRuler word).length) + +/-! ## Exact semantics -/ + +theorem machineListTail_iterate_binaryListCode + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) : βˆ€ (xs : List Ξ±) (k : β„•), + (machineListTail)^[k] (binaryListCode encode xs) = + binaryListCode encode (xs.drop k) := by + intro xs k + induction k generalizing xs with + | zero => simp + | succ k ih => + rw [Function.iterate_succ_apply] + cases xs with + | nil => + have htail : machineListTail [] = [] := by + rfl + simpa [binaryListCode] using! ih ([] : List Ξ±) + | cons x xs => + rw [machineListTail_cons, ih] + rfl + +theorem machineListIndex_binaryListCode + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (k : β„•) (hk : k < xs.length) : + machineListIndex + (pair (List.replicate k true) (binaryListCode encode xs)) = + encode xs[k] := by + rw [machineListIndex, machineListIndexFinalState, + machineListIndexRuler, machinePairFirst_pair, List.length_replicate, + machineListIndexData, machinePairSecond_pair, + machineListTail_iterate_binaryListCode] + rw [List.drop_eq_getElem_cons hk] + exact machineListHead_cons encode xs[k] (xs.drop (k + 1)) + +/-- Read a matrix entry using unary row and column indices. The input is +`pair rowUnary (pair columnUnary matrixCode)`. -/ +def machineMatrixEntryAtUnary (word : List Bool) : List Bool := + let rowUnary := machinePairFirst word + let rest := machinePairSecond word + let columnUnary := machinePairFirst rest + let matrixWord := machinePairSecond rest + let rowCode := machineListIndex + (pair rowUnary (machineMatrixRowsWord matrixWord)) + machineListIndex (pair columnUnary rowCode) + +theorem machineMatrixEntryAtUnary_mem_FP : + machineMatrixEntryAtUnary ∈ Complexity.FP := by + have hrowUnary : (fun word : List Bool => machinePairFirst word) ∈ + Complexity.FP := machinePairFirst_mem_FP + have hrest : (fun word : List Bool => machinePairSecond word) ∈ + Complexity.FP := machinePairSecond_mem_FP + have hcolumnUnary : + (fun word : List Bool => machinePairFirst (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP hrest machinePairFirst_mem_FP + have hmatrixWord : + (fun word : List Bool => machinePairSecond (machinePairSecond word)) ∈ + Complexity.FP := + machineCompose_mem_FP hrest machinePairSecond_mem_FP + have hrows : + (fun word : List Bool => + machineMatrixRowsWord (machinePairSecond (machinePairSecond word))) ∈ + Complexity.FP := + machineCompose_mem_FP hmatrixWord machineMatrixRowsWord_mem_FP + have hrowPayload := machinePair_mem_FP hrowUnary hrows + have hrowCode := machineCompose_mem_FP hrowPayload machineListIndex_mem_FP + have hentryPayload := machinePair_mem_FP hcolumnUnary hrowCode + simpa only [machineMatrixEntryAtUnary] using! + machineCompose_mem_FP hentryPayload machineListIndex_mem_FP + +@[simp] theorem machineMatrixEntryAtUnary_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) : + machineMatrixEntryAtUnary + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩))) = + rationalEntryBinaryCode (A i j) := by + rw [machineMatrixEntryAtUnary] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineMatrixRowsWord_encode] + rw [machineListIndex_binaryListCode] + Β· rw [machineListIndex_binaryListCode] + Β· simp [rationalMatrixRows, List.getElem_ofFn] + Β· simp [rationalMatrixRows] + Β· simp [rationalMatrixRows] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineListReverse.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineListReverse.lean new file mode 100644 index 0000000000..270ac8c170 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineListReverse.lean @@ -0,0 +1,337 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import Mathlib.Tactic + +/-! +# Reversal of a self-delimiting machine list + +The machine scans a right-nested list code and pushes each decoded head onto +an accumulator. The accumulator is clamped to the input-word length on +arbitrary malformed strings. On canonical list codes its length never +exceeds the input length, so the semantic proof below shows that the clamp is +inactive. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Packs the unprocessed list, reversed accumulator, and length-bound word for list reversal. -/ +def machineListReversePack + (remaining accumulator bound : List Bool) : List Bool := + pair remaining (pair accumulator bound) + +/-- Extracts the unprocessed encoded list from a reversal state. -/ +def machineListReverseRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reversed-prefix accumulator from a reversal state. -/ +def machineListReverseAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the word bounding accumulator length in a reversal state. -/ +def machineListReverseBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Prepends the next unprocessed list entry to the reversed accumulator. -/ +def machineListReverseCandidate (state : List Bool) : List Bool := + pair (machineListHead (machineListReverseRemaining state)) + (machineListReverseAccumulator state) + +/-- Truncates the candidate reversed accumulator to the length of the stored bound. -/ +def machineListReverseNextAccumulator (state : List Bool) : List Bool := + (machineListReverseCandidate state).take + (machineListReverseBound state).length + +/-- Drops the next input entry and records the bounded reversed accumulator while preserving the +bound. -/ +def machineListReverseAdvance (state : List Bool) : List Bool := + machineListReversePack + (machineListTail (machineListReverseRemaining state)) + (machineListReverseNextAccumulator state) + (machineListReverseBound state) + +/-- Fixes an exhausted reversal state and otherwise transfers one entry to the reversed +accumulator. -/ +def machineListReverseStep (state : List Bool) : List Bool := + machineIfEmpty (machineListReverseRemaining state) state + (machineListReverseAdvance state) + +/-- Initializes reversal with the input list, empty accumulator, and the input word itself as +bound. -/ +def machineListReverseInit (word : List Bool) : List Bool := + machineListReversePack word [] word + +/-- Packs three copies of the input word to bound the encoded reversal state. -/ +def machineListReverseWidth (word : List Bool) : List Bool := + machineListReversePack word word word + +/-- Iterates the reversal step once per input bit from the initial state. -/ +def machineListReverseFinalState (word : List Bool) : List Bool := + (machineListReverseStep)^[word.length] (machineListReverseInit word) + +/-- Extracts the reversed encoded list from the final reversal state. -/ +def machineListReverse (word : List Bool) : List Bool := + machineListReverseAccumulator (machineListReverseFinalState word) + +theorem machineListReverseRemaining_mem_FP : + machineListReverseRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineListReverseAccumulator_mem_FP : + machineListReverseAccumulator ∈ Complexity.FP := by + simpa only [machineListReverseAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineListReverseBound_mem_FP : + machineListReverseBound ∈ Complexity.FP := by + simpa only [machineListReverseBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineListReverseCandidate_mem_FP : + machineListReverseCandidate ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP machineListReverseRemaining_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP hhead machineListReverseAccumulator_mem_FP + +theorem machineListReverseNextAccumulator_mem_FP : + machineListReverseNextAccumulator ∈ Complexity.FP := by + simpa only [machineListReverseNextAccumulator] using! + machineTake_mem_FP machineListReverseBound_mem_FP + machineListReverseCandidate_mem_FP + +theorem machineListReverseAdvance_mem_FP : + machineListReverseAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineListReverseRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineListReverseNextAccumulator_mem_FP + machineListReverseBound_mem_FP) + +theorem machineListReverseStep_mem_FP : + machineListReverseStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineListReverseRemaining_mem_FP id_mem_FP + machineListReverseAdvance_mem_FP + +theorem machineListReverseInit_mem_FP : + machineListReverseInit ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP) + +theorem machineListReverseWidth_mem_FP : + machineListReverseWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP id_mem_FP) + +@[simp] theorem machineListReverseRemaining_pack (a b c) : + machineListReverseRemaining (machineListReversePack a b c) = a := by + simp [machineListReverseRemaining, machineListReversePack] + +@[simp] theorem machineListReverseAccumulator_pack (a b c) : + machineListReverseAccumulator (machineListReversePack a b c) = b := by + simp [machineListReverseAccumulator, machineListReversePack] + +@[simp] theorem machineListReverseBound_pack (a b c) : + machineListReverseBound (machineListReversePack a b c) = c := by + simp [machineListReverseBound, machineListReversePack] + +/-- Requires exact reversal-state packing, remaining and accumulator lengths bounded by the +original word, and that original word as the bound. -/ +def MachineListReverseStateBound (word state : List Bool) : Prop := + state = machineListReversePack + (machineListReverseRemaining state) + (machineListReverseAccumulator state) + (machineListReverseBound state) ∧ + (machineListReverseRemaining state).length ≀ word.length ∧ + (machineListReverseAccumulator state).length ≀ word.length ∧ + machineListReverseBound state = word + +theorem machineListReverseInit_bound (word : List Bool) : + MachineListReverseStateBound word (machineListReverseInit word) := by + simp [MachineListReverseStateBound, machineListReverseInit] + +theorem machineListReverseStep_bound {word state : List Bool} + (hstate : MachineListReverseStateBound word state) : + MachineListReverseStateBound word (machineListReverseStep state) := by + rcases hstate with ⟨hdecomp, hremaining, haccumulator, hbound⟩ + by_cases hnil : machineListReverseRemaining state = [] + Β· rw [machineListReverseStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, haccumulator, hbound⟩ + Β· rw [machineListReverseStep] + cases hremainingCode : machineListReverseRemaining state with + | nil => exact False.elim (hnil hremainingCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineListReverseAdvance] + simp only [MachineListReverseStateBound, + machineListReverseRemaining_pack, + machineListReverseAccumulator_pack, + machineListReverseBound_pack] + refine ⟨trivial, ?_, ?_, hbound⟩ + Β· exact (machineListTail_length_le + (machineListReverseRemaining state)).trans hremaining + Β· rw [machineListReverseNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineListReverseIterate_bound (word : List Bool) : βˆ€ k, + MachineListReverseStateBound word + ((machineListReverseStep)^[k] (machineListReverseInit word)) := by + intro k + induction k with + | zero => exact machineListReverseInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineListReverseStep_bound ih + +theorem machineListReverseIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineListReverseStep)^[iterations] + (machineListReverseInit word)).length ≀ + (machineListReverseWidth word).length := by + rcases machineListReverseIterate_bound word iterations with + ⟨hdecomp, hremaining, haccumulator, hbound⟩ + rw [hdecomp, hbound] + simp only [machineListReversePack, machineListReverseWidth, pair_length] + omega + +theorem machineListReverseFinalState_mem_FP : + machineListReverseFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineListReverseStep_mem_FP + machineListReverseInit_mem_FP id_mem_FP machineListReverseWidth_mem_FP + machineListReverseIterate_length_le_width + +theorem machineListReverse_mem_FP : machineListReverse ∈ Complexity.FP := by + simpa only [machineListReverse] using! + machineCompose_mem_FP machineListReverseFinalState_mem_FP + machineListReverseAccumulator_mem_FP + +/-! ## Exact semantics on canonical list codes -/ + +/-- Encodes the unprocessed suffix, reversed processed prefix, and original-list bound after `k` +reversal steps. -/ +def machineListReverseSemanticState + {alpha : Type*} (encode : alpha β†’ List Bool) + (xs : List alpha) (k : β„•) : List Bool := + machineListReversePack + (binaryListCode encode (xs.drop k)) + (binaryListCode encode (xs.take k).reverse) + (binaryListCode encode xs) + +theorem machineListReverseInit_semantics + {alpha : Type*} (encode : alpha β†’ List Bool) (xs : List alpha) : + machineListReverseInit (binaryListCode encode xs) = + machineListReverseSemanticState encode xs 0 := by + simp [machineListReverseInit, machineListReverseSemanticState, + binaryListCode] + +theorem machineListReverseStep_semantics + {alpha : Type*} (encode : alpha β†’ List Bool) + (xs : List alpha) (k : β„•) (hk : k < xs.length) : + machineListReverseStep + (machineListReverseSemanticState encode xs k) = + machineListReverseSemanticState encode xs (k + 1) := by + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hk + have hprefix : (xs.take (k + 1)).reverse = + xs[k] :: (xs.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := xs.take k) (a := xs[k])) + have hprefixLength : + (binaryListCode encode (xs.take (k + 1)).reverse).length ≀ + (binaryListCode encode xs).length := + binaryListCode_take_reverse_length_le encode xs (k + 1) + have htakeBound : + (binaryListCode encode (xs.take (k + 1)).reverse).take + (binaryListCode encode xs).length = + binaryListCode encode (xs.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hnonempty : binaryListCode encode (xs.drop k) β‰  [] := by + rw [hdrop] + intro hnil + have hlen := congrArg List.length hnil + simp [binaryListCode] at hlen + rw [machineListReverseStep] + simp only [machineListReverseSemanticState, + machineListReverseRemaining_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hnonempty, + machineListReverseAdvance] + simp only [machineListReverseRemaining_pack, + machineListReverseAccumulator_pack, machineListReverseBound_pack, + machineListReverseNextAccumulator, machineListReverseCandidate] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineListReversePack (binaryListCode encode (xs.drop (k + 1))) + ((binaryListCode encode + (xs[k] :: (xs.take k).reverse)).take + (binaryListCode encode xs).length) + (binaryListCode encode xs) = _ + rw [← hprefix, htakeBound] + +theorem machineListReverseIterate_semantics + {alpha : Type*} (encode : alpha β†’ List Bool) + (xs : List alpha) : βˆ€ k ≀ xs.length, + (machineListReverseStep)^[k] + (machineListReverseInit (binaryListCode encode xs)) = + machineListReverseSemanticState encode xs k := by + intro k hk + induction k with + | zero => exact machineListReverseInit_semantics encode xs + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineListReverseStep_semantics encode xs k (by omega) + +theorem binaryListCode_listLength_le + {alpha : Type*} (encode : alpha β†’ List Bool) : βˆ€ xs : List alpha, + xs.length ≀ (binaryListCode encode xs).length := by + intro xs + induction xs with + | nil => simp [binaryListCode] + | cons x xs ih => + simp only [List.length_cons, binaryListCode, pair_length] + omega + +theorem machineListReverse_done_iterate + (extra : β„•) (accumulator bound : List Bool) : + (machineListReverseStep)^[extra] + (machineListReversePack [] accumulator bound) = + machineListReversePack [] accumulator bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineListReverseStep] + +theorem machineListReverseFinalState_encode + {alpha : Type*} (encode : alpha β†’ List Bool) (xs : List alpha) : + machineListReverseFinalState (binaryListCode encode xs) = + machineListReversePack [] (binaryListCode encode xs.reverse) + (binaryListCode encode xs) := by + let word := binaryListCode encode xs + have hlength : xs.length ≀ word.length := + binaryListCode_listLength_le encode xs + have hsplit : word.length = + (word.length - xs.length) + xs.length := by omega + change (machineListReverseStep)^[word.length] + (machineListReverseInit word) = _ + rw [hsplit, Function.iterate_add_apply, + machineListReverseIterate_semantics encode xs xs.length le_rfl] + simp only [machineListReverseSemanticState, List.drop_length, + List.take_length, binaryListCode, word] + rw [machineListReverse_done_iterate] + +@[simp] theorem machineListReverse_encode + {alpha : Type*} (encode : alpha β†’ List Bool) (xs : List alpha) : + machineListReverse (binaryListCode encode xs) = + binaryListCode encode xs.reverse := by + rw [machineListReverse, machineListReverseFinalState_encode] + simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineListUpdate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineListUpdate.lean new file mode 100644 index 0000000000..2bb21c9919 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineListUpdate.lean @@ -0,0 +1,1053 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex + +/-! +# Indexed update of right-nested machine lists + +This file supplies the mutable-array primitive used by the matching and +ellipsoid machines. The input is +`pair indexUnary (pair replacement listCode)`. A first bounded pass removes +the indexed prefix while storing it in reverse order. A second bounded pass +rebuilds the prefix around the replacement. Both passes clamp their growing +field to an explicit quadratic word. The semantic invariant proves that the +clamps are inactive on every canonical in-range list update. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Forward scan -/ + +/-- Extracts the unary target-index ruler from a list-update request. -/ +def machineListUpdateRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the replacement-and-list payload from a list-update request. -/ +def machineListUpdatePayload (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the encoded replacement entry from a list-update request. -/ +def machineListUpdateReplacement (word : List Bool) : List Bool := + machinePairFirst (machineListUpdatePayload word) + +/-- Extracts the encoded list to update. -/ +def machineListUpdateData (word : List Bool) : List Bool := + machinePairSecond (machineListUpdatePayload word) + +/-- Applies the binary-multiplication width construction twice to bound the list-update +computation. -/ +def machineListUpdateInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth word) + +/-- Packs the remaining index ruler, reversed prefix, current suffix, replacement, and bound for +the update scan. -/ +def machineListUpdateScanPack + (remaining pref current replacement bound : List Bool) : List Bool := + pair remaining (pair pref (pair current (pair replacement bound))) + +/-- Extracts the unconsumed unary index ruler from an update scan state. -/ +def machineListUpdateScanRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reversed processed prefix from an update scan state. -/ +def machineListUpdateScanPrefix (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the current unprocessed list suffix from an update scan state. -/ +def machineListUpdateScanCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the replacement entry stored in an update scan state. -/ +def machineListUpdateScanReplacement (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the bound word stored in an update scan state. -/ +def machineListUpdateScanBound (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Prepends the current suffix head to the reversed processed prefix. -/ +def machineListUpdateScanPrefixCandidate (state : List Bool) : List Bool := + pair (machineListHead (machineListUpdateScanCurrent state)) + (machineListUpdateScanPrefix state) + +/-- Truncates the updated reversed prefix to the length of the scan bound. -/ +def machineListUpdateScanNextPrefix (state : List Bool) : List Bool := + (machineListUpdateScanPrefixCandidate state).take + (machineListUpdateScanBound state).length + +/-- Consumes one index-ruler bit and one list entry, extending the bounded reversed prefix while +retaining replacement and bound. -/ +def machineListUpdateScanAdvance (state : List Bool) : List Bool := + machineListUpdateScanPack + (machineListUpdateScanRemaining state).tail + (machineListUpdateScanNextPrefix state) + (machineListTail (machineListUpdateScanCurrent state)) + (machineListUpdateScanReplacement state) + (machineListUpdateScanBound state) + +/-- Fixes an update scan when either the index ruler or current suffix is exhausted and +otherwise advances once. -/ +def machineListUpdateScanStep (state : List Bool) : List Bool := + machineIfEmpty (machineListUpdateScanRemaining state) state + (machineIfEmpty (machineListUpdateScanCurrent state) state + (machineListUpdateScanAdvance state)) + +/-- Initializes the update scan with the requested index, empty prefix, input list, replacement, +and computed bound. -/ +def machineListUpdateScanInit (word : List Bool) : List Bool := + machineListUpdateScanPack (machineListUpdateRuler word) [] + (machineListUpdateData word) (machineListUpdateReplacement word) + (machineListUpdateInputBound word) + +/-- Packs five copies of the input bound to bound the encoded update-scan state. -/ +def machineListUpdateScanWidth (word : List Bool) : List Bool := + let bound := machineListUpdateInputBound word + machineListUpdateScanPack bound bound bound bound bound + +/-- Runs the update scan for the length of the requested unary index ruler. -/ +def machineListUpdateScanFinalState (word : List Bool) : List Bool := + (machineListUpdateScanStep)^[(machineListUpdateRuler word).length] + (machineListUpdateScanInit word) + +theorem machineListUpdateRuler_mem_FP : + machineListUpdateRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineListUpdatePayload_mem_FP : + machineListUpdatePayload ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineListUpdateReplacement_mem_FP : + machineListUpdateReplacement ∈ Complexity.FP := by + simpa only [machineListUpdateReplacement] using! + machineCompose_mem_FP machineListUpdatePayload_mem_FP + machinePairFirst_mem_FP + +theorem machineListUpdateData_mem_FP : + machineListUpdateData ∈ Complexity.FP := by + simpa only [machineListUpdateData] using! + machineCompose_mem_FP machineListUpdatePayload_mem_FP + machinePairSecond_mem_FP + +theorem machineListUpdateInputBound_mem_FP : + machineListUpdateInputBound ∈ Complexity.FP := by + simpa only [machineListUpdateInputBound] using! + machineCompose_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineBinaryMulWidth_length_mono {left right : List Bool} + (h : left.length ≀ right.length) : + (machineBinaryMulWidth left).length ≀ + (machineBinaryMulWidth right).length := by + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] + simpa [pow_two] using! + Nat.pow_le_pow_left (Nat.add_le_add_left h 16) 2 + +theorem machineListUpdateInputBound_length_mono {left right : List Bool} + (h : left.length ≀ right.length) : + (machineListUpdateInputBound left).length ≀ + (machineListUpdateInputBound right).length := by + exact machineBinaryMulWidth_length_mono + (machineBinaryMulWidth_length_mono h) + +theorem machineListUpdateScanRemaining_mem_FP : + machineListUpdateScanRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineListUpdateScanPrefix_mem_FP : + machineListUpdateScanPrefix ∈ Complexity.FP := by + simpa only [machineListUpdateScanPrefix] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineListUpdateScanCurrent_mem_FP : + machineListUpdateScanCurrent ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineListUpdateScanCurrent] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineListUpdateScanReplacement_mem_FP : + machineListUpdateScanReplacement ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineListUpdateScanReplacement] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineListUpdateScanBound_mem_FP : + machineListUpdateScanBound ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineListUpdateScanBound] using! + machineCompose_mem_FP htailThree machinePairSecond_mem_FP + +theorem machineListUpdateScanPrefixCandidate_mem_FP : + machineListUpdateScanPrefixCandidate ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP + machineListUpdateScanCurrent_mem_FP machineListHead_mem_FP + exact machinePair_mem_FP hhead machineListUpdateScanPrefix_mem_FP + +theorem machineListUpdateScanNextPrefix_mem_FP : + machineListUpdateScanNextPrefix ∈ Complexity.FP := by + simpa only [machineListUpdateScanNextPrefix] using! + machineTake_mem_FP machineListUpdateScanBound_mem_FP + machineListUpdateScanPrefixCandidate_mem_FP + +theorem machineListUpdateScanAdvance_mem_FP : + machineListUpdateScanAdvance ∈ Complexity.FP := by + have hremaining := machineCompose_mem_FP + machineListUpdateScanRemaining_mem_FP machineTail_mem_FP + have hcurrent := machineCompose_mem_FP + machineListUpdateScanCurrent_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP hremaining + (machinePair_mem_FP machineListUpdateScanNextPrefix_mem_FP + (machinePair_mem_FP hcurrent + (machinePair_mem_FP machineListUpdateScanReplacement_mem_FP + machineListUpdateScanBound_mem_FP))) + +theorem machineListUpdateScanStep_mem_FP : + machineListUpdateScanStep ∈ Complexity.FP := by + have hinner := machineIfEmpty_mem_FP + machineListUpdateScanCurrent_mem_FP id_mem_FP + machineListUpdateScanAdvance_mem_FP + simpa only [machineListUpdateScanStep] using! + machineIfEmpty_mem_FP machineListUpdateScanRemaining_mem_FP + id_mem_FP hinner + +theorem machineListUpdateScanInit_mem_FP : + machineListUpdateScanInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineListUpdateRuler_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineListUpdateData_mem_FP + (machinePair_mem_FP machineListUpdateReplacement_mem_FP + machineListUpdateInputBound_mem_FP))) + +theorem machineListUpdateScanWidth_mem_FP : + machineListUpdateScanWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineListUpdateInputBound_mem_FP + (machinePair_mem_FP machineListUpdateInputBound_mem_FP + (machinePair_mem_FP machineListUpdateInputBound_mem_FP + (machinePair_mem_FP machineListUpdateInputBound_mem_FP + machineListUpdateInputBound_mem_FP))) + +@[simp] theorem machineListUpdateScanRemaining_pack (a b c d e) : + machineListUpdateScanRemaining + (machineListUpdateScanPack a b c d e) = a := by + simp [machineListUpdateScanRemaining, machineListUpdateScanPack] + +@[simp] theorem machineListUpdateScanPrefix_pack (a b c d e) : + machineListUpdateScanPrefix + (machineListUpdateScanPack a b c d e) = b := by + simp [machineListUpdateScanPrefix, machineListUpdateScanPack] + +@[simp] theorem machineListUpdateScanCurrent_pack (a b c d e) : + machineListUpdateScanCurrent + (machineListUpdateScanPack a b c d e) = c := by + simp [machineListUpdateScanCurrent, machineListUpdateScanPack] + +@[simp] theorem machineListUpdateScanReplacement_pack (a b c d e) : + machineListUpdateScanReplacement + (machineListUpdateScanPack a b c d e) = d := by + simp [machineListUpdateScanReplacement, machineListUpdateScanPack] + +@[simp] theorem machineListUpdateScanBound_pack (a b c d e) : + machineListUpdateScanBound + (machineListUpdateScanPack a b c d e) = e := by + simp [machineListUpdateScanBound, machineListUpdateScanPack] + +theorem machineListUpdate_word_length_le_bound (word : List Bool) : + word.length ≀ (machineListUpdateInputBound word).length := by + simp only [machineListUpdateInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +/-- Requires exact update-scan packing and bounds all five field lengths by the computed +input-bound length. -/ +def MachineListUpdateScanStateBound + (word state : List Bool) : Prop := + let B := (machineListUpdateInputBound word).length + state = machineListUpdateScanPack + (machineListUpdateScanRemaining state) + (machineListUpdateScanPrefix state) + (machineListUpdateScanCurrent state) + (machineListUpdateScanReplacement state) + (machineListUpdateScanBound state) ∧ + (machineListUpdateScanRemaining state).length ≀ B ∧ + (machineListUpdateScanPrefix state).length ≀ B ∧ + (machineListUpdateScanCurrent state).length ≀ B ∧ + (machineListUpdateScanReplacement state).length ≀ B ∧ + (machineListUpdateScanBound state).length ≀ B + +theorem machineListUpdateScanInit_bound (word : List Bool) : + MachineListUpdateScanStateBound word + (machineListUpdateScanInit word) := by + simp only [MachineListUpdateScanStateBound, machineListUpdateScanInit, + machineListUpdateScanRemaining_pack, machineListUpdateScanPrefix_pack, + machineListUpdateScanCurrent_pack, + machineListUpdateScanReplacement_pack, + machineListUpdateScanBound_pack] + have hword := machineListUpdate_word_length_le_bound word + refine ⟨trivial, ?_, by simp, ?_, ?_, le_rfl⟩ + Β· exact (machinePairFirst_length_le word).trans hword + Β· exact (machinePairSecond_length_le + (machineListUpdatePayload word)).trans + ((machinePairSecond_length_le word).trans hword) + Β· exact (machinePairFirst_length_le + (machineListUpdatePayload word)).trans + ((machinePairSecond_length_le word).trans hword) + +theorem machineListUpdateScanStep_bound + {word state : List Bool} + (hstate : MachineListUpdateScanStateBound word state) : + MachineListUpdateScanStateBound word + (machineListUpdateScanStep state) := by + dsimp only [MachineListUpdateScanStateBound] at hstate ⊒ + rcases hstate with ⟨hdecomp, hrem, hprefix, hcurrent, hrepl, hbound⟩ + by_cases hr : machineListUpdateScanRemaining state = [] + Β· rw [machineListUpdateScanStep, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hrem, hprefix, hcurrent, hrepl, hbound⟩ + Β· cases hremCode : machineListUpdateScanRemaining state with + | nil => exact False.elim (hr hremCode) + | cons rb rt => + rw [machineListUpdateScanStep, hremCode, machineIfEmpty_cons] + by_cases hc : machineListUpdateScanCurrent state = [] + Β· rw [hc, machineIfEmpty_nil] + exact ⟨hdecomp, hrem, hprefix, hcurrent, hrepl, hbound⟩ + Β· cases hcurrentCode : machineListUpdateScanCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons cb ct => + rw [machineIfEmpty_cons, machineListUpdateScanAdvance] + simp only [machineListUpdateScanRemaining_pack, + machineListUpdateScanPrefix_pack, + machineListUpdateScanCurrent_pack, + machineListUpdateScanReplacement_pack, + machineListUpdateScanBound_pack] + refine ⟨trivial, ?_, ?_, ?_, hrepl, hbound⟩ + Β· rw [List.length_tail] + omega + Β· exact (List.length_take_le _ _).trans hbound + Β· exact (machineListTail_length_le _).trans hcurrent + +theorem machineListUpdateScanIterate_bound (word : List Bool) : βˆ€ k, + MachineListUpdateScanStateBound word + ((machineListUpdateScanStep)^[k] + (machineListUpdateScanInit word)) := by + intro k + induction k with + | zero => exact machineListUpdateScanInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineListUpdateScanStep_bound ih + +theorem machineListUpdateScanIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineListUpdateRuler word).length) : + ((machineListUpdateScanStep)^[iterations] + (machineListUpdateScanInit word)).length ≀ + (machineListUpdateScanWidth word).length := by + rcases machineListUpdateScanIterate_bound word iterations with + ⟨hdecomp, hrem, hprefix, hcurrent, hrepl, hbound⟩ + rw [hdecomp] + simp only [machineListUpdateScanPack, machineListUpdateScanWidth, + pair_length] + omega + +theorem machineListUpdateScanFinalState_mem_FP : + machineListUpdateScanFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineListUpdateScanStep_mem_FP + machineListUpdateScanInit_mem_FP machineListUpdateRuler_mem_FP + machineListUpdateScanWidth_mem_FP + machineListUpdateScanIterate_length_le_width + +/-! ## Reverse-prefix rebuild -/ + +/-- Builds the updated suffix by replacing its head and truncating to the stored bound; an +exhausted suffix gives the empty word. -/ +def machineListUpdateSeed (word : List Bool) : List Bool := + let scan := machineListUpdateScanFinalState word + machineIfEmpty (machineListUpdateScanCurrent scan) [] + ((pair (machineListUpdateScanReplacement scan) + (machineListTail (machineListUpdateScanCurrent scan))).take + (machineListUpdateScanBound scan).length) + +/-- Packs the reversed prefix, current output, and bound for rebuilding the updated list. -/ +def machineListUpdateRebuildPack + (pref output bound : List Bool) : List Bool := + pair pref (pair output bound) + +/-- Extracts the remaining reversed prefix from a list-update rebuild state. -/ +def machineListUpdateRebuildPrefix (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reconstructed output list from a list-update rebuild state. -/ +def machineListUpdateRebuildOutput (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the stored width bound from a list-update rebuild state. -/ +def machineListUpdateRebuildBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Prepends the next saved prefix entry to the reconstructed output list. -/ +def machineListUpdateRebuildCandidate (state : List Bool) : List Bool := + pair (machineListHead (machineListUpdateRebuildPrefix state)) + (machineListUpdateRebuildOutput state) + +/-- Truncates the rebuilt candidate list to the stored width bound. -/ +def machineListUpdateRebuildNextOutput (state : List Bool) : List Bool := + (machineListUpdateRebuildCandidate state).take + (machineListUpdateRebuildBound state).length + +/-- Consumes one saved prefix entry and updates the bounded reconstructed list. -/ +def machineListUpdateRebuildAdvance (state : List Bool) : List Bool := + machineListUpdateRebuildPack + (machineListTail (machineListUpdateRebuildPrefix state)) + (machineListUpdateRebuildNextOutput state) + (machineListUpdateRebuildBound state) + +/-- Rebuilds one prefix entry, leaving states with no saved prefix fixed. -/ +def machineListUpdateRebuildStep (state : List Bool) : List Bool := + machineIfEmpty (machineListUpdateRebuildPrefix state) state + (machineListUpdateRebuildAdvance state) + +/-- Starts reconstruction from the scanned reversed prefix, updated suffix seed, and stored +bound. -/ +def machineListUpdateRebuildInit (word : List Bool) : List Bool := + let scan := machineListUpdateScanFinalState word + machineListUpdateRebuildPack (machineListUpdateScanPrefix scan) + (machineListUpdateSeed word) (machineListUpdateScanBound scan) + +/-- Packs three copies of the input-derived bound to bound a rebuild state. -/ +def machineListUpdateRebuildWidth (word : List Bool) : List Bool := + let bound := machineListUpdateInputBound word + machineListUpdateRebuildPack bound bound bound + +/-- Runs the rebuild step for the number of iterations specified by the update ruler. -/ +def machineListUpdateRebuildFinalState (word : List Bool) : List Bool := + (machineListUpdateRebuildStep)^[(machineListUpdateRuler word).length] + (machineListUpdateRebuildInit word) + +/-- Replace the element at the unary index. Out-of-range and malformed +inputs return a total, polynomially bounded default determined above. -/ +def machineListUpdate (word : List Bool) : List Bool := + machineListUpdateRebuildOutput + (machineListUpdateRebuildFinalState word) + +theorem machineListUpdateSeed_mem_FP : + machineListUpdateSeed ∈ Complexity.FP := by + let scan : List Bool β†’ List Bool := machineListUpdateScanFinalState + have hscan : scan ∈ Complexity.FP := + machineListUpdateScanFinalState_mem_FP + have hcurrent := machineCompose_mem_FP hscan + machineListUpdateScanCurrent_mem_FP + have hrepl := machineCompose_mem_FP hscan + machineListUpdateScanReplacement_mem_FP + have htailCurrent := machineCompose_mem_FP hcurrent machineListTail_mem_FP + have hcandidate := machinePair_mem_FP hrepl htailCurrent + have hbound := machineCompose_mem_FP hscan + machineListUpdateScanBound_mem_FP + have htaken := machineTake_mem_FP hbound hcandidate + simpa only [machineListUpdateSeed, scan] using! + machineIfEmpty_mem_FP hcurrent (machineConst_mem_FP []) htaken + +theorem machineListUpdateRebuildPrefix_mem_FP : + machineListUpdateRebuildPrefix ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineListUpdateRebuildOutput_mem_FP : + machineListUpdateRebuildOutput ∈ Complexity.FP := by + simpa only [machineListUpdateRebuildOutput] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineListUpdateRebuildBound_mem_FP : + machineListUpdateRebuildBound ∈ Complexity.FP := by + simpa only [machineListUpdateRebuildBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineListUpdateRebuildCandidate_mem_FP : + machineListUpdateRebuildCandidate ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP + machineListUpdateRebuildPrefix_mem_FP machineListHead_mem_FP + exact machinePair_mem_FP hhead machineListUpdateRebuildOutput_mem_FP + +theorem machineListUpdateRebuildNextOutput_mem_FP : + machineListUpdateRebuildNextOutput ∈ Complexity.FP := by + simpa only [machineListUpdateRebuildNextOutput] using! + machineTake_mem_FP machineListUpdateRebuildBound_mem_FP + machineListUpdateRebuildCandidate_mem_FP + +theorem machineListUpdateRebuildAdvance_mem_FP : + machineListUpdateRebuildAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP + machineListUpdateRebuildPrefix_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineListUpdateRebuildNextOutput_mem_FP + machineListUpdateRebuildBound_mem_FP) + +theorem machineListUpdateRebuildStep_mem_FP : + machineListUpdateRebuildStep ∈ Complexity.FP := by + simpa only [machineListUpdateRebuildStep] using! + machineIfEmpty_mem_FP machineListUpdateRebuildPrefix_mem_FP + id_mem_FP machineListUpdateRebuildAdvance_mem_FP + +theorem machineListUpdateRebuildInit_mem_FP : + machineListUpdateRebuildInit ∈ Complexity.FP := by + have hprefix := machineCompose_mem_FP + machineListUpdateScanFinalState_mem_FP machineListUpdateScanPrefix_mem_FP + have hbound := machineCompose_mem_FP + machineListUpdateScanFinalState_mem_FP machineListUpdateScanBound_mem_FP + exact machinePair_mem_FP hprefix + (machinePair_mem_FP machineListUpdateSeed_mem_FP hbound) + +theorem machineListUpdateRebuildWidth_mem_FP : + machineListUpdateRebuildWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineListUpdateInputBound_mem_FP + (machinePair_mem_FP machineListUpdateInputBound_mem_FP + machineListUpdateInputBound_mem_FP) + +@[simp] theorem machineListUpdateRebuildPrefix_pack (a b c) : + machineListUpdateRebuildPrefix + (machineListUpdateRebuildPack a b c) = a := by + simp [machineListUpdateRebuildPrefix, machineListUpdateRebuildPack] + +@[simp] theorem machineListUpdateRebuildOutput_pack (a b c) : + machineListUpdateRebuildOutput + (machineListUpdateRebuildPack a b c) = b := by + simp [machineListUpdateRebuildOutput, machineListUpdateRebuildPack] + +@[simp] theorem machineListUpdateRebuildBound_pack (a b c) : + machineListUpdateRebuildBound + (machineListUpdateRebuildPack a b c) = c := by + simp [machineListUpdateRebuildBound, machineListUpdateRebuildPack] + +/-- Bounds all components of a canonically packed list-update rebuild state. -/ +def MachineListUpdateRebuildStateBound + (word state : List Bool) : Prop := + let B := (machineListUpdateInputBound word).length + state = machineListUpdateRebuildPack + (machineListUpdateRebuildPrefix state) + (machineListUpdateRebuildOutput state) + (machineListUpdateRebuildBound state) ∧ + (machineListUpdateRebuildPrefix state).length ≀ B ∧ + (machineListUpdateRebuildOutput state).length ≀ B ∧ + (machineListUpdateRebuildBound state).length ≀ B + +theorem machineListUpdateRebuildInit_bound (word : List Bool) : + MachineListUpdateRebuildStateBound word + (machineListUpdateRebuildInit word) := by + have hscan := machineListUpdateScanIterate_bound word + (machineListUpdateRuler word).length + change MachineListUpdateScanStateBound word + (machineListUpdateScanFinalState word) at hscan + dsimp only [MachineListUpdateScanStateBound] at hscan + rcases hscan with ⟨_, _, hprefix, _, _, hbound⟩ + simp only [MachineListUpdateRebuildStateBound, + machineListUpdateRebuildInit, + machineListUpdateRebuildPrefix_pack, + machineListUpdateRebuildOutput_pack, + machineListUpdateRebuildBound_pack] + refine ⟨trivial, hprefix, ?_, hbound⟩ + simp only [machineListUpdateSeed] + exact (machineIfEmpty_length_le_max _ _ _).trans (by + apply max_le + Β· simp + Β· exact (List.length_take_le _ _).trans hbound) + +theorem machineListUpdateRebuildStep_bound + {word state : List Bool} + (hstate : MachineListUpdateRebuildStateBound word state) : + MachineListUpdateRebuildStateBound word + (machineListUpdateRebuildStep state) := by + dsimp only [MachineListUpdateRebuildStateBound] at hstate ⊒ + rcases hstate with ⟨hdecomp, hprefix, houtput, hbound⟩ + by_cases hp : machineListUpdateRebuildPrefix state = [] + Β· rw [machineListUpdateRebuildStep, hp, machineIfEmpty_nil] + exact ⟨hdecomp, hprefix, houtput, hbound⟩ + Β· cases hprefixCode : machineListUpdateRebuildPrefix state with + | nil => exact False.elim (hp hprefixCode) + | cons pb pt => + rw [machineListUpdateRebuildStep, hprefixCode] + rw [machineIfEmpty_cons, + machineListUpdateRebuildAdvance] + simp only [machineListUpdateRebuildPrefix_pack, + machineListUpdateRebuildOutput_pack, + machineListUpdateRebuildBound_pack] + refine ⟨trivial, ?_, ?_, hbound⟩ + Β· exact (machineListTail_length_le _).trans hprefix + Β· exact (List.length_take_le _ _).trans hbound + +theorem machineListUpdateRebuildIterate_bound (word : List Bool) : βˆ€ k, + MachineListUpdateRebuildStateBound word + ((machineListUpdateRebuildStep)^[k] + (machineListUpdateRebuildInit word)) := by + intro k + induction k with + | zero => exact machineListUpdateRebuildInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineListUpdateRebuildStep_bound ih + +theorem machineListUpdateRebuildIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineListUpdateRuler word).length) : + ((machineListUpdateRebuildStep)^[iterations] + (machineListUpdateRebuildInit word)).length ≀ + (machineListUpdateRebuildWidth word).length := by + rcases machineListUpdateRebuildIterate_bound word iterations with + ⟨hdecomp, hprefix, houtput, hbound⟩ + rw [hdecomp] + simp only [machineListUpdateRebuildPack, machineListUpdateRebuildWidth, + pair_length] + omega + +theorem machineListUpdateRebuildFinalState_mem_FP : + machineListUpdateRebuildFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineListUpdateRebuildStep_mem_FP + machineListUpdateRebuildInit_mem_FP machineListUpdateRuler_mem_FP + machineListUpdateRebuildWidth_mem_FP + machineListUpdateRebuildIterate_length_le_width + +theorem machineListUpdate_mem_FP : + machineListUpdate ∈ Complexity.FP := by + simpa only [machineListUpdate] using! + machineCompose_mem_FP machineListUpdateRebuildFinalState_mem_FP + machineListUpdateRebuildOutput_mem_FP + +/-! ## Exact semantics on canonical list codes -/ + +theorem binaryListCode_length_eq_sum + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) : βˆ€ xs : List Ξ±, + (binaryListCode encode xs).length = + (xs.map fun x ↦ 2 * (encode x).length + 2).sum := by + intro xs + induction xs with + | nil => simp [binaryListCode] + | cons x xs ih => + simp only [binaryListCode, pair_length, List.map_cons, List.sum_cons, ih] + +private theorem natList_sum_take_le_sum : βˆ€ (xs : List β„•) (k : β„•), + (xs.take k).sum ≀ xs.sum := by + intro xs k + induction xs generalizing k with + | nil => simp + | cons x xs ih => + cases k with + | zero => simp + | succ k => + simp only [List.take_succ_cons, List.sum_cons] + exact Nat.add_le_add_left (ih k) x + +theorem binaryListCode_take_reverse_length_le + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) (xs : List Ξ±) (k : β„•) : + (binaryListCode encode (xs.take k).reverse).length ≀ + (binaryListCode encode xs).length := by + rw [binaryListCode_length_eq_sum, binaryListCode_length_eq_sum, + List.map_reverse, List.sum_reverse, List.map_take] + exact natList_sum_take_le_sum _ _ + +theorem binaryListCode_drop_length_le + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) (xs : List Ξ±) (k : β„•) : + (binaryListCode encode (xs.drop k)).length ≀ + (binaryListCode encode xs).length := by + rw [binaryListCode_length_eq_sum, binaryListCode_length_eq_sum, + List.map_drop] + have h := congrArg List.sum + (show (xs.map fun x ↦ 2 * (encode x).length + 2).take k ++ + (xs.map fun x ↦ 2 * (encode x).length + 2).drop k = + xs.map fun x ↦ 2 * (encode x).length + 2 by + exact List.take_append_drop _ _) + simp only [List.sum_append] at h + omega + +theorem binaryListCode_element_length_le + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + {x : Ξ±} {xs : List Ξ±} (hx : x ∈ xs) : + (encode x).length ≀ (binaryListCode encode xs).length := by + induction xs with + | nil => simp at hx + | cons y ys ih => + simp only [List.mem_cons] at hx + rcases hx with rfl | hx + Β· simp only [binaryListCode, pair_length] + omega + Β· exact (ih hx).trans (by simp [binaryListCode]) + +/-- Encodes a unary update index, replacement entry, and original list. -/ +def machineListUpdateCanonicalInput + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) : List Bool := + pair (List.replicate index true) + (pair (encode replacement) (binaryListCode encode xs)) + +/-- Encodes the scan after `k` entries, with the reversed prefix, remaining suffix, and residual +index. -/ +def machineListUpdateScanSemanticState + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index k : β„•) : List Bool := + let word := machineListUpdateCanonicalInput encode xs replacement index + machineListUpdateScanPack (List.replicate (index - k) true) + (binaryListCode encode (xs.take k).reverse) + (binaryListCode encode (xs.drop k)) (encode replacement) + (machineListUpdateInputBound word) + +theorem machineListUpdateScanInit_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) : + machineListUpdateScanInit + (machineListUpdateCanonicalInput encode xs replacement index) = + machineListUpdateScanSemanticState encode xs replacement index 0 := by + simp [machineListUpdateScanInit, machineListUpdateScanSemanticState, + machineListUpdateCanonicalInput, machineListUpdateRuler, + machineListUpdateData, machineListUpdatePayload, + machineListUpdateReplacement, binaryListCode] + +theorem machineListUpdateScanStep_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index k : β„•) + (hk : k < index) (hindex : index < xs.length) : + machineListUpdateScanStep + (machineListUpdateScanSemanticState + encode xs replacement index k) = + machineListUpdateScanSemanticState + encode xs replacement index (k + 1) := by + let word := machineListUpdateCanonicalInput encode xs replacement index + have hkxs : k < xs.length := hk.trans hindex + have hremain : index - k = (index - (k + 1)) + 1 := by omega + have hdrop := List.drop_eq_getElem_cons hkxs + have htake := List.take_concat_get hkxs + have hprefix : (xs.take (k + 1)).reverse = + xs[k] :: (xs.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := xs.take k) (a := xs[k])) + have hprefixLength : + (binaryListCode encode (xs.take (k + 1)).reverse).length ≀ + (machineListUpdateInputBound word).length := by + exact (binaryListCode_take_reverse_length_le encode xs (k + 1)).trans + ((show (binaryListCode encode xs).length ≀ word.length by + simp only [word, machineListUpdateCanonicalInput, pair_length] + omega).trans + (machineListUpdate_word_length_le_bound word)) + have htakeBound : + (binaryListCode encode (xs.take (k + 1)).reverse).take + (machineListUpdateInputBound word).length = + binaryListCode encode (xs.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hcurrentNonempty : + binaryListCode encode (xs.drop k) β‰  [] := by + rw [hdrop] + intro hnil + have hlen := congrArg List.length hnil + simp [binaryListCode] at hlen + have hhead : + machineListHead (binaryListCode encode (xs.drop k)) = encode xs[k] := by + rw [hdrop] + exact machineListHead_cons encode xs[k] (xs.drop (k + 1)) + have htail : + machineListTail (binaryListCode encode (xs.drop k)) = + binaryListCode encode (xs.drop (k + 1)) := by + rw [hdrop] + exact machineListTail_cons encode xs[k] (xs.drop (k + 1)) + have hnextPrefix : + (pair (machineListHead (binaryListCode encode (xs.drop k))) + (binaryListCode encode (xs.take k).reverse)).take + (machineListUpdateInputBound word).length = + binaryListCode encode (xs.take (k + 1)).reverse := by + rw [hhead] + change (binaryListCode encode + (xs[k] :: (xs.take k).reverse)).take + (machineListUpdateInputBound word).length = _ + rw [← hprefix] + exact htakeBound + rw [machineListUpdateScanStep] + simp only [machineListUpdateScanSemanticState, + machineListUpdateScanRemaining_pack, hremain, List.replicate_succ, + machineIfEmpty_cons, machineListUpdateScanCurrent_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hcurrentNonempty] + simp only [machineListUpdateScanAdvance, + machineListUpdateScanRemaining_pack, List.tail_cons, + machineListUpdateScanCurrent_pack, + machineListUpdateScanReplacement_pack, + machineListUpdateScanBound_pack, + machineListUpdateScanNextPrefix, + machineListUpdateScanPrefixCandidate, + machineListUpdateScanPrefix_pack] + rw [hnextPrefix, htail] + +theorem machineListUpdateScanIterate_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : βˆ€ k ≀ index, + (machineListUpdateScanStep)^[k] + (machineListUpdateScanInit + (machineListUpdateCanonicalInput encode xs replacement index)) = + machineListUpdateScanSemanticState + encode xs replacement index k := by + intro k hk + induction k with + | zero => exact machineListUpdateScanInit_semantics _ _ _ _ + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineListUpdateScanStep_semantics + encode xs replacement index k (by omega) hindex + +theorem machineListUpdateScanFinalState_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : + machineListUpdateScanFinalState + (machineListUpdateCanonicalInput encode xs replacement index) = + machineListUpdateScanSemanticState + encode xs replacement index index := by + rw [machineListUpdateScanFinalState] + simp only [machineListUpdateRuler, machineListUpdateCanonicalInput, + machinePairFirst_pair, List.length_replicate] + exact machineListUpdateScanIterate_semantics + encode xs replacement index hindex index le_rfl + +theorem binaryListCode_append_length + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) : βˆ€ xs ys : List Ξ±, + (binaryListCode encode (xs ++ ys)).length = + (binaryListCode encode xs).length + + (binaryListCode encode ys).length := by + intro xs ys + induction xs with + | nil => simp [binaryListCode] + | cons x xs ih => + simp only [List.cons_append, binaryListCode, pair_length, ih] + omega + +theorem machineListUpdate_double_word_length_le_bound (word : List Bool) : + 2 * word.length ≀ (machineListUpdateInputBound word).length := by + simp only [machineListUpdateInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineListUpdateSeed_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : + machineListUpdateSeed + (machineListUpdateCanonicalInput encode xs replacement index) = + binaryListCode encode (replacement :: xs.drop (index + 1)) := by + let word := machineListUpdateCanonicalInput encode xs replacement index + have hdrop := List.drop_eq_getElem_cons hindex + have hseedLength : + (binaryListCode encode (replacement :: xs.drop (index + 1))).length ≀ + (machineListUpdateInputBound word).length := by + have hdropLength := binaryListCode_drop_length_le + encode xs (index + 1) + have hword : + (binaryListCode encode + (replacement :: xs.drop (index + 1))).length ≀ word.length := by + simp only [binaryListCode, pair_length, word, + machineListUpdateCanonicalInput] + omega + exact hword.trans (machineListUpdate_word_length_le_bound word) + rw [machineListUpdateSeed, machineListUpdateScanFinalState_semantics + encode xs replacement index hindex] + simp only [machineListUpdateScanSemanticState, + machineListUpdateScanCurrent_pack, + machineListUpdateScanReplacement_pack, + machineListUpdateScanBound_pack, Nat.sub_self, + List.replicate_zero] + rw [hdrop] + rw [machineIfEmpty_of_ne_nil] + Β· rw [machineListTail_cons] + change (binaryListCode encode + (replacement :: xs.drop (index + 1))).take + (machineListUpdateInputBound word).length = _ + exact List.take_of_length_le hseedLength + Β· intro hnil + have hlen := congrArg List.length hnil + simp [binaryListCode] at hlen + +/-- Encodes reconstruction after `k` saved-prefix entries have been restored before the updated +suffix. -/ +def machineListUpdateRebuildSemanticState + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index k : β„•) : List Bool := + let word := machineListUpdateCanonicalInput encode xs replacement index + let pref := (xs.take index).reverse + let suffix := replacement :: xs.drop (index + 1) + machineListUpdateRebuildPack (binaryListCode encode (pref.drop k)) + (binaryListCode encode ((pref.take k).reverse ++ suffix)) + (machineListUpdateInputBound word) + +theorem machineListUpdateRebuildInit_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : + machineListUpdateRebuildInit + (machineListUpdateCanonicalInput encode xs replacement index) = + machineListUpdateRebuildSemanticState + encode xs replacement index 0 := by + rw [machineListUpdateRebuildInit, + machineListUpdateScanFinalState_semantics + encode xs replacement index hindex, + machineListUpdateSeed_semantics encode xs replacement index hindex] + simp [machineListUpdateRebuildSemanticState, + machineListUpdateScanSemanticState, binaryListCode] + +theorem machineListUpdateRebuildStep_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index k : β„•) + (hk : k < index) (hindex : index < xs.length) : + machineListUpdateRebuildStep + (machineListUpdateRebuildSemanticState + encode xs replacement index k) = + machineListUpdateRebuildSemanticState + encode xs replacement index (k + 1) := by + let word := machineListUpdateCanonicalInput encode xs replacement index + let pref := (xs.take index).reverse + let suffix := replacement :: xs.drop (index + 1) + have hindexLe : index ≀ xs.length := hindex.le + have hprefLength : pref.length = index := by + simp [pref, List.length_take_of_le hindexLe] + have hkPref : k < pref.length := by omega + have hdrop := List.drop_eq_getElem_cons hkPref + have htake := List.take_concat_get hkPref + have hpart : (pref.take (k + 1)).reverse = + pref[k] :: (pref.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := pref.take k) (a := pref[k])) + have hprefCodeLength : + (binaryListCode encode pref).length ≀ + (binaryListCode encode xs).length := by + simpa only [pref] using! + binaryListCode_take_reverse_length_le encode xs index + have hpartCodeLength : + (binaryListCode encode (pref.take (k + 1)).reverse).length ≀ + word.length := by + exact (binaryListCode_take_reverse_length_le encode pref (k + 1)).trans + (hprefCodeLength.trans (by + simp only [word, machineListUpdateCanonicalInput, pair_length] + omega)) + have hsuffixCodeLength : + (binaryListCode encode suffix).length ≀ word.length := by + have hdropLength := binaryListCode_drop_length_le + encode xs (index + 1) + simp only [suffix, binaryListCode, pair_length, word, + machineListUpdateCanonicalInput] + omega + have hnextLength : + (binaryListCode encode + ((pref.take (k + 1)).reverse ++ suffix)).length ≀ + (machineListUpdateInputBound word).length := by + rw [binaryListCode_append_length] + exact (Nat.add_le_add hpartCodeLength hsuffixCodeLength).trans + (by simpa [two_mul] using! + machineListUpdate_double_word_length_le_bound word) + have htakeBound : + (binaryListCode encode + ((pref.take (k + 1)).reverse ++ suffix)).take + (machineListUpdateInputBound word).length = + binaryListCode encode + ((pref.take (k + 1)).reverse ++ suffix) := + List.take_of_length_le hnextLength + have hprefNonempty : binaryListCode encode (pref.drop k) β‰  [] := by + rw [hdrop] + intro hnil + have hlen := congrArg List.length hnil + simp [binaryListCode] at hlen + have hhead : + machineListHead (binaryListCode encode (pref.drop k)) = + encode pref[k] := by + rw [hdrop] + exact machineListHead_cons encode pref[k] (pref.drop (k + 1)) + have htail : + machineListTail (binaryListCode encode (pref.drop k)) = + binaryListCode encode (pref.drop (k + 1)) := by + rw [hdrop] + exact machineListTail_cons encode pref[k] (pref.drop (k + 1)) + have hnextOutput : + (pair (machineListHead (binaryListCode encode (pref.drop k))) + (binaryListCode encode ((pref.take k).reverse ++ suffix))).take + (machineListUpdateInputBound word).length = + binaryListCode encode + ((pref.take (k + 1)).reverse ++ suffix) := by + rw [hhead] + change (binaryListCode encode + (pref[k] :: (pref.take k).reverse ++ suffix)).take + (machineListUpdateInputBound word).length = _ + rw [← hpart] + exact htakeBound + rw [machineListUpdateRebuildStep] + simp only [machineListUpdateRebuildSemanticState, + machineListUpdateRebuildPrefix_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hprefNonempty] + simp only [machineListUpdateRebuildAdvance, + machineListUpdateRebuildPrefix_pack, + machineListUpdateRebuildOutput_pack, + machineListUpdateRebuildBound_pack, + machineListUpdateRebuildNextOutput, + machineListUpdateRebuildCandidate] + rw [htail, hnextOutput] + +theorem machineListUpdateRebuildIterate_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : βˆ€ k ≀ index, + (machineListUpdateRebuildStep)^[k] + (machineListUpdateRebuildInit + (machineListUpdateCanonicalInput encode xs replacement index)) = + machineListUpdateRebuildSemanticState + encode xs replacement index k := by + intro k hk + induction k with + | zero => + simpa using! (machineListUpdateRebuildInit_semantics + encode xs replacement index hindex) + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineListUpdateRebuildStep_semantics + encode xs replacement index k (by omega) hindex + +theorem machineListUpdateRebuildFinalState_semantics + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : + machineListUpdateRebuildFinalState + (machineListUpdateCanonicalInput encode xs replacement index) = + machineListUpdateRebuildSemanticState + encode xs replacement index index := by + rw [machineListUpdateRebuildFinalState] + simp only [machineListUpdateRuler, machineListUpdateCanonicalInput, + machinePairFirst_pair, List.length_replicate] + exact machineListUpdateRebuildIterate_semantics + encode xs replacement index hindex index le_rfl + +@[simp] theorem machineListUpdate_binaryListCode + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) + (xs : List Ξ±) (replacement : Ξ±) (index : β„•) + (hindex : index < xs.length) : + machineListUpdate + (machineListUpdateCanonicalInput encode xs replacement index) = + binaryListCode encode (xs.set index replacement) := by + rw [machineListUpdate, machineListUpdateRebuildFinalState_semantics + encode xs replacement index hindex] + simp only [machineListUpdateRebuildSemanticState, + machineListUpdateRebuildOutput_pack] + have htakeLength : (xs.take index).length = index := + List.length_take_of_le hindex.le + have hprefLength : (xs.take index).reverse.length = index := by + simp [htakeLength] + have htakePref : + List.take index (xs.take index).reverse = (xs.take index).reverse := by + exact List.take_of_length_le hprefLength.le + rw [htakePref, List.reverse_reverse] + rw [List.set_eq_take_cons_drop replacement hindex] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatchingGain.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatchingGain.lean new file mode 100644 index 0000000000..05b23b2eda --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatchingGain.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineGreedyRowMatching +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateAssembly + +/-! +# Counting the selected pairs and assembling the fixed matching gain + +The matching machine returns a self-delimiting list of ordered endpoint pairs. +This module counts that list with a verified binary counter and multiplies the +count by the fixed rational gain. The counter iterates for the bit-length of +the input word and stutters after the encoded list is exhausted, so it is a +total polynomial-time string function even on malformed inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a list-count state as remaining list, binary counter, and source word. -/ +def machineListCountPack + (remaining counter source : List Bool) : List Bool := + pair remaining (pair counter source) + +/-- Extracts the unprocessed list suffix from the counting state. -/ +def machineListCountRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the binary count from the list-count state. -/ +def machineListCountCounter (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the original encoded list from the counting state. -/ +def machineListCountSource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Pairs a false bit with the source list to provide a count-state width bound. -/ +def machineListCountInputBound (word : List Bool) : List Bool := + pair [false] word + +/-- Reads the count-state bound derived from the original list. -/ +def machineListCountBound (state : List Bool) : List Bool := + machineListCountInputBound (machineListCountSource state) + +/-- Increments the binary count and truncates it to the source-derived width bound. -/ +def machineListCountNextCounter (state : List Bool) : List Bool := + (machineBinaryAddBits + (pair (machineListCountCounter state) [true])).take + (machineListCountBound state).length + +/-- Consumes one encoded list entry and updates the bounded count. -/ +def machineListCountProcess (state : List Bool) : List Bool := + machineListCountPack + (machineListTail (machineListCountRemaining state)) + (machineListCountNextCounter state) + (machineListCountSource state) + +/-- Counts the next entry, leaving an exhausted list-count state fixed. -/ +def machineListCountStep (state : List Bool) : List Bool := + machineIfEmpty (machineListCountRemaining state) state + (machineListCountProcess state) + +/-- Initializes list counting with the entire input list and a zero counter. -/ +def machineListCountInit (word : List Bool) : List Bool := + machineListCountPack word [] word + +/-- Packs three copies of the source-derived bound to bound the full counting state. -/ +def machineListCountWidth (word : List Bool) : List Bool := + let bound := machineListCountInputBound word + machineListCountPack bound bound bound + +/-- Counts encoded list entries using at most one step per input bit and returns the binary +count. -/ +def machineEncodedListLengthBits (word : List Bool) : List Bool := + machineListCountCounter + ((machineListCountStep)^[word.length] (machineListCountInit word)) + +theorem machineListCountRemaining_mem_FP : + machineListCountRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineListCountCounter_mem_FP : + machineListCountCounter ∈ FP := by + simpa only [machineListCountCounter] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineListCountSource_mem_FP : + machineListCountSource ∈ FP := by + simpa only [machineListCountSource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineListCountInputBound_mem_FP : + machineListCountInputBound ∈ FP := + machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP + +theorem machineListCountBound_mem_FP : + machineListCountBound ∈ FP := by + simpa only [machineListCountBound] using! machineCompose_mem_FP + machineListCountSource_mem_FP machineListCountInputBound_mem_FP + +theorem machineListCountNextCounter_mem_FP : + machineListCountNextCounter ∈ FP := by + have hinput := machinePair_mem_FP machineListCountCounter_mem_FP + (machineConst_mem_FP [true]) + have hadd := machineCompose_mem_FP hinput machineBinaryAddBits_mem_FP + simpa only [machineListCountNextCounter] using! + machineTake_mem_FP machineListCountBound_mem_FP hadd + +theorem machineListCountProcess_mem_FP : + machineListCountProcess ∈ FP := by + have htail := machineCompose_mem_FP machineListCountRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineListCountNextCounter_mem_FP + machineListCountSource_mem_FP) + +theorem machineListCountStep_mem_FP : + machineListCountStep ∈ FP := by + simpa only [machineListCountStep] using! machineIfEmpty_mem_FP + machineListCountRemaining_mem_FP id_mem_FP machineListCountProcess_mem_FP + +theorem machineListCountInit_mem_FP : + machineListCountInit ∈ FP := + machinePair_mem_FP id_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP) + +theorem machineListCountWidth_mem_FP : + machineListCountWidth ∈ FP := + machinePair_mem_FP machineListCountInputBound_mem_FP + (machinePair_mem_FP machineListCountInputBound_mem_FP + machineListCountInputBound_mem_FP) + +@[simp] theorem machineListCountRemaining_pack (remaining counter source) : + machineListCountRemaining + (machineListCountPack remaining counter source) = remaining := by + simp [machineListCountRemaining, machineListCountPack] + +@[simp] theorem machineListCountCounter_pack (remaining counter source) : + machineListCountCounter + (machineListCountPack remaining counter source) = counter := by + simp [machineListCountCounter, machineListCountPack] + +@[simp] theorem machineListCountSource_pack (remaining counter source) : + machineListCountSource + (machineListCountPack remaining counter source) = source := by + simp [machineListCountSource, machineListCountPack] + +/-- Bounds the remaining-list and counter lengths while preserving the original encoded list. -/ +def MachineListCountStateBound (word state : List Bool) : Prop := + let B := (machineListCountInputBound word).length + state = machineListCountPack (machineListCountRemaining state) + (machineListCountCounter state) (machineListCountSource state) ∧ + (machineListCountRemaining state).length ≀ B ∧ + (machineListCountCounter state).length ≀ B ∧ + machineListCountSource state = word + +theorem machineListCount_word_le_bound (word : List Bool) : + word.length ≀ (machineListCountInputBound word).length := by + simp [machineListCountInputBound, pair_length] + +theorem machineListCountInit_bound (word : List Bool) : + MachineListCountStateBound word (machineListCountInit word) := by + simp only [MachineListCountStateBound, machineListCountInit, + machineListCountRemaining_pack, machineListCountCounter_pack, + machineListCountSource_pack, List.length_nil] + exact ⟨trivial, machineListCount_word_le_bound word, + Nat.zero_le _, trivial⟩ + +theorem machineListCountStep_bound {word state : List Bool} + (hstate : MachineListCountStateBound word state) : + MachineListCountStateBound word (machineListCountStep state) := by + rcases hstate with ⟨hpack, hremaining, hcounter, hsource⟩ + by_cases hrem : machineListCountRemaining state = [] + Β· rw [machineListCountStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hcounter, hsource⟩ + Β· rw [machineListCountStep] + cases hcode : machineListCountRemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineListCountProcess] + simp only [MachineListCountStateBound, + machineListCountRemaining_pack, machineListCountCounter_pack, + machineListCountSource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineListCountRemaining state)).trans hremaining + Β· simp only [machineListCountNextCounter, List.length_take, + machineListCountBound, hsource] + exact Nat.min_le_left _ _ + +theorem machineListCountIterate_bound (word : List Bool) : βˆ€ k, + MachineListCountStateBound word + ((machineListCountStep)^[k] (machineListCountInit word)) := by + intro k + induction k with + | zero => exact machineListCountInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineListCountStep_bound ih + +theorem machineListCountIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineListCountStep)^[iterations] + (machineListCountInit word)).length ≀ + (machineListCountWidth word).length := by + rcases machineListCountIterate_bound word iterations with + ⟨hpack, hremaining, hcounter, hsource⟩ + have hsourceLength : (machineListCountSource + ((machineListCountStep)^[iterations] + (machineListCountInit word))).length ≀ + (machineListCountInputBound word).length := by + rw [hsource] + exact machineListCount_word_le_bound word + rw [hpack] + simp only [machineListCountPack, machineListCountWidth, pair_length] + omega + +theorem machineEncodedListLengthBits_mem_FP : + machineEncodedListLengthBits ∈ FP := by + have hfinal : (fun word => + (machineListCountStep)^[word.length] + (machineListCountInit word)) ∈ FP := + Cobham.iterate_mem_FP machineListCountStep_mem_FP + machineListCountInit_mem_FP id_mem_FP machineListCountWidth_mem_FP + machineListCountIterate_length_le_width + simpa only [machineEncodedListLengthBits] using! machineCompose_mem_FP + hfinal machineListCountCounter_mem_FP + +/-! ## Exact counting semantics -/ + +/-- Encodes a counting state with suffix `xs.drop k`, counter `k`, and the original list. -/ +def machineListCountSemanticState {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) (k : β„•) : List Bool := + machineListCountPack (binaryListCode encode (xs.drop k)) k.bits + (binaryListCode encode xs) + +@[simp] theorem machineListCountSemanticState_zero {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) : + machineListCountSemanticState encode xs 0 = + machineListCountInit (binaryListCode encode xs) := by + simp [machineListCountSemanticState, machineListCountInit, + binaryListCode] + +theorem nat_succ_bits_length_le_succ (k : β„•) : + (k + 1).bits.length ≀ k + 1 := by + rw [Nat.size_eq_bits_len, Nat.size_le] + exact Nat.lt_two_pow_self + +theorem machineListCountSemanticState_step {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) + (k : β„•) (hk : k < xs.length) : + machineListCountStep (machineListCountSemanticState encode xs k) = + machineListCountSemanticState encode xs (k + 1) := by + rw [machineListCountSemanticState, List.drop_eq_getElem_cons hk, + machineListCountStep] + simp only [machineListCountRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil encode xs[k] (xs.drop (k + 1))), + machineListCountProcess] + simp only [machineListCountRemaining_pack, machineListTail_cons, + machineListCountSource_pack, machineListCountNextCounter, + machineListCountCounter_pack] + have hadd : machineBinaryAddBits (pair k.bits [true]) = (k + 1).bits := by + simpa using! machineBinaryAddBits_pair_natBits k 1 + rw [hadd] + have hbits : (k + 1).bits.length ≀ + (machineListCountInputBound (binaryListCode encode xs)).length := by + calc + _ ≀ k + 1 := nat_succ_bits_length_le_succ k + _ ≀ xs.length := by omega + _ ≀ (binaryListCode encode xs).length := + binaryListCode_listLength_le encode xs + _ ≀ _ := machineListCount_word_le_bound _ + rw [machineListCountBound, machineListCountSource_pack, + (List.take_eq_self_iff _).2 hbits] + rw [machineListCountSemanticState] + +theorem machineListCountIterate_semantics {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) : βˆ€ k ≀ xs.length, + (machineListCountStep)^[k] + (machineListCountInit (binaryListCode encode xs)) = + machineListCountSemanticState encode xs k := by + intro k hk + induction k with + | zero => exact (machineListCountSemanticState_zero encode xs).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineListCountSemanticState_step encode xs k (by omega) + +theorem machineListCount_done_iterate + (extra : β„•) (counter source : List Bool) : + (machineListCountStep)^[extra] + (machineListCountPack [] counter source) = + machineListCountPack [] counter source := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineListCountStep] + +@[simp] theorem machineEncodedListLengthBits_encode {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) : + machineEncodedListLengthBits (binaryListCode encode xs) = xs.length.bits := by + rw [machineEncodedListLengthBits] + let word := binaryListCode encode xs + have hle : xs.length ≀ word.length := + binaryListCode_listLength_le encode xs + have hsplit : word.length = (word.length - xs.length) + xs.length := by + omega + rw [hsplit, Function.iterate_add_apply, + machineListCountIterate_semantics encode xs xs.length le_rfl] + simp only [machineListCountSemanticState, List.drop_length] + change machineListCountCounter + ((machineListCountStep)^[word.length - xs.length] + (machineListCountPack [] xs.length.bits + (binaryListCode encode xs))) = xs.length.bits + rw [machineListCount_done_iterate] + simp only [machineListCountCounter_pack] + +/-! ## Fixed-gain assembly -/ + +/-- Encodes the computed list length as a nonnegative raw rational with denominator one. -/ +def machineListCountRawNatCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineEncodedListLengthBits word)) [true] + +/-- The raw-rational representation of the fixed matching-gain coefficient `explicitGamma`. -/ +def rawExplicitGamma : RawRat := rawRatOfRat explicitGamma + +/-- Multiplies the selected-pair count by `explicitGamma` and normalizes the resulting rational +entry. -/ +def machineMatchingGainFromSelected (selectedWord : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRawRatMulCode + (pair (rawRatBinaryCode rawExplicitGamma) + (machineListCountRawNatCode selectedWord))) + +/-- Computes the explicit matching gain from the greedy selection in the input's second +component. -/ +def machineExplicitMatchingGainRawCode (word : List Bool) : List Bool := + machineMatchingGainFromSelected + (machineGreedyMatchingSelected (machinePairSecond word)) + +theorem machineListCountRawNatCode_mem_FP : + machineListCountRawNatCode ∈ FP := by + have hnum := machineCompose_mem_FP machineEncodedListLengthBits_mem_FP + machineNaturalIntegerCode_mem_FP + exact machinePair_mem_FP hnum (machineConst_mem_FP [true]) + +theorem machineMatchingGainFromSelected_mem_FP : + machineMatchingGainFromSelected ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawExplicitGamma)) + machineListCountRawNatCode_mem_FP + have hmul := machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + simpa only [machineMatchingGainFromSelected] using! + machineCompose_mem_FP hmul machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExplicitMatchingGainRawCode_mem_FP : + machineExplicitMatchingGainRawCode ∈ FP := by + have hselected := machineCompose_mem_FP machinePairSecond_mem_FP + machineGreedyMatchingSelected_mem_FP + simpa only [machineExplicitMatchingGainRawCode] using! machineCompose_mem_FP + hselected machineMatchingGainFromSelected_mem_FP + +@[simp] theorem machineListCountRawNatCode_encode {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) : + machineListCountRawNatCode (binaryListCode encode xs) = + rawRatBinaryCode (RawRat.ofNat xs.length) := by + rw [machineListCountRawNatCode, + machineEncodedListLengthBits_encode, + machineNaturalIntegerCode_natBits] + simp [rawRatBinaryCode, RawRat.ofNat] + +@[simp] theorem machineMatchingGainFromSelected_encode {alpha : Type*} + (encode : alpha β†’ List Bool) (xs : List alpha) : + machineMatchingGainFromSelected (binaryListCode encode xs) = + rawRatBinaryCode (rawRatOfRat + (explicitGamma * (xs.length : β„š))) := by + rw [machineMatchingGainFromSelected, + machineListCountRawNatCode_encode, machineRawRatMulCode_encode, + machineNormalizeRawRatEntryCode_encode, + ← rawRatBinaryCode_rawRatOfRat] + apply congrArg rawRatBinaryCode + apply congrArg rawRatOfRat + rw [binaryNormalizeRawRat_eq_value, RawRat.value_mul, + rawExplicitGamma, rawRatOfRat_value, RawRat.value_ofNat] + +theorem explicitCertifiedMatchingGain_eq_typed_length {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + explicitCertifiedMatchingGain X = + explicitGamma * + (certifiedGreedyTypedOuterScan X [] + (List.finRange n).reverse).length := by + let selected := certifiedGreedyTypedOuterScan X [] + (List.finRange n).reverse + have hfin := certifiedGreedyTypedOuterScan_toFinset X + have hnodup := certifiedGreedyTypedOuterScan_full_nodup X + rw [explicitCertifiedMatchingGain, greedyCertifiedMatchingGain] + rw [← hfin] + have hweight : βˆ€ q ∈ selected.toFinset, + explicitCertifiedRowWeight X q = explicitGamma := by + intro q hq + have hqmatching : q ∈ greedyThresholdRowMatching + (explicitCertifiedRowWeight X) explicitGamma := by + rw [← hfin] + exact hq + have hmax := greedyThresholdRowMatching_isMaximal + (explicitCertifiedRowWeight X) explicitGamma + have hthreshold : explicitGamma ≀ explicitCertifiedRowWeight X q := by + have hmem := hmax.subset hqmatching + simpa only [List.mem_toFinset, mem_thresholdRowPairsList_iff] using! hmem + exact certifiedConstantRowWeight_eq_gamma_of_threshold + (explicitRegularizationScale n) X explicitKappa explicitGamma + (directedPairCostPrecision n) q explicitGamma_pos hthreshold + calc + βˆ‘ q ∈ selected.toFinset, explicitCertifiedRowWeight X q = + βˆ‘ _q ∈ selected.toFinset, explicitGamma := by + exact Finset.sum_congr rfl hweight + _ = selected.toFinset.card * explicitGamma := by simp + _ = explicitGamma * selected.length := by + rw [List.toFinset_card_of_nodup hnodup] + ring + +@[simp] theorem machineExplicitMatchingGainRawCode_encode + (source : List Bool) {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineExplicitMatchingGainRawCode + (pair source (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode (rawRatOfRat (explicitCertifiedMatchingGain X)) := by + rw [machineExplicitMatchingGainRawCode, machinePairSecond_pair, + machineGreedyMatchingSelected_typed_encode, + machineMatchingGainFromSelected_encode] + simp only [List.length_map] + rw [explicitCertifiedMatchingGain_eq_typed_length] + +theorem machineExplicitMatchingGainRawCode_realizes : + OptimizerMatchingGainStringRealizes machineExplicitMatchingGainRawCode := by + intro m B + simpa only [explicitLargeOptimizerOutput] using! + machineExplicitMatchingGainRawCode_encode + (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMateAllSome.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMateAllSome.lean new file mode 100644 index 0000000000..16718d807a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMateAllSome.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineKuhnRunner +public import Mathlib.Tactic + +/-! +# Testing whether the final mate table is total + +The Kuhn machine returns a column-to-row mate table. This module scans its +self-delimiting encoding and returns one bit indicating whether every column +contains a row. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a mate-completeness scan as remaining entries, remaining ruler, and accumulated +success bit. -/ +def machineMateAllSomePack + (remaining ruler ok : List Bool) : List Bool := + pair remaining (pair ruler ok) + +/-- Extracts the unprocessed mate-vector entries. -/ +def machineMateAllSomeRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the remaining iteration ruler from the mate-completeness state. -/ +def machineMateAllSomeRulerState (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated flag that all examined mate entries are present. -/ +def machineMateAllSomeOk (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the presence bit of the current encoded mate entry. -/ +def machineMateAllSomeCurrentBit (state : List Bool) : List Bool := + machineHeadBit (machineListHead (machineMateAllSomeRemaining state)) + +/-- Consumes one mate entry and ruler bit, conjoining its presence with the accumulated flag. -/ +def machineMateAllSomeAdvance (state : List Bool) : List Bool := + machineMateAllSomePack (machineListTail (machineMateAllSomeRemaining state)) + (machineMateAllSomeRulerState state).tail + (machineAndBit (machineMateAllSomeOk state) + (machineMateAllSomeCurrentBit state)) + +/-- Checks the next mate entry, leaving states with an exhausted ruler fixed. -/ +def machineMateAllSomeStep (state : List Bool) : List Bool := + machineIfEmpty (machineMateAllSomeRulerState state) state + (machineMateAllSomeAdvance state) + +/-- Extracts the input ruler specifying how many mate entries to check. -/ +def machineMateAllSomeInputRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded mate vector from the completeness-test input. -/ +def machineMateAllSomeInputMate (word : List Bool) : List Bool := + machinePairSecond word + +/-- Initializes mate completeness checking with the supplied vector, ruler, and a true success +flag. -/ +def machineMateAllSomeInit (word : List Bool) : List Bool := + machineMateAllSomePack (machineMateAllSomeInputMate word) + (machineMateAllSomeInputRuler word) [true] + +/-- Uses the binary-multiplication width constructor to bound mate-completeness states. -/ +def machineMateAllSomeWidth (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Runs one mate-completeness step per bit of the input ruler. -/ +def machineMateAllSomeFinalState (word : List Bool) : List Bool := + (machineMateAllSomeStep^[(machineMateAllSomeInputRuler word).length]) + (machineMateAllSomeInit word) + +/-- Extracts the final flag that every ruler-selected mate entry is present. -/ +def machineMateAllSomeBit (word : List Bool) : List Bool := + machineMateAllSomeOk (machineMateAllSomeFinalState word) + +theorem machineMateAllSomeRemaining_mem_FP : + machineMateAllSomeRemaining ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineMateAllSomeRulerState_mem_FP : + machineMateAllSomeRulerState ∈ Complexity.FP := by + simpa only [machineMateAllSomeRulerState] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMateAllSomeOk_mem_FP : + machineMateAllSomeOk ∈ Complexity.FP := by + simpa only [machineMateAllSomeOk] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineMateAllSomeCurrentBit_mem_FP : + machineMateAllSomeCurrentBit ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP machineMateAllSomeRemaining_mem_FP + machineListHead_mem_FP + simpa only [machineMateAllSomeCurrentBit] using! + machineCompose_mem_FP hhead machineHeadBit_mem_FP + +theorem machineMateAllSomeAdvance_mem_FP : + machineMateAllSomeAdvance ∈ Complexity.FP := by + have hremainingTail := machineCompose_mem_FP + machineMateAllSomeRemaining_mem_FP machineListTail_mem_FP + have hrulerTail := machineCompose_mem_FP + machineMateAllSomeRulerState_mem_FP machineTail_mem_FP + have hok := machineAndBit_mem_FP machineMateAllSomeOk_mem_FP + machineMateAllSomeCurrentBit_mem_FP + exact machinePair_mem_FP hremainingTail + (machinePair_mem_FP hrulerTail hok) + +theorem machineMateAllSomeStep_mem_FP : + machineMateAllSomeStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMateAllSomeRulerState_mem_FP id_mem_FP + machineMateAllSomeAdvance_mem_FP + +theorem machineMateAllSomeInputRuler_mem_FP : + machineMateAllSomeInputRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineMateAllSomeInputMate_mem_FP : + machineMateAllSomeInputMate ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineMateAllSomeInit_mem_FP : + machineMateAllSomeInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMateAllSomeInputMate_mem_FP + (machinePair_mem_FP machineMateAllSomeInputRuler_mem_FP + (machineConst_mem_FP [true])) + +theorem machineMateAllSomeWidth_mem_FP : + machineMateAllSomeWidth ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +@[simp] theorem machineMateAllSomeRemaining_pack (a b c) : + machineMateAllSomeRemaining (machineMateAllSomePack a b c) = a := by + simp [machineMateAllSomeRemaining, machineMateAllSomePack] + +@[simp] theorem machineMateAllSomeRulerState_pack (a b c) : + machineMateAllSomeRulerState (machineMateAllSomePack a b c) = b := by + simp [machineMateAllSomeRulerState, machineMateAllSomePack] + +@[simp] theorem machineMateAllSomeOk_pack (a b c) : + machineMateAllSomeOk (machineMateAllSomePack a b c) = c := by + simp [machineMateAllSomeOk, machineMateAllSomePack] + +@[simp] theorem machineMateAllSomeCurrentBit_pack (a b c) : + machineMateAllSomeCurrentBit (machineMateAllSomePack a b c) = + machineHeadBit (machineListHead a) := by + simp [machineMateAllSomeCurrentBit] + +@[simp] theorem machineMateAllSomeCurrentBit_length (state) : + (machineMateAllSomeCurrentBit state).length = 1 := by + exact machineHeadBit_length _ + +/-- Bounds remaining mate entries, ruler length, and accumulated flag in a packed state. -/ +def MachineMateAllSomeStateBound (word state : List Bool) : Prop := + state = machineMateAllSomePack (machineMateAllSomeRemaining state) + (machineMateAllSomeRulerState state) (machineMateAllSomeOk state) ∧ + (machineMateAllSomeRemaining state).length ≀ word.length ∧ + (machineMateAllSomeRulerState state).length ≀ word.length ∧ + (machineMateAllSomeOk state).length ≀ word.length + 1 + +theorem machineMateAllSomeInit_bound (word : List Bool) : + MachineMateAllSomeStateBound word (machineMateAllSomeInit word) := by + dsimp only [MachineMateAllSomeStateBound] + refine ⟨?_, ?_, ?_, ?_⟩ + Β· simp [machineMateAllSomeInit] + Β· simpa [machineMateAllSomeInit] using! machinePairSecond_length_le word + Β· simpa [machineMateAllSomeInit] using! machinePairFirst_length_le word + Β· simp [machineMateAllSomeInit] + +theorem machineMateAllSomeStep_bound {word state : List Bool} + (hstate : MachineMateAllSomeStateBound word state) : + MachineMateAllSomeStateBound word (machineMateAllSomeStep state) := by + rcases hstate with ⟨hpack, hremaining, hruler, hok⟩ + cases hrulerEq : machineMateAllSomeRulerState state with + | nil => + rw [machineMateAllSomeStep, hrulerEq, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hruler, hok⟩ + | cons bit tail => + rw [machineMateAllSomeStep, hrulerEq, machineIfEmpty_cons, + machineMateAllSomeAdvance] + dsimp only [MachineMateAllSomeStateBound] + refine ⟨?_, ?_, ?_, ?_⟩ + Β· simp + Β· simpa only [machineMateAllSomeRemaining_pack] using! + (machinePairSecond_length_le + (machineMateAllSomeRemaining state)).trans hremaining + Β· rw [hrulerEq] at hruler + simp only [List.length_cons] at hruler + simp only [machineMateAllSomeRulerState_pack] + rw [hrulerEq] + simp only [List.tail_cons] + omega + Β· have hbit : + (machineAndBit (machineMateAllSomeOk state) + (machineMateAllSomeCurrentBit state)).length ≀ 1 := by + simpa only [machineAndBit, machineMateAllSomeCurrentBit_length, + List.length_cons, List.length_nil, Nat.zero_add, max_self] using! + machineIfHead_length_le_max (machineMateAllSomeOk state) + (machineMateAllSomeCurrentBit state) [false] + simpa only [machineMateAllSomeOk_pack] using! + hbit.trans (by omega : 1 ≀ word.length + 1) + +theorem machineMateAllSomeIterate_bound (word : List Bool) : βˆ€ iterations, + MachineMateAllSomeStateBound word + ((machineMateAllSomeStep^[iterations]) + (machineMateAllSomeInit word)) := by + intro iterations + induction iterations with + | zero => simpa using! machineMateAllSomeInit_bound word + | succ iterations ih => + rw [Function.iterate_succ_apply'] + exact machineMateAllSomeStep_bound ih + +theorem machineMateAllSomeIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_hiterations : iterations ≀ (machineMateAllSomeInputRuler word).length) : + ((machineMateAllSomeStep^[iterations]) + (machineMateAllSomeInit word)).length ≀ + (machineMateAllSomeWidth word).length := by + rcases machineMateAllSomeIterate_bound word iterations with + ⟨hpack, hremaining, hruler, hok⟩ + rw [hpack] + simp only [machineMateAllSomePack, pair_length] + simp only [machineMateAllSomeWidth, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineMateAllSomeFinalState_mem_FP : + machineMateAllSomeFinalState ∈ Complexity.FP := by + simpa only [machineMateAllSomeFinalState] using! + Cobham.iterate_mem_FP machineMateAllSomeStep_mem_FP + machineMateAllSomeInit_mem_FP machineMateAllSomeInputRuler_mem_FP + machineMateAllSomeWidth_mem_FP + machineMateAllSomeIterate_length_le_width + +theorem machineMateAllSomeBit_mem_FP : + machineMateAllSomeBit ∈ Complexity.FP := by + simpa only [machineMateAllSomeBit] using! + machineCompose_mem_FP machineMateAllSomeFinalState_mem_FP + machineMateAllSomeOk_mem_FP + +/-! ## Exact scan semantics -/ + +@[simp] theorem machineHeadBit_mateValueCode (value : Option β„•) : + machineHeadBit (mateValueCode value) = [value.isSome] := by + cases value <;> simp [machineHeadBit, mateValueCode] + +/-- Encodes the semantic state after checking `k` mates, recording whether all checked entries +are present. -/ +def mateAllSomeSemanticState (mate : List (Option β„•)) (k : β„•) : List Bool := + machineMateAllSomePack (mateVectorCode (mate.drop k)) + (List.replicate (mate.length - k) true) + [(mate.take k).all Option.isSome] + +theorem machineMateAllSomeStep_semantics + (mate : List (Option β„•)) (k : β„•) (hk : k < mate.length) : + machineMateAllSomeStep (mateAllSomeSemanticState mate k) = + mateAllSomeSemanticState mate (k + 1) := by + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hk + rw [mateAllSomeSemanticState, machineMateAllSomeStep] + simp only [machineMateAllSomeRulerState_pack] + have hremain : mate.length - k = (mate.length - (k + 1)) + 1 := by omega + rw [hremain, List.replicate_succ, machineIfEmpty_cons, + machineMateAllSomeAdvance] + simp only [machineMateAllSomeRemaining_pack, + machineMateAllSomeRulerState_pack, machineMateAllSomeOk_pack, + List.tail_cons, mateVectorCode] + rw [hdrop] + simp only [machineListTail_cons, machineMateAllSomeCurrentBit_pack, + machineListHead_cons, + machineHeadBit_mateValueCode] + rw [mateAllSomeSemanticState] + have hall : + (mate.take (k + 1)).all Option.isSome = + ((mate.take k).all Option.isSome && mate[k].isSome) := by + rw [← htake] + simp only [List.concat_eq_append, List.all_append, List.all_cons, + List.all_nil, Bool.and_true] + rw [hall] + cases (mate.take k).all Option.isSome <;> + cases mate[k].isSome <;> + simp [machineAndBit, mateVectorCode] + +theorem machineMateAllSomeIterate_semantics + (mate : List (Option β„•)) : βˆ€ k, k ≀ mate.length β†’ + (machineMateAllSomeStep^[k]) + (mateAllSomeSemanticState mate 0) = + mateAllSomeSemanticState mate k := by + intro k hk + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega), + machineMateAllSomeStep_semantics mate k (by omega)] + +@[simp] theorem machineMateAllSomeBit_encode + (mate : List (Option β„•)) : + machineMateAllSomeBit + (pair (List.replicate mate.length true) (mateVectorCode mate)) = + [mate.all Option.isSome] := by + rw [machineMateAllSomeBit, machineMateAllSomeFinalState] + simp only [machineMateAllSomeInputRuler, machinePairFirst_pair, + List.length_replicate, machineMateAllSomeInit, + machineMateAllSomeInputMate, machinePairSecond_pair] + change machineMateAllSomeOk + ((machineMateAllSomeStep^[mate.length]) + (mateAllSomeSemanticState mate 0)) = _ + rw [machineMateAllSomeIterate_semantics mate mate.length (le_rfl)] + simp [mateAllSomeSemanticState] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMateMemory.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMateMemory.lean new file mode 100644 index 0000000000..1df1111fea --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMateMemory.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanInit + +/-! +# Column-mate memory for augmenting-path matching + +One column stores either `[false]` for `none` or `true :: rowUnary` for a +matched row. The enclosing right-nested list delimits these variable-length +elements. This representation makes the old row immediately available to a +recursive augmenting-path search while retaining exact polynomial-time list +lookup and update. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes absence by a false bit and a present row by a true bit followed by its unary index. -/ +def mateValueCode : Option β„• β†’ List Bool + | none => [false] + | some row => true :: List.replicate row true + +/-- Encodes a list of optional row mates using the tagged mate-value encoding. -/ +def mateVectorCode (mate : List (Option β„•)) : List Bool := + binaryListCode mateValueCode mate + +/-- Tests for an absent mate by negating its presence bit. -/ +def machineMateValueIsNoneBit (value : List Bool) : List Bool := + machineNotBit (machineHeadBit value) + +/-- Drops the presence tag to extract the unary row index of an encoded mate. -/ +def machineMateValueRowUnary (value : List Bool) : List Bool := + value.tail + +/-- Looks up a mate-vector entry at an encoded unary index. -/ +def machineMateVectorGetAtUnary (word : List Bool) : List Bool := + machineListIndex word + +/-- Input: `pair columnUnary (pair mateValue mateVectorCode)`. -/ +def machineMateVectorUpdateAtUnary (word : List Bool) : List Bool := + machineListUpdate word + +theorem machineMateValueIsNoneBit_mem_FP : + machineMateValueIsNoneBit ∈ Complexity.FP := by + simpa only [machineMateValueIsNoneBit] using! + machineNotBit_mem_FP machineHeadBit_mem_FP + +theorem machineMateValueRowUnary_mem_FP : + machineMateValueRowUnary ∈ Complexity.FP := + machineTail_mem_FP + +theorem machineMateVectorGetAtUnary_mem_FP : + machineMateVectorGetAtUnary ∈ Complexity.FP := + machineListIndex_mem_FP + +theorem machineMateVectorUpdateAtUnary_mem_FP : + machineMateVectorUpdateAtUnary ∈ Complexity.FP := + machineListUpdate_mem_FP + +@[simp] theorem machineMateValueIsNoneBit_encode (value : Option β„•) : + machineMateValueIsNoneBit (mateValueCode value) = + [decide value.isNone] := by + cases value <;> simp [machineMateValueIsNoneBit, mateValueCode] + +@[simp] theorem machineMateValueRowUnary_some (row : β„•) : + machineMateValueRowUnary (mateValueCode (some row)) = + List.replicate row true := by + simp [machineMateValueRowUnary, mateValueCode] + +@[simp] theorem machineMateVectorGetAtUnary_encode + (mate : List (Option β„•)) (column : β„•) + (hcolumn : column < mate.length) : + machineMateVectorGetAtUnary + (pair (List.replicate column true) (mateVectorCode mate)) = + mateValueCode mate[column] := by + exact machineListIndex_binaryListCode mateValueCode mate column hcolumn + +@[simp] theorem machineMateVectorUpdateAtUnary_encode + (mate : List (Option β„•)) (column : β„•) (value : Option β„•) + (hcolumn : column < mate.length) : + machineMateVectorUpdateAtUnary + (pair (List.replicate column true) + (pair (mateValueCode value) (mateVectorCode mate))) = + mateVectorCode (mate.set column value) := by + exact machineListUpdate_binaryListCode mateValueCode mate value column hcolumn + +/-- The all-`none` mate vector is exactly the already verified false-vector +constructor. -/ +def machineEmptyMateVectorCode (ruler : List Bool) : List Bool := + machineFalseVectorCode ruler + +theorem machineEmptyMateVectorCode_mem_FP : + machineEmptyMateVectorCode ∈ Complexity.FP := + machineFalseVectorCode_mem_FP + +@[simp] theorem machineEmptyMateVectorCode_encode (n : β„•) : + machineEmptyMateVectorCode (List.replicate n true) = + mateVectorCode (List.replicate n none) := by + rw [machineEmptyMateVectorCode, machineFalseVectorCode_encode] + change binaryListCode boolElementCode (List.replicate n false) = + binaryListCode mateValueCode (List.replicate n none) + induction n with + | zero => rfl + | succ n ih => + simp only [List.replicate_succ, binaryListCode, boolElementCode, + mateValueCode, ih] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixAddDelta.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixAddDelta.lean new file mode 100644 index 0000000000..52b27f9f28 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixAddDelta.lean @@ -0,0 +1,833 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowAdd +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import Mathlib.Tactic + +/-! +# Entrywise addition of a rational matrix + +The input is `pair deltaRawCode matrixCode`. The machine adds `delta` to +every entry, preserves the matrix dimension prefix, and maps the +self-delimiting row list with the verified row-addition machine. A +polynomial clamp is present on malformed inputs and is proved inactive on +every canonical pair of a raw rational and a rational matrix. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the encoded rational increment from the matrix-addition input. -/ +def machineMatrixAddDeltaInputDelta (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded matrix from the matrix-addition input. -/ +def machineMatrixAddDeltaInputMatrix (word : List Bool) : List Bool := + machinePairSecond word + +/-- Concatenates twenty copies of the input for the matrix-addition width estimate. -/ +def machineMatrixAddDeltaPadTwenty (word : List Bool) : List Bool := + machineRationalRowAddPadSixteen word ++ + machineRationalRowAddPadFour word + +/-- A direct quadratic envelope in the original matrix-word length. Using +twenty copies before squaring avoids materializing the much larger nested +row-machine envelope used in the first implementation. -/ +def machineMatrixAddDeltaInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineMatrixAddDeltaPadTwenty word) + +/-- Encodes matrix-addition state as remaining rows, reversed output, increment, dimension, and +bound. -/ +def machineMatrixAddDeltaPack + (remaining accumulator delta dimension bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair delta (pair dimension bound))) + +/-- Extracts the unprocessed rows from a matrix-addition state. -/ +def machineMatrixAddDeltaRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reversed accumulated output rows from a matrix-addition state. -/ +def machineMatrixAddDeltaAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed rational increment from the matrix-addition state. -/ +def machineMatrixAddDeltaDelta (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the binary matrix dimension from the matrix-addition state. -/ +def machineMatrixAddDeltaDimension (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the stored width bound from the matrix-addition state. -/ +def machineMatrixAddDeltaBound (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Reads the first unprocessed row of the matrix. -/ +def machineMatrixAddDeltaCurrentRow (state : List Bool) : List Bool := + machineListHead (machineMatrixAddDeltaRemaining state) + +/-- Adds the fixed rational increment to each entry of the current row. -/ +def machineMatrixAddDeltaOutputRow (state : List Bool) : List Bool := + machineRationalRowAdd + (pair (machineMatrixAddDeltaDelta state) + (machineMatrixAddDeltaCurrentRow state)) + +/-- Prepends the incremented row to the reversed output accumulator. -/ +def machineMatrixAddDeltaCandidate (state : List Bool) : List Bool := + pair (machineMatrixAddDeltaOutputRow state) + (machineMatrixAddDeltaAccumulator state) + +/-- Truncates the candidate row accumulator to the stored width bound. -/ +def machineMatrixAddDeltaNextAccumulator (state : List Bool) : List Bool := + (machineMatrixAddDeltaCandidate state).take + (machineMatrixAddDeltaBound state).length + +/-- Consumes one row and stores its incremented output, preserving the increment, dimension, and +bound. -/ +def machineMatrixAddDeltaAdvance (state : List Bool) : List Bool := + machineMatrixAddDeltaPack + (machineListTail (machineMatrixAddDeltaRemaining state)) + (machineMatrixAddDeltaNextAccumulator state) + (machineMatrixAddDeltaDelta state) + (machineMatrixAddDeltaDimension state) + (machineMatrixAddDeltaBound state) + +/-- Processes the next matrix row, leaving exhausted matrix-addition states fixed. -/ +def machineMatrixAddDeltaStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixAddDeltaRemaining state) state + (machineMatrixAddDeltaAdvance state) + +/-- Initializes matrix addition with the source rows, empty output, increment, dimension, and +input bound. -/ +def machineMatrixAddDeltaInit (word : List Bool) : List Bool := + machineMatrixAddDeltaPack + (machineMatrixRowsWord (machineMatrixAddDeltaInputMatrix word)) [] + (machineMatrixAddDeltaInputDelta word) + (machineMatrixDimensionWord (machineMatrixAddDeltaInputMatrix word)) + (machineMatrixAddDeltaInputBound word) + +/-- Builds an encoded width envelope for the five components of a matrix-addition state. -/ +def machineMatrixAddDeltaWidth (word : List Bool) : List Bool := + machineMatrixAddDeltaPack word (machineMatrixAddDeltaInputBound word) + (machineMatrixAddDeltaInputDelta word) word + (machineMatrixAddDeltaInputBound word) + +/-- Runs matrix addition for one step per input bit. -/ +def machineMatrixAddDeltaFinalState (word : List Bool) : List Bool := + (machineMatrixAddDeltaStep)^[word.length] + (machineMatrixAddDeltaInit word) + +/-- Pairs the matrix dimension with the accumulated output rows restored to their original +order. -/ +def machineMatrixAddDeltaEntries (word : List Bool) : List Bool := + let state := machineMatrixAddDeltaFinalState word + pair (machineMatrixAddDeltaDimension state) + (machineListReverse (machineMatrixAddDeltaAccumulator state)) + +theorem machineMatrixAddDeltaPadTwenty_mem_FP : + machineMatrixAddDeltaPadTwenty ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowAddPadSixteen_mem_FP + machineRationalRowAddPadFour_mem_FP + +theorem machineMatrixAddDeltaPadTwenty_length (word : List Bool) : + (machineMatrixAddDeltaPadTwenty word).length = 20 * word.length := by + simp only [machineMatrixAddDeltaPadTwenty, List.length_append, + machineRationalRowAddPadSixteen_length, + machineRationalRowAddPadFour, + machineRationalRowAddPadTwo, List.length_append] + omega + +theorem machineMatrixAddDeltaInputBound_mem_FP : + machineMatrixAddDeltaInputBound ∈ Complexity.FP := by + simpa only [machineMatrixAddDeltaInputBound] using! + machineCompose_mem_FP machineMatrixAddDeltaPadTwenty_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineMatrixAddDeltaInputDelta_mem_FP : + machineMatrixAddDeltaInputDelta ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineMatrixAddDeltaInputMatrix_mem_FP : + machineMatrixAddDeltaInputMatrix ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineMatrixAddDeltaInputRows_mem_FP : + (fun word ↦ machineMatrixRowsWord + (machineMatrixAddDeltaInputMatrix word)) ∈ Complexity.FP := by + exact machineCompose_mem_FP machineMatrixAddDeltaInputMatrix_mem_FP + machineMatrixRowsWord_mem_FP + +theorem machineMatrixAddDeltaInputDimension_mem_FP : + (fun word ↦ machineMatrixDimensionWord + (machineMatrixAddDeltaInputMatrix word)) ∈ Complexity.FP := by + exact machineCompose_mem_FP machineMatrixAddDeltaInputMatrix_mem_FP + machineMatrixDimensionWord_mem_FP + +theorem machineMatrixAddDeltaRemaining_mem_FP : + machineMatrixAddDeltaRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineMatrixAddDeltaAccumulator_mem_FP : + machineMatrixAddDeltaAccumulator ∈ Complexity.FP := by + simpa only [machineMatrixAddDeltaAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixAddDeltaDelta_mem_FP : + machineMatrixAddDeltaDelta ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineMatrixAddDeltaDelta] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineMatrixAddDeltaDimension_mem_FP : + machineMatrixAddDeltaDimension ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineMatrixAddDeltaDimension] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineMatrixAddDeltaBound_mem_FP : + machineMatrixAddDeltaBound ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineMatrixAddDeltaBound] using! + machineCompose_mem_FP htailThree machinePairSecond_mem_FP + +theorem machineMatrixAddDeltaCurrentRow_mem_FP : + machineMatrixAddDeltaCurrentRow ∈ Complexity.FP := by + simpa only [machineMatrixAddDeltaCurrentRow] using! + machineCompose_mem_FP machineMatrixAddDeltaRemaining_mem_FP + machineListHead_mem_FP + +theorem machineMatrixAddDeltaOutputRow_mem_FP : + machineMatrixAddDeltaOutputRow ∈ Complexity.FP := by + have hinput := machinePair_mem_FP machineMatrixAddDeltaDelta_mem_FP + machineMatrixAddDeltaCurrentRow_mem_FP + simpa only [machineMatrixAddDeltaOutputRow] using! + machineCompose_mem_FP hinput machineRationalRowAdd_mem_FP + +theorem machineMatrixAddDeltaCandidate_mem_FP : + machineMatrixAddDeltaCandidate ∈ Complexity.FP := + machinePair_mem_FP machineMatrixAddDeltaOutputRow_mem_FP + machineMatrixAddDeltaAccumulator_mem_FP + +theorem machineMatrixAddDeltaNextAccumulator_mem_FP : + machineMatrixAddDeltaNextAccumulator ∈ Complexity.FP := by + simpa only [machineMatrixAddDeltaNextAccumulator] using! + machineTake_mem_FP machineMatrixAddDeltaBound_mem_FP + machineMatrixAddDeltaCandidate_mem_FP + +theorem machineMatrixAddDeltaAdvance_mem_FP : + machineMatrixAddDeltaAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixAddDeltaRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineMatrixAddDeltaNextAccumulator_mem_FP + (machinePair_mem_FP machineMatrixAddDeltaDelta_mem_FP + (machinePair_mem_FP machineMatrixAddDeltaDimension_mem_FP + machineMatrixAddDeltaBound_mem_FP))) + +theorem machineMatrixAddDeltaStep_mem_FP : + machineMatrixAddDeltaStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixAddDeltaRemaining_mem_FP + id_mem_FP machineMatrixAddDeltaAdvance_mem_FP + +theorem machineMatrixAddDeltaInit_mem_FP : + machineMatrixAddDeltaInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixAddDeltaInputRows_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineMatrixAddDeltaInputDelta_mem_FP + (machinePair_mem_FP machineMatrixAddDeltaInputDimension_mem_FP + machineMatrixAddDeltaInputBound_mem_FP))) + +theorem machineMatrixAddDeltaWidth_mem_FP : + machineMatrixAddDeltaWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineMatrixAddDeltaInputBound_mem_FP + (machinePair_mem_FP machineMatrixAddDeltaInputDelta_mem_FP + (machinePair_mem_FP id_mem_FP + machineMatrixAddDeltaInputBound_mem_FP))) + +@[simp] theorem machineMatrixAddDeltaRemaining_pack (a b c d e) : + machineMatrixAddDeltaRemaining + (machineMatrixAddDeltaPack a b c d e) = a := by + simp [machineMatrixAddDeltaRemaining, machineMatrixAddDeltaPack] + +@[simp] theorem machineMatrixAddDeltaAccumulator_pack (a b c d e) : + machineMatrixAddDeltaAccumulator + (machineMatrixAddDeltaPack a b c d e) = b := by + simp [machineMatrixAddDeltaAccumulator, machineMatrixAddDeltaPack] + +@[simp] theorem machineMatrixAddDeltaDelta_pack (a b c d e) : + machineMatrixAddDeltaDelta + (machineMatrixAddDeltaPack a b c d e) = c := by + simp [machineMatrixAddDeltaDelta, machineMatrixAddDeltaPack] + +@[simp] theorem machineMatrixAddDeltaDimension_pack (a b c d e) : + machineMatrixAddDeltaDimension + (machineMatrixAddDeltaPack a b c d e) = d := by + simp [machineMatrixAddDeltaDimension, machineMatrixAddDeltaPack] + +@[simp] theorem machineMatrixAddDeltaBound_pack (a b c d e) : + machineMatrixAddDeltaBound + (machineMatrixAddDeltaPack a b c d e) = e := by + simp [machineMatrixAddDeltaBound, machineMatrixAddDeltaPack] + +/-- Bounds matrix-addition state lengths and preserves the input increment and width bound. -/ +def MachineMatrixAddDeltaStateBound (word state : List Bool) : Prop := + state = machineMatrixAddDeltaPack + (machineMatrixAddDeltaRemaining state) + (machineMatrixAddDeltaAccumulator state) + (machineMatrixAddDeltaDelta state) + (machineMatrixAddDeltaDimension state) + (machineMatrixAddDeltaBound state) ∧ + (machineMatrixAddDeltaRemaining state).length ≀ word.length ∧ + (machineMatrixAddDeltaAccumulator state).length ≀ + (machineMatrixAddDeltaInputBound word).length ∧ + machineMatrixAddDeltaDelta state = + machineMatrixAddDeltaInputDelta word ∧ + (machineMatrixAddDeltaDimension state).length ≀ word.length ∧ + machineMatrixAddDeltaBound state = machineMatrixAddDeltaInputBound word + +theorem machineMatrixAddDeltaInit_bound (word : List Bool) : + MachineMatrixAddDeltaStateBound word (machineMatrixAddDeltaInit word) := by + simp only [MachineMatrixAddDeltaStateBound, machineMatrixAddDeltaInit, + machineMatrixAddDeltaRemaining_pack, + machineMatrixAddDeltaAccumulator_pack, + machineMatrixAddDeltaDelta_pack, + machineMatrixAddDeltaDimension_pack, + machineMatrixAddDeltaBound_pack] + refine ⟨trivial, ?_, by simp, trivial, ?_, trivial⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixAddDeltaInputMatrix word)).trans + (machinePairSecond_length_le word) + Β· exact (machinePairFirst_length_le + (machineMatrixAddDeltaInputMatrix word)).trans + (machinePairSecond_length_le word) + +theorem machineMatrixAddDeltaStep_bound {word state : List Bool} + (hstate : MachineMatrixAddDeltaStateBound word state) : + MachineMatrixAddDeltaStateBound word + (machineMatrixAddDeltaStep state) := by + rcases hstate with + ⟨hdecomp, hremaining, haccumulator, hdelta, hdimension, hbound⟩ + by_cases hnil : machineMatrixAddDeltaRemaining state = [] + Β· rw [machineMatrixAddDeltaStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, haccumulator, hdelta, hdimension, hbound⟩ + Β· rw [machineMatrixAddDeltaStep] + cases hremainingCode : machineMatrixAddDeltaRemaining state with + | nil => exact False.elim (hnil hremainingCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixAddDeltaAdvance] + simp only [MachineMatrixAddDeltaStateBound, + machineMatrixAddDeltaRemaining_pack, + machineMatrixAddDeltaAccumulator_pack, + machineMatrixAddDeltaDelta_pack, + machineMatrixAddDeltaDimension_pack, + machineMatrixAddDeltaBound_pack] + refine ⟨trivial, ?_, ?_, hdelta, hdimension, hbound⟩ + Β· exact (machineListTail_length_le + (machineMatrixAddDeltaRemaining state)).trans hremaining + Β· rw [machineMatrixAddDeltaNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineMatrixAddDeltaIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixAddDeltaStateBound word + ((machineMatrixAddDeltaStep)^[k] + (machineMatrixAddDeltaInit word)) := by + intro k + induction k with + | zero => exact machineMatrixAddDeltaInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixAddDeltaStep_bound ih + +theorem machineMatrixAddDeltaIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineMatrixAddDeltaStep)^[iterations] + (machineMatrixAddDeltaInit word)).length ≀ + (machineMatrixAddDeltaWidth word).length := by + rcases machineMatrixAddDeltaIterate_bound word iterations with + ⟨hdecomp, hremaining, haccumulator, hdelta, hdimension, hbound⟩ + rw [hdecomp, hdelta, hbound] + simp only [machineMatrixAddDeltaPack, machineMatrixAddDeltaWidth, + pair_length] + omega + +theorem machineMatrixAddDeltaFinalState_mem_FP : + machineMatrixAddDeltaFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixAddDeltaStep_mem_FP + machineMatrixAddDeltaInit_mem_FP id_mem_FP + machineMatrixAddDeltaWidth_mem_FP + machineMatrixAddDeltaIterate_length_le_width + +theorem machineMatrixAddDeltaEntries_mem_FP : + machineMatrixAddDeltaEntries ∈ Complexity.FP := by + have hdimension := machineCompose_mem_FP + machineMatrixAddDeltaFinalState_mem_FP + machineMatrixAddDeltaDimension_mem_FP + have hacc := machineCompose_mem_FP + machineMatrixAddDeltaFinalState_mem_FP + machineMatrixAddDeltaAccumulator_mem_FP + have hrows := machineCompose_mem_FP hacc machineListReverse_mem_FP + simpa only [machineMatrixAddDeltaEntries] using! + machinePair_mem_FP hdimension hrows + +/-! ## Output-size bound on canonical matrices -/ + +private theorem matrixAddDelta_natList_sum_le_length_mul + {values : List β„•} {bound : β„•} + (h : βˆ€ value ∈ values, value ≀ bound) : + values.sum ≀ values.length * bound := by + induction values with + | nil => simp + | cons value values ih => + simp only [List.sum_cons, List.length_cons] + have hvalue := h value (by simp) + have htail : βˆ€ x ∈ values, x ≀ bound := by + intro x hx + exact h x (by simp [hx]) + have hi := ih htail + calc + value + values.sum ≀ bound + values.length * bound := + Nat.add_le_add hvalue hi + _ = (values.length + 1) * bound := by ring + +private theorem matrixNonnegativeRowsWork_eq_length_add_entries : + βˆ€ rows : List (List β„š), + matrixNonnegativeRowsWork rows = + rows.length + (rows.map List.length).sum := by + intro rows + induction rows with + | nil => simp [matrixNonnegativeRowsWork] + | cons row rows ih => + simp [matrixNonnegativeRowsWork, ih] + omega + +private theorem matrixAddDelta_outputCode_length_le + (delta : RawRat) (budget : β„•) : βˆ€ rows : List (List β„š), + (βˆ€ row ∈ rows, βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).add delta))).length ≀ + 172 + 72 * budget) β†’ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.map (rationalRowAddValues delta))).length ≀ + (rows.map List.length).sum * (692 + 288 * budget) + + 2 * rows.length := by + intro rows hentry + induction rows with + | nil => simp [binaryListCode] + | cons row rows ih => + have hrowEntry : βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).add delta))).length ≀ + 172 + 72 * budget := by + intro q hq + exact hentry row (by simp) q hq + have htailEntry : βˆ€ tailRow ∈ rows, βˆ€ q ∈ tailRow, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).add delta))).length ≀ + 172 + 72 * budget := by + intro tailRow htailRow q hq + exact hentry tailRow (by simp [htailRow]) q hq + have hinner : + (binaryListCode rationalEntryBinaryCode + (rationalRowAddValues delta row)).length ≀ + row.length * (346 + 144 * budget) := by + rw [binaryListCode_length_eq_sum] + have hterm : βˆ€ value ∈ + ((rationalRowAddValues delta row).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2), + value ≀ 346 + 144 * budget := by + simp only [rationalRowAddValues, List.map_map] + intro value hvalue + rw [List.mem_map] at hvalue + rcases hvalue with ⟨q, hq, rfl⟩ + have hqBound := hrowEntry q hq + simp only [Function.comp_apply] + omega + have hsum := matrixAddDelta_natList_sum_le_length_mul hterm + simpa only [rationalRowAddValues, List.length_map] using! hsum + have htail := ih htailEntry + simp only [List.map_cons, binaryListCode, pair_length, + List.map_map, List.sum_cons, List.length_cons] at htail ⊒ + nlinarith + +theorem machineMatrixAddDelta_outputRows_length_le_bound {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : + let matrixWord := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let word := pair (rawRatBinaryCode delta) matrixWord + let output := (rationalMatrixRows A).map + (rationalRowAddValues delta) + (binaryListCode (binaryListCode rationalEntryBinaryCode) output).length ≀ + (machineMatrixAddDeltaInputBound word).length := by + dsimp only + let matrixWord := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let word := pair (rawRatBinaryCode delta) matrixWord + let rows := rationalMatrixRows A + have hrowsMatrixCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + matrixWord.length := by + calc + _ = (machineMatrixRowsWord matrixWord).length := by + simpa only [matrixWord, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ matrixWord.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le matrixWord + have hmatrixWord : matrixWord.length ≀ word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := hrowsMatrixCode.trans hmatrixWord + have hdeltaWidth : rawRatWidth delta ≀ word.length := by + have hdeltaCode : (rawRatBinaryCode delta).length ≀ word.length := by + simpa only [word, machinePairFirst_pair] using! + machinePairFirst_length_le word + exact (rawRatWidth_le_binaryCode_length delta).trans hdeltaCode + have hentry : βˆ€ row ∈ rows, βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).add delta))).length ≀ + 172 + 72 * word.length := by + intro row hrow q hq + have hqCode := binaryListCode_element_length_le + rationalEntryBinaryCode hq + have hrowCode := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hrow + have hqWidth : rawRatWidth (rawRatOfRat q) ≀ word.length := by + have hentryCode : + (rawRatBinaryCode (rawRatOfRat q)).length ≀ word.length := by + rw [rawRatBinaryCode_rawRatOfRat] + exact hqCode.trans (hrowCode.trans hrowsCode) + exact (rawRatWidth_le_binaryCode_length (rawRatOfRat q)).trans + hentryCode + have hadd := rawRatWidth_add_le (rawRatOfRat q) delta + have hnormalize := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + ((rawRatOfRat q).add delta) + omega + have houtput := matrixAddDelta_outputCode_length_le + delta word.length rows hentry + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsCode + rw [matrixNonnegativeRowsWork_eq_length_add_entries] at hwork + have hquadratic : + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (machineMatrixAddDeltaInputBound word).length := by + rw [machineMatrixAddDeltaInputBound] + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] + rw [machineMatrixAddDeltaPadTwenty_length] + have hcombined : + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (rows.length + (rows.map List.length).sum) * + (694 + 288 * word.length) := by + have hentries := Nat.mul_le_mul_left + (rows.map List.length).sum + (show 692 + 288 * word.length ≀ 694 + 288 * word.length by omega) + have hrows := Nat.mul_le_mul_left rows.length + (show 2 ≀ 694 + 288 * word.length by omega) + calc + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (rows.map List.length).sum * (694 + 288 * word.length) + + rows.length * (694 + 288 * word.length) := by + exact Nat.add_le_add hentries (by simpa [Nat.mul_comm] using! hrows) + _ = (rows.length + (rows.map List.length).sum) * + (694 + 288 * word.length) := by ring + have hlinear := Nat.mul_le_mul_right (694 + 288 * word.length) hwork + have hsquare : + word.length * (694 + 288 * word.length) ≀ + (16 + 20 * word.length) * (16 + 20 * word.length) := by + cases hword : word.length with + | zero => simp + | succ length => + have hsquareDominates : length + 1 ≀ (length + 1) * (length + 1) := by + nlinarith + nlinarith + exact hcombined.trans (hlinear.trans hsquare) + exact houtput.trans hquadratic + +/-! ## Exact semantics -/ + +/-- Adds the raw-rational increment to every entry of every supplied row. -/ +def rationalMatrixAddRows (delta : RawRat) + (rows : List (List β„š)) : List (List β„š) := + rows.map (rationalRowAddValues delta) + +/-- Encodes a square rational matrix together with the raw-rational increment to add. -/ +def machineMatrixAddDeltaCanonicalInput {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : List Bool := + pair (rawRatBinaryCode delta) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) + +/-- Encodes matrix addition after `k` rows, with untouched remaining rows and reversed processed +output. -/ +def machineMatrixAddDeltaSemanticState + (word dimension : List Bool) (delta : RawRat) + (rows : List (List β„š)) (k : β„•) : List Bool := + let output := rationalMatrixAddRows delta rows + machineMatrixAddDeltaPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) (rows.drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take k).reverse) + (rawRatBinaryCode delta) dimension + (machineMatrixAddDeltaInputBound word) + +theorem machineMatrixAddDeltaInit_encode {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : + let word := machineMatrixAddDeltaCanonicalInput delta A + machineMatrixAddDeltaInit word = + machineMatrixAddDeltaSemanticState word n.bits delta + (rationalMatrixRows A) 0 := by + dsimp only + simp only [machineMatrixAddDeltaInit, + machineMatrixAddDeltaCanonicalInput, + machineMatrixAddDeltaInputMatrix, machinePairSecond_pair, + machineMatrixAddDeltaInputDelta, machinePairFirst_pair, + machineMatrixRowsWord_encode, + machineMatrixDimensionWord_encode, + machineMatrixAddDeltaSemanticState, List.drop_zero, + List.take_zero, List.reverse_nil, binaryListCode] + +theorem machineMatrixAddDeltaOutputRow_semantics + (word dimension : List Bool) (delta : RawRat) + (rows : List (List β„š)) (k : β„•) (hk : k < rows.length) : + machineMatrixAddDeltaOutputRow + (machineMatrixAddDeltaSemanticState word dimension delta rows k) = + binaryListCode rationalEntryBinaryCode + (rationalRowAddValues delta rows[k]) := by + have hdrop := List.drop_eq_getElem_cons hk + rw [machineMatrixAddDeltaOutputRow] + simp only [machineMatrixAddDeltaSemanticState, + machineMatrixAddDeltaDelta_pack, + machineMatrixAddDeltaCurrentRow, + machineMatrixAddDeltaRemaining_pack, hdrop, + machineListHead_cons] + change machineRationalRowAdd + (machineRationalRowAddCanonicalInput delta rows[k]) = _ + exact machineRationalRowAdd_encode delta rows[k] + +theorem machineMatrixAddDeltaStep_semantics + (word dimension : List Bool) (delta : RawRat) + (rows : List (List β„š)) (k : β„•) (hk : k < rows.length) + (hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixAddRows delta rows)).length ≀ + (machineMatrixAddDeltaInputBound word).length) : + machineMatrixAddDeltaStep + (machineMatrixAddDeltaSemanticState word dimension delta rows k) = + machineMatrixAddDeltaSemanticState word dimension delta rows (k + 1) := by + let output := rationalMatrixAddRows delta rows + have houtputLength : output.length = rows.length := by + simp [output, rationalMatrixAddRows] + have hkoutput : k < output.length := by omega + have houtputGet : output[k] = + rationalRowAddValues delta rows[k] := by + simp [output, rationalMatrixAddRows, List.getElem_map] + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hkoutput + have hprefix : (output.take (k + 1)).reverse = + output[k] :: (output.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := output.take k) (a := output[k])) + have hprefixLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse).length ≀ + (machineMatrixAddDeltaInputBound word).length := + (binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) output (k + 1)).trans + (by simpa only [output] using! hfullBound) + have htakeBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse).take + (machineMatrixAddDeltaInputBound word).length = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hnonempty : + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil _ _ _ + rw [machineMatrixAddDeltaStep] + simp only [machineMatrixAddDeltaSemanticState, + machineMatrixAddDeltaRemaining_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hnonempty, + machineMatrixAddDeltaAdvance] + simp only [machineMatrixAddDeltaRemaining_pack, + machineMatrixAddDeltaAccumulator_pack, + machineMatrixAddDeltaDelta_pack, + machineMatrixAddDeltaDimension_pack, + machineMatrixAddDeltaBound_pack, + machineMatrixAddDeltaNextAccumulator, + machineMatrixAddDeltaCandidate] + have hrow : + machineMatrixAddDeltaOutputRow + (machineMatrixAddDeltaPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take k).reverse) + (rawRatBinaryCode delta) dimension + (machineMatrixAddDeltaInputBound word)) = + binaryListCode rationalEntryBinaryCode output[k] := by + rw [houtputGet] + simpa only [machineMatrixAddDeltaSemanticState, output] using! + machineMatrixAddDeltaOutputRow_semantics + word dimension delta rows k hk + rw [hrow, hdrop, machineListTail_cons] + change machineMatrixAddDeltaPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop (k + 1))) + ((binaryListCode (binaryListCode rationalEntryBinaryCode) + (output[k] :: (output.take k).reverse)).take + (machineMatrixAddDeltaInputBound word).length) + (rawRatBinaryCode delta) dimension + (machineMatrixAddDeltaInputBound word) = _ + rw [← hprefix, htakeBound] + +theorem machineMatrixAddDeltaIterate_semantics + (word dimension : List Bool) (delta : RawRat) + (rows : List (List β„š)) + (hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixAddRows delta rows)).length ≀ + (machineMatrixAddDeltaInputBound word).length) : βˆ€ k ≀ rows.length, + (machineMatrixAddDeltaStep)^[k] + (machineMatrixAddDeltaSemanticState word dimension delta rows 0) = + machineMatrixAddDeltaSemanticState word dimension delta rows k := by + intro k hk + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineMatrixAddDeltaStep_semantics word dimension delta rows k + (by omega) hfullBound + +theorem machineMatrixAddDelta_done_iterate + (extra : β„•) (accumulator delta dimension bound : List Bool) : + (machineMatrixAddDeltaStep)^[extra] + (machineMatrixAddDeltaPack [] accumulator delta dimension bound) = + machineMatrixAddDeltaPack [] accumulator delta dimension bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineMatrixAddDeltaStep] + +theorem machineMatrixAddDeltaFinalState_encode {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : + let word := machineMatrixAddDeltaCanonicalInput delta A + let rows := rationalMatrixRows A + machineMatrixAddDeltaFinalState word = + machineMatrixAddDeltaPack [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixAddRows delta rows).reverse) + (rawRatBinaryCode delta) n.bits + (machineMatrixAddDeltaInputBound word) := by + dsimp only + let word := machineMatrixAddDeltaCanonicalInput delta A + let matrixWord := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let rows := rationalMatrixRows A + have hrowsLength : rows.length ≀ word.length := by + have hn : rows.length ≀ matrixWord.length := by + simpa only [rows, matrixWord, rationalMatrixRows, List.length_ofFn] using! + matrix_dimension_le_code_length A + have hm : matrixWord.length ≀ word.length := by + simpa only [word, machineMatrixAddDeltaCanonicalInput, + machinePairSecond_pair] using! machinePairSecond_length_le word + exact hn.trans hm + have hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixAddRows delta rows)).length ≀ + (machineMatrixAddDeltaInputBound word).length := by + simpa only [word, rows, machineMatrixAddDeltaCanonicalInput, + rationalMatrixAddRows] using! + machineMatrixAddDelta_outputRows_length_le_bound delta A + have hsplit : word.length = + (word.length - rows.length) + rows.length := by omega + have htakeAll : + (rationalMatrixAddRows delta rows).take rows.length = + rationalMatrixAddRows delta rows := by + have hlength : (rationalMatrixAddRows delta rows).length = + rows.length := by simp [rationalMatrixAddRows] + rw [← hlength, List.take_length] + change (machineMatrixAddDeltaStep)^[word.length] + (machineMatrixAddDeltaInit word) = _ + rw [hsplit, Function.iterate_add_apply, + machineMatrixAddDeltaInit_encode delta A, + machineMatrixAddDeltaIterate_semantics word n.bits delta rows + hfullBound rows.length le_rfl] + simp only [machineMatrixAddDeltaSemanticState, List.drop_length, + binaryListCode] + rw [htakeAll, machineMatrixAddDelta_done_iterate] + +/-- Adds `delta.value` to every entry of a square rational matrix. -/ +def rationalMatrixAddDeltaSemantic {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (delta : RawRat) : + Matrix (Fin n) (Fin n) β„š := + fun i j ↦ A i j + delta.value + +theorem rationalMatrixAddRows_semantics {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : + rationalMatrixAddRows delta (rationalMatrixRows A) = + rationalMatrixRows (rationalMatrixAddDeltaSemantic A delta) := by + apply List.ext_get + Β· simp [rationalMatrixAddRows, rationalMatrixRows] + Β· intro i hi hi' + apply List.ext_get + Β· simp [rationalMatrixAddRows, rationalRowAddValues, + rationalMatrixRows] + Β· intro j hj hj' + simp [rationalMatrixAddRows, rationalRowAddValues, + rationalMatrixRows, rationalMatrixAddDeltaSemantic, + binaryNormalizeRawRat_eq_value, RawRat.value_add, + rawRatOfRat_value] + +@[simp] theorem machineMatrixAddDeltaEntries_encode {n : β„•} + (delta : RawRat) (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixAddDeltaEntries + (machineMatrixAddDeltaCanonicalInput delta A) = + rationalMatrixBinaryEncoding.encode + ⟨n, rationalMatrixAddDeltaSemantic A delta⟩ := by + let rows := rationalMatrixRows A + rw [machineMatrixAddDeltaEntries, + machineMatrixAddDeltaFinalState_encode delta A] + simp only [machineMatrixAddDeltaDimension_pack, + machineMatrixAddDeltaAccumulator_pack, + machineListReverse_encode, List.reverse_reverse] + rw [rationalMatrixAddRows_semantics delta A] + rfl + +@[simp] theorem machineMatrixAddDeltaEntries_rational {n : β„•} + (delta : β„š) (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixAddDeltaEntries + (pair (rawRatBinaryCode (rawRatOfRat delta)) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalMatrixBinaryEncoding.encode + ⟨n, fun i j ↦ A i j + delta⟩ := by + rw [show pair (rawRatBinaryCode (rawRatOfRat delta)) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + machineMatrixAddDeltaCanonicalInput (rawRatOfRat delta) A from rfl, + machineMatrixAddDeltaEntries_encode] + congr 2 + funext i j + simp [rationalMatrixAddDeltaSemantic] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixDimension.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixDimension.lean new file mode 100644 index 0000000000..b87993ebc7 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixDimension.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary + +/-! +# A guarded unary dimension ruler + +Several bounded loops execute once per row or column. The binary dimension +cannot be expanded to unary on arbitrary strings, so the entire matrix word is +used as an explicit guard. Canonical square-matrix encodings are long enough +to make this guard inactive. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Converts the encoded binary matrix dimension to a unary ruler bounded by the input length. -/ +def machineMatrixDimensionUnary (word : List Bool) : List Bool := + machineBoundedUnary (pair word (machineMatrixDimensionWord word)) + +theorem machineMatrixDimensionUnary_mem_FP : + machineMatrixDimensionUnary ∈ Complexity.FP := by + have hpair := machinePair_mem_FP id_mem_FP + machineMatrixDimensionWord_mem_FP + simpa only [machineMatrixDimensionUnary] using! + machineCompose_mem_FP hpair machineBoundedUnary_mem_FP + +theorem list_length_le_binaryListCode_length {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) : βˆ€ xs : List Ξ±, + xs.length ≀ (binaryListCode encode xs).length := by + intro xs + induction xs with + | nil => simp [binaryListCode] + | cons x xs ih => + simp only [List.length_cons, binaryListCode, pair_length] + omega + +theorem matrix_dimension_le_code_length {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + n ≀ (rationalMatrixBinaryEncoding.encode ⟨n, A⟩).length := by + have hlist : n ≀ (rationalMatrixRows A).length := by + simp [rationalMatrixRows] + have hrows := list_length_le_binaryListCode_length + (binaryListCode rationalEntryBinaryCode) (rationalMatrixRows A) + have hcode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length ≀ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩).length := by + calc + _ = (machineMatrixRowsWord + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + simpa using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ _ := by + simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) + exact hlist.trans (hrows.trans hcode) + +@[simp] theorem machineMatrixDimensionUnary_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixDimensionUnary + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate n true := by + rw [machineMatrixDimensionUnary, machineMatrixDimensionWord_encode, + machineBoundedUnary_encode_of_le] + exact matrix_dimension_le_code_length A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNonnegative.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNonnegative.lean new file mode 100644 index 0000000000..9963c4d610 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNonnegative.lean @@ -0,0 +1,499 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds + +/-! +# Polynomial-time matrix nonnegativity guard + +The public matrix encoding is a pair containing a right-nested list of rows, +each itself a right-nested list of rational entries. This file scans that +encoding directly. The scan never decodes a binary dimension into unary and +never invokes Lean's decision procedure on the typed matrix. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a nonnegativity scan as remaining rows, current row, and accumulated success flag. -/ +def machineMatrixNonnegativePack + (rows current ok : List Bool) : List Bool := + pair rows (pair current ok) + +/-- Extracts the rows still to be loaded by the nonnegativity scan. -/ +def machineMatrixNonnegativeRows (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed suffix of the current row. -/ +def machineMatrixNonnegativeCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated nonnegativity flag. -/ +def machineMatrixNonnegativeOk (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the next rational entry of the current row. -/ +def machineMatrixNonnegativeEntry (state : List Bool) : List Bool := + machineListHead (machineMatrixNonnegativeCurrent state) + +/-- Tests whether the current encoded rational matrix entry is at least zero. -/ +def machineMatrixNonnegativeEntryBit (state : List Bool) : List Bool := + machineHeadBit + (machineRawRatLeBit + (pair (rawRatBinaryCode RawRat.zero) + (machineMatrixNonnegativeEntry state))) + +/-- Consumes one entry and conjoins its nonnegativity test with the accumulated flag. -/ +def machineMatrixNonnegativeProcessEntry (state : List Bool) : List Bool := + machineMatrixNonnegativePack + (machineMatrixNonnegativeRows state) + (machineListTail (machineMatrixNonnegativeCurrent state)) + (machineAndBit (machineMatrixNonnegativeOk state) + (machineMatrixNonnegativeEntryBit state)) + +/-- Loads the next row while preserving the accumulated nonnegativity flag. -/ +def machineMatrixNonnegativeLoadRow (state : List Bool) : List Bool := + machineMatrixNonnegativePack + (machineListTail (machineMatrixNonnegativeRows state)) + (machineListHead (machineMatrixNonnegativeRows state)) + (machineMatrixNonnegativeOk state) + +/-- Loads another row when available, otherwise retaining the completed scan state. -/ +def machineMatrixNonnegativeAfterRow (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixNonnegativeRows state) state + (machineMatrixNonnegativeLoadRow state) + +/-- Checks the next entry or loads a new row when the current row is exhausted. -/ +def machineMatrixNonnegativeStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixNonnegativeCurrent state) + (machineMatrixNonnegativeAfterRow state) + (machineMatrixNonnegativeProcessEntry state) + +/-- Initializes the nonnegativity scan with all matrix rows and a true success flag. -/ +def machineMatrixNonnegativeInit (word : List Bool) : List Bool := + machineMatrixNonnegativePack (machineMatrixRowsWord word) [] [true] + +/-- Builds a width envelope for remaining rows, current row, and the one-bit success flag. -/ +def machineMatrixNonnegativeWidth (word : List Bool) : List Bool := + machineMatrixNonnegativePack word word [true] + +/-- Runs the matrix nonnegativity scan for one step per input bit. -/ +def machineMatrixNonnegativeFinalState (word : List Bool) : List Bool := + (machineMatrixNonnegativeStep)^[word.length] + (machineMatrixNonnegativeInit word) + +/-- One-bit result of the direct nested-list scan. -/ +def machineMatrixNonnegativeBit (word : List Bool) : List Bool := + machineMatrixNonnegativeOk (machineMatrixNonnegativeFinalState word) + +theorem machineMatrixNonnegativeRows_mem_FP : + machineMatrixNonnegativeRows ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineMatrixNonnegativeCurrent_mem_FP : + machineMatrixNonnegativeCurrent ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeCurrent] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixNonnegativeOk_mem_FP : + machineMatrixNonnegativeOk ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeOk] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineMatrixNonnegativeEntry_mem_FP : + machineMatrixNonnegativeEntry ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeEntry, machineListHead] using! + machineCompose_mem_FP machineMatrixNonnegativeCurrent_mem_FP + machinePairFirst_mem_FP + +theorem machineMatrixNonnegativeEntryBit_mem_FP : + machineMatrixNonnegativeEntryBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineMatrixNonnegativeEntry_mem_FP + simpa only [machineMatrixNonnegativeEntryBit] using! + machineCompose_mem_FP + (machineCompose_mem_FP hpair machineRawRatLeBit_mem_FP) + machineHeadBit_mem_FP + +theorem machineMatrixNonnegativeProcessEntry_mem_FP : + machineMatrixNonnegativeProcessEntry ∈ Complexity.FP := by + have htail := machineCompose_mem_FP + machineMatrixNonnegativeCurrent_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP machineMatrixNonnegativeRows_mem_FP + (machinePair_mem_FP htail + (machineAndBit_mem_FP machineMatrixNonnegativeOk_mem_FP + machineMatrixNonnegativeEntryBit_mem_FP)) + +theorem machineMatrixNonnegativeLoadRow_mem_FP : + machineMatrixNonnegativeLoadRow ∈ Complexity.FP := by + have htail := machineCompose_mem_FP + machineMatrixNonnegativeRows_mem_FP machineListTail_mem_FP + have hhead := machineCompose_mem_FP + machineMatrixNonnegativeRows_mem_FP machineListHead_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP hhead machineMatrixNonnegativeOk_mem_FP) + +theorem machineMatrixNonnegativeAfterRow_mem_FP : + machineMatrixNonnegativeAfterRow ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeAfterRow] using! + machineIfEmpty_mem_FP machineMatrixNonnegativeRows_mem_FP id_mem_FP + machineMatrixNonnegativeLoadRow_mem_FP + +theorem machineMatrixNonnegativeStep_mem_FP : + machineMatrixNonnegativeStep ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeStep] using! + machineIfEmpty_mem_FP machineMatrixNonnegativeCurrent_mem_FP + machineMatrixNonnegativeAfterRow_mem_FP + machineMatrixNonnegativeProcessEntry_mem_FP + +theorem machineMatrixNonnegativeInit_mem_FP : + machineMatrixNonnegativeInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machineConst_mem_FP [true])) + +theorem machineMatrixNonnegativeWidth_mem_FP : + machineMatrixNonnegativeWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP (machineConst_mem_FP [true])) + +@[simp] theorem machineMatrixNonnegativeRows_pack (rows current ok) : + machineMatrixNonnegativeRows + (machineMatrixNonnegativePack rows current ok) = rows := by + simp [machineMatrixNonnegativeRows, machineMatrixNonnegativePack] + +@[simp] theorem machineMatrixNonnegativeCurrent_pack (rows current ok) : + machineMatrixNonnegativeCurrent + (machineMatrixNonnegativePack rows current ok) = current := by + simp [machineMatrixNonnegativeCurrent, machineMatrixNonnegativePack] + +@[simp] theorem machineMatrixNonnegativeOk_pack (rows current ok) : + machineMatrixNonnegativeOk + (machineMatrixNonnegativePack rows current ok) = ok := by + simp [machineMatrixNonnegativeOk, machineMatrixNonnegativePack] + +/-- Bounds the remaining-row and current-row lengths and the one-bit success flag. -/ +def MachineMatrixNonnegativeStateBound + (word state : List Bool) : Prop := + state = machineMatrixNonnegativePack + (machineMatrixNonnegativeRows state) + (machineMatrixNonnegativeCurrent state) + (machineMatrixNonnegativeOk state) ∧ + (machineMatrixNonnegativeRows state).length ≀ word.length ∧ + (machineMatrixNonnegativeCurrent state).length ≀ word.length ∧ + (machineMatrixNonnegativeOk state).length ≀ 1 + +theorem machineMatrixNonnegativeInit_bound (word : List Bool) : + MachineMatrixNonnegativeStateBound word + (machineMatrixNonnegativeInit word) := by + simp only [MachineMatrixNonnegativeStateBound, + machineMatrixNonnegativeInit, machineMatrixNonnegativeRows_pack, + machineMatrixNonnegativeCurrent_pack, machineMatrixNonnegativeOk_pack] + refine ⟨trivial, ?_, by simp, by simp⟩ + simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le word + +theorem machineMatrixNonnegativeStep_bound + {word state : List Bool} + (hstate : MachineMatrixNonnegativeStateBound word state) : + MachineMatrixNonnegativeStateBound word + (machineMatrixNonnegativeStep state) := by + rcases hstate with ⟨hdecomp, hrows, hcurrent, hok⟩ + by_cases hc : machineMatrixNonnegativeCurrent state = [] + Β· rw [machineMatrixNonnegativeStep, hc, machineIfEmpty_nil] + by_cases hr : machineMatrixNonnegativeRows state = [] + Β· rw [machineMatrixNonnegativeAfterRow, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hrows, hcurrent, hok⟩ + Β· rw [machineMatrixNonnegativeAfterRow] + cases hrowsCode : machineMatrixNonnegativeRows state with + | nil => exact False.elim (hr hrowsCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixNonnegativeLoadRow] + simp only [MachineMatrixNonnegativeStateBound, + machineMatrixNonnegativeRows_pack, + machineMatrixNonnegativeCurrent_pack, + machineMatrixNonnegativeOk_pack] + refine ⟨trivial, ?_, ?_, hok⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixNonnegativeRows state)).trans hrows + Β· exact (machinePairFirst_length_le + (machineMatrixNonnegativeRows state)).trans hrows + Β· rw [machineMatrixNonnegativeStep] + cases hcurrentCode : machineMatrixNonnegativeCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixNonnegativeProcessEntry] + simp only [MachineMatrixNonnegativeStateBound, + machineMatrixNonnegativeRows_pack, + machineMatrixNonnegativeCurrent_pack, + machineMatrixNonnegativeOk_pack] + refine ⟨trivial, hrows, ?_, ?_⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixNonnegativeCurrent state)).trans hcurrent + Β· change (machineIfHead (machineMatrixNonnegativeOk state) + (machineMatrixNonnegativeEntryBit state) [false]).length ≀ 1 + cases hokCode : machineMatrixNonnegativeOk state with + | nil => simp [machineIfHead, Cobham.selectHead] + | cons bit tail => + cases bit <;> + simp [machineIfHead, Cobham.selectHead, + machineMatrixNonnegativeEntryBit] + +theorem machineMatrixNonnegativeIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixNonnegativeStateBound word + ((machineMatrixNonnegativeStep)^[k] + (machineMatrixNonnegativeInit word)) := by + intro k + induction k with + | zero => exact machineMatrixNonnegativeInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixNonnegativeStep_bound ih + +theorem machineMatrixNonnegativeIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineMatrixNonnegativeStep)^[iterations] + (machineMatrixNonnegativeInit word)).length ≀ + (machineMatrixNonnegativeWidth word).length := by + rcases machineMatrixNonnegativeIterate_bound word iterations with + ⟨hdecomp, hrows, hcurrent, hok⟩ + rw [hdecomp] + simp only [machineMatrixNonnegativePack, + machineMatrixNonnegativeWidth, pair_length, List.length_cons, + List.length_nil] + omega + +theorem machineMatrixNonnegativeFinalState_mem_FP : + machineMatrixNonnegativeFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixNonnegativeStep_mem_FP + machineMatrixNonnegativeInit_mem_FP id_mem_FP + machineMatrixNonnegativeWidth_mem_FP + machineMatrixNonnegativeIterate_length_le_width + +theorem machineMatrixNonnegativeBit_mem_FP : + machineMatrixNonnegativeBit ∈ Complexity.FP := by + simpa only [machineMatrixNonnegativeBit] using! + machineCompose_mem_FP machineMatrixNonnegativeFinalState_mem_FP + machineMatrixNonnegativeOk_mem_FP + +/-! ## Exact semantics on canonical nested-list encodings -/ + +/-- The Boolean test that a rational number is nonnegative. -/ +def rationalNonnegativeBit (q : β„š) : Bool := decide (0 ≀ q) + +theorem machineIfEmpty_of_ne_nil_matrix + (test whenEmpty whenNonempty : List Bool) (h : test β‰  []) : + machineIfEmpty test whenEmpty whenNonempty = whenNonempty := by + cases test with + | nil => exact False.elim (h rfl) + | cons bit tail => simp + +theorem binaryListCode_cons_ne_nil {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) (x : Ξ±) (xs : List Ξ±) : + binaryListCode encode (x :: xs) β‰  [] := by + intro h + have hlen := congrArg List.length h + simp [binaryListCode] at hlen + +@[simp] theorem rawRatBinaryCode_rawRatOfRat (q : β„š) : + rawRatBinaryCode (rawRatOfRat q) = rationalEntryBinaryCode q := by + simp [rawRatBinaryCode, rawRatOfRat, rationalEntryBinaryCode] + +@[simp] theorem machineMatrixNonnegativeEntryBit_encode + (rows : List (List β„š)) (current : List β„š) (ok : Bool) (q : β„š) : + machineMatrixNonnegativeEntryBit + (machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode (q :: current)) [ok]) = + [rationalNonnegativeBit q] := by + rw [machineMatrixNonnegativeEntryBit, + machineMatrixNonnegativeEntry] + simp only [machineMatrixNonnegativeCurrent_pack, + machineListHead_cons, ← rawRatBinaryCode_rawRatOfRat] + rw [machineRawRatLeBit_encode, machineHeadBit_cons] + simp [rationalNonnegativeBit] + +@[simp] theorem machineMatrixNonnegativeStep_entry_encode + (rows : List (List β„š)) (q : β„š) (current : List β„š) (ok : Bool) : + machineMatrixNonnegativeStep + (machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode (q :: current)) [ok]) = + machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode current) + [ok && rationalNonnegativeBit q] := by + rw [machineMatrixNonnegativeStep] + simp only [machineMatrixNonnegativeCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q current)] + simp [machineMatrixNonnegativeProcessEntry] + +@[simp] theorem machineMatrixNonnegativeStep_row_encode + (row : List β„š) (rows : List (List β„š)) (ok : Bool) : + machineMatrixNonnegativeStep + (machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (row :: rows)) [] [ok]) = + machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode row) [ok] := by + rw [machineMatrixNonnegativeStep] + simp only [machineMatrixNonnegativeCurrent_pack] + rw [machineIfEmpty_nil, machineMatrixNonnegativeAfterRow] + simp only [machineMatrixNonnegativeRows_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil + (binaryListCode rationalEntryBinaryCode) row rows)] + simp [machineMatrixNonnegativeLoadRow] + +@[simp] theorem machineMatrixNonnegativeStep_done_encode (ok : Bool) : + machineMatrixNonnegativeStep + (machineMatrixNonnegativePack [] [] [ok]) = + machineMatrixNonnegativePack [] [] [ok] := by + simp [machineMatrixNonnegativeStep, machineMatrixNonnegativeAfterRow] + +/-- Tests whether every entry of a rational row is nonnegative. -/ +def matrixNonnegativeRowBit (row : List β„š) : Bool := + row.all rationalNonnegativeBit + +/-- Tests whether every entry of every supplied rational row is nonnegative. -/ +def matrixNonnegativeRowsBit (rows : List (List β„š)) : Bool := + rows.all matrixNonnegativeRowBit + +theorem machineMatrixNonnegativeProcessRow_encode + (rows : List (List β„š)) (row : List β„š) (ok : Bool) : + (machineMatrixNonnegativeStep)^[row.length] + (machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode row) [ok]) = + machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) [] + [ok && matrixNonnegativeRowBit row] := by + induction row generalizing ok with + | nil => simp [matrixNonnegativeRowBit, binaryListCode] + | cons q row ih => + rw [List.length_cons, Function.iterate_succ_apply, + machineMatrixNonnegativeStep_entry_encode, ih] + simp [matrixNonnegativeRowBit, Bool.and_assoc] + +/-- Counts one row-loading step plus one test per entry across all rows. -/ +def matrixNonnegativeRowsWork : List (List β„š) β†’ β„• + | [] => 0 + | row :: rows => 1 + row.length + matrixNonnegativeRowsWork rows + +theorem machineMatrixNonnegativeProcessRows_encode + (rows : List (List β„š)) (ok : Bool) : + (machineMatrixNonnegativeStep)^[matrixNonnegativeRowsWork rows] + (machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + [] [ok]) = + machineMatrixNonnegativePack [] [] + [ok && matrixNonnegativeRowsBit rows] := by + induction rows generalizing ok with + | nil => + simp [matrixNonnegativeRowsWork, matrixNonnegativeRowsBit, + binaryListCode] + | cons row rows ih => + rw [matrixNonnegativeRowsWork, show 1 + row.length + + matrixNonnegativeRowsWork rows = + matrixNonnegativeRowsWork rows + row.length + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one, machineMatrixNonnegativeStep_row_encode, + machineMatrixNonnegativeProcessRow_encode, ih] + simp [matrixNonnegativeRowsBit, Bool.and_assoc] + +theorem binaryListCode_length_ge_work (rows : List (List β„š)) : + matrixNonnegativeRowsWork rows ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + induction rows with + | nil => simp [matrixNonnegativeRowsWork, binaryListCode] + | cons row rows ih => + simp only [matrixNonnegativeRowsWork, binaryListCode, pair_length] + have hrow : row.length ≀ + (binaryListCode rationalEntryBinaryCode row).length := by + induction row with + | nil => simp [binaryListCode] + | cons q row ihrow => + simp only [binaryListCode, pair_length, List.length_cons] + omega + omega + +theorem machineMatrixNonnegativeDone_iterate (extra : β„•) (ok : Bool) : + (machineMatrixNonnegativeStep)^[extra] + (machineMatrixNonnegativePack [] [] [ok]) = + machineMatrixNonnegativePack [] [] [ok] := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih, + machineMatrixNonnegativeStep_done_encode] + +theorem machineMatrixNonnegativeFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNonnegativeFinalState + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + machineMatrixNonnegativePack [] [] + [matrixNonnegativeRowsBit (rationalMatrixRows A)] := by + let rows := rationalMatrixRows A + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := by + have hcode := binaryListCode_length_ge_work rows + have hrows : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length = + (machineMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ word.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le word + exact hcode.trans hrows + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + change machineMatrixNonnegativeFinalState word = _ + rw [machineMatrixNonnegativeFinalState, hsplit, + Function.iterate_add_apply] + have hinit : machineMatrixNonnegativeInit word = + machineMatrixNonnegativePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + [] [true] := by + simp [machineMatrixNonnegativeInit, word, rows] + rw [hinit, machineMatrixNonnegativeProcessRows_encode, + machineMatrixNonnegativeDone_iterate] + simp [rows] + +theorem matrixNonnegativeRowsBit_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + matrixNonnegativeRowsBit (rationalMatrixRows A) = true ↔ + Matrix.Nonnegative A := by + simp [matrixNonnegativeRowsBit, matrixNonnegativeRowBit, + rationalNonnegativeBit, rationalMatrixRows, Matrix.Nonnegative] + +open scoped Classical in +@[simp] theorem machineMatrixNonnegativeBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNonnegativeBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [decide (βˆ€ i : Fin n, βˆ€ j : Fin n, 0 ≀ A i j)] := by + rw [machineMatrixNonnegativeBit, + machineMatrixNonnegativeFinalState_encode] + simp only [machineMatrixNonnegativeOk_pack] + apply congrArg singleton + apply Bool.eq_iff_iff.mpr + simpa [Matrix.Nonnegative] using! matrixNonnegativeRowsBit_iff A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalization.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalization.lean new file mode 100644 index 0000000000..072ff31634 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalization.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower + +/-! +# Machine normalization scale and its dimension power +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Raises the raw-rational matrix normalization scale to the matrix dimension. -/ +def machineMatrixNormalizationScalePowerRawCode + (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineMatrixDimensionUnary word) + (machineMatrixNormalizationScaleRawCode word)) + +/-- Normalizes the encoded dimension-th power of the matrix normalization scale. -/ +def machineMatrixNormalizationScalePowerOutputCode + (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode + (machineMatrixNormalizationScalePowerRawCode word) + +theorem machineMatrixNormalizationScalePowerRawCode_mem_FP : + machineMatrixNormalizationScalePowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixDimensionUnary_mem_FP + machineMatrixNormalizationScaleRawCode_mem_FP + simpa only [machineMatrixNormalizationScalePowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatPowerCode_mem_FP + +theorem machineMatrixNormalizationScalePowerOutputCode_mem_FP : + machineMatrixNormalizationScalePowerOutputCode ∈ Complexity.FP := by + simpa only [machineMatrixNormalizationScalePowerOutputCode] using! + machineCompose_mem_FP + machineMatrixNormalizationScalePowerRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +@[simp] theorem machineMatrixNormalizationScalePowerRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScalePowerRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + ((RawRat.one.add + (rawRatRowsSum RawRat.zero (rationalMatrixRows A))).pow n) := by + rw [machineMatrixNormalizationScalePowerRawCode, + machineMatrixDimensionUnary_encode, + machineMatrixNormalizationScaleRawCode_encode, + machineRawRatPowerCode_encode] + +@[simp] theorem machineMatrixNormalizationScalePowerOutputCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScalePowerOutputCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode ((1 + βˆ‘ i, βˆ‘ j, A i j) ^ n) := by + rw [machineMatrixNormalizationScalePowerOutputCode, + machineMatrixNormalizationScalePowerRawCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_pow, + RawRat.value_add, RawRat.value_one, rawRatRowsSum_value, + RawRat.value_zero, zero_add, rationalMatrixRows_sum] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalizeEntries.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalizeEntries.lean new file mode 100644 index 0000000000..59ecfa357f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixNormalizeEntries.lean @@ -0,0 +1,788 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowDivide +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import Mathlib.Tactic + +/-! +# Entrywise normalization of a rational matrix + +This machine computes `A / (1 + sum A)` entry by entry. It preserves the +binary dimension prefix and maps the self-delimiting row list with the +verified row-division machine. A polynomial clamp is present on malformed +inputs and is proved inactive on every canonical rational matrix. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Concatenates twenty copies of the input for the matrix-normalization width estimate. -/ +def machineMatrixNormalizePadTwenty (word : List Bool) : List Bool := + machineRationalRowDividePadSixteen word ++ + machineRationalRowDividePadFour word + +/-- A direct quadratic envelope in the original matrix-word length. Using +twenty copies before squaring avoids materializing the much larger nested +row-machine envelope used in the first implementation. -/ +def machineMatrixNormalizeInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineMatrixNormalizePadTwenty word) + +/-- Encodes normalization state as remaining rows, reversed output, scale, dimension, and bound. -/ +def machineMatrixNormalizePack + (remaining accumulator scale dimension bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair scale (pair dimension bound))) + +/-- Extracts the unprocessed rows from a matrix-normalization state. -/ +def machineMatrixNormalizeRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reversed accumulated normalized rows. -/ +def machineMatrixNormalizeAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed raw-rational normalization scale. -/ +def machineMatrixNormalizeScale (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the binary dimension retained in the normalization state. -/ +def machineMatrixNormalizeDimension (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the stored width bound from the normalization state. -/ +def machineMatrixNormalizeBound (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Reads the first unprocessed row to normalize. -/ +def machineMatrixNormalizeCurrentRow (state : List Bool) : List Bool := + machineListHead (machineMatrixNormalizeRemaining state) + +/-- Divides every entry of the current row by the stored normalization scale. -/ +def machineMatrixNormalizeOutputRow (state : List Bool) : List Bool := + machineRationalRowDivide + (pair (machineMatrixNormalizeScale state) + (machineMatrixNormalizeCurrentRow state)) + +/-- Prepends the normalized current row to the reversed output accumulator. -/ +def machineMatrixNormalizeCandidate (state : List Bool) : List Bool := + pair (machineMatrixNormalizeOutputRow state) + (machineMatrixNormalizeAccumulator state) + +/-- Truncates the candidate normalized-row accumulator to the stored width bound. -/ +def machineMatrixNormalizeNextAccumulator (state : List Bool) : List Bool := + (machineMatrixNormalizeCandidate state).take + (machineMatrixNormalizeBound state).length + +/-- Consumes one row and stores its normalized output while preserving scale, dimension, and +bound. -/ +def machineMatrixNormalizeAdvance (state : List Bool) : List Bool := + machineMatrixNormalizePack + (machineListTail (machineMatrixNormalizeRemaining state)) + (machineMatrixNormalizeNextAccumulator state) + (machineMatrixNormalizeScale state) + (machineMatrixNormalizeDimension state) + (machineMatrixNormalizeBound state) + +/-- Normalizes the next row, leaving exhausted normalization states fixed. -/ +def machineMatrixNormalizeStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixNormalizeRemaining state) state + (machineMatrixNormalizeAdvance state) + +/-- Initializes normalization with the source rows, empty output, computed scale, dimension, and +bound. -/ +def machineMatrixNormalizeInit (word : List Bool) : List Bool := + machineMatrixNormalizePack (machineMatrixRowsWord word) [] + (machineMatrixNormalizationScaleRawCode word) + (machineMatrixDimensionWord word) + (machineMatrixNormalizeInputBound word) + +/-- Builds an encoded width envelope for the five normalization-state components. -/ +def machineMatrixNormalizeWidth (word : List Bool) : List Bool := + machineMatrixNormalizePack word (machineMatrixNormalizeInputBound word) + (machineMatrixNormalizationScaleRawCode word) word + (machineMatrixNormalizeInputBound word) + +/-- Runs matrix normalization for one step per input bit. -/ +def machineMatrixNormalizeFinalState (word : List Bool) : List Bool := + (machineMatrixNormalizeStep)^[word.length] + (machineMatrixNormalizeInit word) + +/-- Pairs the matrix dimension with normalized rows restored to their original order. -/ +def machineMatrixNormalizeEntries (word : List Bool) : List Bool := + let state := machineMatrixNormalizeFinalState word + pair (machineMatrixNormalizeDimension state) + (machineListReverse (machineMatrixNormalizeAccumulator state)) + +theorem machineMatrixNormalizePadTwenty_mem_FP : + machineMatrixNormalizePadTwenty ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowDividePadSixteen_mem_FP + machineRationalRowDividePadFour_mem_FP + +theorem machineMatrixNormalizePadTwenty_length (word : List Bool) : + (machineMatrixNormalizePadTwenty word).length = 20 * word.length := by + simp only [machineMatrixNormalizePadTwenty, List.length_append, + machineRationalRowDividePadSixteen_length, + machineRationalRowDividePadFour, + machineRationalRowDividePadTwo, List.length_append] + omega + +theorem machineMatrixNormalizeInputBound_mem_FP : + machineMatrixNormalizeInputBound ∈ Complexity.FP := by + simpa only [machineMatrixNormalizeInputBound] using! + machineCompose_mem_FP machineMatrixNormalizePadTwenty_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineMatrixNormalizeRemaining_mem_FP : + machineMatrixNormalizeRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineMatrixNormalizeAccumulator_mem_FP : + machineMatrixNormalizeAccumulator ∈ Complexity.FP := by + simpa only [machineMatrixNormalizeAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixNormalizeScale_mem_FP : + machineMatrixNormalizeScale ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineMatrixNormalizeScale] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineMatrixNormalizeDimension_mem_FP : + machineMatrixNormalizeDimension ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineMatrixNormalizeDimension] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineMatrixNormalizeBound_mem_FP : + machineMatrixNormalizeBound ∈ Complexity.FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineMatrixNormalizeBound] using! + machineCompose_mem_FP htailThree machinePairSecond_mem_FP + +theorem machineMatrixNormalizeCurrentRow_mem_FP : + machineMatrixNormalizeCurrentRow ∈ Complexity.FP := by + simpa only [machineMatrixNormalizeCurrentRow] using! + machineCompose_mem_FP machineMatrixNormalizeRemaining_mem_FP + machineListHead_mem_FP + +theorem machineMatrixNormalizeOutputRow_mem_FP : + machineMatrixNormalizeOutputRow ∈ Complexity.FP := by + have hinput := machinePair_mem_FP machineMatrixNormalizeScale_mem_FP + machineMatrixNormalizeCurrentRow_mem_FP + simpa only [machineMatrixNormalizeOutputRow] using! + machineCompose_mem_FP hinput machineRationalRowDivide_mem_FP + +theorem machineMatrixNormalizeCandidate_mem_FP : + machineMatrixNormalizeCandidate ∈ Complexity.FP := + machinePair_mem_FP machineMatrixNormalizeOutputRow_mem_FP + machineMatrixNormalizeAccumulator_mem_FP + +theorem machineMatrixNormalizeNextAccumulator_mem_FP : + machineMatrixNormalizeNextAccumulator ∈ Complexity.FP := by + simpa only [machineMatrixNormalizeNextAccumulator] using! + machineTake_mem_FP machineMatrixNormalizeBound_mem_FP + machineMatrixNormalizeCandidate_mem_FP + +theorem machineMatrixNormalizeAdvance_mem_FP : + machineMatrixNormalizeAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixNormalizeRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineMatrixNormalizeNextAccumulator_mem_FP + (machinePair_mem_FP machineMatrixNormalizeScale_mem_FP + (machinePair_mem_FP machineMatrixNormalizeDimension_mem_FP + machineMatrixNormalizeBound_mem_FP))) + +theorem machineMatrixNormalizeStep_mem_FP : + machineMatrixNormalizeStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixNormalizeRemaining_mem_FP + id_mem_FP machineMatrixNormalizeAdvance_mem_FP + +theorem machineMatrixNormalizeInit_mem_FP : + machineMatrixNormalizeInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineMatrixNormalizationScaleRawCode_mem_FP + (machinePair_mem_FP machineMatrixDimensionWord_mem_FP + machineMatrixNormalizeInputBound_mem_FP))) + +theorem machineMatrixNormalizeWidth_mem_FP : + machineMatrixNormalizeWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineMatrixNormalizeInputBound_mem_FP + (machinePair_mem_FP machineMatrixNormalizationScaleRawCode_mem_FP + (machinePair_mem_FP id_mem_FP + machineMatrixNormalizeInputBound_mem_FP))) + +@[simp] theorem machineMatrixNormalizeRemaining_pack (a b c d e) : + machineMatrixNormalizeRemaining + (machineMatrixNormalizePack a b c d e) = a := by + simp [machineMatrixNormalizeRemaining, machineMatrixNormalizePack] + +@[simp] theorem machineMatrixNormalizeAccumulator_pack (a b c d e) : + machineMatrixNormalizeAccumulator + (machineMatrixNormalizePack a b c d e) = b := by + simp [machineMatrixNormalizeAccumulator, machineMatrixNormalizePack] + +@[simp] theorem machineMatrixNormalizeScale_pack (a b c d e) : + machineMatrixNormalizeScale + (machineMatrixNormalizePack a b c d e) = c := by + simp [machineMatrixNormalizeScale, machineMatrixNormalizePack] + +@[simp] theorem machineMatrixNormalizeDimension_pack (a b c d e) : + machineMatrixNormalizeDimension + (machineMatrixNormalizePack a b c d e) = d := by + simp [machineMatrixNormalizeDimension, machineMatrixNormalizePack] + +@[simp] theorem machineMatrixNormalizeBound_pack (a b c d e) : + machineMatrixNormalizeBound + (machineMatrixNormalizePack a b c d e) = e := by + simp [machineMatrixNormalizeBound, machineMatrixNormalizePack] + +/-- Bounds normalization state lengths and preserves the computed scale and input-derived bound. -/ +def MachineMatrixNormalizeStateBound (word state : List Bool) : Prop := + state = machineMatrixNormalizePack + (machineMatrixNormalizeRemaining state) + (machineMatrixNormalizeAccumulator state) + (machineMatrixNormalizeScale state) + (machineMatrixNormalizeDimension state) + (machineMatrixNormalizeBound state) ∧ + (machineMatrixNormalizeRemaining state).length ≀ word.length ∧ + (machineMatrixNormalizeAccumulator state).length ≀ + (machineMatrixNormalizeInputBound word).length ∧ + machineMatrixNormalizeScale state = + machineMatrixNormalizationScaleRawCode word ∧ + (machineMatrixNormalizeDimension state).length ≀ word.length ∧ + machineMatrixNormalizeBound state = machineMatrixNormalizeInputBound word + +theorem machineMatrixNormalizeInit_bound (word : List Bool) : + MachineMatrixNormalizeStateBound word (machineMatrixNormalizeInit word) := by + simp only [MachineMatrixNormalizeStateBound, machineMatrixNormalizeInit, + machineMatrixNormalizeRemaining_pack, + machineMatrixNormalizeAccumulator_pack, + machineMatrixNormalizeScale_pack, + machineMatrixNormalizeDimension_pack, + machineMatrixNormalizeBound_pack] + refine ⟨trivial, ?_, by simp, trivial, ?_, trivial⟩ + Β· simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le word + Β· simpa only [machineMatrixDimensionWord] using! + machinePairFirst_length_le word + +theorem machineMatrixNormalizeStep_bound {word state : List Bool} + (hstate : MachineMatrixNormalizeStateBound word state) : + MachineMatrixNormalizeStateBound word + (machineMatrixNormalizeStep state) := by + rcases hstate with + ⟨hdecomp, hremaining, haccumulator, hscale, hdimension, hbound⟩ + by_cases hnil : machineMatrixNormalizeRemaining state = [] + Β· rw [machineMatrixNormalizeStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, haccumulator, hscale, hdimension, hbound⟩ + Β· rw [machineMatrixNormalizeStep] + cases hremainingCode : machineMatrixNormalizeRemaining state with + | nil => exact False.elim (hnil hremainingCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixNormalizeAdvance] + simp only [MachineMatrixNormalizeStateBound, + machineMatrixNormalizeRemaining_pack, + machineMatrixNormalizeAccumulator_pack, + machineMatrixNormalizeScale_pack, + machineMatrixNormalizeDimension_pack, + machineMatrixNormalizeBound_pack] + refine ⟨trivial, ?_, ?_, hscale, hdimension, hbound⟩ + Β· exact (machineListTail_length_le + (machineMatrixNormalizeRemaining state)).trans hremaining + Β· rw [machineMatrixNormalizeNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineMatrixNormalizeIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixNormalizeStateBound word + ((machineMatrixNormalizeStep)^[k] + (machineMatrixNormalizeInit word)) := by + intro k + induction k with + | zero => exact machineMatrixNormalizeInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixNormalizeStep_bound ih + +theorem machineMatrixNormalizeIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineMatrixNormalizeStep)^[iterations] + (machineMatrixNormalizeInit word)).length ≀ + (machineMatrixNormalizeWidth word).length := by + rcases machineMatrixNormalizeIterate_bound word iterations with + ⟨hdecomp, hremaining, haccumulator, hscale, hdimension, hbound⟩ + rw [hdecomp, hscale, hbound] + simp only [machineMatrixNormalizePack, machineMatrixNormalizeWidth, + pair_length] + omega + +theorem machineMatrixNormalizeFinalState_mem_FP : + machineMatrixNormalizeFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixNormalizeStep_mem_FP + machineMatrixNormalizeInit_mem_FP id_mem_FP + machineMatrixNormalizeWidth_mem_FP + machineMatrixNormalizeIterate_length_le_width + +theorem machineMatrixNormalizeEntries_mem_FP : + machineMatrixNormalizeEntries ∈ Complexity.FP := by + have hdimension := machineCompose_mem_FP + machineMatrixNormalizeFinalState_mem_FP + machineMatrixNormalizeDimension_mem_FP + have hacc := machineCompose_mem_FP + machineMatrixNormalizeFinalState_mem_FP + machineMatrixNormalizeAccumulator_mem_FP + have hrows := machineCompose_mem_FP hacc machineListReverse_mem_FP + simpa only [machineMatrixNormalizeEntries] using! + machinePair_mem_FP hdimension hrows + +/-! ## Output-size bound on canonical matrices -/ + +private theorem matrixNormalize_natList_sum_le_length_mul + {values : List β„•} {bound : β„•} + (h : βˆ€ value ∈ values, value ≀ bound) : + values.sum ≀ values.length * bound := by + induction values with + | nil => simp + | cons value values ih => + simp only [List.sum_cons, List.length_cons] + have hvalue := h value (by simp) + have htail : βˆ€ x ∈ values, x ≀ bound := by + intro x hx + exact h x (by simp [hx]) + have hi := ih htail + calc + value + values.sum ≀ bound + values.length * bound := + Nat.add_le_add hvalue hi + _ = (values.length + 1) * bound := by ring + +private theorem matrixNonnegativeRowsWork_eq_length_add_entries : + βˆ€ rows : List (List β„š), + matrixNonnegativeRowsWork rows = + rows.length + (rows.map List.length).sum := by + intro rows + induction rows with + | nil => simp [matrixNonnegativeRowsWork] + | cons row rows ih => + simp [matrixNonnegativeRowsWork, ih] + omega + +private theorem matrixNormalize_outputCode_length_le + (scale : RawRat) (budget : β„•) : βˆ€ rows : List (List β„š), + (βˆ€ row ∈ rows, βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).div scale))).length ≀ + 172 + 72 * budget) β†’ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.map (rationalRowDivideValues scale))).length ≀ + (rows.map List.length).sum * (692 + 288 * budget) + + 2 * rows.length := by + intro rows hentry + induction rows with + | nil => simp [binaryListCode] + | cons row rows ih => + have hrowEntry : βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).div scale))).length ≀ + 172 + 72 * budget := by + intro q hq + exact hentry row (by simp) q hq + have htailEntry : βˆ€ tailRow ∈ rows, βˆ€ q ∈ tailRow, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).div scale))).length ≀ + 172 + 72 * budget := by + intro tailRow htailRow q hq + exact hentry tailRow (by simp [htailRow]) q hq + have hinner : + (binaryListCode rationalEntryBinaryCode + (rationalRowDivideValues scale row)).length ≀ + row.length * (346 + 144 * budget) := by + rw [binaryListCode_length_eq_sum] + have hterm : βˆ€ value ∈ + ((rationalRowDivideValues scale row).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2), + value ≀ 346 + 144 * budget := by + simp only [rationalRowDivideValues, List.map_map] + intro value hvalue + rw [List.mem_map] at hvalue + rcases hvalue with ⟨q, hq, rfl⟩ + have hqBound := hrowEntry q hq + simp only [Function.comp_apply] + omega + have hsum := matrixNormalize_natList_sum_le_length_mul hterm + simpa only [rationalRowDivideValues, List.length_map] using! hsum + have htail := ih htailEntry + simp only [List.map_cons, binaryListCode, pair_length, + List.map_map, List.sum_cons, List.length_cons] at htail ⊒ + nlinarith + +theorem machineMatrixNormalize_outputRows_length_le_bound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let scale := RawRat.one.add + (rawRatRowsSum RawRat.zero (rationalMatrixRows A)) + let output := (rationalMatrixRows A).map + (rationalRowDivideValues scale) + (binaryListCode (binaryListCode rationalEntryBinaryCode) output).length ≀ + (machineMatrixNormalizeInputBound word).length := by + dsimp only + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let rows := rationalMatrixRows A + let scale := RawRat.one.add (rawRatRowsSum RawRat.zero rows) + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ word.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le word + have hcost : rawRatRowsCost rows ≀ word.length := + (rawRatRowsCost_le_codeLength rows).trans hrowsCode + have hsumWidth : + rawRatWidth (rawRatRowsSum RawRat.zero rows) ≀ 1 + word.length := by + have h := rawRatWidth_rowsSum_le RawRat.zero rows + simpa only [rawRatWidth_zero] using! h.trans + (Nat.add_le_add_left hcost 1) + have hscaleWidth : rawRatWidth scale ≀ word.length + 3 := by + have h := rawRatWidth_add_le RawRat.one + (rawRatRowsSum RawRat.zero rows) + simp only [rawRatWidth_one] at h + have hraw : + rawRatWidth + (RawRat.one.add (rawRatRowsSum RawRat.zero rows)) ≀ + word.length + 3 := by + omega + simpa only [scale] using! hraw + have hentry : βˆ€ row ∈ rows, βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).div scale))).length ≀ + 172 + 72 * word.length := by + intro row hrow q hq + have hqCode := binaryListCode_element_length_le + rationalEntryBinaryCode hq + have hrowCode := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hrow + have hqWidth : rawRatWidth (rawRatOfRat q) ≀ word.length := by + have hentryCode : + (rawRatBinaryCode (rawRatOfRat q)).length ≀ word.length := by + rw [rawRatBinaryCode_rawRatOfRat] + exact hqCode.trans (hrowCode.trans hrowsCode) + exact (rawRatWidth_le_binaryCode_length (rawRatOfRat q)).trans + hentryCode + have hdiv := rawRatWidth_div_le (rawRatOfRat q) scale + have hnormalize := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + ((rawRatOfRat q).div scale) + omega + have houtput := matrixNormalize_outputCode_length_le + scale word.length rows hentry + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsCode + rw [matrixNonnegativeRowsWork_eq_length_add_entries] at hwork + have hquadratic : + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (machineMatrixNormalizeInputBound word).length := by + rw [machineMatrixNormalizeInputBound] + simp only [machineBinaryMulWidth, List.length_replicate, + List.length_append] + rw [machineMatrixNormalizePadTwenty_length] + have hcombined : + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (rows.length + (rows.map List.length).sum) * + (694 + 288 * word.length) := by + have hentries := Nat.mul_le_mul_left + (rows.map List.length).sum + (show 692 + 288 * word.length ≀ 694 + 288 * word.length by omega) + have hrows := Nat.mul_le_mul_left rows.length + (show 2 ≀ 694 + 288 * word.length by omega) + calc + (rows.map List.length).sum * (692 + 288 * word.length) + + 2 * rows.length ≀ + (rows.map List.length).sum * (694 + 288 * word.length) + + rows.length * (694 + 288 * word.length) := by + exact Nat.add_le_add hentries (by simpa [Nat.mul_comm] using! hrows) + _ = (rows.length + (rows.map List.length).sum) * + (694 + 288 * word.length) := by ring + have hlinear := Nat.mul_le_mul_right (694 + 288 * word.length) hwork + have hsquare : + word.length * (694 + 288 * word.length) ≀ + (16 + 20 * word.length) * (16 + 20 * word.length) := by + cases hword : word.length with + | zero => simp + | succ length => + have hsquareDominates : length + 1 ≀ (length + 1) * (length + 1) := by + nlinarith + nlinarith + exact hcombined.trans (hlinear.trans hsquare) + exact houtput.trans hquadratic + +/-! ## Exact semantics -/ + +/-- Divides every entry of every supplied row by the raw-rational scale. -/ +def rationalMatrixDivideRows (scale : RawRat) + (rows : List (List β„š)) : List (List β„š) := + rows.map (rationalRowDivideValues scale) + +/-- Encodes normalization after `k` rows, with the remaining input rows and reversed normalized +output. -/ +def machineMatrixNormalizeSemanticState + (word dimension : List Bool) (scale : RawRat) + (rows : List (List β„š)) (k : β„•) : List Bool := + let output := rationalMatrixDivideRows scale rows + machineMatrixNormalizePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) (rows.drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take k).reverse) + (rawRatBinaryCode scale) dimension + (machineMatrixNormalizeInputBound word) + +theorem machineMatrixNormalizeInit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let scale := RawRat.one.add + (rawRatRowsSum RawRat.zero (rationalMatrixRows A)) + machineMatrixNormalizeInit word = + machineMatrixNormalizeSemanticState word n.bits scale + (rationalMatrixRows A) 0 := by + dsimp only + rw [machineMatrixNormalizeInit] + simp only [machineMatrixRowsWord_encode, + machineMatrixNormalizationScaleRawCode_encode, + machineMatrixDimensionWord_encode, + machineMatrixNormalizeSemanticState, List.drop_zero, + List.take_zero, List.reverse_nil, binaryListCode] + +theorem machineMatrixNormalizeOutputRow_semantics + (word dimension : List Bool) (scale : RawRat) + (rows : List (List β„š)) (k : β„•) (hk : k < rows.length) : + machineMatrixNormalizeOutputRow + (machineMatrixNormalizeSemanticState word dimension scale rows k) = + binaryListCode rationalEntryBinaryCode + (rationalRowDivideValues scale rows[k]) := by + have hdrop := List.drop_eq_getElem_cons hk + rw [machineMatrixNormalizeOutputRow] + simp only [machineMatrixNormalizeSemanticState, + machineMatrixNormalizeScale_pack, + machineMatrixNormalizeCurrentRow, + machineMatrixNormalizeRemaining_pack, hdrop, + machineListHead_cons] + change machineRationalRowDivide + (machineRationalRowDivideCanonicalInput scale rows[k]) = _ + exact machineRationalRowDivide_encode scale rows[k] + +theorem machineMatrixNormalizeStep_semantics + (word dimension : List Bool) (scale : RawRat) + (rows : List (List β„š)) (k : β„•) (hk : k < rows.length) + (hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixDivideRows scale rows)).length ≀ + (machineMatrixNormalizeInputBound word).length) : + machineMatrixNormalizeStep + (machineMatrixNormalizeSemanticState word dimension scale rows k) = + machineMatrixNormalizeSemanticState word dimension scale rows (k + 1) := by + let output := rationalMatrixDivideRows scale rows + have houtputLength : output.length = rows.length := by + simp [output, rationalMatrixDivideRows] + have hkoutput : k < output.length := by omega + have houtputGet : output[k] = + rationalRowDivideValues scale rows[k] := by + simp [output, rationalMatrixDivideRows, List.getElem_map] + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hkoutput + have hprefix : (output.take (k + 1)).reverse = + output[k] :: (output.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := output.take k) (a := output[k])) + have hprefixLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse).length ≀ + (machineMatrixNormalizeInputBound word).length := + (binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) output (k + 1)).trans + (by simpa only [output] using! hfullBound) + have htakeBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse).take + (machineMatrixNormalizeInputBound word).length = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hnonempty : + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil _ _ _ + rw [machineMatrixNormalizeStep] + simp only [machineMatrixNormalizeSemanticState, + machineMatrixNormalizeRemaining_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hnonempty, + machineMatrixNormalizeAdvance] + simp only [machineMatrixNormalizeRemaining_pack, + machineMatrixNormalizeAccumulator_pack, + machineMatrixNormalizeScale_pack, + machineMatrixNormalizeDimension_pack, + machineMatrixNormalizeBound_pack, + machineMatrixNormalizeNextAccumulator, + machineMatrixNormalizeCandidate] + have hrow : + machineMatrixNormalizeOutputRow + (machineMatrixNormalizePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (output.take k).reverse) + (rawRatBinaryCode scale) dimension + (machineMatrixNormalizeInputBound word)) = + binaryListCode rationalEntryBinaryCode output[k] := by + rw [houtputGet] + simpa only [machineMatrixNormalizeSemanticState, output] using! + machineMatrixNormalizeOutputRow_semantics + word dimension scale rows k hk + rw [hrow, hdrop, machineListTail_cons] + change machineMatrixNormalizePack + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop (k + 1))) + ((binaryListCode (binaryListCode rationalEntryBinaryCode) + (output[k] :: (output.take k).reverse)).take + (machineMatrixNormalizeInputBound word).length) + (rawRatBinaryCode scale) dimension + (machineMatrixNormalizeInputBound word) = _ + rw [← hprefix, htakeBound] + +theorem machineMatrixNormalizeIterate_semantics + (word dimension : List Bool) (scale : RawRat) + (rows : List (List β„š)) + (hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixDivideRows scale rows)).length ≀ + (machineMatrixNormalizeInputBound word).length) : βˆ€ k ≀ rows.length, + (machineMatrixNormalizeStep)^[k] + (machineMatrixNormalizeSemanticState word dimension scale rows 0) = + machineMatrixNormalizeSemanticState word dimension scale rows k := by + intro k hk + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineMatrixNormalizeStep_semantics word dimension scale rows k + (by omega) hfullBound + +theorem machineMatrixNormalize_done_iterate + (extra : β„•) (accumulator scale dimension bound : List Bool) : + (machineMatrixNormalizeStep)^[extra] + (machineMatrixNormalizePack [] accumulator scale dimension bound) = + machineMatrixNormalizePack [] accumulator scale dimension bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineMatrixNormalizeStep] + +theorem machineMatrixNormalizeFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let rows := rationalMatrixRows A + let scale := RawRat.one.add (rawRatRowsSum RawRat.zero rows) + machineMatrixNormalizeFinalState word = + machineMatrixNormalizePack [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixDivideRows scale rows).reverse) + (rawRatBinaryCode scale) n.bits + (machineMatrixNormalizeInputBound word) := by + dsimp only + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let rows := rationalMatrixRows A + let scale := RawRat.one.add (rawRatRowsSum RawRat.zero rows) + have hrowsLength : rows.length ≀ word.length := by + simpa only [rows, word, rationalMatrixRows, List.length_ofFn] using! + matrix_dimension_le_code_length A + have hfullBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixDivideRows scale rows)).length ≀ + (machineMatrixNormalizeInputBound word).length := by + simpa only [word, rows, scale, rationalMatrixDivideRows] using! + machineMatrixNormalize_outputRows_length_le_bound A + have hsplit : word.length = + (word.length - rows.length) + rows.length := by omega + have htakeAll : + (rationalMatrixDivideRows scale rows).take rows.length = + rationalMatrixDivideRows scale rows := by + have hlength : (rationalMatrixDivideRows scale rows).length = + rows.length := by simp [rationalMatrixDivideRows] + rw [← hlength, List.take_length] + change (machineMatrixNormalizeStep)^[word.length] + (machineMatrixNormalizeInit word) = _ + rw [hsplit, Function.iterate_add_apply, + machineMatrixNormalizeInit_encode A, + machineMatrixNormalizeIterate_semantics word n.bits scale rows + hfullBound rows.length le_rfl] + simp only [machineMatrixNormalizeSemanticState, List.drop_length, + binaryListCode] + rw [htakeAll, machineMatrixNormalize_done_iterate] + +theorem rationalMatrixDivideRows_normalized {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + let rows := rationalMatrixRows A + let scale := RawRat.one.add (rawRatRowsSum RawRat.zero rows) + rationalMatrixDivideRows scale rows = + rationalMatrixRows (normalizedRationalMatrix A) := by + dsimp only + have hscale : + (RawRat.one.add + (rawRatRowsSum RawRat.zero (rationalMatrixRows A))).value = + rationalNormalizationScale A := by + rw [RawRat.value_add, RawRat.value_one, rawRatRowsSum_value, + RawRat.value_zero, zero_add, rationalMatrixRows_sum] + rfl + have hscaleRows := hscale + simp only [rationalMatrixRows] at hscaleRows + apply List.ext_get + Β· simp [rationalMatrixDivideRows, rationalMatrixRows] + Β· intro i hi hi' + apply List.ext_get + Β· simp [rationalMatrixDivideRows, rationalRowDivideValues, + rationalMatrixRows] + Β· intro j hj hj' + simp [rationalMatrixDivideRows, rationalRowDivideValues, + rationalMatrixRows, normalizedRationalMatrix, + binaryNormalizeRawRat_eq_value, RawRat.value_div, + rawRatOfRat_value, hscaleRows] + +@[simp] theorem machineMatrixNormalizeEntries_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizeEntries + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalMatrixBinaryEncoding.encode + ⟨n, normalizedRationalMatrix A⟩ := by + let rows := rationalMatrixRows A + let scale := RawRat.one.add (rawRatRowsSum RawRat.zero rows) + rw [machineMatrixNormalizeEntries, + machineMatrixNormalizeFinalState_encode A] + simp only [machineMatrixNormalizeDimension_pack, + machineMatrixNormalizeAccumulator_pack, + machineListReverse_encode, List.reverse_reverse] + rw [rationalMatrixDivideRows_normalized A] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSum.lean new file mode 100644 index 0000000000..49360ed6a9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSum.lean @@ -0,0 +1,788 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNonnegative + +/-! +# Polynomial-time row-major rational matrix sum + +The normalization scale starts with the sum of all matrix entries. We scan +the canonical nested row code and accumulate an unreduced fraction. A +quadratic clamp gives a global state envelope on malformed strings. The +semantic width invariant below proves that the clamp is inactive on every +canonical matrix input. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a matrix-sum state as remaining rows, current row, raw-rational accumulator, and +bound. -/ +def machineMatrixRawSumPack + (rows current acc bound : List Bool) : List Bool := + pair rows (pair current (pair acc bound)) + +/-- Extracts the rows still to be loaded for matrix summation. -/ +def machineMatrixRawSumRows (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed suffix of the current summation row. -/ +def machineMatrixRawSumCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated raw-rational matrix sum. -/ +def machineMatrixRawSumAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the width bound stored in the matrix-sum state. -/ +def machineMatrixRawSumBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Reads the next rational entry to add to the matrix sum. -/ +def machineMatrixRawSumEntry (state : List Bool) : List Bool := + machineListHead (machineMatrixRawSumCurrent state) + +/-- Adds the current entry to the raw-rational sum accumulator. -/ +def machineMatrixRawSumCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineMatrixRawSumAcc state) + (machineMatrixRawSumEntry state)) + +/-- Truncates the candidate sum encoding to the stored width bound. -/ +def machineMatrixRawSumNextAcc (state : List Bool) : List Bool := + (machineMatrixRawSumCandidate state).take + (machineMatrixRawSumBound state).length + +/-- Consumes one entry and updates the bounded matrix-sum accumulator. -/ +def machineMatrixRawSumProcessEntry (state : List Bool) : List Bool := + machineMatrixRawSumPack + (machineMatrixRawSumRows state) + (machineListTail (machineMatrixRawSumCurrent state)) + (machineMatrixRawSumNextAcc state) + (machineMatrixRawSumBound state) + +/-- Loads the next matrix row while retaining the current sum and width bound. -/ +def machineMatrixRawSumLoadRow (state : List Bool) : List Bool := + machineMatrixRawSumPack + (machineListTail (machineMatrixRawSumRows state)) + (machineListHead (machineMatrixRawSumRows state)) + (machineMatrixRawSumAcc state) + (machineMatrixRawSumBound state) + +/-- Loads a further row when available, otherwise retaining the completed summation state. -/ +def machineMatrixRawSumAfterRow (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixRawSumRows state) state + (machineMatrixRawSumLoadRow state) + +/-- Adds the next matrix entry or loads another row when the current row is exhausted. -/ +def machineMatrixRawSumStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixRawSumCurrent state) + (machineMatrixRawSumAfterRow state) + (machineMatrixRawSumProcessEntry state) + +/-- A quadratic word used both as an accumulator clamp and a state envelope. -/ +def machineMatrixRawSumInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Initializes the matrix sum with all encoded rows, an empty current row, zero raw +accumulator, and the computed bound. -/ +def machineMatrixRawSumInit (word : List Bool) : List Bool := + machineMatrixRawSumPack (machineMatrixRowsWord word) [] + (rawRatBinaryCode RawRat.zero) (machineMatrixRawSumInputBound word) + +/-- Packs the original word twice and the accumulator bound twice to bound the matrix-sum state. -/ +def machineMatrixRawSumWidth (word : List Bool) : List Bool := + let bound := machineMatrixRawSumInputBound word + machineMatrixRawSumPack word word bound bound + +/-- Runs the matrix-sum step once per input bit from the initial state. -/ +def machineMatrixRawSumFinalState (word : List Bool) : List Bool := + (machineMatrixRawSumStep)^[word.length] (machineMatrixRawSumInit word) + +/-- Extracts the raw rational accumulator from the final matrix-sum state. -/ +def machineMatrixRawSumCode (word : List Bool) : List Bool := + machineMatrixRawSumAcc (machineMatrixRawSumFinalState word) + +/-- Normalizes the final raw matrix sum into the rational binary output encoding. -/ +def machineMatrixSumOutputCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineMatrixRawSumCode word) + +/-- Unreduced code of `1 + sum A`, the normalization scale used later. -/ +def machineMatrixNormalizationScaleRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode RawRat.one) (machineMatrixRawSumCode word)) + +/-- Normalizes the raw matrix-normalization scale into the rational binary output encoding. -/ +def machineMatrixNormalizationScaleOutputCode + (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode + (machineMatrixNormalizationScaleRawCode word) + +theorem machineMatrixRawSumRows_mem_FP : + machineMatrixRawSumRows ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineMatrixRawSumCurrent_mem_FP : + machineMatrixRawSumCurrent ∈ Complexity.FP := by + simpa only [machineMatrixRawSumCurrent] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixRawSumAcc_mem_FP : + machineMatrixRawSumAcc ∈ Complexity.FP := by + simpa only [machineMatrixRawSumAcc] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineMatrixRawSumBound_mem_FP : + machineMatrixRawSumBound ∈ Complexity.FP := by + simpa only [machineMatrixRawSumBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineMatrixRawSumEntry_mem_FP : + machineMatrixRawSumEntry ∈ Complexity.FP := by + simpa only [machineMatrixRawSumEntry] using! + machineCompose_mem_FP machineMatrixRawSumCurrent_mem_FP + machineListHead_mem_FP + +theorem machineMatrixRawSumCandidate_mem_FP : + machineMatrixRawSumCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixRawSumAcc_mem_FP + machineMatrixRawSumEntry_mem_FP + simpa only [machineMatrixRawSumCandidate] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineMatrixRawSumNextAcc_mem_FP : + machineMatrixRawSumNextAcc ∈ Complexity.FP := by + simpa only [machineMatrixRawSumNextAcc] using! + machineTake_mem_FP machineMatrixRawSumBound_mem_FP + machineMatrixRawSumCandidate_mem_FP + +theorem machineMatrixRawSumProcessEntry_mem_FP : + machineMatrixRawSumProcessEntry ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixRawSumCurrent_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP machineMatrixRawSumRows_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP machineMatrixRawSumNextAcc_mem_FP + machineMatrixRawSumBound_mem_FP)) + +theorem machineMatrixRawSumLoadRow_mem_FP : + machineMatrixRawSumLoadRow ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixRawSumRows_mem_FP + machineListTail_mem_FP + have hhead := machineCompose_mem_FP machineMatrixRawSumRows_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP hhead + (machinePair_mem_FP machineMatrixRawSumAcc_mem_FP + machineMatrixRawSumBound_mem_FP)) + +theorem machineMatrixRawSumAfterRow_mem_FP : + machineMatrixRawSumAfterRow ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixRawSumRows_mem_FP id_mem_FP + machineMatrixRawSumLoadRow_mem_FP + +theorem machineMatrixRawSumStep_mem_FP : + machineMatrixRawSumStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixRawSumCurrent_mem_FP + machineMatrixRawSumAfterRow_mem_FP machineMatrixRawSumProcessEntry_mem_FP + +theorem machineMatrixRawSumInputBound_mem_FP : + machineMatrixRawSumInputBound ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineMatrixRawSumInit_mem_FP : + machineMatrixRawSumInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineMatrixRawSumInputBound_mem_FP)) + +theorem machineMatrixRawSumWidth_mem_FP : + machineMatrixRawSumWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineMatrixRawSumInputBound_mem_FP + machineMatrixRawSumInputBound_mem_FP)) + +@[simp] theorem machineMatrixRawSumRows_pack (rows current acc bound) : + machineMatrixRawSumRows + (machineMatrixRawSumPack rows current acc bound) = rows := by + simp [machineMatrixRawSumRows, machineMatrixRawSumPack] + +@[simp] theorem machineMatrixRawSumCurrent_pack (rows current acc bound) : + machineMatrixRawSumCurrent + (machineMatrixRawSumPack rows current acc bound) = current := by + simp [machineMatrixRawSumCurrent, machineMatrixRawSumPack] + +@[simp] theorem machineMatrixRawSumAcc_pack (rows current acc bound) : + machineMatrixRawSumAcc + (machineMatrixRawSumPack rows current acc bound) = acc := by + simp [machineMatrixRawSumAcc, machineMatrixRawSumPack] + +@[simp] theorem machineMatrixRawSumBound_pack (rows current acc bound) : + machineMatrixRawSumBound + (machineMatrixRawSumPack rows current acc bound) = bound := by + simp [machineMatrixRawSumBound, machineMatrixRawSumPack] + +/-- Requires exact sum-state packing, row and current-suffix lengths bounded by the input +length, bounded accumulator length, and the prescribed bound word. -/ +def MachineMatrixRawSumStateBound (word state : List Bool) : Prop := + state = machineMatrixRawSumPack + (machineMatrixRawSumRows state) (machineMatrixRawSumCurrent state) + (machineMatrixRawSumAcc state) (machineMatrixRawSumBound state) ∧ + (machineMatrixRawSumRows state).length ≀ word.length ∧ + (machineMatrixRawSumCurrent state).length ≀ word.length ∧ + (machineMatrixRawSumAcc state).length ≀ + (machineMatrixRawSumInputBound word).length ∧ + machineMatrixRawSumBound state = machineMatrixRawSumInputBound word + +theorem machineMatrixRawSumInit_bound (word : List Bool) : + MachineMatrixRawSumStateBound word (machineMatrixRawSumInit word) := by + simp only [MachineMatrixRawSumStateBound, machineMatrixRawSumInit, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le word + Β· simp [machineMatrixRawSumInputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.zero, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineMatrixRawSumStep_bound {word state : List Bool} + (hstate : MachineMatrixRawSumStateBound word state) : + MachineMatrixRawSumStateBound word (machineMatrixRawSumStep state) := by + rcases hstate with ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + by_cases hc : machineMatrixRawSumCurrent state = [] + Β· rw [machineMatrixRawSumStep, hc, machineIfEmpty_nil] + by_cases hr : machineMatrixRawSumRows state = [] + Β· rw [machineMatrixRawSumAfterRow, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + Β· rw [machineMatrixRawSumAfterRow] + cases hrowsCode : machineMatrixRawSumRows state with + | nil => exact False.elim (hr hrowsCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixRawSumLoadRow] + simp only [MachineMatrixRawSumStateBound, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, ?_, ?_, hacc, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixRawSumRows state)).trans hrows + Β· exact (machinePairFirst_length_le + (machineMatrixRawSumRows state)).trans hrows + Β· rw [machineMatrixRawSumStep] + cases hcurrentCode : machineMatrixRawSumCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixRawSumProcessEntry] + simp only [MachineMatrixRawSumStateBound, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, hrows, ?_, ?_, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixRawSumCurrent state)).trans hcurrent + Β· rw [machineMatrixRawSumNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineMatrixRawSumIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixRawSumStateBound word + ((machineMatrixRawSumStep)^[k] (machineMatrixRawSumInit word)) := by + intro k + induction k with + | zero => exact machineMatrixRawSumInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixRawSumStep_bound ih + +theorem machineMatrixRawSumIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineMatrixRawSumStep)^[iterations] + (machineMatrixRawSumInit word)).length ≀ + (machineMatrixRawSumWidth word).length := by + rcases machineMatrixRawSumIterate_bound word iterations with + ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + rw [hdecomp, hbound] + simp only [machineMatrixRawSumPack, machineMatrixRawSumWidth, pair_length] + omega + +theorem machineMatrixRawSumFinalState_mem_FP : + machineMatrixRawSumFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixRawSumStep_mem_FP + machineMatrixRawSumInit_mem_FP id_mem_FP machineMatrixRawSumWidth_mem_FP + machineMatrixRawSumIterate_length_le_width + +theorem machineMatrixRawSumCode_mem_FP : + machineMatrixRawSumCode ∈ Complexity.FP := by + simpa only [machineMatrixRawSumCode] using! + machineCompose_mem_FP machineMatrixRawSumFinalState_mem_FP + machineMatrixRawSumAcc_mem_FP + +theorem machineMatrixSumOutputCode_mem_FP : + machineMatrixSumOutputCode ∈ Complexity.FP := by + simpa only [machineMatrixSumOutputCode] using! + machineCompose_mem_FP machineMatrixRawSumCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineMatrixNormalizationScaleRawCode_mem_FP : + machineMatrixNormalizationScaleRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineMatrixRawSumCode_mem_FP + simpa only [machineMatrixNormalizationScaleRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineMatrixNormalizationScaleOutputCode_mem_FP : + machineMatrixNormalizationScaleOutputCode ∈ Complexity.FP := by + simpa only [machineMatrixNormalizationScaleOutputCode] using! + machineCompose_mem_FP machineMatrixNormalizationScaleRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +/-! ## Semantic invariant and exactness -/ + +/-- Sums the raw rational widths of a list's entries, adding one per entry for accumulator +growth. -/ +def rawRatListCost (xs : List β„š) : β„• := + (xs.map fun q => rawRatWidth (rawRatOfRat q) + 1).sum + +/-- Sums the raw rational list costs of all matrix rows. -/ +def rawRatRowsCost (rows : List (List β„š)) : β„• := + (rows.map rawRatListCost).sum + +/-- Adds a list of rational entries to a raw rational accumulator from left to right. -/ +def rawRatListSum : RawRat β†’ List β„š β†’ RawRat + | acc, [] => acc + | acc, q :: qs => rawRatListSum (acc.add (rawRatOfRat q)) qs + +/-- Adds successive rational rows to a raw rational accumulator, processing each row from left +to right. -/ +def rawRatRowsSum : RawRat β†’ List (List β„š) β†’ RawRat + | acc, [] => acc + | acc, row :: rows => rawRatRowsSum (rawRatListSum acc row) rows + +theorem rawRatWidth_listSum_le (acc : RawRat) : βˆ€ xs : List β„š, + rawRatWidth (rawRatListSum acc xs) ≀ rawRatWidth acc + rawRatListCost xs := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRatListSum, rawRatListCost] + | cons q qs ih => + rw [rawRatListSum] + have hadd := rawRatWidth_add_le acc (rawRatOfRat q) + have htail := ih (acc.add (rawRatOfRat q)) + simp only [rawRatListCost, List.map_cons, List.sum_cons] at htail ⊒ + omega + +theorem rawRatWidth_rowsSum_le (acc : RawRat) : βˆ€ rows : List (List β„š), + rawRatWidth (rawRatRowsSum acc rows) ≀ + rawRatWidth acc + rawRatRowsCost rows := by + intro rows + induction rows generalizing acc with + | nil => simp [rawRatRowsSum, rawRatRowsCost] + | cons row rows ih => + rw [rawRatRowsSum] + have hrow := rawRatWidth_listSum_le acc row + have htail := ih (rawRatListSum acc row) + simp only [rawRatRowsCost, List.map_cons, List.sum_cons] at htail ⊒ + omega + +theorem integerNatAbs_size_le_binaryCode_length (z : β„€) : + z.natAbs.size ≀ (integerBinaryCode z).length := by + cases z with + | ofNat n => + simp [integerBinaryCode, Nat.size_eq_bits_len] + | negSucc n => + have hs : (n + 1).size ≀ n.size + 1 := by + rw [Nat.size_le] + have hle : n + 1 ≀ 2 ^ n.size := + Nat.succ_le_iff.mpr (Nat.lt_size_self n) + have hlt : 2 ^ n.size < 2 ^ (n.size + 1) := by + rw [pow_succ] + have hpos : 0 < 2 ^ n.size := by positivity + omega + exact hle.trans_lt hlt + simpa [integerBinaryCode, Nat.size_eq_bits_len, + Nat.add_comm] using! hs + +theorem rawRatWidth_le_binaryCode_length (q : RawRat) : + rawRatWidth q ≀ (rawRatBinaryCode q).length := by + rw [rawRatWidth, rawRatBinaryCode, pair_length] + apply max_le + Β· have h := integerNatAbs_size_le_binaryCode_length q.num + omega + Β· rw [Nat.size_eq_bits_len] + omega + +theorem rawRatBinaryCode_length_le_width (q : RawRat) : + (rawRatBinaryCode q).length ≀ 4 + 3 * rawRatWidth q := by + rw [rawRatBinaryCode, pair_length] + have hnum : (integerBinaryCode q.num).length ≀ 1 + rawRatWidth q := by + cases hqnum : q.num with + | ofNat n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have habs := rawRat_num_size_le_width q + simp only [hqnum, Int.natAbs_ofNat'] at habs + omega + | negSucc n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have hsize : n.size ≀ (n + 1).size := + Nat.size_le_size (Nat.le_succ n) + have habs : (n + 1).size ≀ rawRatWidth q := by + simpa only [hqnum, Int.natAbs_negSucc] using! + rawRat_num_size_le_width q + omega + have hden := rawRat_den_size_le_width q + have hdenBits : q.den.bits.length ≀ rawRatWidth q := by + rw [Nat.size_eq_bits_len] + exact hden + omega + +/-- The ordinary finite-word encoding of an explicitly normalized rational +has length linear in the width of the unreduced input. This is the bridge +between the exact `DataEncode` estimate used by the arithmetic analysis and +the concrete binary words carried by the machine implementation. -/ +theorem rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (q : RawRat) : + (rationalEntryBinaryCode (binaryNormalizeRawRat q)).length ≀ + 64 + 36 * rawRatWidth q := by + rw [← rawRatBinaryCode_rawRatOfRat] + have hcode := rawRatBinaryCode_length_le_width + (rawRatOfRat (binaryNormalizeRawRat q)) + have hwidth := rawRatOfRat_width_le_encodedBitLength + (binaryNormalizeRawRat q) + have hnormalize := binaryNormalizeRawRat_encodedBitLength_le q + omega + +theorem rawRatListCost_le_codeLength (xs : List β„š) : + rawRatListCost xs ≀ (binaryListCode rationalEntryBinaryCode xs).length := by + induction xs with + | nil => simp [rawRatListCost, binaryListCode] + | cons q qs ih => + rw [rawRatListCost, List.map_cons, List.sum_cons, + binaryListCode, pair_length] + have ih' : (qs.map fun q => rawRatWidth (rawRatOfRat q) + 1).sum ≀ + (binaryListCode rationalEntryBinaryCode qs).length := by + simpa only [rawRatListCost] using! ih + have hq : rawRatWidth (rawRatOfRat q) ≀ + (rationalEntryBinaryCode q).length := by + rw [← rawRatBinaryCode_rawRatOfRat] + exact rawRatWidth_le_binaryCode_length _ + omega + +theorem rawRatRowsCost_le_codeLength (rows : List (List β„š)) : + rawRatRowsCost rows ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + induction rows with + | nil => simp [rawRatRowsCost, binaryListCode] + | cons row rows ih => + rw [rawRatRowsCost, List.map_cons, List.sum_cons, + binaryListCode, pair_length] + have ih' : (rows.map rawRatListCost).sum ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + simpa only [rawRatRowsCost] using! ih + have hrow := rawRatListCost_le_codeLength row + omega + +structure MatrixRawSumSemState where + /-- The unprocessed rows of the semantic raw matrix-sum scan. -/ + rows : List (List β„š) + /-- The unprocessed suffix of the row currently being summed. -/ + current : List β„š + /-- The raw rational sum accumulated from processed matrix entries. -/ + acc : RawRat + +/-- Adds the next current-row entry, loads the next row when needed, and fixes a state with no +entries or rows remaining. -/ +def matrixRawSumSemStep (s : MatrixRawSumSemState) : MatrixRawSumSemState := + match s.current with + | q :: qs => ⟨s.rows, qs, s.acc.add (rawRatOfRat q)⟩ + | [] => + match s.rows with + | row :: rows => ⟨rows, row, s.acc⟩ + | [] => s + +/-- Encodes the semantic scan's remaining rows, current suffix, and raw accumulator using the +supplied bound word. -/ +def matrixRawSumSemCode (bound : List Bool) + (s : MatrixRawSumSemState) : List Bool := + machineMatrixRawSumPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) s.rows) + (binaryListCode rationalEntryBinaryCode s.current) + (rawRatBinaryCode s.acc) bound + +/-- Bounds the accumulator width plus the costs of all unprocessed current-row entries and +remaining rows by the supplied budget. -/ +def MatrixRawSumSemInvariant (budget : β„•) + (s : MatrixRawSumSemState) : Prop := + rawRatWidth s.acc + rawRatListCost s.current + rawRatRowsCost s.rows ≀ budget + +theorem matrixRawSumSemStep_invariant {budget : β„•} + {s : MatrixRawSumSemState} (hs : MatrixRawSumSemInvariant budget s) : + MatrixRawSumSemInvariant budget (matrixRawSumSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => exact hs + | cons row rows => + simp [MatrixRawSumSemInvariant, matrixRawSumSemStep, + rawRatRowsCost, rawRatListCost] at hs ⊒ + omega + | cons q qs => + have hadd := rawRatWidth_add_le acc (rawRatOfRat q) + simp only [MatrixRawSumSemInvariant, matrixRawSumSemStep, + rawRatListCost, List.map_cons, List.sum_cons] at hs ⊒ + omega + +theorem matrixRawSumBound_large (word : List Bool) : + 4 + 3 * (1 + word.length) ≀ + (machineMatrixRawSumInputBound word).length := by + simp only [machineMatrixRawSumInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineMatrixRawSumStep_semantics + (word : List Bool) (s : MatrixRawSumSemState) + (hs : MatrixRawSumSemInvariant (1 + word.length) s) : + machineMatrixRawSumStep + (matrixRawSumSemCode (machineMatrixRawSumInputBound word) s) = + matrixRawSumSemCode (machineMatrixRawSumInputBound word) + (matrixRawSumSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => + simp [matrixRawSumSemCode, matrixRawSumSemStep, + machineMatrixRawSumStep, machineMatrixRawSumAfterRow, + binaryListCode] + | cons row rows => + rw [matrixRawSumSemCode, matrixRawSumSemStep, + machineMatrixRawSumStep] + simp only [machineMatrixRawSumCurrent_pack, binaryListCode, + machineIfEmpty_nil, machineMatrixRawSumAfterRow, + machineMatrixRawSumRows_pack] + have hpair : pair (binaryListCode rationalEntryBinaryCode row) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) β‰  [] := by + intro h + have hlen := congrArg List.length h + simp at hlen + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hpair] + simp [machineMatrixRawSumLoadRow, matrixRawSumSemCode, + machineListHead, machineListTail] + | cons q qs => + have hnext : rawRatWidth (acc.add (rawRatOfRat q)) ≀ 1 + word.length := by + have hinv := matrixRawSumSemStep_invariant hs + have hinv' : rawRatWidth (acc.add (rawRatOfRat q)) + + rawRatListCost qs + rawRatRowsCost rows ≀ 1 + word.length := by + simpa only [MatrixRawSumSemInvariant, matrixRawSumSemStep] using! hinv + omega + have hcode : + (rawRatBinaryCode (acc.add (rawRatOfRat q))).length ≀ + (machineMatrixRawSumInputBound word).length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans + (matrixRawSumBound_large word)) + rw [matrixRawSumSemCode, matrixRawSumSemStep, + machineMatrixRawSumStep] + simp only [machineMatrixRawSumCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineMatrixRawSumProcessEntry, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack, + machineListTail_cons, machineMatrixRawSumNextAcc, + machineMatrixRawSumCandidate, machineMatrixRawSumEntry, + machineListHead_cons] + rw [← rawRatBinaryCode_rawRatOfRat q, + machineRawRatAddCode_encode] + rw [(List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineMatrixRawSumIterate_semantics + (word : List Bool) (s : MatrixRawSumSemState) + (hs : MatrixRawSumSemInvariant (1 + word.length) s) : βˆ€ k, + (machineMatrixRawSumStep)^[k] + (matrixRawSumSemCode (machineMatrixRawSumInputBound word) s) = + matrixRawSumSemCode (machineMatrixRawSumInputBound word) + ((matrixRawSumSemStep)^[k] s) := by + intro k + have hinv : βˆ€ t : β„•, + MatrixRawSumSemInvariant (1 + word.length) + ((matrixRawSumSemStep)^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact matrixRawSumSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineMatrixRawSumStep_semantics word _ (hinv k) + +theorem matrixRawSumSem_processRow + (rows : List (List β„š)) (row : List β„š) (acc : RawRat) : + (matrixRawSumSemStep)^[row.length] + ⟨rows, row, acc⟩ = ⟨rows, [], rawRatListSum acc row⟩ := by + induction row generalizing acc with + | nil => rfl + | cons q qs ih => + rw [List.length_cons, Function.iterate_succ_apply, + matrixRawSumSemStep, ih] + rfl + +theorem matrixRawSumSem_processRows + (rows : List (List β„š)) (acc : RawRat) : + (matrixRawSumSemStep)^[matrixNonnegativeRowsWork rows] + ⟨rows, [], acc⟩ = ⟨[], [], rawRatRowsSum acc rows⟩ := by + induction rows generalizing acc with + | nil => rfl + | cons row rows ih => + rw [matrixNonnegativeRowsWork, show 1 + row.length + + matrixNonnegativeRowsWork rows = + matrixNonnegativeRowsWork rows + row.length + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one, matrixRawSumSemStep, + matrixRawSumSem_processRow, ih, rawRatRowsSum] + +theorem matrixRawSumSem_done_iterate (extra : β„•) (acc : RawRat) : + (matrixRawSumSemStep)^[extra] ⟨[], [], acc⟩ = ⟨[], [], acc⟩ := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + rfl + +theorem machineMatrixRawSum_done_iterate + (extra : β„•) (acc : RawRat) (bound : List Bool) : + (machineMatrixRawSumStep)^[extra] + (machineMatrixRawSumPack [] [] (rawRatBinaryCode acc) bound) = + machineMatrixRawSumPack [] [] (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineMatrixRawSumStep, machineMatrixRawSumAfterRow] + +theorem machineMatrixRawSumFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixRawSumFinalState + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + machineMatrixRawSumPack [] [] + (rawRatBinaryCode + (rawRatRowsSum RawRat.zero (rationalMatrixRows A))) + (machineMatrixRawSumInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) := by + let rows := rationalMatrixRows A + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let s : MatrixRawSumSemState := ⟨rows, [], RawRat.zero⟩ + have hrowsLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ word.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le word + have hinv : MatrixRawSumSemInvariant (1 + word.length) s := by + simp only [MatrixRawSumSemInvariant, s, rawRatListCost, + List.map_nil, List.sum_nil, rawRatWidth_zero, Nat.add_zero] + exact Nat.add_le_add_left + ((rawRatRowsCost_le_codeLength rows).trans hrowsLength) 1 + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsLength + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + have hinit : machineMatrixRawSumInit word = + matrixRawSumSemCode (machineMatrixRawSumInputBound word) s := by + simp [machineMatrixRawSumInit, matrixRawSumSemCode, s, word, rows, + binaryListCode] + change machineMatrixRawSumFinalState word = _ + rw [machineMatrixRawSumFinalState, hsplit, Function.iterate_add_apply, + hinit, machineMatrixRawSumIterate_semantics word s hinv, + matrixRawSumSem_processRows] + simp only [matrixRawSumSemCode, binaryListCode] + rw [machineMatrixRawSum_done_iterate] + +@[simp] theorem machineMatrixRawSumCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixRawSumCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawRatRowsSum RawRat.zero (rationalMatrixRows A)) := by + rw [machineMatrixRawSumCode, machineMatrixRawSumFinalState_encode] + simp + +theorem rawRatListSum_value (acc : RawRat) : βˆ€ xs : List β„š, + (rawRatListSum acc xs).value = acc.value + xs.sum := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRatListSum] + | cons q qs ih => + rw [rawRatListSum, ih] + simp [rawRatOfRat_value, add_assoc] + +theorem rawRatRowsSum_value (acc : RawRat) : βˆ€ rows : List (List β„š), + (rawRatRowsSum acc rows).value = + acc.value + (rows.map List.sum).sum := by + intro rows + induction rows generalizing acc with + | nil => simp [rawRatRowsSum] + | cons row rows ih => + rw [rawRatRowsSum, ih, rawRatListSum_value] + simp [add_assoc] + +theorem rationalMatrixRows_sum {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + ((rationalMatrixRows A).map List.sum).sum = + βˆ‘ i, βˆ‘ j, A i j := by + simp [rationalMatrixRows, List.sum_ofFn] + +@[simp] theorem machineMatrixSumOutputCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixSumOutputCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (βˆ‘ i, βˆ‘ j, A i j) := by + rw [machineMatrixSumOutputCode, machineMatrixRawSumCode_encode, + machineNormalizeRawRatBinaryCode_encode, binaryNormalizeRawRat_eq_value, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum] + +@[simp] theorem machineMatrixNormalizationScaleRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScaleRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (RawRat.one.add + (rawRatRowsSum RawRat.zero (rationalMatrixRows A))) := by + rw [machineMatrixNormalizationScaleRawCode, + machineMatrixRawSumCode_encode, machineRawRatAddCode_encode] + +@[simp] theorem machineMatrixNormalizationScaleOutputCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixNormalizationScaleOutputCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (1 + βˆ‘ i, βˆ‘ j, A i j) := by + rw [machineMatrixNormalizationScaleOutputCode, + machineMatrixNormalizationScaleRawCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_add, + RawRat.value_one, rawRatRowsSum_value, RawRat.value_zero, + zero_add, rationalMatrixRows_sum] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSupportProduct.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSupportProduct.lean new file mode 100644 index 0000000000..bc0b4d289c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineMatrixSupportProduct.lean @@ -0,0 +1,618 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineBooleanMemory +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly + +/-! +# Row-major support product of a rational matrix + +The support floor multiplies every nonzero matrix entry while letting a zero +entry contribute the neutral factor one. This file implements that scan on +the concrete nested binary matrix encoding. The accumulator is an unreduced +rational; a quadratic clamp is total on malformed inputs and is proved +inactive on canonical matrices. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Tests whether the current matrix entry differs from zero in raw rational arithmetic. -/ +def machineMatrixSupportNonzeroFlag (state : List Bool) : List Bool := + machineRawRatNeBit + (pair (machineMatrixRawSumEntry state) + (rawRatBinaryCode RawRat.zero)) + +/-- Uses the current nonzero matrix entry as a support-product factor and substitutes one for +zero entries. -/ +def machineMatrixSupportFactorCode (state : List Bool) : List Bool := + machineIfHead (machineMatrixSupportNonzeroFlag state) + (machineMatrixRawSumEntry state) (rawRatBinaryCode RawRat.one) + +/-- Multiplies the support-product accumulator by the current entry's nonzero-or-one factor. -/ +def machineMatrixSupportCandidate (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineMatrixRawSumAcc state) + (machineMatrixSupportFactorCode state)) + +/-- Truncates the updated support-product accumulator to the length of the stored bound. -/ +def machineMatrixSupportNextAcc (state : List Bool) : List Bool := + (machineMatrixSupportCandidate state).take + (machineMatrixRawSumBound state).length + +/-- Consumes one current-row entry and stores the bounded updated support-product accumulator. -/ +def machineMatrixSupportProcessEntry (state : List Bool) : List Bool := + machineMatrixRawSumPack + (machineMatrixRawSumRows state) + (machineListTail (machineMatrixRawSumCurrent state)) + (machineMatrixSupportNextAcc state) + (machineMatrixRawSumBound state) + +/-- Reuses the raw matrix scan's row-loading operation for the support-product scan. -/ +def machineMatrixSupportLoadRow (state : List Bool) : List Bool := + machineMatrixRawSumLoadRow state + +/-- Fixes an exhausted support-product scan or loads the next row if one remains. -/ +def machineMatrixSupportAfterRow (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixRawSumRows state) state + (machineMatrixSupportLoadRow state) + +/-- Processes the next current-row support factor, or loads another row when the current one is +empty. -/ +def machineMatrixSupportStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixRawSumCurrent state) + (machineMatrixSupportAfterRow state) + (machineMatrixSupportProcessEntry state) + +/-- Applies the binary-multiplication width construction to bound the support-product +accumulator. -/ +def machineMatrixSupportInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Initializes the support-product scan with all matrix rows, empty current row, multiplicative +identity, and its input bound. -/ +def machineMatrixSupportInit (word : List Bool) : List Bool := + machineMatrixRawSumPack (machineMatrixRowsWord word) [] + (rawRatBinaryCode RawRat.one) (machineMatrixSupportInputBound word) + +/-- Packs the original word twice and the support-product bound twice to bound the complete scan +state. -/ +def machineMatrixSupportWidth (word : List Bool) : List Bool := + let bound := machineMatrixSupportInputBound word + machineMatrixRawSumPack word word bound bound + +/-- Runs the support-product scan once per input bit from its initial state. -/ +def machineMatrixSupportFinalState (word : List Bool) : List Bool := + (machineMatrixSupportStep)^[word.length] (machineMatrixSupportInit word) + +/-- Extracts the raw support-product accumulator from the final scan state. -/ +def machineMatrixSupportRawCode (word : List Bool) : List Bool := + machineMatrixRawSumAcc (machineMatrixSupportFinalState word) + +/-- Normalizes the raw product of nonzero matrix entries into the rational binary output +encoding. -/ +def machineMatrixSupportProductCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineMatrixSupportRawCode word) + +theorem machineMatrixSupportNonzeroFlag_mem_FP : + machineMatrixSupportNonzeroFlag ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixRawSumEntry_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + simpa only [machineMatrixSupportNonzeroFlag] using! + machineCompose_mem_FP hpair machineRawRatNeBit_mem_FP + +theorem machineMatrixSupportFactorCode_mem_FP : + machineMatrixSupportFactorCode ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineMatrixSupportNonzeroFlag_mem_FP + machineMatrixRawSumEntry_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + +theorem machineMatrixSupportCandidate_mem_FP : + machineMatrixSupportCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixRawSumAcc_mem_FP + machineMatrixSupportFactorCode_mem_FP + simpa only [machineMatrixSupportCandidate] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineMatrixSupportNextAcc_mem_FP : + machineMatrixSupportNextAcc ∈ Complexity.FP := by + simpa only [machineMatrixSupportNextAcc] using! + machineTake_mem_FP machineMatrixRawSumBound_mem_FP + machineMatrixSupportCandidate_mem_FP + +theorem machineMatrixSupportProcessEntry_mem_FP : + machineMatrixSupportProcessEntry ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixRawSumCurrent_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP machineMatrixRawSumRows_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP machineMatrixSupportNextAcc_mem_FP + machineMatrixRawSumBound_mem_FP)) + +theorem machineMatrixSupportLoadRow_mem_FP : + machineMatrixSupportLoadRow ∈ Complexity.FP := by + simpa only [machineMatrixSupportLoadRow] using! + machineMatrixRawSumLoadRow_mem_FP + +theorem machineMatrixSupportAfterRow_mem_FP : + machineMatrixSupportAfterRow ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixRawSumRows_mem_FP id_mem_FP + machineMatrixSupportLoadRow_mem_FP + +theorem machineMatrixSupportStep_mem_FP : + machineMatrixSupportStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixRawSumCurrent_mem_FP + machineMatrixSupportAfterRow_mem_FP + machineMatrixSupportProcessEntry_mem_FP + +theorem machineMatrixSupportInputBound_mem_FP : + machineMatrixSupportInputBound ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineMatrixSupportInit_mem_FP : + machineMatrixSupportInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineMatrixSupportInputBound_mem_FP)) + +theorem machineMatrixSupportWidth_mem_FP : + machineMatrixSupportWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineMatrixSupportInputBound_mem_FP + machineMatrixSupportInputBound_mem_FP)) + +theorem machineMatrixSupportInit_bound (word : List Bool) : + MachineMatrixRawSumStateBound word (machineMatrixSupportInit word) := by + simp only [MachineMatrixRawSumStateBound, machineMatrixSupportInit, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, ?_, by simp, ?_, rfl⟩ + Β· simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le word + Β· simp [machineMatrixRawSumInputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.one, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineMatrixSupportStep_bound {word state : List Bool} + (hstate : MachineMatrixRawSumStateBound word state) : + MachineMatrixRawSumStateBound word (machineMatrixSupportStep state) := by + rcases hstate with ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + by_cases hc : machineMatrixRawSumCurrent state = [] + Β· rw [machineMatrixSupportStep, hc, machineIfEmpty_nil] + by_cases hr : machineMatrixRawSumRows state = [] + Β· rw [machineMatrixSupportAfterRow, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + Β· rw [machineMatrixSupportAfterRow] + cases hrowsCode : machineMatrixRawSumRows state with + | nil => exact False.elim (hr hrowsCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixSupportLoadRow] + rw [machineMatrixRawSumLoadRow] + simp only [MachineMatrixRawSumStateBound, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, ?_, ?_, hacc, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixRawSumRows state)).trans hrows + Β· exact (machinePairFirst_length_le + (machineMatrixRawSumRows state)).trans hrows + Β· rw [machineMatrixSupportStep] + cases hcurrentCode : machineMatrixRawSumCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixSupportProcessEntry] + simp only [MachineMatrixRawSumStateBound, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack] + refine ⟨trivial, hrows, ?_, ?_, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixRawSumCurrent state)).trans hcurrent + Β· rw [machineMatrixSupportNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineMatrixSupportIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixRawSumStateBound word + ((machineMatrixSupportStep)^[k] (machineMatrixSupportInit word)) := by + intro k + induction k with + | zero => exact machineMatrixSupportInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixSupportStep_bound ih + +theorem machineMatrixSupportIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineMatrixSupportStep)^[iterations] + (machineMatrixSupportInit word)).length ≀ + (machineMatrixSupportWidth word).length := by + rcases machineMatrixSupportIterate_bound word iterations with + ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + have hbound' : + machineMatrixRawSumBound + ((machineMatrixSupportStep)^[iterations] + (machineMatrixSupportInit word)) = + machineMatrixSupportInputBound word := by + simpa only [machineMatrixSupportInputBound, + machineMatrixRawSumInputBound] using! hbound + have hacc' : + (machineMatrixRawSumAcc + ((machineMatrixSupportStep)^[iterations] + (machineMatrixSupportInit word))).length ≀ + (machineMatrixSupportInputBound word).length := by + simpa only [machineMatrixSupportInputBound, + machineMatrixRawSumInputBound] using! hacc + rw [hdecomp, hbound'] + simp only [machineMatrixRawSumPack, machineMatrixSupportWidth, pair_length] + omega + +theorem machineMatrixSupportFinalState_mem_FP : + machineMatrixSupportFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixSupportStep_mem_FP + machineMatrixSupportInit_mem_FP id_mem_FP + machineMatrixSupportWidth_mem_FP + machineMatrixSupportIterate_length_le_width + +theorem machineMatrixSupportRawCode_mem_FP : + machineMatrixSupportRawCode ∈ Complexity.FP := by + simpa only [machineMatrixSupportRawCode] using! + machineCompose_mem_FP machineMatrixSupportFinalState_mem_FP + machineMatrixRawSumAcc_mem_FP + +theorem machineMatrixSupportProductCode_mem_FP : + machineMatrixSupportProductCode ∈ Complexity.FP := by + simpa only [machineMatrixSupportProductCode] using! + machineCompose_mem_FP machineMatrixSupportRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +/-! ## Exact semantics -/ + +/-- Replaces zero by the raw multiplicative identity and converts each nonzero rational to its +raw representation. -/ +def rawRatSupportFactor (q : β„š) : RawRat := + if q = 0 then RawRat.one else rawRatOfRat q + +/-- Multiplies the nonzero entries of a rational list into a raw accumulator, treating zero +entries as factors of one. -/ +def rawRatListSupportProduct : RawRat β†’ List β„š β†’ RawRat + | acc, [] => acc + | acc, q :: qs => + rawRatListSupportProduct (acc.mul (rawRatSupportFactor q)) qs + +/-- Multiplies the nonzero entries of successive rational rows into a raw accumulator. -/ +def rawRatRowsSupportProduct : RawRat β†’ List (List β„š) β†’ RawRat + | acc, [] => acc + | acc, row :: rows => + rawRatRowsSupportProduct (rawRatListSupportProduct acc row) rows + +/-- Multiplies in one support factor, loads another row when necessary, and fixes the exhausted +semantic scan. -/ +def matrixSupportSemStep (s : MatrixRawSumSemState) : MatrixRawSumSemState := + match s.current with + | q :: qs => ⟨s.rows, qs, s.acc.mul (rawRatSupportFactor q)⟩ + | [] => + match s.rows with + | row :: rows => ⟨rows, row, s.acc⟩ + | [] => s + +/-- Bounds the support-product accumulator width plus all remaining entry costs by the supplied +budget. -/ +def MatrixSupportSemInvariant (budget : β„•) + (s : MatrixRawSumSemState) : Prop := + rawRatWidth s.acc + rawRatListCost s.current + rawRatRowsCost s.rows ≀ budget + +theorem rawRatWidth_supportFactor_le (q : β„š) : + rawRatWidth (rawRatSupportFactor q) ≀ + rawRatWidth (rawRatOfRat q) + 1 := by + by_cases hq : q = 0 + Β· simp [rawRatSupportFactor, hq, rawRatWidth_one] + Β· simp [rawRatSupportFactor, hq] + +theorem matrixSupportSemStep_invariant {budget : β„•} + {s : MatrixRawSumSemState} (hs : MatrixSupportSemInvariant budget s) : + MatrixSupportSemInvariant budget (matrixSupportSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => exact hs + | cons row rows => + simp [MatrixSupportSemInvariant, matrixSupportSemStep, + rawRatRowsCost, rawRatListCost] at hs ⊒ + omega + | cons q qs => + have hmul := rawRatWidth_mul_le acc (rawRatSupportFactor q) + have hfactor := rawRatWidth_supportFactor_le q + simp only [MatrixSupportSemInvariant, matrixSupportSemStep, + rawRatListCost, List.map_cons, List.sum_cons] at hs ⊒ + omega + +theorem matrixSupportBound_large (word : List Bool) : + 4 + 3 * (1 + word.length) ≀ + (machineMatrixSupportInputBound word).length := by + simp only [machineMatrixSupportInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +@[simp] theorem machineMatrixSupportFactorCode_semantics + (rows : List (List β„š)) (q : β„š) (qs : List β„š) + (acc : RawRat) (bound : List Bool) : + machineMatrixSupportFactorCode + (matrixRawSumSemCode bound ⟨rows, q :: qs, acc⟩) = + rawRatBinaryCode (rawRatSupportFactor q) := by + rw [machineMatrixSupportFactorCode, machineMatrixSupportNonzeroFlag] + simp only [matrixRawSumSemCode, machineMatrixRawSumEntry, + machineMatrixRawSumCurrent_pack, machineListHead_cons, + ← rawRatBinaryCode_rawRatOfRat, machineRawRatNeBit_encode, + RawRat.value_zero, rawRatOfRat_value] + by_cases hq : q = 0 + Β· simp [hq, rawRatSupportFactor] + Β· simp [hq, rawRatSupportFactor] + +theorem machineMatrixSupportStep_semantics + (word : List Bool) (s : MatrixRawSumSemState) + (hs : MatrixSupportSemInvariant (1 + word.length) s) : + machineMatrixSupportStep + (matrixRawSumSemCode (machineMatrixSupportInputBound word) s) = + matrixRawSumSemCode (machineMatrixSupportInputBound word) + (matrixSupportSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => + simp [matrixRawSumSemCode, matrixSupportSemStep, + machineMatrixSupportStep, machineMatrixSupportAfterRow, + binaryListCode] + | cons row rows => + rw [matrixRawSumSemCode, matrixSupportSemStep, + machineMatrixSupportStep] + simp only [machineMatrixRawSumCurrent_pack, binaryListCode, + machineIfEmpty_nil, machineMatrixSupportAfterRow, + machineMatrixRawSumRows_pack] + have hpair : pair (binaryListCode rationalEntryBinaryCode row) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) β‰  [] := by + intro h + have hlen := congrArg List.length h + simp at hlen + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hpair] + simp [machineMatrixSupportLoadRow, machineMatrixRawSumLoadRow, + matrixRawSumSemCode, machineListHead, machineListTail] + | cons q qs => + have hnext : + rawRatWidth (acc.mul (rawRatSupportFactor q)) ≀ + 1 + word.length := by + have hinv := matrixSupportSemStep_invariant hs + have hinv' : rawRatWidth (acc.mul (rawRatSupportFactor q)) + + rawRatListCost qs + rawRatRowsCost rows ≀ 1 + word.length := by + simpa only [MatrixSupportSemInvariant, + matrixSupportSemStep] using! hinv + omega + have hcode : + (rawRatBinaryCode (acc.mul (rawRatSupportFactor q))).length ≀ + (machineMatrixSupportInputBound word).length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans + (matrixSupportBound_large word)) + have hfactor : + machineMatrixSupportFactorCode + (machineMatrixRawSumPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode (q :: qs)) + (rawRatBinaryCode acc) + (machineMatrixSupportInputBound word)) = + rawRatBinaryCode (rawRatSupportFactor q) := by + simpa only [matrixRawSumSemCode] using! + machineMatrixSupportFactorCode_semantics rows q qs acc + (machineMatrixSupportInputBound word) + rw [matrixRawSumSemCode, matrixSupportSemStep, + machineMatrixSupportStep] + simp only [machineMatrixRawSumCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineMatrixSupportProcessEntry, + machineMatrixRawSumRows_pack, machineMatrixRawSumCurrent_pack, + machineMatrixRawSumAcc_pack, machineMatrixRawSumBound_pack, + machineListTail_cons, machineMatrixSupportNextAcc, + machineMatrixSupportCandidate] + rw [hfactor, machineRawRatMulCode_encode] + rw [(List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineMatrixSupportIterate_semantics + (word : List Bool) (s : MatrixRawSumSemState) + (hs : MatrixSupportSemInvariant (1 + word.length) s) : βˆ€ k, + (machineMatrixSupportStep)^[k] + (matrixRawSumSemCode (machineMatrixSupportInputBound word) s) = + matrixRawSumSemCode (machineMatrixSupportInputBound word) + ((matrixSupportSemStep)^[k] s) := by + intro k + have hinv : βˆ€ t : β„•, + MatrixSupportSemInvariant (1 + word.length) + ((matrixSupportSemStep)^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact matrixSupportSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineMatrixSupportStep_semantics word _ (hinv k) + +theorem matrixSupportSem_processRow + (rows : List (List β„š)) (row : List β„š) (acc : RawRat) : + (matrixSupportSemStep)^[row.length] ⟨rows, row, acc⟩ = + ⟨rows, [], rawRatListSupportProduct acc row⟩ := by + induction row generalizing acc with + | nil => rfl + | cons q qs ih => + rw [List.length_cons, Function.iterate_succ_apply, + matrixSupportSemStep, ih] + rfl + +theorem matrixSupportSem_processRows + (rows : List (List β„š)) (acc : RawRat) : + (matrixSupportSemStep)^[matrixNonnegativeRowsWork rows] + ⟨rows, [], acc⟩ = + ⟨[], [], rawRatRowsSupportProduct acc rows⟩ := by + induction rows generalizing acc with + | nil => rfl + | cons row rows ih => + rw [matrixNonnegativeRowsWork, show 1 + row.length + + matrixNonnegativeRowsWork rows = + matrixNonnegativeRowsWork rows + row.length + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one, matrixSupportSemStep, + matrixSupportSem_processRow, ih, rawRatRowsSupportProduct] + +theorem machineMatrixSupport_done_iterate + (extra : β„•) (acc : RawRat) (bound : List Bool) : + (machineMatrixSupportStep)^[extra] + (machineMatrixRawSumPack [] [] (rawRatBinaryCode acc) bound) = + machineMatrixRawSumPack [] [] (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineMatrixSupportStep, machineMatrixSupportAfterRow] + +theorem machineMatrixSupportFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixSupportFinalState + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + machineMatrixRawSumPack [] [] + (rawRatBinaryCode + (rawRatRowsSupportProduct RawRat.one (rationalMatrixRows A))) + (machineMatrixSupportInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) := by + let rows := rationalMatrixRows A + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let s : MatrixRawSumSemState := ⟨rows, [], RawRat.one⟩ + have hrowsLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ word.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le word + have hinv : MatrixSupportSemInvariant (1 + word.length) s := by + simp only [MatrixSupportSemInvariant, s, rawRatListCost, + List.map_nil, List.sum_nil, rawRatWidth_one, Nat.add_zero] + exact Nat.add_le_add_left + ((rawRatRowsCost_le_codeLength rows).trans hrowsLength) 1 + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsLength + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + have hinit : machineMatrixSupportInit word = + matrixRawSumSemCode (machineMatrixSupportInputBound word) s := by + simp [machineMatrixSupportInit, matrixRawSumSemCode, s, word, rows, + binaryListCode] + change machineMatrixSupportFinalState word = _ + rw [machineMatrixSupportFinalState, hsplit, Function.iterate_add_apply, + hinit, machineMatrixSupportIterate_semantics word s hinv, + matrixSupportSem_processRows] + simp only [matrixRawSumSemCode, binaryListCode] + rw [machineMatrixSupport_done_iterate] + +@[simp] theorem machineMatrixSupportRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixSupportRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawRatRowsSupportProduct RawRat.one (rationalMatrixRows A)) := by + rw [machineMatrixSupportRawCode, machineMatrixSupportFinalState_encode] + simp + +@[simp] theorem machineMatrixSupportProductCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixSupportProductCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode + (binaryNormalizeRawRat + (rawRatRowsSupportProduct RawRat.one (rationalMatrixRows A))) := by + rw [machineMatrixSupportProductCode, + machineMatrixSupportRawCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +theorem rawRatSupportFactor_value (q : β„š) : + (rawRatSupportFactor q).value = if q = 0 then 1 else q := by + by_cases hq : q = 0 + Β· simp [rawRatSupportFactor, hq, RawRat.value_one] + Β· simp [rawRatSupportFactor, hq, rawRatOfRat_value] + +theorem rawRatListSupportProduct_value (acc : RawRat) : βˆ€ xs : List β„š, + (rawRatListSupportProduct acc xs).value = + acc.value * (xs.map fun q ↦ if q = 0 then 1 else q).prod := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRatListSupportProduct] + | cons q qs ih => + rw [rawRatListSupportProduct, ih, RawRat.value_mul, + rawRatSupportFactor_value] + simp only [List.map_cons, List.prod_cons] + ring + +theorem rawRatRowsSupportProduct_value (acc : RawRat) : + βˆ€ rows : List (List β„š), + (rawRatRowsSupportProduct acc rows).value = + acc.value * + (rows.map fun row ↦ + (row.map fun q ↦ if q = 0 then 1 else q).prod).prod := by + intro rows + induction rows generalizing acc with + | nil => simp [rawRatRowsSupportProduct] + | cons row rows ih => + rw [rawRatRowsSupportProduct, ih, + rawRatListSupportProduct_value] + simp only [List.map_cons, List.prod_cons] + ring + +theorem rawRatRowsSupportProduct_eq_rationalSupportFloor {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (rawRatRowsSupportProduct RawRat.one + (rationalMatrixRows A)).value = rationalSupportFloor A := by + rw [rawRatRowsSupportProduct_value] + simp only [RawRat.value_one, one_mul, rationalMatrixRows, List.map_ofFn, + List.prod_ofFn, Function.comp_apply] + have hproduct : + (∏ i : Fin n, ∏ j : Fin n, + if A i j = 0 then 1 else A i j) = + ∏ p ∈ (Finset.univ.product Finset.univ), + if A p.1 p.2 = 0 then 1 else A p.1 p.2 := by + simpa using! + (Finset.prod_product' (Finset.univ : Finset (Fin n)) + (Finset.univ : Finset (Fin n)) + (fun i j ↦ if A i j = 0 then 1 else A i j)).symm + rw [hproduct, rationalSupportFloor] + apply Finset.prod_congr rfl + intro p hp + simp only [rationalSupportFactor] + +@[simp] theorem machineMatrixSupportProductCode_rationalSupportFloor {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixSupportProductCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (rationalSupportFloor A) := by + rw [machineMatrixSupportProductCode_encode, + binaryNormalizeRawRat_eq_value, + rawRatRowsSupportProduct_eq_rationalSupportFloor] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineNaturalCombinators.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineNaturalCombinators.lean new file mode 100644 index 0000000000..0d49496df0 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineNaturalCombinators.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul + +/-! # Machine Natural Combinators -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Combinators for binary-natural word machines + +These wrappers keep later arithmetic schedules readable. They do not add a +new computational primitive: each is just pairing followed by the verified +binary addition or multiplication machine. +-/ + +/-- Adds the binary outputs of two machines evaluated on the same input word. -/ +def machineBinaryAddOf (f g : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineBinaryAddBits (pair (f word) (g word)) + +/-- Multiplies the binary outputs of two machines evaluated on the same input word. -/ +def machineBinaryMulOf (f g : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineBinaryMulBits (pair (f word) (g word)) + +/-- Returns the binary natural-number code for the fixed constant `k`, independently of the +input. -/ +def machineBinaryConst (k : β„•) (_word : List Bool) : List Bool := k.bits + +theorem machineBinaryAddOf_mem_FP {f g : List Bool β†’ List Bool} + (hf : f ∈ FP) (hg : g ∈ FP) : machineBinaryAddOf f g ∈ FP := by + simpa only [machineBinaryAddOf] using! + machineCompose_mem_FP (machinePair_mem_FP hf hg) + machineBinaryAddBits_mem_FP + +theorem machineBinaryMulOf_mem_FP {f g : List Bool β†’ List Bool} + (hf : f ∈ FP) (hg : g ∈ FP) : machineBinaryMulOf f g ∈ FP := by + simpa only [machineBinaryMulOf] using! + machineCompose_mem_FP (machinePair_mem_FP hf hg) + machineBinaryMulBits_mem_FP + +theorem machineBinaryConst_mem_FP (k : β„•) : machineBinaryConst k ∈ FP := by + simpa only [machineBinaryConst] using! machineConst_mem_FP k.bits + +@[simp] theorem machineBinaryAddOf_natBits + (f g : List Bool β†’ List Bool) (word : List Bool) (a b : β„•) + (hf : f word = a.bits) (hg : g word = b.bits) : + machineBinaryAddOf f g word = (a + b).bits := by + rw [machineBinaryAddOf, hf, hg, machineBinaryAddBits_pair_natBits] + +@[simp] theorem machineBinaryMulOf_natBits + (f g : List Bool β†’ List Bool) (word : List Bool) (a b : β„•) + (hf : f word = a.bits) (hg : g word = b.bits) : + machineBinaryMulOf f g word = (a * b).bits := by + rw [machineBinaryMulOf, hf, hg, machineBinaryMulBits_pair_natBits] + +@[simp] theorem machineBinaryConst_apply (k : β„•) (word : List Bool) : + machineBinaryConst k word = k.bits := rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyCoordinate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyCoordinate.lean new file mode 100644 index 0000000000..172c1c9007 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyCoordinate.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLog +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization + +/-! +# One directed nearby-Bethe coordinate as a finite-word function + +The input is `pair precision (pair tau x)`, where precision is unary, `tau` is +an arbitrary raw rational, and `x` is a canonical rational-entry word. The +output is the unreduced rational + +`scheduledLogLower (1-x) p + tau*x*scheduledLogLower x p`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary precision ruler from a nearby-coordinate request. -/ +def machineNearbyCoordinatePrecisionRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the regularization-and-coordinate payload following the precision ruler. -/ +def machineNearbyCoordinatePayload (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the raw regularization parameter from a nearby-coordinate request. -/ +def machineNearbyCoordinateTauRawCode (word : List Bool) : List Bool := + machinePairFirst (machineNearbyCoordinatePayload word) + +/-- Extracts the encoded rational coordinate from a nearby-coordinate request. -/ +def machineNearbyCoordinateXCode (word : List Bool) : List Bool := + machinePairSecond (machineNearbyCoordinatePayload word) + +/-- Negates the encoded coordinate in raw rational arithmetic. -/ +def machineNearbyCoordinateNegXRawCode (word : List Bool) : List Bool := + machineRawRatNegCode (machineNearbyCoordinateXCode word) + +/-- Adds raw one to the negated coordinate to compute its unnormalized complement. -/ +def machineNearbyCoordinateComplementUnnormalizedRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair rawRatOneCode (machineNearbyCoordinateNegXRawCode word)) + +/-- Normalize before logarithm scheduling so that range reduction reads the +canonical numerator and denominator lengths of `1-x`. -/ +def machineNearbyCoordinateComplementCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineNearbyCoordinateComplementUnnormalizedRawCode word) + +/-- Computes the scheduled lower logarithm approximation of the coordinate complement at the +requested precision. -/ +def machineNearbyCoordinateLogComplementRawCode + (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (pair (machineNearbyCoordinatePrecisionRuler word) + (machineNearbyCoordinateComplementCode word)) + +/-- Computes the scheduled lower logarithm approximation of the coordinate at the requested +precision. -/ +def machineNearbyCoordinateLogXRawCode (word : List Bool) : List Bool := + machineScheduledLogLowerRawCode + (pair (machineNearbyCoordinatePrecisionRuler word) + (machineNearbyCoordinateXCode word)) + +/-- Multiplies the raw regularization parameter by the coordinate. -/ +def machineNearbyCoordinateTauTimesXRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineNearbyCoordinateTauRawCode word) + (machineNearbyCoordinateXCode word)) + +/-- Multiplies the regularized coordinate by its scheduled lower logarithm approximation. -/ +def machineNearbyCoordinateWeightedLogXRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineNearbyCoordinateTauTimesXRawCode word) + (machineNearbyCoordinateLogXRawCode word)) + +/-- Adds the lower complement logarithm to the regularized coordinate times its lower logarithm. -/ +def machineNearbyCoordinateLowerRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineNearbyCoordinateLogComplementRawCode word) + (machineNearbyCoordinateWeightedLogXRawCode word)) + +theorem machineNearbyCoordinatePrecisionRuler_mem_FP : + machineNearbyCoordinatePrecisionRuler ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineNearbyCoordinatePayload_mem_FP : + machineNearbyCoordinatePayload ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineNearbyCoordinateTauRawCode_mem_FP : + machineNearbyCoordinateTauRawCode ∈ Complexity.FP := by + simpa only [machineNearbyCoordinateTauRawCode] using! + machineCompose_mem_FP machineNearbyCoordinatePayload_mem_FP + machinePairFirst_mem_FP + +theorem machineNearbyCoordinateXCode_mem_FP : + machineNearbyCoordinateXCode ∈ Complexity.FP := by + simpa only [machineNearbyCoordinateXCode] using! + machineCompose_mem_FP machineNearbyCoordinatePayload_mem_FP + machinePairSecond_mem_FP + +theorem machineNearbyCoordinateNegXRawCode_mem_FP : + machineNearbyCoordinateNegXRawCode ∈ Complexity.FP := by + simpa only [machineNearbyCoordinateNegXRawCode] using! + machineCompose_mem_FP machineNearbyCoordinateXCode_mem_FP + machineRawRatNegCode_mem_FP + +theorem machineNearbyCoordinateComplementUnnormalizedRawCode_mem_FP : + machineNearbyCoordinateComplementUnnormalizedRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) + machineNearbyCoordinateNegXRawCode_mem_FP + simpa only [machineNearbyCoordinateComplementUnnormalizedRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineNearbyCoordinateComplementCode_mem_FP : + machineNearbyCoordinateComplementCode ∈ Complexity.FP := by + simpa only [machineNearbyCoordinateComplementCode] using! + machineCompose_mem_FP + machineNearbyCoordinateComplementUnnormalizedRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineNearbyCoordinateLogComplementRawCode_mem_FP : + machineNearbyCoordinateLogComplementRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineNearbyCoordinatePrecisionRuler_mem_FP + machineNearbyCoordinateComplementCode_mem_FP + simpa only [machineNearbyCoordinateLogComplementRawCode] using! + machineCompose_mem_FP hpair machineScheduledLogLowerRawCode_mem_FP + +theorem machineNearbyCoordinateLogXRawCode_mem_FP : + machineNearbyCoordinateLogXRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineNearbyCoordinatePrecisionRuler_mem_FP + machineNearbyCoordinateXCode_mem_FP + simpa only [machineNearbyCoordinateLogXRawCode] using! + machineCompose_mem_FP hpair machineScheduledLogLowerRawCode_mem_FP + +theorem machineNearbyCoordinateTauTimesXRawCode_mem_FP : + machineNearbyCoordinateTauTimesXRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineNearbyCoordinateTauRawCode_mem_FP + machineNearbyCoordinateXCode_mem_FP + simpa only [machineNearbyCoordinateTauTimesXRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineNearbyCoordinateWeightedLogXRawCode_mem_FP : + machineNearbyCoordinateWeightedLogXRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineNearbyCoordinateTauTimesXRawCode_mem_FP + machineNearbyCoordinateLogXRawCode_mem_FP + simpa only [machineNearbyCoordinateWeightedLogXRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineNearbyCoordinateLowerRawCode_mem_FP : + machineNearbyCoordinateLowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineNearbyCoordinateLogComplementRawCode_mem_FP + machineNearbyCoordinateWeightedLogXRawCode_mem_FP + simpa only [machineNearbyCoordinateLowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +/-- Computes raw one minus the rational coordinate without reducing the resulting fraction. -/ +def rawNearbyCoordinateComplement (x : β„š) : RawRat := + RawRat.one.add (rawRatOfRat x).neg + +/-- Forms the raw expression `logLower(1 - x) + tau * x * logLower(x)` at precision `p`. -/ +def rawNearbyCoordinateLower (tau : RawRat) (x : β„š) (p : β„•) : RawRat := + (rawScheduledLogLower (1 - x) p).add + ((tau.mul (rawRatOfRat x)).mul (rawScheduledLogLower x p)) + +@[simp] theorem machineNearbyCoordinateComplementUnnormalizedRawCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateComplementUnnormalizedRawCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (rawNearbyCoordinateComplement x) := by + rw [machineNearbyCoordinateComplementUnnormalizedRawCode, + machineNearbyCoordinateNegXRawCode, + machineNearbyCoordinateXCode, machineNearbyCoordinatePayload] + simp only [machinePairSecond_pair, machineRawRatNegCode_encode, + ← rawRatBinaryCode_rawRatOfRat, rawRatOneCode] + rw [machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineNearbyCoordinateComplementCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateComplementCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (rawRatOfRat (1 - x)) := by + rw [machineNearbyCoordinateComplementCode, + machineNearbyCoordinateComplementUnnormalizedRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value] + simp [rawNearbyCoordinateComplement, RawRat.value_add, + RawRat.value_one, RawRat.value_neg, rawRatOfRat_value] + ring + +@[simp] theorem machineNearbyCoordinateLogComplementRawCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateLogComplementRawCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (rawScheduledLogLower (1 - x) p) := by + rw [machineNearbyCoordinateLogComplementRawCode] + simp only [machineNearbyCoordinatePrecisionRuler, + machinePairFirst_pair, machineNearbyCoordinateComplementCode_encode, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineNearbyCoordinateLogXRawCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateLogXRawCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (rawScheduledLogLower x p) := by + rw [machineNearbyCoordinateLogXRawCode] + simp only [machineNearbyCoordinatePrecisionRuler, + machinePairFirst_pair, machineNearbyCoordinateXCode, + machineNearbyCoordinatePayload, machinePairSecond_pair, + ← rawRatBinaryCode_rawRatOfRat, + machineScheduledLogLowerRawCode_encode] + +@[simp] theorem machineNearbyCoordinateTauTimesXRawCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateTauTimesXRawCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (tau.mul (rawRatOfRat x)) := by + rw [machineNearbyCoordinateTauTimesXRawCode] + simp only [machineNearbyCoordinateTauRawCode, + machineNearbyCoordinateXCode, machineNearbyCoordinatePayload, + machinePairSecond_pair, machinePairFirst_pair, + ← rawRatBinaryCode_rawRatOfRat, machineRawRatMulCode_encode] + +@[simp] theorem machineNearbyCoordinateLowerRawCode_encode + (tau : RawRat) (x : β„š) (p : β„•) : + machineNearbyCoordinateLowerRawCode + (pair (List.replicate p true) + (pair (rawRatBinaryCode tau) (rationalEntryBinaryCode x))) = + rawRatBinaryCode (rawNearbyCoordinateLower tau x p) := by + rw [machineNearbyCoordinateLowerRawCode, + machineNearbyCoordinateLogComplementRawCode_encode, + machineNearbyCoordinateWeightedLogXRawCode, + machineNearbyCoordinateTauTimesXRawCode_encode, + machineNearbyCoordinateLogXRawCode_encode, + machineRawRatMulCode_encode, machineRawRatAddCode_encode] + rfl + +theorem rawNearbyCoordinateLower_value + (tau : RawRat) (x : β„š) (p : β„•) : + (rawNearbyCoordinateLower tau x p).value = + directedNearbyCoordinateLower tau.value x p := by + simp [rawNearbyCoordinateLower, directedNearbyCoordinateLower, + RawRat.value_add, RawRat.value_mul, rawRatOfRat_value, + rawScheduledLogLower_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyMatrixSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyMatrixSum.lean new file mode 100644 index 0000000000..26cec13631 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineNearbyMatrixSum.lean @@ -0,0 +1,1031 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineScheduledLogWidth + +/-! +# Row-major evaluation of the nearby-Bethe coordinate sum + +This module scans the matrix carried by a canonical optimizer-output word and +accumulates + +`sum_ij directedNearbyCoordinateLower tau X_ij p`. + +The concrete transducer is total on arbitrary bitstrings. Its raw rational +accumulator is clamped by an explicit iterated-quadratic word; the semantic +section proves separately that this clamp is inactive on canonical inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Packs the fixed source, remaining rows, current row suffix, accumulator, and bound for the +nearby-matrix sum. -/ +def machineNearbyMatrixPack + (source rows current acc bound : List Bool) : List Bool := + pair source (pair rows (pair current (pair acc bound))) + +/-- Extracts the fixed problem source from a nearby-matrix scan state. -/ +def machineNearbyMatrixSource (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the remaining encoded matrix rows from a nearby-matrix scan state. -/ +def machineNearbyMatrixRows (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the current row suffix from a nearby-matrix scan state. -/ +def machineNearbyMatrixCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the raw accumulated nearby-coordinate sum from a scan state. -/ +def machineNearbyMatrixAcc (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the accumulator length-bound word from a nearby-matrix scan state. -/ +def machineNearbyMatrixBound (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Reads the next entry of the current matrix-row suffix. -/ +def machineNearbyMatrixEntry (state : List Bool) : List Bool := + machineListHead (machineNearbyMatrixCurrent state) + +/-- Packages the source's certificate precision and regularization scale with the current matrix +entry. -/ +def machineNearbyMatrixCoordinateInput (state : List Bool) : List Bool := + pair + (machineCertificateLogPrecisionRuler (machineNearbyMatrixSource state)) + (pair + (machineCertificateRegularizationScaleRawCode + (machineNearbyMatrixSource state)) + (machineNearbyMatrixEntry state)) + +/-- Computes the current matrix entry's directed nearby-coordinate lower expression. -/ +def machineNearbyMatrixCoordinateRawCode (state : List Bool) : List Bool := + machineNearbyCoordinateLowerRawCode + (machineNearbyMatrixCoordinateInput state) + +/-- Adds the current nearby-coordinate expression to the raw accumulator. -/ +def machineNearbyMatrixCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineNearbyMatrixAcc state) + (machineNearbyMatrixCoordinateRawCode state)) + +/-- Truncates the updated nearby-matrix accumulator to the stored bound length. -/ +def machineNearbyMatrixNextAcc (state : List Bool) : List Bool := + (machineNearbyMatrixCandidate state).take + (machineNearbyMatrixBound state).length + +/-- Consumes the current matrix entry and stores the bounded updated accumulator while retaining +source, remaining rows, and bound. -/ +def machineNearbyMatrixProcessEntry (state : List Bool) : List Bool := + machineNearbyMatrixPack + (machineNearbyMatrixSource state) + (machineNearbyMatrixRows state) + (machineListTail (machineNearbyMatrixCurrent state)) + (machineNearbyMatrixNextAcc state) + (machineNearbyMatrixBound state) + +/-- Loads the next matrix row while preserving the source, nearby-term accumulator, and width +bound. -/ +def machineNearbyMatrixLoadRow (state : List Bool) : List Bool := + machineNearbyMatrixPack + (machineNearbyMatrixSource state) + (machineListTail (machineNearbyMatrixRows state)) + (machineListHead (machineNearbyMatrixRows state)) + (machineNearbyMatrixAcc state) + (machineNearbyMatrixBound state) + +/-- Loads another row when available, otherwise retaining the completed nearby-sum state. -/ +def machineNearbyMatrixAfterRow (state : List Bool) : List Bool := + machineIfEmpty (machineNearbyMatrixRows state) state + (machineNearbyMatrixLoadRow state) + +/-- Adds the next nearby-coordinate term or loads a row when the current row is exhausted. -/ +def machineNearbyMatrixStep (state : List Bool) : List Bool := + machineIfEmpty (machineNearbyMatrixCurrent state) + (machineNearbyMatrixAfterRow state) + (machineNearbyMatrixProcessEntry state) + +/-- An explicit degree-eight accumulator envelope. Repeated application of +`machineBinaryMulWidth` is a concrete finite-word construction, not an +existential polynomial ruler. -/ +def machineNearbyMatrixInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth + (machineBinaryMulWidth (machineBinaryMulWidth word)) + +/-- Extracts the optimizer matrix's encoded rows for nearby-coordinate summation. -/ +def machineNearbyMatrixRowsWord (word : List Bool) : List Bool := + machineMatrixRowsWord (machineOptimizerMatrixWord word) + +/-- Initializes nearby-coordinate summation with all rows, zero accumulator, and input-derived +bound. -/ +def machineNearbyMatrixInit (word : List Bool) : List Bool := + machineNearbyMatrixPack word (machineNearbyMatrixRowsWord word) [] + (rawRatBinaryCode RawRat.zero) (machineNearbyMatrixInputBound word) + +/-- Builds a width envelope for the source, remaining rows, current row, accumulator, and bound. -/ +def machineNearbyMatrixWidth (word : List Bool) : List Bool := + let bound := machineNearbyMatrixInputBound word + machineNearbyMatrixPack word word word bound bound + +/-- Runs nearby-coordinate summation for one step per input bit. -/ +def machineNearbyMatrixFinalState (word : List Bool) : List Bool := + (machineNearbyMatrixStep)^[word.length] (machineNearbyMatrixInit word) + +/-- Extracts the accumulated raw-rational nearby-coordinate sum after the full scan. -/ +def machineNearbyMatrixRawSumCode (word : List Bool) : List Bool := + machineNearbyMatrixAcc (machineNearbyMatrixFinalState word) + +theorem machineNearbyMatrixSource_mem_FP : + machineNearbyMatrixSource ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineNearbyMatrixRows_mem_FP : + machineNearbyMatrixRows ∈ Complexity.FP := by + simpa only [machineNearbyMatrixRows] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineNearbyMatrixCurrent_mem_FP : + machineNearbyMatrixCurrent ∈ Complexity.FP := by + simpa only [machineNearbyMatrixCurrent] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineNearbyMatrixAcc_mem_FP : + machineNearbyMatrixAcc ∈ Complexity.FP := by + simpa only [machineNearbyMatrixAcc] using! + machineCompose_mem_FP + (machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineNearbyMatrixBound_mem_FP : + machineNearbyMatrixBound ∈ Complexity.FP := by + simpa only [machineNearbyMatrixBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineNearbyMatrixEntry_mem_FP : + machineNearbyMatrixEntry ∈ Complexity.FP := by + simpa only [machineNearbyMatrixEntry] using! + machineCompose_mem_FP machineNearbyMatrixCurrent_mem_FP + machineListHead_mem_FP + +theorem machineNearbyMatrixCoordinateInput_mem_FP : + machineNearbyMatrixCoordinateInput ∈ Complexity.FP := by + have hp := machineCompose_mem_FP machineNearbyMatrixSource_mem_FP + machineCertificateLogPrecisionRuler_mem_FP + have htau := machineCompose_mem_FP machineNearbyMatrixSource_mem_FP + machineCertificateRegularizationScaleRawCode_mem_FP + exact machinePair_mem_FP hp + (machinePair_mem_FP htau machineNearbyMatrixEntry_mem_FP) + +theorem machineNearbyMatrixCoordinateRawCode_mem_FP : + machineNearbyMatrixCoordinateRawCode ∈ Complexity.FP := by + simpa only [machineNearbyMatrixCoordinateRawCode] using! + machineCompose_mem_FP machineNearbyMatrixCoordinateInput_mem_FP + machineNearbyCoordinateLowerRawCode_mem_FP + +theorem machineNearbyMatrixCandidate_mem_FP : + machineNearbyMatrixCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineNearbyMatrixAcc_mem_FP + machineNearbyMatrixCoordinateRawCode_mem_FP + simpa only [machineNearbyMatrixCandidate] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineNearbyMatrixNextAcc_mem_FP : + machineNearbyMatrixNextAcc ∈ Complexity.FP := by + simpa only [machineNearbyMatrixNextAcc] using! + machineTake_mem_FP machineNearbyMatrixBound_mem_FP + machineNearbyMatrixCandidate_mem_FP + +theorem machineNearbyMatrixProcessEntry_mem_FP : + machineNearbyMatrixProcessEntry ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineNearbyMatrixCurrent_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP machineNearbyMatrixSource_mem_FP + (machinePair_mem_FP machineNearbyMatrixRows_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP machineNearbyMatrixNextAcc_mem_FP + machineNearbyMatrixBound_mem_FP))) + +theorem machineNearbyMatrixLoadRow_mem_FP : + machineNearbyMatrixLoadRow ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineNearbyMatrixRows_mem_FP + machineListTail_mem_FP + have hhead := machineCompose_mem_FP machineNearbyMatrixRows_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP machineNearbyMatrixSource_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP hhead + (machinePair_mem_FP machineNearbyMatrixAcc_mem_FP + machineNearbyMatrixBound_mem_FP))) + +theorem machineNearbyMatrixAfterRow_mem_FP : + machineNearbyMatrixAfterRow ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineNearbyMatrixRows_mem_FP id_mem_FP + machineNearbyMatrixLoadRow_mem_FP + +theorem machineNearbyMatrixStep_mem_FP : + machineNearbyMatrixStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineNearbyMatrixCurrent_mem_FP + machineNearbyMatrixAfterRow_mem_FP machineNearbyMatrixProcessEntry_mem_FP + +theorem machineNearbyMatrixInputBound_mem_FP : + machineNearbyMatrixInputBound ∈ Complexity.FP := by + have h1 := machineBinaryMulWidth_mem_FP + have h2 := machineCompose_mem_FP h1 machineBinaryMulWidth_mem_FP + simpa only [machineNearbyMatrixInputBound] using! + machineCompose_mem_FP h2 machineBinaryMulWidth_mem_FP + +theorem machineNearbyMatrixRowsWord_mem_FP : + machineNearbyMatrixRowsWord ∈ Complexity.FP := by + simpa only [machineNearbyMatrixRowsWord] using! + machineCompose_mem_FP machineOptimizerMatrixWord_mem_FP + machineMatrixRowsWord_mem_FP + +theorem machineNearbyMatrixInit_mem_FP : + machineNearbyMatrixInit ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineNearbyMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineNearbyMatrixInputBound_mem_FP))) + +theorem machineNearbyMatrixWidth_mem_FP : + machineNearbyMatrixWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineNearbyMatrixInputBound_mem_FP + machineNearbyMatrixInputBound_mem_FP))) + +@[simp] theorem machineNearbyMatrixSource_pack (source rows current acc bound) : + machineNearbyMatrixSource + (machineNearbyMatrixPack source rows current acc bound) = source := by + simp [machineNearbyMatrixSource, machineNearbyMatrixPack] + +@[simp] theorem machineNearbyMatrixRows_pack (source rows current acc bound) : + machineNearbyMatrixRows + (machineNearbyMatrixPack source rows current acc bound) = rows := by + simp [machineNearbyMatrixRows, machineNearbyMatrixPack] + +@[simp] theorem machineNearbyMatrixCurrent_pack + (source rows current acc bound) : + machineNearbyMatrixCurrent + (machineNearbyMatrixPack source rows current acc bound) = current := by + simp [machineNearbyMatrixCurrent, machineNearbyMatrixPack] + +@[simp] theorem machineNearbyMatrixAcc_pack (source rows current acc bound) : + machineNearbyMatrixAcc + (machineNearbyMatrixPack source rows current acc bound) = acc := by + simp [machineNearbyMatrixAcc, machineNearbyMatrixPack] + +@[simp] theorem machineNearbyMatrixBound_pack (source rows current acc bound) : + machineNearbyMatrixBound + (machineNearbyMatrixPack source rows current acc bound) = bound := by + simp [machineNearbyMatrixBound, machineNearbyMatrixPack] + +/-- Bounds the scan state lengths while preserving its source and input-derived accumulator +bound. -/ +def MachineNearbyMatrixStateBound (word state : List Bool) : Prop := + state = machineNearbyMatrixPack + (machineNearbyMatrixSource state) (machineNearbyMatrixRows state) + (machineNearbyMatrixCurrent state) (machineNearbyMatrixAcc state) + (machineNearbyMatrixBound state) ∧ + machineNearbyMatrixSource state = word ∧ + (machineNearbyMatrixRows state).length ≀ word.length ∧ + (machineNearbyMatrixCurrent state).length ≀ word.length ∧ + (machineNearbyMatrixAcc state).length ≀ + (machineNearbyMatrixInputBound word).length ∧ + machineNearbyMatrixBound state = machineNearbyMatrixInputBound word + +theorem machineNearbyMatrixInit_bound (word : List Bool) : + MachineNearbyMatrixStateBound word (machineNearbyMatrixInit word) := by + simp only [MachineNearbyMatrixStateBound, machineNearbyMatrixInit, + machineNearbyMatrixSource_pack, machineNearbyMatrixRows_pack, + machineNearbyMatrixCurrent_pack, machineNearbyMatrixAcc_pack, + machineNearbyMatrixBound_pack] + refine ⟨trivial, trivial, ?_, by simp, ?_, trivial⟩ + Β· exact (machinePairSecond_length_le + (machineOptimizerMatrixWord word)).trans + ((machinePairFirst_length_le word)) + Β· simp [machineNearbyMatrixInputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.zero, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineNearbyMatrixStep_bound {word state : List Bool} + (hstate : MachineNearbyMatrixStateBound word state) : + MachineNearbyMatrixStateBound word (machineNearbyMatrixStep state) := by + rcases hstate with + ⟨hdecomp, hsource, hrows, hcurrent, hacc, hbound⟩ + by_cases hc : machineNearbyMatrixCurrent state = [] + Β· rw [machineNearbyMatrixStep, hc, machineIfEmpty_nil] + by_cases hr : machineNearbyMatrixRows state = [] + Β· rw [machineNearbyMatrixAfterRow, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hsource, hrows, hcurrent, hacc, hbound⟩ + Β· rw [machineNearbyMatrixAfterRow] + cases hrowsCode : machineNearbyMatrixRows state with + | nil => exact False.elim (hr hrowsCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineNearbyMatrixLoadRow] + simp only [MachineNearbyMatrixStateBound, + machineNearbyMatrixSource_pack, machineNearbyMatrixRows_pack, + machineNearbyMatrixCurrent_pack, machineNearbyMatrixAcc_pack, + machineNearbyMatrixBound_pack] + refine ⟨trivial, hsource, ?_, ?_, hacc, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineNearbyMatrixRows state)).trans hrows + Β· exact (machinePairFirst_length_le + (machineNearbyMatrixRows state)).trans hrows + Β· rw [machineNearbyMatrixStep] + cases hcurrentCode : machineNearbyMatrixCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineNearbyMatrixProcessEntry] + simp only [MachineNearbyMatrixStateBound, + machineNearbyMatrixSource_pack, machineNearbyMatrixRows_pack, + machineNearbyMatrixCurrent_pack, machineNearbyMatrixAcc_pack, + machineNearbyMatrixBound_pack] + refine ⟨trivial, hsource, hrows, ?_, ?_, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineNearbyMatrixCurrent state)).trans hcurrent + Β· rw [machineNearbyMatrixNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineNearbyMatrixIterate_bound (word : List Bool) : βˆ€ k, + MachineNearbyMatrixStateBound word + ((machineNearbyMatrixStep)^[k] (machineNearbyMatrixInit word)) := by + intro k + induction k with + | zero => exact machineNearbyMatrixInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineNearbyMatrixStep_bound ih + +theorem machineNearbyMatrixIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineNearbyMatrixStep)^[iterations] + (machineNearbyMatrixInit word)).length ≀ + (machineNearbyMatrixWidth word).length := by + rcases machineNearbyMatrixIterate_bound word iterations with + ⟨hdecomp, hsource, hrows, hcurrent, hacc, hbound⟩ + rw [hdecomp, hsource, hbound] + simp only [machineNearbyMatrixPack, machineNearbyMatrixWidth, pair_length] + omega + +theorem machineNearbyMatrixFinalState_mem_FP : + machineNearbyMatrixFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineNearbyMatrixStep_mem_FP + machineNearbyMatrixInit_mem_FP id_mem_FP machineNearbyMatrixWidth_mem_FP + machineNearbyMatrixIterate_length_le_width + +theorem machineNearbyMatrixRawSumCode_mem_FP : + machineNearbyMatrixRawSumCode ∈ Complexity.FP := by + simpa only [machineNearbyMatrixRawSumCode] using! + machineCompose_mem_FP machineNearbyMatrixFinalState_mem_FP + machineNearbyMatrixAcc_mem_FP + +/-! ## Semantic invariant and exactness before discharging the size bound -/ + +/-- Sums the raw widths plus one of nearby-coordinate lower approximations for a rational row. -/ +def rawNearbyListCost (tau : RawRat) (p : β„•) (xs : List β„š) : β„• := + (xs.map fun q => rawRatWidth (rawNearbyCoordinateLower tau q p) + 1).sum + +/-- Sums the nearby-coordinate width costs across a list of rational rows. -/ +def rawNearbyRowsCost (tau : RawRat) (p : β„•) + (rows : List (List β„š)) : β„• := + (rows.map (rawNearbyListCost tau p)).sum + +/-- Uniform raw-width budget for one coordinate whose canonical matrix entry, +matrix dimension, and requested precision are all controlled by a word of +length `L`. The constants come directly from the normalized complement, +the `n + 400` schedule, and the fixed regularization constant. -/ +def rawNearbyCoordinateInputWidthBudget (L : β„•) : β„• := + 64 * ((L + 400) + 2 * (44 + 12 * L) + 4) ^ 2 * + ((44 + 12 * L) + 2) + + (L + 235) + L + + 64 * ((L + 400) + 2 * L + 4) ^ 2 * (L + 2) + 1 + +theorem rawCertificateRegularizationScale_width_le_optimizer_word + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + rawRatWidth (rawCertificateRegularizationScale n) ≀ + (rationalOptimizerOutputCode ⟨X, R, C⟩).length + 235 := by + let word := rationalOptimizerOutputCode ⟨X, R, C⟩ + have hxi : rawRatWidth rawExplicitXi = 231 := by + rw [rawExplicitXi, explicitXi, explicitDelta, explicitEta, + explicitRowRatio] + norm_num [rawRatOfRat, rawRatWidth] + apply Nat.le_antisymm + Β· apply max_le + Β· norm_num + Β· rw [Nat.size_le] + norm_num + Β· apply le_max_of_le_right + have hsize : 230 < Nat.size + 1785851933491520000000000000000000000000000000000000000000000000000000 := by + rw [Nat.lt_size] + norm_num + omega + have hfour : rawRatWidth rawCertificateFour = 3 := by + decide + have hnraw := RawRat.width_ofNat_le n + have hfourN := rawRatWidth_mul_le rawCertificateFour (RawRat.ofNat n) + have htau := rawRatWidth_div_le rawExplicitXi + (rawCertificateFourDimension n) + have hnMatrix := matrix_dimension_le_code_length X + have hmatrixWord : + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length ≀ word.length := by + simpa only [word, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le word + have hnWord : n ≀ word.length := hnMatrix.trans hmatrixWord + simp only [rawCertificateRegularizationScale, + rawCertificateFourDimension] at htau + rw [hxi] at htau + rw [hfour] at hfourN + rw [rawCertificateRegularizationScale, + rawCertificateFourDimension] + dsimp only [word] at hnWord ⊒ + omega + +theorem rawNearbyCoordinateLower_width_le_optimizer_word + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + {row : List β„š} (hrow : row ∈ rationalMatrixRows X) + {q : β„š} (hq : q ∈ row) : + rawRatWidth + (rawNearbyCoordinateLower (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n)) ≀ + rawNearbyCoordinateInputWidthBudget + (rationalOptimizerOutputCode ⟨X, R, C⟩).length := by + let word := rationalOptimizerOutputCode ⟨X, R, C⟩ + let L := word.length + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows X)).length ≀ L := by + calc + _ = (machineMatrixRowsWord + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩)).length := by + simpa using! congrArg List.length + (machineMatrixRowsWord_encode X).symm + _ ≀ (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length := by + simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩) + _ ≀ word.length := by + simpa only [word, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le word + _ = L := rfl + have hqCode := binaryListCode_element_length_le + rationalEntryBinaryCode hq + have hrowCode := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hrow + have hqWidth : rawRatWidth (rawRatOfRat q) ≀ L := by + have hentryCode : + (rawRatBinaryCode (rawRatOfRat q)).length ≀ L := by + rw [rawRatBinaryCode_rawRatOfRat] + exact hqCode.trans (hrowCode.trans hrowsCode) + exact (rawRatWidth_le_binaryCode_length _).trans hentryCode + have hnMatrix := matrix_dimension_le_code_length X + have hmatrixWord : + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length ≀ L := by + simpa only [L, word, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le word + have hnWord : n ≀ L := hnMatrix.trans hmatrixWord + have hp : directedCertificatePrecision n ≀ L + 400 := by + simp only [directedCertificatePrecision] + omega + have hcompWidth0 := rawRatWidth_complement_le q + have hcompWidth : rawRatWidth (rawRatOfRat (1 - q)) ≀ 44 + 12 * L := by + omega + have hcompLog := rawRatWidth_scheduledLogLower_of_bounds_le + (1 - q) hp hcompWidth + have hqLog := rawRatWidth_scheduledLogLower_of_bounds_le q hp hqWidth + have htau := rawCertificateRegularizationScale_width_le_optimizer_word + X R C + have htx := rawRatWidth_mul_le + (rawCertificateRegularizationScale n) (rawRatOfRat q) + have hweighted := rawRatWidth_mul_le + ((rawCertificateRegularizationScale n).mul (rawRatOfRat q)) + (rawScheduledLogLower q (directedCertificatePrecision n)) + have hadd := rawRatWidth_add_le + (rawScheduledLogLower (1 - q) (directedCertificatePrecision n)) + (((rawCertificateRegularizationScale n).mul (rawRatOfRat q)).mul + (rawScheduledLogLower q (directedCertificatePrecision n))) + rw [rawNearbyCoordinateLower] + simp only [rawNearbyCoordinateInputWidthBudget] + dsimp only [L, word] at hqWidth hcompLog hqLog htx hweighted hadd + exact hadd.trans (by omega) + +theorem rawNearbyListCost_le_uniform {tau : RawRat} {p budget : β„•} : + βˆ€ xs : List β„š, + (βˆ€ q ∈ xs, + rawRatWidth (rawNearbyCoordinateLower tau q p) ≀ budget) β†’ + rawNearbyListCost tau p xs ≀ xs.length * (budget + 1) := by + intro xs hwidth + induction xs with + | nil => simp [rawNearbyListCost] + | cons q qs ih => + have hq := hwidth q (by simp) + have hqs : βˆ€ r ∈ qs, + rawRatWidth (rawNearbyCoordinateLower tau r p) ≀ budget := by + intro r hr + exact hwidth r (by simp [hr]) + have ih' := ih hqs + simp only [rawNearbyListCost] at ih' + simp only [rawNearbyListCost, List.map_cons, List.sum_cons, + List.length_cons] + rw [Nat.succ_mul] + omega + +theorem rawNearbyRowsCost_le_uniform {tau : RawRat} {p budget : β„•} : + βˆ€ rows : List (List β„š), + (βˆ€ row ∈ rows, βˆ€ q ∈ row, + rawRatWidth (rawNearbyCoordinateLower tau q p) ≀ budget) β†’ + rawNearbyRowsCost tau p rows ≀ + (rows.map List.length).sum * (budget + 1) := by + intro rows hwidth + induction rows with + | nil => simp [rawNearbyRowsCost] + | cons row rows ih => + have hrow := rawNearbyListCost_le_uniform row (by + intro q hq + exact hwidth row (by simp) q hq) + have hrows : βˆ€ tailRow ∈ rows, βˆ€ q ∈ tailRow, + rawRatWidth (rawNearbyCoordinateLower tau q p) ≀ budget := by + intro tailRow htail q hq + exact hwidth tailRow (by simp [htail]) q hq + have ih' := ih hrows + simp only [rawNearbyRowsCost] at ih' + simp only [rawNearbyRowsCost, List.map_cons, List.sum_cons, + List.length_cons] + rw [Nat.add_mul] + omega + +theorem rawNearbyRowsCost_le_optimizer_word + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + rawNearbyRowsCost (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) (rationalMatrixRows X) ≀ + (rationalOptimizerOutputCode ⟨X, R, C⟩).length * + (rawNearbyCoordinateInputWidthBudget + (rationalOptimizerOutputCode ⟨X, R, C⟩).length + 1) := by + let rows := rationalMatrixRows X + let word := rationalOptimizerOutputCode ⟨X, R, C⟩ + let budget := rawNearbyCoordinateInputWidthBudget word.length + have hcoordinate : βˆ€ row ∈ rows, βˆ€ q ∈ row, + rawRatWidth + (rawNearbyCoordinateLower (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n)) ≀ budget := by + intro row hrow q hq + simpa only [rows, word, budget] using! + rawNearbyCoordinateLower_width_le_optimizer_word X R C hrow hq + have hcost := rawNearbyRowsCost_le_uniform rows hcoordinate + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineMatrixRowsWord + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩)).length := by + simpa only [rows] using! congrArg List.length + (machineMatrixRowsWord_encode X).symm + _ ≀ (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length := by + simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩) + _ ≀ word.length := by + simpa only [word, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le word + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsCode + have hentries : (rows.map List.length).sum ≀ word.length := by + have hentriesWork : βˆ€ rs : List (List β„š), + (rs.map List.length).sum ≀ matrixNonnegativeRowsWork rs := by + intro rs + induction rs with + | nil => simp [matrixNonnegativeRowsWork] + | cons row rs ih => + simp only [List.map_cons, List.sum_cons, + matrixNonnegativeRowsWork] + omega + exact (hentriesWork rows).trans hwork + have hmul := Nat.mul_le_mul_right (budget + 1) hentries + exact hcost.trans (by simpa only [rows, word, budget] using! hmul) + +theorem machineNearbyMatrixInputBound_length_dominates (word : List Bool) : + 4 + 3 * (1 + word.length * + (rawNearbyCoordinateInputWidthBudget word.length + 1)) ≀ + (machineNearbyMatrixInputBound word).length := by + simp only [rawNearbyCoordinateInputWidthBudget, + machineNearbyMatrixInputBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + by_cases hsmall : word.length < 9 + Β· interval_cases word.length <;> norm_num + Β· have h9 : 9 ≀ word.length := by omega + have hsq : 81 ≀ word.length ^ 2 := by + exact_mod_cast Nat.pow_le_pow_left h9 2 + have hcoef : 272148486 ≀ 3393120 * 81 := by norm_num + have hcover : + 272148486 * word.length ^ 2 ≀ 3393120 * word.length ^ 4 := by + calc + 272148486 * word.length ^ 2 ≀ + (3393120 * 81) * word.length ^ 2 := + Nat.mul_le_mul_right (word.length ^ 2) hcoef + _ ≀ (3393120 * word.length ^ 2) * word.length ^ 2 := by + exact Nat.mul_le_mul_right (word.length ^ 2) + (Nat.mul_le_mul_left 3393120 hsq) + _ = 3393120 * word.length ^ 4 := by ring + ring_nf at hcover ⊒ + omega + +/-- Adds nearby-coordinate lower approximations for a list into a raw-rational accumulator. -/ +def rawNearbyListSum (tau : RawRat) (p : β„•) : + RawRat β†’ List β„š β†’ RawRat + | acc, [] => acc + | acc, q :: qs => + rawNearbyListSum tau p + (acc.add (rawNearbyCoordinateLower tau q p)) qs + +/-- Adds nearby-coordinate lower approximations across all rows into a raw-rational accumulator. -/ +def rawNearbyRowsSum (tau : RawRat) (p : β„•) : + RawRat β†’ List (List β„š) β†’ RawRat + | acc, [] => acc + | acc, row :: rows => + rawNearbyRowsSum tau p (rawNearbyListSum tau p acc row) rows + +structure NearbyMatrixSemState where + /-- Rows not yet loaded by the semantic nearby-coordinate scan. -/ + rows : List (List β„š) + /-- Unprocessed entries of the current semantic scan row. -/ + current : List β„š + /-- Accumulated raw-rational sum of nearby-coordinate lower approximations. -/ + acc : RawRat + +/-- Adds the next nearby-coordinate term, loads another row, or leaves a completed semantic +state fixed. -/ +def nearbyMatrixSemStep (tau : RawRat) (p : β„•) + (s : NearbyMatrixSemState) : NearbyMatrixSemState := + match s.current with + | q :: qs => + ⟨s.rows, qs, s.acc.add (rawNearbyCoordinateLower tau q p)⟩ + | [] => + match s.rows with + | row :: rows => ⟨rows, row, s.acc⟩ + | [] => s + +/-- Encodes a semantic nearby-coordinate scan state together with its source and width bound. -/ +def nearbyMatrixSemCode (source bound : List Bool) + (s : NearbyMatrixSemState) : List Bool := + machineNearbyMatrixPack source + (binaryListCode (binaryListCode rationalEntryBinaryCode) s.rows) + (binaryListCode rationalEntryBinaryCode s.current) + (rawRatBinaryCode s.acc) bound + +/-- Bounds accumulator width plus the remaining nearby-coordinate costs by a fixed budget. -/ +def NearbyMatrixSemInvariant (tau : RawRat) (p budget : β„•) + (s : NearbyMatrixSemState) : Prop := + rawRatWidth s.acc + rawNearbyListCost tau p s.current + + rawNearbyRowsCost tau p s.rows ≀ budget + +theorem nearbyMatrixSemStep_invariant {tau : RawRat} {p budget : β„•} + {s : NearbyMatrixSemState} + (hs : NearbyMatrixSemInvariant tau p budget s) : + NearbyMatrixSemInvariant tau p budget (nearbyMatrixSemStep tau p s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => exact hs + | cons row rows => + simp [NearbyMatrixSemInvariant, nearbyMatrixSemStep, + rawNearbyRowsCost, rawNearbyListCost] at hs ⊒ + omega + | cons q qs => + have hadd := rawRatWidth_add_le acc + (rawNearbyCoordinateLower tau q p) + simp only [NearbyMatrixSemInvariant, nearbyMatrixSemStep, + rawNearbyListCost, List.map_cons, List.sum_cons] at hs ⊒ + omega + +@[simp] theorem machineNearbyMatrixRowsWord_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineNearbyMatrixRowsWord + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows X) := by + simp [machineNearbyMatrixRowsWord] + +@[simp] theorem machineNearbyMatrixCoordinateRawCode_semCode + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rows : List (List β„š)) (q : β„š) (qs : List β„š) + (acc : RawRat) (bound : List Bool) : + machineNearbyMatrixCoordinateRawCode + (nearbyMatrixSemCode (rationalOptimizerOutputCode ⟨X, R, C⟩) + bound ⟨rows, q :: qs, acc⟩) = + rawRatBinaryCode + (rawNearbyCoordinateLower + (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n)) := by + rw [machineNearbyMatrixCoordinateRawCode, + machineNearbyMatrixCoordinateInput] + simp only [nearbyMatrixSemCode, machineNearbyMatrixSource_pack, + machineNearbyMatrixEntry, machineNearbyMatrixCurrent_pack, + machineListHead_cons, machineCertificateLogPrecisionRuler_encode, + machineCertificateRegularizationScaleRawCode_encode, + machineNearbyCoordinateLowerRawCode_encode] + +@[simp] theorem machineNearbyMatrixCoordinateRawCode_pack + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rows : List (List β„š)) (q : β„š) (qs : List β„š) + (acc : RawRat) (bound : List Bool) : + machineNearbyMatrixCoordinateRawCode + (machineNearbyMatrixPack + (rationalOptimizerOutputCode ⟨X, R, C⟩) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (binaryListCode rationalEntryBinaryCode (q :: qs)) + (rawRatBinaryCode acc) bound) = + rawRatBinaryCode + (rawNearbyCoordinateLower + (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n)) := by + simpa only [nearbyMatrixSemCode] using! + machineNearbyMatrixCoordinateRawCode_semCode X R C rows q qs acc bound + +theorem machineNearbyMatrixStep_semantics + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (bound : List Bool) (s : NearbyMatrixSemState) (budget : β„•) + (hs : NearbyMatrixSemInvariant + (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) budget s) + (hlarge : 4 + 3 * budget ≀ bound.length) : + machineNearbyMatrixStep + (nearbyMatrixSemCode (rationalOptimizerOutputCode ⟨X, R, C⟩) + bound s) = + nearbyMatrixSemCode (rationalOptimizerOutputCode ⟨X, R, C⟩) + bound (nearbyMatrixSemStep + (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => + simp [nearbyMatrixSemCode, nearbyMatrixSemStep, + machineNearbyMatrixStep, machineNearbyMatrixAfterRow, + binaryListCode] + | cons row rows => + rw [nearbyMatrixSemCode, nearbyMatrixSemStep, + machineNearbyMatrixStep] + simp only [machineNearbyMatrixCurrent_pack, binaryListCode, + machineIfEmpty_nil, machineNearbyMatrixAfterRow, + machineNearbyMatrixRows_pack] + have hpair : pair (binaryListCode rationalEntryBinaryCode row) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) β‰  + [] := by + intro h + have hlen := congrArg List.length h + simp at hlen + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hpair] + simp [machineNearbyMatrixLoadRow, nearbyMatrixSemCode, + machineListHead, machineListTail] + | cons q qs => + have hnext : + rawRatWidth + (acc.add (rawNearbyCoordinateLower + (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n))) ≀ budget := by + have hinv := nearbyMatrixSemStep_invariant hs + have hinv' : + rawRatWidth + (acc.add (rawNearbyCoordinateLower + (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n))) + + rawNearbyListCost (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) qs + + rawNearbyRowsCost (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) rows ≀ budget := by + simpa only [NearbyMatrixSemInvariant, nearbyMatrixSemStep] using! hinv + omega + have hcode : + (rawRatBinaryCode + (acc.add (rawNearbyCoordinateLower + (rawCertificateRegularizationScale n) q + (directedCertificatePrecision n)))).length ≀ bound.length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans + hlarge) + rw [nearbyMatrixSemCode, nearbyMatrixSemStep, + machineNearbyMatrixStep] + simp only [machineNearbyMatrixCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineNearbyMatrixProcessEntry, + machineNearbyMatrixSource_pack, machineNearbyMatrixRows_pack, + machineNearbyMatrixCurrent_pack, machineNearbyMatrixAcc_pack, + machineNearbyMatrixBound_pack, machineListTail_cons, + machineNearbyMatrixNextAcc, machineNearbyMatrixCandidate, + machineNearbyMatrixCoordinateRawCode_pack] + rw [machineRawRatAddCode_encode] + rw [(List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineNearbyMatrixIterate_semantics + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (bound : List Bool) (s : NearbyMatrixSemState) (budget : β„•) + (hs : NearbyMatrixSemInvariant + (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) budget s) + (hlarge : 4 + 3 * budget ≀ bound.length) : βˆ€ k, + (machineNearbyMatrixStep)^[k] + (nearbyMatrixSemCode (rationalOptimizerOutputCode ⟨X, R, C⟩) + bound s) = + nearbyMatrixSemCode (rationalOptimizerOutputCode ⟨X, R, C⟩) + bound + ((nearbyMatrixSemStep (rawCertificateRegularizationScale n) + (directedCertificatePrecision n))^[k] s) := by + intro k + have hinv : βˆ€ t : β„•, + NearbyMatrixSemInvariant (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) budget + ((nearbyMatrixSemStep (rawCertificateRegularizationScale n) + (directedCertificatePrecision n))^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact nearbyMatrixSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineNearbyMatrixStep_semantics X R C bound _ budget + (hinv k) hlarge + +theorem nearbyMatrixSem_processRow + (tau : RawRat) (p : β„•) (rows : List (List β„š)) + (row : List β„š) (acc : RawRat) : + (nearbyMatrixSemStep tau p)^[row.length] + ⟨rows, row, acc⟩ = + ⟨rows, [], rawNearbyListSum tau p acc row⟩ := by + induction row generalizing acc with + | nil => rfl + | cons q qs ih => + rw [List.length_cons, Function.iterate_succ_apply, + nearbyMatrixSemStep, ih] + rfl + +theorem nearbyMatrixSem_processRows + (tau : RawRat) (p : β„•) (rows : List (List β„š)) (acc : RawRat) : + (nearbyMatrixSemStep tau p)^[matrixNonnegativeRowsWork rows] + ⟨rows, [], acc⟩ = + ⟨[], [], rawNearbyRowsSum tau p acc rows⟩ := by + induction rows generalizing acc with + | nil => rfl + | cons row rows ih => + rw [matrixNonnegativeRowsWork, show 1 + row.length + + matrixNonnegativeRowsWork rows = + matrixNonnegativeRowsWork rows + row.length + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one, nearbyMatrixSemStep, + nearbyMatrixSem_processRow, ih, rawNearbyRowsSum] + +theorem machineNearbyMatrix_done_iterate + (extra : β„•) (source : List Bool) (acc : RawRat) (bound : List Bool) : + (machineNearbyMatrixStep)^[extra] + (machineNearbyMatrixPack source [] [] (rawRatBinaryCode acc) bound) = + machineNearbyMatrixPack source [] [] (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineNearbyMatrixStep, machineNearbyMatrixAfterRow] + +theorem machineNearbyMatrixRawSumCode_encode_of_large + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (hlarge : + 4 + 3 * (1 + rawNearbyRowsCost + (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) (rationalMatrixRows X)) ≀ + (machineNearbyMatrixInputBound + (rationalOptimizerOutputCode ⟨X, R, C⟩)).length) : + machineNearbyMatrixRawSumCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode + (rawNearbyRowsSum (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) RawRat.zero + (rationalMatrixRows X)) := by + let rows := rationalMatrixRows X + let word := rationalOptimizerOutputCode ⟨X, R, C⟩ + let tau := rawCertificateRegularizationScale n + let p := directedCertificatePrecision n + let s : NearbyMatrixSemState := ⟨rows, [], RawRat.zero⟩ + let budget := 1 + rawNearbyRowsCost tau p rows + have hrowsLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineNearbyMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineNearbyMatrixRowsWord_encode X R C).symm + _ ≀ word.length := by + exact (machinePairSecond_length_le + (machineOptimizerMatrixWord word)).trans + (machinePairFirst_length_le word) + have hinv : NearbyMatrixSemInvariant tau p budget s := by + simp [NearbyMatrixSemInvariant, s, budget, rawNearbyListCost, + rawRatWidth_zero] + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsLength + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + have hinit : machineNearbyMatrixInit word = + nearbyMatrixSemCode word (machineNearbyMatrixInputBound word) s := by + simp [machineNearbyMatrixInit, nearbyMatrixSemCode, s, word, rows, + binaryListCode, machineNearbyMatrixRowsWord] + have hlarge' : + 4 + 3 * budget ≀ (machineNearbyMatrixInputBound word).length := by + simpa only [budget, tau, p, rows, word] using! hlarge + rw [machineNearbyMatrixRawSumCode, machineNearbyMatrixFinalState, + hsplit, Function.iterate_add_apply, hinit, + machineNearbyMatrixIterate_semantics X R C + (machineNearbyMatrixInputBound word) s budget hinv hlarge', + nearbyMatrixSem_processRows] + simp only [nearbyMatrixSemCode, binaryListCode] + rw [machineNearbyMatrix_done_iterate] + simp [rows] + +@[simp] theorem machineNearbyMatrixRawSumCode_encode + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) : + machineNearbyMatrixRawSumCode + (rationalOptimizerOutputCode ⟨X, R, C⟩) = + rawRatBinaryCode + (rawNearbyRowsSum (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) RawRat.zero + (rationalMatrixRows X)) := by + apply machineNearbyMatrixRawSumCode_encode_of_large X R C + let word := rationalOptimizerOutputCode ⟨X, R, C⟩ + have hcost := rawNearbyRowsCost_le_optimizer_word X R C + have hruler := machineNearbyMatrixInputBound_length_dominates word + dsimp only [word] at hruler + omega + +theorem rawNearbyListSum_value (tau : RawRat) (p : β„•) + (acc : RawRat) : βˆ€ xs : List β„š, + (rawNearbyListSum tau p acc xs).value = + acc.value + (xs.map (directedNearbyCoordinateLower tau.value Β· p)).sum := by + intro xs + induction xs generalizing acc with + | nil => simp [rawNearbyListSum] + | cons q qs ih => + rw [rawNearbyListSum, ih] + simp [rawNearbyCoordinateLower_value, add_assoc] + +theorem rawNearbyRowsSum_value (tau : RawRat) (p : β„•) + (acc : RawRat) : βˆ€ rows : List (List β„š), + (rawNearbyRowsSum tau p acc rows).value = + acc.value + + (rows.map fun row => + (row.map (directedNearbyCoordinateLower tau.value Β· p)).sum).sum := by + intro rows + induction rows generalizing acc with + | nil => simp [rawNearbyRowsSum] + | cons row rows ih => + rw [rawNearbyRowsSum, ih, rawNearbyListSum_value] + simp [add_assoc] + +theorem rationalMatrixRows_nearby_sum {n : β„•} + (tau : β„š) (X : Matrix (Fin n) (Fin n) β„š) (p : β„•) : + ((rationalMatrixRows X).map fun row => + (row.map (directedNearbyCoordinateLower tau Β· p)).sum).sum = + βˆ‘ i, βˆ‘ j, directedNearbyCoordinateLower tau (X i j) p := by + simp [rationalMatrixRows, List.sum_ofFn] + +theorem rawNearbyRowsSum_certificate_value {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) : + (rawNearbyRowsSum (rawCertificateRegularizationScale n) + (directedCertificatePrecision n) RawRat.zero + (rationalMatrixRows X)).value = + βˆ‘ i, βˆ‘ j, directedNearbyCoordinateLower + (explicitRegularizationScale n) (X i j) + (directedCertificatePrecision n) := by + rw [rawNearbyRowsSum_value, rawCertificateRegularizationScale_value, + rationalMatrixRows_nearby_sum] + simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineNestedMatrixMemory.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineNestedMatrixMemory.lean new file mode 100644 index 0000000000..a81cf89bea --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineNestedMatrixMemory.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListIndex +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate + +/-! # Machine Nested Matrix Memory -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Generic finite-word memory for nested matrices + +These accessors operate on a bare `binaryListCode (binaryListCode encode) M`. +They are independent of the element type and will be used for rational +ellipsoid bases as well as intermediate matrices. +-/ + +/-- Input: `pair rowUnary (pair columnUnary nestedMatrixCode)`. -/ +def machineNestedMatrixEntryAtUnary (word : List Bool) : List Bool := + let rowUnary := machinePairFirst word + let rest := machinePairSecond word + let columnUnary := machinePairFirst rest + let matrixCode := machinePairSecond rest + let rowCode := machineListIndex (pair rowUnary matrixCode) + machineListIndex (pair columnUnary rowCode) + +/-- Input: +`pair rowUnary (pair columnUnary (pair replacement nestedMatrixCode))`. -/ +def machineNestedMatrixUpdateAtUnary (word : List Bool) : List Bool := + let rowUnary := machinePairFirst word + let restOne := machinePairSecond word + let columnUnary := machinePairFirst restOne + let restTwo := machinePairSecond restOne + let replacement := machinePairFirst restTwo + let matrixCode := machinePairSecond restTwo + let rowCode := machineListIndex (pair rowUnary matrixCode) + let updatedRow := machineListUpdate + (pair columnUnary (pair replacement rowCode)) + machineListUpdate (pair rowUnary (pair updatedRow matrixCode)) + +theorem machineNestedMatrixEntryAtUnary_mem_FP : + machineNestedMatrixEntryAtUnary ∈ FP := by + have hrow := machinePairFirst_mem_FP + have hrest := machinePairSecond_mem_FP + have hcolumn := machineCompose_mem_FP hrest machinePairFirst_mem_FP + have hmatrix := machineCompose_mem_FP hrest machinePairSecond_mem_FP + have hrowPayload := machinePair_mem_FP hrow hmatrix + have hrowCode := machineCompose_mem_FP hrowPayload machineListIndex_mem_FP + have hentryPayload := machinePair_mem_FP hcolumn hrowCode + simpa only [machineNestedMatrixEntryAtUnary] using! + machineCompose_mem_FP hentryPayload machineListIndex_mem_FP + +theorem machineNestedMatrixUpdateAtUnary_mem_FP : + machineNestedMatrixUpdateAtUnary ∈ FP := by + have hrow := machinePairFirst_mem_FP + have hrestOne := machinePairSecond_mem_FP + have hcolumn := machineCompose_mem_FP hrestOne machinePairFirst_mem_FP + have hrestTwo := machineCompose_mem_FP hrestOne machinePairSecond_mem_FP + have hreplacement := machineCompose_mem_FP hrestTwo machinePairFirst_mem_FP + have hmatrix := machineCompose_mem_FP hrestTwo machinePairSecond_mem_FP + have hrowPayload := machinePair_mem_FP hrow hmatrix + have hrowCode := machineCompose_mem_FP hrowPayload machineListIndex_mem_FP + have hupdateRowPayload := machinePair_mem_FP hcolumn + (machinePair_mem_FP hreplacement hrowCode) + have hupdatedRow := machineCompose_mem_FP hupdateRowPayload + machineListUpdate_mem_FP + have hupdateMatrixPayload := machinePair_mem_FP hrow + (machinePair_mem_FP hupdatedRow hmatrix) + simpa only [machineNestedMatrixUpdateAtUnary] using! + machineCompose_mem_FP hupdateMatrixPayload machineListUpdate_mem_FP + +@[simp] theorem machineNestedMatrixEntryAtUnary_encode + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) (M : List (List Ξ±)) + (i j : β„•) (hi : i < M.length) (hj : j < M[i].length) : + machineNestedMatrixEntryAtUnary + (pair (List.replicate i true) + (pair (List.replicate j true) + (binaryListCode (binaryListCode encode) M))) = + encode M[i][j] := by + rw [machineNestedMatrixEntryAtUnary] + simp only [machinePairFirst_pair, machinePairSecond_pair] + rw [machineListIndex_binaryListCode (binaryListCode encode) M i hi] + exact machineListIndex_binaryListCode encode M[i] j hj + +@[simp] theorem machineNestedMatrixUpdateAtUnary_encode + {Ξ± : Type*} (encode : Ξ± β†’ List Bool) (M : List (List Ξ±)) + (i j : β„•) (replacement : Ξ±) + (hi : i < M.length) (hj : j < M[i].length) : + machineNestedMatrixUpdateAtUnary + (pair (List.replicate i true) + (pair (List.replicate j true) + (pair (encode replacement) + (binaryListCode (binaryListCode encode) M)))) = + binaryListCode (binaryListCode encode) + (M.set i (M[i].set j replacement)) := by + rw [machineNestedMatrixUpdateAtUnary] + simp only [machinePairFirst_pair, machinePairSecond_pair] + rw [machineListIndex_binaryListCode (binaryListCode encode) M i hi] + change machineListUpdate + (pair (List.replicate i true) + (pair + (machineListUpdate + (machineListUpdateCanonicalInput encode M[i] replacement j)) + (binaryListCode (binaryListCode encode) M))) = _ + rw [machineListUpdate_binaryListCode encode M[i] replacement j hj] + change machineListUpdate + (machineListUpdateCanonicalInput (binaryListCode encode) M + (M[i].set j replacement) i) = _ + exact machineListUpdate_binaryListCode (binaryListCode encode) M + (M[i].set j replacement) i hi + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionLoop.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionLoop.lean new file mode 100644 index 0000000000..71d6c7c63a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionLoop.lean @@ -0,0 +1,621 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilityCall +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheBisection +public import Mathlib.Tactic + +/-! +# A finite-word dyadic bisection loop for the Bethe optimizer + +Rather than storing two rational endpoints whose concrete representations +change at every step, the machine stores a natural interval index `k` and a +unary depth `t`. They represent the adjacent dyadic endpoints + +`L + k (H - L) / 2^t` and `L + (k + 1) (H - L) / 2^t`. + +An exhausted midpoint appends a one bit to the branch index; an accepted +midpoint appends a zero bit. Consequently the persistent state grows by at +most one bit in each of its two mutable fields. This gives a direct global +polynomial state envelope for the bounded iteration. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Exact dyadic thresholds -/ + +/-- The raw-rational initial lower objective bound `-2*n^2`. -/ +def rawOptimizerInitialLow (n : β„•) : RawRat := + (rawOptimizerTwiceNSquare n).neg + +/-- The threshold at dyadic position `k/2^t` within the initial objective interval. -/ +def optimizerDyadicThreshold {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (k t : β„•) : β„š := + betheNegativeObjectiveLower m + + (k : β„š) / 2 ^ t * explicitOptimizerInitialWidth A + +/-- Normalizes the encoded initial lower objective bound `-2*n^2`. -/ +def machineOptimizerInitialLowEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRawRatNegCode + (machineOptimizerTwiceNSquareForWidthRawCode word)) + +/-- Normalizes the initial interval width for use in the bisection loop. -/ +def machineOptimizerInitialWidthEntryCodeForBisection + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineExplicitOptimizerInitialWidthRawCode word) + +/-! ## Persistent state -/ + +/-- Encodes a bisection state as source matrix, iteration ruler, binary index, and unary depth. -/ +def machineOptimizerBisectionStatePack + (source ruler index depth : List Bool) : List Bool := + pair source (pair ruler (pair index depth)) + +/-- Extracts the source matrix from the bisection state. -/ +def machineOptimizerBisectionStateSource + (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the fixed bisection-iteration ruler from the state. -/ +def machineOptimizerBisectionStateRuler + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the binary index of the current dyadic interval. -/ +def machineOptimizerBisectionStateIndex + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the unary depth of the current dyadic interval. -/ +def machineOptimizerBisectionStateDepth + (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Initializes bisection with the source matrix, scheduled ruler, and zero index and depth. -/ +def machineOptimizerBisectionInit (word : List Bool) : List Bool := + machineOptimizerBisectionStatePack word + (machineExplicitOptimizerBisectionStepsRuler word) [] [] + +/-! ## Reconstruct the queried midpoint -/ + +/-- Doubles the current dyadic interval index in binary. -/ +def machineOptimizerBisectionEvenIndexBits + (state : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerBisectionStateIndex state) [false, true]) + +/-- Computes the odd midpoint index `2*k + 1` in binary. -/ +def machineOptimizerBisectionOddIndexBits + (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerBisectionEvenIndexBits state) [true]) + +/-- Increments the unary bisection depth. -/ +def machineOptimizerBisectionNextDepth + (state : List Bool) : List Bool := + true :: machineOptimizerBisectionStateDepth state + +/-- Computes the binary denominator `2^(t + 1)` for the next midpoint. -/ +def machineOptimizerBisectionDenominatorBits + (state : List Bool) : List Bool := + machineDirectedLogPowerTwoBits + (machineOptimizerBisectionNextDepth state) + +/-- Encodes the raw dyadic midpoint fraction `(2*k + 1)/2^(t + 1)`. -/ +def machineOptimizerBisectionFractionRawCode + (state : List Bool) : List Bool := + pair + (machineNaturalIntegerCode + (machineOptimizerBisectionOddIndexBits state)) + (machineOptimizerBisectionDenominatorBits state) + +/-- Multiplies the dyadic midpoint fraction by the initial objective-interval width. -/ +def machineOptimizerBisectionScaledFractionRawCode + (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerBisectionFractionRawCode state) + (machineOptimizerInitialWidthEntryCodeForBisection + (machineOptimizerBisectionStateSource state))) + +/-- Adds the initial lower objective bound to the scaled midpoint fraction. -/ +def machineOptimizerBisectionMidpointUnnormalizedRawCode + (state : List Bool) : List Bool := + machineRawRatAddCode + (pair + (machineOptimizerInitialLowEntryCode + (machineOptimizerBisectionStateSource state)) + (machineOptimizerBisectionScaledFractionRawCode state)) + +/-- Normalizes the encoded midpoint threshold. -/ +def machineOptimizerBisectionMidpointRawCode + (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerBisectionMidpointUnnormalizedRawCode state) + +/-- Pairs the source matrix with the current midpoint threshold for a feasibility query. -/ +def machineOptimizerBisectionFeasibilityCall + (state : List Bool) : List Bool := + pair (machineOptimizerBisectionStateSource state) + (machineOptimizerBisectionMidpointRawCode state) + +/-- Runs the explicit threshold-feasibility machine at the current bisection midpoint. -/ +def machineOptimizerBisectionFeasibilityResult + (state : List Bool) : List Bool := + machineExplicitBetheThresholdFeasibilityCode + (machineOptimizerBisectionFeasibilityCall state) + +/-- Reads the exhausted flag from the midpoint feasibility result. -/ +def machineOptimizerBisectionExhaustedBit + (state : List Bool) : List Bool := + machineHeadBit + (machinePairFirst + (machineOptimizerBisectionFeasibilityResult state)) + +/-! ## One branch and the bounded iteration -/ + +/-- Chooses index `2*k + 1` on exhaustion and `2*k` on acceptance. -/ +def machineOptimizerBisectionNextIndexBits + (state : List Bool) : List Bool := + machineIfHead (machineOptimizerBisectionExhaustedBit state) + (machineOptimizerBisectionOddIndexBits state) + (machineOptimizerBisectionEvenIndexBits state) + +/-- Updates the dyadic interval index and depth while preserving the source and iteration ruler. -/ +def machineOptimizerBisectionStep (state : List Bool) : List Bool := + machineOptimizerBisectionStatePack + (machineOptimizerBisectionStateSource state) + (machineOptimizerBisectionStateRuler state) + (machineOptimizerBisectionNextIndexBits state) + (machineOptimizerBisectionNextDepth state) + +/-- Runs bisection for the scheduled number of iterations. -/ +def machineOptimizerBisectionFinalState + (word : List Bool) : List Bool := + (machineOptimizerBisectionStep)^[( + machineExplicitOptimizerBisectionStepsRuler word).length] + (machineOptimizerBisectionInit word) + +/-! ## Re-query the certified upper endpoint -/ + +/-- Computes the upper endpoint index `k + 1` of the current dyadic interval. -/ +def machineOptimizerBisectionHighIndexBits + (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerBisectionStateIndex state) [true]) + +/-- Encodes the current upper endpoint fraction `(k + 1)/2^t`. -/ +def machineOptimizerBisectionHighFractionRawCode + (state : List Bool) : List Bool := + pair + (machineNaturalIntegerCode + (machineOptimizerBisectionHighIndexBits state)) + (machineDirectedLogPowerTwoBits + (machineOptimizerBisectionStateDepth state)) + +/-- Scales the upper endpoint fraction by the initial interval width. -/ +def machineOptimizerBisectionHighScaledRawCode + (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerBisectionHighFractionRawCode state) + (machineOptimizerInitialWidthEntryCodeForBisection + (machineOptimizerBisectionStateSource state))) + +/-- Adds the initial lower bound to the scaled upper endpoint fraction. -/ +def machineOptimizerBisectionHighUnnormalizedRawCode + (state : List Bool) : List Bool := + machineRawRatAddCode + (pair + (machineOptimizerInitialLowEntryCode + (machineOptimizerBisectionStateSource state)) + (machineOptimizerBisectionHighScaledRawCode state)) + +/-- Normalizes the encoded upper endpoint threshold. -/ +def machineOptimizerBisectionHighRawCode + (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerBisectionHighUnnormalizedRawCode state) + +/-- Runs threshold feasibility once more at the final bisection interval's upper endpoint. -/ +def machineExplicitBetheOptimizerFeasibilityResultCode + (word : List Bool) : List Bool := + let state := machineOptimizerBisectionFinalState word + machineExplicitBetheThresholdFeasibilityCode + (pair word (machineOptimizerBisectionHighRawCode state)) + +/-- Extracts the point payload returned by the final optimizer feasibility call. -/ +def machineExplicitBetheOptimizerPointCode + (word : List Bool) : List Bool := + machinePairSecond + (machineExplicitBetheOptimizerFeasibilityResultCode word) + +/-! ## Polynomial-time closure -/ + +theorem machineOptimizerInitialLowEntryCode_mem_FP : + machineOptimizerInitialLowEntryCode ∈ FP := by + have hneg := machineCompose_mem_FP + machineOptimizerTwiceNSquareForWidthRawCode_mem_FP + machineRawRatNegCode_mem_FP + simpa only [machineOptimizerInitialLowEntryCode] using! + machineCompose_mem_FP hneg machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerInitialWidthEntryCodeForBisection_mem_FP : + machineOptimizerInitialWidthEntryCodeForBisection ∈ FP := by + simpa only [machineOptimizerInitialWidthEntryCodeForBisection] using! + machineCompose_mem_FP machineExplicitOptimizerInitialWidthRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerBisectionStateSource_mem_FP : + machineOptimizerBisectionStateSource ∈ FP := machinePairFirst_mem_FP + +theorem machineOptimizerBisectionStateRuler_mem_FP : + machineOptimizerBisectionStateRuler ∈ FP := by + simpa only [machineOptimizerBisectionStateRuler] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineOptimizerBisectionStateIndex_mem_FP : + machineOptimizerBisectionStateIndex ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineOptimizerBisectionStateIndex] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineOptimizerBisectionStateDepth_mem_FP : + machineOptimizerBisectionStateDepth ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineOptimizerBisectionStateDepth] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineOptimizerBisectionInit_mem_FP : + machineOptimizerBisectionInit ∈ FP := by + simpa only [machineOptimizerBisectionInit] using! + machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineExplicitOptimizerBisectionStepsRuler_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machineConst_mem_FP []))) + +theorem machineOptimizerBisectionEvenIndexBits_mem_FP : + machineOptimizerBisectionEvenIndexBits ∈ FP := by + simpa only [machineOptimizerBisectionEvenIndexBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerBisectionStateIndex_mem_FP + (machineConst_mem_FP [false, true])) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerBisectionOddIndexBits_mem_FP : + machineOptimizerBisectionOddIndexBits ∈ FP := by + simpa only [machineOptimizerBisectionOddIndexBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerBisectionEvenIndexBits_mem_FP + (machineConst_mem_FP [true])) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerBisectionNextDepth_mem_FP : + machineOptimizerBisectionNextDepth ∈ FP := by + simpa only [machineOptimizerBisectionNextDepth] using! + machineCompose_mem_FP machineOptimizerBisectionStateDepth_mem_FP + (machinePrepend_mem_FP true) + +theorem machineOptimizerBisectionDenominatorBits_mem_FP : + machineOptimizerBisectionDenominatorBits ∈ FP := by + simpa only [machineOptimizerBisectionDenominatorBits] using! + machineCompose_mem_FP machineOptimizerBisectionNextDepth_mem_FP + machineDirectedLogPowerTwoBits_mem_FP + +theorem machineOptimizerBisectionFractionRawCode_mem_FP : + machineOptimizerBisectionFractionRawCode ∈ FP := by + have hnum := machineCompose_mem_FP + machineOptimizerBisectionOddIndexBits_mem_FP + machineNaturalIntegerCode_mem_FP + exact machinePair_mem_FP hnum + machineOptimizerBisectionDenominatorBits_mem_FP + +theorem machineOptimizerBisectionScaledFractionRawCode_mem_FP : + machineOptimizerBisectionScaledFractionRawCode ∈ FP := by + have hwidth := machineCompose_mem_FP + machineOptimizerBisectionStateSource_mem_FP + machineOptimizerInitialWidthEntryCodeForBisection_mem_FP + simpa only [machineOptimizerBisectionScaledFractionRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerBisectionFractionRawCode_mem_FP hwidth) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerBisectionMidpointUnnormalizedRawCode_mem_FP : + machineOptimizerBisectionMidpointUnnormalizedRawCode ∈ FP := by + have hlow := machineCompose_mem_FP + machineOptimizerBisectionStateSource_mem_FP + machineOptimizerInitialLowEntryCode_mem_FP + simpa only [machineOptimizerBisectionMidpointUnnormalizedRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP hlow + machineOptimizerBisectionScaledFractionRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerBisectionMidpointRawCode_mem_FP : + machineOptimizerBisectionMidpointRawCode ∈ FP := by + simpa only [machineOptimizerBisectionMidpointRawCode] using! + machineCompose_mem_FP + machineOptimizerBisectionMidpointUnnormalizedRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerBisectionFeasibilityCall_mem_FP : + machineOptimizerBisectionFeasibilityCall ∈ FP := + machinePair_mem_FP machineOptimizerBisectionStateSource_mem_FP + machineOptimizerBisectionMidpointRawCode_mem_FP + +theorem machineOptimizerBisectionFeasibilityResult_mem_FP : + machineOptimizerBisectionFeasibilityResult ∈ FP := by + simpa only [machineOptimizerBisectionFeasibilityResult] using! + machineCompose_mem_FP machineOptimizerBisectionFeasibilityCall_mem_FP + machineExplicitBetheThresholdFeasibilityCode_mem_FP + +theorem machineOptimizerBisectionExhaustedBit_mem_FP : + machineOptimizerBisectionExhaustedBit ∈ FP := by + have htag := machineCompose_mem_FP + machineOptimizerBisectionFeasibilityResult_mem_FP + machinePairFirst_mem_FP + simpa only [machineOptimizerBisectionExhaustedBit] using! + machineCompose_mem_FP htag machineHeadBit_mem_FP + +theorem machineOptimizerBisectionNextIndexBits_mem_FP : + machineOptimizerBisectionNextIndexBits ∈ FP := by + exact machineIfHead_mem_FP machineOptimizerBisectionExhaustedBit_mem_FP + machineOptimizerBisectionOddIndexBits_mem_FP + machineOptimizerBisectionEvenIndexBits_mem_FP + +theorem machineOptimizerBisectionStep_mem_FP : + machineOptimizerBisectionStep ∈ FP := by + exact machinePair_mem_FP machineOptimizerBisectionStateSource_mem_FP + (machinePair_mem_FP machineOptimizerBisectionStateRuler_mem_FP + (machinePair_mem_FP machineOptimizerBisectionNextIndexBits_mem_FP + machineOptimizerBisectionNextDepth_mem_FP)) + +/-! ## A global state envelope for Cobham iteration -/ + +@[simp] theorem machineOptimizerBisectionStateSource_pack + (source ruler index depth : List Bool) : + machineOptimizerBisectionStateSource + (machineOptimizerBisectionStatePack source ruler index depth) = + source := by + simp [machineOptimizerBisectionStateSource, + machineOptimizerBisectionStatePack] + +@[simp] theorem machineOptimizerBisectionStateRuler_pack + (source ruler index depth : List Bool) : + machineOptimizerBisectionStateRuler + (machineOptimizerBisectionStatePack source ruler index depth) = + ruler := by + simp [machineOptimizerBisectionStateRuler, + machineOptimizerBisectionStatePack] + +@[simp] theorem machineOptimizerBisectionStateIndex_pack + (source ruler index depth : List Bool) : + machineOptimizerBisectionStateIndex + (machineOptimizerBisectionStatePack source ruler index depth) = + index := by + simp [machineOptimizerBisectionStateIndex, + machineOptimizerBisectionStatePack] + +@[simp] theorem machineOptimizerBisectionStateDepth_pack + (source ruler index depth : List Bool) : + machineOptimizerBisectionStateDepth + (machineOptimizerBisectionStatePack source ruler index depth) = + depth := by + simp [machineOptimizerBisectionStateDepth, + machineOptimizerBisectionStatePack] + +/-- Records canonical state packing, fixed source and ruler, index below `2^iterations`, and +matching depth. -/ +def MachineOptimizerBisectionStateBound + (word : List Bool) (iterations : β„•) (state : List Bool) : Prop := + state = machineOptimizerBisectionStatePack + (machineOptimizerBisectionStateSource state) + (machineOptimizerBisectionStateRuler state) + (machineOptimizerBisectionStateIndex state) + (machineOptimizerBisectionStateDepth state) ∧ + machineOptimizerBisectionStateSource state = word ∧ + machineOptimizerBisectionStateRuler state = + machineExplicitOptimizerBisectionStepsRuler word ∧ + (βˆƒ k : β„•, + machineOptimizerBisectionStateIndex state = k.bits ∧ + k < 2 ^ iterations) ∧ + (machineOptimizerBisectionStateDepth state).length = iterations + +theorem machineOptimizerBisectionInit_bound (word : List Bool) : + MachineOptimizerBisectionStateBound word 0 + (machineOptimizerBisectionInit word) := by + simp only [MachineOptimizerBisectionStateBound, + machineOptimizerBisectionInit, + machineOptimizerBisectionStateSource_pack, + machineOptimizerBisectionStateRuler_pack, + machineOptimizerBisectionStateIndex_pack, + machineOptimizerBisectionStateDepth_pack, List.length_nil] + exact ⟨trivial, trivial, trivial, ⟨0, rfl, by norm_num⟩, trivial⟩ + +theorem machineOptimizerBisectionStep_bound + {word state : List Bool} {iterations : β„•} + (hs : MachineOptimizerBisectionStateBound word iterations state) : + MachineOptimizerBisectionStateBound word (iterations + 1) + (machineOptimizerBisectionStep state) := by + rcases hs with ⟨hdecomp, hsource, hruler, + ⟨k, hindex, hk⟩, hdepth⟩ + have heven : machineOptimizerBisectionEvenIndexBits state = + (2 * k).bits := by + rw [machineOptimizerBisectionEvenIndexBits, hindex] + change machineBinaryMulBits (pair k.bits (2 : β„•).bits) = _ + rw [machineBinaryMulBits_pair_natBits] + congr 1 + omega + have hodd : machineOptimizerBisectionOddIndexBits state = + (2 * k + 1).bits := by + rw [machineOptimizerBisectionOddIndexBits, heven] + change machineBinaryAddBits (pair (2 * k).bits (1 : β„•).bits) = _ + rw [machineBinaryAddBits_pair_natBits] + simp only [machineOptimizerBisectionStep, + MachineOptimizerBisectionStateBound, + machineOptimizerBisectionStateSource_pack, + machineOptimizerBisectionStateRuler_pack, + machineOptimizerBisectionStateIndex_pack, + machineOptimizerBisectionStateDepth_pack] + refine ⟨by trivial, hsource, hruler, ?_, ?_⟩ + Β· rw [machineOptimizerBisectionNextIndexBits, + machineOptimizerBisectionExhaustedBit] + cases hflag : machinePairFirst + (machineOptimizerBisectionFeasibilityResult state) with + | nil => + rw [machineHeadBit_nil, machineIfHead_false] + refine ⟨2 * k, heven, ?_⟩ + rw [pow_succ] + omega + | cons bit tail => + cases bit with + | false => + rw [machineHeadBit_cons, machineIfHead_false] + refine ⟨2 * k, heven, ?_⟩ + rw [pow_succ] + omega + | true => + rw [machineHeadBit_cons, machineIfHead_true] + refine ⟨2 * k + 1, hodd, ?_⟩ + rw [pow_succ] + omega + Β· simp [machineOptimizerBisectionNextDepth, hdepth] + +theorem machineOptimizerBisectionIterate_bound (word : List Bool) : βˆ€ k, + MachineOptimizerBisectionStateBound word k + ((machineOptimizerBisectionStep)^[k] + (machineOptimizerBisectionInit word)) := by + intro k + induction k with + | zero => exact machineOptimizerBisectionInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + simpa only [Nat.succ_eq_add_one] using! + machineOptimizerBisectionStep_bound ih + +/-- Packs four copies of a source-and-ruler envelope to bound a bisection state. -/ +def machineOptimizerBisectionWidth (word : List Bool) : List Bool := + let envelope := false :: + (word ++ machineExplicitOptimizerBisectionStepsRuler word) + machineOptimizerBisectionStatePack envelope envelope envelope envelope + +theorem machineOptimizerBisectionWidth_mem_FP : + machineOptimizerBisectionWidth ∈ FP := by + have happend := machineAppend_mem_FP id_mem_FP + machineExplicitOptimizerBisectionStepsRuler_mem_FP + have henvelope : (fun word : List Bool ↦ + false :: (word ++ machineExplicitOptimizerBisectionStepsRuler word)) + ∈ FP := machineCompose_mem_FP happend (machinePrepend_mem_FP false) + simpa only [machineOptimizerBisectionWidth] using! + machinePair_mem_FP henvelope + (machinePair_mem_FP henvelope + (machinePair_mem_FP henvelope henvelope)) + +theorem machineOptimizerBisectionIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ + (machineExplicitOptimizerBisectionStepsRuler word).length) : + ((machineOptimizerBisectionStep)^[iterations] + (machineOptimizerBisectionInit word)).length ≀ + (machineOptimizerBisectionWidth word).length := by + rcases machineOptimizerBisectionIterate_bound word iterations with + ⟨hdecomp, hsource, hruler, ⟨k, hindex, hk⟩, hdepth⟩ + have hkbits : k.bits.length ≀ iterations := by + rw [Nat.size_eq_bits_len, Nat.size_le] + exact hk + rw [hdecomp] + simp only [machineOptimizerBisectionStatePack, + machineOptimizerBisectionWidth, pair_length, List.length_cons, + List.length_append] + rw [hsource, hruler, hindex, hdepth] + omega + +theorem machineOptimizerBisectionFinalState_mem_FP : + machineOptimizerBisectionFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineOptimizerBisectionStep_mem_FP + machineOptimizerBisectionInit_mem_FP + machineExplicitOptimizerBisectionStepsRuler_mem_FP + machineOptimizerBisectionWidth_mem_FP + machineOptimizerBisectionIterate_length_le_width + +/-! ## Polynomial-time closure of the final upper-endpoint query -/ + +theorem machineOptimizerBisectionHighIndexBits_mem_FP : + machineOptimizerBisectionHighIndexBits ∈ FP := by + simpa only [machineOptimizerBisectionHighIndexBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerBisectionStateIndex_mem_FP + (machineConst_mem_FP [true])) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerBisectionHighFractionRawCode_mem_FP : + machineOptimizerBisectionHighFractionRawCode ∈ FP := by + have hnum := machineCompose_mem_FP + machineOptimizerBisectionHighIndexBits_mem_FP + machineNaturalIntegerCode_mem_FP + have hden := machineCompose_mem_FP + machineOptimizerBisectionStateDepth_mem_FP + machineDirectedLogPowerTwoBits_mem_FP + exact machinePair_mem_FP hnum hden + +theorem machineOptimizerBisectionHighScaledRawCode_mem_FP : + machineOptimizerBisectionHighScaledRawCode ∈ FP := by + have hwidth := machineCompose_mem_FP + machineOptimizerBisectionStateSource_mem_FP + machineOptimizerInitialWidthEntryCodeForBisection_mem_FP + simpa only [machineOptimizerBisectionHighScaledRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerBisectionHighFractionRawCode_mem_FP hwidth) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerBisectionHighUnnormalizedRawCode_mem_FP : + machineOptimizerBisectionHighUnnormalizedRawCode ∈ FP := by + have hlow := machineCompose_mem_FP + machineOptimizerBisectionStateSource_mem_FP + machineOptimizerInitialLowEntryCode_mem_FP + simpa only [machineOptimizerBisectionHighUnnormalizedRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP hlow + machineOptimizerBisectionHighScaledRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerBisectionHighRawCode_mem_FP : + machineOptimizerBisectionHighRawCode ∈ FP := by + simpa only [machineOptimizerBisectionHighRawCode] using! + machineCompose_mem_FP + machineOptimizerBisectionHighUnnormalizedRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExplicitBetheOptimizerFeasibilityResultCode_mem_FP : + machineExplicitBetheOptimizerFeasibilityResultCode ∈ FP := by + have hhigh := machineCompose_mem_FP + machineOptimizerBisectionFinalState_mem_FP + machineOptimizerBisectionHighRawCode_mem_FP + have hcall := machinePair_mem_FP id_mem_FP hhigh + simpa only [machineExplicitBetheOptimizerFeasibilityResultCode] using! + machineCompose_mem_FP hcall + machineExplicitBetheThresholdFeasibilityCode_mem_FP + +theorem machineExplicitBetheOptimizerPointCode_mem_FP : + machineExplicitBetheOptimizerPointCode ∈ FP := by + simpa only [machineExplicitBetheOptimizerPointCode] using! + machineCompose_mem_FP + machineExplicitBetheOptimizerFeasibilityResultCode_mem_FP + machinePairSecond_mem_FP + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSchedule.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSchedule.lean new file mode 100644 index 0000000000..9b501b2e83 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSchedule.lean @@ -0,0 +1,358 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerDerivedScales + +/-! +# Initial interval and bisection schedule as finite-word functions + +The initial objective width is assembled by exact rational arithmetic. The +number of bisection calls is then the sum of the canonical encoding lengths +of that width and of the optimizer gap, plus three. Both schedules are +returned in unary, so later bounded iterations can consume them directly. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw-rational objective upper bound `n*B + n`. -/ +def rawOptimizerObjectiveUpper (n B : β„•) : RawRat := + ((rawOptimizerDimension n).mul (rawOptimizerBitBound B)).add + (rawOptimizerDimension n) + +/-- Twice the explicit optimizer inner radius as a raw rational. -/ +def rawOptimizerTwiceInnerRadius (n B : β„•) : RawRat := + rawOptimizerTwo.mul (rawExplicitOptimizerInnerRadius n B) + +/-- The smoothing slack given by mixing times the objective range plus twice the inner radius. -/ +def rawOptimizerSmoothingSlack (n B : β„•) : RawRat := + ((rawExplicitOptimizerMix n B).mul + (rawOptimizerObjectiveRange n B)).add + (rawOptimizerTwiceInnerRadius n B) + +/-- The initial upper threshold obtained by adding smoothing slack to the objective upper bound. -/ +def rawOptimizerInitialHigh (n B : β„•) : RawRat := + (rawOptimizerObjectiveUpper n B).add + (rawOptimizerSmoothingSlack n B) + +/-- The raw-rational quantity `2*n^2` used to form the initial interval width. -/ +def rawOptimizerTwiceNSquare (n : β„•) : RawRat := + rawOptimizerTwo.mul (rawOptimizerNSquare n) + +/-- The initial upper threshold minus the lower threshold `-2*n^2`. -/ +def rawExplicitOptimizerInitialWidth (n B : β„•) : RawRat := + (rawOptimizerInitialHigh n B).add (rawOptimizerTwiceNSquare n) + +/-- Computes the encoded objective upper bound `n*B + n`. -/ +def machineOptimizerObjectiveUpperRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerNBProductRawCode word) + (machineOptimizerDimensionRawCode word)) + +/-- Computes twice the encoded optimizer inner radius. -/ +def machineOptimizerTwiceInnerRadiusRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineExplicitOptimizerInnerRadiusRawCode word)) + +/-- Multiplies the encoded mixing parameter by the objective range. -/ +def machineOptimizerMixRangeRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineExplicitOptimizerMixRawCode word) + (machineOptimizerObjectiveRangeRawCode word)) + +/-- Adds the mixing-range product and twice the inner radius to encode smoothing slack. -/ +def machineOptimizerSmoothingSlackRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerMixRangeRawCode word) + (machineOptimizerTwiceInnerRadiusRawCode word)) + +/-- Adds smoothing slack to the encoded objective upper bound. -/ +def machineOptimizerInitialHighRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerObjectiveUpperRawCode word) + (machineOptimizerSmoothingSlackRawCode word)) + +/-- Computes the encoded quantity `2*n^2` used in the initial width. -/ +def machineOptimizerTwiceNSquareForWidthRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineOptimizerNSquareRawCode word)) + +/-- Adds `2*n^2` to the initial upper threshold to encode the initial bisection width. -/ +def machineExplicitOptimizerInitialWidthRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerInitialHighRawCode word) + (machineOptimizerTwiceNSquareForWidthRawCode word)) + +theorem machineOptimizerObjectiveUpperRawCode_mem_FP : + machineOptimizerObjectiveUpperRawCode ∈ FP := by + simpa only [machineOptimizerObjectiveUpperRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerNBProductRawCode_mem_FP + machineOptimizerDimensionRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerTwiceInnerRadiusRawCode_mem_FP : + machineOptimizerTwiceInnerRadiusRawCode ∈ FP := by + simpa only [machineOptimizerTwiceInnerRadiusRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineExplicitOptimizerInnerRadiusRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerMixRangeRawCode_mem_FP : + machineOptimizerMixRangeRawCode ∈ FP := by + simpa only [machineOptimizerMixRangeRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerMixRawCode_mem_FP + machineOptimizerObjectiveRangeRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerSmoothingSlackRawCode_mem_FP : + machineOptimizerSmoothingSlackRawCode ∈ FP := by + simpa only [machineOptimizerSmoothingSlackRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerMixRangeRawCode_mem_FP + machineOptimizerTwiceInnerRadiusRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerInitialHighRawCode_mem_FP : + machineOptimizerInitialHighRawCode ∈ FP := by + simpa only [machineOptimizerInitialHighRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerObjectiveUpperRawCode_mem_FP + machineOptimizerSmoothingSlackRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerTwiceNSquareForWidthRawCode_mem_FP : + machineOptimizerTwiceNSquareForWidthRawCode ∈ FP := by + simpa only [machineOptimizerTwiceNSquareForWidthRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineOptimizerNSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineExplicitOptimizerInitialWidthRawCode_mem_FP : + machineExplicitOptimizerInitialWidthRawCode ∈ FP := by + simpa only [machineExplicitOptimizerInitialWidthRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerInitialHighRawCode_mem_FP + machineOptimizerTwiceNSquareForWidthRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +@[simp] theorem machineOptimizerObjectiveUpperRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerObjectiveUpperRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerObjectiveUpper n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerObjectiveUpperRawCode, + machineOptimizerNBProductRawCode_encode, + machineOptimizerDimensionRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerTwiceInnerRadiusRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTwiceInnerRadiusRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerTwiceInnerRadius n + (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerTwiceInnerRadiusRawCode, + machineExplicitOptimizerInnerRadiusRawCode_encode hn, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineOptimizerMixRangeRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerMixRangeRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + ((rawExplicitOptimizerMix n (rationalMatrixEntryBitBound A)).mul + (rawOptimizerObjectiveRange n + (rationalMatrixEntryBitBound A))) := by + rw [machineOptimizerMixRangeRawCode, + machineExplicitOptimizerMixRawCode_encode hn, + machineOptimizerObjectiveRangeRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerSmoothingSlackRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerSmoothingSlackRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerSmoothingSlack n + (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerSmoothingSlackRawCode, + machineOptimizerMixRangeRawCode_encode hn, + machineOptimizerTwiceInnerRadiusRawCode_encode hn, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerInitialHighRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInitialHighRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerInitialHigh n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerInitialHighRawCode, + machineOptimizerObjectiveUpperRawCode_encode, + machineOptimizerSmoothingSlackRawCode_encode hn, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerTwiceNSquareForWidthRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTwiceNSquareForWidthRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerTwiceNSquare n) := by + rw [machineOptimizerTwiceNSquareForWidthRawCode, + machineOptimizerNSquareRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineExplicitOptimizerInitialWidthRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerInitialWidthRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawExplicitOptimizerInitialWidth n + (rationalMatrixEntryBitBound A)) := by + rw [machineExplicitOptimizerInitialWidthRawCode, + machineOptimizerInitialHighRawCode_encode hn, + machineOptimizerTwiceNSquareForWidthRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem rawOptimizerObjectiveUpper_value (n B : β„•) : + (rawOptimizerObjectiveUpper n B).value = n * B + n := by + simp [rawOptimizerObjectiveUpper] + +@[simp] theorem rawOptimizerSmoothingSlack_value (n B : β„•) : + (rawOptimizerSmoothingSlack n B).value = + (rawExplicitOptimizerMix n B).value * + (rawOptimizerObjectiveRange n B).value + + 2 * (rawExplicitOptimizerInnerRadius n B).value := by + simp [rawOptimizerSmoothingSlack, rawOptimizerTwiceInnerRadius, + rawOptimizerTwo] + +@[simp] theorem rawExplicitOptimizerInitialWidth_value (n B : β„•) : + (rawExplicitOptimizerInitialWidth n B).value = + n * B + n + + ((rawExplicitOptimizerMix n B).value * + (rawOptimizerObjectiveRange n B).value + + 2 * (rawExplicitOptimizerInnerRadius n B).value) + + 2 * n ^ 2 := by + simp [rawExplicitOptimizerInitialWidth, rawOptimizerInitialHigh, + rawOptimizerTwiceNSquare, rawOptimizerNSquare, + rawOptimizerDimension, rawOptimizerTwo] + ring + +theorem rawExplicitOptimizerInitialWidth_eq {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + (rawExplicitOptimizerInitialWidth (m + 1) + (rationalMatrixEntryBitBound A)).value = + explicitOptimizerInitialWidth A := by + rcases rawExplicitOptimizerScales_value A with + ⟨_, _, _, hmix, hradius⟩ + rw [rawExplicitOptimizerInitialWidth_value, hmix, hradius, + rawOptimizerObjectiveRange_value] + simp [explicitOptimizerInitialWidth, betheBisectionInitialHigh, + betheNegativeObjectiveUpper, betheSmoothingSlack, + betheNegativeObjectiveLower, rationalRegularizedObjectiveRange] + +/-! ## Exact unary bisection count -/ + +/-- Normalizes the raw initial bisection width into a rational entry code. -/ +def machineExplicitOptimizerInitialWidthEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineExplicitOptimizerInitialWidthRawCode word) + +/-- Measures the encoded initial interval width with an optimizer entry-length ruler. -/ +def machineExplicitOptimizerInitialWidthLengthRuler + (word : List Bool) : List Bool := + machineOptimizerEntryLengthRuler + (machineExplicitOptimizerInitialWidthEntryCode word) + +/-- Concatenates the initial-width and gap length rulers with three extra bisection steps. -/ +def machineExplicitOptimizerBisectionStepsRuler + (word : List Bool) : List Bool := + machineExplicitOptimizerInitialWidthLengthRuler word ++ + (machineExplicitOptimizerGapLengthRuler word ++ + List.replicate 3 true) + +theorem machineExplicitOptimizerInitialWidthEntryCode_mem_FP : + machineExplicitOptimizerInitialWidthEntryCode ∈ FP := by + simpa only [machineExplicitOptimizerInitialWidthEntryCode] using! + machineCompose_mem_FP machineExplicitOptimizerInitialWidthRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExplicitOptimizerInitialWidthLengthRuler_mem_FP : + machineExplicitOptimizerInitialWidthLengthRuler ∈ FP := by + simpa only [machineExplicitOptimizerInitialWidthLengthRuler] using! + machineCompose_mem_FP + machineExplicitOptimizerInitialWidthEntryCode_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + +theorem machineExplicitOptimizerBisectionStepsRuler_mem_FP : + machineExplicitOptimizerBisectionStepsRuler ∈ FP := by + simpa only [machineExplicitOptimizerBisectionStepsRuler] using! + machineAppend_mem_FP + machineExplicitOptimizerInitialWidthLengthRuler_mem_FP + (machineAppend_mem_FP machineExplicitOptimizerGapLengthRuler_mem_FP + (machineConst_mem_FP (List.replicate 3 true))) + +@[simp] theorem machineExplicitOptimizerInitialWidthEntryCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerInitialWidthEntryCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalEntryBinaryCode + ((rawExplicitOptimizerInitialWidth n + (rationalMatrixEntryBitBound A)).value) := by + rw [machineExplicitOptimizerInitialWidthEntryCode, + machineExplicitOptimizerInitialWidthRawCode_encode hn, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value] + +@[simp] theorem machineExplicitOptimizerInitialWidthLengthRuler_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerInitialWidthLengthRuler + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate + (encodedBitLength β„š + ((rawExplicitOptimizerInitialWidth n + (rationalMatrixEntryBitBound A)).value)) true := by + rw [machineExplicitOptimizerInitialWidthLengthRuler, + machineExplicitOptimizerInitialWidthEntryCode_encode hn, + machineOptimizerEntryLengthRuler_encode] + +@[simp] theorem machineExplicitOptimizerBisectionStepsRuler_encode + {m : β„•} (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineExplicitOptimizerBisectionStepsRuler + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + List.replicate (explicitOptimizerBisectionSteps A) true := by + rw [machineExplicitOptimizerBisectionStepsRuler, + machineExplicitOptimizerInitialWidthLengthRuler_encode (by omega), + machineExplicitOptimizerGapLengthRuler_encode (by omega), + rawExplicitOptimizerInitialWidth_eq] + have hgap := (rawExplicitOptimizerScales_value A).2.2.1 + rw [hgap] + simp only [← List.replicate_add, explicitOptimizerBisectionSteps] + congr 1 + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSemantics.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSemantics.lean new file mode 100644 index 0000000000..774cf8a54d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerBisectionSemantics.lean @@ -0,0 +1,487 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionLoop +public import Mathlib.Tactic + +/-! +# Exact semantics of the dyadic optimizer bisection machine + +This file proves that the finite-word loop queries exactly the rational +midpoints of the row-major semantic bisection. No numerical interpretation +is inferred from a decoder: every intermediate word is reduced to the +canonical project encoding of its stated rational value. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +@[simp] theorem rawOptimizerInitialLow_value (n : β„•) : + (rawOptimizerInitialLow n).value = -(2 * n ^ 2 : β„š) := by + simp [rawOptimizerInitialLow, rawOptimizerTwiceNSquare, + rawOptimizerTwo, rawOptimizerNSquare, rawOptimizerDimension] + ring + +theorem explicitOptimizerInitialWidth_eq_interval {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + explicitOptimizerInitialWidth A = + betheBisectionInitialHigh A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) - + betheNegativeObjectiveLower m := by + rfl + +@[simp] theorem optimizerDyadicThreshold_zero {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + optimizerDyadicThreshold A 0 0 = betheNegativeObjectiveLower m := by + simp [optimizerDyadicThreshold] + +@[simp] theorem optimizerDyadicThreshold_one_zero {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + optimizerDyadicThreshold A 1 0 = + betheBisectionInitialHigh A (explicitOptimizerMix A) + (explicitOptimizerInnerRadius A) := by + rw [optimizerDyadicThreshold, pow_zero, div_one, + explicitOptimizerInitialWidth_eq_interval] + norm_num + +/-- The raw-rational dyadic fraction `k/2^t`. -/ +def rawDyadicFraction (k t : β„•) : RawRat := + ⟨k, 2 ^ t, pow_pos (by omega) _⟩ + +@[simp] theorem rawDyadicFraction_value (k t : β„•) : + (rawDyadicFraction k t).value = (k : β„š) / 2 ^ t := by + simp [rawDyadicFraction, RawRat.value] + +/-- Encodes a matrix, scheduled iteration ruler, binary index `k`, and unary depth `t` as +bisection state. -/ +def machineOptimizerBisectionCanonicalState {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (k t : β„•) : List Bool := + machineOptimizerBisectionStatePack + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) + (List.replicate (explicitOptimizerBisectionSteps A) true) + k.bits (List.replicate t true) + +@[simp] theorem machineOptimizerBisectionCanonicalState_source {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionStateSource + (machineOptimizerBisectionCanonicalState A k t) = + rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩ := by + simp [machineOptimizerBisectionCanonicalState] + +@[simp] theorem machineOptimizerBisectionCanonicalState_ruler {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionStateRuler + (machineOptimizerBisectionCanonicalState A k t) = + List.replicate (explicitOptimizerBisectionSteps A) true := by + simp [machineOptimizerBisectionCanonicalState] + +@[simp] theorem machineOptimizerBisectionCanonicalState_index {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionStateIndex + (machineOptimizerBisectionCanonicalState A k t) = k.bits := by + simp [machineOptimizerBisectionCanonicalState] + +@[simp] theorem machineOptimizerBisectionCanonicalState_depth {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionStateDepth + (machineOptimizerBisectionCanonicalState A k t) = + List.replicate t true := by + simp [machineOptimizerBisectionCanonicalState] + +@[simp] theorem machineOptimizerInitialLowEntryCode_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineOptimizerInitialLowEntryCode + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rawRatBinaryCode + (rawRatOfRat (betheNegativeObjectiveLower m)) := by + rw [machineOptimizerInitialLowEntryCode, + machineOptimizerTwiceNSquareForWidthRawCode_encode, + machineRawRatNegCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, + RawRat.value_neg, rawOptimizerTwiceNSquare, RawRat.value_mul] + simp [rawOptimizerTwo, rawOptimizerNSquare, + rawOptimizerDimension, betheNegativeObjectiveLower] + ring + +@[simp] theorem machineOptimizerInitialWidthEntryCodeForBisection_encode + {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineOptimizerInitialWidthEntryCodeForBisection + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + rawRatBinaryCode (rawRatOfRat (explicitOptimizerInitialWidth A)) := by + rw [machineOptimizerInitialWidthEntryCodeForBisection, + machineExplicitOptimizerInitialWidthRawCode_encode (by omega), + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, + rawExplicitOptimizerInitialWidth_eq] + +@[simp] theorem machineOptimizerBisectionEvenIndexBits_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionEvenIndexBits + (machineOptimizerBisectionCanonicalState A k t) = + (2 * k).bits := by + rw [machineOptimizerBisectionEvenIndexBits, + machineOptimizerBisectionCanonicalState_index] + change machineBinaryMulBits (pair k.bits (2 : β„•).bits) = _ + rw [machineBinaryMulBits_pair_natBits] + congr 1 + omega + +@[simp] theorem machineOptimizerBisectionOddIndexBits_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionOddIndexBits + (machineOptimizerBisectionCanonicalState A k t) = + (2 * k + 1).bits := by + rw [machineOptimizerBisectionOddIndexBits, + machineOptimizerBisectionEvenIndexBits_encode] + change machineBinaryAddBits (pair (2 * k).bits (1 : β„•).bits) = _ + rw [machineBinaryAddBits_pair_natBits] + +@[simp] theorem machineOptimizerBisectionNextDepth_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionNextDepth + (machineOptimizerBisectionCanonicalState A k t) = + List.replicate (t + 1) true := by + rw [machineOptimizerBisectionNextDepth, + machineOptimizerBisectionCanonicalState_depth, + List.replicate_succ] + +@[simp] theorem machineOptimizerBisectionDenominatorBits_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionDenominatorBits + (machineOptimizerBisectionCanonicalState A k t) = + (2 ^ (t + 1)).bits := by + rw [machineOptimizerBisectionDenominatorBits, + machineOptimizerBisectionNextDepth_encode, + machineDirectedLogPowerTwoBits_encode, List.length_replicate] + +@[simp] theorem machineOptimizerBisectionFractionRawCode_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionFractionRawCode + (machineOptimizerBisectionCanonicalState A k t) = + rawRatBinaryCode (rawDyadicFraction (2 * k + 1) (t + 1)) := by + rw [machineOptimizerBisectionFractionRawCode, + machineOptimizerBisectionOddIndexBits_encode, + machineOptimizerBisectionDenominatorBits_encode, + machineNaturalIntegerCode_natBits] + rfl + +@[simp] theorem machineOptimizerBisectionMidpointRawCode_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionMidpointRawCode + (machineOptimizerBisectionCanonicalState A k t) = + rawRatBinaryCode + (rawRatOfRat (optimizerDyadicThreshold A (2 * k + 1) (t + 1))) := by + rw [machineOptimizerBisectionMidpointRawCode, + machineOptimizerBisectionMidpointUnnormalizedRawCode, + machineOptimizerBisectionScaledFractionRawCode, + machineOptimizerBisectionCanonicalState_source, + machineOptimizerBisectionFractionRawCode_encode, + machineOptimizerInitialWidthEntryCodeForBisection_encode, + machineRawRatMulCode_encode, + machineOptimizerInitialLowEntryCode_encode, + machineRawRatAddCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, + RawRat.value_add, RawRat.value_mul, rawRatOfRat_value, + rawRatOfRat_value, rawDyadicFraction_value] + rfl + +@[simp] theorem machineOptimizerBisectionFeasibilityResult_encode {m : β„•} + (hm : 0 < m) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hA : βˆ€ i j, 0 < A i j) (k t : β„•) : + machineOptimizerBisectionFeasibilityResult + (machineOptimizerBisectionCanonicalState A k t) = + rationalFeasibilityResultBinaryCode + (runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (rawRatOfRat + (optimizerDyadicThreshold A (2 * k + 1) (t + 1))) + (explicitOptimizerInnerRadius A)) := by + rw [machineOptimizerBisectionFeasibilityResult, + machineOptimizerBisectionFeasibilityCall, + machineOptimizerBisectionCanonicalState_source, + machineOptimizerBisectionMidpointRawCode_encode] + exact machineExplicitBetheThresholdFeasibilityCode_encode hm A hA _ + +/-! ## Indexed semantic loop and exact step simulation -/ + +/-- Updates the dyadic index to `2*k` on midpoint acceptance or `2*k + 1` on exhaustion. -/ +def scannedOptimizerIndexStep {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (k t : β„•) : β„• := + match runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (rawRatOfRat + (optimizerDyadicThreshold A (2 * k + 1) (t + 1))) + (explicitOptimizerInnerRadius A) with + | .accepted _ => 2 * k + | .exhausted _ => 2 * k + 1 + +/-- Runs the semantic dyadic-index update for a specified number of steps from depth `t` and +index `k`. -/ +def runScannedOptimizerIndex {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + β„• β†’ β„• β†’ β„• β†’ β„• + | 0, _t, k => k + | N + 1, t, k => + runScannedOptimizerIndex A N (t + 1) + (scannedOptimizerIndexStep A k t) + +theorem machineOptimizerBisectionStep_encode {m : β„•} + (hm : 0 < m) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hA : βˆ€ i j, 0 < A i j) (k t : β„•) : + machineOptimizerBisectionStep + (machineOptimizerBisectionCanonicalState A k t) = + machineOptimizerBisectionCanonicalState A + (scannedOptimizerIndexStep A k t) (t + 1) := by + rw [machineOptimizerBisectionStep, + machineOptimizerBisectionCanonicalState_source, + machineOptimizerBisectionCanonicalState_ruler, + machineOptimizerBisectionNextDepth_encode, + machineOptimizerBisectionNextIndexBits, + machineOptimizerBisectionExhaustedBit, + machineOptimizerBisectionFeasibilityResult_encode hm A hA] + cases hrun : runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (rawRatOfRat + (optimizerDyadicThreshold A (2 * k + 1) (t + 1))) + (explicitOptimizerInnerRadius A) with + | accepted q => + simp only [rationalFeasibilityResultBinaryCode, + scannedOptimizerIndexStep, hrun, + machinePairFirst_pair, machineHeadBit_cons, + machineIfHead_false] + rw [machineOptimizerBisectionEvenIndexBits_encode] + rfl + | exhausted E => + simp only [rationalFeasibilityResultBinaryCode, + scannedOptimizerIndexStep, hrun, + machinePairFirst_pair, machineHeadBit_cons, + machineIfHead_true] + rw [machineOptimizerBisectionOddIndexBits_encode] + rfl + +theorem machineOptimizerBisectionIterate_encode {m : β„•} + (hm : 0 < m) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hA : βˆ€ i j, 0 < A i j) (k t : β„•) : βˆ€ N : β„•, + (machineOptimizerBisectionStep)^[N] + (machineOptimizerBisectionCanonicalState A k t) = + machineOptimizerBisectionCanonicalState A + (runScannedOptimizerIndex A N t k) (t + N) := by + intro N + induction N generalizing k t with + | zero => simp [runScannedOptimizerIndex] + | succ N ih => + rw [Function.iterate_succ_apply, + machineOptimizerBisectionStep_encode hm A hA, + ih, runScannedOptimizerIndex] + have ht : t + 1 + N = t + (N + 1) := by omega + rw [ht] + +@[simp] theorem machineOptimizerBisectionInit_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineOptimizerBisectionInit + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + machineOptimizerBisectionCanonicalState A 0 0 := by + rw [machineOptimizerBisectionInit, + machineExplicitOptimizerBisectionStepsRuler_encode] + rfl + +@[simp] theorem machineOptimizerBisectionFinalState_encode {m : β„•} + (hm : 0 < m) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hA : βˆ€ i j, 0 < A i j) : + machineOptimizerBisectionFinalState + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + machineOptimizerBisectionCanonicalState A + (runScannedOptimizerIndex A (explicitOptimizerBisectionSteps A) 0 0) + (explicitOptimizerBisectionSteps A) := by + rw [machineOptimizerBisectionFinalState, + machineExplicitOptimizerBisectionStepsRuler_encode, + List.length_replicate, machineOptimizerBisectionInit_encode, + machineOptimizerBisectionIterate_encode hm A hA] + simp + +@[simp] theorem machineOptimizerBisectionHighIndexBits_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionHighIndexBits + (machineOptimizerBisectionCanonicalState A k t) = + (k + 1).bits := by + rw [machineOptimizerBisectionHighIndexBits, + machineOptimizerBisectionCanonicalState_index] + change machineBinaryAddBits (pair k.bits (1 : β„•).bits) = _ + rw [machineBinaryAddBits_pair_natBits] + +@[simp] theorem machineOptimizerBisectionHighFractionRawCode_encode + {m : β„•} (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (k t : β„•) : + machineOptimizerBisectionHighFractionRawCode + (machineOptimizerBisectionCanonicalState A k t) = + rawRatBinaryCode (rawDyadicFraction (k + 1) t) := by + rw [machineOptimizerBisectionHighFractionRawCode, + machineOptimizerBisectionHighIndexBits_encode, + machineOptimizerBisectionCanonicalState_depth, + machineNaturalIntegerCode_natBits, + machineDirectedLogPowerTwoBits_encode, List.length_replicate] + rfl + +@[simp] theorem machineOptimizerBisectionHighRawCode_encode {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + machineOptimizerBisectionHighRawCode + (machineOptimizerBisectionCanonicalState A k t) = + rawRatBinaryCode + (rawRatOfRat (optimizerDyadicThreshold A (k + 1) t)) := by + rw [machineOptimizerBisectionHighRawCode, + machineOptimizerBisectionHighUnnormalizedRawCode, + machineOptimizerBisectionHighScaledRawCode, + machineOptimizerBisectionCanonicalState_source, + machineOptimizerBisectionHighFractionRawCode_encode, + machineOptimizerInitialWidthEntryCodeForBisection_encode, + machineRawRatMulCode_encode, + machineOptimizerInitialLowEntryCode_encode, + machineRawRatAddCode_encode, + machineNormalizeRawRatEntryCode_encode, + rawRatBinaryCode_rawRatOfRat] + apply congrArg rationalEntryBinaryCode + rw [binaryNormalizeRawRat_eq_value, + RawRat.value_add, RawRat.value_mul, rawRatOfRat_value, + rawRatOfRat_value, rawDyadicFraction_value] + rfl + +/-! ## Equivalence with ordinary midpoint bisection -/ + +theorem optimizerDyadicThreshold_even {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + optimizerDyadicThreshold A (2 * k) (t + 1) = + optimizerDyadicThreshold A k t := by + simp only [optimizerDyadicThreshold] + push_cast + rw [pow_succ] + ring + +theorem optimizerDyadicThreshold_odd_midpoint {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + optimizerDyadicThreshold A (2 * k + 1) (t + 1) = + (optimizerDyadicThreshold A k t + + optimizerDyadicThreshold A (k + 1) t) / 2 := by + simp only [optimizerDyadicThreshold] + push_cast + rw [pow_succ] + ring + +theorem optimizerDyadicThreshold_odd_high {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) (k t : β„•) : + optimizerDyadicThreshold A (2 * k + 1 + 1) (t + 1) = + optimizerDyadicThreshold A (k + 1) t := by + simp only [optimizerDyadicThreshold] + push_cast + rw [pow_succ] + ring + +/-- Relates a bisection state's endpoints to adjacent dyadic thresholds with index `k` and depth +`t`. -/ +def ScannedOptimizerIndexAgrees {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (s : BetheBisectionState (m * m + 1)) (k t : β„•) : Prop := + s.low = optimizerDyadicThreshold A k t ∧ + s.high = optimizerDyadicThreshold A (k + 1) t + +theorem initialScannedOptimizerIndexAgrees {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + ScannedOptimizerIndexAgrees A + (initialScannedBetheBisectionState + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (explicitOptimizerMix A) (explicitOptimizerInnerRadius A)) 0 0 := by + constructor + Β· rw [initialScannedBetheBisectionState_low, + optimizerDyadicThreshold_zero] + Β· rw [initialScannedBetheBisectionState_high, + optimizerDyadicThreshold_one_zero] + +theorem scannedOptimizerIndexStep_agrees {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + {s : BetheBisectionState (m * m + 1)} {k t : β„•} + (hs : ScannedOptimizerIndexAgrees A s k t) : + ScannedOptimizerIndexAgrees A + (scannedBetheBisectionStep + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (explicitOptimizerInnerRadius A) s) + (scannedOptimizerIndexStep A k t) (t + 1) := by + rcases hs with ⟨hlow, hhigh⟩ + rw [scannedBetheBisectionStep] + have hmid : (s.low + s.high) / 2 = + optimizerDyadicThreshold A (2 * k + 1) (t + 1) := by + rw [hlow, hhigh, optimizerDyadicThreshold_odd_midpoint] + rw [hmid] + cases hrun : runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (rawRatOfRat + (optimizerDyadicThreshold A (2 * k + 1) (t + 1))) + (explicitOptimizerInnerRadius A) with + | accepted q => + simp only [scannedOptimizerIndexStep, hrun] + constructor + Β· simpa only [optimizerDyadicThreshold_even] using! hlow + Β· rfl + | exhausted E => + simp only [scannedOptimizerIndexStep, hrun] + constructor + Β· rfl + Β· simpa only [optimizerDyadicThreshold_odd_high] using! hhigh + +theorem runScannedOptimizerIndex_agrees {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + {s : BetheBisectionState (m * m + 1)} {k t : β„•} + (hs : ScannedOptimizerIndexAgrees A s k t) : βˆ€ N : β„•, + ScannedOptimizerIndexAgrees A + (runScannedBetheBisection + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) + (explicitOptimizerInnerRadius A) N s) + (runScannedOptimizerIndex A N t k) (t + N) := by + intro N + induction N generalizing s k t with + | zero => simpa [runScannedBetheBisection, + runScannedOptimizerIndex] using! hs + | succ N ih => + rw [runScannedBetheBisection, runScannedOptimizerIndex] + have hstep := scannedOptimizerIndexStep_agrees A hs + simpa only [Nat.add_assoc, Nat.add_comm 1 N] using! ih hstep + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerCertificateBoundary.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerCertificateBoundary.lean new file mode 100644 index 0000000000..b517b8e6db --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerCertificateBoundary.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.OptimizerOutputEncoding + +/-! +# The finite-word interface between optimization and certification + +The normalized positive routine has two logically distinct executable parts: +the regularized-Bethe optimizer returns a rational matrix and two rational +potential vectors, and the certificate evaluator consumes exactly those three +objects. This file fixes their finite-word interface and proves that +polynomial-time machines realizing the two parts compose to a raw-output +machine for `explicitNormalizedCertificateAlgorithm`. + +There is deliberately no decoder or noncomputable choice in this interface. +Every well-formed optimizer output is a right-nested word built from the +already fixed matrix and rational-entry encodings. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The exact optimizer output used by the paper in dimensions at least two. -/ +def explicitLargeOptimizerOutput (m : β„•) + (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) : + RationalOptimizerOutput (m + 2) where + matrix := explicitBetheOptimizerMatrix (m := m + 1) B + rowPotential := explicitBetheOptimizerRowPotential (m := m + 1) B + columnPotential := explicitBetheOptimizerColumnPotential (m := m + 1) B + +/-- A raw string function realizes the optimizer on every canonical input of +dimension at least two. -/ +def LargeOptimizerStringRealizes (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + F (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) = + rationalOptimizerOutputCode (explicitLargeOptimizerOutput m B) + +/-- A raw string function realizes the directed certificate evaluator on the +canonical words actually emitted by the fixed optimizer. Its input retains +the original normalized matrix word as the first component and the optimizer +output as the second. This source guard is necessary: optimizer potentials +of numerical size `W` can have only `O(log W)` encoded bits, while the final +exponential output can require `Theta(W)` bits. -/ +def CertificateEvaluatorStringRealizes + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + F (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode (explicitLargeOptimizerOutput m B))) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + +/-- The certificate evaluator is used only on positive matrices whose entries +are at most one. These are exactly the normalized matrices supplied by the +positive routine. Requiring correctness outside this domain would impose an +irrelevant numerical-magnitude claim on the totalized optimizer. -/ +def CertificateEvaluatorStringRealizesOnPositiveNormalized + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + F (pair (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) + (rationalOptimizerOutputCode (explicitLargeOptimizerOutput m B))) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B))) + +/-- Compose optimizer and certificate machines, retaining the exact zero +branches in dimensions zero and one. -/ +def machineNormalizedCertificateFromParts + (optimizerMachine certificateMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineIfHead (machineCompletedDimensionLtTwoBit word) + (rawRatBinaryCode RawRat.zero) + (certificateMachine (pair word (optimizerMachine word))) + +theorem machineNormalizedCertificateFromParts_mem_FP + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizer : optimizerMachine ∈ Complexity.FP) + (hcertificate : certificateMachine ∈ Complexity.FP) : + machineNormalizedCertificateFromParts + optimizerMachine certificateMachine ∈ Complexity.FP := by + have hpair := machinePair_mem_FP id_mem_FP hoptimizer + have hcompose := machineCompose_mem_FP hpair hcertificate + exact machineIfHead_mem_FP machineCompletedDimensionLtTwoBit_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) hcompose + +theorem machineNormalizedCertificateFromParts_realizes + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) + (hcertificate : CertificateEvaluatorStringRealizes certificateMachine) : + RawStringRealizes + (machineNormalizedCertificateFromParts + optimizerMachine certificateMachine) + explicitNormalizedCertificateAlgorithm := by + intro x + obtain ⟨n, B⟩ := x + rw [machineNormalizedCertificateFromParts, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true] + interval_cases n <;> rfl + Β· rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false] + obtain ⟨m, rfl⟩ : βˆƒ m, n = m + 2 := by + use n - 2 + omega + rw [hoptimizer m B] + exact hcertificate m B + +theorem machineNormalizedCertificateFromParts_realizes_onPositive + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) + (hcertificate : + CertificateEvaluatorStringRealizesOnPositiveNormalized certificateMachine) : + NormalizedCertificateStringRealizesOnPositive + (machineNormalizedCertificateFromParts + optimizerMachine certificateMachine) := by + intro m B hBpos hBupper + rw [machineNormalizedCertificateFromParts, + machineCompletedDimensionLtTwoBit_encode, + show [decide (m + 2 < 2)] = [false] by simp, + machineIfHead_false, hoptimizer m B] + exact hcertificate m B hBpos hBupper + +theorem normalizedCertificate_rawMachine_of_parts + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizerFP : optimizerMachine ∈ Complexity.FP) + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hcertificate : CertificateEvaluatorStringRealizes certificateMachine) : + βˆƒ F : List Bool β†’ List Bool, + F ∈ Complexity.FP ∧ + RawStringRealizes F explicitNormalizedCertificateAlgorithm := by + exact ⟨machineNormalizedCertificateFromParts + optimizerMachine certificateMachine, + machineNormalizedCertificateFromParts_mem_FP + hoptimizerFP hcertificateFP, + machineNormalizedCertificateFromParts_realizes + hoptimizer hcertificate⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerDerivedScales.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerDerivedScales.lean new file mode 100644 index 0000000000..6a5be77fbc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerDerivedScales.lean @@ -0,0 +1,549 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerInteriorScale +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMin + +/-! +# Remaining rational scales and precision ruler for the optimizer + +Starting from the guarded dyadic interior floor, all remaining scales are +formed by exact unreduced rational arithmetic. The precision is emitted +directly as a unary ruler assembled from the exact canonical encoding length +of the objective gap and fixed dimension-dependent summands. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw-rational constant one used in optimizer scale formulas. -/ +def rawOptimizerOne : RawRat := RawRat.ofNat 1 + +/-- The raw-rational constant three used in optimizer scale formulas. -/ +def rawOptimizerThree : RawRat := RawRat.ofNat 3 + +/-- The raw-rational constant ten used in optimizer scale formulas. -/ +def rawOptimizerTen : RawRat := RawRat.ofNat 10 + +/-- The raw-rational constant forty-eight used in optimizer scale formulas. -/ +def rawOptimizerFortyEight : RawRat := RawRat.ofNat 48 + +/-- The raw-rational representation of the fixed optimizer KKT error allowance. -/ +def rawOptimizerKKTError : RawRat := rawRatOfRat explicitKKTError + +/-- Half the power of one half determined by the numerical interior exponent. -/ +def rawExplicitOptimizerFloor (n B : β„•) : RawRat := + (rawOptimizerHalf.pow + (numericalInteriorExponent n B (explicitRegularizationScale n))).div + rawOptimizerTwo + +/-- The optimizer radius parameter given by the floor times the KKT error allowance divided by +48. -/ +def rawExplicitOptimizerRho (n B : β„•) : RawRat := + ((rawExplicitOptimizerFloor n B).mul rawOptimizerKKTError).div + rawOptimizerFortyEight + +/-- The optimizer gap given by the regularization parameter times the squared radius, divided by +four. -/ +def rawExplicitOptimizerGap (n B : β„•) : RawRat := + ((rawOptimizerTau n).mul + ((rawExplicitOptimizerRho n B).mul (rawExplicitOptimizerRho n B))).div + rawOptimizerFour + +/-- The raw-rational objective range `n*B + 3*n^2`. -/ +def rawOptimizerObjectiveRange (n B : β„•) : RawRat := + ((rawOptimizerDimension n).mul (rawOptimizerBitBound B)).add + (rawOptimizerThree.mul (rawOptimizerNSquare n)) + +/-- Four times one plus the objective range, used as the mixing denominator. -/ +def rawOptimizerMixDenominator (n B : β„•) : RawRat := + rawOptimizerFour.mul ((rawOptimizerObjectiveRange n B).add rawOptimizerOne) + +/-- The candidate mixing parameter obtained by dividing the optimizer gap by its mixing +denominator. -/ +def rawOptimizerMixCandidate (n B : β„•) : RawRat := + (rawExplicitOptimizerGap n B).div (rawOptimizerMixDenominator n B) + +/-- The smaller of one half and the candidate optimizer mixing parameter. -/ +def rawExplicitOptimizerMix (n B : β„•) : RawRat := + if rawOptimizerHalf.value ≀ (rawOptimizerMixCandidate n B).value then + rawOptimizerHalf + else rawOptimizerMixCandidate n B + +/-- The raw-rational quantity `2*n`. -/ +def rawOptimizerTwiceDimension (n : β„•) : RawRat := + rawOptimizerTwo.mul (rawOptimizerDimension n) + +/-- The inner radius given by the mixing parameter divided by twice the dimension. -/ +def rawExplicitOptimizerInnerRadius (n B : β„•) : RawRat := + (rawExplicitOptimizerMix n B).div (rawOptimizerTwiceDimension n) + +/-! ## Finite-word scale machines -/ + +/-- Computes the encoded floor times the KKT error allowance, divided by 48. -/ +def machineExplicitOptimizerRhoRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair + (machineRawRatMulCode + (pair (machineExplicitOptimizerFloorRawCode word) + (rawRatBinaryCode rawOptimizerKKTError))) + (rawRatBinaryCode rawOptimizerFortyEight)) + +/-- Squares the encoded optimizer radius parameter. -/ +def machineExplicitOptimizerRhoSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineExplicitOptimizerRhoRawCode word) + (machineExplicitOptimizerRhoRawCode word)) + +/-- Multiplies the encoded regularization parameter by the squared radius. -/ +def machineExplicitOptimizerGapNumeratorRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerTauRawCode word) + (machineExplicitOptimizerRhoSquareRawCode word)) + +/-- Divides the gap numerator by four. -/ +def machineExplicitOptimizerGapRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineExplicitOptimizerGapNumeratorRawCode word) + (rawRatBinaryCode rawOptimizerFour)) + +/-- Computes the encoded quantity `3*n^2`. -/ +def machineOptimizerThreeNSquareRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerThree) + (machineOptimizerNSquareRawCode word)) + +/-- Adds `n*B` and `3*n^2` to encode the objective range. -/ +def machineOptimizerObjectiveRangeRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerNBProductRawCode word) + (machineOptimizerThreeNSquareRawCode word)) + +/-- Adds one to the encoded objective range. -/ +def machineOptimizerRangePlusOneRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerObjectiveRangeRawCode word) + (rawRatBinaryCode rawOptimizerOne)) + +/-- Multiplies the objective range plus one by four for the mixing denominator. -/ +def machineOptimizerMixDenominatorRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerFour) + (machineOptimizerRangePlusOneRawCode word)) + +/-- Divides the encoded optimizer gap by the mixing denominator. -/ +def machineOptimizerMixCandidateRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineExplicitOptimizerGapRawCode word) + (machineOptimizerMixDenominatorRawCode word)) + +/-- Takes the raw-rational minimum of one half and the candidate mixing parameter. -/ +def machineExplicitOptimizerMixRawCode (word : List Bool) : List Bool := + machineRawRatMinCode + (pair (rawRatBinaryCode rawOptimizerHalf) + (machineOptimizerMixCandidateRawCode word)) + +/-- Computes the encoded quantity twice the matrix dimension. -/ +def machineOptimizerTwiceDimensionRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineOptimizerDimensionRawCode word)) + +/-- Divides the encoded mixing parameter by twice the dimension to obtain the inner radius. -/ +def machineExplicitOptimizerInnerRadiusRawCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineExplicitOptimizerMixRawCode word) + (machineOptimizerTwiceDimensionRawCode word)) + +/-! ## Polynomial-time closure -/ + +theorem machineExplicitOptimizerRhoRawCode_mem_FP : + machineExplicitOptimizerRhoRawCode ∈ FP := by + have hproduct := machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerFloorRawCode_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerKKTError))) + machineRawRatMulCode_mem_FP + simpa only [machineExplicitOptimizerRhoRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP hproduct + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerFortyEight))) + machineRawRatDivCode_mem_FP + +theorem machineExplicitOptimizerRhoSquareRawCode_mem_FP : + machineExplicitOptimizerRhoSquareRawCode ∈ FP := by + simpa only [machineExplicitOptimizerRhoSquareRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerRhoRawCode_mem_FP + machineExplicitOptimizerRhoRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineExplicitOptimizerGapNumeratorRawCode_mem_FP : + machineExplicitOptimizerGapNumeratorRawCode ∈ FP := by + simpa only [machineExplicitOptimizerGapNumeratorRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerTauRawCode_mem_FP + machineExplicitOptimizerRhoSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineExplicitOptimizerGapRawCode_mem_FP : + machineExplicitOptimizerGapRawCode ∈ FP := by + simpa only [machineExplicitOptimizerGapRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerGapNumeratorRawCode_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerFour))) + machineRawRatDivCode_mem_FP + +theorem machineOptimizerThreeNSquareRawCode_mem_FP : + machineOptimizerThreeNSquareRawCode ∈ FP := by + simpa only [machineOptimizerThreeNSquareRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerThree)) + machineOptimizerNSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerObjectiveRangeRawCode_mem_FP : + machineOptimizerObjectiveRangeRawCode ∈ FP := by + simpa only [machineOptimizerObjectiveRangeRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerNBProductRawCode_mem_FP + machineOptimizerThreeNSquareRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerRangePlusOneRawCode_mem_FP : + machineOptimizerRangePlusOneRawCode ∈ FP := by + simpa only [machineOptimizerRangePlusOneRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerObjectiveRangeRawCode_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerOne))) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerMixDenominatorRawCode_mem_FP : + machineOptimizerMixDenominatorRawCode ∈ FP := by + simpa only [machineOptimizerMixDenominatorRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerFour)) + machineOptimizerRangePlusOneRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerMixCandidateRawCode_mem_FP : + machineOptimizerMixCandidateRawCode ∈ FP := by + simpa only [machineOptimizerMixCandidateRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerGapRawCode_mem_FP + machineOptimizerMixDenominatorRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +theorem machineExplicitOptimizerMixRawCode_mem_FP : + machineExplicitOptimizerMixRawCode ∈ FP := by + simpa only [machineExplicitOptimizerMixRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerHalf)) + machineOptimizerMixCandidateRawCode_mem_FP) + machineRawRatMinCode_mem_FP + +theorem machineOptimizerTwiceDimensionRawCode_mem_FP : + machineOptimizerTwiceDimensionRawCode ∈ FP := by + simpa only [machineOptimizerTwiceDimensionRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineOptimizerDimensionRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineExplicitOptimizerInnerRadiusRawCode_mem_FP : + machineExplicitOptimizerInnerRadiusRawCode ∈ FP := by + simpa only [machineExplicitOptimizerInnerRadiusRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineExplicitOptimizerMixRawCode_mem_FP + machineOptimizerTwiceDimensionRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +/-! ## Exact semantics -/ + +@[simp] theorem machineExplicitOptimizerRhoRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerRhoRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawExplicitOptimizerRho n (rationalMatrixEntryBitBound A)) := by + rw [machineExplicitOptimizerRhoRawCode, + machineExplicitOptimizerFloorRawCode_encode hn, + machineRawRatMulCode_encode, machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineExplicitOptimizerRhoSquareRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerRhoSquareRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + ((rawExplicitOptimizerRho n + (rationalMatrixEntryBitBound A)).mul + (rawExplicitOptimizerRho n + (rationalMatrixEntryBitBound A))) := by + rw [machineExplicitOptimizerRhoSquareRawCode, + machineExplicitOptimizerRhoRawCode_encode hn, + machineRawRatMulCode_encode] + +@[simp] theorem machineExplicitOptimizerGapRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerGapRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawExplicitOptimizerGap n (rationalMatrixEntryBitBound A)) := by + rw [machineExplicitOptimizerGapRawCode, + machineExplicitOptimizerGapNumeratorRawCode, + machineOptimizerTauRawCode_encode, + machineExplicitOptimizerRhoSquareRawCode_encode hn, + machineRawRatMulCode_encode, machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineOptimizerThreeNSquareRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerThreeNSquareRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerThree.mul (rawOptimizerNSquare n)) := by + rw [machineOptimizerThreeNSquareRawCode, + machineOptimizerNSquareRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerObjectiveRangeRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerObjectiveRangeRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerObjectiveRange n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerObjectiveRangeRawCode, + machineOptimizerNBProductRawCode_encode, + machineOptimizerThreeNSquareRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerRangePlusOneRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerRangePlusOneRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + ((rawOptimizerObjectiveRange n + (rationalMatrixEntryBitBound A)).add rawOptimizerOne) := by + rw [machineOptimizerRangePlusOneRawCode, + machineOptimizerObjectiveRangeRawCode_encode, + machineRawRatAddCode_encode] + +@[simp] theorem machineOptimizerMixDenominatorRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerMixDenominatorRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerMixDenominator n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerMixDenominatorRawCode, + machineOptimizerRangePlusOneRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineOptimizerMixCandidateRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerMixCandidateRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerMixCandidate n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerMixCandidateRawCode, + machineExplicitOptimizerGapRawCode_encode hn, + machineOptimizerMixDenominatorRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineExplicitOptimizerMixRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerMixRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawExplicitOptimizerMix n (rationalMatrixEntryBitBound A)) := by + rw [machineExplicitOptimizerMixRawCode, + machineOptimizerMixCandidateRawCode_encode hn, + machineRawRatMinCode_encode] + rfl + +@[simp] theorem machineOptimizerTwiceDimensionRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTwiceDimensionRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerTwiceDimension n) := by + rw [machineOptimizerTwiceDimensionRawCode, + machineOptimizerDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineExplicitOptimizerInnerRadiusRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerInnerRadiusRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)) := by + rw [machineExplicitOptimizerInnerRadiusRawCode, + machineExplicitOptimizerMixRawCode_encode hn, + machineOptimizerTwiceDimensionRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem rawExplicitOptimizerFloor_value (n B : β„•) : + (rawExplicitOptimizerFloor n B).value = + numericalInteriorFloor n B (explicitRegularizationScale n) / 2 := by + simp [rawExplicitOptimizerFloor, numericalInteriorFloor, + rawOptimizerHalf, rawOptimizerTwo] + +@[simp] theorem rawExplicitOptimizerRho_value (n B : β„•) : + (rawExplicitOptimizerRho n B).value = + numericalInteriorFloor n B (explicitRegularizationScale n) / 2 * + explicitKKTError / 48 := by + simp [rawExplicitOptimizerRho, rawOptimizerKKTError, + rawOptimizerFortyEight] + +@[simp] theorem rawExplicitOptimizerGap_value (n B : β„•) : + (rawExplicitOptimizerGap n B).value = + explicitRegularizationScale n * + (numericalInteriorFloor n B (explicitRegularizationScale n) / 2 * + explicitKKTError / 48) ^ 2 / 4 := by + simp [rawExplicitOptimizerGap, rawOptimizerFour, pow_two] + +@[simp] theorem rawOptimizerObjectiveRange_value (n B : β„•) : + (rawOptimizerObjectiveRange n B).value = n * B + 3 * n ^ 2 := by + simp [rawOptimizerObjectiveRange, rawOptimizerThree, + rawOptimizerNSquare] + ring + +@[simp] theorem rawOptimizerMixDenominator_value (n B : β„•) : + (rawOptimizerMixDenominator n B).value = + 4 * ((rawOptimizerObjectiveRange n B).value + 1) := by + simp [rawOptimizerMixDenominator, rawOptimizerFour, rawOptimizerOne] + +@[simp] theorem rawOptimizerMixCandidate_value (n B : β„•) : + (rawOptimizerMixCandidate n B).value = + (rawExplicitOptimizerGap n B).value / + (4 * ((rawOptimizerObjectiveRange n B).value + 1)) := by + simp [rawOptimizerMixCandidate] + +@[simp] theorem rawExplicitOptimizerMix_value (n B : β„•) : + (rawExplicitOptimizerMix n B).value = + min (1 / 2) + ((rawExplicitOptimizerGap n B).value / + (4 * ((rawOptimizerObjectiveRange n B).value + 1))) := by + rw [← rawOptimizerHalf_value, + ← rawOptimizerMixCandidate_value] + rw [rawExplicitOptimizerMix] + by_cases h : rawOptimizerHalf.value ≀ + (rawOptimizerMixCandidate n B).value + Β· rw [ite_eq_left h, min_eq_left h] + Β· rw [ite_eq_right h, min_eq_right (le_of_not_ge h)] + +@[simp] theorem rawExplicitOptimizerInnerRadius_value (n B : β„•) : + (rawExplicitOptimizerInnerRadius n B).value = + (rawExplicitOptimizerMix n B).value / (2 * n) := by + simp [rawExplicitOptimizerInnerRadius, rawOptimizerTwiceDimension, + rawOptimizerTwo] + +theorem rawExplicitOptimizerScales_value {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)).value = explicitOptimizerFloor A ∧ + (rawExplicitOptimizerRho (m + 1) + (rationalMatrixEntryBitBound A)).value = explicitOptimizerRho A ∧ + (rawExplicitOptimizerGap (m + 1) + (rationalMatrixEntryBitBound A)).value = explicitOptimizerGap A ∧ + (rawExplicitOptimizerMix (m + 1) + (rationalMatrixEntryBitBound A)).value = explicitOptimizerMix A ∧ + (rawExplicitOptimizerInnerRadius (m + 1) + (rationalMatrixEntryBitBound A)).value = + explicitOptimizerInnerRadius A := by + simp [explicitOptimizerFloor, explicitOptimizerRho, explicitOptimizerGap, + explicitOptimizerMix, explicitOptimizerInnerRadius, + rationalRegularizedObjectiveRange] + +/-! ## Exact unary precision ruler -/ + +/-- Normalizes the raw optimizer gap into a rational entry code. -/ +def machineExplicitOptimizerGapEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineExplicitOptimizerGapRawCode word) + +/-- Builds an entry-length ruler for the normalized optimizer gap. -/ +def machineExplicitOptimizerGapLengthRuler + (word : List Bool) : List Bool := + machineOptimizerEntryLengthRuler + (machineExplicitOptimizerGapEntryCode word) + +/-- Schedules precision from the gap length, KKT-error encoding length, twice the dimension, and +ten extra steps. -/ +def machineExplicitOptimizerPrecisionRuler + (word : List Bool) : List Bool := + machineExplicitOptimizerGapLengthRuler word ++ + (List.replicate (encodedBitLength β„š explicitKKTError) true ++ + (machineOptimizerDimensionUnary word ++ + (machineOptimizerDimensionUnary word ++ List.replicate 10 true))) + +theorem machineExplicitOptimizerGapEntryCode_mem_FP : + machineExplicitOptimizerGapEntryCode ∈ FP := by + simpa only [machineExplicitOptimizerGapEntryCode] using! + machineCompose_mem_FP machineExplicitOptimizerGapRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineExplicitOptimizerGapLengthRuler_mem_FP : + machineExplicitOptimizerGapLengthRuler ∈ FP := by + simpa only [machineExplicitOptimizerGapLengthRuler] using! + machineCompose_mem_FP machineExplicitOptimizerGapEntryCode_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + +theorem machineExplicitOptimizerPrecisionRuler_mem_FP : + machineExplicitOptimizerPrecisionRuler ∈ FP := by + have hdim2 := machineAppend_mem_FP machineOptimizerDimensionUnary_mem_FP + (machineAppend_mem_FP machineOptimizerDimensionUnary_mem_FP + (machineConst_mem_FP (List.replicate 10 true))) + have htail := machineAppend_mem_FP + (machineConst_mem_FP + (List.replicate (encodedBitLength β„š explicitKKTError) true)) hdim2 + simpa only [machineExplicitOptimizerPrecisionRuler] using! + machineAppend_mem_FP machineExplicitOptimizerGapLengthRuler_mem_FP htail + +@[simp] theorem machineExplicitOptimizerGapEntryCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerGapEntryCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalEntryBinaryCode + ((rawExplicitOptimizerGap n + (rationalMatrixEntryBitBound A)).value) := by + rw [machineExplicitOptimizerGapEntryCode, + machineExplicitOptimizerGapRawCode_encode hn, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value] + +@[simp] theorem machineExplicitOptimizerGapLengthRuler_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerGapLengthRuler + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate + (encodedBitLength β„š + ((rawExplicitOptimizerGap n + (rationalMatrixEntryBitBound A)).value)) true := by + rw [machineExplicitOptimizerGapLengthRuler, + machineExplicitOptimizerGapEntryCode_encode hn, + machineOptimizerEntryLengthRuler_encode] + +@[simp] theorem machineExplicitOptimizerPrecisionRuler_encode + {m : β„•} (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + machineExplicitOptimizerPrecisionRuler + (rationalMatrixBinaryEncoding.encode ⟨m + 1, A⟩) = + List.replicate (explicitOptimizerPrecision A) true := by + rw [machineExplicitOptimizerPrecisionRuler, + machineExplicitOptimizerGapLengthRuler_encode (by omega), + machineOptimizerDimensionUnary_encode] + have hgap := (rawExplicitOptimizerScales_value A).2.2.1 + rw [hgap] + simp only [← List.replicate_add, explicitOptimizerPrecision] + congr 1 + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerEntryLength.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerEntryLength.lean new file mode 100644 index 0000000000..546c566147 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerEntryLength.lean @@ -0,0 +1,425 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds + +/-! +# Exact unary lengths for optimizer matrix entries + +The optimizer schedules use `encodedBitLength β„š q`, not merely the length of +the machine-facing rational-entry word. This module computes that quantity +exactly from the numerator and denominator subwords. Producing a unary ruler +is the useful form: every later precision loop consumes its schedule in unary. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Assigns data-code size two to false and four to true. -/ +def boolDataSize : Bool β†’ β„• + | false => 2 + | true => 4 + +/-- Sums the data-code sizes of all bits in a word. -/ +def boolDataLength (word : List Bool) : β„• := + (word.map boolDataSize).sum + +/-- Expands each false bit to two unary bits and each true bit to four. -/ +def boolDataRuler (word : List Bool) : List Bool := + word.flatMap fun bit ↦ List.replicate (boolDataSize bit) true + +@[simp] theorem boolDataRuler_length (word : List Bool) : + (boolDataRuler word).length = boolDataLength word := by + simp [boolDataRuler, boolDataLength] + +theorem boolDataRuler_eq_replicate (word : List Bool) : + boolDataRuler word = List.replicate (boolDataLength word) true := by + induction word with + | nil => simp [boolDataRuler, boolDataLength] + | cons bit word ih => + change List.replicate (boolDataSize bit) true ++ boolDataRuler word = _ + rw [ih, ← List.replicate_add] + congr 1 + +theorem boolDataLength_le_four_mul_length (word : List Bool) : + boolDataLength word ≀ 4 * word.length := by + induction word with + | nil => simp [boolDataLength] + | cons bit word ih => + change boolDataSize bit + boolDataLength word ≀ + 4 * (word.length + 1) + cases bit <;> simp [boolDataSize] <;> omega + +theorem bool_dataEncode_size_eq (b : Bool) : + (DataEncode.encode b).size = boolDataSize b := by + cases b <;> norm_num [DataEncode.encode, Data.size, boolDataSize] + +theorem nat_encodedBitLength_eq_boolDataLength (n : β„•) : + encodedBitLength β„• n = 2 + boolDataLength n.bits := by + rw [encodedBitLength_eq_dataSize] + change (Data.l (n.bits.map fun b ↦ DataEncode.encode b)).size = _ + rw [Data.size] + unfold boolDataLength + congr 1 + simp only [List.map_map] + apply congrArg List.sum + apply List.map_congr_left + intro b _ + exact bool_dataEncode_size_eq b + +theorem integer_encodedBitLength_eq_boolDataLength (z : β„€) : + encodedBitLength β„€ z = + 4 + boolDataSize (integerPayload z).1 + + boolDataLength z.natAbs.bits := by + rw [encodedBitLength_eq_dataSize] + change (DataEncode.encode (integerPayload z)).size = _ + rw [show DataEncode.encode (integerPayload z) = + Data.l [DataEncode.encode (integerPayload z).1, + DataEncode.encode (integerPayload z).2] by + exact DataEncode_pair _ _] + simp only [Data.size, List.map_cons, List.map_nil, List.sum_cons, + List.sum_nil, add_zero, bool_dataEncode_size_eq] + rw [← encodedBitLength_eq_dataSize, + nat_encodedBitLength_eq_boolDataLength, integerPayload_snd] + omega + +theorem rational_encodedBitLength_eq_boolDataLength (q : β„š) : + encodedBitLength β„š q = + 8 + boolDataSize (integerPayload q.num).1 + + boolDataLength q.num.natAbs.bits + boolDataLength q.den.bits := by + rw [encodedBitLength_eq_dataSize] + change (DataEncode.encode (rationalPayload q)).size = _ + rw [show DataEncode.encode (rationalPayload q) = + Data.l [DataEncode.encode q.num, DataEncode.encode q.den] by + simpa only [rationalPayload] using! DataEncode_pair q.num q.den] + simp only [Data.size, List.map_cons, List.map_nil, List.sum_cons, + List.sum_nil, add_zero] + rw [← encodedBitLength_eq_dataSize, + ← encodedBitLength_eq_dataSize, + integer_encodedBitLength_eq_boolDataLength, + nat_encodedBitLength_eq_boolDataLength] + omega + +/-! ## A finite-word transducer for `boolDataRuler` -/ + +/-- Encodes a Boolean-data length state as remaining bits and accumulated unary ruler. -/ +def machineBoolDataPack (remaining acc : List Bool) : List Bool := + pair remaining acc + +/-- Extracts the unprocessed bits of the data-length scan. -/ +def machineBoolDataRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the accumulated unary data-length ruler. -/ +def machineBoolDataAcc (state : List Bool) : List Bool := + machinePairSecond state + +/-- Produces four unary bits for a true head and two for a false head. -/ +def machineBoolDataBitRuler (state : List Bool) : List Bool := + machineIfHead (machineBoolDataRemaining state) + (List.replicate 4 true) (List.replicate 2 true) + +/-- Consumes one source bit and appends its data-size ruler to the accumulator. -/ +def machineBoolDataContinue (state : List Bool) : List Bool := + machineBoolDataPack (machineBoolDataRemaining state).tail + (machineBoolDataAcc state ++ machineBoolDataBitRuler state) + +/-- Processes the next data bit, leaving an exhausted scan state fixed. -/ +def machineBoolDataStep (state : List Bool) : List Bool := + machineIfEmpty (machineBoolDataRemaining state) state + (machineBoolDataContinue state) + +/-- Initializes the Boolean-data length scan with the whole word and an empty ruler. -/ +def machineBoolDataInit (word : List Bool) : List Bool := + machineBoolDataPack word [] + +/-- Provides a ruler of length `4 + 4*word.length` for the data-length state bound. -/ +def machineBoolDataBound (word : List Bool) : List Bool := + List.replicate 4 true ++ + (word ++ (word ++ (word ++ word))) + +/-- Packs two copies of the data-length bound to bound the encoded scan state. -/ +def machineBoolDataWidth (word : List Bool) : List Bool := + machineBoolDataPack (machineBoolDataBound word) + (machineBoolDataBound word) + +/-- Runs the data-length scan once per input bit. -/ +def machineBoolDataFinalState (word : List Bool) : List Bool := + (machineBoolDataStep)^[word.length] (machineBoolDataInit word) + +/-- Extracts the complete unary ruler for the input's data-code length. -/ +def machineBoolDataLengthRuler (word : List Bool) : List Bool := + machineBoolDataAcc (machineBoolDataFinalState word) + +theorem machineBoolDataRemaining_mem_FP : + machineBoolDataRemaining ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineBoolDataAcc_mem_FP : + machineBoolDataAcc ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineBoolDataBitRuler_mem_FP : + machineBoolDataBitRuler ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineBoolDataRemaining_mem_FP + (machineConst_mem_FP (List.replicate 4 true)) + (machineConst_mem_FP (List.replicate 2 true)) + +theorem machineBoolDataContinue_mem_FP : + machineBoolDataContinue ∈ Complexity.FP := by + have hremaining := machineCompose_mem_FP + machineBoolDataRemaining_mem_FP machineTail_mem_FP + have hacc := machineAppend_mem_FP machineBoolDataAcc_mem_FP + machineBoolDataBitRuler_mem_FP + exact machinePair_mem_FP hremaining hacc + +theorem machineBoolDataStep_mem_FP : + machineBoolDataStep ∈ Complexity.FP := by + simpa only [machineBoolDataStep] using! + machineIfEmpty_mem_FP machineBoolDataRemaining_mem_FP + id_mem_FP machineBoolDataContinue_mem_FP + +theorem machineBoolDataInit_mem_FP : + machineBoolDataInit ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP (machineConst_mem_FP []) + +theorem machineBoolDataBound_mem_FP : + machineBoolDataBound ∈ Complexity.FP := by + have hdouble := machineAppend_mem_FP id_mem_FP id_mem_FP + have htriple := machineAppend_mem_FP id_mem_FP hdouble + have hquadruple := machineAppend_mem_FP id_mem_FP htriple + simpa only [machineBoolDataBound] using! + machineAppend_mem_FP + (machineConst_mem_FP (List.replicate 4 true)) hquadruple + +theorem machineBoolDataWidth_mem_FP : + machineBoolDataWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineBoolDataBound_mem_FP + machineBoolDataBound_mem_FP + +@[simp] theorem machineBoolDataRemaining_pack (remaining acc) : + machineBoolDataRemaining (machineBoolDataPack remaining acc) = + remaining := by + simp [machineBoolDataRemaining, machineBoolDataPack] + +@[simp] theorem machineBoolDataAcc_pack (remaining acc) : + machineBoolDataAcc (machineBoolDataPack remaining acc) = acc := by + simp [machineBoolDataAcc, machineBoolDataPack] + +/-- Bounds the remaining source and an accumulator growing by at most four bits per iteration. -/ +def MachineBoolDataStateBound + (word : List Bool) (iterations : β„•) (state : List Bool) : Prop := + state = machineBoolDataPack + (machineBoolDataRemaining state) (machineBoolDataAcc state) ∧ + (machineBoolDataRemaining state).length ≀ word.length ∧ + (machineBoolDataAcc state).length ≀ 4 * iterations + +theorem machineBoolDataInit_bound (word : List Bool) : + MachineBoolDataStateBound word 0 (machineBoolDataInit word) := by + simp [MachineBoolDataStateBound, machineBoolDataInit] + +theorem machineBoolDataStep_bound + {word state : List Bool} {iterations : β„•} + (hstate : MachineBoolDataStateBound word iterations state) : + MachineBoolDataStateBound word (iterations + 1) + (machineBoolDataStep state) := by + rcases hstate with ⟨hdecomp, hremaining, hacc⟩ + cases hrem : machineBoolDataRemaining state with + | nil => + rw [machineBoolDataStep, hrem, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc.trans (by omega)⟩ + | cons bit tail => + rw [machineBoolDataStep, hrem, machineIfEmpty_cons, + machineBoolDataContinue] + simp only [MachineBoolDataStateBound, + machineBoolDataRemaining_pack, machineBoolDataAcc_pack, + List.length_append, List.length_tail] + refine ⟨trivial, ?_, ?_⟩ + Β· omega + Β· have hbit : (machineBoolDataBitRuler state).length ≀ 4 := by + rw [machineBoolDataBitRuler, hrem] + cases bit <;> simp + omega + +theorem machineBoolDataIterate_bound (word : List Bool) : βˆ€ k, + MachineBoolDataStateBound word k + ((machineBoolDataStep)^[k] (machineBoolDataInit word)) := by + intro k + induction k with + | zero => exact machineBoolDataInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineBoolDataStep_bound ih + +theorem machineBoolDataIterate_length_le_width + (word : List Bool) (iterations : β„•) + (hiterations : iterations ≀ word.length) : + ((machineBoolDataStep)^[iterations] + (machineBoolDataInit word)).length ≀ + (machineBoolDataWidth word).length := by + rcases machineBoolDataIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc⟩ + rw [hdecomp] + simp only [machineBoolDataPack, machineBoolDataWidth, pair_length, + machineBoolDataBound, List.length_append, List.length_replicate] + omega + +theorem machineBoolDataFinalState_mem_FP : + machineBoolDataFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineBoolDataStep_mem_FP + machineBoolDataInit_mem_FP id_mem_FP machineBoolDataWidth_mem_FP + machineBoolDataIterate_length_le_width + +theorem machineBoolDataLengthRuler_mem_FP : + machineBoolDataLengthRuler ∈ Complexity.FP := by + simpa only [machineBoolDataLengthRuler] using! + machineCompose_mem_FP machineBoolDataFinalState_mem_FP + machineBoolDataAcc_mem_FP + +theorem machineBoolDataIterate_complete (word acc : List Bool) : + (machineBoolDataStep)^[word.length] + (machineBoolDataPack word acc) = + machineBoolDataPack [] (acc ++ boolDataRuler word) := by + induction word generalizing acc with + | nil => simp [boolDataRuler] + | cons bit word ih => + rw [List.length_cons, Function.iterate_succ_apply] + simp only [machineBoolDataStep, machineBoolDataRemaining_pack, + machineIfEmpty_cons, machineBoolDataContinue, + machineBoolDataAcc_pack, List.tail_cons] + have hbit : machineBoolDataBitRuler + (machineBoolDataPack (bit :: word) acc) = + List.replicate (boolDataSize bit) true := by + cases bit <;> simp [machineBoolDataBitRuler, boolDataSize] + rw [hbit, ih] + simp [boolDataRuler, List.append_assoc] + +@[simp] theorem machineBoolDataLengthRuler_encode (word : List Bool) : + machineBoolDataLengthRuler word = boolDataRuler word := by + rw [machineBoolDataLengthRuler, machineBoolDataFinalState, + machineBoolDataInit, machineBoolDataIterate_complete] + simp + +/-! ## One rational entry -/ + +/-- Extracts the encoded integer numerator of a rational entry. -/ +def machineOptimizerEntryNumeratorCode (word : List Bool) : List Bool := + machineRationalEntryNumeratorWord word + +/-- Extracts the numerator's absolute-value bits from a rational entry. -/ +def machineOptimizerEntryNatAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machineOptimizerEntryNumeratorCode word) + +/-- Produces the data-size ruler for the numerator sign, with four bits for negative and two +otherwise. -/ +def machineOptimizerEntrySignRuler (word : List Bool) : List Bool := + machineIfHead (machineOptimizerEntryNumeratorCode word) + (List.replicate 4 true) (List.replicate 2 true) + +/-- Builds the Boolean-data length ruler for the numerator's absolute-value bits. -/ +def machineOptimizerEntryNumeratorRuler (word : List Bool) : List Bool := + machineBoolDataLengthRuler (machineOptimizerEntryNatAbsBits word) + +/-- Builds the Boolean-data length ruler for the rational entry's denominator bits. -/ +def machineOptimizerEntryDenominatorRuler (word : List Bool) : List Bool := + machineBoolDataLengthRuler + (machineRationalEntryDenominatorWord word) + +/-- A unary word of length exactly `encodedBitLength β„š q` on a canonical +rational-entry input. -/ +def machineOptimizerEntryLengthRuler (word : List Bool) : List Bool := + List.replicate 8 true ++ + (machineOptimizerEntrySignRuler word ++ + (machineOptimizerEntryNumeratorRuler word ++ + machineOptimizerEntryDenominatorRuler word)) + +theorem machineOptimizerEntryNumeratorCode_mem_FP : + machineOptimizerEntryNumeratorCode ∈ Complexity.FP := + machineRationalEntryNumeratorWord_mem_FP + +theorem machineOptimizerEntryNatAbsBits_mem_FP : + machineOptimizerEntryNatAbsBits ∈ Complexity.FP := by + simpa only [machineOptimizerEntryNatAbsBits] using! + machineCompose_mem_FP machineOptimizerEntryNumeratorCode_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineOptimizerEntrySignRuler_mem_FP : + machineOptimizerEntrySignRuler ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineOptimizerEntryNumeratorCode_mem_FP + (machineConst_mem_FP (List.replicate 4 true)) + (machineConst_mem_FP (List.replicate 2 true)) + +theorem machineOptimizerEntryNumeratorRuler_mem_FP : + machineOptimizerEntryNumeratorRuler ∈ Complexity.FP := by + simpa only [machineOptimizerEntryNumeratorRuler] using! + machineCompose_mem_FP machineOptimizerEntryNatAbsBits_mem_FP + machineBoolDataLengthRuler_mem_FP + +theorem machineOptimizerEntryDenominatorRuler_mem_FP : + machineOptimizerEntryDenominatorRuler ∈ Complexity.FP := by + simpa only [machineOptimizerEntryDenominatorRuler] using! + machineCompose_mem_FP machineRationalEntryDenominatorWord_mem_FP + machineBoolDataLengthRuler_mem_FP + +theorem machineOptimizerEntryLengthRuler_mem_FP : + machineOptimizerEntryLengthRuler ∈ Complexity.FP := by + have htail := machineAppend_mem_FP + machineOptimizerEntryNumeratorRuler_mem_FP + machineOptimizerEntryDenominatorRuler_mem_FP + have hpayload := machineAppend_mem_FP + machineOptimizerEntrySignRuler_mem_FP htail + simpa only [machineOptimizerEntryLengthRuler] using! + machineAppend_mem_FP + (machineConst_mem_FP (List.replicate 8 true)) hpayload + +@[simp] theorem machineOptimizerEntryNumeratorCode_encode (q : β„š) : + machineOptimizerEntryNumeratorCode (rationalEntryBinaryCode q) = + integerBinaryCode q.num := by + exact machineRationalEntryNumeratorWord_encode q + +@[simp] theorem machineOptimizerEntryNatAbsBits_encode (q : β„š) : + machineOptimizerEntryNatAbsBits (rationalEntryBinaryCode q) = + q.num.natAbs.bits := by + rw [machineOptimizerEntryNatAbsBits, + machineOptimizerEntryNumeratorCode_encode, + machineIntegerNatAbsBits_encode] + +@[simp] theorem machineOptimizerEntrySignRuler_encode (q : β„š) : + machineOptimizerEntrySignRuler (rationalEntryBinaryCode q) = + List.replicate (boolDataSize (integerPayload q.num).1) true := by + rw [machineOptimizerEntrySignRuler, + machineOptimizerEntryNumeratorCode_encode] + cases q.num <;> simp [integerBinaryCode, integerPayload, boolDataSize] + +@[simp] theorem machineOptimizerEntryNumeratorRuler_encode (q : β„š) : + machineOptimizerEntryNumeratorRuler (rationalEntryBinaryCode q) = + boolDataRuler q.num.natAbs.bits := by + simp [machineOptimizerEntryNumeratorRuler] + +@[simp] theorem machineOptimizerEntryDenominatorRuler_encode (q : β„š) : + machineOptimizerEntryDenominatorRuler (rationalEntryBinaryCode q) = + boolDataRuler q.den.bits := by + simp [machineOptimizerEntryDenominatorRuler] + +@[simp] theorem machineOptimizerEntryLengthRuler_encode (q : β„š) : + machineOptimizerEntryLengthRuler (rationalEntryBinaryCode q) = + List.replicate (encodedBitLength β„š q) true := by + rw [machineOptimizerEntryLengthRuler, + machineOptimizerEntrySignRuler_encode, + machineOptimizerEntryNumeratorRuler_encode, + machineOptimizerEntryDenominatorRuler_encode, + rational_encodedBitLength_eq_boolDataLength] + rw [boolDataRuler_eq_replicate, boolDataRuler_eq_replicate] + simp only [← List.replicate_add] + congr 1 + omega + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilityCall.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilityCall.lean new file mode 100644 index 0000000000..eb4ce2d358 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilityCall.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerStateBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalBallInit + +/-! +# A complete finite-word Bethe threshold call + +This module assembles one canonical threshold-feasibility input directly from +the matrix word and a raw rational threshold. Every numerical parameter, +the initial ball, and the state-size ruler are produced by verified +finite-word machines. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Converts the reduced feasibility dimension to a unary ruler bounded by the source word. -/ +def machineOptimizerFeasibilityReducedDimensionUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerFeasibilitySource word) + (machineOptimizerFeasibilityReducedDimensionBits word)) + +/-- Normalizes the source matrix's regularization parameter for the feasibility oracle. -/ +def machineOptimizerFeasibilityTauCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerTauRawCode (machineOptimizerFeasibilitySource word)) + +/-- Obtains the encoded optimizer floor from the source matrix. -/ +def machineOptimizerFeasibilityDeltaRawCode + (word : List Bool) : List Bool := + machineExplicitOptimizerFloorRawCode + (machineOptimizerFeasibilitySource word) + +/-- Packages dimension, precision, regularization, floor, threshold, and source for the static +feasibility oracle. -/ +def machineOptimizerFeasibilityOracleStaticCode + (word : List Bool) : List Bool := + pair (machineOptimizerFeasibilityReducedDimensionUnary word) + (pair + (machineExplicitOptimizerPrecisionRuler + (machineOptimizerFeasibilitySource word)) + (pair (machineOptimizerFeasibilityTauCode word) + (pair (machineOptimizerFeasibilityDeltaRawCode word) + (pair (machineOptimizerFeasibilityUpperRawCode word) + (machineOptimizerFeasibilitySource word))))) + +/-- Encodes the initial rational ball using the ellipsoid dimension and outer-radius code. -/ +def machineOptimizerFeasibilityInitialBallCode + (word : List Bool) : List Bool := + machineRationalBallStateCode + (pair (machineOptimizerFeasibilityEllipsoidDimensionUnary word) + (machineOptimizerFeasibilityOuterRadiusEntryCode word)) + +/-- Packages the iteration budget, state bound, rounding precision, static oracle data, and +initial ball. -/ +def machineOptimizerFeasibilityLoopWord + (word : List Bool) : List Bool := + pair (machineOptimizerFeasibilityBudgetUnary word) + (pair (machineOptimizerFeasibilityStateBoundUnary word) + (pair (machineOptimizerFeasibilityRoundingPrecisionUnary word) + (pair (machineOptimizerFeasibilityOracleStaticCode word) + (machineOptimizerFeasibilityInitialBallCode word)))) + +/-- Runs the Bethe feasibility loop on the optimizer-generated request and extracts its result +code. -/ +def machineExplicitBetheThresholdFeasibilityCode + (word : List Bool) : List Bool := + machineBetheFeasibilityResultCode + (machineOptimizerFeasibilityLoopWord word) + +/-! ## Polynomial-time closure -/ + +theorem machineOptimizerFeasibilityReducedDimensionUnary_mem_FP : + machineOptimizerFeasibilityReducedDimensionUnary ∈ FP := by + simpa only [machineOptimizerFeasibilityReducedDimensionUnary] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineOptimizerFeasibilityReducedDimensionBits_mem_FP) + machineBoundedUnary_mem_FP + +theorem machineOptimizerFeasibilityTauCode_mem_FP : + machineOptimizerFeasibilityTauCode ∈ FP := by + have htau := machineCompose_mem_FP + machineOptimizerFeasibilitySource_mem_FP + machineOptimizerTauRawCode_mem_FP + simpa only [machineOptimizerFeasibilityTauCode] using! + machineCompose_mem_FP htau machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerFeasibilityDeltaRawCode_mem_FP : + machineOptimizerFeasibilityDeltaRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityDeltaRawCode] using! + machineCompose_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineExplicitOptimizerFloorRawCode_mem_FP + +theorem machineOptimizerFeasibilityOracleStaticCode_mem_FP : + machineOptimizerFeasibilityOracleStaticCode ∈ FP := by + exact machinePair_mem_FP + machineOptimizerFeasibilityReducedDimensionUnary_mem_FP + (machinePair_mem_FP + (machineCompose_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineExplicitOptimizerPrecisionRuler_mem_FP) + (machinePair_mem_FP machineOptimizerFeasibilityTauCode_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityDeltaRawCode_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityUpperRawCode_mem_FP + machineOptimizerFeasibilitySource_mem_FP)))) + +theorem machineOptimizerFeasibilityInitialBallCode_mem_FP : + machineOptimizerFeasibilityInitialBallCode ∈ FP := by + simpa only [machineOptimizerFeasibilityInitialBallCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionUnary_mem_FP + machineOptimizerFeasibilityOuterRadiusEntryCode_mem_FP) + machineRationalBallStateCode_mem_FP + +theorem machineOptimizerFeasibilityLoopWord_mem_FP : + machineOptimizerFeasibilityLoopWord ∈ FP := by + exact machinePair_mem_FP machineOptimizerFeasibilityBudgetUnary_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityStateBoundUnary_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityRoundingPrecisionUnary_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityOracleStaticCode_mem_FP + machineOptimizerFeasibilityInitialBallCode_mem_FP))) + +theorem machineExplicitBetheThresholdFeasibilityCode_mem_FP : + machineExplicitBetheThresholdFeasibilityCode ∈ FP := by + simpa only [machineExplicitBetheThresholdFeasibilityCode] using! + machineCompose_mem_FP machineOptimizerFeasibilityLoopWord_mem_FP + machineBetheFeasibilityResultCode_mem_FP + +/-! ## Exact canonical semantics -/ + +@[simp] theorem machineOptimizerFeasibilityReducedDimensionUnary_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityReducedDimensionUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate (n - 1) true := by + rw [machineOptimizerFeasibilityReducedDimensionUnary, + machineOptimizerFeasibilitySource_encode, + machineOptimizerFeasibilityReducedDimensionBits_encode] + apply machineBoundedUnary_encode_of_le + exact (show n - 1 ≀ (n - 1) ^ 2 + 1 by nlinarith).trans + (optimizerEllipsoidDimension_le_sourceLength hn A) + +@[simp] theorem machineOptimizerFeasibilityTauCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityTauCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode (rawRatOfRat (explicitRegularizationScale n)) := by + rw [machineOptimizerFeasibilityTauCode, + machineOptimizerFeasibilitySource_encode, + machineOptimizerTauRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, rawOptimizerTau_value, + rawRatBinaryCode_rawRatOfRat] + +@[simp] theorem machineOptimizerFeasibilityDeltaRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityDeltaRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode + (rawExplicitOptimizerFloor n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerFeasibilityDeltaRawCode, + machineOptimizerFeasibilitySource_encode, + machineExplicitOptimizerFloorRawCode_encode hn] + rfl + +@[simp] theorem machineOptimizerFeasibilityOracleStaticCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityOracleStaticCode + (optimizerFeasibilityCallCode A upper) = + machineBetheFeasibilityCanonicalStaticWord + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) upper := by + rw [machineOptimizerFeasibilityOracleStaticCode, + machineOptimizerFeasibilityReducedDimensionUnary_encode (by omega), + machineOptimizerFeasibilitySource_encode, + machineExplicitOptimizerPrecisionRuler_encode, + machineOptimizerFeasibilityTauCode_encode, + machineOptimizerFeasibilityDeltaRawCode_encode (by omega), + machineOptimizerFeasibilityUpperRawCode_encode, + machineBetheFeasibilityCanonicalStaticWord] + have hm1 : m + 1 - 1 = m := by omega + rw [hm1] + +@[simp] theorem machineOptimizerFeasibilityInitialBallCode_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInitialBallCode + (optimizerFeasibilityCallCode A upper) = + rationalEllipsoidStateBinaryCode + (rationalBallEllipsoid ((n - 1) ^ 2 + 1) 0 + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) := by + rw [machineOptimizerFeasibilityInitialBallCode, + machineOptimizerFeasibilityEllipsoidDimensionUnary_encode hn, + machineOptimizerFeasibilityOuterRadiusEntryCode_encode (by omega)] + change machineRationalBallStateCode + (machineDiagonalBasisCanonicalInput ((n - 1) ^ 2 + 1) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) = _ + exact machineRationalBallStateCode_encode _ _ + +@[simp] theorem machineOptimizerFeasibilityLoopWord_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityLoopWord + (optimizerFeasibilityCallCode A upper) = + machineBetheFeasibilityCanonicalWord + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) upper + (explicitBallFeasibilityPrecision (m * m + 1) + (betheThresholdFeasibilityBudget m upper.value + (explicitOptimizerInnerRadius A)) + (betheEpigraphOuterRadius m upper.value + (explicitOptimizerInnerRadius A))) + (betheThresholdFeasibilityBudget m upper.value + (explicitOptimizerInnerRadius A)) + (explicitBallFeasibilityStateCodeBound (m * m + 1) + (betheThresholdFeasibilityBudget m upper.value + (explicitOptimizerInnerRadius A)) + (betheEpigraphOuterRadius m upper.value + (explicitOptimizerInnerRadius A))) + (rationalBallEllipsoid (m * m + 1) 0 + (betheEpigraphOuterRadius m upper.value + (explicitOptimizerInnerRadius A))) := by + have hR := rawOptimizerFeasibilityOuterRadius_eq A upper + have hr := (rawExplicitOptimizerScales_value A).2.2.2.2 + rw [machineOptimizerFeasibilityLoopWord, + machineOptimizerFeasibilityBudgetUnary_eq_thresholdBudget hm, + machineOptimizerFeasibilityStateBoundUnary_encode (by omega), + machineOptimizerFeasibilityRoundingPrecisionUnary_encode (by omega), + machineOptimizerFeasibilityOracleStaticCode_encode hm, + machineOptimizerFeasibilityInitialBallCode_encode (by omega), + hR, hr] + have hd : (m + 1 - 1) ^ 2 + 1 = m * m + 1 := by + have hm1 : m + 1 - 1 = m := by omega + rw [hm1, pow_two] + rw [hd] + rfl + +theorem machineExplicitBetheThresholdFeasibilityCode_encode + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (hA : βˆ€ i j, 0 < A i j) (upper : RawRat) : + machineExplicitBetheThresholdFeasibilityCode + (optimizerFeasibilityCallCode A upper) = + rationalFeasibilityResultBinaryCode + (runExplicitScannedBetheThresholdFeasibility + (explicitRegularizationScale (m + 1)) A + (explicitOptimizerPrecision A) + (rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A)) upper + (explicitOptimizerInnerRadius A)) := by + let tau := explicitRegularizationScale (m + 1) + let delta := rawExplicitOptimizerFloor (m + 1) + (rationalMatrixEntryBitBound A) + let r := explicitOptimizerInnerRadius A + let R := betheEpigraphOuterRadius m upper.value r + let T := betheThresholdFeasibilityBudget m upper.value r + have htau0 : 0 ≀ tau := (explicitRegularizationScale_pos (by omega)).le + have htau1 : tau ≀ 1 := explicitRegularizationScale_le_one (by omega) + have hdelta : 0 < delta.value := by + simpa only [delta, (rawExplicitOptimizerScales_value A).1] using! + explicitOptimizerFloor_pos A + have hr : 0 < r := explicitOptimizerInnerRadius_pos A + have hR : 0 < R := betheEpigraphOuterRadius_pos m hr.le + rw [machineExplicitBetheThresholdFeasibilityCode, + machineOptimizerFeasibilityLoopWord_encode hm] + have hmachine := machineExplicitBallBetheFeasibilityResultCode_encode + hm htau0 htau1 hA (explicitOptimizerPrecision A) hdelta upper T hR + simpa only [tau, delta, r, R, T, + runExplicitScannedBetheThresholdFeasibility] using! hmachine + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilitySchedule.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilitySchedule.lean new file mode 100644 index 0000000000..a45d602911 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerFeasibilitySchedule.lean @@ -0,0 +1,907 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerBisectionSchedule + +/-! +# Finite-word budget for one Bethe feasibility call + +A feasibility-call word pairs the original matrix word with a raw rational +objective threshold. This file computes the ellipsoid dimension, the exact +outer radius, and the exact call budget. The final binary budget is expanded +to unary only behind a degree-eight guard built from the exact unary +dimension and the exact canonical bit lengths of both radii. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a matrix and raw upper threshold as a feasibility call. -/ +def optimizerFeasibilityCallCode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : List Bool := + pair (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) + (rawRatBinaryCode upper) + +/-- Extracts the source matrix word from an optimizer feasibility call. -/ +def machineOptimizerFeasibilitySource (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the raw upper-threshold code from an optimizer feasibility call. -/ +def machineOptimizerFeasibilityUpperRawCode + (word : List Bool) : List Bool := + machinePairSecond word + +/-- Replaces a raw rational code's numerator by its nonnegative absolute value while preserving +the denominator. -/ +def machineRawRatAbsCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode + (machineIntegerNatAbsBits (machinePairFirst word))) + (machinePairSecond word) + +/-- Replaces a raw rational numerator by its natural absolute value, retaining the positive +denominator. -/ +def rawRatAbs (q : RawRat) : RawRat := + ⟨q.num.natAbs, q.den, q.den_pos⟩ + +/-- Reads the binary source-matrix dimension from a feasibility call. -/ +def machineOptimizerFeasibilityDimensionBits + (word : List Bool) : List Bool := + machineOptimizerDimensionBits (machineOptimizerFeasibilitySource word) + +/-- Computes the binary reduced dimension `n - 1` using truncated natural subtraction. -/ +def machineOptimizerFeasibilityReducedDimensionBits + (word : List Bool) : List Bool := + machineBinarySubBits + (pair (machineOptimizerFeasibilityDimensionBits word) [true]) + +/-- Computes the square of the reduced dimension in binary. -/ +def machineOptimizerFeasibilityReducedDimensionSquareBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityReducedDimensionBits word) + (machineOptimizerFeasibilityReducedDimensionBits word)) + +/-- Adds one to the reduced-dimension square to obtain the ellipsoid dimension. -/ +def machineOptimizerFeasibilityEllipsoidDimensionBits + (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerFeasibilityReducedDimensionSquareBits word) [true]) + +/-- Converts the ellipsoid dimension to a unary ruler bounded by the source matrix word. -/ +def machineOptimizerFeasibilityEllipsoidDimensionUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerFeasibilitySource word) + (machineOptimizerFeasibilityEllipsoidDimensionBits word)) + +/-- Encodes the ellipsoid dimension as a raw rational with denominator one. -/ +def machineOptimizerFeasibilityEllipsoidDimensionRawCode + (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode + (machineOptimizerFeasibilityEllipsoidDimensionBits word)) [true] + +/-- Computes the optimizer's raw inner radius from the source matrix word. -/ +def machineOptimizerFeasibilityInnerRadiusRawCode + (word : List Bool) : List Bool := + machineExplicitOptimizerInnerRadiusRawCode + (machineOptimizerFeasibilitySource word) + +/-- Multiplies the optimizer's raw inner radius by two. -/ +def machineOptimizerFeasibilityTwiceInnerRadiusRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineOptimizerFeasibilityInnerRadiusRawCode word)) + +/-- Computes raw one plus the absolute value of the feasibility upper threshold. -/ +def machineOptimizerFeasibilityOnePlusAbsUpperRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawOptimizerOne) + (machineRawRatAbsCode + (machineOptimizerFeasibilityUpperRawCode word))) + +/-- Adds twice the inner radius to one plus the absolute upper threshold. -/ +def machineOptimizerFeasibilityRadiusFactorRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerFeasibilityOnePlusAbsUpperRawCode word) + (machineOptimizerFeasibilityTwiceInnerRadiusRawCode word)) + +/-- Multiplies the radius factor by the ellipsoid dimension to obtain the raw outer radius. -/ +def machineOptimizerFeasibilityOuterRadiusRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerFeasibilityEllipsoidDimensionRawCode word) + (machineOptimizerFeasibilityRadiusFactorRawCode word)) + +/-! ## Polynomial-time closure of the radius computation -/ + +theorem machineOptimizerFeasibilitySource_mem_FP : + machineOptimizerFeasibilitySource ∈ FP := machinePairFirst_mem_FP + +theorem machineOptimizerFeasibilityUpperRawCode_mem_FP : + machineOptimizerFeasibilityUpperRawCode ∈ FP := machinePairSecond_mem_FP + +theorem machineRawRatAbsCode_mem_FP : machineRawRatAbsCode ∈ FP := by + have habs := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + have hnum := machineCompose_mem_FP habs machineNaturalIntegerCode_mem_FP + simpa only [machineRawRatAbsCode] using! + machinePair_mem_FP hnum machinePairSecond_mem_FP + +theorem machineOptimizerFeasibilityDimensionBits_mem_FP : + machineOptimizerFeasibilityDimensionBits ∈ FP := by + simpa only [machineOptimizerFeasibilityDimensionBits] using! + machineCompose_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineOptimizerDimensionBits_mem_FP + +theorem machineOptimizerFeasibilityReducedDimensionBits_mem_FP : + machineOptimizerFeasibilityReducedDimensionBits ∈ FP := by + simpa only [machineOptimizerFeasibilityReducedDimensionBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityDimensionBits_mem_FP + (machineConst_mem_FP [true])) + machineBinarySubBits_mem_FP + +theorem machineOptimizerFeasibilityReducedDimensionSquareBits_mem_FP : + machineOptimizerFeasibilityReducedDimensionSquareBits ∈ FP := by + simpa only [machineOptimizerFeasibilityReducedDimensionSquareBits] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityReducedDimensionBits_mem_FP + machineOptimizerFeasibilityReducedDimensionBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityEllipsoidDimensionBits_mem_FP : + machineOptimizerFeasibilityEllipsoidDimensionBits ∈ FP := by + simpa only [machineOptimizerFeasibilityEllipsoidDimensionBits] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityReducedDimensionSquareBits_mem_FP + (machineConst_mem_FP [true])) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerFeasibilityEllipsoidDimensionUnary_mem_FP : + machineOptimizerFeasibilityEllipsoidDimensionUnary ∈ FP := by + simpa only [machineOptimizerFeasibilityEllipsoidDimensionUnary] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionBits_mem_FP) + machineBoundedUnary_mem_FP + +theorem machineOptimizerFeasibilityEllipsoidDimensionRawCode_mem_FP : + machineOptimizerFeasibilityEllipsoidDimensionRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityEllipsoidDimensionRawCode] using! + machinePair_mem_FP + (machineCompose_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionBits_mem_FP + machineNaturalIntegerCode_mem_FP) + (machineConst_mem_FP [true]) + +theorem machineOptimizerFeasibilityInnerRadiusRawCode_mem_FP : + machineOptimizerFeasibilityInnerRadiusRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityInnerRadiusRawCode] using! + machineCompose_mem_FP machineOptimizerFeasibilitySource_mem_FP + machineExplicitOptimizerInnerRadiusRawCode_mem_FP + +theorem machineOptimizerFeasibilityTwiceInnerRadiusRawCode_mem_FP : + machineOptimizerFeasibilityTwiceInnerRadiusRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityTwiceInnerRadiusRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineOptimizerFeasibilityInnerRadiusRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerFeasibilityOnePlusAbsUpperRawCode_mem_FP : + machineOptimizerFeasibilityOnePlusAbsUpperRawCode ∈ FP := by + have habs := machineCompose_mem_FP + machineOptimizerFeasibilityUpperRawCode_mem_FP machineRawRatAbsCode_mem_FP + simpa only [machineOptimizerFeasibilityOnePlusAbsUpperRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerOne)) habs) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerFeasibilityRadiusFactorRawCode_mem_FP : + machineOptimizerFeasibilityRadiusFactorRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityRadiusFactorRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityOnePlusAbsUpperRawCode_mem_FP + machineOptimizerFeasibilityTwiceInnerRadiusRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerFeasibilityOuterRadiusRawCode_mem_FP : + machineOptimizerFeasibilityOuterRadiusRawCode ∈ FP := by + simpa only [machineOptimizerFeasibilityOuterRadiusRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionRawCode_mem_FP + machineOptimizerFeasibilityRadiusFactorRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +/-! ## Exact radius semantics -/ + +@[simp] theorem machineOptimizerFeasibilitySource_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilitySource + (optimizerFeasibilityCallCode A upper) = + rationalMatrixBinaryEncoding.encode ⟨n, A⟩ := by + simp [machineOptimizerFeasibilitySource, optimizerFeasibilityCallCode] + +@[simp] theorem machineOptimizerFeasibilityUpperRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityUpperRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode upper := by + simp [machineOptimizerFeasibilityUpperRawCode, + optimizerFeasibilityCallCode] + +@[simp] theorem machineRawRatAbsCode_encode (q : RawRat) : + machineRawRatAbsCode (rawRatBinaryCode q) = + rawRatBinaryCode (rawRatAbs q) := by + rw [machineRawRatAbsCode, rawRatBinaryCode, + machinePairFirst_pair, machineIntegerNatAbsBits_encode, + machineNaturalIntegerCode_natBits, machinePairSecond_pair] + rfl + +@[simp] theorem rawRatAbs_value (q : RawRat) : + (rawRatAbs q).value = abs q.value := by + rw [rawRatAbs, RawRat.value, RawRat.value] + rw [abs_div, abs_of_pos (by exact_mod_cast q.den_pos : (0 : β„š) < q.den)] + norm_cast + +@[simp] theorem machineOptimizerFeasibilityDimensionBits_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityDimensionBits + (optimizerFeasibilityCallCode A upper) = n.bits := by + simp [machineOptimizerFeasibilityDimensionBits] + +@[simp] theorem machineOptimizerFeasibilityReducedDimensionBits_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityReducedDimensionBits + (optimizerFeasibilityCallCode A upper) = (n - 1).bits := by + rw [machineOptimizerFeasibilityReducedDimensionBits, + machineOptimizerFeasibilityDimensionBits_encode] + exact machineBinarySubBits_pair_natBits n 1 + +@[simp] theorem + machineOptimizerFeasibilityReducedDimensionSquareBits_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityReducedDimensionSquareBits + (optimizerFeasibilityCallCode A upper) = ((n - 1) ^ 2).bits := by + rw [machineOptimizerFeasibilityReducedDimensionSquareBits, + machineOptimizerFeasibilityReducedDimensionBits_encode, + machineBinaryMulBits_pair_natBits] + congr 1 + ring + +@[simp] theorem machineOptimizerFeasibilityEllipsoidDimensionBits_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityEllipsoidDimensionBits + (optimizerFeasibilityCallCode A upper) = + ((n - 1) ^ 2 + 1).bits := by + have hone : ([true] : List Bool) = (1 : β„•).bits := rfl + rw [machineOptimizerFeasibilityEllipsoidDimensionBits, + machineOptimizerFeasibilityReducedDimensionSquareBits_encode, + hone, + machineBinaryAddBits_pair_natBits] + +theorem optimizerEllipsoidDimension_le_sourceLength {n : β„•} + (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + (n - 1) ^ 2 + 1 ≀ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩).length := by + have hsq : n ^ 2 ≀ + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩).length := by + let rows := rationalMatrixRows A + let rowsCode := binaryListCode + (binaryListCode rationalEntryBinaryCode) rows + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + change rowsCode.length ≀ (pair n.bits rowsCode).length + simpa using! machinePairSecond_length_le (pair n.bits rowsCode) + have hcount : n ^ 2 = (rows.map List.length).sum := by + simp only [rows, rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply, List.length_ofFn] + simp + ring + rw [hcount] + exact (rationalRowsEntryCount_le_codeLength rows).trans hrowsCode + have hsmall : (n - 1) ^ 2 + 1 ≀ n ^ 2 := by + have hnform : n - 1 + 1 = n := Nat.sub_add_cancel (by omega) + calc + (n - 1) ^ 2 + 1 ≀ (n - 1 + 1) ^ 2 := by nlinarith + _ = n ^ 2 := by rw [hnform] + exact hsmall.trans hsq + +@[simp] theorem machineOptimizerFeasibilityEllipsoidDimensionUnary_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityEllipsoidDimensionUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate ((n - 1) ^ 2 + 1) true := by + rw [machineOptimizerFeasibilityEllipsoidDimensionUnary, + machineOptimizerFeasibilitySource_encode, + machineOptimizerFeasibilityEllipsoidDimensionBits_encode] + exact machineBoundedUnary_encode_of_le _ _ + (optimizerEllipsoidDimension_le_sourceLength hn A) + +@[simp] theorem + machineOptimizerFeasibilityEllipsoidDimensionRawCode_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) (upper : RawRat) : + machineOptimizerFeasibilityEllipsoidDimensionRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode (RawRat.ofNat ((n - 1) ^ 2 + 1)) := by + rw [machineOptimizerFeasibilityEllipsoidDimensionRawCode, + machineOptimizerFeasibilityEllipsoidDimensionBits_encode, + machineNaturalIntegerCode_natBits] + simp [RawRat.ofNat, rawRatBinaryCode] + +@[simp] theorem machineOptimizerFeasibilityInnerRadiusRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInnerRadiusRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)) := by + simp [machineOptimizerFeasibilityInnerRadiusRawCode, + machineExplicitOptimizerInnerRadiusRawCode_encode hn] + +@[simp] theorem machineOptimizerFeasibilityOuterRadiusRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityOuterRadiusRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode + ((RawRat.ofNat ((n - 1) ^ 2 + 1)).mul + ((rawOptimizerOne.add (rawRatAbs upper)).add + (rawOptimizerTwo.mul + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A))))) := by + rw [machineOptimizerFeasibilityOuterRadiusRawCode, + machineOptimizerFeasibilityEllipsoidDimensionRawCode_encode, + machineOptimizerFeasibilityRadiusFactorRawCode, + machineOptimizerFeasibilityOnePlusAbsUpperRawCode, + machineOptimizerFeasibilityUpperRawCode_encode, + machineRawRatAbsCode_encode, machineRawRatAddCode_encode, + machineOptimizerFeasibilityTwiceInnerRadiusRawCode, + machineOptimizerFeasibilityInnerRadiusRawCode_encode hn, + machineRawRatMulCode_encode, machineRawRatAddCode_encode, + machineRawRatMulCode_encode] + +/-- Forms the raw outer radius `((n - 1)^2 + 1) * (1 + abs upper + 2 * innerRadius(n, B))`. -/ +def rawOptimizerFeasibilityOuterRadius + (n B : β„•) (upper : RawRat) : RawRat := + (RawRat.ofNat ((n - 1) ^ 2 + 1)).mul + ((rawOptimizerOne.add (rawRatAbs upper)).add + (rawOptimizerTwo.mul (rawExplicitOptimizerInnerRadius n B))) + +@[simp] theorem rawOptimizerFeasibilityOuterRadius_value + (n B : β„•) (upper : RawRat) : + (rawOptimizerFeasibilityOuterRadius n B upper).value = + (((n - 1) ^ 2 + 1 : β„•) : β„š) * + (1 + abs upper.value + + 2 * (rawExplicitOptimizerInnerRadius n B).value) := by + simp only [rawOptimizerFeasibilityOuterRadius, RawRat.value_mul, + RawRat.value_add, RawRat.value_ofNat, rawRatAbs_value] + norm_num [rawOptimizerOne, rawOptimizerTwo] + +theorem rawOptimizerFeasibilityOuterRadius_eq {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (upper : RawRat) : + (rawOptimizerFeasibilityOuterRadius (m + 1) + (rationalMatrixEntryBitBound A) upper).value = + betheEpigraphOuterRadius m upper.value + (explicitOptimizerInnerRadius A) := by + rw [rawOptimizerFeasibilityOuterRadius_value] + have hradius := (rawExplicitOptimizerScales_value A).2.2.2.2 + rw [hradius] + have hm : (m + 1 - 1) ^ 2 + 1 = m * m + 1 := by + have : m + 1 - 1 = m := by omega + rw [this, pow_two] + rw [hm] + simp only [betheEpigraphOuterRadius] + push_cast + rfl + +/-! ## Exact encoded lengths and guarded budget -/ + +/-- Normalizes the raw feasibility outer radius into its rational entry encoding. -/ +def machineOptimizerFeasibilityOuterRadiusEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerFeasibilityOuterRadiusRawCode word) + +/-- Computes the optimizer length ruler for the normalized outer-radius entry. -/ +def machineOptimizerFeasibilityOuterRadiusLengthRuler + (word : List Bool) : List Bool := + machineOptimizerEntryLengthRuler + (machineOptimizerFeasibilityOuterRadiusEntryCode word) + +/-- Normalizes the raw feasibility inner radius into its rational entry encoding. -/ +def machineOptimizerFeasibilityInnerRadiusEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerFeasibilityInnerRadiusRawCode word) + +/-- Computes the optimizer length ruler for the normalized inner-radius entry. -/ +def machineOptimizerFeasibilityInnerRadiusLengthRuler + (word : List Bool) : List Bool := + machineOptimizerEntryLengthRuler + (machineOptimizerFeasibilityInnerRadiusEntryCode word) + +/-- Concatenates the unary ellipsoid dimension and the two radius-length rulers to seed the +feasibility-budget guard. -/ +def machineOptimizerFeasibilityBudgetGuardSource + (word : List Bool) : List Bool := + machineOptimizerFeasibilityEllipsoidDimensionUnary word ++ + (machineOptimizerFeasibilityOuterRadiusLengthRuler word ++ + machineOptimizerFeasibilityInnerRadiusLengthRuler word) + +/-- Reads the binary ellipsoid dimension used in the feasibility-budget formulas. -/ +def machineOptimizerFeasibilityDBits (word : List Bool) : List Bool := + machineOptimizerFeasibilityEllipsoidDimensionBits word + +/-- Computes the square of the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityDSquareBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityDBits word) + (machineOptimizerFeasibilityDBits word)) + +/-- Computes the cube of the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityDCubeBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityDSquareBits word) + (machineOptimizerFeasibilityDBits word)) + +/-- Converts the outer-radius length ruler into its binary length. -/ +def machineOptimizerFeasibilityOuterLengthBits + (word : List Bool) : List Bool := + machineLengthBits + (machineOptimizerFeasibilityOuterRadiusLengthRuler word) + +/-- Converts the inner-radius length ruler into its binary length. -/ +def machineOptimizerFeasibilityInnerLengthBits + (word : List Bool) : List Bool := + machineLengthBits + (machineOptimizerFeasibilityInnerRadiusLengthRuler word) + +/-- Multiplies the outer-radius length by the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityOuterLengthTimesDBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityOuterLengthBits word) + (machineOptimizerFeasibilityDBits word)) + +/-- Multiplies the inner-radius length by the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityInnerLengthTimesDBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityInnerLengthBits word) + (machineOptimizerFeasibilityDBits word)) + +/-- Computes `D^2 + D * outerLength` in binary for the feasibility budget. -/ +def machineOptimizerFeasibilityMFirstBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerFeasibilityDSquareBits word) + (machineOptimizerFeasibilityOuterLengthTimesDBits word)) + +/-- Adds `D * innerLength` to the first feasibility-budget sum. -/ +def machineOptimizerFeasibilityMSecondBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerFeasibilityMFirstBits word) + (machineOptimizerFeasibilityInnerLengthTimesDBits word)) + +/-- Computes the budget factor `D^2 + D * outerLength + D * innerLength + 1` in binary. -/ +def machineOptimizerFeasibilityMBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineOptimizerFeasibilityMSecondBits word) [true]) + +/-- Computes thirty-two times the cube of the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityThirtyTwoDCubeBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (32 : β„•).bits (machineOptimizerFeasibilityDCubeBits word)) + +/-- Multiplies `32 * D^3` by the dimension-and-radius-length budget factor. -/ +def machineOptimizerFeasibilityBudgetBits + (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineOptimizerFeasibilityThirtyTwoDCubeBits word) + (machineOptimizerFeasibilityMBits word)) + +/-- Applies the binary-width construction three times to the budget-guard source word. -/ +def machineOptimizerFeasibilityBudgetGuard + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 3 + (machineOptimizerFeasibilityBudgetGuardSource word) + +/-- Converts the binary feasibility budget to a unary ruler bounded by the computed guard. -/ +def machineOptimizerFeasibilityBudgetUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerFeasibilityBudgetGuard word) + (machineOptimizerFeasibilityBudgetBits word)) + +/-! All components above are fixed compositions of verified `FP` machines. -/ + +theorem machineOptimizerFeasibilityOuterRadiusEntryCode_mem_FP : + machineOptimizerFeasibilityOuterRadiusEntryCode ∈ FP := by + simpa only [machineOptimizerFeasibilityOuterRadiusEntryCode] using! + machineCompose_mem_FP machineOptimizerFeasibilityOuterRadiusRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerFeasibilityOuterRadiusLengthRuler_mem_FP : + machineOptimizerFeasibilityOuterRadiusLengthRuler ∈ FP := by + simpa only [machineOptimizerFeasibilityOuterRadiusLengthRuler] using! + machineCompose_mem_FP + machineOptimizerFeasibilityOuterRadiusEntryCode_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + +theorem machineOptimizerFeasibilityInnerRadiusEntryCode_mem_FP : + machineOptimizerFeasibilityInnerRadiusEntryCode ∈ FP := by + simpa only [machineOptimizerFeasibilityInnerRadiusEntryCode] using! + machineCompose_mem_FP machineOptimizerFeasibilityInnerRadiusRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerFeasibilityInnerRadiusLengthRuler_mem_FP : + machineOptimizerFeasibilityInnerRadiusLengthRuler ∈ FP := by + simpa only [machineOptimizerFeasibilityInnerRadiusLengthRuler] using! + machineCompose_mem_FP + machineOptimizerFeasibilityInnerRadiusEntryCode_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + +theorem machineOptimizerFeasibilityBudgetGuardSource_mem_FP : + machineOptimizerFeasibilityBudgetGuardSource ∈ FP := by + simpa only [machineOptimizerFeasibilityBudgetGuardSource] using! + machineAppend_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionUnary_mem_FP + (machineAppend_mem_FP + machineOptimizerFeasibilityOuterRadiusLengthRuler_mem_FP + machineOptimizerFeasibilityInnerRadiusLengthRuler_mem_FP) + +theorem machineOptimizerFeasibilityDBits_mem_FP : + machineOptimizerFeasibilityDBits ∈ FP := + machineOptimizerFeasibilityEllipsoidDimensionBits_mem_FP + +theorem machineOptimizerFeasibilityDSquareBits_mem_FP : + machineOptimizerFeasibilityDSquareBits ∈ FP := by + simpa only [machineOptimizerFeasibilityDSquareBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityDBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityDCubeBits_mem_FP : + machineOptimizerFeasibilityDCubeBits ∈ FP := by + simpa only [machineOptimizerFeasibilityDCubeBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityDSquareBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityOuterLengthBits_mem_FP : + machineOptimizerFeasibilityOuterLengthBits ∈ FP := by + simpa only [machineOptimizerFeasibilityOuterLengthBits] using! + machineCompose_mem_FP + machineOptimizerFeasibilityOuterRadiusLengthRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineOptimizerFeasibilityInnerLengthBits_mem_FP : + machineOptimizerFeasibilityInnerLengthBits ∈ FP := by + simpa only [machineOptimizerFeasibilityInnerLengthBits] using! + machineCompose_mem_FP + machineOptimizerFeasibilityInnerRadiusLengthRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineOptimizerFeasibilityOuterLengthTimesDBits_mem_FP : + machineOptimizerFeasibilityOuterLengthTimesDBits ∈ FP := by + simpa only [machineOptimizerFeasibilityOuterLengthTimesDBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityOuterLengthBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityInnerLengthTimesDBits_mem_FP : + machineOptimizerFeasibilityInnerLengthTimesDBits ∈ FP := by + simpa only [machineOptimizerFeasibilityInnerLengthTimesDBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityInnerLengthBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityMFirstBits_mem_FP : + machineOptimizerFeasibilityMFirstBits ∈ FP := by + simpa only [machineOptimizerFeasibilityMFirstBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityDSquareBits_mem_FP + machineOptimizerFeasibilityOuterLengthTimesDBits_mem_FP) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerFeasibilityMSecondBits_mem_FP : + machineOptimizerFeasibilityMSecondBits ∈ FP := by + simpa only [machineOptimizerFeasibilityMSecondBits] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityMFirstBits_mem_FP + machineOptimizerFeasibilityInnerLengthTimesDBits_mem_FP) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerFeasibilityMBits_mem_FP : + machineOptimizerFeasibilityMBits ∈ FP := by + simpa only [machineOptimizerFeasibilityMBits] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityMSecondBits_mem_FP + (machineConst_mem_FP [true])) + machineBinaryAddBits_mem_FP + +theorem machineOptimizerFeasibilityThirtyTwoDCubeBits_mem_FP : + machineOptimizerFeasibilityThirtyTwoDCubeBits ∈ FP := by + simpa only [machineOptimizerFeasibilityThirtyTwoDCubeBits] using! + machineCompose_mem_FP + (machinePair_mem_FP (machineConst_mem_FP (32 : β„•).bits) + machineOptimizerFeasibilityDCubeBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityBudgetBits_mem_FP : + machineOptimizerFeasibilityBudgetBits ∈ FP := by + simpa only [machineOptimizerFeasibilityBudgetBits] using! + machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityThirtyTwoDCubeBits_mem_FP + machineOptimizerFeasibilityMBits_mem_FP) + machineBinaryMulBits_mem_FP + +theorem machineOptimizerFeasibilityBudgetGuard_mem_FP : + machineOptimizerFeasibilityBudgetGuard ∈ FP := by + simpa only [machineOptimizerFeasibilityBudgetGuard] using! + machineCompose_mem_FP machineOptimizerFeasibilityBudgetGuardSource_mem_FP + (machineIteratedBinaryWidth_mem_FP 3) + +theorem machineOptimizerFeasibilityBudgetUnary_mem_FP : + machineOptimizerFeasibilityBudgetUnary ∈ FP := by + simpa only [machineOptimizerFeasibilityBudgetUnary] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityBudgetGuard_mem_FP + machineOptimizerFeasibilityBudgetBits_mem_FP) + machineBoundedUnary_mem_FP + +/-! ## Exact budget semantics and proof that the guard is inactive -/ + +@[simp] theorem machineOptimizerFeasibilityOuterRadiusEntryCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityOuterRadiusEntryCode + (optimizerFeasibilityCallCode A upper) = + rationalEntryBinaryCode + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) := by + rw [machineOptimizerFeasibilityOuterRadiusEntryCode, + machineOptimizerFeasibilityOuterRadiusRawCode_encode hn, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value] + rfl + +@[simp] theorem machineOptimizerFeasibilityOuterRadiusLengthRuler_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityOuterRadiusLengthRuler + (optimizerFeasibilityCallCode A upper) = + List.replicate + (encodedBitLength β„š + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value)) true := by + rw [machineOptimizerFeasibilityOuterRadiusLengthRuler, + machineOptimizerFeasibilityOuterRadiusEntryCode_encode hn, + machineOptimizerEntryLengthRuler_encode] + +@[simp] theorem machineOptimizerFeasibilityInnerRadiusEntryCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInnerRadiusEntryCode + (optimizerFeasibilityCallCode A upper) = + rationalEntryBinaryCode + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) := by + rw [machineOptimizerFeasibilityInnerRadiusEntryCode, + machineOptimizerFeasibilityInnerRadiusRawCode_encode hn, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value] + +@[simp] theorem machineOptimizerFeasibilityInnerRadiusLengthRuler_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInnerRadiusLengthRuler + (optimizerFeasibilityCallCode A upper) = + List.replicate + (encodedBitLength β„š + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value)) true := by + rw [machineOptimizerFeasibilityInnerRadiusLengthRuler, + machineOptimizerFeasibilityInnerRadiusEntryCode_encode hn, + machineOptimizerEntryLengthRuler_encode] + +@[simp] theorem machineOptimizerFeasibilityBudgetGuardSource_length_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + (machineOptimizerFeasibilityBudgetGuardSource + (optimizerFeasibilityCallCode A upper)).length = + ((n - 1) ^ 2 + 1) + + encodedBitLength β„š + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) + + encodedBitLength β„š + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) := by + have hn1 : 1 ≀ n := by omega + rw [machineOptimizerFeasibilityBudgetGuardSource, + machineOptimizerFeasibilityEllipsoidDimensionUnary_encode hn, + machineOptimizerFeasibilityOuterRadiusLengthRuler_encode hn1, + machineOptimizerFeasibilityInnerRadiusLengthRuler_encode hn1] + simp only [List.length_append, List.length_replicate] + omega + +@[simp] theorem machineOptimizerFeasibilityBudgetBits_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityBudgetBits + (optimizerFeasibilityCallCode A upper) = + (32 * (((n - 1) ^ 2 + 1) ^ 3) * + rationalBallDyadicExponent ((n - 1) ^ 2 + 1) + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value)).bits := by + let word := optimizerFeasibilityCallCode A upper + let d := (n - 1) ^ 2 + 1 + let LR := encodedBitLength β„š + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) + let Lr := encodedBitLength β„š + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + have hd : machineOptimizerFeasibilityDBits word = d.bits := by + simpa only [machineOptimizerFeasibilityDBits, word, d] using! + machineOptimizerFeasibilityEllipsoidDimensionBits_encode A upper + have hd2 : machineOptimizerFeasibilityDSquareBits word = (d ^ 2).bits := by + rw [machineOptimizerFeasibilityDSquareBits, hd, + machineBinaryMulBits_pair_natBits] + simp only [pow_two] + have hd3 : machineOptimizerFeasibilityDCubeBits word = (d ^ 3).bits := by + rw [machineOptimizerFeasibilityDCubeBits, hd2, hd, + machineBinaryMulBits_pair_natBits] + simp only [pow_succ] + have hLR : machineOptimizerFeasibilityOuterLengthBits word = LR.bits := by + have hRuler : machineOptimizerFeasibilityOuterRadiusLengthRuler word = + List.replicate LR true := by + simpa only [word, LR] using! + machineOptimizerFeasibilityOuterRadiusLengthRuler_encode hn A upper + rw [machineOptimizerFeasibilityOuterLengthBits, hRuler, + machineLengthBits_encode, List.length_replicate] + have hLr : machineOptimizerFeasibilityInnerLengthBits word = Lr.bits := by + have hRuler : machineOptimizerFeasibilityInnerRadiusLengthRuler word = + List.replicate Lr true := by + simpa only [word, Lr] using! + machineOptimizerFeasibilityInnerRadiusLengthRuler_encode hn A upper + rw [machineOptimizerFeasibilityInnerLengthBits, hRuler, + machineLengthBits_encode, List.length_replicate] + have hLRd : machineOptimizerFeasibilityOuterLengthTimesDBits word = + (LR * d).bits := by + rw [machineOptimizerFeasibilityOuterLengthTimesDBits, hLR, hd, + machineBinaryMulBits_pair_natBits] + have hLrd : machineOptimizerFeasibilityInnerLengthTimesDBits word = + (Lr * d).bits := by + rw [machineOptimizerFeasibilityInnerLengthTimesDBits, hLr, hd, + machineBinaryMulBits_pair_natBits] + have hM1 : machineOptimizerFeasibilityMFirstBits word = + (d ^ 2 + LR * d).bits := by + rw [machineOptimizerFeasibilityMFirstBits, hd2, hLRd, + machineBinaryAddBits_pair_natBits] + have hM2 : machineOptimizerFeasibilityMSecondBits word = + (d ^ 2 + LR * d + Lr * d).bits := by + rw [machineOptimizerFeasibilityMSecondBits, hM1, hLrd, + machineBinaryAddBits_pair_natBits] + have hone : ([true] : List Bool) = (1 : β„•).bits := rfl + have hM : machineOptimizerFeasibilityMBits word = + (d ^ 2 + LR * d + Lr * d + 1).bits := by + rw [machineOptimizerFeasibilityMBits, hM2, hone, + machineBinaryAddBits_pair_natBits] + have h32d3 : machineOptimizerFeasibilityThirtyTwoDCubeBits word = + (32 * d ^ 3).bits := by + rw [machineOptimizerFeasibilityThirtyTwoDCubeBits, hd3, + machineBinaryMulBits_pair_natBits] + rw [machineOptimizerFeasibilityBudgetBits, h32d3, hM, + machineBinaryMulBits_pair_natBits] + rfl + +theorem optimizerFeasibilityBudget_le_guardPolynomial + (d LR Lr : β„•) : + 32 * d ^ 3 * (d ^ 2 + LR * d + Lr * d + 1) ≀ + certificateExpGuardWidth 3 (d + LR + Lr) := by + let Q := d + LR + Lr + have hd : d ≀ Q := by omega + have hLR : LR ≀ Q := by omega + have hLr : Lr ≀ Q := by omega + have hM : d ^ 2 + LR * d + Lr * d + 1 ≀ 3 * Q ^ 2 + 1 := by + nlinarith [Nat.mul_le_mul hd hd, Nat.mul_le_mul hLR hd, + Nat.mul_le_mul hLr hd] + have hbudget : + 32 * d ^ 3 * (d ^ 2 + LR * d + Lr * d + 1) ≀ + 128 * (Q + 1) ^ 5 := by + have hd3 : d ^ 3 ≀ (Q + 1) ^ 3 := + Nat.pow_le_pow_left (by omega) 3 + have hM' : 3 * Q ^ 2 + 1 ≀ 4 * (Q + 1) ^ 2 := by nlinarith + nlinarith [Nat.mul_le_mul hd3 (hM.trans hM')] + have hconst : 128 ≀ (Q + 16) ^ 3 := by + have : 8 ≀ Q + 16 := by omega + nlinarith [Nat.pow_le_pow_left this 3] + have hq5 : (Q + 1) ^ 5 ≀ (Q + 16) ^ 5 := + Nat.pow_le_pow_left (by omega) 5 + have hpow : 128 * (Q + 1) ^ 5 ≀ (Q + 16) ^ 8 := by + calc + 128 * (Q + 1) ^ 5 ≀ (Q + 16) ^ 3 * (Q + 16) ^ 5 := + Nat.mul_le_mul hconst hq5 + _ = (Q + 16) ^ 8 := by rw [← pow_add] + exact hbudget.trans <| hpow.trans <| by + simpa only [Q] using! certificateExpGuardWidth_pow_lower 2 Q + +@[simp] theorem machineOptimizerFeasibilityBudgetUnary_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityBudgetUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate + (32 * (((n - 1) ^ 2 + 1) ^ 3) * + rationalBallDyadicExponent ((n - 1) ^ 2 + 1) + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value)) true := by + let d := (n - 1) ^ 2 + 1 + let LR := encodedBitLength β„š + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) + let Lr := encodedBitLength β„š + ((rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + rw [machineOptimizerFeasibilityBudgetUnary, + machineOptimizerFeasibilityBudgetBits_encode (by omega)] + apply machineBoundedUnary_encode_of_le + rw [machineOptimizerFeasibilityBudgetGuard, + machineIteratedBinaryWidth_length, + machineOptimizerFeasibilityBudgetGuardSource_length_encode hn] + simpa only [d, LR, Lr, rationalBallDyadicExponent] using! + optimizerFeasibilityBudget_le_guardPolynomial d LR Lr + +theorem machineOptimizerFeasibilityBudgetUnary_eq_thresholdBudget + {m : β„•} (hm : 0 < m) + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityBudgetUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate + (betheThresholdFeasibilityBudget m upper.value + (explicitOptimizerInnerRadius A)) true := by + rw [machineOptimizerFeasibilityBudgetUnary_encode (by omega)] + have hR := rawOptimizerFeasibilityOuterRadius_eq A upper + have hr := (rawExplicitOptimizerScales_value A).2.2.2.2 + have hd : (m + 1 - 1) ^ 2 + 1 = m * m + 1 := by + have : m + 1 - 1 = m := by omega + rw [this, pow_two] + simp only [betheThresholdFeasibilityBudget] + rw [hd, hR, hr] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerInteriorScale.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerInteriorScale.lean new file mode 100644 index 0000000000..ba80113c7e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerInteriorScale.lean @@ -0,0 +1,675 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerMatrixBitBound +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateExpGuard +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitOptimizerScales + +/-! +# Finite-word interior scale for the Bethe optimizer + +The optimizer uses a dyadic lower bound on every matrix coordinate. Its +exponent is computed in binary and expanded to unary only behind an explicit +degree-64 guard in the source matrix length. Thus this file does not hide an +unrestricted binary-to-unary conversion. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## Raw rational expression computed by the machine -/ + +/-- The raw rational constant two used in optimizer scale formulas. -/ +def rawOptimizerTwo : RawRat := RawRat.ofNat 2 + +/-- The raw rational constant four used in optimizer scale formulas. -/ +def rawOptimizerFour : RawRat := RawRat.ofNat 4 + +/-- The raw rational one-half obtained by dividing one by two. -/ +def rawOptimizerHalf : RawRat := + (RawRat.ofNat 1).div rawOptimizerTwo + +/-- The raw rational representation of the explicit optimizer parameter `explicitXi`. -/ +def rawOptimizerXi : RawRat := rawRatOfRat explicitXi + +/-- Embeds the optimizer dimension as a raw rational with denominator one. -/ +def rawOptimizerDimension (n : β„•) : RawRat := RawRat.ofNat n + +/-- Embeds the matrix-entry bit bound as a raw rational with denominator one. -/ +def rawOptimizerBitBound (B : β„•) : RawRat := RawRat.ofNat B + +/-- Computes the raw regularization scale `explicitXi / (4 * n)`. -/ +def rawOptimizerTau (n : β„•) : RawRat := + rawOptimizerXi.div (rawOptimizerFour.mul (rawOptimizerDimension n)) + +/-- Computes the dimension squared in raw rational arithmetic. -/ +def rawOptimizerNSquare (n : β„•) : RawRat := + (rawOptimizerDimension n).mul (rawOptimizerDimension n) + +/-- Computes the dimension cubed in raw rational arithmetic. -/ +def rawOptimizerNCube (n : β„•) : RawRat := + (rawOptimizerNSquare n).mul (rawOptimizerDimension n) + +/-- Computes the interior-scale sum `n * B + 2 * n^2` in raw rational arithmetic. -/ +def rawOptimizerInteriorSum (n B : β„•) : RawRat := + ((rawOptimizerDimension n).mul (rawOptimizerBitBound B)).add + (rawOptimizerTwo.mul (rawOptimizerNSquare n)) + +/-- Computes the raw interior constant `n * (n * B + 2 * n^2) / tau(n) + n^3`. -/ +def rawOptimizerInteriorK0 (n B : β„•) : RawRat := + ((rawOptimizerDimension n).mul (rawOptimizerInteriorSum n B)).div + (rawOptimizerTau n) |>.add (rawOptimizerNCube n) + +/-- Doubles the raw interior constant used to define optimizer scales. -/ +def rawOptimizerTwiceInteriorK0 (n B : β„•) : RawRat := + rawOptimizerTwo.mul (rawOptimizerInteriorK0 n B) + +/-! ## Binary machines for the expression -/ + +/-- Extracts the binary matrix dimension for optimizer computations. -/ +def machineOptimizerDimensionBits (word : List Bool) : List Bool := + machineMatrixDimensionWord word + +/-- Extracts the unary matrix dimension for optimizer computations. -/ +def machineOptimizerDimensionUnary (word : List Bool) : List Bool := + machineMatrixDimensionUnary word + +/-- Encodes the matrix dimension as a raw rational with denominator one. -/ +def machineOptimizerDimensionRawCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineOptimizerDimensionBits word)) [true] + +/-- Computes the binary length of the matrix-entry bit-bound ruler. -/ +def machineOptimizerBitBoundBits (word : List Bool) : List Bool := + machineLengthBits (machineMatrixEntryBitBoundRuler word) + +/-- Encodes the matrix-entry bit bound as a raw rational with denominator one. -/ +def machineOptimizerBitBoundRawCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineOptimizerBitBoundBits word)) [true] + +/-- Computes raw four times the matrix dimension. -/ +def machineOptimizerFourDimensionRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerFour) + (machineOptimizerDimensionRawCode word)) + +/-- Computes the encoded raw regularization scale by dividing `explicitXi` by four times the +dimension. -/ +def machineOptimizerTauRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode rawOptimizerXi) + (machineOptimizerFourDimensionRawCode word)) + +/-- Computes the encoded raw square of the matrix dimension. -/ +def machineOptimizerNSquareRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerDimensionRawCode word) + (machineOptimizerDimensionRawCode word)) + +/-- Computes the encoded raw cube of the matrix dimension. -/ +def machineOptimizerNCubeRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerNSquareRawCode word) + (machineOptimizerDimensionRawCode word)) + +/-- Computes the encoded raw product of dimension and matrix-entry bit bound. -/ +def machineOptimizerNBProductRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerDimensionRawCode word) + (machineOptimizerBitBoundRawCode word)) + +/-- Computes the encoded raw value of twice the squared dimension. -/ +def machineOptimizerTwiceNSquareRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineOptimizerNSquareRawCode word)) + +/-- Computes the encoded raw interior sum `n * B + 2 * n^2`. -/ +def machineOptimizerInteriorSumRawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerNBProductRawCode word) + (machineOptimizerTwiceNSquareRawCode word)) + +/-- Multiplies the raw interior sum by the matrix dimension. -/ +def machineOptimizerNTimesInteriorSumRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineOptimizerDimensionRawCode word) + (machineOptimizerInteriorSumRawCode word)) + +/-- Divides the dimension-scaled interior sum by the raw regularization parameter. -/ +def machineOptimizerInteriorQuotientRawCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineOptimizerNTimesInteriorSumRawCode word) + (machineOptimizerTauRawCode word)) + +/-- Adds the dimension cube to the interior quotient to compute the raw interior constant. -/ +def machineOptimizerInteriorK0RawCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineOptimizerInteriorQuotientRawCode word) + (machineOptimizerNCubeRawCode word)) + +/-- Computes the raw code for twice the optimizer interior constant. -/ +def machineOptimizerTwiceInteriorK0RawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineOptimizerInteriorK0RawCode word)) + +/-- Computes the natural ceiling of twice the raw interior constant in binary. -/ +def machineOptimizerInteriorExponentBits (word : List Bool) : List Bool := + machineRationalCeilNatBits + (machineOptimizerTwiceInteriorK0RawCode word) + +/-! ## Polynomial-time closure -/ + +theorem machineOptimizerDimensionBits_mem_FP : + machineOptimizerDimensionBits ∈ FP := + machineMatrixDimensionWord_mem_FP + +theorem machineOptimizerDimensionUnary_mem_FP : + machineOptimizerDimensionUnary ∈ FP := + machineMatrixDimensionUnary_mem_FP + +theorem machineOptimizerDimensionRawCode_mem_FP : + machineOptimizerDimensionRawCode ∈ FP := by + exact machinePair_mem_FP + (machineCompose_mem_FP machineOptimizerDimensionBits_mem_FP + machineNaturalIntegerCode_mem_FP) + (machineConst_mem_FP [true]) + +theorem machineOptimizerBitBoundBits_mem_FP : + machineOptimizerBitBoundBits ∈ FP := by + simpa only [machineOptimizerBitBoundBits] using! + machineCompose_mem_FP machineMatrixEntryBitBoundRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineOptimizerBitBoundRawCode_mem_FP : + machineOptimizerBitBoundRawCode ∈ FP := by + exact machinePair_mem_FP + (machineCompose_mem_FP machineOptimizerBitBoundBits_mem_FP + machineNaturalIntegerCode_mem_FP) + (machineConst_mem_FP [true]) + +theorem machineOptimizerFourDimensionRawCode_mem_FP : + machineOptimizerFourDimensionRawCode ∈ FP := by + simpa only [machineOptimizerFourDimensionRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerFour)) + machineOptimizerDimensionRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerTauRawCode_mem_FP : + machineOptimizerTauRawCode ∈ FP := by + simpa only [machineOptimizerTauRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerXi)) + machineOptimizerFourDimensionRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +theorem machineOptimizerNSquareRawCode_mem_FP : + machineOptimizerNSquareRawCode ∈ FP := by + simpa only [machineOptimizerNSquareRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerDimensionRawCode_mem_FP + machineOptimizerDimensionRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerNCubeRawCode_mem_FP : + machineOptimizerNCubeRawCode ∈ FP := by + simpa only [machineOptimizerNCubeRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerNSquareRawCode_mem_FP + machineOptimizerDimensionRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerNBProductRawCode_mem_FP : + machineOptimizerNBProductRawCode ∈ FP := by + simpa only [machineOptimizerNBProductRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerDimensionRawCode_mem_FP + machineOptimizerBitBoundRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerTwiceNSquareRawCode_mem_FP : + machineOptimizerTwiceNSquareRawCode ∈ FP := by + simpa only [machineOptimizerTwiceNSquareRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineOptimizerNSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerInteriorSumRawCode_mem_FP : + machineOptimizerInteriorSumRawCode ∈ FP := by + simpa only [machineOptimizerInteriorSumRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerNBProductRawCode_mem_FP + machineOptimizerTwiceNSquareRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerNTimesInteriorSumRawCode_mem_FP : + machineOptimizerNTimesInteriorSumRawCode ∈ FP := by + simpa only [machineOptimizerNTimesInteriorSumRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerDimensionRawCode_mem_FP + machineOptimizerInteriorSumRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerInteriorQuotientRawCode_mem_FP : + machineOptimizerInteriorQuotientRawCode ∈ FP := by + simpa only [machineOptimizerInteriorQuotientRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerNTimesInteriorSumRawCode_mem_FP + machineOptimizerTauRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +theorem machineOptimizerInteriorK0RawCode_mem_FP : + machineOptimizerInteriorK0RawCode ∈ FP := by + simpa only [machineOptimizerInteriorK0RawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerInteriorQuotientRawCode_mem_FP + machineOptimizerNCubeRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerTwiceInteriorK0RawCode_mem_FP : + machineOptimizerTwiceInteriorK0RawCode ∈ FP := by + simpa only [machineOptimizerTwiceInteriorK0RawCode] using! machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) + machineOptimizerInteriorK0RawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineOptimizerInteriorExponentBits_mem_FP : + machineOptimizerInteriorExponentBits ∈ FP := by + simpa only [machineOptimizerInteriorExponentBits] using! + machineCompose_mem_FP machineOptimizerTwiceInteriorK0RawCode_mem_FP + machineRationalCeilNatBits_mem_FP + +/-! ## Exact semantics on canonical matrix words -/ + +@[simp] theorem machineOptimizerDimensionBits_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerDimensionBits + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = n.bits := by + simp [machineOptimizerDimensionBits] + +@[simp] theorem machineOptimizerDimensionUnary_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerDimensionUnary + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate n true := by + simp [machineOptimizerDimensionUnary] + +@[simp] theorem machineOptimizerDimensionRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerDimensionRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerDimension n) := by + rw [machineOptimizerDimensionRawCode, + machineOptimizerDimensionBits_encode, + machineNaturalIntegerCode_natBits] + simp [rawOptimizerDimension, RawRat.ofNat, rawRatBinaryCode] + +@[simp] theorem machineOptimizerBitBoundBits_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerBitBoundBits + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + (rationalMatrixEntryBitBound A).bits := by + simp [machineOptimizerBitBoundBits] + +@[simp] theorem machineOptimizerBitBoundRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerBitBoundRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerBitBound + (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerBitBoundRawCode, + machineOptimizerBitBoundBits_encode, + machineNaturalIntegerCode_natBits] + simp [rawOptimizerBitBound, RawRat.ofNat, rawRatBinaryCode] + +@[simp] theorem machineOptimizerFourDimensionRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerFourDimensionRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerFour.mul (rawOptimizerDimension n)) := by + rw [machineOptimizerFourDimensionRawCode, + machineOptimizerDimensionRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerTauRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTauRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerTau n) := by + rw [machineOptimizerTauRawCode, + machineOptimizerFourDimensionRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineOptimizerNSquareRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerNSquareRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerNSquare n) := by + rw [machineOptimizerNSquareRawCode, + machineOptimizerDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineOptimizerNCubeRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerNCubeRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerNCube n) := by + rw [machineOptimizerNCubeRawCode, + machineOptimizerNSquareRawCode_encode, + machineOptimizerDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineOptimizerNBProductRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerNBProductRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode ((rawOptimizerDimension n).mul + (rawOptimizerBitBound (rationalMatrixEntryBitBound A))) := by + rw [machineOptimizerNBProductRawCode, + machineOptimizerDimensionRawCode_encode, + machineOptimizerBitBoundRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerTwiceNSquareRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTwiceNSquareRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerTwo.mul (rawOptimizerNSquare n)) := by + rw [machineOptimizerTwiceNSquareRawCode, + machineOptimizerNSquareRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerInteriorSumRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorSumRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerInteriorSum n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerInteriorSumRawCode, + machineOptimizerNBProductRawCode_encode, + machineOptimizerTwiceNSquareRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerNTimesInteriorSumRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerNTimesInteriorSumRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode ((rawOptimizerDimension n).mul + (rawOptimizerInteriorSum n (rationalMatrixEntryBitBound A))) := by + rw [machineOptimizerNTimesInteriorSumRawCode, + machineOptimizerDimensionRawCode_encode, + machineOptimizerInteriorSumRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineOptimizerInteriorQuotientRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorQuotientRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (((rawOptimizerDimension n).mul + (rawOptimizerInteriorSum n (rationalMatrixEntryBitBound A))).div + (rawOptimizerTau n)) := by + rw [machineOptimizerInteriorQuotientRawCode, + machineOptimizerNTimesInteriorSumRawCode_encode, + machineOptimizerTauRawCode_encode, + machineRawRatDivCode_encode] + +@[simp] theorem machineOptimizerInteriorK0RawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorK0RawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerInteriorK0 n (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerInteriorK0RawCode, + machineOptimizerInteriorQuotientRawCode_encode, + machineOptimizerNCubeRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineOptimizerTwiceInteriorK0RawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerTwiceInteriorK0RawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode + (rawOptimizerTwiceInteriorK0 n + (rationalMatrixEntryBitBound A)) := by + rw [machineOptimizerTwiceInteriorK0RawCode, + machineOptimizerInteriorK0RawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem rawOptimizerDimension_value (n : β„•) : + (rawOptimizerDimension n).value = n := by + simp [rawOptimizerDimension] + +@[simp] theorem rawOptimizerBitBound_value (B : β„•) : + (rawOptimizerBitBound B).value = B := by + simp [rawOptimizerBitBound] + +@[simp] theorem rawOptimizerTau_value (n : β„•) : + (rawOptimizerTau n).value = explicitRegularizationScale n := by + simp [rawOptimizerTau, rawOptimizerXi, rawOptimizerFour, + rawOptimizerDimension, explicitRegularizationScale] + +@[simp] theorem rawOptimizerInteriorK0_value (n B : β„•) : + (rawOptimizerInteriorK0 n B).value = numericalInteriorK0 n B + (explicitRegularizationScale n) := by + simp [rawOptimizerInteriorK0, rawOptimizerInteriorSum, + rawOptimizerNSquare, rawOptimizerNCube, numericalInteriorK0, + rawOptimizerTwo] + ring + +@[simp] theorem rawOptimizerTwiceInteriorK0_value (n B : β„•) : + (rawOptimizerTwiceInteriorK0 n B).value = + 2 * numericalInteriorK0 n B (explicitRegularizationScale n) := by + simp [rawOptimizerTwiceInteriorK0, rawOptimizerTwo] + +@[simp] theorem machineOptimizerInteriorExponentBits_encode + {n : β„•} (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorExponentBits + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + (numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n)).bits := by + rw [machineOptimizerInteriorExponentBits, + machineOptimizerTwiceInteriorK0RawCode_encode, + machineRationalCeilNatBits_encode, + rawOptimizerTwiceInteriorK0_value] + rw [numericalInteriorExponent] + simp [rationalCeilNat, binaryRatCeil_eq_ceil] + +/-! ## Guarded unary exponent and dyadic floor -/ + +/-- The explicit interior-exponent coefficient `34 * rationalCeilNat (8 / explicitXi) + 2`. -/ +def explicitOptimizerInteriorExponentCoefficient : β„• := + 34 * rationalCeilNat (8 / explicitXi) + 2 + +theorem explicitOptimizerInteriorExponentCoefficient_le : + explicitOptimizerInteriorExponentCoefficient ≀ 17 ^ 60 := by + norm_num [explicitOptimizerInteriorExponentCoefficient, + rationalCeilNat, explicitXi, explicitDelta, explicitEta, + explicitRowRatio] + +theorem numericalInteriorExponent_le_sourcePolynomial + {n B S : β„•} (hn : 1 ≀ n) (hnS : n ≀ S) (hBS : B ≀ 32 * S) : + numericalInteriorExponent n B (explicitRegularizationScale n) ≀ + explicitOptimizerInteriorExponentCoefficient * S ^ 4 := by + have hxi : 0 < explicitXi := explicitXi_pos + have hnQ : (0 : β„š) < n := by exact_mod_cast hn + have htau : explicitRegularizationScale n = explicitXi / (4 * n) := rfl + have hrewrite : + 2 * numericalInteriorK0 n B (explicitRegularizationScale n) = + (8 / explicitXi) * (n ^ 3 * B + 2 * n ^ 4) + 2 * n ^ 3 := by + rw [numericalInteriorK0, htau] + field_simp [hxi.ne', hnQ.ne'] + ring + let C := rationalCeilNat (8 / explicitXi) + have hC : (8 / explicitXi : β„š) ≀ C := by + exact le_rationalCeilNat (by positivity) + have hnonneg : (0 : β„š) ≀ n ^ 3 * B + 2 * n ^ 4 := by positivity + have hmain : + (8 / explicitXi : β„š) * (n ^ 3 * B + 2 * n ^ 4) + 2 * n ^ 3 ≀ + C * (n ^ 3 * B + 2 * n ^ 4) + 2 * n ^ 3 := by + gcongr + have hn3 : n ^ 3 ≀ S ^ 3 := Nat.pow_le_pow_left hnS 3 + have hn4 : n ^ 4 ≀ S ^ 4 := Nat.pow_le_pow_left hnS 4 + have hS1 : 1 ≀ S := hn.trans hnS + have hS3S : S ^ 3 ≀ S ^ 4 := by + rw [pow_succ] + exact Nat.le_mul_of_pos_right _ hS1 + have hpolyNat : + C * (n ^ 3 * B + 2 * n ^ 4) + 2 * n ^ 3 ≀ + (34 * C + 2) * S ^ 4 := by + nlinarith [Nat.mul_le_mul hn3 hBS, hn4, hn3.trans hS3S] + have hpoly : + (C : β„š) * (n ^ 3 * B + 2 * n ^ 4) + 2 * n ^ 3 ≀ + ((34 * C + 2) * S ^ 4 : β„•) := by + exact_mod_cast hpolyNat + apply rationalCeilNat_le_of_le_nat + rw [hrewrite] + exact hmain.trans hpoly + +/-- Applies the binary-width construction six times to bound conversion of the interior exponent +to unary. -/ +def machineOptimizerInteriorExponentGuard (word : List Bool) : List Bool := + machineIteratedBinaryWidth 6 word + +/-- Converts the interior exponent to a unary ruler under its computed guard. -/ +def machineOptimizerInteriorExponentUnary (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerInteriorExponentGuard word) + (machineOptimizerInteriorExponentBits word)) + +/-- Raises raw one-half to the unary interior exponent. -/ +def machineOptimizerInteriorFloorRawCode (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineOptimizerInteriorExponentUnary word) + (rawRatBinaryCode rawOptimizerHalf)) + +/-- Divides the interior power-of-two floor by two to obtain the explicit optimizer floor. -/ +def machineExplicitOptimizerFloorRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineOptimizerInteriorFloorRawCode word) + (rawRatBinaryCode rawOptimizerTwo)) + +theorem machineOptimizerInteriorExponentGuard_mem_FP : + machineOptimizerInteriorExponentGuard ∈ FP := by + simpa only [machineOptimizerInteriorExponentGuard] using! + machineIteratedBinaryWidth_mem_FP 6 + +theorem machineOptimizerInteriorExponentUnary_mem_FP : + machineOptimizerInteriorExponentUnary ∈ FP := by + simpa only [machineOptimizerInteriorExponentUnary] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerInteriorExponentGuard_mem_FP + machineOptimizerInteriorExponentBits_mem_FP) + machineBoundedUnary_mem_FP + +theorem machineOptimizerInteriorFloorRawCode_mem_FP : + machineOptimizerInteriorFloorRawCode ∈ FP := by + simpa only [machineOptimizerInteriorFloorRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerInteriorExponentUnary_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerHalf))) + machineRawRatPowerCode_mem_FP + +theorem machineExplicitOptimizerFloorRawCode_mem_FP : + machineExplicitOptimizerFloorRawCode ∈ FP := by + simpa only [machineExplicitOptimizerFloorRawCode] using! machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerInteriorFloorRawCode_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo))) + machineRawRatDivCode_mem_FP + +theorem optimizerInteriorExponent_le_guard {n : β„•} (hn : 1 ≀ n) + (A : Matrix (Fin n) (Fin n) β„š) : + numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n) ≀ + (machineOptimizerInteriorExponentGuard + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)).length := by + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let S := word.length + have hnS : n ≀ S := by + simpa only [S, word] using! matrix_dimension_le_code_length A + have hBS : rationalMatrixEntryBitBound A ≀ 32 * S := by + simpa only [S, word] using! rationalMatrixEntryBitBound_le_machineCode hn A + have hpoly := numericalInteriorExponent_le_sourcePolynomial hn hnS hBS + have hcoeff : + explicitOptimizerInteriorExponentCoefficient * S ^ 4 ≀ + (S + 16) ^ 64 := by + calc + explicitOptimizerInteriorExponentCoefficient * S ^ 4 ≀ + 17 ^ 60 * S ^ 4 := + Nat.mul_le_mul explicitOptimizerInteriorExponentCoefficient_le + (le_refl _) + _ ≀ (S + 16) ^ 60 * (S + 16) ^ 4 := by + exact Nat.mul_le_mul + (Nat.pow_le_pow_left (by omega) 60) + (Nat.pow_le_pow_left (by omega) 4) + _ = (S + 16) ^ 64 := by rw [← pow_add] + calc + numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n) ≀ + explicitOptimizerInteriorExponentCoefficient * S ^ 4 := hpoly + _ ≀ (S + 16) ^ 64 := hcoeff + _ ≀ certificateExpGuardWidth 6 S := by + simpa using! certificateExpGuardWidth_pow_lower 5 S + _ = (machineOptimizerInteriorExponentGuard word).length := by + simp [machineOptimizerInteriorExponentGuard, S] + +@[simp] theorem machineOptimizerInteriorExponentUnary_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorExponentUnary + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate + (numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n)) true := by + rw [machineOptimizerInteriorExponentUnary, + machineOptimizerInteriorExponentBits_encode] + exact machineBoundedUnary_encode_of_le _ _ + (optimizerInteriorExponent_le_guard hn A) + +@[simp] theorem rawOptimizerHalf_value : rawOptimizerHalf.value = 1 / 2 := by + simp [rawOptimizerHalf, rawOptimizerTwo] + +@[simp] theorem machineOptimizerInteriorFloorRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineOptimizerInteriorFloorRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawOptimizerHalf.pow + (numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n))) := by + rw [machineOptimizerInteriorFloorRawCode, + machineOptimizerInteriorExponentUnary_encode hn, + machineRawRatPowerCode_encode] + +@[simp] theorem machineExplicitOptimizerFloorRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) : + machineExplicitOptimizerFloorRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode ((rawOptimizerHalf.pow + (numericalInteriorExponent n (rationalMatrixEntryBitBound A) + (explicitRegularizationScale n))).div rawOptimizerTwo) := by + rw [machineExplicitOptimizerFloorRawCode, + machineOptimizerInteriorFloorRawCode_encode hn, + machineRawRatDivCode_encode] + +theorem machineExplicitOptimizerFloorRawValue {m : β„•} + (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) : + ((rawOptimizerHalf.pow + (numericalInteriorExponent (m + 1) (rationalMatrixEntryBitBound A) + (explicitRegularizationScale (m + 1)))).div rawOptimizerTwo).value = + explicitOptimizerFloor A := by + simp [explicitOptimizerFloor, numericalInteriorFloor, + rawOptimizerHalf_value, rawOptimizerTwo] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerMatrixBitBound.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerMatrixBitBound.lean new file mode 100644 index 0000000000..138a50f7b1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerMatrixBitBound.lean @@ -0,0 +1,609 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerEntryLength +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.CertificateMagnitude + +/-! +# Exact matrix entry-bit bound for the optimizer + +This row-major transducer returns a unary ruler of length +`rationalMatrixEntryBitBound A`. Its clamp and state envelope are explicit +on arbitrary bitstrings; the clamp is proved inactive on every canonical +matrix input. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Packs remaining matrix rows, the current suffix, accumulated length ruler, and bound for the +entry-length scan. -/ +def machineMatrixEntryLengthPack + (rows current acc bound : List Bool) : List Bool := + pair rows (pair current (pair acc bound)) + +/-- Extracts the remaining rows from the matrix-entry-length scan state. -/ +def machineMatrixEntryLengthRows (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the current row suffix from the matrix-entry-length scan state. -/ +def machineMatrixEntryLengthCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulated entry-length ruler from the scan state. -/ +def machineMatrixEntryLengthAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the length-bound word from the matrix-entry-length scan state. -/ +def machineMatrixEntryLengthBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Reads the next encoded entry of the current row suffix. -/ +def machineMatrixEntryLengthEntry (state : List Bool) : List Bool := + machineListHead (machineMatrixEntryLengthCurrent state) + +/-- Appends the current entry's optimizer length ruler to the accumulated ruler. -/ +def machineMatrixEntryLengthCandidate (state : List Bool) : List Bool := + machineMatrixEntryLengthAcc state ++ + machineOptimizerEntryLengthRuler (machineMatrixEntryLengthEntry state) + +/-- Truncates the updated length ruler to the length of the stored bound. -/ +def machineMatrixEntryLengthNextAcc (state : List Bool) : List Bool := + (machineMatrixEntryLengthCandidate state).take + (machineMatrixEntryLengthBound state).length + +/-- Consumes one matrix entry and stores its contribution in the bounded length accumulator. -/ +def machineMatrixEntryLengthProcessEntry (state : List Bool) : List Bool := + machineMatrixEntryLengthPack + (machineMatrixEntryLengthRows state) + (machineListTail (machineMatrixEntryLengthCurrent state)) + (machineMatrixEntryLengthNextAcc state) + (machineMatrixEntryLengthBound state) + +/-- Loads the next matrix row while preserving the accumulated length and bound. -/ +def machineMatrixEntryLengthLoadRow (state : List Bool) : List Bool := + machineMatrixEntryLengthPack + (machineListTail (machineMatrixEntryLengthRows state)) + (machineListHead (machineMatrixEntryLengthRows state)) + (machineMatrixEntryLengthAcc state) + (machineMatrixEntryLengthBound state) + +/-- Fixes a scan with no remaining rows and otherwise loads its next row. -/ +def machineMatrixEntryLengthAfterRow (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixEntryLengthRows state) state + (machineMatrixEntryLengthLoadRow state) + +/-- Processes the current entry when present and otherwise loads another row or finishes. -/ +def machineMatrixEntryLengthStep (state : List Bool) : List Bool := + machineIfEmpty (machineMatrixEntryLengthCurrent state) + (machineMatrixEntryLengthAfterRow state) + (machineMatrixEntryLengthProcessEntry state) + +/-- Builds a bound word consisting of eight false bits followed by sixty-four copies of the +input word. -/ +def machineMatrixEntryLengthInputBound (word : List Bool) : List Bool := + let w2 := word ++ word + let w4 := w2 ++ w2 + let w8 := w4 ++ w4 + let w16 := w8 ++ w8 + let w32 := w16 ++ w16 + let w64 := w32 ++ w32 + List.replicate 8 false ++ w64 + +/-- Initializes the entry-length scan with all matrix rows, empty current row, a one-bit +accumulator, and its computed bound. -/ +def machineMatrixEntryLengthInit (word : List Bool) : List Bool := + machineMatrixEntryLengthPack (machineMatrixRowsWord word) [] [true] + (machineMatrixEntryLengthInputBound word) + +/-- Packs four copies of the computed bound to bound the encoded entry-length scan state. -/ +def machineMatrixEntryLengthWidth (word : List Bool) : List Bool := + let bound := machineMatrixEntryLengthInputBound word + machineMatrixEntryLengthPack bound bound bound bound + +/-- Runs the entry-length scan once per input bit from its initial state. -/ +def machineMatrixEntryLengthFinalState (word : List Bool) : List Bool := + (machineMatrixEntryLengthStep)^[word.length] + (machineMatrixEntryLengthInit word) + +/-- Exact unary matrix-entry bit bound on canonical inputs. -/ +def machineMatrixEntryBitBoundRuler (word : List Bool) : List Bool := + machineMatrixEntryLengthAcc (machineMatrixEntryLengthFinalState word) + +/-! ## Polynomial-time envelope -/ + +theorem machineMatrixEntryLengthRows_mem_FP : + machineMatrixEntryLengthRows ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineMatrixEntryLengthCurrent_mem_FP : + machineMatrixEntryLengthCurrent ∈ Complexity.FP := by + simpa only [machineMatrixEntryLengthCurrent] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixEntryLengthAcc_mem_FP : + machineMatrixEntryLengthAcc ∈ Complexity.FP := by + simpa only [machineMatrixEntryLengthAcc] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineMatrixEntryLengthBound_mem_FP : + machineMatrixEntryLengthBound ∈ Complexity.FP := by + simpa only [machineMatrixEntryLengthBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineMatrixEntryLengthEntry_mem_FP : + machineMatrixEntryLengthEntry ∈ Complexity.FP := by + simpa only [machineMatrixEntryLengthEntry] using! + machineCompose_mem_FP machineMatrixEntryLengthCurrent_mem_FP + machineListHead_mem_FP + +theorem machineMatrixEntryLengthCandidate_mem_FP : + machineMatrixEntryLengthCandidate ∈ Complexity.FP := by + have hcost := machineCompose_mem_FP machineMatrixEntryLengthEntry_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + exact machineAppend_mem_FP machineMatrixEntryLengthAcc_mem_FP hcost + +theorem machineMatrixEntryLengthNextAcc_mem_FP : + machineMatrixEntryLengthNextAcc ∈ Complexity.FP := by + simpa only [machineMatrixEntryLengthNextAcc] using! + machineTake_mem_FP machineMatrixEntryLengthBound_mem_FP + machineMatrixEntryLengthCandidate_mem_FP + +theorem machineMatrixEntryLengthProcessEntry_mem_FP : + machineMatrixEntryLengthProcessEntry ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixEntryLengthCurrent_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP machineMatrixEntryLengthRows_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP machineMatrixEntryLengthNextAcc_mem_FP + machineMatrixEntryLengthBound_mem_FP)) + +theorem machineMatrixEntryLengthLoadRow_mem_FP : + machineMatrixEntryLengthLoadRow ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineMatrixEntryLengthRows_mem_FP + machineListTail_mem_FP + have hhead := machineCompose_mem_FP machineMatrixEntryLengthRows_mem_FP + machineListHead_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP hhead + (machinePair_mem_FP machineMatrixEntryLengthAcc_mem_FP + machineMatrixEntryLengthBound_mem_FP)) + +theorem machineMatrixEntryLengthAfterRow_mem_FP : + machineMatrixEntryLengthAfterRow ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixEntryLengthRows_mem_FP id_mem_FP + machineMatrixEntryLengthLoadRow_mem_FP + +theorem machineMatrixEntryLengthStep_mem_FP : + machineMatrixEntryLengthStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineMatrixEntryLengthCurrent_mem_FP + machineMatrixEntryLengthAfterRow_mem_FP + machineMatrixEntryLengthProcessEntry_mem_FP + +theorem machineMatrixEntryLengthInputBound_mem_FP : + machineMatrixEntryLengthInputBound ∈ Complexity.FP := by + have h2 := machineAppend_mem_FP id_mem_FP id_mem_FP + have h4 := machineAppend_mem_FP h2 h2 + have h8 := machineAppend_mem_FP h4 h4 + have h16 := machineAppend_mem_FP h8 h8 + have h32 := machineAppend_mem_FP h16 h16 + have h64 := machineAppend_mem_FP h32 h32 + simpa only [machineMatrixEntryLengthInputBound] using! + machineAppend_mem_FP + (machineConst_mem_FP (List.replicate 8 false)) h64 + +theorem machineMatrixEntryLengthInit_mem_FP : + machineMatrixEntryLengthInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixRowsWord_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineMatrixEntryLengthInputBound_mem_FP)) + +theorem machineMatrixEntryLengthWidth_mem_FP : + machineMatrixEntryLengthWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineMatrixEntryLengthInputBound_mem_FP + (machinePair_mem_FP machineMatrixEntryLengthInputBound_mem_FP + (machinePair_mem_FP machineMatrixEntryLengthInputBound_mem_FP + machineMatrixEntryLengthInputBound_mem_FP)) + +@[simp] theorem machineMatrixEntryLengthRows_pack (rows current acc bound) : + machineMatrixEntryLengthRows + (machineMatrixEntryLengthPack rows current acc bound) = rows := by + simp [machineMatrixEntryLengthRows, machineMatrixEntryLengthPack] + +@[simp] theorem machineMatrixEntryLengthCurrent_pack (rows current acc bound) : + machineMatrixEntryLengthCurrent + (machineMatrixEntryLengthPack rows current acc bound) = current := by + simp [machineMatrixEntryLengthCurrent, machineMatrixEntryLengthPack] + +@[simp] theorem machineMatrixEntryLengthAcc_pack (rows current acc bound) : + machineMatrixEntryLengthAcc + (machineMatrixEntryLengthPack rows current acc bound) = acc := by + simp [machineMatrixEntryLengthAcc, machineMatrixEntryLengthPack] + +@[simp] theorem machineMatrixEntryLengthBound_pack (rows current acc bound) : + machineMatrixEntryLengthBound + (machineMatrixEntryLengthPack rows current acc bound) = bound := by + simp [machineMatrixEntryLengthBound, machineMatrixEntryLengthPack] + +@[simp] theorem machineMatrixEntryLengthInputBound_length (word : List Bool) : + (machineMatrixEntryLengthInputBound word).length = + 8 + 64 * word.length := by + simp [machineMatrixEntryLengthInputBound] + omega + +/-- Requires exact scan-state packing, remaining row data bounded by input length, bounded +accumulated ruler, and the prescribed bound word. -/ +def MachineMatrixEntryLengthStateBound (word state : List Bool) : Prop := + state = machineMatrixEntryLengthPack + (machineMatrixEntryLengthRows state) + (machineMatrixEntryLengthCurrent state) + (machineMatrixEntryLengthAcc state) + (machineMatrixEntryLengthBound state) ∧ + (machineMatrixEntryLengthRows state).length ≀ word.length ∧ + (machineMatrixEntryLengthCurrent state).length ≀ word.length ∧ + (machineMatrixEntryLengthAcc state).length ≀ + (machineMatrixEntryLengthInputBound word).length ∧ + machineMatrixEntryLengthBound state = + machineMatrixEntryLengthInputBound word + +theorem machineMatrixEntryLengthInit_bound (word : List Bool) : + MachineMatrixEntryLengthStateBound word + (machineMatrixEntryLengthInit word) := by + simp only [MachineMatrixEntryLengthStateBound, + machineMatrixEntryLengthInit, machineMatrixEntryLengthRows_pack, + machineMatrixEntryLengthCurrent_pack, machineMatrixEntryLengthAcc_pack, + machineMatrixEntryLengthBound_pack] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le word + Β· simp only [machineMatrixEntryLengthInputBound_length, + List.length_singleton] + omega + +theorem machineMatrixEntryLengthStep_bound {word state : List Bool} + (hstate : MachineMatrixEntryLengthStateBound word state) : + MachineMatrixEntryLengthStateBound word + (machineMatrixEntryLengthStep state) := by + rcases hstate with ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + by_cases hc : machineMatrixEntryLengthCurrent state = [] + Β· rw [machineMatrixEntryLengthStep, hc, machineIfEmpty_nil] + by_cases hr : machineMatrixEntryLengthRows state = [] + Β· rw [machineMatrixEntryLengthAfterRow, hr, machineIfEmpty_nil] + exact ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + Β· rw [machineMatrixEntryLengthAfterRow] + cases hrowsCode : machineMatrixEntryLengthRows state with + | nil => exact False.elim (hr hrowsCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixEntryLengthLoadRow] + simp only [MachineMatrixEntryLengthStateBound, + machineMatrixEntryLengthRows_pack, + machineMatrixEntryLengthCurrent_pack, + machineMatrixEntryLengthAcc_pack, + machineMatrixEntryLengthBound_pack] + refine ⟨trivial, ?_, ?_, hacc, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixEntryLengthRows state)).trans hrows + Β· exact (machinePairFirst_length_le + (machineMatrixEntryLengthRows state)).trans hrows + Β· rw [machineMatrixEntryLengthStep] + cases hcurrentCode : machineMatrixEntryLengthCurrent state with + | nil => exact False.elim (hc hcurrentCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineMatrixEntryLengthProcessEntry] + simp only [MachineMatrixEntryLengthStateBound, + machineMatrixEntryLengthRows_pack, + machineMatrixEntryLengthCurrent_pack, + machineMatrixEntryLengthAcc_pack, + machineMatrixEntryLengthBound_pack] + refine ⟨trivial, hrows, ?_, ?_, hbound⟩ + Β· exact (machinePairSecond_length_le + (machineMatrixEntryLengthCurrent state)).trans hcurrent + Β· rw [machineMatrixEntryLengthNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineMatrixEntryLengthIterate_bound (word : List Bool) : βˆ€ k, + MachineMatrixEntryLengthStateBound word + ((machineMatrixEntryLengthStep)^[k] + (machineMatrixEntryLengthInit word)) := by + intro k + induction k with + | zero => exact machineMatrixEntryLengthInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineMatrixEntryLengthStep_bound ih + +theorem machineMatrixEntryLengthIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineMatrixEntryLengthStep)^[iterations] + (machineMatrixEntryLengthInit word)).length ≀ + (machineMatrixEntryLengthWidth word).length := by + rcases machineMatrixEntryLengthIterate_bound word iterations with + ⟨hdecomp, hrows, hcurrent, hacc, hbound⟩ + rw [hdecomp, hbound] + simp only [machineMatrixEntryLengthPack, + machineMatrixEntryLengthWidth, pair_length] + have hword : word.length ≀ + (machineMatrixEntryLengthInputBound word).length := by + simp only [machineMatrixEntryLengthInputBound_length] + omega + omega + +theorem machineMatrixEntryLengthFinalState_mem_FP : + machineMatrixEntryLengthFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineMatrixEntryLengthStep_mem_FP + machineMatrixEntryLengthInit_mem_FP id_mem_FP + machineMatrixEntryLengthWidth_mem_FP + machineMatrixEntryLengthIterate_length_le_width + +theorem machineMatrixEntryBitBoundRuler_mem_FP : + machineMatrixEntryBitBoundRuler ∈ Complexity.FP := by + simpa only [machineMatrixEntryBitBoundRuler] using! + machineCompose_mem_FP machineMatrixEntryLengthFinalState_mem_FP + machineMatrixEntryLengthAcc_mem_FP + +/-! ## Exact semantics -/ + +/-- Sums the rational encoding bit lengths of a list of entries. -/ +def matrixEntryLengthListCost (xs : List β„š) : β„• := + (xs.map fun q ↦ encodedBitLength β„š q).sum + +/-- Sums the entry-encoding bit costs of all rows. -/ +def matrixEntryLengthRowsCost (rows : List (List β„š)) : β„• := + (rows.map matrixEntryLengthListCost).sum + +structure MatrixEntryLengthSemState where + /-- The unprocessed rows of the semantic matrix-entry-length scan. -/ + rows : List (List β„š) + /-- The unprocessed suffix of the current row in the semantic length scan. -/ + current : List β„š + /-- The natural-number total accumulated by the semantic entry-length scan. -/ + acc : β„• + +/-- Encodes the semantic remaining rows, current suffix, and unary accumulated length using the +supplied bound word. -/ +def matrixEntryLengthSemCode (bound : List Bool) + (s : MatrixEntryLengthSemState) : List Bool := + machineMatrixEntryLengthPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) s.rows) + (binaryListCode rationalEntryBinaryCode s.current) + (List.replicate s.acc true) bound + +/-- Adds the next entry's encoding length, loads the next row when needed, and fixes the +exhausted semantic scan. -/ +def matrixEntryLengthSemStep : + MatrixEntryLengthSemState β†’ MatrixEntryLengthSemState + | ⟨[], [], acc⟩ => ⟨[], [], acc⟩ + | ⟨row :: rows, [], acc⟩ => ⟨rows, row, acc⟩ + | ⟨rows, q :: qs, acc⟩ => + ⟨rows, qs, acc + encodedBitLength β„š q⟩ + +/-- Bounds the accumulated length plus all unprocessed entry costs by the specified bound +length. -/ +def MatrixEntryLengthSemInvariant + (boundLength : β„•) (s : MatrixEntryLengthSemState) : Prop := + s.acc + matrixEntryLengthListCost s.current + + matrixEntryLengthRowsCost s.rows ≀ boundLength + +theorem matrixEntryLengthSemStep_invariant {L : β„•} + {s : MatrixEntryLengthSemState} + (hs : MatrixEntryLengthSemInvariant L s) : + MatrixEntryLengthSemInvariant L (matrixEntryLengthSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | cons q qs => + simpa [MatrixEntryLengthSemInvariant, matrixEntryLengthSemStep, + matrixEntryLengthListCost, Nat.add_assoc] using! hs + | nil => + cases rows with + | nil => simpa [MatrixEntryLengthSemInvariant, + matrixEntryLengthSemStep] using! hs + | cons row rows => + simpa [MatrixEntryLengthSemInvariant, matrixEntryLengthSemStep, + matrixEntryLengthListCost, matrixEntryLengthRowsCost, + Nat.add_assoc] using! hs + +theorem machineMatrixEntryLengthStep_semantics + (bound : List Bool) (s : MatrixEntryLengthSemState) + (hs : MatrixEntryLengthSemInvariant bound.length s) : + machineMatrixEntryLengthStep (matrixEntryLengthSemCode bound s) = + matrixEntryLengthSemCode bound (matrixEntryLengthSemStep s) := by + rcases s with ⟨rows, current, acc⟩ + cases current with + | nil => + cases rows with + | nil => + simp [machineMatrixEntryLengthStep, + machineMatrixEntryLengthAfterRow, matrixEntryLengthSemCode, + matrixEntryLengthSemStep, binaryListCode] + | cons row rows => + rw [matrixEntryLengthSemCode, matrixEntryLengthSemStep, + machineMatrixEntryLengthStep] + simp only [machineMatrixEntryLengthCurrent_pack, binaryListCode, + machineIfEmpty_nil, machineMatrixEntryLengthAfterRow, + machineMatrixEntryLengthRows_pack] + have hpair : pair (binaryListCode rationalEntryBinaryCode row) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) β‰  + [] := by + intro h + have hlen := congrArg List.length h + simp at hlen + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hpair] + simp [machineMatrixEntryLengthLoadRow, + matrixEntryLengthSemCode, machineListHead, machineListTail] + | cons q qs => + have hfit : acc + encodedBitLength β„š q ≀ bound.length := by + simp [MatrixEntryLengthSemInvariant, + matrixEntryLengthListCost] at hs + omega + rw [matrixEntryLengthSemCode, matrixEntryLengthSemStep, + machineMatrixEntryLengthStep] + simp only [machineMatrixEntryLengthCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineMatrixEntryLengthProcessEntry, + machineMatrixEntryLengthRows_pack, + machineMatrixEntryLengthCurrent_pack, + machineMatrixEntryLengthAcc_pack, + machineMatrixEntryLengthBound_pack, + machineListTail_cons, machineMatrixEntryLengthNextAcc, + machineMatrixEntryLengthCandidate, + machineMatrixEntryLengthEntry, machineListHead_cons, + machineOptimizerEntryLengthRuler_encode] + rw [show List.replicate acc true ++ + List.replicate (encodedBitLength β„š q) true = + List.replicate (acc + encodedBitLength β„š q) true by + exact (List.replicate_add _ _ _).symm, + (List.take_eq_self_iff _).mpr (by simpa using! hfit)] + rfl + +theorem machineMatrixEntryLengthIterate_semantics + (bound : List Bool) (s : MatrixEntryLengthSemState) + (hs : MatrixEntryLengthSemInvariant bound.length s) : βˆ€ k, + (machineMatrixEntryLengthStep)^[k] + (matrixEntryLengthSemCode bound s) = + matrixEntryLengthSemCode bound ((matrixEntryLengthSemStep)^[k] s) := by + intro k + have hinv : βˆ€ t, + MatrixEntryLengthSemInvariant bound.length + ((matrixEntryLengthSemStep)^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact matrixEntryLengthSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineMatrixEntryLengthStep_semantics bound _ (hinv k) + +theorem matrixEntryLengthSem_processRow + (rows : List (List β„š)) (row : List β„š) (acc : β„•) : + (matrixEntryLengthSemStep)^[row.length] + ⟨rows, row, acc⟩ = + ⟨rows, [], acc + matrixEntryLengthListCost row⟩ := by + induction row generalizing acc with + | nil => simp [matrixEntryLengthListCost] + | cons q qs ih => + rw [List.length_cons, Function.iterate_succ_apply, + matrixEntryLengthSemStep, ih] + simp [matrixEntryLengthListCost, Nat.add_assoc] + +theorem matrixEntryLengthSem_processRows + (rows : List (List β„š)) (acc : β„•) : + (matrixEntryLengthSemStep)^[matrixNonnegativeRowsWork rows] + ⟨rows, [], acc⟩ = + ⟨[], [], acc + matrixEntryLengthRowsCost rows⟩ := by + induction rows generalizing acc with + | nil => simp [matrixNonnegativeRowsWork, matrixEntryLengthRowsCost] + | cons row rows ih => + rw [matrixNonnegativeRowsWork, show 1 + row.length + + matrixNonnegativeRowsWork rows = + matrixNonnegativeRowsWork rows + row.length + 1 by omega, + Function.iterate_add_apply, Function.iterate_add_apply, + Function.iterate_one, matrixEntryLengthSemStep, + matrixEntryLengthSem_processRow, ih] + simp [matrixEntryLengthRowsCost, Nat.add_assoc] + +theorem machineMatrixEntryLength_done_iterate + (extra : β„•) (acc : β„•) (bound : List Bool) : + (machineMatrixEntryLengthStep)^[extra] + (machineMatrixEntryLengthPack [] [] + (List.replicate acc true) bound) = + machineMatrixEntryLengthPack [] [] + (List.replicate acc true) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineMatrixEntryLengthStep, machineMatrixEntryLengthAfterRow] + +theorem matrixEntryLengthRowsCost_eq_matrixBound {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + 1 + matrixEntryLengthRowsCost (rationalMatrixRows A) = + rationalMatrixEntryBitBound A := by + simp only [matrixEntryLengthRowsCost, matrixEntryLengthListCost, + rationalMatrixRows, rationalMatrixEntryBitBound, + List.map_ofFn, List.sum_ofFn, Function.comp_apply] + +theorem machineMatrixEntryLengthFinalState_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixEntryLengthFinalState + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + machineMatrixEntryLengthPack [] [] + (List.replicate (rationalMatrixEntryBitBound A) true) + (machineMatrixEntryLengthInputBound + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) := by + let rows := rationalMatrixRows A + let word := rationalMatrixBinaryEncoding.encode ⟨n, A⟩ + let bound := machineMatrixEntryLengthInputBound word + let s : MatrixEntryLengthSemState := ⟨rows, [], 1⟩ + have hrowsLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machineMatrixRowsWord word).length := by + simpa only [word, rows] using! congrArg List.length + (machineMatrixRowsWord_encode A).symm + _ ≀ word.length := by + simpa only [machineMatrixRowsWord] using! + machinePairSecond_length_le word + have hcost : rationalMatrixEntryBitBound A ≀ bound.length := by + by_cases hn : n = 0 + Β· subst n + simp only [rationalMatrixEntryBitBound, rationalMatrixRows, + Finset.univ_eq_empty, Finset.sum_empty, Nat.add_zero, bound, + machineMatrixEntryLengthInputBound_length] + omega + Β· have hmachine := rationalMatrixEntryBitBound_le_machineCode + (Nat.pos_of_ne_zero hn) A + have hmachine' : rationalMatrixEntryBitBound A ≀ 32 * word.length := by + simpa only [word] using! hmachine + simp only [bound, machineMatrixEntryLengthInputBound_length] + omega + have hinv : MatrixEntryLengthSemInvariant bound.length s := by + simpa only [MatrixEntryLengthSemInvariant, s, + matrixEntryLengthListCost, List.map_nil, List.sum_nil, Nat.add_zero, + rows, matrixEntryLengthRowsCost_eq_matrixBound] using! hcost + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsLength + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + have hinit : machineMatrixEntryLengthInit word = + matrixEntryLengthSemCode bound s := by + simp [machineMatrixEntryLengthInit, matrixEntryLengthSemCode, + s, rows, word, bound, binaryListCode] + change machineMatrixEntryLengthFinalState word = _ + rw [machineMatrixEntryLengthFinalState, hsplit, + Function.iterate_add_apply, hinit, + machineMatrixEntryLengthIterate_semantics bound s hinv, + matrixEntryLengthSem_processRows] + simp only [matrixEntryLengthSemCode, binaryListCode] + rw [machineMatrixEntryLength_done_iterate] + congr 2 + rw [matrixEntryLengthRowsCost_eq_matrixBound] + +@[simp] theorem machineMatrixEntryBitBoundRuler_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixEntryBitBoundRuler + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + List.replicate (rationalMatrixEntryBitBound A) true := by + rw [machineMatrixEntryBitBoundRuler, + machineMatrixEntryLengthFinalState_encode] + simp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerRoundingSchedule.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerRoundingSchedule.lean new file mode 100644 index 0000000000..446e017e9c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerRoundingSchedule.lean @@ -0,0 +1,605 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerFeasibilitySchedule +public import LeanPool.BeyondBethe.BeyondBethe.MachineNaturalCombinators +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitBetheThresholdFeasibility + +/-! # Machine Optimizer Rounding Schedule -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Finite-word rounding precision for Bethe feasibility + +The precision is the explicit zero-ball schedule proved in +`ExplicitScheduledFeasibility`. Its inputs are the exact ellipsoid dimension, +the exact iteration budget, and canonical bit lengths of the outer radius and +of the initial state-magnitude bound. +-/ + +/-- Computes the raw initial magnitude `2 + d * R` for ellipsoid feasibility. -/ +def rawOptimizerFeasibilityInitialMagnitude + (d : β„•) (R : RawRat) : RawRat := + rawOptimizerTwo.add ((RawRat.ofNat d).mul R) + +/-- Computes the raw initial magnitude by adding two to ellipsoid dimension times outer radius. -/ +def machineOptimizerFeasibilityInitialMagnitudeRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawOptimizerTwo) + (machineRawRatMulCode + (pair (machineOptimizerFeasibilityEllipsoidDimensionRawCode word) + (machineOptimizerFeasibilityOuterRadiusRawCode word)))) + +/-- Normalizes the raw initial-magnitude code into its rational entry encoding. -/ +def machineOptimizerFeasibilityInitialMagnitudeEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineOptimizerFeasibilityInitialMagnitudeRawCode word) + +/-- Computes the optimizer length ruler for the normalized initial magnitude. -/ +def machineOptimizerFeasibilityInitialMagnitudeLengthRuler + (word : List Bool) : List Bool := + machineOptimizerEntryLengthRuler + (machineOptimizerFeasibilityInitialMagnitudeEntryCode word) + +/-- Computes the binary initial-magnitude length `K` from its ruler. -/ +def machineOptimizerFeasibilityKBits (word : List Bool) : List Bool := + machineLengthBits + (machineOptimizerFeasibilityInitialMagnitudeLengthRuler word) + +/-- Computes `L` as the outer-radius length multiplied by ellipsoid dimension. -/ +def machineOptimizerFeasibilityLBits (word : List Bool) : List Bool := + machineBinaryMulOf machineOptimizerFeasibilityOuterLengthBits + machineOptimizerFeasibilityDBits word + +/-- Doubles the binary feasibility iteration budget `T`. -/ +def machineOptimizerFeasibilityTwoTBits (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityBudgetBits word + +/-- Computes the magnitude-bound term `L + 2 * T` in binary. -/ +def machineOptimizerFeasibilityFirstBaseBits (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityLBits + machineOptimizerFeasibilityTwoTBits word + +/-- Computes the magnitude-bound term `L + 2 * T + 1` in binary. -/ +def machineOptimizerFeasibilityFirstBits (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityFirstBaseBits + (machineBinaryConst 1) word + +/-- Computes three times the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityThreeDBits (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 3) + machineOptimizerFeasibilityDBits word + +/-- Computes the per-step magnitude-growth term `6 + 3 * D` in binary. -/ +def machineOptimizerFeasibilitySixPlusThreeDBits + (word : List Bool) : List Bool := + machineBinaryAddOf (machineBinaryConst 6) + machineOptimizerFeasibilityThreeDBits word + +/-- Multiplies the feasibility iteration budget by the magnitude-growth term `6 + 3 * D`. -/ +def machineOptimizerFeasibilityTTimesGrowthBits + (word : List Bool) : List Bool := + machineBinaryMulOf machineOptimizerFeasibilityBudgetBits + machineOptimizerFeasibilitySixPlusThreeDBits word + +/-- Adds initial-magnitude length `K` to the accumulated growth `T * (6 + 3 * D)`. -/ +def machineOptimizerFeasibilityKPlusGrowthBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityKBits + machineOptimizerFeasibilityTTimesGrowthBits word + +/-- Adds three to the initial length plus accumulated magnitude growth. -/ +def machineOptimizerFeasibilityKPlusGrowthPlusThreeBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityKPlusGrowthBits + (machineBinaryConst 3) word + +/-- Computes the inner magnitude term `K + T * (6 + 3 * D) + 3 + D` in binary. -/ +def machineOptimizerFeasibilityInnerMagnitudeBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityKPlusGrowthPlusThreeBits + machineOptimizerFeasibilityDBits word + +/-- Multiplies the inner magnitude term by the ellipsoid dimension. -/ +def machineOptimizerFeasibilityDInnerMagnitudeBits + (word : List Bool) : List Bool := + machineBinaryMulOf machineOptimizerFeasibilityDBits + machineOptimizerFeasibilityInnerMagnitudeBits word + +/-- Computes eight times the ellipsoid dimension in binary. -/ +def machineOptimizerFeasibilityEightDBits (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 8) + machineOptimizerFeasibilityDBits word + +/-- Computes the first denominator-exponent term `12 + 8 * D` in binary. -/ +def machineOptimizerFeasibilityDenomFirstBits + (word : List Bool) : List Bool := + machineBinaryAddOf (machineBinaryConst 12) + machineOptimizerFeasibilityEightDBits word + +/-- Adds the squared dimension to the first denominator-exponent term. -/ +def machineOptimizerFeasibilityDenomSecondBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityDenomFirstBits + machineOptimizerFeasibilityDSquareBits word + +/-- Adds dimension times the inner magnitude to `12 + 8 * D + D^2` for the denominator exponent. -/ +def machineOptimizerFeasibilityDenominatorExponentBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityDenomSecondBits + machineOptimizerFeasibilityDInnerMagnitudeBits word + +/-- Adds the first magnitude term and denominator exponent to form the rounding-precision base. -/ +def machineOptimizerFeasibilityPrecisionBaseBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityFirstBits + machineOptimizerFeasibilityDenominatorExponentBits word + +/-- Adds two to the rounding-precision base. -/ +def machineOptimizerFeasibilityRoundingPrecisionBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityPrecisionBaseBits + (machineBinaryConst 2) word + +/-- Concatenates the iteration, dimension, initial-magnitude-length, and outer-radius-length +rulers to seed the rounding guard. -/ +def machineOptimizerFeasibilityRoundingGuardSource + (word : List Bool) : List Bool := + machineOptimizerFeasibilityBudgetUnary word ++ + (machineOptimizerFeasibilityEllipsoidDimensionUnary word ++ + (machineOptimizerFeasibilityInitialMagnitudeLengthRuler word ++ + machineOptimizerFeasibilityOuterRadiusLengthRuler word)) + +/-- Applies the binary-width construction twice to the rounding-guard source. -/ +def machineOptimizerFeasibilityRoundingGuard + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 + (machineOptimizerFeasibilityRoundingGuardSource word) + +/-- Converts rounding precision from binary to unary under the computed guard. -/ +def machineOptimizerFeasibilityRoundingPrecisionUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerFeasibilityRoundingGuard word) + (machineOptimizerFeasibilityRoundingPrecisionBits word)) + +/-! ## Polynomial-time closure -/ + +theorem machineOptimizerFeasibilityInitialMagnitudeRawCode_mem_FP : + machineOptimizerFeasibilityInitialMagnitudeRawCode ∈ FP := by + have hproduct := machineCompose_mem_FP + (machinePair_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionRawCode_mem_FP + machineOptimizerFeasibilityOuterRadiusRawCode_mem_FP) + machineRawRatMulCode_mem_FP + simpa only [machineOptimizerFeasibilityInitialMagnitudeRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawOptimizerTwo)) hproduct) + machineRawRatAddCode_mem_FP + +theorem machineOptimizerFeasibilityInitialMagnitudeEntryCode_mem_FP : + machineOptimizerFeasibilityInitialMagnitudeEntryCode ∈ FP := by + simpa only [machineOptimizerFeasibilityInitialMagnitudeEntryCode] using! + machineCompose_mem_FP + machineOptimizerFeasibilityInitialMagnitudeRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineOptimizerFeasibilityInitialMagnitudeLengthRuler_mem_FP : + machineOptimizerFeasibilityInitialMagnitudeLengthRuler ∈ FP := by + simpa only [machineOptimizerFeasibilityInitialMagnitudeLengthRuler] using! + machineCompose_mem_FP + machineOptimizerFeasibilityInitialMagnitudeEntryCode_mem_FP + machineOptimizerEntryLengthRuler_mem_FP + +theorem machineOptimizerFeasibilityKBits_mem_FP : + machineOptimizerFeasibilityKBits ∈ FP := by + simpa only [machineOptimizerFeasibilityKBits] using! + machineCompose_mem_FP + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineOptimizerFeasibilityLBits_mem_FP : + machineOptimizerFeasibilityLBits ∈ FP := + machineBinaryMulOf_mem_FP + machineOptimizerFeasibilityOuterLengthBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP + +theorem machineOptimizerFeasibilityTwoTBits_mem_FP : + machineOptimizerFeasibilityTwoTBits ∈ FP := + machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityBudgetBits_mem_FP + +theorem machineOptimizerFeasibilityFirstBaseBits_mem_FP : + machineOptimizerFeasibilityFirstBaseBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityLBits_mem_FP + machineOptimizerFeasibilityTwoTBits_mem_FP + +theorem machineOptimizerFeasibilityFirstBits_mem_FP : + machineOptimizerFeasibilityFirstBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityFirstBaseBits_mem_FP + (machineBinaryConst_mem_FP 1) + +theorem machineOptimizerFeasibilityThreeDBits_mem_FP : + machineOptimizerFeasibilityThreeDBits ∈ FP := + machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 3) + machineOptimizerFeasibilityDBits_mem_FP + +theorem machineOptimizerFeasibilitySixPlusThreeDBits_mem_FP : + machineOptimizerFeasibilitySixPlusThreeDBits ∈ FP := + machineBinaryAddOf_mem_FP (machineBinaryConst_mem_FP 6) + machineOptimizerFeasibilityThreeDBits_mem_FP + +theorem machineOptimizerFeasibilityTTimesGrowthBits_mem_FP : + machineOptimizerFeasibilityTTimesGrowthBits ∈ FP := + machineBinaryMulOf_mem_FP machineOptimizerFeasibilityBudgetBits_mem_FP + machineOptimizerFeasibilitySixPlusThreeDBits_mem_FP + +theorem machineOptimizerFeasibilityKPlusGrowthBits_mem_FP : + machineOptimizerFeasibilityKPlusGrowthBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityKBits_mem_FP + machineOptimizerFeasibilityTTimesGrowthBits_mem_FP + +theorem machineOptimizerFeasibilityKPlusGrowthPlusThreeBits_mem_FP : + machineOptimizerFeasibilityKPlusGrowthPlusThreeBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityKPlusGrowthBits_mem_FP + (machineBinaryConst_mem_FP 3) + +theorem machineOptimizerFeasibilityInnerMagnitudeBits_mem_FP : + machineOptimizerFeasibilityInnerMagnitudeBits ∈ FP := + machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityKPlusGrowthPlusThreeBits_mem_FP + machineOptimizerFeasibilityDBits_mem_FP + +theorem machineOptimizerFeasibilityDInnerMagnitudeBits_mem_FP : + machineOptimizerFeasibilityDInnerMagnitudeBits ∈ FP := + machineBinaryMulOf_mem_FP machineOptimizerFeasibilityDBits_mem_FP + machineOptimizerFeasibilityInnerMagnitudeBits_mem_FP + +theorem machineOptimizerFeasibilityEightDBits_mem_FP : + machineOptimizerFeasibilityEightDBits ∈ FP := + machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 8) + machineOptimizerFeasibilityDBits_mem_FP + +theorem machineOptimizerFeasibilityDenomFirstBits_mem_FP : + machineOptimizerFeasibilityDenomFirstBits ∈ FP := + machineBinaryAddOf_mem_FP (machineBinaryConst_mem_FP 12) + machineOptimizerFeasibilityEightDBits_mem_FP + +theorem machineOptimizerFeasibilityDenomSecondBits_mem_FP : + machineOptimizerFeasibilityDenomSecondBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityDenomFirstBits_mem_FP + machineOptimizerFeasibilityDSquareBits_mem_FP + +theorem machineOptimizerFeasibilityDenominatorExponentBits_mem_FP : + machineOptimizerFeasibilityDenominatorExponentBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityDenomSecondBits_mem_FP + machineOptimizerFeasibilityDInnerMagnitudeBits_mem_FP + +theorem machineOptimizerFeasibilityPrecisionBaseBits_mem_FP : + machineOptimizerFeasibilityPrecisionBaseBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityFirstBits_mem_FP + machineOptimizerFeasibilityDenominatorExponentBits_mem_FP + +theorem machineOptimizerFeasibilityRoundingPrecisionBits_mem_FP : + machineOptimizerFeasibilityRoundingPrecisionBits ∈ FP := + machineBinaryAddOf_mem_FP machineOptimizerFeasibilityPrecisionBaseBits_mem_FP + (machineBinaryConst_mem_FP 2) + +theorem machineOptimizerFeasibilityRoundingGuardSource_mem_FP : + machineOptimizerFeasibilityRoundingGuardSource ∈ FP := by + simpa only [machineOptimizerFeasibilityRoundingGuardSource] using! + machineAppend_mem_FP machineOptimizerFeasibilityBudgetUnary_mem_FP + (machineAppend_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionUnary_mem_FP + (machineAppend_mem_FP + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_mem_FP + machineOptimizerFeasibilityOuterRadiusLengthRuler_mem_FP)) + +theorem machineOptimizerFeasibilityRoundingGuard_mem_FP : + machineOptimizerFeasibilityRoundingGuard ∈ FP := by + simpa only [machineOptimizerFeasibilityRoundingGuard] using! + machineCompose_mem_FP + machineOptimizerFeasibilityRoundingGuardSource_mem_FP + (machineIteratedBinaryWidth_mem_FP 2) + +theorem machineOptimizerFeasibilityRoundingPrecisionUnary_mem_FP : + machineOptimizerFeasibilityRoundingPrecisionUnary ∈ FP := by + simpa only [machineOptimizerFeasibilityRoundingPrecisionUnary] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityRoundingGuard_mem_FP + machineOptimizerFeasibilityRoundingPrecisionBits_mem_FP) + machineBoundedUnary_mem_FP + +/-! ## Exact semantics -/ + +@[simp] theorem machineOptimizerFeasibilityInitialMagnitudeRawCode_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInitialMagnitudeRawCode + (optimizerFeasibilityCallCode A upper) = + rawRatBinaryCode + (rawOptimizerFeasibilityInitialMagnitude ((n - 1) ^ 2 + 1) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper)) := by + rw [machineOptimizerFeasibilityInitialMagnitudeRawCode, + machineOptimizerFeasibilityEllipsoidDimensionRawCode_encode, + machineOptimizerFeasibilityOuterRadiusRawCode_encode hn, + machineRawRatMulCode_encode, machineRawRatAddCode_encode] + rfl + +@[simp] theorem rawOptimizerFeasibilityInitialMagnitude_value + (d : β„•) (R : RawRat) : + (rawOptimizerFeasibilityInitialMagnitude d R).value = + explicitBallInitialMagnitudeBound d R.value := by + simp [rawOptimizerFeasibilityInitialMagnitude, + explicitBallInitialMagnitudeBound, rawOptimizerTwo] + +@[simp] theorem machineOptimizerFeasibilityInitialMagnitudeLengthRuler_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityInitialMagnitudeLengthRuler + (optimizerFeasibilityCallCode A upper) = + List.replicate + (explicitBallInitialMagnitudeExponent ((n - 1) ^ 2 + 1) + ((rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value)) true := by + rw [machineOptimizerFeasibilityInitialMagnitudeLengthRuler, + machineOptimizerFeasibilityInitialMagnitudeEntryCode, + machineOptimizerFeasibilityInitialMagnitudeRawCode_encode hn, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + machineOptimizerEntryLengthRuler_encode] + rw [rawOptimizerFeasibilityInitialMagnitude_value] + rfl + +/-- The explicit feasibility rounding precision, combining radius length, iteration count, +dimension, and initial magnitude length. -/ +def optimizerFeasibilityRoundingPrecision + (d LR K T : β„•) : β„• := + (LR * d + 2 * T + 1) + + (12 + 8 * d + d ^ 2 + + d * (K + T * (6 + 3 * d) + 3 + d)) + 2 + +theorem optimizerFeasibilityRoundingPrecision_eq_explicit + (d T : β„•) (R : β„š) : + optimizerFeasibilityRoundingPrecision d (encodedBitLength β„š R) + (explicitBallInitialMagnitudeExponent d R) T = + explicitBallFeasibilityPrecision d T R := by + rw [optimizerFeasibilityRoundingPrecision, + explicitBallFeasibilityPrecision, explicitBallInitialDetExponent, + roundedEllipsoidPrecisionSchedule, + roundedEllipsoidNextPrecisionBound, + roundedEllipsoidDenominatorExponent] + +@[simp] theorem machineOptimizerFeasibilityRoundingPrecisionBits_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityRoundingPrecisionBits + (optimizerFeasibilityCallCode A upper) = + (explicitBallFeasibilityPrecision ((n - 1) ^ 2 + 1) + (betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value).bits := by + let word := optimizerFeasibilityCallCode A upper + let d := (n - 1) ^ 2 + 1 + let R := (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + let LR := encodedBitLength β„š R + let K := explicitBallInitialMagnitudeExponent d R + let T := 32 * d ^ 3 * rationalBallDyadicExponent d R + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + have hd : machineOptimizerFeasibilityDBits word = d.bits := by + simpa only [machineOptimizerFeasibilityDBits, word, d] using! + machineOptimizerFeasibilityEllipsoidDimensionBits_encode A upper + have hLR : machineOptimizerFeasibilityOuterLengthBits word = LR.bits := by + have hRuler : machineOptimizerFeasibilityOuterRadiusLengthRuler word = + List.replicate LR true := by + simpa only [word, LR, R] using! + machineOptimizerFeasibilityOuterRadiusLengthRuler_encode hn A upper + rw [machineOptimizerFeasibilityOuterLengthBits, hRuler, + machineLengthBits_encode, List.length_replicate] + have hK : machineOptimizerFeasibilityKBits word = K.bits := by + have hRuler : + machineOptimizerFeasibilityInitialMagnitudeLengthRuler word = + List.replicate K true := by + simpa only [word, K, d, R] using! + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_encode hn A upper + rw [machineOptimizerFeasibilityKBits, hRuler, + machineLengthBits_encode, List.length_replicate] + have hT : machineOptimizerFeasibilityBudgetBits word = T.bits := by + simpa only [word, T, d, R] using! + machineOptimizerFeasibilityBudgetBits_encode hn A upper + have hL : machineOptimizerFeasibilityLBits word = (LR * d).bits := + machineBinaryMulOf_natBits _ _ _ _ _ hLR hd + have h2T : machineOptimizerFeasibilityTwoTBits word = (2 * T).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hT + have hfirstBase : machineOptimizerFeasibilityFirstBaseBits word = + (LR * d + 2 * T).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hL h2T + have hfirst : machineOptimizerFeasibilityFirstBits word = + (LR * d + 2 * T + 1).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hfirstBase rfl + have h3d : machineOptimizerFeasibilityThreeDBits word = (3 * d).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hd + have hgrowth : machineOptimizerFeasibilitySixPlusThreeDBits word = + (6 + 3 * d).bits := + machineBinaryAddOf_natBits _ _ _ _ _ rfl h3d + have hTgrowth : machineOptimizerFeasibilityTTimesGrowthBits word = + (T * (6 + 3 * d)).bits := + machineBinaryMulOf_natBits _ _ _ _ _ hT hgrowth + have hKgrowth : machineOptimizerFeasibilityKPlusGrowthBits word = + (K + T * (6 + 3 * d)).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hK hTgrowth + have hKgrowth3 : + machineOptimizerFeasibilityKPlusGrowthPlusThreeBits word = + (K + T * (6 + 3 * d) + 3).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hKgrowth rfl + have hinner : machineOptimizerFeasibilityInnerMagnitudeBits word = + (K + T * (6 + 3 * d) + 3 + d).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hKgrowth3 hd + have hdinner : machineOptimizerFeasibilityDInnerMagnitudeBits word = + (d * (K + T * (6 + 3 * d) + 3 + d)).bits := + machineBinaryMulOf_natBits _ _ _ _ _ hd hinner + have h8d : machineOptimizerFeasibilityEightDBits word = (8 * d).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hd + have hden1 : machineOptimizerFeasibilityDenomFirstBits word = + (12 + 8 * d).bits := + machineBinaryAddOf_natBits _ _ _ _ _ rfl h8d + have hd2 : machineOptimizerFeasibilityDSquareBits word = (d ^ 2).bits := by + rw [machineOptimizerFeasibilityDSquareBits, hd, + machineBinaryMulBits_pair_natBits] + simp only [pow_two] + have hden2 : machineOptimizerFeasibilityDenomSecondBits word = + (12 + 8 * d + d ^ 2).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hden1 hd2 + have hden : machineOptimizerFeasibilityDenominatorExponentBits word = + (12 + 8 * d + d ^ 2 + + d * (K + T * (6 + 3 * d) + 3 + d)).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hden2 hdinner + have hbase : machineOptimizerFeasibilityPrecisionBaseBits word = + ((LR * d + 2 * T + 1) + + (12 + 8 * d + d ^ 2 + + d * (K + T * (6 + 3 * d) + 3 + d))).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hfirst hden + have hp : machineOptimizerFeasibilityRoundingPrecisionBits word = + (optimizerFeasibilityRoundingPrecision d LR K T).bits := by + rw [machineOptimizerFeasibilityRoundingPrecisionBits] + exact machineBinaryAddOf_natBits _ _ _ _ _ hbase rfl + have hRthreshold : + R = betheEpigraphOuterRadius (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + dsimp [R] + rw [rawOptimizerFeasibilityOuterRadius_value, + betheEpigraphOuterRadius] + push_cast + rw [pow_two] + have hTthreshold : + T = betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + dsimp [T, d] + rw [betheThresholdFeasibilityBudget, hRthreshold, pow_two] + rw [hp, optimizerFeasibilityRoundingPrecision_eq_explicit, hTthreshold] + +theorem optimizerFeasibilityRoundingPrecision_le_guardPolynomial + (d LR K T : β„•) : + optimizerFeasibilityRoundingPrecision d LR K T ≀ + certificateExpGuardWidth 2 (T + d + K + LR) := by + let Q := T + d + K + LR + have hd : d ≀ Q := by omega + have hLR : LR ≀ Q := by omega + have hK : K ≀ Q := by omega + have hT : T ≀ Q := by omega + have hLRd : LR * d ≀ Q ^ 2 := by + simpa only [pow_two] using! Nat.mul_le_mul hLR hd + have hd2 : d ^ 2 ≀ Q ^ 2 := Nat.pow_le_pow_left hd 2 + have hdK : d * K ≀ Q ^ 2 := by + simpa only [pow_two] using! Nat.mul_le_mul hd hK + have hdT : d * T ≀ Q ^ 2 := by + simpa only [pow_two] using! Nat.mul_le_mul hd hT + have hd2T : d ^ 2 * T ≀ Q ^ 3 := by + simpa only [pow_two, pow_succ, pow_zero, one_mul] using! + Nat.mul_le_mul (Nat.mul_le_mul hd hd) hT + have hcoarse : optimizerFeasibilityRoundingPrecision d LR K T ≀ + 3 * Q ^ 3 + 10 * Q ^ 2 + 13 * Q + 15 := by + rw [optimizerFeasibilityRoundingPrecision] + nlinarith + have hcubic : + 3 * Q ^ 3 + 10 * Q ^ 2 + 13 * Q + 15 ≀ + 8 * (Q + 4) ^ 3 := by nlinarith + have h8 : 8 ≀ Q + 16 := by omega + have hshift : (Q + 4) ^ 3 ≀ (Q + 16) ^ 3 := + Nat.pow_le_pow_left (by omega) 3 + calc + optimizerFeasibilityRoundingPrecision d LR K T ≀ + 3 * Q ^ 3 + 10 * Q ^ 2 + 13 * Q + 15 := hcoarse + _ ≀ 8 * (Q + 4) ^ 3 := hcubic + _ ≀ (Q + 16) * (Q + 16) ^ 3 := Nat.mul_le_mul h8 hshift + _ = (Q + 16) ^ 4 := by ring + _ ≀ certificateExpGuardWidth 2 Q := by + simpa using! certificateExpGuardWidth_pow_lower 1 Q + +@[simp] theorem machineOptimizerFeasibilityRoundingGuardSource_length_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + (machineOptimizerFeasibilityRoundingGuardSource + (optimizerFeasibilityCallCode A upper)).length = + betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + + ((n - 1) ^ 2 + 1) + + explicitBallInitialMagnitudeExponent ((n - 1) ^ 2 + 1) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + + encodedBitLength β„š + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value := by + have hn1 : 1 ≀ n := by omega + have hRthreshold : + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value = + betheEpigraphOuterRadius (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + rw [rawOptimizerFeasibilityOuterRadius_value, + betheEpigraphOuterRadius] + push_cast + rw [pow_two] + rw [machineOptimizerFeasibilityRoundingGuardSource, + machineOptimizerFeasibilityBudgetUnary_encode hn, + machineOptimizerFeasibilityEllipsoidDimensionUnary_encode hn, + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_encode hn1, + machineOptimizerFeasibilityOuterRadiusLengthRuler_encode hn1] + simp only [List.length_append, List.length_replicate] + rw [betheThresholdFeasibilityBudget, hRthreshold, pow_two] + omega + +@[simp] theorem machineOptimizerFeasibilityRoundingPrecisionUnary_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityRoundingPrecisionUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate + (explicitBallFeasibilityPrecision ((n - 1) ^ 2 + 1) + (betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) true := by + let d := (n - 1) ^ 2 + 1 + let R := (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + let LR := encodedBitLength β„š R + let K := explicitBallInitialMagnitudeExponent d R + let T := betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + rw [machineOptimizerFeasibilityRoundingPrecisionUnary, + machineOptimizerFeasibilityRoundingPrecisionBits_encode (by omega)] + apply machineBoundedUnary_encode_of_le + rw [machineOptimizerFeasibilityRoundingGuard, + machineIteratedBinaryWidth_length, + machineOptimizerFeasibilityRoundingGuardSource_length_encode hn] + rw [← optimizerFeasibilityRoundingPrecision_eq_explicit d T R] + simpa only [d, R, LR, K, T] using! + optimizerFeasibilityRoundingPrecision_le_guardPolynomial d LR K T + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerStateBound.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerStateBound.lean new file mode 100644 index 0000000000..2b469af201 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOptimizerStateBound.lean @@ -0,0 +1,513 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilityFit +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerRoundingSchedule + +/-! +# Finite-word state ruler for one optimizer feasibility call + +The feasibility loop truncates every updated ellipsoid to a stored unary +ruler in order to remain polynomial-time on malformed words. This file +computes the proved ordinary-binary state bound from the same finite-word +dimension, budget, magnitude, and precision schedules used by the call. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Adds `10 + 4 * D` to the rounding precision to obtain the state denominator bound in binary. -/ +def machineOptimizerFeasibilityStateDenominatorBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityRoundingPrecisionBits + (machineBinaryAddOf (machineBinaryConst 10) + (machineBinaryMulOf (machineBinaryConst 4) + machineOptimizerFeasibilityDBits)) word + +/-- Doubles the initial length plus accumulated magnitude growth for the state-entry bound. -/ +def machineOptimizerFeasibilityStateTwiceMagnitudeBits + (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityKPlusGrowthBits word + +/-- Quadruples the state denominator bound in binary. -/ +def machineOptimizerFeasibilityStateFourDenominatorBits + (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 4) + machineOptimizerFeasibilityStateDenominatorBits word + +/-- Adds eight to the doubled magnitude bound for the first state-entry term. -/ +def machineOptimizerFeasibilityStateEntryFirstBits + (word : List Bool) : List Bool := + machineBinaryAddOf (machineBinaryConst 8) + machineOptimizerFeasibilityStateTwiceMagnitudeBits word + +/-- Adds four times the denominator bound to the first state-entry term. -/ +def machineOptimizerFeasibilityStateEntryBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityStateEntryFirstBits + machineOptimizerFeasibilityStateFourDenominatorBits word + +/-- Doubles the state-entry bound and adds two for one encoded list entry. -/ +def machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits + (word : List Bool) : List Bool := + machineBinaryAddOf + (machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateEntryBits) + (machineBinaryConst 2) word + +/-- Multiplies the encoded-entry bound by the ellipsoid dimension to bound a vector. -/ +def machineOptimizerFeasibilityStateVectorBits + (word : List Bool) : List Bool := + machineBinaryMulOf machineOptimizerFeasibilityDBits + machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits word + +/-- Doubles the vector bound and adds two for one encoded matrix row. -/ +def machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits + (word : List Bool) : List Bool := + machineBinaryAddOf + (machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateVectorBits) + (machineBinaryConst 2) word + +/-- Multiplies the encoded-row bound by the ellipsoid dimension to bound a matrix. -/ +def machineOptimizerFeasibilityStateMatrixBits + (word : List Bool) : List Bool := + machineBinaryMulOf machineOptimizerFeasibilityDBits + machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits word + +/-- Computes the outer dimension-encoding contribution `2 * (D + 1)`. -/ +def machineOptimizerFeasibilityStateDimensionTermBits + (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 2) + (machineBinaryAddOf machineOptimizerFeasibilityDBits + (machineBinaryConst 1)) word + +/-- Adds twice the vector bound and twice the matrix bound for the state inner payload. -/ +def machineOptimizerFeasibilityStateInnerFirstBits + (word : List Bool) : List Bool := + machineBinaryAddOf + (machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateVectorBits) + (machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateMatrixBits) word + +/-- Adds two to the combined vector-and-matrix payload bound. -/ +def machineOptimizerFeasibilityStateInnerBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityStateInnerFirstBits + (machineBinaryConst 2) word + +/-- Doubles the inner payload bound for the outer state encoding. -/ +def machineOptimizerFeasibilityStateTwiceInnerBits + (word : List Bool) : List Bool := + machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateInnerBits word + +/-- Adds the dimension contribution to the doubled inner payload bound. -/ +def machineOptimizerFeasibilityStateBoundFirstBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityStateDimensionTermBits + machineOptimizerFeasibilityStateTwiceInnerBits word + +/-- Adds the final two-bit overhead to the complete feasibility-state bound. -/ +def machineOptimizerFeasibilityStateBoundBits + (word : List Bool) : List Bool := + machineBinaryAddOf machineOptimizerFeasibilityStateBoundFirstBits + (machineBinaryConst 2) word + +/-- Concatenates dimension, initial-magnitude-length, iteration-budget, and rounding-precision +rulers to seed the state guard. -/ +def machineOptimizerFeasibilityStateGuardSource + (word : List Bool) : List Bool := + machineOptimizerFeasibilityEllipsoidDimensionUnary word ++ + (machineOptimizerFeasibilityInitialMagnitudeLengthRuler word ++ + (machineOptimizerFeasibilityBudgetUnary word ++ + machineOptimizerFeasibilityRoundingPrecisionUnary word)) + +/-- Applies the binary-width construction three times to the feasibility-state guard source. -/ +def machineOptimizerFeasibilityStateGuard + (word : List Bool) : List Bool := + machineIteratedBinaryWidth 3 + (machineOptimizerFeasibilityStateGuardSource word) + +/-- Converts the computed state bound from binary to a unary ruler under its guard. -/ +def machineOptimizerFeasibilityStateBoundUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineOptimizerFeasibilityStateGuard word) + (machineOptimizerFeasibilityStateBoundBits word)) + +/-! ## Polynomial-time closure -/ + +theorem machineOptimizerFeasibilityStateDenominatorBits_mem_FP : + machineOptimizerFeasibilityStateDenominatorBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityRoundingPrecisionBits_mem_FP + (machineBinaryAddOf_mem_FP (machineBinaryConst_mem_FP 10) + (machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 4) + machineOptimizerFeasibilityDBits_mem_FP)) + +theorem machineOptimizerFeasibilityStateTwiceMagnitudeBits_mem_FP : + machineOptimizerFeasibilityStateTwiceMagnitudeBits ∈ FP := by + exact machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityKPlusGrowthBits_mem_FP + +theorem machineOptimizerFeasibilityStateFourDenominatorBits_mem_FP : + machineOptimizerFeasibilityStateFourDenominatorBits ∈ FP := by + exact machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 4) + machineOptimizerFeasibilityStateDenominatorBits_mem_FP + +theorem machineOptimizerFeasibilityStateEntryFirstBits_mem_FP : + machineOptimizerFeasibilityStateEntryFirstBits ∈ FP := by + exact machineBinaryAddOf_mem_FP (machineBinaryConst_mem_FP 8) + machineOptimizerFeasibilityStateTwiceMagnitudeBits_mem_FP + +theorem machineOptimizerFeasibilityStateEntryBits_mem_FP : + machineOptimizerFeasibilityStateEntryBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityStateEntryFirstBits_mem_FP + machineOptimizerFeasibilityStateFourDenominatorBits_mem_FP + +theorem machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits_mem_FP : + machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + (machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityStateEntryBits_mem_FP) + (machineBinaryConst_mem_FP 2) + +theorem machineOptimizerFeasibilityStateVectorBits_mem_FP : + machineOptimizerFeasibilityStateVectorBits ∈ FP := by + exact machineBinaryMulOf_mem_FP machineOptimizerFeasibilityDBits_mem_FP + machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits_mem_FP + +theorem machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits_mem_FP : + machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + (machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityStateVectorBits_mem_FP) + (machineBinaryConst_mem_FP 2) + +theorem machineOptimizerFeasibilityStateMatrixBits_mem_FP : + machineOptimizerFeasibilityStateMatrixBits ∈ FP := by + exact machineBinaryMulOf_mem_FP machineOptimizerFeasibilityDBits_mem_FP + machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits_mem_FP + +theorem machineOptimizerFeasibilityStateDimensionTermBits_mem_FP : + machineOptimizerFeasibilityStateDimensionTermBits ∈ FP := by + exact machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + (machineBinaryAddOf_mem_FP machineOptimizerFeasibilityDBits_mem_FP + (machineBinaryConst_mem_FP 1)) + +theorem machineOptimizerFeasibilityStateInnerFirstBits_mem_FP : + machineOptimizerFeasibilityStateInnerFirstBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + (machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityStateVectorBits_mem_FP) + (machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityStateMatrixBits_mem_FP) + +theorem machineOptimizerFeasibilityStateInnerBits_mem_FP : + machineOptimizerFeasibilityStateInnerBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityStateInnerFirstBits_mem_FP + (machineBinaryConst_mem_FP 2) + +theorem machineOptimizerFeasibilityStateTwiceInnerBits_mem_FP : + machineOptimizerFeasibilityStateTwiceInnerBits ∈ FP := by + exact machineBinaryMulOf_mem_FP (machineBinaryConst_mem_FP 2) + machineOptimizerFeasibilityStateInnerBits_mem_FP + +theorem machineOptimizerFeasibilityStateBoundFirstBits_mem_FP : + machineOptimizerFeasibilityStateBoundFirstBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityStateDimensionTermBits_mem_FP + machineOptimizerFeasibilityStateTwiceInnerBits_mem_FP + +theorem machineOptimizerFeasibilityStateBoundBits_mem_FP : + machineOptimizerFeasibilityStateBoundBits ∈ FP := by + exact machineBinaryAddOf_mem_FP + machineOptimizerFeasibilityStateBoundFirstBits_mem_FP + (machineBinaryConst_mem_FP 2) + +theorem machineOptimizerFeasibilityStateGuardSource_mem_FP : + machineOptimizerFeasibilityStateGuardSource ∈ FP := by + exact machineAppend_mem_FP + machineOptimizerFeasibilityEllipsoidDimensionUnary_mem_FP + (machineAppend_mem_FP + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_mem_FP + (machineAppend_mem_FP machineOptimizerFeasibilityBudgetUnary_mem_FP + machineOptimizerFeasibilityRoundingPrecisionUnary_mem_FP)) + +theorem machineOptimizerFeasibilityStateGuard_mem_FP : + machineOptimizerFeasibilityStateGuard ∈ FP := by + simpa only [machineOptimizerFeasibilityStateGuard] using! + machineCompose_mem_FP + machineOptimizerFeasibilityStateGuardSource_mem_FP + (machineIteratedBinaryWidth_mem_FP 3) + +theorem machineOptimizerFeasibilityStateBoundUnary_mem_FP : + machineOptimizerFeasibilityStateBoundUnary ∈ FP := by + simpa only [machineOptimizerFeasibilityStateBoundUnary] using! + machineCompose_mem_FP + (machinePair_mem_FP machineOptimizerFeasibilityStateGuard_mem_FP + machineOptimizerFeasibilityStateBoundBits_mem_FP) + machineBoundedUnary_mem_FP + +/-! ## Exact semantics -/ + +theorem machineOptimizerFeasibilityStateBoundBits_encode + {n : β„•} (hn : 1 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityStateBoundBits + (optimizerFeasibilityCallCode A upper) = + (explicitBallFeasibilityStateCodeBound + ((n - 1) ^ 2 + 1) + (betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value).bits := by + let word := optimizerFeasibilityCallCode A upper + let d := (n - 1) ^ 2 + 1 + let T := betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + let R := (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + let K := explicitBallInitialMagnitudeExponent d R + let p := explicitBallFeasibilityPrecision d T R + let KS := K + T * (6 + 3 * d) + let P := p + 10 + 4 * d + let e := rationalEntryMachineCodeBound KS P + let v := rationalVectorMachineCodeBound d KS P + let M := rationalMatrixMachineCodeBound d KS P + have hRthreshold : + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value = + betheEpigraphOuterRadius (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + rw [rawOptimizerFeasibilityOuterRadius_value, + betheEpigraphOuterRadius] + push_cast + rw [pow_two] + have hd : machineOptimizerFeasibilityDBits word = d.bits := by + simpa only [machineOptimizerFeasibilityDBits, word, d] using! + machineOptimizerFeasibilityEllipsoidDimensionBits_encode A upper + have hT : machineOptimizerFeasibilityBudgetBits word = T.bits := by + have h := machineOptimizerFeasibilityBudgetBits_encode hn A upper + rw [hRthreshold] at h + simpa only [word, T, betheThresholdFeasibilityBudget, pow_two] using! h + have hK : machineOptimizerFeasibilityKBits word = K.bits := by + have hruler : + machineOptimizerFeasibilityInitialMagnitudeLengthRuler word = + List.replicate K true := by + simpa only [word, K, d, R] using! + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_encode hn A upper + rw [machineOptimizerFeasibilityKBits, hruler, + machineLengthBits_encode, List.length_replicate] + have hp : machineOptimizerFeasibilityRoundingPrecisionBits word = p.bits := by + simpa only [word, p, d, T, R] using! + machineOptimizerFeasibilityRoundingPrecisionBits_encode hn A upper + have h3d : machineOptimizerFeasibilityThreeDBits word = (3 * d).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hd + have hgrowth : machineOptimizerFeasibilitySixPlusThreeDBits word = + (6 + 3 * d).bits := + machineBinaryAddOf_natBits _ _ _ _ _ rfl h3d + have hTgrowth : machineOptimizerFeasibilityTTimesGrowthBits word = + (T * (6 + 3 * d)).bits := + machineBinaryMulOf_natBits _ _ _ _ _ hT hgrowth + have hKS : machineOptimizerFeasibilityKPlusGrowthBits word = KS.bits := by + simpa only [KS] using! + machineBinaryAddOf_natBits _ _ _ _ _ hK hTgrowth + have h4d : machineBinaryMulOf (machineBinaryConst 4) + machineOptimizerFeasibilityDBits word = (4 * d).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hd + have h10plus4d : machineBinaryAddOf (machineBinaryConst 10) + (machineBinaryMulOf (machineBinaryConst 4) + machineOptimizerFeasibilityDBits) word = (10 + 4 * d).bits := + machineBinaryAddOf_natBits _ _ _ _ _ rfl h4d + have hP : machineOptimizerFeasibilityStateDenominatorBits word = P.bits := by + simpa only [machineOptimizerFeasibilityStateDenominatorBits, P, + Nat.add_assoc] using! + machineBinaryAddOf_natBits _ _ _ _ _ hp h10plus4d + have h2KS : machineOptimizerFeasibilityStateTwiceMagnitudeBits word = + (2 * KS).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hKS + have h4P : machineOptimizerFeasibilityStateFourDenominatorBits word = + (4 * P).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hP + have h8plus2KS : machineOptimizerFeasibilityStateEntryFirstBits word = + (8 + 2 * KS).bits := + machineBinaryAddOf_natBits _ _ _ _ _ rfl h2KS + have he : machineOptimizerFeasibilityStateEntryBits word = e.bits := by + simpa only [e, rationalEntryMachineCodeBound] using! + machineBinaryAddOf_natBits _ _ _ _ _ h8plus2KS h4P + have h2e : machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateEntryBits word = (2 * e).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl he + have h2e2 : machineOptimizerFeasibilityStateTwiceEntryPlusTwoBits word = + (2 * e + 2).bits := + machineBinaryAddOf_natBits _ _ _ _ _ h2e rfl + have hv : machineOptimizerFeasibilityStateVectorBits word = v.bits := by + simpa only [v, rationalVectorMachineCodeBound] using! + machineBinaryMulOf_natBits _ _ _ _ _ hd h2e2 + have h2v : machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateVectorBits word = (2 * v).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hv + have h2v2 : machineOptimizerFeasibilityStateTwiceVectorPlusTwoBits word = + (2 * v + 2).bits := + machineBinaryAddOf_natBits _ _ _ _ _ h2v rfl + have hM : machineOptimizerFeasibilityStateMatrixBits word = M.bits := by + simpa only [M, rationalMatrixMachineCodeBound] using! + machineBinaryMulOf_natBits _ _ _ _ _ hd h2v2 + have hd1 : machineBinaryAddOf machineOptimizerFeasibilityDBits + (machineBinaryConst 1) word = (d + 1).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hd rfl + have hdim : machineOptimizerFeasibilityStateDimensionTermBits word = + (2 * (d + 1)).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hd1 + have h2v' : machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateVectorBits word = (2 * v).bits := h2v + have h2M : machineBinaryMulOf (machineBinaryConst 2) + machineOptimizerFeasibilityStateMatrixBits word = (2 * M).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hM + have hinnerFirst : machineOptimizerFeasibilityStateInnerFirstBits word = + (2 * v + 2 * M).bits := + machineBinaryAddOf_natBits _ _ _ _ _ h2v' h2M + have hinner : machineOptimizerFeasibilityStateInnerBits word = + (2 * v + 2 * M + 2).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hinnerFirst rfl + have htwiceInner : machineOptimizerFeasibilityStateTwiceInnerBits word = + (2 * (2 * v + 2 * M + 2)).bits := + machineBinaryMulOf_natBits _ _ _ _ _ rfl hinner + have hfirst : machineOptimizerFeasibilityStateBoundFirstBits word = + (2 * (d + 1) + 2 * (2 * v + 2 * M + 2)).bits := + machineBinaryAddOf_natBits _ _ _ _ _ hdim htwiceInner + rw [machineOptimizerFeasibilityStateBoundBits] + rw [machineBinaryAddOf_natBits _ _ word _ _ hfirst rfl] + simp only [explicitBallFeasibilityStateCodeBound, + scheduledFeasibilityStateCodeBound, rationalEllipsoidMachineCodeBound, + rationalVectorMachineCodeBound, rationalMatrixMachineCodeBound, + rationalEntryMachineCodeBound, explicitBallFeasibilityPrecision, + d, T, R, K, p, KS, P, e, v, M] + +theorem optimizerFeasibilityStateBound_le_guardPolynomial + (d K T p : β„•) : + rationalEllipsoidMachineCodeBound d + (K + T * (6 + 3 * d)) (p + 10 + 4 * d) ≀ + certificateExpGuardWidth 3 (d + K + T + p) := by + let Q := d + K + T + p + have hd : d ≀ Q := by omega + have hK : K ≀ Q := by omega + have hT : T ≀ Q := by omega + have hp : p ≀ Q := by omega + have hcoarse : + rationalEllipsoidMachineCodeBound d + (K + T * (6 + 3 * d)) (p + 10 + 4 * d) ≀ + 256 * (Q + 1) ^ 4 + 256 := by + simp only [rationalEllipsoidMachineCodeBound, + rationalMatrixMachineCodeBound, rationalVectorMachineCodeBound, + rationalEntryMachineCodeBound] + nlinarith [Nat.mul_le_mul hd hd, Nat.mul_le_mul hT hd, + Nat.mul_le_mul hK hd, Nat.mul_le_mul hp hd, + Nat.pow_le_pow_left (Nat.le_add_right Q 1) 2, + Nat.pow_le_pow_left (Nat.le_add_right Q 1) 3, + Nat.pow_le_pow_left (Nat.le_add_right Q 1) 4] + have hmain : 256 * (Q + 1) ^ 4 + 256 ≀ (Q + 16) ^ 8 := by + nlinarith [Nat.pow_le_pow_left (by omega : 4 ≀ Q + 16) 4, + Nat.pow_le_pow_left (by omega : Q + 1 ≀ Q + 16) 4] + exact hcoarse.trans <| hmain.trans <| by + simpa only [Q] using! certificateExpGuardWidth_pow_lower 2 Q + +@[simp] theorem machineOptimizerFeasibilityStateGuardSource_length_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + (machineOptimizerFeasibilityStateGuardSource + (optimizerFeasibilityCallCode A upper)).length = + ((n - 1) ^ 2 + 1) + + explicitBallInitialMagnitudeExponent ((n - 1) ^ 2 + 1) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + + betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + + explicitBallFeasibilityPrecision ((n - 1) ^ 2 + 1) + (betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value := by + have hRthreshold : + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value = + betheEpigraphOuterRadius (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + rw [rawOptimizerFeasibilityOuterRadius_value, + betheEpigraphOuterRadius] + push_cast + rw [pow_two] + have hbudget : + 32 * (((n - 1) ^ 2 + 1) ^ 3) * + rationalBallDyadicExponent ((n - 1) ^ 2 + 1) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value = + betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value := by + rw [betheThresholdFeasibilityBudget, hRthreshold] + simp only [pow_two] + rw [machineOptimizerFeasibilityStateGuardSource, + machineOptimizerFeasibilityEllipsoidDimensionUnary_encode hn, + machineOptimizerFeasibilityInitialMagnitudeLengthRuler_encode (by omega), + machineOptimizerFeasibilityBudgetUnary_encode hn, + machineOptimizerFeasibilityRoundingPrecisionUnary_encode hn] + simp only [List.length_append, List.length_replicate] + rw [hbudget] + omega + +@[simp] theorem machineOptimizerFeasibilityStateBoundUnary_encode + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) β„š) + (upper : RawRat) : + machineOptimizerFeasibilityStateBoundUnary + (optimizerFeasibilityCallCode A upper) = + List.replicate + (explicitBallFeasibilityStateCodeBound ((n - 1) ^ 2 + 1) + (betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value) + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value) true := by + let d := (n - 1) ^ 2 + 1 + let K := explicitBallInitialMagnitudeExponent d + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + let T := betheThresholdFeasibilityBudget (n - 1) upper.value + (rawExplicitOptimizerInnerRadius n + (rationalMatrixEntryBitBound A)).value + let p := explicitBallFeasibilityPrecision d T + (rawOptimizerFeasibilityOuterRadius n + (rationalMatrixEntryBitBound A) upper).value + rw [machineOptimizerFeasibilityStateBoundUnary, + machineOptimizerFeasibilityStateBoundBits_encode (by omega)] + apply machineBoundedUnary_encode_of_le + rw [machineOptimizerFeasibilityStateGuard, + machineIteratedBinaryWidth_length, + machineOptimizerFeasibilityStateGuardSource_length_encode hn] + simpa only [d, K, T, p, explicitBallFeasibilityStateCodeBound, + scheduledFeasibilityStateCodeBound, explicitBallInitialDetExponent] using! + optimizerFeasibilityStateBound_le_guardPolynomial d K T p + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineOutputEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineOutputEncoding.lean new file mode 100644 index 0000000000..e50fc411b1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineOutputEncoding.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul + +/-! +# Polynomial-time canonical output encodings + +The public rational output is the canonical bit expansion of a natural pairing +of the signed numerator code and positive denominator. This file realizes +that pairing formula from the verified arithmetic primitives, and then proves +the complete rational encoder correct. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Squares the left binary natural-number component of a pair. -/ +def machineNatPairLeftSquare (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machinePairFirst word) (machinePairFirst word)) + +/-- Squares the right binary natural-number component of a pair. -/ +def machineNatPairRightSquare (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machinePairSecond word) (machinePairSecond word)) + +/-- Computes the natural-pairing branch `right^2 + left` in binary. -/ +def machineNatPairLeftBranch (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineNatPairRightSquare word) (machinePairFirst word)) + +/-- Computes the intermediate natural-pairing term `left^2 + left` in binary. -/ +def machineNatPairRightBranchFirst (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineNatPairLeftSquare word) (machinePairFirst word)) + +/-- Computes the natural-pairing branch `left^2 + left + right` in binary. -/ +def machineNatPairRightBranch (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineNatPairRightBranchFirst word) (machinePairSecond word)) + +/-- Canonical bits of Mathlib's monotone natural pairing function. -/ +def machineNatPairBits (word : List Bool) : List Bool := + machineIfHead (machineBinaryNatLtBit word) + (machineNatPairLeftBranch word) (machineNatPairRightBranch word) + +theorem machineNatPairLeftSquare_mem_FP : + machineNatPairLeftSquare ∈ Complexity.FP := by + have hpair : (fun word => pair (machinePairFirst word) + (machinePairFirst word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairFirst_mem_FP machinePairFirst_mem_FP + simpa only [machineNatPairLeftSquare] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineNatPairRightSquare_mem_FP : + machineNatPairRightSquare ∈ Complexity.FP := by + have hpair : (fun word => pair (machinePairSecond word) + (machinePairSecond word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineNatPairRightSquare] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineNatPairLeftBranch_mem_FP : + machineNatPairLeftBranch ∈ Complexity.FP := by + have hpair : (fun word => pair (machineNatPairRightSquare word) + (machinePairFirst word)) ∈ Complexity.FP := + machinePair_mem_FP machineNatPairRightSquare_mem_FP + machinePairFirst_mem_FP + simpa only [machineNatPairLeftBranch] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineNatPairRightBranchFirst_mem_FP : + machineNatPairRightBranchFirst ∈ Complexity.FP := by + have hpair : (fun word => pair (machineNatPairLeftSquare word) + (machinePairFirst word)) ∈ Complexity.FP := + machinePair_mem_FP machineNatPairLeftSquare_mem_FP + machinePairFirst_mem_FP + simpa only [machineNatPairRightBranchFirst] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineNatPairRightBranch_mem_FP : + machineNatPairRightBranch ∈ Complexity.FP := by + have hpair : (fun word => pair (machineNatPairRightBranchFirst word) + (machinePairSecond word)) ∈ Complexity.FP := + machinePair_mem_FP machineNatPairRightBranchFirst_mem_FP + machinePairSecond_mem_FP + simpa only [machineNatPairRightBranch] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineNatPairBits_mem_FP : + machineNatPairBits ∈ Complexity.FP := by + simpa only [machineNatPairBits] using! + machineIfHead_mem_FP machineBinaryNatLtBit_mem_FP + machineNatPairLeftBranch_mem_FP machineNatPairRightBranch_mem_FP + +theorem machineNatPairBits_pair_natBits (a b : β„•) : + machineNatPairBits (pair a.bits b.bits) = (Nat.pair a b).bits := by + simp only [machineNatPairBits, machineBinaryNatLtBit_pair_natBits] + by_cases h : a < b + Β· simp only [h, decide_true, machineIfHead_true, + machineNatPairLeftBranch, machineNatPairRightSquare, + machinePairFirst_pair, machinePairSecond_pair, + machineBinaryMulBits_pair_natBits, + machineBinaryAddBits_pair_natBits] + simp [Nat.pair, h] + Β· simp only [h, decide_false, machineIfHead_false, + machineNatPairRightBranch, machineNatPairRightBranchFirst, + machineNatPairLeftSquare, machinePairFirst_pair, + machinePairSecond_pair, machineBinaryMulBits_pair_natBits, + machineBinaryAddBits_pair_natBits] + simp [Nat.pair, h, Nat.add_assoc] + +/-- Drops the sign bit to expose the integer code's magnitude payload. -/ +def machineIntegerMagnitudeWord (word : List Bool) : List Bool := word.tail + +/-- Doubles the integer payload in binary to obtain its even natural-number code. -/ +def machineIntegerEvenCodeBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineIntegerMagnitudeWord word) + (machineIntegerMagnitudeWord word)) + +/-- Adds one to the doubled integer payload to obtain its odd natural-number code. -/ +def machineIntegerOddCodeBits (word : List Bool) : List Bool := + machineBinaryAddBits (pair (machineIntegerEvenCodeBits word) [true]) + +/-- Convert the sign-and-magnitude `integerBinaryCode` to the natural code +used by the public rational output. -/ +def machineIntegerNatCodeBits (word : List Bool) : List Bool := + machineIfHead word (machineIntegerOddCodeBits word) + (machineIntegerEvenCodeBits word) + +theorem machineIntegerMagnitudeWord_mem_FP : + machineIntegerMagnitudeWord ∈ Complexity.FP := by + simpa only [machineIntegerMagnitudeWord] using! machineTail_mem_FP + +theorem machineIntegerEvenCodeBits_mem_FP : + machineIntegerEvenCodeBits ∈ Complexity.FP := by + have hpair : (fun word => pair (machineIntegerMagnitudeWord word) + (machineIntegerMagnitudeWord word)) ∈ Complexity.FP := + machinePair_mem_FP machineIntegerMagnitudeWord_mem_FP + machineIntegerMagnitudeWord_mem_FP + simpa only [machineIntegerEvenCodeBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineIntegerOddCodeBits_mem_FP : + machineIntegerOddCodeBits ∈ Complexity.FP := by + have hpair : (fun word => pair (machineIntegerEvenCodeBits word) [true]) ∈ + Complexity.FP := + machinePair_mem_FP machineIntegerEvenCodeBits_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineIntegerOddCodeBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineIntegerNatCodeBits_mem_FP : + machineIntegerNatCodeBits ∈ Complexity.FP := by + simpa only [machineIntegerNatCodeBits] using! + machineIfHead_mem_FP id_mem_FP machineIntegerOddCodeBits_mem_FP + machineIntegerEvenCodeBits_mem_FP + +theorem machineIntegerNatCodeBits_encode (z : β„€) : + machineIntegerNatCodeBits (integerBinaryCode z) = + (integerNatCode z).bits := by + cases z with + | ofNat n => + simp [machineIntegerNatCodeBits, integerBinaryCode, + machineIntegerEvenCodeBits, machineIntegerMagnitudeWord, + integerNatCode, machineBinaryAddBits_pair_natBits, + two_mul] + | negSucc n => + simp [machineIntegerNatCodeBits, integerBinaryCode, + machineIntegerOddCodeBits, machineIntegerEvenCodeBits, + machineIntegerMagnitudeWord, integerNatCode, + machineBinaryAddBits_pair_natBits, two_mul] + rw [show ([true] : List Bool) = (1 : β„•).bits by rfl, + machineBinaryAddBits_pair_natBits] + +/-- Complete public rational output encoder, from the entry representation +used inside the matrix input to canonical `rationalBinaryCode`. -/ +def machineRationalBinaryCode (word : List Bool) : List Bool := + machineNatPairBits + (pair + (machineIntegerNatCodeBits + (machineRationalEntryNumeratorWord word)) + (machineRationalEntryDenominatorWord word)) + +theorem machineRationalBinaryCode_mem_FP : + machineRationalBinaryCode ∈ Complexity.FP := by + have hnum : (fun word => machineIntegerNatCodeBits + (machineRationalEntryNumeratorWord word)) ∈ Complexity.FP := + machineCompose_mem_FP machineRationalEntryNumeratorWord_mem_FP + machineIntegerNatCodeBits_mem_FP + have hpair : (fun word => pair + (machineIntegerNatCodeBits + (machineRationalEntryNumeratorWord word)) + (machineRationalEntryDenominatorWord word)) ∈ Complexity.FP := + machinePair_mem_FP hnum machineRationalEntryDenominatorWord_mem_FP + simpa only [machineRationalBinaryCode] using! + machineCompose_mem_FP hpair machineNatPairBits_mem_FP + +theorem machineRationalBinaryCode_encode (q : β„š) : + machineRationalBinaryCode (rationalEntryBinaryCode q) = + rationalBinaryCode q := by + simp only [machineRationalBinaryCode, + machineRationalEntryNumeratorWord_encode, + machineRationalEntryDenominatorWord_encode, + machineIntegerNatCodeBits_encode, + machineNatPairBits_pair_natBits] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachinePerfectMatching.lean b/LeanPool/BeyondBethe/BeyondBethe/MachinePerfectMatching.lean new file mode 100644 index 0000000000..c7acc0f722 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachinePerfectMatching.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateAllSome +public import Mathlib.Tactic + +/-! +# A finite-word perfect-matching decision procedure + +This module composes the complete Kuhn runner with the exact mate-table scan. +The result is an actual polynomial-time function on bitstrings. On the +canonical encoding of a square rational matrix it returns `[true]` exactly +when the positive support contains a perfect matching. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! ## The finite-word program -/ + +/-- Extracts the final matching payload from the completed Kuhn run. -/ +def machineKuhnFinalMate (matrix : List Bool) : List Bool := + machineKuhnDoneMate (machineKuhnControl (machineKuhnFinalState matrix)) + +/-- Pairs the matrix dimension ruler with the final Kuhn matching for the completeness test. -/ +def machineKuhnPerfectMatchingInput (matrix : List Bool) : List Bool := + pair (machineKuhnInitDimension matrix) (machineKuhnFinalMate matrix) + +/-- Tests whether every column of the final Kuhn matching has a present mate. -/ +def machineKuhnPerfectMatchingBit (matrix : List Bool) : List Bool := + machineMateAllSomeBit (machineKuhnPerfectMatchingInput matrix) + +theorem machineKuhnFinalMate_mem_FP : + machineKuhnFinalMate ∈ Complexity.FP := by + have hcontrol := machineCompose_mem_FP machineKuhnFinalState_mem_FP + machineKuhnControl_mem_FP + simpa only [machineKuhnFinalMate] using! + machineCompose_mem_FP hcontrol machineKuhnDoneMate_mem_FP + +theorem machineKuhnPerfectMatchingInput_mem_FP : + machineKuhnPerfectMatchingInput ∈ Complexity.FP := by + exact machinePair_mem_FP machineKuhnInitDimension_mem_FP + machineKuhnFinalMate_mem_FP + +theorem machineKuhnPerfectMatchingBit_mem_FP : + machineKuhnPerfectMatchingBit ∈ Complexity.FP := by + simpa only [machineKuhnPerfectMatchingBit] using! + machineCompose_mem_FP machineKuhnPerfectMatchingInput_mem_FP + machineMateAllSomeBit_mem_FP + +/-! ## The column-totality criterion -/ + +/-- Requires every column to have some matched row. -/ +def AllColumnsMatched {n : β„•} (mate : ColumnMate n) : Prop := + βˆ€ col, βˆƒ row, mate col = some row + +theorem hasPerfectMatching_of_all_columns_matched {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (mate : ColumnMate n) + (hsupport : IsSupportColumnMate A mate) + (hallColumns : AllColumnsMatched mate) : + Matrix.HasPerfectMatching A := by + classical + let rowOfColumn : Fin n β†’ Fin n := + fun col ↦ Classical.choose (hallColumns col) + have rowOfColumn_spec (col : Fin n) : + mate col = some (rowOfColumn col) := + Classical.choose_spec (hallColumns col) + have rowOfColumn_injective : Function.Injective rowOfColumn := by + intro col col' hrows + apply hsupport.injective (rowOfColumn_spec col) + simpa only [hrows] using! rowOfColumn_spec col' + have rowOfColumn_bijective : Function.Bijective rowOfColumn := + (Fintype.bijective_iff_injective_and_card rowOfColumn).2 + ⟨rowOfColumn_injective, rfl⟩ + let matching : Fin n ≃ Fin n := + Equiv.ofBijective rowOfColumn rowOfColumn_bijective + refine ⟨matching, ?_⟩ + intro col + exact hsupport.support (rowOfColumn_spec col) + +theorem all_columns_matched_of_all_rows_matched {n : β„•} + (mate : ColumnMate n) + (hallRows : βˆ€ row, MatchesRow mate row) : + AllColumnsMatched mate := by + classical + let colOfRow : Fin n β†’ Fin n := + fun row ↦ Classical.choose (hallRows row) + have colOfRow_spec (row : Fin n) : mate (colOfRow row) = some row := + Classical.choose_spec (hallRows row) + have colOfRow_injective : Function.Injective colOfRow := by + intro row row' hcols + have hrow := colOfRow_spec row + have hrow' := colOfRow_spec row' + rw [hcols, hrow'] at hrow + exact Option.some.inj hrow.symm + have colOfRow_surjective : Function.Surjective colOfRow := + ((Fintype.bijective_iff_injective_and_card colOfRow).2 + ⟨colOfRow_injective, rfl⟩).2 + intro col + obtain ⟨row, hrow⟩ := colOfRow_surjective col + refine ⟨row, ?_⟩ + simpa only [hrow] using! colOfRow_spec row + +theorem columnMateList_all_isSome_eq_true_iff {n : β„•} + (mate : ColumnMate n) : + (columnMateList mate).all Option.isSome = true ↔ + AllColumnsMatched mate := by + constructor + Β· intro hall col + have hi : col.1 < (columnMateList mate).length := by simp + have hvalue := (List.all_eq_true.mp hall) + (columnMateList mate)[col.1] (List.getElem_mem hi) + rw [columnMateList_getElem] at hvalue + cases hmate : mate col with + | none => simp [hmate] at hvalue + | some row => exact ⟨row, rfl⟩ + Β· intro hall + apply List.all_eq_true.mpr + intro value hvalue + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp hvalue + have hin : i < n := by simpa using! hi + obtain ⟨row, hrow⟩ := hall ⟨i, hin⟩ + rw [columnMateList_getElem, hrow] + rfl + +theorem kuhnColumnMate_all_isSome_eq_true_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + (columnMateList (kuhnColumnMate A)).all Option.isSome = true ↔ + Matrix.HasPerfectMatching A := by + rw [columnMateList_all_isSome_eq_true_iff] + constructor + Β· exact hasPerfectMatching_of_all_columns_matched A (kuhnColumnMate A) + (kuhnColumnMate_support A) + Β· intro hperfect + exact all_columns_matched_of_all_rows_matched (kuhnColumnMate A) + (kuhnColumnMate_all_rows_of_hasPerfectMatching A hperfect) + +/-! ## Exact machine semantics -/ + +@[simp] theorem machineKuhnFinalMate_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnFinalMate (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + mateVectorCode (columnMateList (kuhnColumnMate A)) := by + simp [machineKuhnFinalMate, kuhnControlCode] + +@[simp] theorem machineKuhnPerfectMatchingInput_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnPerfectMatchingInput + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + pair (List.replicate n true) + (mateVectorCode (columnMateList (kuhnColumnMate A))) := by + simp [machineKuhnPerfectMatchingInput] + +@[simp] theorem machineKuhnPerfectMatchingBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnPerfectMatchingBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [(columnMateList (kuhnColumnMate A)).all Option.isSome] := by + rw [machineKuhnPerfectMatchingBit, + machineKuhnPerfectMatchingInput_encode] + simpa only [columnMateList_length] using! + machineMateAllSomeBit_encode (columnMateList (kuhnColumnMate A)) + +theorem machineKuhnPerfectMatchingBit_eq_true_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnPerfectMatchingBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = [true] ↔ + Matrix.HasPerfectMatching A := by + rw [machineKuhnPerfectMatchingBit_encode, List.cons.injEq, + and_iff_left rfl, kuhnColumnMate_all_isSome_eq_true_iff] + +theorem machineKuhnPerfectMatchingBit_eq_false_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineKuhnPerfectMatchingBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = [false] ↔ + Β¬Matrix.HasPerfectMatching A := by + rw [machineKuhnPerfectMatchingBit_encode, List.cons.injEq, + and_iff_left rfl, ← kuhnColumnMate_all_isSome_eq_true_iff] + exact Bool.eq_false_iff + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachinePositiveAlgorithm.lean b/LeanPool/BeyondBethe/BeyondBethe/MachinePositiveAlgorithm.lean new file mode 100644 index 0000000000..d6574683d7 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachinePositiveAlgorithm.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineCompletedAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitPositiveRoutine + +/-! +# Finite-word wrapper for the positive-matrix routine + +This module removes normalization, scale restoration, and the exact small +dimensions from the remaining positive-routine boundary. The only parameter +is a raw-output machine for the normalized optimizer-plus-certificate value. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Returns zero in dimensions zero and one; otherwise evaluates the directed certificate at the +explicit optimizer matrix and its row and column potentials. -/ +def explicitNormalizedCertificateAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + | 0, _ => 0 + | 1, _ => 0 + | m + 2, B => + explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) B) + (explicitBetheOptimizerRowPotential (m := m + 1) B) + (explicitBetheOptimizerColumnPotential (m := m + 1) B) + +/-- Conditional realization of the normalized optimizer-certificate value on +the positive, entrywise-at-most-one matrices supplied by normalization. -/ +def NormalizedCertificateStringRealizesOnPositive + (F : List Bool β†’ List Bool) : Prop := + βˆ€ (m : β„•) (B : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š), + (βˆ€ i j, 0 < B i j) β†’ (βˆ€ i j, B i j ≀ 1) β†’ + F (rationalMatrixBinaryEncoding.encode ⟨m + 2, B⟩) = + rawRatBinaryCode + (rawRatOfRat (explicitNormalizedCertificateAlgorithm (m + 2) B)) + +/-- Returns raw one for a zero-dimensional positive-matrix input and its first entry otherwise. -/ +def machinePositiveSmallRawCode (word : List Bool) : List Bool := + machineIfHead (machineMatrixDimensionZeroBit word) + (rawRatBinaryCode RawRat.one) + (machineMatrixFirstEntryCode word) + +/-- Normalizes the positive input matrix's entries for the certificate machine. -/ +def machinePositiveNormalizedMatrixCode (word : List Bool) : List Bool := + machineMatrixNormalizeEntries word + +/-- Runs the supplied certificate machine on the normalized positive matrix. -/ +def machinePositiveCertificateRawCode + (certificateMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + certificateMachine (machinePositiveNormalizedMatrixCode word) + +/-- Multiplies the normalized-matrix certificate by the matrix-normalization scale raised to the +dimension. -/ +def machinePositiveLargeProductRawCode + (certificateMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineMatrixNormalizationScalePowerRawCode word) + (machinePositiveCertificateRawCode certificateMachine word)) + +/-- Normalizes the scaled certificate product into a rational entry code. -/ +def machinePositiveLargeRawCode + (certificateMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machinePositiveLargeProductRawCode certificateMachine word) + +/-- Uses the direct small-dimension branch below dimension two and the scaled +normalized-certificate branch otherwise. -/ +def machinePositiveAlgorithmRawCode + (certificateMachine : List Bool β†’ List Bool) + (word : List Bool) : List Bool := + machineIfHead (machineCompletedDimensionLtTwoBit word) + (machinePositiveSmallRawCode word) + (machinePositiveLargeRawCode certificateMachine word) + +theorem machinePositiveSmallRawCode_mem_FP : + machinePositiveSmallRawCode ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineMatrixDimensionZeroBit_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineMatrixFirstEntryCode_mem_FP + +theorem machinePositiveNormalizedMatrixCode_mem_FP : + machinePositiveNormalizedMatrixCode ∈ Complexity.FP := + machineMatrixNormalizeEntries_mem_FP + +theorem machinePositiveCertificateRawCode_mem_FP + {certificateMachine : List Bool β†’ List Bool} + (hcertificate : certificateMachine ∈ Complexity.FP) : + machinePositiveCertificateRawCode certificateMachine ∈ Complexity.FP := by + simpa only [machinePositiveCertificateRawCode] using! + machineCompose_mem_FP machinePositiveNormalizedMatrixCode_mem_FP + hcertificate + +theorem machinePositiveLargeProductRawCode_mem_FP + {certificateMachine : List Bool β†’ List Bool} + (hcertificate : certificateMachine ∈ Complexity.FP) : + machinePositiveLargeProductRawCode certificateMachine ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineMatrixNormalizationScalePowerRawCode_mem_FP + (machinePositiveCertificateRawCode_mem_FP hcertificate) + simpa only [machinePositiveLargeProductRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machinePositiveLargeRawCode_mem_FP + {certificateMachine : List Bool β†’ List Bool} + (hcertificate : certificateMachine ∈ Complexity.FP) : + machinePositiveLargeRawCode certificateMachine ∈ Complexity.FP := by + simpa only [machinePositiveLargeRawCode] using! + machineCompose_mem_FP + (machinePositiveLargeProductRawCode_mem_FP hcertificate) + machineNormalizeRawRatEntryCode_mem_FP + +theorem machinePositiveAlgorithmRawCode_mem_FP + {certificateMachine : List Bool β†’ List Bool} + (hcertificate : certificateMachine ∈ Complexity.FP) : + machinePositiveAlgorithmRawCode certificateMachine ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineCompletedDimensionLtTwoBit_mem_FP + machinePositiveSmallRawCode_mem_FP + (machinePositiveLargeRawCode_mem_FP hcertificate) + +@[simp] theorem machinePositiveSmallRawCode_zero + (A : Matrix (Fin 0) (Fin 0) β„š) : + machinePositiveSmallRawCode + (rationalMatrixBinaryEncoding.encode ⟨0, A⟩) = + rawRatBinaryCode (rawRatOfRat (Matrix.permanent A)) := by + simp [machinePositiveSmallRawCode, Matrix.permanent, + rawRatBinaryCode, rawRatOfRat, integerBinaryCode, RawRat.one] + +@[simp] theorem machinePositiveSmallRawCode_one + (A : Matrix (Fin 1) (Fin 1) β„š) : + machinePositiveSmallRawCode + (rationalMatrixBinaryEncoding.encode ⟨1, A⟩) = + rawRatBinaryCode (rawRatOfRat (Matrix.permanent A)) := by + simp [machinePositiveSmallRawCode, Matrix.permanent_fin_one, + rawRatBinaryCode_rawRatOfRat] + +theorem machinePositiveSmallRawCode_encode {n : β„•} + (hn : n < 2) (A : Matrix (Fin n) (Fin n) β„š) : + machinePositiveSmallRawCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rawRatBinaryCode (rawRatOfRat (Matrix.permanent A)) := by + interval_cases n + Β· exact machinePositiveSmallRawCode_zero A + Β· exact machinePositiveSmallRawCode_one A + +theorem machinePositiveLargeRawCode_encode + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : RawStringRealizes certificateMachine + explicitNormalizedCertificateAlgorithm) + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) : + machinePositiveLargeRawCode certificateMachine + (rationalMatrixBinaryEncoding.encode ⟨m + 2, A⟩) = + rawRatBinaryCode + (rawRatOfRat (explicitPositiveAlgorithm (m + 2) A)) := by + have hcertificate := hrealizes + ⟨m + 2, normalizedRationalMatrix A⟩ + change certificateMachine + (rationalMatrixBinaryEncoding.encode + ⟨m + 2, normalizedRationalMatrix A⟩) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerRowPotential (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerColumnPotential (m := m + 1) + (normalizedRationalMatrix A)))) at hcertificate + simp only [machinePositiveLargeRawCode, + machinePositiveLargeProductRawCode, + machinePositiveCertificateRawCode, + machinePositiveNormalizedMatrixCode, + machineMatrixNormalizeEntries_encode, + hcertificate, + machineMatrixNormalizationScalePowerRawCode_encode, + machineRawRatMulCode_encode, + machineNormalizeRawRatEntryCode_encode, + ← rawRatBinaryCode_rawRatOfRat] + apply congrArg rawRatBinaryCode + apply congrArg rawRatOfRat + rw [binaryNormalizeRawRat_eq_value, RawRat.value_mul, + RawRat.value_pow, RawRat.value_add, RawRat.value_one, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum, rawRatOfRat_value] + rfl + +theorem machinePositiveLargeRawCode_encode_onPositive + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : + NormalizedCertificateStringRealizesOnPositive certificateMachine) + (m : β„•) (A : Matrix (Fin (m + 2)) (Fin (m + 2)) β„š) + (hA : Matrix.Positive (fun i j ↦ (A i j : ℝ))) : + machinePositiveLargeRawCode certificateMachine + (rationalMatrixBinaryEncoding.encode ⟨m + 2, A⟩) = + rawRatBinaryCode + (rawRatOfRat (explicitPositiveAlgorithm (m + 2) A)) := by + have hAq : βˆ€ i j, 0 < A i j := fun i j ↦ Rat.cast_pos.mp (hA i j) + have hA0 : Matrix.Nonnegative A := fun i j ↦ (hAq i j).le + have hBpos : βˆ€ i j, 0 < normalizedRationalMatrix A i j := by + intro i j + rw [normalizedRationalMatrix] + exact div_pos (hAq i j) (rationalNormalizationScale_pos hA0) + have hBupper : βˆ€ i j, normalizedRationalMatrix A i j ≀ 1 := + normalizedRationalMatrix_le_one hA0 + have hcertificate := hrealizes m (normalizedRationalMatrix A) + hBpos hBupper + change certificateMachine + (rationalMatrixBinaryEncoding.encode + ⟨m + 2, normalizedRationalMatrix A⟩) = + rawRatBinaryCode + (rawRatOfRat + (explicitDirectedCertificateValue + (explicitBetheOptimizerMatrix (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerRowPotential (m := m + 1) + (normalizedRationalMatrix A)) + (explicitBetheOptimizerColumnPotential (m := m + 1) + (normalizedRationalMatrix A)))) at hcertificate + simp only [machinePositiveLargeRawCode, + machinePositiveLargeProductRawCode, + machinePositiveCertificateRawCode, + machinePositiveNormalizedMatrixCode, + machineMatrixNormalizeEntries_encode, + hcertificate, + machineMatrixNormalizationScalePowerRawCode_encode, + machineRawRatMulCode_encode, + machineNormalizeRawRatEntryCode_encode, + ← rawRatBinaryCode_rawRatOfRat] + apply congrArg rawRatBinaryCode + apply congrArg rawRatOfRat + rw [binaryNormalizeRawRat_eq_value, RawRat.value_mul, + RawRat.value_pow, RawRat.value_add, RawRat.value_one, + rawRatRowsSum_value, RawRat.value_zero, zero_add, + rationalMatrixRows_sum, rawRatOfRat_value] + rfl + +theorem machinePositiveAlgorithmRawCode_realizes + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : RawStringRealizes certificateMachine + explicitNormalizedCertificateAlgorithm) : + RawStringRealizes + (machinePositiveAlgorithmRawCode certificateMachine) + explicitPositiveAlgorithm := by + intro x + obtain ⟨n, A⟩ := x + rw [machinePositiveAlgorithmRawCode, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true, + machinePositiveSmallRawCode_encode hsmall] + interval_cases n <;> rfl + Β· rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false] + obtain ⟨m, rfl⟩ : βˆƒ m, n = m + 2 := by + use n - 2 + omega + exact machinePositiveLargeRawCode_encode hrealizes m A + +theorem machinePositiveAlgorithmRawCode_realizes_onPositive + {certificateMachine : List Bool β†’ List Bool} + (hrealizes : + NormalizedCertificateStringRealizesOnPositive certificateMachine) : + PositiveRawStringRealizes + (machinePositiveAlgorithmRawCode certificateMachine) + explicitPositiveAlgorithm := by + intro n A hA + rw [machinePositiveAlgorithmRawCode, + machineCompletedDimensionLtTwoBit_encode] + by_cases hsmall : n < 2 + Β· rw [show [decide (n < 2)] = [true] by simp [hsmall], + machineIfHead_true, + machinePositiveSmallRawCode_encode hsmall] + interval_cases n <;> rfl + Β· rw [show [decide (n < 2)] = [false] by simp [hsmall], + machineIfHead_false] + obtain ⟨m, rfl⟩ : βˆƒ m, n = m + 2 := by + use n - 2 + omega + exact machinePositiveLargeRawCode_encode_onPositive hrealizes m A hA + +theorem explicitPositiveAlgorithm_rawMachine_of_certificateMachine + {certificateMachine : List Bool β†’ List Bool} + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hrealizes : RawStringRealizes certificateMachine + explicitNormalizedCertificateAlgorithm) : + βˆƒ positiveMachine : List Bool β†’ List Bool, + positiveMachine ∈ Complexity.FP ∧ + RawStringRealizes positiveMachine explicitPositiveAlgorithm := by + exact ⟨machinePositiveAlgorithmRawCode certificateMachine, + machinePositiveAlgorithmRawCode_mem_FP hcertificateFP, + machinePositiveAlgorithmRawCode_realizes hrealizes⟩ + +theorem explicitPositiveAlgorithm_positive_rawMachine_of_certificateMachine + {certificateMachine : List Bool β†’ List Bool} + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hrealizes : + NormalizedCertificateStringRealizesOnPositive certificateMachine) : + βˆƒ positiveMachine : List Bool β†’ List Bool, + positiveMachine ∈ Complexity.FP ∧ + PositiveRawStringRealizes positiveMachine explicitPositiveAlgorithm := by + exact ⟨machinePositiveAlgorithmRawCode certificateMachine, + machinePositiveAlgorithmRawCode_mem_FP hcertificateFP, + machinePositiveAlgorithmRawCode_realizes_onPositive hrealizes⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRAMBridge.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRAMBridge.lean new file mode 100644 index 0000000000..6b24b0b353 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRAMBridge.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment + +/-! +# From logarithmic-cost RAM deciders to one-bit `FP` functions + +Complexitylib's RAM simulator is stated for languages. The executable +permanent approximation will use it as a bit graph: a RAM program answers one +requested output bit, and an outer bounded `FP` loop assembles those answers. +This file proves the first, generic bridge without introducing a machine-time +assumption. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +namespace MachineRAMBridge + +open RAM.RegisterStore.Machine + +/-- The clean verdict tape emitted by the RAM simulator contains exactly one +Boolean output symbol and then a blank. -/ +theorem registerVerdictOutput_hasOutput (value : β„•) : + (registerVerdictOutput value).HasOutput [decide (value β‰  0)] := by + by_cases h : value = 0 <;> + simp [h, Tape.HasOutput, registerVerdictOutput, registerVerdictSymbol, + TM.idleDir, Tape.writeAndMove, Tape.move, Tape.write, Tape.read, + Tape.init] + all_goals rfl + +/-- The ordinary one-bit characteristic string of a decidable language. -/ +def languageFlag (L : Language) + [DecidablePred (fun word => word ∈ L)] (word : List Bool) : List Bool := + [decide (word ∈ L)] + +/-- A logarithmic-cost RAM decider computes the corresponding one-bit string +on the verified sparse simulator, with the simulator's explicit envelope. -/ +theorem programDecision_computesLanguageFlagInTime + {L : Language} {T : β„• β†’ β„•} + [DecidablePred (fun word => word ∈ L)] + (program : RAM.Program) (hdecides : program.DecidesInTime L T) : + (programDecisionTM standardControlInstructionTapes program).ComputesInTime + (languageFlag L) + (fun inputLength => + programDecisionEnvelope program inputLength (T inputLength)) := by + intro input + obtain ⟨fuel, hhalted, hcost, hyes, hno⟩ := hdecides input + let haltWitness : βˆƒ candidate, + RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := ⟨fuel, hhalted⟩ + let firstFuel := Nat.find haltWitness + have hfirstHalted : RAM.Halted program + (RAM.run program firstFuel (RAM.initCfg input)) := + Nat.find_spec haltWitness + have hfirstLe : firstFuel ≀ fuel := Nat.find_min' haltWitness hhalted + have hnotHalted : βˆ€ candidate < firstFuel, + Β¬ RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := by + intro candidate hcandidate + exact Nat.find_min haltWitness hcandidate + have hunit : RAM.unitTimeUpto program firstFuel (RAM.initCfg input) = + firstFuel := + RAM.unitTimeUpto_eq_of_not_halted program (RAM.initCfg input) firstFuel + hnotHalted + have hfuelCost : firstFuel ≀ + RAM.logTimeUpto program firstFuel (RAM.initCfg input) := by + calc + firstFuel = RAM.unitTimeUpto program firstFuel (RAM.initCfg input) := + hunit.symm + _ ≀ RAM.logTimeUpto program firstFuel (RAM.initCfg input) := + RAM.unitTimeUpto_le_logTimeUpto program firstFuel (RAM.initCfg input) + have hcostMono := RAM.logTimeUpto_mono program + (c := RAM.initCfg input) hfirstLe + have hfirstCost : RAM.logTimeUpto program firstFuel (RAM.initCfg input) ≀ + T input.length := le_trans hcostMono hcost + have hrunEq : RAM.run program fuel (RAM.initCfg input) = + RAM.run program firstFuel (RAM.initCfg input) := + RAM.run_eq_of_halted_le program hfirstLe hfirstHalted + have hmachine := programDecisionTM_hoareTime_ramRun + standardControlInstructionTapes program input firstFuel hfirstHalted + obtain ⟨final, time, htime, hreach, hfinalHalted, houtput⟩ := + hmachine (Tape.init (input.map Ξ“.ofBool)) + (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + have hresource := programDecisionTime_le_envelope + standardControlInstructionTapes program input firstFuel hfirstHalted + hfuelCost + have henvelope := programDecisionEnvelope_mono_cost program input.length + (RAM.logTimeUpto program firstFuel (RAM.initCfg input)) + (T input.length) hfirstCost + refine ⟨final, time, le_trans htime (le_trans hresource henvelope), + hreach, hfinalHalted, ?_⟩ + by_cases hmember : input ∈ L + Β· have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 1 := by + rw [← hrunEq] + exact hyes hmember + rw [houtput, hverdict] + simpa [languageFlag, hmember] using! registerVerdictOutput_hasOutput 1 + Β· have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 0 := by + rw [← hrunEq] + exact hno hmember + rw [houtput, hverdict] + simpa [languageFlag, hmember] using! registerVerdictOutput_hasOutput 0 + +/-- If the RAM time bound is a polynomial evaluation, its one-bit answer is a +genuine deterministic Turing-machine `FP` function. -/ +theorem languageFlag_mem_FP_of_ramProgram + {L : Language} [DecidablePred (fun word => word ∈ L)] + (program : RAM.Program) (p : Polynomial β„•) + (hdecides : program.DecidesInTime L p.eval) : + languageFlag L ∈ Complexity.FP := by + apply mem_FP_iff_computesInTime_polynomial.mpr + refine ⟨20, programDecisionTM standardControlInstructionTapes program, + programDecisionPolynomial program p, ?_⟩ + simpa only [programDecisionPolynomial_eval] using! + programDecision_computesLanguageFlagInTime program hdecides + +/-- Reserve a fixed prefix of zero input registers for a RAM program's direct +scratch registers. The semantic payload begins immediately after it. -/ +def prefixZeroRegisters (count : β„•) (word : List Bool) : List Bool := + List.replicate count false ++ word + +theorem prefixZeroRegisters_mem_FP (count : β„•) : + prefixZeroRegisters count ∈ Complexity.FP := by + simpa only [prefixZeroRegisters] using! + machineAppend_mem_FP (machineConst_mem_FP (List.replicate count false)) + id_mem_FP + +/-- Language seen through a fixed zero-register prefix. -/ +def paddedLanguage (count : β„•) (L : Language) : Language := + {word | word.drop count ∈ L} + +instance paddedLanguage_decidable (count : β„•) (L : Language) + [DecidablePred (fun word => word ∈ L)] : + DecidablePred (fun word => word ∈ paddedLanguage count L) := by + intro word + change Decidable (word.drop count ∈ L) + infer_instance + +theorem languageFlag_padded_prefix (count : β„•) (L : Language) + [DecidablePred (fun word => word ∈ L)] (word : List Bool) : + languageFlag (paddedLanguage count L) (prefixZeroRegisters count word) = + languageFlag L word := by + simp [languageFlag, paddedLanguage, prefixZeroRegisters] + +/-- A RAM decider may safely use a fixed direct-register prefix: preprocessing +that prefix and composing the verified one-bit simulator remains in `FP`. -/ +theorem languageFlag_mem_FP_of_paddedRamProgram + (count : β„•) {L : Language} + [DecidablePred (fun word => word ∈ L)] + (program : RAM.Program) (p : Polynomial β„•) + (hdecides : program.DecidesInTime (paddedLanguage count L) p.eval) : + languageFlag L ∈ Complexity.FP := by + have hpadded : languageFlag (paddedLanguage count L) ∈ Complexity.FP := + languageFlag_mem_FP_of_ramProgram program p hdecides + have hcomposed : + (fun word => languageFlag (paddedLanguage count L) + (prefixZeroRegisters count word)) ∈ Complexity.FP := + machineCompose_mem_FP (prefixZeroRegisters_mem_FP count) hpadded + have heq : (fun word => languageFlag (paddedLanguage count L) + (prefixZeroRegisters count word)) = languageFlag L := by + funext word + exact languageFlag_padded_prefix count L word + rwa [heq] at hcomposed + +end MachineRAMBridge + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalArithmetic.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalArithmetic.lean new file mode 100644 index 0000000000..9eb338662b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalArithmetic.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerArithmetic + +/-! +# Polynomial-time rational addition and multiplication + +The input is a pair of unreduced rational encodings. Addition forms the two +cross-products and multiplication forms the two direct products. Both public +operations then invoke the separately verified gcd normalizer, so no use of +Lean's built-in rational arithmetic is hidden in the machine implementation. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the signed numerator of the left raw rational in a pair. -/ +def machineRawLeftNumeratorCode (word : List Bool) : List Bool := + machinePairFirst (machinePairFirst word) + +/-- Extracts the denominator bits of the left raw rational in a pair. -/ +def machineRawLeftDenominatorBits (word : List Bool) : List Bool := + machinePairSecond (machinePairFirst word) + +/-- Extracts the signed numerator of the right raw rational in a pair. -/ +def machineRawRightNumeratorCode (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond word) + +/-- Extracts the denominator bits of the right raw rational in a pair. -/ +def machineRawRightDenominatorBits (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond word) + +/-- Regard canonical natural-number bits as a nonnegative integer code. -/ +def machineNaturalIntegerCode (word : List Bool) : List Bool := + false :: word + +/-- Multiplies the left signed numerator by the right denominator for raw rational addition. -/ +def machineRawAddLeftScaledNumerator (word : List Bool) : List Bool := + machineIntegerMulCode + (pair (machineRawLeftNumeratorCode word) + (machineNaturalIntegerCode (machineRawRightDenominatorBits word))) + +/-- Multiplies the right signed numerator by the left denominator for raw rational addition. -/ +def machineRawAddRightScaledNumerator (word : List Bool) : List Bool := + machineIntegerMulCode + (pair (machineRawRightNumeratorCode word) + (machineNaturalIntegerCode (machineRawLeftDenominatorBits word))) + +/-- Adds the two cross-multiplied signed numerators for raw rational addition. -/ +def machineRawAddNumeratorCode (word : List Bool) : List Bool := + machineIntegerAddCode + (pair (machineRawAddLeftScaledNumerator word) + (machineRawAddRightScaledNumerator word)) + +/-- Multiplies the two signed numerators for raw rational multiplication. -/ +def machineRawProductNumeratorCode (word : List Bool) : List Bool := + machineIntegerMulCode + (pair (machineRawLeftNumeratorCode word) + (machineRawRightNumeratorCode word)) + +/-- Multiplies the two binary denominators for raw rational arithmetic. -/ +def machineRawProductDenominatorBits (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineRawLeftDenominatorBits word) + (machineRawRightDenominatorBits word)) + +/-- Unreduced output encoding for rational addition. -/ +def machineRawRatAddCode (word : List Bool) : List Bool := + pair (machineRawAddNumeratorCode word) + (machineRawProductDenominatorBits word) + +/-- Unreduced output encoding for rational multiplication. -/ +def machineRawRatMulCode (word : List Bool) : List Bool := + pair (machineRawProductNumeratorCode word) + (machineRawProductDenominatorBits word) + +/-- Canonical public rational encoding of the sum. -/ +def machineRationalAddCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatAddCode word) + +/-- Canonical public rational encoding of the product. -/ +def machineRationalMulCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatMulCode word) + +theorem machineRawLeftNumeratorCode_mem_FP : + machineRawLeftNumeratorCode ∈ Complexity.FP := by + simpa only [machineRawLeftNumeratorCode] using! + machineCompose_mem_FP machinePairFirst_mem_FP machinePairFirst_mem_FP + +theorem machineRawLeftDenominatorBits_mem_FP : + machineRawLeftDenominatorBits ∈ Complexity.FP := by + simpa only [machineRawLeftDenominatorBits] using! + machineCompose_mem_FP machinePairFirst_mem_FP machinePairSecond_mem_FP + +theorem machineRawRightNumeratorCode_mem_FP : + machineRawRightNumeratorCode ∈ Complexity.FP := by + simpa only [machineRawRightNumeratorCode] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRawRightDenominatorBits_mem_FP : + machineRawRightDenominatorBits ∈ Complexity.FP := by + simpa only [machineRawRightDenominatorBits] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineNaturalIntegerCode_mem_FP : + machineNaturalIntegerCode ∈ Complexity.FP := by + exact machinePrepend_mem_FP false + +theorem machineRawAddLeftScaledNumerator_mem_FP : + machineRawAddLeftScaledNumerator ∈ Complexity.FP := by + have hden := machineCompose_mem_FP + machineRawRightDenominatorBits_mem_FP machineNaturalIntegerCode_mem_FP + have hpair := machinePair_mem_FP machineRawLeftNumeratorCode_mem_FP hden + simpa only [machineRawAddLeftScaledNumerator] using! + machineCompose_mem_FP hpair machineIntegerMulCode_mem_FP + +theorem machineRawAddRightScaledNumerator_mem_FP : + machineRawAddRightScaledNumerator ∈ Complexity.FP := by + have hden := machineCompose_mem_FP + machineRawLeftDenominatorBits_mem_FP machineNaturalIntegerCode_mem_FP + have hpair := machinePair_mem_FP machineRawRightNumeratorCode_mem_FP hden + simpa only [machineRawAddRightScaledNumerator] using! + machineCompose_mem_FP hpair machineIntegerMulCode_mem_FP + +theorem machineRawAddNumeratorCode_mem_FP : + machineRawAddNumeratorCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineRawAddLeftScaledNumerator_mem_FP + machineRawAddRightScaledNumerator_mem_FP + simpa only [machineRawAddNumeratorCode] using! + machineCompose_mem_FP hpair machineIntegerAddCode_mem_FP + +theorem machineRawProductNumeratorCode_mem_FP : + machineRawProductNumeratorCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineRawLeftNumeratorCode_mem_FP + machineRawRightNumeratorCode_mem_FP + simpa only [machineRawProductNumeratorCode] using! + machineCompose_mem_FP hpair machineIntegerMulCode_mem_FP + +theorem machineRawProductDenominatorBits_mem_FP : + machineRawProductDenominatorBits ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineRawLeftDenominatorBits_mem_FP + machineRawRightDenominatorBits_mem_FP + simpa only [machineRawProductDenominatorBits] using! + machineCompose_mem_FP hpair machineBinaryMulBits_mem_FP + +theorem machineRawRatAddCode_mem_FP : machineRawRatAddCode ∈ Complexity.FP := by + exact machinePair_mem_FP machineRawAddNumeratorCode_mem_FP + machineRawProductDenominatorBits_mem_FP + +theorem machineRawRatMulCode_mem_FP : machineRawRatMulCode ∈ Complexity.FP := by + exact machinePair_mem_FP machineRawProductNumeratorCode_mem_FP + machineRawProductDenominatorBits_mem_FP + +theorem machineRationalAddCode_mem_FP : machineRationalAddCode ∈ Complexity.FP := by + simpa only [machineRationalAddCode] using! + machineCompose_mem_FP machineRawRatAddCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineRationalMulCode_mem_FP : machineRationalMulCode ∈ Complexity.FP := by + simpa only [machineRationalMulCode] using! + machineCompose_mem_FP machineRawRatMulCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +@[simp] theorem machineNaturalIntegerCode_natBits (n : β„•) : + machineNaturalIntegerCode n.bits = integerBinaryCode (Int.ofNat n) := by + rfl + +@[simp] theorem machineRawLeftNumeratorCode_encode (q r : RawRat) : + machineRawLeftNumeratorCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode q.num := by + simp [machineRawLeftNumeratorCode, rawRatBinaryCode] + +@[simp] theorem machineRawLeftDenominatorBits_encode (q r : RawRat) : + machineRawLeftDenominatorBits + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = q.den.bits := by + simp [machineRawLeftDenominatorBits, rawRatBinaryCode] + +@[simp] theorem machineRawRightNumeratorCode_encode (q r : RawRat) : + machineRawRightNumeratorCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode r.num := by + simp [machineRawRightNumeratorCode, rawRatBinaryCode] + +@[simp] theorem machineRawRightDenominatorBits_encode (q r : RawRat) : + machineRawRightDenominatorBits + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = r.den.bits := by + simp [machineRawRightDenominatorBits, rawRatBinaryCode] + +theorem machineRawAddLeftScaledNumerator_encode (q r : RawRat) : + machineRawAddLeftScaledNumerator + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode (q.num * (r.den : β„€)) := by + simp [machineRawAddLeftScaledNumerator, + machineIntegerMulCode_encode] + +theorem machineRawAddRightScaledNumerator_encode (q r : RawRat) : + machineRawAddRightScaledNumerator + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode (r.num * (q.den : β„€)) := by + simp [machineRawAddRightScaledNumerator, + machineIntegerMulCode_encode] + +theorem machineRawAddNumeratorCode_encode (q r : RawRat) : + machineRawAddNumeratorCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode + (q.num * (r.den : β„€) + r.num * (q.den : β„€)) := by + rw [machineRawAddNumeratorCode, + machineRawAddLeftScaledNumerator_encode, + machineRawAddRightScaledNumerator_encode, + machineIntegerAddCode_encode] + +theorem machineRawProductNumeratorCode_encode (q r : RawRat) : + machineRawProductNumeratorCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + integerBinaryCode (q.num * r.num) := by + simp [machineRawProductNumeratorCode, machineIntegerMulCode_encode] + +theorem machineRawProductDenominatorBits_encode (q r : RawRat) : + machineRawProductDenominatorBits + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + (q.den * r.den).bits := by + simp [machineRawProductDenominatorBits, + machineBinaryMulBits_pair_natBits] + +theorem machineRawRatAddCode_encode (q r : RawRat) : + machineRawRatAddCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rawRatBinaryCode (q.add r) := by + rw [machineRawRatAddCode, machineRawAddNumeratorCode_encode, + machineRawProductDenominatorBits_encode] + rfl + +theorem machineRawRatMulCode_encode (q r : RawRat) : + machineRawRatMulCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rawRatBinaryCode (q.mul r) := by + rw [machineRawRatMulCode, machineRawProductNumeratorCode_encode, + machineRawProductDenominatorBits_encode] + rfl + +theorem machineRationalAddCode_encode (q r : RawRat) : + machineRationalAddCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rationalBinaryCode (binaryNormalizeRawRat (q.add r)) := by + rw [machineRationalAddCode, machineRawRatAddCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +theorem machineRationalMulCode_encode (q r : RawRat) : + machineRationalMulCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rationalBinaryCode (binaryNormalizeRawRat (q.mul r)) := by + rw [machineRationalMulCode, machineRawRatMulCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalBallInit.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalBallInit.lean new file mode 100644 index 0000000000..8d38e25e9a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalBallInit.lean @@ -0,0 +1,708 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineRepeatPair +public import LeanPool.BeyondBethe.BeyondBethe.MachineNestedMatrixMemory +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits + +/-! # Machine Rational Ball Init -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Finite-word construction of rational ball states + +This module begins the concrete state constructor used by every feasibility +call. It first builds the zero center and all-zero square basis from a unary +dimension ruler. The following section will replace the diagonal entries by +the encoded radius and package the result as a complete ellipsoid state. +-/ + +/-- The canonical rational-entry binary code for zero. -/ +def machineRationalZeroEntry : List Bool := + rationalEntryBinaryCode 0 + +/-- Input: a unary dimension ruler. -/ +def machineRationalZeroVectorCode (ruler : List Bool) : List Bool := + machineRepeatPairCode + (pair ruler (pair machineRationalZeroEntry [])) + +/-- Input: a unary dimension ruler. -/ +def machineRationalZeroMatrixRowsCode (ruler : List Bool) : List Bool := + let row := machineRationalZeroVectorCode ruler + machineRepeatPairCode (pair ruler (pair row [])) + +theorem machineRationalZeroVectorCode_mem_FP : + machineRationalZeroVectorCode ∈ FP := by + have hpayload := machinePair_mem_FP id_mem_FP + (machinePair_mem_FP (machineConst_mem_FP machineRationalZeroEntry) + (machineConst_mem_FP [])) + simpa only [machineRationalZeroVectorCode] using! + machineCompose_mem_FP hpayload machineRepeatPairCode_mem_FP + +theorem machineRationalZeroMatrixRowsCode_mem_FP : + machineRationalZeroMatrixRowsCode ∈ FP := by + have hpayload := machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRationalZeroVectorCode_mem_FP + (machineConst_mem_FP [])) + simpa only [machineRationalZeroMatrixRowsCode] using! + machineCompose_mem_FP hpayload machineRepeatPairCode_mem_FP + +@[simp] theorem machineRationalZeroVectorCode_encode (d : β„•) : + machineRationalZeroVectorCode (List.replicate d true) = + rationalFiniteVectorCode (fun _ : Fin d ↦ (0 : β„š)) := by + rw [machineRationalZeroVectorCode] + change machineRepeatPairCode + (machineRepeatPairCanonicalInput d machineRationalZeroEntry []) = _ + rw [machineRepeatPairCode_encode] + change repeatPairCode d (rationalEntryBinaryCode 0) + (binaryListCode rationalEntryBinaryCode []) = _ + rw [repeatPairCode_binaryListCode] + simp [rationalFiniteVectorCode] + +theorem rationalMatrixRows_zero (d : β„•) : + rationalMatrixRows (0 : Matrix (Fin d) (Fin d) β„š) = + List.replicate d (List.replicate d 0) := by + simp [rationalMatrixRows] + +@[simp] theorem machineRationalZeroMatrixRowsCode_encode (d : β„•) : + machineRationalZeroMatrixRowsCode (List.replicate d true) = + rationalSquareMatrixRowsCode + (0 : Matrix (Fin d) (Fin d) β„š) := by + rw [machineRationalZeroMatrixRowsCode, + machineRationalZeroVectorCode_encode] + change machineRepeatPairCode + (machineRepeatPairCanonicalInput d + (rationalFiniteVectorCode (fun _ : Fin d ↦ (0 : β„š))) []) = _ + rw [machineRepeatPairCode_encode] + change repeatPairCode d + (binaryListCode rationalEntryBinaryCode + (List.ofFn (fun _ : Fin d ↦ (0 : β„š)))) + (binaryListCode (binaryListCode rationalEntryBinaryCode) []) = _ + rw [repeatPairCode_binaryListCode] + rw [rationalSquareMatrixRowsCode, rationalMatrixRows_zero] + simp + +/-! ## Diagonal prefixes -/ + +/-- The first `k` diagonal entries have been replaced by `R`; all other +entries are zero. -/ +def rationalDiagonalPrefixMatrix (d k : β„•) (R : β„š) : + Matrix (Fin d) (Fin d) β„š := + fun i j ↦ if i = j ∧ i.1 < k then R else 0 + +@[simp] theorem rationalDiagonalPrefixMatrix_zero + (d : β„•) (R : β„š) : + rationalDiagonalPrefixMatrix d 0 R = 0 := by + ext i j + simp [rationalDiagonalPrefixMatrix] + +theorem rationalDiagonalPrefixMatrix_all + (d : β„•) (R : β„š) : + rationalDiagonalPrefixMatrix d d R = + (rationalBallEllipsoid d 0 R).basis := by + ext i j + simp [rationalDiagonalPrefixMatrix, rationalBallEllipsoid] + +theorem rationalMatrixRows_diagonalPrefix_set + {d k : β„•} (R : β„š) (hk : k < d) : + let rows := rationalMatrixRows (rationalDiagonalPrefixMatrix d k R) + rows.set k + ((rows[k]'(by simpa [rows, rationalMatrixRows] using! hk)).set k R) = + rationalMatrixRows (rationalDiagonalPrefixMatrix d (k + 1) R) := by + dsimp only + apply List.ext_getElem + Β· simp [rationalMatrixRows] + Β· intro i hiLeft hiRight + have hi : i < d := by + simpa [rationalMatrixRows] using! hiRight + by_cases hik : i = k + Β· subst i + simp only [List.getElem_set, ↓reduceIte] + apply List.ext_getElem + Β· simp [rationalMatrixRows] + Β· intro j hjLeft hjRight + have hj : j < d := by + simpa [rationalMatrixRows] using! hjRight + by_cases hjk : j = k + Β· subst j + simp [rationalMatrixRows, rationalDiagonalPrefixMatrix] + Β· rw [List.getElem_set_of_ne (Ne.symm hjk)] + simp [rationalMatrixRows, rationalDiagonalPrefixMatrix, + Ne.symm hjk] + Β· rw [List.getElem_set_of_ne (Ne.symm hik)] + simp only [rationalMatrixRows, List.getElem_ofFn] + apply List.ext_getElem + Β· simp + Β· intro j hjLeft hjRight + have hj : j < d := by simpa using! hjRight + simp only [List.getElem_ofFn] + by_cases hij : i = j + Β· subst j + simp only [rationalDiagonalPrefixMatrix, Nat.lt_succ_iff] + by_cases hlt : i < k + Β· have hnki : Β¬k < i := by omega + simp [hlt, hnki] + Β· have hgt : k < i := by omega + simp [hlt, Nat.not_le.mpr hgt] + Β· simp [rationalDiagonalPrefixMatrix, hij] + +/-! ## Diagonal-basis machine -/ + +/-- Extracts the unary dimension ruler from a diagonal-basis request. -/ +def machineDiagonalBasisRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded radius entry from a diagonal-basis request. -/ +def machineDiagonalBasisRadiusEntry (word : List Bool) : List Bool := + machinePairSecond word + +/-- A quartic envelope for the nested matrix under diagonal updates. -/ +def machineDiagonalBasisBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth word) + +/-- Packs the diagonal-basis scan index, accumulated matrix, fixed radius entry, and bound word. -/ +def machineDiagonalBasisPack + (index matrix radius bound : List Bool) : List Bool := + pair index (pair matrix (pair radius bound)) + +/-- Extracts the unary diagonal index from a diagonal-basis construction state. -/ +def machineDiagonalBasisIndex (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the accumulated encoded matrix from a diagonal-basis state. -/ +def machineDiagonalBasisMatrix (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed radius entry from a diagonal-basis state. -/ +def machineDiagonalBasisRadius (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the stored field-length bound from a diagonal-basis state. -/ +def machineDiagonalBasisStateBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Increments the unary diagonal index by prepending one true bit. -/ +def machineDiagonalBasisNextIndexCandidate + (state : List Bool) : List Bool := + true :: machineDiagonalBasisIndex state + +/-- Truncates the incremented diagonal index to the stored bound length. -/ +def machineDiagonalBasisNextIndex (state : List Bool) : List Bool := + (machineDiagonalBasisNextIndexCandidate state).take + (machineDiagonalBasisStateBound state).length + +/-- Updates the matrix entry at the current diagonal index to the fixed radius value. -/ +def machineDiagonalBasisMatrixCandidate (state : List Bool) : List Bool := + machineNestedMatrixUpdateAtUnary + (pair (machineDiagonalBasisIndex state) + (pair (machineDiagonalBasisIndex state) + (pair (machineDiagonalBasisRadius state) + (machineDiagonalBasisMatrix state)))) + +/-- Truncates the updated matrix code to the stored bound length. -/ +def machineDiagonalBasisNextMatrix (state : List Bool) : List Bool := + (machineDiagonalBasisMatrixCandidate state).take + (machineDiagonalBasisStateBound state).length + +/-- Advances the diagonal index and updates the corresponding matrix entry while preserving +radius and bound. -/ +def machineDiagonalBasisStep (state : List Bool) : List Bool := + machineDiagonalBasisPack (machineDiagonalBasisNextIndex state) + (machineDiagonalBasisNextMatrix state) + (machineDiagonalBasisRadius state) + (machineDiagonalBasisStateBound state) + +/-- Constructs an encoded zero matrix of the requested dimension and truncates it to the +diagonal-basis bound. -/ +def machineDiagonalBasisInitialMatrix (word : List Bool) : List Bool := + (machineRationalZeroMatrixRowsCode (machineDiagonalBasisRuler word)).take + (machineDiagonalBasisBound word).length + +/-- Initializes diagonal-basis construction at index zero with the bounded zero matrix and +requested radius. -/ +def machineDiagonalBasisInit (word : List Bool) : List Bool := + machineDiagonalBasisPack [] (machineDiagonalBasisInitialMatrix word) + (machineDiagonalBasisRadiusEntry word) + (machineDiagonalBasisBound word) + +/-- Packs four copies of the diagonal-basis bound to bound the full state encoding. -/ +def machineDiagonalBasisWidth (word : List Bool) : List Bool := + machineDiagonalBasisPack (machineDiagonalBasisBound word) + (machineDiagonalBasisBound word) (machineDiagonalBasisBound word) + (machineDiagonalBasisBound word) + +/-- Iterates the diagonal-basis update once per element of the unary dimension ruler. -/ +def machineDiagonalBasisFinalState (word : List Bool) : List Bool := + (machineDiagonalBasisStep)^[(machineDiagonalBasisRuler word).length] + (machineDiagonalBasisInit word) + +/-- Extracts the encoded matrix rows after all diagonal updates. -/ +def machineDiagonalBasisRowsCode (word : List Bool) : List Bool := + machineDiagonalBasisMatrix (machineDiagonalBasisFinalState word) + +/-! ### Polynomial-time closure -/ + +theorem machineDiagonalBasisRuler_mem_FP : + machineDiagonalBasisRuler ∈ FP := machinePairFirst_mem_FP + +theorem machineDiagonalBasisRadiusEntry_mem_FP : + machineDiagonalBasisRadiusEntry ∈ FP := machinePairSecond_mem_FP + +theorem machineDiagonalBasisBound_mem_FP : + machineDiagonalBasisBound ∈ FP := by + simpa only [machineDiagonalBasisBound] using! + machineCompose_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineDiagonalBasisIndex_mem_FP : + machineDiagonalBasisIndex ∈ FP := machinePairFirst_mem_FP + +theorem machineDiagonalBasisMatrix_mem_FP : + machineDiagonalBasisMatrix ∈ FP := by + simpa only [machineDiagonalBasisMatrix] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineDiagonalBasisRadius_mem_FP : + machineDiagonalBasisRadius ∈ FP := by + have hsecondTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineDiagonalBasisRadius] using! + machineCompose_mem_FP hsecondTwo machinePairFirst_mem_FP + +theorem machineDiagonalBasisStateBound_mem_FP : + machineDiagonalBasisStateBound ∈ FP := by + have hsecondTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineDiagonalBasisStateBound] using! + machineCompose_mem_FP hsecondTwo machinePairSecond_mem_FP + +theorem machineDiagonalBasisNextIndexCandidate_mem_FP : + machineDiagonalBasisNextIndexCandidate ∈ FP := by + simpa only [machineDiagonalBasisNextIndexCandidate] using! + machineAppend_mem_FP (machineConst_mem_FP [true]) + machineDiagonalBasisIndex_mem_FP + +theorem machineDiagonalBasisNextIndex_mem_FP : + machineDiagonalBasisNextIndex ∈ FP := by + simpa only [machineDiagonalBasisNextIndex] using! + machineTake_mem_FP machineDiagonalBasisStateBound_mem_FP + machineDiagonalBasisNextIndexCandidate_mem_FP + +theorem machineDiagonalBasisMatrixCandidate_mem_FP : + machineDiagonalBasisMatrixCandidate ∈ FP := by + have hpayload := machinePair_mem_FP machineDiagonalBasisIndex_mem_FP + (machinePair_mem_FP machineDiagonalBasisIndex_mem_FP + (machinePair_mem_FP machineDiagonalBasisRadius_mem_FP + machineDiagonalBasisMatrix_mem_FP)) + simpa only [machineDiagonalBasisMatrixCandidate] using! + machineCompose_mem_FP hpayload machineNestedMatrixUpdateAtUnary_mem_FP + +theorem machineDiagonalBasisNextMatrix_mem_FP : + machineDiagonalBasisNextMatrix ∈ FP := by + simpa only [machineDiagonalBasisNextMatrix] using! + machineTake_mem_FP machineDiagonalBasisStateBound_mem_FP + machineDiagonalBasisMatrixCandidate_mem_FP + +theorem machineDiagonalBasisStep_mem_FP : machineDiagonalBasisStep ∈ FP := + machinePair_mem_FP machineDiagonalBasisNextIndex_mem_FP + (machinePair_mem_FP machineDiagonalBasisNextMatrix_mem_FP + (machinePair_mem_FP machineDiagonalBasisRadius_mem_FP + machineDiagonalBasisStateBound_mem_FP)) + +theorem machineDiagonalBasisInitialMatrix_mem_FP : + machineDiagonalBasisInitialMatrix ∈ FP := by + have hzero := machineCompose_mem_FP machineDiagonalBasisRuler_mem_FP + machineRationalZeroMatrixRowsCode_mem_FP + simpa only [machineDiagonalBasisInitialMatrix] using! + machineTake_mem_FP machineDiagonalBasisBound_mem_FP hzero + +theorem machineDiagonalBasisInit_mem_FP : machineDiagonalBasisInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineDiagonalBasisInitialMatrix_mem_FP + (machinePair_mem_FP machineDiagonalBasisRadiusEntry_mem_FP + machineDiagonalBasisBound_mem_FP)) + +theorem machineDiagonalBasisWidth_mem_FP : machineDiagonalBasisWidth ∈ FP := + machinePair_mem_FP machineDiagonalBasisBound_mem_FP + (machinePair_mem_FP machineDiagonalBasisBound_mem_FP + (machinePair_mem_FP machineDiagonalBasisBound_mem_FP + machineDiagonalBasisBound_mem_FP)) + +@[simp] theorem machineDiagonalBasisIndex_pack (a b c e) : + machineDiagonalBasisIndex (machineDiagonalBasisPack a b c e) = a := by + simp [machineDiagonalBasisIndex, machineDiagonalBasisPack] + +@[simp] theorem machineDiagonalBasisMatrix_pack (a b c e) : + machineDiagonalBasisMatrix (machineDiagonalBasisPack a b c e) = b := by + simp [machineDiagonalBasisMatrix, machineDiagonalBasisPack] + +@[simp] theorem machineDiagonalBasisRadius_pack (a b c e) : + machineDiagonalBasisRadius (machineDiagonalBasisPack a b c e) = c := by + simp [machineDiagonalBasisRadius, machineDiagonalBasisPack] + +@[simp] theorem machineDiagonalBasisStateBound_pack (a b c e) : + machineDiagonalBasisStateBound (machineDiagonalBasisPack a b c e) = e := by + simp [machineDiagonalBasisStateBound, machineDiagonalBasisPack] + +/-- Requires exact diagonal-state packing and bounds each of its four field lengths by the +input-derived bound. -/ +def MachineDiagonalBasisStateBound (word state : List Bool) : Prop := + let B := (machineDiagonalBasisBound word).length + state = machineDiagonalBasisPack + (machineDiagonalBasisIndex state) + (machineDiagonalBasisMatrix state) + (machineDiagonalBasisRadius state) + (machineDiagonalBasisStateBound state) ∧ + (machineDiagonalBasisIndex state).length ≀ B ∧ + (machineDiagonalBasisMatrix state).length ≀ B ∧ + (machineDiagonalBasisRadius state).length ≀ B ∧ + (machineDiagonalBasisStateBound state).length ≀ B + +theorem machineDiagonalBasis_word_length_le_bound (word : List Bool) : + word.length ≀ (machineDiagonalBasisBound word).length := by + simp only [machineDiagonalBasisBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineDiagonalBasisInit_bound (word : List Bool) : + MachineDiagonalBasisStateBound word (machineDiagonalBasisInit word) := by + simp only [MachineDiagonalBasisStateBound, machineDiagonalBasisInit, + machineDiagonalBasisIndex_pack, machineDiagonalBasisMatrix_pack, + machineDiagonalBasisRadius_pack, machineDiagonalBasisStateBound_pack] + refine ⟨trivial, by simp, ?_, ?_, le_rfl⟩ + Β· exact (List.length_take_le _ _).trans le_rfl + Β· exact (machinePairSecond_length_le word).trans + (machineDiagonalBasis_word_length_le_bound word) + +theorem machineDiagonalBasisStep_bound {word state : List Bool} + (hstate : MachineDiagonalBasisStateBound word state) : + MachineDiagonalBasisStateBound word (machineDiagonalBasisStep state) := by + dsimp only [MachineDiagonalBasisStateBound] at hstate ⊒ + rcases hstate with ⟨_, _hindex, _hmatrix, hradius, hbound⟩ + simp only [machineDiagonalBasisStep, machineDiagonalBasisIndex_pack, + machineDiagonalBasisMatrix_pack, machineDiagonalBasisRadius_pack, + machineDiagonalBasisStateBound_pack] + refine ⟨trivial, ?_, ?_, hradius, hbound⟩ + Β· exact (List.length_take_le _ _).trans hbound + Β· exact (List.length_take_le _ _).trans hbound + +theorem machineDiagonalBasisIterate_bound (word : List Bool) : βˆ€ k, + MachineDiagonalBasisStateBound word + ((machineDiagonalBasisStep)^[k] (machineDiagonalBasisInit word)) := by + intro k + induction k with + | zero => exact machineDiagonalBasisInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineDiagonalBasisStep_bound ih + +theorem machineDiagonalBasisIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineDiagonalBasisRuler word).length) : + ((machineDiagonalBasisStep)^[iterations] + (machineDiagonalBasisInit word)).length ≀ + (machineDiagonalBasisWidth word).length := by + rcases machineDiagonalBasisIterate_bound word iterations with + ⟨hdecomp, hindex, hmatrix, hradius, hbound⟩ + rw [hdecomp] + simp only [machineDiagonalBasisPack, machineDiagonalBasisWidth, pair_length] + omega + +theorem machineDiagonalBasisFinalState_mem_FP : + machineDiagonalBasisFinalState ∈ FP := + Cobham.iterate_mem_FP machineDiagonalBasisStep_mem_FP + machineDiagonalBasisInit_mem_FP machineDiagonalBasisRuler_mem_FP + machineDiagonalBasisWidth_mem_FP + machineDiagonalBasisIterate_length_le_width + +theorem machineDiagonalBasisRowsCode_mem_FP : + machineDiagonalBasisRowsCode ∈ FP := by + simpa only [machineDiagonalBasisRowsCode] using! + machineCompose_mem_FP machineDiagonalBasisFinalState_mem_FP + machineDiagonalBasisMatrix_mem_FP + +/-! ### Exact canonical semantics -/ + +/-- Encodes dimension `d` as a unary ruler followed by rational radius `R`. -/ +def machineDiagonalBasisCanonicalInput (d : β„•) (R : β„š) : List Bool := + pair (List.replicate d true) (rationalEntryBinaryCode R) + +/-- Encodes the semantic construction state after `k` diagonal entries have been set to `R`. -/ +def machineDiagonalBasisCanonicalState + (d : β„•) (R : β„š) (k : β„•) : List Bool := + let word := machineDiagonalBasisCanonicalInput d R + machineDiagonalBasisPack (List.replicate k true) + (rationalSquareMatrixRowsCode (rationalDiagonalPrefixMatrix d k R)) + (rationalEntryBinaryCode R) (machineDiagonalBasisBound word) + +theorem rationalSquareMatrixRowsCode_diagonalPrefix_length_le + (d k : β„•) (R : β„š) : + (rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d k R)).length ≀ + d * (2 * (d * + (2 * (machineRationalZeroEntry.length + + (rationalEntryBinaryCode R).length) + 2)) + 2) := by + let M := machineRationalZeroEntry.length + + (rationalEntryBinaryCode R).length + have hentry : βˆ€ i j : Fin d, + (rationalEntryBinaryCode + (rationalDiagonalPrefixMatrix d k R i j)).length ≀ M := by + intro i j + simp only [rationalDiagonalPrefixMatrix] + split + Β· omega + Β· change machineRationalZeroEntry.length ≀ M + omega + rw [rationalSquareMatrixRowsCode, binaryListCode_length_eq_sum] + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply] + calc + (βˆ‘ i : Fin d, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalDiagonalPrefixMatrix d k R i j)).length + + 2)) ≀ + βˆ‘ _i : Fin d, (2 * (d * (2 * M + 2)) + 2) := by + apply Finset.sum_le_sum + intro i _ + gcongr + rw [binaryListCode_length_eq_sum] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + calc + (βˆ‘ j : Fin d, + (2 * (rationalEntryBinaryCode + (rationalDiagonalPrefixMatrix d k R i j)).length + 2)) ≀ + βˆ‘ _j : Fin d, (2 * M + 2) := by + apply Finset.sum_le_sum + intro j _ + have he := hentry i j + omega + _ = d * (2 * M + 2) := by simp [mul_comm] + _ = d * (2 * (d * (2 * M + 2)) + 2) := by simp [mul_comm] + +theorem machineDiagonalBasis_prefix_fits + (d k : β„•) (R : β„š) : + (rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d k R)).length ≀ + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length := by + let W := (machineDiagonalBasisCanonicalInput d R).length + let Z := machineRationalZeroEntry.length + let L := (rationalEntryBinaryCode R).length + have hZ : Z = 5 := by + decide + have hW : W = 2 * d + 2 + L := by + simp [W, L, machineDiagonalBasisCanonicalInput] + have hL : 4 ≀ L := by + dsimp only [L, rationalEntryBinaryCode] + cases R.num <;> simp [integerBinaryCode] <;> omega + have hdW : d ≀ W := by omega + have hLW : L ≀ W := by omega + have hZW : Z ≀ W := by omega + have hM : Z + L ≀ 2 * W := by omega + have hinner : d * (2 * (Z + L) + 2) ≀ 6 * W ^ 2 := by + have hfactor : 2 * (Z + L) + 2 ≀ 6 * W := by + have hWpos : 1 ≀ W := by omega + omega + have hmul := Nat.mul_le_mul hdW hfactor + nlinarith + have hrow : 2 * (d * (2 * (Z + L) + 2)) + 2 ≀ + 14 * W ^ 2 := by + have hWpos : 1 ≀ W := by omega + nlinarith + have hcode : d * (2 * (d * (2 * (Z + L) + 2)) + 2) ≀ + 14 * W ^ 3 := by + have hmul := Nat.mul_le_mul hdW hrow + nlinarith + have hshift : W ≀ 16 + W := by omega + have hpow3 : W ^ 3 ≀ (16 + W) ^ 3 := + Nat.pow_le_pow_left hshift 3 + have h14 : 14 ≀ 16 + W := by omega + have hcubic : 14 * W ^ 3 ≀ (16 + W) ^ 4 := by + calc + 14 * W ^ 3 ≀ (16 + W) * (16 + W) ^ 3 := + Nat.mul_le_mul h14 hpow3 + _ = (16 + W) ^ 4 := by ring + have hbase : (16 + W) ^ 2 ≀ 16 + (16 + W) ^ 2 := by omega + have hquartic : (16 + W) ^ 4 ≀ + (16 + (16 + W) ^ 2) ^ 2 := by + rw [show (16 + W) ^ 4 = ((16 + W) ^ 2) ^ 2 by ring] + exact Nat.pow_le_pow_left hbase 2 + have hpref := rationalSquareMatrixRowsCode_diagonalPrefix_length_le + d k R + dsimp only [Z, L] at hpref hcode + calc + (rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d k R)).length ≀ + d * (2 * (d * + (2 * (machineRationalZeroEntry.length + + (rationalEntryBinaryCode R).length) + 2)) + 2) := hpref + _ ≀ 14 * W ^ 3 := hcode + _ ≀ (16 + W) ^ 4 := hcubic + _ ≀ (16 + (16 + W) ^ 2) ^ 2 := hquartic + _ = (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length := by + simp only [machineDiagonalBasisBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + rw [show (machineDiagonalBasisCanonicalInput d R).length = W by rfl] + ring + +theorem machineDiagonalBasisInit_semantics (d : β„•) (R : β„š) : + machineDiagonalBasisInit (machineDiagonalBasisCanonicalInput d R) = + machineDiagonalBasisCanonicalState d R 0 := by + have hfit := machineDiagonalBasis_prefix_fits d 0 R + have hzero : rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d 0 R) = + rationalSquareMatrixRowsCode (0 : Matrix (Fin d) (Fin d) β„š) := by + rw [rationalDiagonalPrefixMatrix_zero] + have htake : + (machineRationalZeroMatrixRowsCode (List.replicate d true)).take + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length = + rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d 0 R) := by + rw [machineRationalZeroMatrixRowsCode_encode, ← hzero] + exact List.take_of_length_le hfit + simp only [machineDiagonalBasisInit, machineDiagonalBasisCanonicalInput, + machineDiagonalBasisCanonicalState, machineDiagonalBasisRuler, + machineDiagonalBasisRadiusEntry, machinePairFirst_pair, + machinePairSecond_pair, machineDiagonalBasisInitialMatrix] + have htake' := htake + simp only [machineDiagonalBasisCanonicalInput] at htake' + rw [htake'] + simp + +theorem machineDiagonalBasisStep_semantics + (d k : β„•) (R : β„š) (hk : k < d) : + machineDiagonalBasisStep + (machineDiagonalBasisCanonicalState d R k) = + machineDiagonalBasisCanonicalState d R (k + 1) := by + let M := rationalMatrixRows (rationalDiagonalPrefixMatrix d k R) + have hrow : k < M.length := by simp [M, rationalMatrixRows, hk] + have hcol : k < M[k].length := by simp [M, rationalMatrixRows, hk] + have hupdate := machineNestedMatrixUpdateAtUnary_encode + rationalEntryBinaryCode M k k R hrow hcol + rw [rationalMatrixRows_diagonalPrefix_set R hk] at hupdate + have hmatrixFit := machineDiagonalBasis_prefix_fits d (k + 1) R + have hmatrixTake : + (machineDiagonalBasisMatrixCandidate + (machineDiagonalBasisCanonicalState d R k)).take + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length = + rationalSquareMatrixRowsCode + (rationalDiagonalPrefixMatrix d (k + 1) R) := by + rw [machineDiagonalBasisMatrixCandidate, + machineDiagonalBasisCanonicalState, + machineDiagonalBasisIndex_pack, machineDiagonalBasisMatrix_pack, + machineDiagonalBasisRadius_pack] + simpa only [rationalSquareMatrixRowsCode] using! + congrArg (fun word ↦ word.take + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length) hupdate |>.trans + (List.take_of_length_le hmatrixFit) + have hindexFit : k + 1 ≀ + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length := by + have hword := machineDiagonalBasis_word_length_le_bound + (machineDiagonalBasisCanonicalInput d R) + have hdim : d ≀ (machineDiagonalBasisCanonicalInput d R).length := by + simp only [machineDiagonalBasisCanonicalInput, pair_length, + List.length_replicate] + omega + exact (show k + 1 ≀ d by omega).trans (hdim.trans hword) + have hindexTake : + (true :: List.replicate k true).take + (machineDiagonalBasisBound + (machineDiagonalBasisCanonicalInput d R)).length = + List.replicate (k + 1) true := by + have hrep : List.replicate (k + 1) true = + true :: List.replicate k true := by + rw [List.replicate_succ] + rw [← hrep] + exact List.take_of_length_le (by simpa using! hindexFit) + simp only [machineDiagonalBasisStep, machineDiagonalBasisCanonicalState, + machineDiagonalBasisNextIndex, machineDiagonalBasisNextIndexCandidate, + machineDiagonalBasisIndex_pack, machineDiagonalBasisNextMatrix, + machineDiagonalBasisStateBound_pack, machineDiagonalBasisRadius_pack] + rw [hindexTake] + have hmatrixTake' := hmatrixTake + simp only [machineDiagonalBasisCanonicalState] at hmatrixTake' + rw [hmatrixTake'] + +theorem machineDiagonalBasisIterate_semantics + (d : β„•) (R : β„š) : βˆ€ k ≀ d, + (machineDiagonalBasisStep)^[k] + (machineDiagonalBasisInit + (machineDiagonalBasisCanonicalInput d R)) = + machineDiagonalBasisCanonicalState d R k := by + intro k hk + induction k with + | zero => exact machineDiagonalBasisInit_semantics d R + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineDiagonalBasisStep_semantics d k R (by omega) + +@[simp] theorem machineDiagonalBasisRowsCode_encode (d : β„•) (R : β„š) : + machineDiagonalBasisRowsCode (machineDiagonalBasisCanonicalInput d R) = + rationalSquareMatrixRowsCode + (rationalBallEllipsoid d 0 R).basis := by + have hstate := congrArg machineDiagonalBasisMatrix + (machineDiagonalBasisIterate_semantics d R d le_rfl) + rw [machineDiagonalBasisRowsCode, machineDiagonalBasisFinalState] + have hruler : + (machineDiagonalBasisRuler + (machineDiagonalBasisCanonicalInput d R)).length = d := by + simp [machineDiagonalBasisRuler, machineDiagonalBasisCanonicalInput] + rw [hruler] + rw [hstate] + simp only [machineDiagonalBasisCanonicalState, + machineDiagonalBasisMatrix_pack] + rw [rationalDiagonalPrefixMatrix_all] + +/-! ## Complete ball state -/ + +/-- Input: `pair dimensionUnary radiusEntryCode`. -/ +def machineRationalBallStateCode (word : List Bool) : List Bool := + pair (machineLengthBits (machineDiagonalBasisRuler word)) + (pair + (machineRationalZeroVectorCode (machineDiagonalBasisRuler word)) + (machineDiagonalBasisRowsCode word)) + +theorem machineRationalBallStateCode_mem_FP : + machineRationalBallStateCode ∈ FP := by + have hdim := machineCompose_mem_FP machineDiagonalBasisRuler_mem_FP + machineLengthBits_mem_FP + have hcenter := machineCompose_mem_FP machineDiagonalBasisRuler_mem_FP + machineRationalZeroVectorCode_mem_FP + simpa only [machineRationalBallStateCode] using! + machinePair_mem_FP hdim + (machinePair_mem_FP hcenter machineDiagonalBasisRowsCode_mem_FP) + +@[simp] theorem machineRationalBallStateCode_encode (d : β„•) (R : β„š) : + machineRationalBallStateCode (machineDiagonalBasisCanonicalInput d R) = + rationalEllipsoidStateBinaryCode + (rationalBallEllipsoid d 0 R) := by + rw [machineRationalBallStateCode] + simp only [machineDiagonalBasisRuler, + machineDiagonalBasisCanonicalInput, machinePairFirst_pair, + machineLengthBits_encode, List.length_replicate, + machineRationalZeroVectorCode_encode, + rationalEllipsoidStateBinaryCode, rationalBallEllipsoid_center] + change pair d.bits + (pair (rationalFiniteVectorCode (fun _ : Fin d ↦ (0 : β„š))) + (machineDiagonalBasisRowsCode + (machineDiagonalBasisCanonicalInput d R))) = _ + rw [machineDiagonalBasisRowsCode_encode] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalCompare.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalCompare.lean new file mode 100644 index 0000000000..b8bbfa03f6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalCompare.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic + +/-! +# Polynomial-time comparison of unreduced rationals + +Positive denominators allow comparison by signed cross multiplication. The +two cross-products are exactly the products already used by rational addition; +the final comparison is the verified signed-integer machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Compares raw rationals by comparing their signed cross-multiplied numerators. -/ +def machineRawRatLeBit (word : List Bool) : List Bool := + machineIntegerLeCode + (pair (machineRawAddLeftScaledNumerator word) + (machineRawAddRightScaledNumerator word)) + +theorem machineRawRatLeBit_mem_FP : machineRawRatLeBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineRawAddLeftScaledNumerator_mem_FP + machineRawAddRightScaledNumerator_mem_FP + simpa only [machineRawRatLeBit] using! + machineCompose_mem_FP hpair machineIntegerLeCode_mem_FP + +theorem machineRawRatLeBit_cross_encode (q r : RawRat) : + machineRawRatLeBit + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + [decide + (q.num * (r.den : β„€) ≀ r.num * (q.den : β„€))] := by + rw [machineRawRatLeBit, machineRawAddLeftScaledNumerator_encode, + machineRawAddRightScaledNumerator_encode, + machineIntegerLeCode_encode] + +theorem rawRat_value_le_iff_cross (q r : RawRat) : + q.value ≀ r.value ↔ + q.num * (r.den : β„€) ≀ r.num * (q.den : β„€) := by + constructor + Β· intro h + have hdiv : (q.num : β„š) / (q.den : β„š) ≀ + (r.num : β„š) / (r.den : β„š) := by + simpa only [RawRat.value] using! h + have hcross := + (div_le_div_iffβ‚€ (by exact_mod_cast q.den_pos : (0 : β„š) < q.den) + (by exact_mod_cast r.den_pos : (0 : β„š) < r.den)).1 hdiv + exact_mod_cast hcross + Β· intro h + have hcross : (q.num : β„š) * (r.den : β„š) ≀ + (r.num : β„š) * (q.den : β„š) := by + exact_mod_cast h + have hdiv : (q.num : β„š) / (q.den : β„š) ≀ + (r.num : β„š) / (r.den : β„š) := + (div_le_div_iffβ‚€ (by exact_mod_cast q.den_pos : (0 : β„š) < q.den) + (by exact_mod_cast r.den_pos : (0 : β„š) < r.den)).2 hcross + simpa only [RawRat.value] using! hdiv + +theorem machineRawRatLeBit_encode (q r : RawRat) : + machineRawRatLeBit + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + [decide (q.value ≀ r.value)] := by + rw [machineRawRatLeBit_cross_encode] + by_cases hcross : q.num * (r.den : β„€) ≀ r.num * (q.den : β„€) + Β· have hvalue := (rawRat_value_le_iff_cross q r).2 hcross + simp [hcross, hvalue] + Β· have hvalue : Β¬ q.value ≀ r.value := by + exact fun h => hcross ((rawRat_value_le_iff_cross q r).1 h) + simp [hcross, hvalue] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateMatrix.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateMatrix.lean new file mode 100644 index 0000000000..f3f6603473 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateMatrix.lean @@ -0,0 +1,838 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateRow +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMul + +/-! +# Polynomial-time direction-update matrices + +This module maps the verified row constructor over all row indices. The +result is the full rational matrix used to update an ellipsoid basis. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Constructs the rational direction-update matrix using the dimension-dependent perpendicular +and parallel ellipsoid scales. -/ +def rationalDirectionUpdateMatrix {d : β„•} (b : Fin d β†’ β„š) : + Matrix (Fin d) (Fin d) β„š := + directionUpdateMatrix (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b + +/-- Encodes the direction dimension in both unary and binary followed by the rational direction +vector. -/ +def rationalDirectionUpdateCanonicalWord {d : β„•} + (b : Fin d β†’ β„š) : List Bool := + pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)) + +/-- Returns the raw perpendicular scale on the diagonal and raw zero off the diagonal. -/ +def rawDirectionDiagonalEntry {d : β„•} (i j : Fin d) : RawRat := + if i = j then rawEllipsoidPerpScale d else RawRat.zero + +/-- Subtracts the raw rank-one correction from the scaled diagonal entry to form a +direction-update matrix coefficient. -/ +def rawDirectionMatrixEntry {d : β„•} + (b : Fin d β†’ β„š) (i j : Fin d) : RawRat := + (rawDirectionDiagonalEntry i j).sub + ((rawDirectionRowScale b i).mul (rawRatOfRat (b j))) + +@[simp] theorem rawDirectionDiagonalEntry_value {d : β„•} + (i j : Fin d) : + (rawDirectionDiagonalEntry i j).value = + if i = j then rationalEllipsoidPerpScale d else 0 := by + by_cases h : i = j + Β· simp [rawDirectionDiagonalEntry, h] + Β· simp [rawDirectionDiagonalEntry, h] + +@[simp] theorem rawDirectionMatrixEntry_value {d : β„•} + (b : Fin d β†’ β„š) (i j : Fin d) : + (rawDirectionMatrixEntry b i j).value = + rationalDirectionUpdateMatrix b i j := by + simp [rawDirectionMatrixEntry, rationalDirectionUpdateMatrix, + directionUpdateMatrix, sub_eq_add_neg] + +theorem rawEllipsoidDimension_width_le_direction_word {d : β„•} + (b : Fin d β†’ β„š) : + rawRatWidth (rawEllipsoidDimension d) ≀ + (rationalDirectionUpdateCanonicalWord b).length := by + have hsmall : rawRatWidth (rawEllipsoidDimension d) ≀ d + 1 := by + simp [rawEllipsoidDimension, RawRat.ofNat, rawRatWidth] + rw [Nat.size_le] + have h := @Nat.lt_two_pow_self (d + 1) + omega + simp only [rationalDirectionUpdateCanonicalWord, pair_length, + List.length_replicate] at hsmall ⊒ + omega + +theorem rawDirection_b_width_le_word {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + rawRatWidth (rawRatOfRat (b i)) ≀ + (rationalDirectionUpdateCanonicalWord b).length := by + have hcanonical := rawRatWidth_le_binaryCode_length (rawRatOfRat (b i)) + have helem := binaryListCode_element_length_le rationalEntryBinaryCode + (show b i ∈ List.ofFn b by simp) + have hvector : + (rationalEntryBinaryCode (b i)).length ≀ + (rationalFiniteVectorCode b).length := by + simpa only [rationalFiniteVectorCode] using! helem + rw [rawRatBinaryCode_rawRatOfRat] at hcanonical + exact hcanonical.trans (hvector.trans (by + change (rationalFiniteVectorCode b).length ≀ + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b))).length + rw [pair_length, pair_length] + omega)) + +theorem rawDirectionNormSq_width_le_word {d : β„•} + (b : Fin d β†’ β„š) : + rawRatWidth (rawDirectionNormSq b) ≀ + 1 + 2 * (rationalDirectionUpdateCanonicalWord b).length := by + let xs := List.ofFn b + have hwidth := rawRatWidth_listDot_le RawRat.zero xs xs + have hcost := rawRatListDotCost_le_codeLength xs xs + have hcode : + (binaryListCode rationalEntryBinaryCode xs).length ≀ + (rationalDirectionUpdateCanonicalWord b).length := by + simp only [xs, rationalFiniteVectorCode, + rationalDirectionUpdateCanonicalWord, pair_length, + List.length_replicate] + omega + change rawRatWidth (rawRatListDot RawRat.zero xs xs) ≀ _ + rw [rawRatWidth_zero] at hwidth + omega + +theorem rawEllipsoidPerpScale_width_le_direction_word {d : β„•} + (b : Fin d β†’ β„š) : + rawRatWidth (rawEllipsoidPerpScale d) ≀ + 12 + 4 * (rationalDirectionUpdateCanonicalWord b).length := by + let W := (rationalDirectionUpdateCanonicalWord b).length + have hd := rawEllipsoidDimension_width_le_direction_word b + have hdsq := rawRatWidth_mul_le + (rawEllipsoidDimension d) (rawEllipsoidDimension d) + have hfour := rawRatWidth_mul_le rawEllipsoidFour + (rawEllipsoidDimensionSquare d) + have halpha := rawRatWidth_div_le rawEllipsoidOne + (rawEllipsoidFourDimensionSquare d) + have halphaSq := rawRatWidth_mul_le + (rawEllipsoidAlpha d) (rawEllipsoidAlpha d) + have htwice := rawRatWidth_mul_le rawEllipsoidTwo + (rawEllipsoidAlphaSquare d) + have hperp := rawRatWidth_add_le rawEllipsoidOne + (rawEllipsoidTwiceAlphaSquare d) + have hone : rawRatWidth rawEllipsoidOne = 1 := by rfl + have htwo : rawRatWidth rawEllipsoidTwo = 2 := by rfl + have hfourWidth : rawRatWidth rawEllipsoidFour = 3 := by rfl + have hd' : rawRatWidth (rawEllipsoidDimension d) ≀ W := by + simpa only [W] using! hd + have hdsq0 : rawRatWidth (rawEllipsoidDimensionSquare d) ≀ + rawRatWidth (rawEllipsoidDimension d) + + rawRatWidth (rawEllipsoidDimension d) := by + simpa only [rawEllipsoidDimensionSquare] using! hdsq + have hdsq' : rawRatWidth (rawEllipsoidDimensionSquare d) ≀ 2 * W := by + omega + have hfour' : rawRatWidth (rawEllipsoidFourDimensionSquare d) ≀ + 3 + 2 * W := by + have hfour0 : rawRatWidth (rawEllipsoidFourDimensionSquare d) ≀ + rawRatWidth rawEllipsoidFour + + rawRatWidth (rawEllipsoidDimensionSquare d) := by + simpa only [rawEllipsoidFourDimensionSquare] using! hfour + omega + have halpha' : rawRatWidth (rawEllipsoidAlpha d) ≀ 4 + 2 * W := by + have halpha0 : rawRatWidth (rawEllipsoidAlpha d) ≀ + rawRatWidth rawEllipsoidOne + + rawRatWidth (rawEllipsoidFourDimensionSquare d) := by + simpa only [rawEllipsoidAlpha] using! halpha + omega + have halphaSq' : rawRatWidth (rawEllipsoidAlphaSquare d) ≀ + 8 + 4 * W := by + have halphaSq0 : rawRatWidth (rawEllipsoidAlphaSquare d) ≀ + rawRatWidth (rawEllipsoidAlpha d) + + rawRatWidth (rawEllipsoidAlpha d) := by + simpa only [rawEllipsoidAlphaSquare] using! halphaSq + omega + have htwice' : rawRatWidth (rawEllipsoidTwiceAlphaSquare d) ≀ + 10 + 4 * W := by + have htwice0 : rawRatWidth (rawEllipsoidTwiceAlphaSquare d) ≀ + rawRatWidth rawEllipsoidTwo + + rawRatWidth (rawEllipsoidAlphaSquare d) := by + simpa only [rawEllipsoidTwiceAlphaSquare] using! htwice + omega + have hperp' : rawRatWidth (rawEllipsoidPerpScale d) ≀ 12 + 4 * W := by + have hperp0 : rawRatWidth (rawEllipsoidPerpScale d) ≀ + rawRatWidth rawEllipsoidOne + + rawRatWidth (rawEllipsoidTwiceAlphaSquare d) + 1 := by + simpa only [rawEllipsoidPerpScale] using! hperp + omega + simpa only [W] using! hperp' + +theorem rawEllipsoidParallelScale_width_le_direction_word {d : β„•} + (b : Fin d β†’ β„š) : + rawRatWidth (rawEllipsoidParallelScale d) ≀ + 6 + 3 * (rationalDirectionUpdateCanonicalWord b).length := by + let W := (rationalDirectionUpdateCanonicalWord b).length + have hd := rawEllipsoidDimension_width_le_direction_word b + have hdsq := rawRatWidth_mul_le + (rawEllipsoidDimension d) (rawEllipsoidDimension d) + have hfour := rawRatWidth_mul_le rawEllipsoidFour + (rawEllipsoidDimensionSquare d) + have halpha := rawRatWidth_div_le rawEllipsoidOne + (rawEllipsoidFourDimensionSquare d) + have hover := rawRatWidth_div_le (rawEllipsoidAlpha d) + (rawEllipsoidDimension d) + have hparallel := rawRatWidth_sub_le rawEllipsoidOne + (rawEllipsoidAlphaOverDimension d) + have hone : rawRatWidth rawEllipsoidOne = 1 := by rfl + have hfourWidth : rawRatWidth rawEllipsoidFour = 3 := by rfl + have hd' : rawRatWidth (rawEllipsoidDimension d) ≀ W := by + simpa only [W] using! hd + have hdsq0 : rawRatWidth (rawEllipsoidDimensionSquare d) ≀ + rawRatWidth (rawEllipsoidDimension d) + + rawRatWidth (rawEllipsoidDimension d) := by + simpa only [rawEllipsoidDimensionSquare] using! hdsq + have hdsq' : rawRatWidth (rawEllipsoidDimensionSquare d) ≀ 2 * W := by + omega + have hfour' : rawRatWidth (rawEllipsoidFourDimensionSquare d) ≀ + 3 + 2 * W := by + have hfour0 : rawRatWidth (rawEllipsoidFourDimensionSquare d) ≀ + rawRatWidth rawEllipsoidFour + + rawRatWidth (rawEllipsoidDimensionSquare d) := by + simpa only [rawEllipsoidFourDimensionSquare] using! hfour + omega + have halpha' : rawRatWidth (rawEllipsoidAlpha d) ≀ 4 + 2 * W := by + have halpha0 : rawRatWidth (rawEllipsoidAlpha d) ≀ + rawRatWidth rawEllipsoidOne + + rawRatWidth (rawEllipsoidFourDimensionSquare d) := by + simpa only [rawEllipsoidAlpha] using! halpha + omega + have hover' : rawRatWidth (rawEllipsoidAlphaOverDimension d) ≀ + 4 + 3 * W := by + have hover0 : rawRatWidth (rawEllipsoidAlphaOverDimension d) ≀ + rawRatWidth (rawEllipsoidAlpha d) + + rawRatWidth (rawEllipsoidDimension d) := by + simpa only [rawEllipsoidAlphaOverDimension] using! hover + omega + have hparallel' : rawRatWidth (rawEllipsoidParallelScale d) ≀ + 6 + 3 * W := by + have hparallel0 : rawRatWidth (rawEllipsoidParallelScale d) ≀ + rawRatWidth rawEllipsoidOne + + rawRatWidth (rawEllipsoidAlphaOverDimension d) + 1 := by + simpa only [rawEllipsoidParallelScale] using! hparallel + omega + simpa only [W] using! hparallel' + +theorem rawDirectionMatrixEntry_width_le_word {d : β„•} + (b : Fin d β†’ β„š) (i j : Fin d) : + rawRatWidth (rawDirectionMatrixEntry b i j) ≀ + 33 + 15 * (rationalDirectionUpdateCanonicalWord b).length := by + let W := (rationalDirectionUpdateCanonicalWord b).length + have hperp := rawEllipsoidPerpScale_width_le_direction_word b + have hparallel := rawEllipsoidParallelScale_width_le_direction_word b + have hnorm := rawDirectionNormSq_width_le_word b + have hbi := rawDirection_b_width_le_word b i + have hbj := rawDirection_b_width_le_word b j + have hperp' : rawRatWidth (rawEllipsoidPerpScale d) ≀ 12 + 4 * W := by + simpa only [W] using! hperp + have hparallel' : rawRatWidth (rawEllipsoidParallelScale d) ≀ + 6 + 3 * W := by simpa only [W] using! hparallel + have hnorm' : rawRatWidth (rawDirectionNormSq b) ≀ 1 + 2 * W := by + simpa only [W] using! hnorm + have hbi' : rawRatWidth (rawRatOfRat (b i)) ≀ W := by + simpa only [W] using! hbi + have hbj' : rawRatWidth (rawRatOfRat (b j)) ≀ W := by + simpa only [W] using! hbj + have hgap' : rawRatWidth (rawDirectionGap d) ≀ 19 + 7 * W := by + calc + _ = rawRatWidth ((rawEllipsoidPerpScale d).sub + (rawEllipsoidParallelScale d)) := rfl + _ ≀ rawRatWidth (rawEllipsoidPerpScale d) + + rawRatWidth (rawEllipsoidParallelScale d) + 1 := + rawRatWidth_sub_le _ _ + _ ≀ 19 + 7 * W := by omega + have hcoeff' : rawRatWidth (rawDirectionCoefficient b) ≀ + 20 + 9 * W := by + calc + _ = rawRatWidth ((rawDirectionGap d).div + (rawDirectionNormSq b)) := rfl + _ ≀ rawRatWidth (rawDirectionGap d) + + rawRatWidth (rawDirectionNormSq b) := rawRatWidth_div_le _ _ + _ ≀ 20 + 9 * W := by omega + have hrowScale' : rawRatWidth (rawDirectionRowScale b i) ≀ + 20 + 10 * W := by + calc + _ = rawRatWidth ((rawDirectionCoefficient b).mul + (rawRatOfRat (b i))) := rfl + _ ≀ rawRatWidth (rawDirectionCoefficient b) + + rawRatWidth (rawRatOfRat (b i)) := rawRatWidth_mul_le _ _ + _ ≀ 20 + 10 * W := by omega + have hproduct' : rawRatWidth + ((rawDirectionRowScale b i).mul (rawRatOfRat (b j))) ≀ + 20 + 11 * W := by + exact (rawRatWidth_mul_le _ _).trans (by omega) + have hdiag : rawRatWidth (rawDirectionDiagonalEntry i j) ≀ + 12 + 4 * W := by + by_cases hij : i = j + Β· simpa only [rawDirectionDiagonalEntry, hij, if_true] using! hperp + Β· simp only [rawDirectionDiagonalEntry, hij, ite_false, rawRatWidth_zero] + omega + calc + _ = rawRatWidth ((rawDirectionDiagonalEntry i j).sub + ((rawDirectionRowScale b i).mul (rawRatOfRat (b j)))) := rfl + _ ≀ rawRatWidth (rawDirectionDiagonalEntry i j) + + rawRatWidth ((rawDirectionRowScale b i).mul + (rawRatOfRat (b j))) + 1 := rawRatWidth_sub_le _ _ + _ ≀ 33 + 15 * W := by omega + +theorem rationalDirectionMatrix_entry_code_length_le {d : β„•} + (b : Fin d β†’ β„š) (i j : Fin d) : + (rationalEntryBinaryCode (rationalDirectionUpdateMatrix b i j)).length ≀ + 1252 + 540 * (rationalDirectionUpdateCanonicalWord b).length := by + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (rawDirectionMatrixEntry b i j) + rw [binaryNormalizeRawRat_eq_value, + rawDirectionMatrixEntry_value] at hcanonical + have hwidth := rawDirectionMatrixEntry_width_le_word b i j + exact hcanonical.trans (by nlinarith) + +/-- Reuses the rational transpose-vector input bound for direction-update matrix generation. -/ +def machineRationalDirectionUpdateMatrixInputBound + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineRationalDirectionUpdateMatrixInputBound_mem_FP : + machineRationalDirectionUpdateMatrixInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem rationalDirectionUpdateMatrix_code_length_le_cubic {d : β„•} + (b : Fin d β†’ β„š) : + (rationalSquareMatrixRowsCode + (rationalDirectionUpdateMatrix b)).length ≀ + d * (2 * (d * + (2 * (1252 + 540 * + (rationalDirectionUpdateCanonicalWord b).length) + 2)) + 2) := by + let L := 1252 + 540 * (rationalDirectionUpdateCanonicalWord b).length + have hentry : βˆ€ i j : Fin d, + (rationalEntryBinaryCode + (rationalDirectionUpdateMatrix b i j)).length ≀ L := by + intro i j + exact rationalDirectionMatrix_entry_code_length_le b i j + rw [rationalSquareMatrixRowsCode, binaryListCode_length_eq_sum] + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply] + calc + (βˆ‘ i : Fin d, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j)).length + + 2)) ≀ + βˆ‘ _i : Fin d, (2 * (d * (2 * L + 2)) + 2) := by + apply Finset.sum_le_sum + intro i _ + gcongr + rw [binaryListCode_length_eq_sum] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + calc + (βˆ‘ j : Fin d, + (2 * (rationalEntryBinaryCode + (rationalDirectionUpdateMatrix b i j)).length + 2)) ≀ + βˆ‘ _j : Fin d, (2 * L + 2) := by + apply Finset.sum_le_sum + intro j _ + have h := hentry i j + omega + _ = d * (2 * L + 2) := by simp + _ = d * (2 * (d * (2 * L + 2)) + 2) := by simp + +theorem rationalDirectionUpdateMatrix_code_length_le_bound {d : β„•} + (b : Fin d β†’ β„š) : + (rationalSquareMatrixRowsCode + (rationalDirectionUpdateMatrix b)).length ≀ + (machineRationalDirectionUpdateMatrixInputBound + (rationalDirectionUpdateCanonicalWord b)).length := by + let word := rationalDirectionUpdateCanonicalWord b + let n := word.length + let x := 16 + n + let y := 16 + x ^ 2 + let z := 16 + y ^ 2 + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalDirectionUpdateCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hn4 : 4 ≀ n := by + simp only [n, word, rationalDirectionUpdateCanonicalWord, + pair_length, List.length_replicate] + omega + have hcubic := rationalDirectionUpdateMatrix_code_length_le_cubic b + have hd' : d ≀ n := by simpa only [n] using! hd + have hdn : d * n ≀ n * n := Nat.mul_le_mul hd' le_rfl + have hdd : d * d ≀ n * n := Nat.mul_le_mul hd' hd' + have hddn : (d * d) * n ≀ (n * n) * n := + Nat.mul_le_mul hdd le_rfl + have hpoly : + d * (2 * (d * (2 * (1252 + 540 * n) + 2)) + 2) ≀ + 4000 * n ^ 3 := by + nlinarith + have hout : + (rationalSquareMatrixRowsCode + (rationalDirectionUpdateMatrix b)).length ≀ 4000 * n ^ 3 := by + apply hcubic.trans + simpa only [n, word] using! hpoly + have hnx : n ≀ x := by simp [x] + have hxpos : 0 < x := by omega + have h4000 : 4000 ≀ x ^ 3 := by + dsimp only [x] + nlinarith + have hnx3 : n ^ 3 ≀ x ^ 3 := Nat.pow_le_pow_left hnx 3 + have hto6 : 4000 * n ^ 3 ≀ x ^ 6 := by + have h := Nat.mul_le_mul h4000 hnx3 + simpa only [← pow_add] using! h + have hto8 : x ^ 6 ≀ x ^ 8 := + Nat.pow_le_pow_right hxpos (by omega) + have hxy : x ^ 2 ≀ y := by simp [y] + have hx4y2 : x ^ 4 ≀ y ^ 2 := by + have h := Nat.pow_le_pow_left hxy 2 + simpa only [← pow_mul] using! h + have hyz : y ^ 2 ≀ z := by simp [z] + have hx4z : x ^ 4 ≀ z := hx4y2.trans hyz + have hx8z2 : x ^ 8 ≀ z ^ 2 := by + have h := Nat.pow_le_pow_left hx4z 2 + simpa only [← pow_mul] using! h + apply hout.trans + apply hto6.trans + apply hto8.trans + apply hx8z2.trans_eq + simp only [machineRationalDirectionUpdateMatrixInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, n, x, y, z, word, pow_two] + +/-! ## Bounded outer row scan -/ + +/-- Builds the complete encoded row-index range from the unary direction dimension. -/ +def machineRationalDirectionUpdateMatrixIndices + (word : List Bool) : List Bool := + machineUnaryRangeCode (machinePairFirst word) + +/-- Computes the direction-update row at the current row index using the fixed request payload. -/ +def machineRationalDirectionUpdateMatrixCurrentRow + (state : List Bool) : List Bool := + machineRationalDirectionUpdateRowCode + (pair (machineRationalTransposeMulVectorCurrentIndex state) + (machineRationalTransposeMulVectorStatePayload state)) + +/-- Prepends the newly computed direction-update row to the reverse-order matrix accumulator. -/ +def machineRationalDirectionUpdateMatrixCandidate + (state : List Bool) : List Bool := + pair (machineRationalDirectionUpdateMatrixCurrentRow state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate matrix accumulator to the stored bound length. -/ +def machineRationalDirectionUpdateMatrixNextAccumulator + (state : List Bool) : List Bool := + (machineRationalDirectionUpdateMatrixCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Drops the completed row index and stores the bounded updated matrix accumulator. -/ +def machineRationalDirectionUpdateMatrixAdvance + (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineRationalDirectionUpdateMatrixNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Fixes direction-matrix generation when no indices remain and otherwise computes its next +row. -/ +def machineRationalDirectionUpdateMatrixStep + (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineRationalDirectionUpdateMatrixAdvance state) + +/-- Initializes direction-matrix generation with all row indices, empty accumulator, fixed +request, and computed bound. -/ +def machineRationalDirectionUpdateMatrixInit + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineRationalDirectionUpdateMatrixIndices word) [] word + (machineRationalDirectionUpdateMatrixInputBound word) + +/-- Packs four copies of the computed bound to bound the direction-matrix generation state. -/ +def machineRationalDirectionUpdateMatrixWidth + (word : List Bool) : List Bool := + let bound := machineRationalDirectionUpdateMatrixInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs direction-matrix generation once per input bit from its initial state. -/ +def machineRationalDirectionUpdateMatrixFinalState + (word : List Bool) : List Bool := + (machineRationalDirectionUpdateMatrixStep)^[word.length] + (machineRationalDirectionUpdateMatrixInit word) + +/-- Extracts the generated rows in reverse order from the final matrix-generation state. -/ +def machineRationalDirectionUpdateMatrixReversedCode + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineRationalDirectionUpdateMatrixFinalState word) + +/-- Input: `pair dimensionUnary (pair dimensionBits vectorCode)`. -/ +def machineRationalDirectionUpdateMatrixCode + (word : List Bool) : List Bool := + machineListReverse + (machineRationalDirectionUpdateMatrixReversedCode word) + +theorem machineRationalDirectionUpdateMatrixIndices_mem_FP : + machineRationalDirectionUpdateMatrixIndices ∈ FP := by + simpa only [machineRationalDirectionUpdateMatrixIndices] using! + machineCompose_mem_FP machinePairFirst_mem_FP + machineUnaryRangeCode_mem_FP + +theorem machineRationalDirectionUpdateMatrixCurrentRow_mem_FP : + machineRationalDirectionUpdateMatrixCurrentRow ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalTransposeMulVectorCurrentIndex_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + simpa only [machineRationalDirectionUpdateMatrixCurrentRow] using! + machineCompose_mem_FP hinput + machineRationalDirectionUpdateRowCode_mem_FP + +theorem machineRationalDirectionUpdateMatrixCandidate_mem_FP : + machineRationalDirectionUpdateMatrixCandidate ∈ FP := + machinePair_mem_FP machineRationalDirectionUpdateMatrixCurrentRow_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalDirectionUpdateMatrixNextAccumulator_mem_FP : + machineRationalDirectionUpdateMatrixNextAccumulator ∈ FP := by + simpa only [machineRationalDirectionUpdateMatrixNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineRationalDirectionUpdateMatrixCandidate_mem_FP + +theorem machineRationalDirectionUpdateMatrixAdvance_mem_FP : + machineRationalDirectionUpdateMatrixAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP + machineRationalDirectionUpdateMatrixNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineRationalDirectionUpdateMatrixStep_mem_FP : + machineRationalDirectionUpdateMatrixStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineRationalDirectionUpdateMatrixAdvance_mem_FP + +theorem machineRationalDirectionUpdateMatrixInit_mem_FP : + machineRationalDirectionUpdateMatrixInit ∈ FP := by + exact machinePair_mem_FP + machineRationalDirectionUpdateMatrixIndices_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP id_mem_FP + machineRationalDirectionUpdateMatrixInputBound_mem_FP)) + +theorem machineRationalDirectionUpdateMatrixWidth_mem_FP : + machineRationalDirectionUpdateMatrixWidth ∈ FP := by + have hbound := machineRationalDirectionUpdateMatrixInputBound_mem_FP + exact machinePair_mem_FP hbound + (machinePair_mem_FP hbound (machinePair_mem_FP hbound hbound)) + +theorem machineRationalDirectionUpdateMatrixInit_bound + (word : List Bool) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalDirectionUpdateMatrixInit word) := by + simp only [MachineRationalTransposeMulVectorStateBound, + machineRationalDirectionUpdateMatrixInit, + machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalDirectionUpdateMatrixInputBound] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineRationalDirectionUpdateMatrixIndices, + machineRationalTransposeMulVectorIndices, + machineRationalTransposeMulVectorDimension] using! + machineRationalTransposeMulVector_indices_le_bound word + Β· exact machineRationalTransposeMulVector_word_le_bound word + +theorem machineRationalDirectionUpdateMatrixStep_bound + {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalDirectionUpdateMatrixStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineRationalDirectionUpdateMatrixStep, hnil, + machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineRationalDirectionUpdateMatrixStep, hcode, + machineIfEmpty_cons, + machineRationalDirectionUpdateMatrixAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineRationalDirectionUpdateMatrixNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalDirectionUpdateMatrixIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineRationalDirectionUpdateMatrixStep)^[k] + (machineRationalDirectionUpdateMatrixInit word)) := by + intro k + induction k with + | zero => exact machineRationalDirectionUpdateMatrixInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalDirectionUpdateMatrixStep_bound ih + +theorem machineRationalDirectionUpdateMatrixIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalDirectionUpdateMatrixStep)^[iterations] + (machineRationalDirectionUpdateMatrixInit word)).length ≀ + (machineRationalDirectionUpdateMatrixWidth word).length := by + rcases machineRationalDirectionUpdateMatrixIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineRationalDirectionUpdateMatrixWidth, + machineRationalDirectionUpdateMatrixInputBound, pair_length] + omega + +theorem machineRationalDirectionUpdateMatrixFinalState_mem_FP : + machineRationalDirectionUpdateMatrixFinalState ∈ FP := by + exact Cobham.iterate_mem_FP + machineRationalDirectionUpdateMatrixStep_mem_FP + machineRationalDirectionUpdateMatrixInit_mem_FP id_mem_FP + machineRationalDirectionUpdateMatrixWidth_mem_FP + machineRationalDirectionUpdateMatrixIterate_length_le_width + +theorem machineRationalDirectionUpdateMatrixReversedCode_mem_FP : + machineRationalDirectionUpdateMatrixReversedCode ∈ FP := by + simpa only [machineRationalDirectionUpdateMatrixReversedCode] using! + machineCompose_mem_FP + machineRationalDirectionUpdateMatrixFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalDirectionUpdateMatrixCode_mem_FP : + machineRationalDirectionUpdateMatrixCode ∈ FP := by + simpa only [machineRationalDirectionUpdateMatrixCode] using! + machineCompose_mem_FP + machineRationalDirectionUpdateMatrixReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact scan semantics -/ + +/-- Lists the first `k` rows of the rational direction-update matrix in finite-index order. -/ +def rationalDirectionUpdateRowsPrefix {d : β„•} + (b : Fin d β†’ β„š) (k : β„•) : List (List β„š) := + ((List.finRange d).take k).map + fun i ↦ List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j + +/-- Encodes the remaining row indices and reversed generated row prefix after `k` rows, +preserving request and bound. -/ +def machineRationalDirectionUpdateMatrixSemanticState {d : β„•} + (b : Fin d β†’ β„š) (k : β„•) : List Bool := + let word := rationalDirectionUpdateCanonicalWord b + machineRationalTransposeMulVectorPack + (binaryListCode finUnaryCode ((List.finRange d).drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalDirectionUpdateRowsPrefix b k).reverse) + word (machineRationalDirectionUpdateMatrixInputBound word) + +theorem machineRationalDirectionUpdateMatrixInit_semantics {d : β„•} + (b : Fin d β†’ β„š) : + machineRationalDirectionUpdateMatrixInit + (rationalDirectionUpdateCanonicalWord b) = + machineRationalDirectionUpdateMatrixSemanticState b 0 := by + simp [machineRationalDirectionUpdateMatrixInit, + machineRationalDirectionUpdateMatrixSemanticState, + machineRationalDirectionUpdateMatrixIndices, + rationalDirectionUpdateCanonicalWord, + machineUnaryRangeCode_encode, finRangeUnaryCode, + rationalDirectionUpdateRowsPrefix, binaryListCode] + +theorem rationalDirectionUpdateRowsPrefix_succ {d : β„•} + (b : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + rationalDirectionUpdateRowsPrefix b (k + 1) = + rationalDirectionUpdateRowsPrefix b k ++ + [List.ofFn fun j ↦ rationalDirectionUpdateMatrix b ⟨k, hk⟩ j] := by + simp only [rationalDirectionUpdateRowsPrefix, List.map_take] + have hkm : k < (List.finRange d).length := by simpa + simpa [List.getElem_finRange] using! + congrArg (List.map fun i ↦ + List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j) + (List.take_concat_get hkm).symm + +theorem machineRationalDirectionUpdateMatrixStep_semantics {d : β„•} + (b : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + machineRationalDirectionUpdateMatrixStep + (machineRationalDirectionUpdateMatrixSemanticState b k) = + machineRationalDirectionUpdateMatrixSemanticState b (k + 1) := by + let word := rationalDirectionUpdateCanonicalWord b + let i : Fin d := ⟨k, hk⟩ + have hdrop : + (List.finRange d).drop k = + i :: (List.finRange d).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.finRange d).length by simpa) using 1 + simp [i, List.getElem_finRange] + have hprefix := rationalDirectionUpdateRowsPrefix_succ b k hk + have hreverse : + (rationalDirectionUpdateRowsPrefix b (k + 1)).reverse = + (List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j) :: + (rationalDirectionUpdateRowsPrefix b k).reverse := by + rw [hprefix, List.reverse_append] + simp [i] + have hcand : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalDirectionUpdateRowsPrefix b (k + 1)).reverse).length ≀ + (machineRationalDirectionUpdateMatrixInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (rationalDirectionUpdateMatrix b)) (k + 1) + have hprefixEq : rationalDirectionUpdateRowsPrefix b (k + 1) = + (rationalMatrixRows + (rationalDirectionUpdateMatrix b)).take (k + 1) := by + apply List.ext_getElem + Β· simp [rationalDirectionUpdateRowsPrefix, rationalMatrixRows] + Β· intro r hrLeft hrRight + simp [rationalDirectionUpdateRowsPrefix, rationalMatrixRows, + List.getElem_finRange] + rw [hprefixEq] + exact hprefixBound.trans + (rationalDirectionUpdateMatrix_code_length_le_bound b) + have hcandPair : + (pair + (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalDirectionUpdateRowsPrefix b k).reverse)).length ≀ + (machineRationalDirectionUpdateMatrixInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode finUnaryCode ((List.finRange d).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil finUnaryCode i + ((List.finRange d).drop (k + 1)) + rw [machineRationalDirectionUpdateMatrixStep] + simp only [machineRationalDirectionUpdateMatrixSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalDirectionUpdateMatrixAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalDirectionUpdateMatrixNextAccumulator, + machineRationalDirectionUpdateMatrixCandidate, + machineRationalDirectionUpdateMatrixCurrentRow, + machineRationalTransposeMulVectorCurrentIndex] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineRationalDirectionUpdateRowCode + (pair (finUnaryCode i) word)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalDirectionUpdateRowsPrefix b k).reverse)).take + (machineRationalDirectionUpdateMatrixInputBound word).length) _ _ = _ + dsimp only [word, rationalDirectionUpdateCanonicalWord] + rw [show finUnaryCode i = List.replicate i.1 true by rfl, + machineRationalDirectionUpdateRowCode_encode] + change machineRationalTransposeMulVectorPack _ + ((pair (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalDirectionUpdateMatrix b i j)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalDirectionUpdateRowsPrefix b k).reverse)).take + (machineRationalDirectionUpdateMatrixInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineRationalDirectionUpdateMatrixIterate_semantics {d : β„•} + (b : Fin d β†’ β„š) : βˆ€ k ≀ d, + (machineRationalDirectionUpdateMatrixStep)^[k] + (machineRationalDirectionUpdateMatrixInit + (rationalDirectionUpdateCanonicalWord b)) = + machineRationalDirectionUpdateMatrixSemanticState b k := by + intro k hk + induction k with + | zero => exact machineRationalDirectionUpdateMatrixInit_semantics b + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalDirectionUpdateMatrixStep_semantics b k (by omega) + +theorem machineRationalDirectionUpdateMatrix_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineRationalDirectionUpdateMatrixStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalDirectionUpdateMatrixStep] + +theorem rationalDirectionUpdateRowsPrefix_all {d : β„•} + (b : Fin d β†’ β„š) : + rationalDirectionUpdateRowsPrefix b d = + rationalMatrixRows (rationalDirectionUpdateMatrix b) := by + apply List.ext_getElem + Β· simp [rationalDirectionUpdateRowsPrefix, rationalMatrixRows] + Β· intro i hiLeft hiRight + simp [rationalDirectionUpdateRowsPrefix, rationalMatrixRows, + List.getElem_finRange] + +theorem machineRationalDirectionUpdateMatrixReversedCode_encode {d : β„•} + (b : Fin d β†’ β„š) : + machineRationalDirectionUpdateMatrixReversedCode + (rationalDirectionUpdateCanonicalWord b) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (rationalDirectionUpdateMatrix b)).reverse := by + let word := rationalDirectionUpdateCanonicalWord b + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalDirectionUpdateCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hsplit : word.length = (word.length - d) + d := by omega + change machineRationalDirectionUpdateMatrixReversedCode word = _ + rw [machineRationalDirectionUpdateMatrixReversedCode, + machineRationalDirectionUpdateMatrixFinalState, hsplit, + Function.iterate_add_apply, + machineRationalDirectionUpdateMatrixIterate_semantics b d le_rfl] + simp only [machineRationalDirectionUpdateMatrixSemanticState] + rw [show binaryListCode finUnaryCode ((List.finRange d).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineRationalDirectionUpdateMatrix_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [rationalDirectionUpdateRowsPrefix_all] + +@[simp] theorem machineRationalDirectionUpdateMatrixCode_encode {d : β„•} + (b : Fin d β†’ β„š) : + machineRationalDirectionUpdateMatrixCode + (rationalDirectionUpdateCanonicalWord b) = + rationalSquareMatrixRowsCode (rationalDirectionUpdateMatrix b) := by + rw [machineRationalDirectionUpdateMatrixCode, + machineRationalDirectionUpdateMatrixReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateRow.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateRow.lean new file mode 100644 index 0000000000..d796054908 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalDirectionUpdateRow.lean @@ -0,0 +1,442 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalBallInit +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidCenterUpdate + +/-! +# Polynomial-time rows of the ellipsoid direction update + +For a unary row index `i`, dimension, and cut-direction vector `b`, this +module constructs the `i`th row of the rank-one matrix + +`A I - ((A-p) / ||b||^2) b b^T`. + +The diagonal row is built by updating an encoded zero vector, while the +rank-one row is produced by one scalar-vector multiplication. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Constructs row `i` of the scalar diagonal matrix with value `A` on its diagonal. -/ +def rationalDirectionDiagonalRow {d : β„•} + (A : β„š) (i : Fin d) : Fin d β†’ β„š := + fun j ↦ if i = j then A else 0 + +/-- Computes the raw squared Euclidean norm of the rational direction by taking its dot product +with itself. -/ +def rawDirectionNormSq {d : β„•} (b : Fin d β†’ β„š) : RawRat := + rawRatListDot RawRat.zero (List.ofFn b) (List.ofFn b) + +/-- Subtracts the parallel ellipsoid scale from the perpendicular scale in raw rational +arithmetic. -/ +def rawDirectionGap (d : β„•) : RawRat := + (rawEllipsoidPerpScale d).sub (rawEllipsoidParallelScale d) + +/-- Divides the raw perpendicular-parallel scale gap by the squared direction norm. -/ +def rawDirectionCoefficient {d : β„•} (b : Fin d β†’ β„š) : RawRat := + (rawDirectionGap d).div (rawDirectionNormSq b) + +/-- Multiplies the direction-update coefficient by direction coordinate `i`. -/ +def rawDirectionRowScale {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : RawRat := + (rawDirectionCoefficient b).mul (rawRatOfRat (b i)) + +/-- Extracts the unary row index from a direction-update row request. -/ +def machineDirectionRowIndex (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the dimension-and-vector payload after the requested row index. -/ +def machineDirectionRowPayload (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary direction dimension from a row request. -/ +def machineDirectionRowDimensionUnary + (word : List Bool) : List Bool := + machinePairFirst (machineDirectionRowPayload word) + +/-- Extracts the binary-dimension and vector payload from a direction-update row request. -/ +def machineDirectionRowDimensionAndVector + (word : List Bool) : List Bool := + machinePairSecond (machineDirectionRowPayload word) + +/-- Extracts the binary direction dimension from a row request. -/ +def machineDirectionRowDimensionBits + (word : List Bool) : List Bool := + machinePairFirst (machineDirectionRowDimensionAndVector word) + +/-- Extracts the encoded direction vector from a row request. -/ +def machineDirectionRowVectorCode + (word : List Bool) : List Bool := + machinePairSecond (machineDirectionRowDimensionAndVector word) + +/-- Computes the raw dot product of the direction vector with itself. -/ +def machineDirectionRowNormSqRawCode + (word : List Bool) : List Bool := + machineRationalVectorDotRawCode + (pair (machineDirectionRowVectorCode word) + (machineDirectionRowVectorCode word)) + +/-- Computes the raw perpendicular scale minus the parallel scale for the requested dimension. -/ +def machineDirectionRowGapRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair + (machineEllipsoidPerpScaleRawCode + (machineDirectionRowDimensionBits word)) + (machineRawRatNegCode + (machineEllipsoidParallelScaleRawCode + (machineDirectionRowDimensionBits word)))) + +/-- Divides the raw scale gap by the squared direction norm to compute the update coefficient. -/ +def machineDirectionRowCoefficientRawCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineDirectionRowGapRawCode word) + (machineDirectionRowNormSqRawCode word)) + +/-- Looks up the direction coordinate at the requested unary row index. -/ +def machineDirectionRowBEntry + (word : List Bool) : List Bool := + machineListIndex + (pair (machineDirectionRowIndex word) + (machineDirectionRowVectorCode word)) + +/-- Multiplies the update coefficient by the selected direction coordinate. -/ +def machineDirectionRowScaleRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineDirectionRowCoefficientRawCode word) + (machineDirectionRowBEntry word)) + +/-- Scales the full direction vector by the row-dependent update coefficient. -/ +def machineDirectionRowScaledVectorCode + (word : List Bool) : List Bool := + machineRationalVectorScaleCode + (pair (machineDirectionRowScaleRawCode word) + (machineDirectionRowVectorCode word)) + +/-- Constructs the zero vector of the requested unary dimension. -/ +def machineDirectionRowZeroVectorCode + (word : List Bool) : List Bool := + machineRationalZeroVectorCode + (machineDirectionRowDimensionUnary word) + +/-- Updates the selected entry of the zero vector to the perpendicular scale, producing a scaled +diagonal row. -/ +def machineDirectionRowDiagonalCode + (word : List Bool) : List Bool := + machineListUpdate + (pair (machineDirectionRowIndex word) + (pair + (machineEllipsoidPerpScaleEntryCode + (machineDirectionRowDimensionBits word)) + (machineDirectionRowZeroVectorCode word))) + +/-- Subtracts the scaled direction vector from the diagonal row to obtain one direction-update +matrix row. -/ +def machineRationalDirectionUpdateRowCode + (word : List Bool) : List Bool := + machineRationalVectorSubCode + (pair (machineDirectionRowDimensionUnary word) + (pair (machineDirectionRowDiagonalCode word) + (machineDirectionRowScaledVectorCode word))) + +/-! ## Polynomial-time closure -/ + +theorem machineDirectionRowIndex_mem_FP : + machineDirectionRowIndex ∈ FP := machinePairFirst_mem_FP + +theorem machineDirectionRowPayload_mem_FP : + machineDirectionRowPayload ∈ FP := machinePairSecond_mem_FP + +theorem machineDirectionRowDimensionUnary_mem_FP : + machineDirectionRowDimensionUnary ∈ FP := by + simpa only [machineDirectionRowDimensionUnary] using! + machineCompose_mem_FP machineDirectionRowPayload_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectionRowDimensionAndVector_mem_FP : + machineDirectionRowDimensionAndVector ∈ FP := by + simpa only [machineDirectionRowDimensionAndVector] using! + machineCompose_mem_FP machineDirectionRowPayload_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectionRowDimensionBits_mem_FP : + machineDirectionRowDimensionBits ∈ FP := by + simpa only [machineDirectionRowDimensionBits] using! + machineCompose_mem_FP machineDirectionRowDimensionAndVector_mem_FP + machinePairFirst_mem_FP + +theorem machineDirectionRowVectorCode_mem_FP : + machineDirectionRowVectorCode ∈ FP := by + simpa only [machineDirectionRowVectorCode] using! + machineCompose_mem_FP machineDirectionRowDimensionAndVector_mem_FP + machinePairSecond_mem_FP + +theorem machineDirectionRowNormSqRawCode_mem_FP : + machineDirectionRowNormSqRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineDirectionRowVectorCode_mem_FP + machineDirectionRowVectorCode_mem_FP + simpa only [machineDirectionRowNormSqRawCode] using! + machineCompose_mem_FP hinput machineRationalVectorDotRawCode_mem_FP + +theorem machineDirectionRowGapRawCode_mem_FP : + machineDirectionRowGapRawCode ∈ FP := by + have hperp := machineCompose_mem_FP machineDirectionRowDimensionBits_mem_FP + machineEllipsoidPerpScaleRawCode_mem_FP + have hparallel := machineCompose_mem_FP + machineDirectionRowDimensionBits_mem_FP + machineEllipsoidParallelScaleRawCode_mem_FP + have hneg := machineCompose_mem_FP hparallel machineRawRatNegCode_mem_FP + simpa only [machineDirectionRowGapRawCode] using! + machineCompose_mem_FP (machinePair_mem_FP hperp hneg) + machineRawRatAddCode_mem_FP + +theorem machineDirectionRowCoefficientRawCode_mem_FP : + machineDirectionRowCoefficientRawCode ∈ FP := by + have hinput := machinePair_mem_FP machineDirectionRowGapRawCode_mem_FP + machineDirectionRowNormSqRawCode_mem_FP + simpa only [machineDirectionRowCoefficientRawCode] using! + machineCompose_mem_FP hinput machineRawRatDivCode_mem_FP + +theorem machineDirectionRowBEntry_mem_FP : + machineDirectionRowBEntry ∈ FP := by + have hinput := machinePair_mem_FP machineDirectionRowIndex_mem_FP + machineDirectionRowVectorCode_mem_FP + simpa only [machineDirectionRowBEntry] using! + machineCompose_mem_FP hinput machineListIndex_mem_FP + +theorem machineDirectionRowScaleRawCode_mem_FP : + machineDirectionRowScaleRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineDirectionRowCoefficientRawCode_mem_FP + machineDirectionRowBEntry_mem_FP + simpa only [machineDirectionRowScaleRawCode] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineDirectionRowScaledVectorCode_mem_FP : + machineDirectionRowScaledVectorCode ∈ FP := by + have hinput := machinePair_mem_FP machineDirectionRowScaleRawCode_mem_FP + machineDirectionRowVectorCode_mem_FP + simpa only [machineDirectionRowScaledVectorCode] using! + machineCompose_mem_FP hinput machineRationalVectorScaleCode_mem_FP + +theorem machineDirectionRowZeroVectorCode_mem_FP : + machineDirectionRowZeroVectorCode ∈ FP := by + simpa only [machineDirectionRowZeroVectorCode] using! + machineCompose_mem_FP machineDirectionRowDimensionUnary_mem_FP + machineRationalZeroVectorCode_mem_FP + +theorem machineDirectionRowDiagonalCode_mem_FP : + machineDirectionRowDiagonalCode ∈ FP := by + have hperp := machineCompose_mem_FP machineDirectionRowDimensionBits_mem_FP + machineEllipsoidPerpScaleEntryCode_mem_FP + have hpayload := machinePair_mem_FP hperp + machineDirectionRowZeroVectorCode_mem_FP + have hinput := machinePair_mem_FP machineDirectionRowIndex_mem_FP hpayload + simpa only [machineDirectionRowDiagonalCode] using! + machineCompose_mem_FP hinput machineListUpdate_mem_FP + +theorem machineRationalDirectionUpdateRowCode_mem_FP : + machineRationalDirectionUpdateRowCode ∈ FP := by + have hpayload := machinePair_mem_FP machineDirectionRowDiagonalCode_mem_FP + machineDirectionRowScaledVectorCode_mem_FP + have hinput := machinePair_mem_FP machineDirectionRowDimensionUnary_mem_FP + hpayload + simpa only [machineRationalDirectionUpdateRowCode] using! + machineCompose_mem_FP hinput machineRationalVectorSubCode_mem_FP + +/-! ## Exact semantics -/ + +@[simp] theorem rawDirectionNormSq_value {d : β„•} (b : Fin d β†’ β„š) : + (rawDirectionNormSq b).value = finiteNormSq b := by + rw [rawDirectionNormSq, rawRatListDot_ofFn_value] + rfl + +@[simp] theorem rawDirectionGap_value (d : β„•) : + (rawDirectionGap d).value = + rationalEllipsoidPerpScale d - rationalEllipsoidParallelScale d := by + simp [rawDirectionGap, RawRat.sub, RawRat.value_add, + RawRat.value_neg, sub_eq_add_neg] + +@[simp] theorem rawDirectionCoefficient_value {d : β„•} + (b : Fin d β†’ β„š) : + (rawDirectionCoefficient b).value = + (rationalEllipsoidPerpScale d - + rationalEllipsoidParallelScale d) / finiteNormSq b := by + simp [rawDirectionCoefficient] + +@[simp] theorem rawDirectionRowScale_value {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + (rawDirectionRowScale b i).value = + ((rationalEllipsoidPerpScale d - + rationalEllipsoidParallelScale d) / finiteNormSq b) * b i := by + simp [rawDirectionRowScale] + +@[simp] theorem machineDirectionRowNormSqRawCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowNormSqRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) (pair d.bits + (rationalFiniteVectorCode b)))) = + rawRatBinaryCode (rawDirectionNormSq b) := by + rw [machineDirectionRowNormSqRawCode] + simp only [machineDirectionRowVectorCode, + machineDirectionRowDimensionAndVector, machineDirectionRowPayload, + machinePairSecond_pair, machineRationalVectorDotRawCode_encode, + rawDirectionNormSq] + +@[simp] theorem machineDirectionRowGapRawCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowGapRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rawRatBinaryCode (rawDirectionGap d) := by + rw [machineDirectionRowGapRawCode] + simp only [machineDirectionRowDimensionBits, + machineDirectionRowDimensionAndVector, machineDirectionRowPayload, + machinePairSecond_pair, machinePairFirst_pair, + machineEllipsoidPerpScaleRawCode_encode, + machineEllipsoidParallelScaleRawCode_encode, + machineRawRatNegCode_encode, machineRawRatAddCode_encode, + rawDirectionGap, RawRat.sub] + +@[simp] theorem machineDirectionRowCoefficientRawCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowCoefficientRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rawRatBinaryCode (rawDirectionCoefficient b) := by + rw [machineDirectionRowCoefficientRawCode] + simp only [machineDirectionRowGapRawCode_encode, + machineDirectionRowNormSqRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineDirectionRowBEntry_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowBEntry + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rationalEntryBinaryCode (b i) := by + rw [machineDirectionRowBEntry] + simp only [machineDirectionRowIndex, machinePairFirst_pair, + machineDirectionRowVectorCode, machineDirectionRowDimensionAndVector, + machineDirectionRowPayload, machinePairSecond_pair, + rationalFiniteVectorCode] + rw [machineListIndex_binaryListCode] + Β· simp + Β· simp + +@[simp] theorem machineDirectionRowScaleRawCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowScaleRawCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rawRatBinaryCode (rawDirectionRowScale b i) := by + rw [machineDirectionRowScaleRawCode] + simp only [machineDirectionRowCoefficientRawCode_encode, + machineDirectionRowBEntry_encode, + ← rawRatBinaryCode_rawRatOfRat, machineRawRatMulCode_encode, + rawDirectionRowScale] + +@[simp] theorem machineDirectionRowScaledVectorCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowScaledVectorCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rationalFiniteVectorCode + (rationalVectorScale (rawDirectionRowScale b i).value b) := by + rw [machineDirectionRowScaledVectorCode] + simp only [machineDirectionRowScaleRawCode_encode, + machineDirectionRowVectorCode, machineDirectionRowDimensionAndVector, + machineDirectionRowPayload, machinePairSecond_pair] + rw [machineRationalVectorScaleCode_encode] + +@[simp] theorem machineDirectionRowDiagonalCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineDirectionRowDiagonalCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rationalFiniteVectorCode + (rationalDirectionDiagonalRow (rationalEllipsoidPerpScale d) i) := by + rw [machineDirectionRowDiagonalCode] + simp only [machineDirectionRowIndex, machinePairFirst_pair, + machineDirectionRowDimensionBits, + machineDirectionRowDimensionAndVector, machineDirectionRowPayload, + machinePairSecond_pair, machineEllipsoidPerpScaleEntryCode_encode, + machineDirectionRowZeroVectorCode, + machineDirectionRowDimensionUnary, machinePairFirst_pair, + machineRationalZeroVectorCode_encode] + change machineListUpdate + (machineListUpdateCanonicalInput rationalEntryBinaryCode + (List.ofFn (fun _ : Fin d ↦ (0 : β„š))) + (rationalEllipsoidPerpScale d) i.1) = _ + rw [machineListUpdate_binaryListCode] + Β· rw [rationalFiniteVectorCode] + congr 1 + apply List.ext_getElem + Β· simp + Β· intro j hjLeft hjRight + by_cases hji : j = i.1 + Β· subst j + simp [rationalDirectionDiagonalRow] + Β· have hfin : i β‰  ⟨j, by simpa using! hjRight⟩ := by + intro h + apply hji + exact (congrArg Fin.val h).symm + have hij : i.1 β‰  j := Ne.symm hji + simp [List.getElem_set, hij, rationalDirectionDiagonalRow, hfin] + Β· simpa using! i.isLt + +theorem rationalDirectionUpdateRow_eq {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + rationalVectorSub + (rationalDirectionDiagonalRow (rationalEllipsoidPerpScale d) i) + (rationalVectorScale (rawDirectionRowScale b i).value b) = + fun j ↦ directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b i j := by + funext j + simp [rationalVectorSub, rationalDirectionDiagonalRow, + rationalVectorScale, directionUpdateMatrix] + +@[simp] theorem machineRationalDirectionUpdateRowCode_encode {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + machineRationalDirectionUpdateRowCode + (pair (List.replicate i.1 true) + (pair (List.replicate d true) + (pair d.bits (rationalFiniteVectorCode b)))) = + rationalFiniteVectorCode + (fun j ↦ directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b i j) := by + rw [machineRationalDirectionUpdateRowCode] + simp only [machineDirectionRowDimensionUnary, + machineDirectionRowPayload, machinePairSecond_pair, + machinePairFirst_pair, machineDirectionRowDiagonalCode_encode, + machineDirectionRowScaledVectorCode_encode] + change machineRationalVectorSubCode + (rationalVectorSubCanonicalWord + (rationalDirectionDiagonalRow (rationalEllipsoidPerpScale d) i) + (rationalVectorScale (rawDirectionRowScale b i).value b)) = _ + rw [machineRationalVectorSubCode_encode, + rationalDirectionUpdateRow_eq] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidCenterUpdate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidCenterUpdate.lean new file mode 100644 index 0000000000..644d91a32c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidCenterUpdate.lean @@ -0,0 +1,316 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSub + +/-! +# Polynomial-time center part of the rational ellipsoid update + +The input is a canonical ellipsoid-state word followed by a canonical cut +normal. Every intermediate remains a finite word: the program pulls the cut +back through the transposed basis, normalizes by its `β„“1` norm, multiplies by +the basis, scales by `alpha`, and subtracts from the stored center. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the current ellipsoid-state word from a center-update request. -/ +def machineRationalCenterUpdateStateWord + (word : List Bool) : List Bool := machinePairFirst word + +/-- Extracts the cut-vector word from a center-update request. -/ +def machineRationalCenterUpdateCutWord + (word : List Bool) : List Bool := machinePairSecond word + +/-- Reads the binary ellipsoid dimension from the center-update state. -/ +def machineRationalCenterUpdateDimensionBits + (word : List Bool) : List Bool := + machineRationalEllipsoidDimensionWord + (machineRationalCenterUpdateStateWord word) + +/-- The complete state word is a unary guard for its own dimension. -/ +def machineRationalCenterUpdateDimensionUnary + (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineRationalCenterUpdateStateWord word) + (machineRationalCenterUpdateDimensionBits word)) + +/-- Reads the encoded current center from the center-update state. -/ +def machineRationalCenterUpdateCenterWord + (word : List Bool) : List Bool := + machineRationalEllipsoidCenterWord + (machineRationalCenterUpdateStateWord word) + +/-- Reads the encoded current basis matrix from the center-update state. -/ +def machineRationalCenterUpdateBasisWord + (word : List Bool) : List Bool := + machineRationalEllipsoidBasisWord + (machineRationalCenterUpdateStateWord word) + +/-- Multiplies the cut vector by the transpose of the current basis to pull it into ellipsoid +coordinates. -/ +def machineRationalCenterUpdatePulledBackCode + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorCode + (pair (machineRationalCenterUpdateDimensionUnary word) + (pair (machineRationalCenterUpdateBasisWord word) + (machineRationalCenterUpdateCutWord word))) + +/-- Computes the rational normalized direction associated with the pulled-back cut vector. -/ +def machineRationalCenterUpdateNormalizedCode + (word : List Bool) : List Bool := + machineRationalNormalizedDirectionCode + (machineRationalCenterUpdatePulledBackCode word) + +/-- Maps the normalized pulled-back direction through the current basis to obtain a displacement +vector. -/ +def machineRationalCenterUpdateDisplacementCode + (word : List Bool) : List Bool := + machineRationalMatrixMulVectorCode + (pair (machineRationalCenterUpdateDimensionUnary word) + (pair (machineRationalCenterUpdateBasisWord word) + (machineRationalCenterUpdateNormalizedCode word))) + +/-- Scales the displacement vector by the dimension-dependent rational ellipsoid center-shift +factor. -/ +def machineRationalCenterUpdateScaledDisplacementCode + (word : List Bool) : List Bool := + machineRationalVectorScaleCode + (pair + (machineEllipsoidAlphaRawCode + (machineRationalCenterUpdateDimensionBits word)) + (machineRationalCenterUpdateDisplacementCode word)) + +/-- Encodes the updated ellipsoid center by subtracting the scaled displacement from its current +center. -/ +def machineRationalEllipsoidCenterUpdateCode + (word : List Bool) : List Bool := + machineRationalVectorSubCode + (pair (machineRationalCenterUpdateDimensionUnary word) + (pair (machineRationalCenterUpdateCenterWord word) + (machineRationalCenterUpdateScaledDisplacementCode word))) + +theorem machineRationalCenterUpdateStateWord_mem_FP : + machineRationalCenterUpdateStateWord ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalCenterUpdateCutWord_mem_FP : + machineRationalCenterUpdateCutWord ∈ FP := machinePairSecond_mem_FP + +theorem machineRationalCenterUpdateDimensionBits_mem_FP : + machineRationalCenterUpdateDimensionBits ∈ FP := by + simpa only [machineRationalCenterUpdateDimensionBits] using! + machineCompose_mem_FP machineRationalCenterUpdateStateWord_mem_FP + machineRationalEllipsoidDimensionWord_mem_FP + +theorem machineRationalCenterUpdateDimensionUnary_mem_FP : + machineRationalCenterUpdateDimensionUnary ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalCenterUpdateStateWord_mem_FP + machineRationalCenterUpdateDimensionBits_mem_FP + simpa only [machineRationalCenterUpdateDimensionUnary] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineRationalCenterUpdateCenterWord_mem_FP : + machineRationalCenterUpdateCenterWord ∈ FP := by + simpa only [machineRationalCenterUpdateCenterWord] using! + machineCompose_mem_FP machineRationalCenterUpdateStateWord_mem_FP + machineRationalEllipsoidCenterWord_mem_FP + +theorem machineRationalCenterUpdateBasisWord_mem_FP : + machineRationalCenterUpdateBasisWord ∈ FP := by + simpa only [machineRationalCenterUpdateBasisWord] using! + machineCompose_mem_FP machineRationalCenterUpdateStateWord_mem_FP + machineRationalEllipsoidBasisWord_mem_FP + +theorem machineRationalCenterUpdatePulledBackCode_mem_FP : + machineRationalCenterUpdatePulledBackCode ∈ FP := by + have hpayload := machinePair_mem_FP + machineRationalCenterUpdateBasisWord_mem_FP + machineRationalCenterUpdateCutWord_mem_FP + have hinput := machinePair_mem_FP + machineRationalCenterUpdateDimensionUnary_mem_FP hpayload + simpa only [machineRationalCenterUpdatePulledBackCode] using! + machineCompose_mem_FP hinput machineRationalTransposeMulVectorCode_mem_FP + +theorem machineRationalCenterUpdateNormalizedCode_mem_FP : + machineRationalCenterUpdateNormalizedCode ∈ FP := by + simpa only [machineRationalCenterUpdateNormalizedCode] using! + machineCompose_mem_FP machineRationalCenterUpdatePulledBackCode_mem_FP + machineRationalNormalizedDirectionCode_mem_FP + +theorem machineRationalCenterUpdateDisplacementCode_mem_FP : + machineRationalCenterUpdateDisplacementCode ∈ FP := by + have hpayload := machinePair_mem_FP + machineRationalCenterUpdateBasisWord_mem_FP + machineRationalCenterUpdateNormalizedCode_mem_FP + have hinput := machinePair_mem_FP + machineRationalCenterUpdateDimensionUnary_mem_FP hpayload + simpa only [machineRationalCenterUpdateDisplacementCode] using! + machineCompose_mem_FP hinput machineRationalMatrixMulVectorCode_mem_FP + +theorem machineRationalCenterUpdateScaledDisplacementCode_mem_FP : + machineRationalCenterUpdateScaledDisplacementCode ∈ FP := by + have halpha := machineCompose_mem_FP + machineRationalCenterUpdateDimensionBits_mem_FP + machineEllipsoidAlphaRawCode_mem_FP + have hinput := machinePair_mem_FP halpha + machineRationalCenterUpdateDisplacementCode_mem_FP + simpa only [machineRationalCenterUpdateScaledDisplacementCode] using! + machineCompose_mem_FP hinput machineRationalVectorScaleCode_mem_FP + +theorem machineRationalEllipsoidCenterUpdateCode_mem_FP : + machineRationalEllipsoidCenterUpdateCode ∈ FP := by + have hpayload := machinePair_mem_FP + machineRationalCenterUpdateCenterWord_mem_FP + machineRationalCenterUpdateScaledDisplacementCode_mem_FP + have hinput := machinePair_mem_FP + machineRationalCenterUpdateDimensionUnary_mem_FP hpayload + simpa only [machineRationalEllipsoidCenterUpdateCode] using! + machineCompose_mem_FP hinput machineRationalVectorSubCode_mem_FP + +/-! ## Exact semantics -/ + +theorem rationalEllipsoid_dimension_le_state_code_length {d : β„•} + (E : RationalEllipsoidState d) : + d ≀ (rationalEllipsoidStateBinaryCode E).length := by + have hlist := binaryListCode_listLength_le rationalEntryBinaryCode + (List.ofFn E.center) + have hcenter : + (rationalFiniteVectorCode E.center).length ≀ + (rationalEllipsoidStateBinaryCode E).length := by + let payload := pair (rationalFiniteVectorCode E.center) + (rationalSquareMatrixRowsCode E.basis) + have hfirst := machinePairFirst_length_le payload + have hsecond : payload.length ≀ + (rationalEllipsoidStateBinaryCode E).length := by + simpa only [payload, rationalEllipsoidStateBinaryCode, + machinePairSecond_pair] using! machinePairSecond_length_le + (rationalEllipsoidStateBinaryCode E) + simpa only [payload, machinePairFirst_pair] using! hfirst.trans hsecond + simpa only [rationalFiniteVectorCode, List.length_ofFn] using! + hlist.trans hcenter + +@[simp] theorem machineRationalCenterUpdateDimensionUnary_encode {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalCenterUpdateDimensionUnary + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + List.replicate d true := by + rw [machineRationalCenterUpdateDimensionUnary] + simp only [machineRationalCenterUpdateStateWord, + machineRationalCenterUpdateDimensionBits, + machinePairFirst_pair, machineRationalEllipsoidDimensionWord_encode] + exact machineBoundedUnary_encode_of_le + (rationalEllipsoidStateBinaryCode E) d + (rationalEllipsoid_dimension_le_state_code_length E) + +@[simp] theorem machineRationalCenterUpdatePulledBackCode_encode {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalCenterUpdatePulledBackCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalFiniteVectorCode (rationalPulledBackNormal E a) := by + rw [machineRationalCenterUpdatePulledBackCode] + simp only [machineRationalCenterUpdateDimensionUnary_encode, + machineRationalCenterUpdateBasisWord, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidBasisWord_encode, + machineRationalCenterUpdateCutWord, machinePairSecond_pair] + change machineRationalTransposeMulVectorCode + (rationalTransposeMulVectorCanonicalWord E.basis a) = _ + rw [machineRationalTransposeMulVectorCode_encode, + rationalTransposeMulVector_eq_pulledBack] + +@[simp] theorem machineRationalCenterUpdateNormalizedCode_encode {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalCenterUpdateNormalizedCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalFiniteVectorCode + (rationalNormalizedDirection (rationalPulledBackNormal E a)) := by + rw [machineRationalCenterUpdateNormalizedCode, + machineRationalCenterUpdatePulledBackCode_encode, + machineRationalNormalizedDirectionCode_encode] + +@[simp] theorem machineRationalCenterUpdateDisplacementCode_encode {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalCenterUpdateDisplacementCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalFiniteVectorCode + (rationalMatrixMulVector E.basis + (rationalNormalizedDirection (rationalPulledBackNormal E a))) := by + rw [machineRationalCenterUpdateDisplacementCode] + simp only [machineRationalCenterUpdateDimensionUnary_encode, + machineRationalCenterUpdateBasisWord, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidBasisWord_encode, + machineRationalCenterUpdateNormalizedCode_encode] + change machineRationalMatrixMulVectorCode + (rationalMatrixMulVectorCanonicalWord E.basis + (rationalNormalizedDirection (rationalPulledBackNormal E a))) = _ + rw [machineRationalMatrixMulVectorCode_encode] + +@[simp] theorem machineRationalCenterUpdateScaledDisplacementCode_encode + {d : β„•} (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalCenterUpdateScaledDisplacementCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalFiniteVectorCode + (rationalVectorScale (rationalEllipsoidAlpha d) + (rationalMatrixMulVector E.basis + (rationalNormalizedDirection + (rationalPulledBackNormal E a)))) := by + rw [machineRationalCenterUpdateScaledDisplacementCode] + simp only [machineRationalCenterUpdateDimensionBits, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidDimensionWord_encode, + machineEllipsoidAlphaRawCode_encode, + machineRationalCenterUpdateDisplacementCode_encode, + machineRationalVectorScaleCode_encode, rawEllipsoidAlpha_value] + +theorem rationalEllipsoidCentralUpdate_center_eq {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + (rationalEllipsoidCentralUpdate E a).center = + rationalVectorSub E.center + (rationalVectorScale (rationalEllipsoidAlpha d) + (rationalMatrixMulVector E.basis + (rationalNormalizedDirection + (rationalPulledBackNormal E a)))) := by + funext i + simp [rationalEllipsoidCentralUpdate, rationalVectorSub, + rationalVectorScale, rationalMatrixMulVector, + rationalNormalizedDirection, cutL1Scale] + +@[simp] theorem machineRationalEllipsoidCenterUpdateCode_encode {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalEllipsoidCenterUpdateCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalFiniteVectorCode (rationalEllipsoidCentralUpdate E a).center := by + rw [machineRationalEllipsoidCenterUpdateCode] + simp only [machineRationalCenterUpdateDimensionUnary_encode, + machineRationalCenterUpdateCenterWord, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidCenterWord_encode, + machineRationalCenterUpdateScaledDisplacementCode_encode] + change machineRationalVectorSubCode + (rationalVectorSubCanonicalWord E.center + (rationalVectorScale (rationalEllipsoidAlpha d) + (rationalMatrixMulVector E.basis + (rationalNormalizedDirection + (rationalPulledBackNormal E a))))) = _ + rw [machineRationalVectorSubCode_encode, + ← rationalEllipsoidCentralUpdate_center_eq] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidEncoding.lean new file mode 100644 index 0000000000..aa335cfd22 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidEncoding.lean @@ -0,0 +1,249 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineEncoding +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility + +/-! # Machine Rational Ellipsoid Encoding -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Canonical finite-word encodings for rational ellipsoid feasibility + +The optimizer stores a center vector and a square basis matrix. This file +fixes their ordinary binary representation before any update or oracle +machine is introduced. Every list is right-nested with `binaryListCode`, and +every rational entry is in the unique reduced representation +`rationalEntryBinaryCode`. +-/ + +/-- Canonical word for a fixed-length rational vector. -/ +def rationalFiniteVectorCode {d : β„•} (v : Fin d β†’ β„š) : List Bool := + binaryListCode rationalEntryBinaryCode (List.ofFn v) + +theorem rationalFiniteVectorCode_injective {d : β„•} : + Function.Injective (@rationalFiniteVectorCode d) := by + intro v w h + have hlists : List.ofFn v = List.ofFn w := + (binaryListCode_injective rationalEntryBinaryCode_injective) h + exact List.ofFn_injective hlists + +/-- Canonical word for a fixed-size rational square matrix, without a second +copy of the dimension. -/ +def rationalSquareMatrixRowsCode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : List Bool := + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A) + +theorem rationalSquareMatrixRowsCode_injective {d : β„•} : + Function.Injective (@rationalSquareMatrixRowsCode d) := by + intro A B h + apply rationalMatrixRows_injective + exact (binaryListCode_injective + (binaryListCode_injective rationalEntryBinaryCode_injective)) h + +/-- Dimension followed by center and basis. Keeping the dimension in the +word makes the representation self-contained for a single uniform machine. -/ +def rationalEllipsoidStateBinaryCode {d : β„•} + (E : RationalEllipsoidState d) : List Bool := + pair d.bits + (pair (rationalFiniteVectorCode E.center) + (rationalSquareMatrixRowsCode E.basis)) + +theorem rationalEllipsoidStateBinaryCode_injective_fixed {d : β„•} : + Function.Injective (@rationalEllipsoidStateBinaryCode d) := by + intro E F h + obtain ⟨_hd, hpayload⟩ := pair_inj h + obtain ⟨hcenter, hbasis⟩ := pair_inj hpayload + cases E with + | mk Ec Eb => + cases F with + | mk Fc Fb => + simp only at hcenter hbasis ⊒ + have hc : Ec = Fc := rationalFiniteVectorCode_injective hcenter + have hb : Eb = Fb := + rationalSquareMatrixRowsCode_injective hbasis + cases hc + cases hb + rfl + +/-- A dimension-indexed ellipsoid state, used only to state global +injectivity of the self-contained word representation. -/ +abbrev RationalEllipsoidInput := Ξ£ d : β„•, RationalEllipsoidState d + +/-- Encodes a dimension-indexed rational ellipsoid input using its state encoding. -/ +def rationalEllipsoidInputBinaryCode : + RationalEllipsoidInput β†’ List Bool + | ⟨_d, E⟩ => rationalEllipsoidStateBinaryCode E + +theorem rationalEllipsoidInputBinaryCode_injective : + Function.Injective rationalEllipsoidInputBinaryCode := by + intro x y h + obtain ⟨d, E⟩ := x + obtain ⟨e, F⟩ := y + simp only [rationalEllipsoidInputBinaryCode, + rationalEllipsoidStateBinaryCode] at h + obtain ⟨hde, hpayload⟩ := pair_inj h + have hde' : d = e := natBits_injective hde + subst e + have hcode : rationalEllipsoidStateBinaryCode E = + rationalEllipsoidStateBinaryCode F := by + simp only [rationalEllipsoidStateBinaryCode] + exact congrArg (pair d.bits) hpayload + have hEF : E = F := + rationalEllipsoidStateBinaryCode_injective_fixed hcode + subst F + rfl + +/-- Tag and payload encoding of an oracle response. -/ +def rationalCentralOracleResponseBinaryCode {d : β„•} : + RationalCentralOracleResponse d β†’ List Bool + | .accept => pair [false] [] + | .cut a => pair [true] (rationalFiniteVectorCode a) + +theorem rationalCentralOracleResponseBinaryCode_injective {d : β„•} : + Function.Injective (@rationalCentralOracleResponseBinaryCode d) := by + intro r s h + cases r with + | accept => + cases s with + | accept => rfl + | cut a => + have htag := congrArg machinePairFirst h + simp [rationalCentralOracleResponseBinaryCode] at htag + | cut a => + cases s with + | accept => + have htag := congrArg machinePairFirst h + simp [rationalCentralOracleResponseBinaryCode] at htag + | cut b => + have hpayload := congrArg machinePairSecond h + simp only [rationalCentralOracleResponseBinaryCode, + machinePairSecond_pair] at hpayload + exact congrArg RationalCentralOracleResponse.cut + (rationalFiniteVectorCode_injective hpayload) + +/-- Tag and payload encoding of a bounded feasibility result. -/ +def rationalFeasibilityResultBinaryCode {d : β„•} : + RationalFeasibilityResult d β†’ List Bool + | .accepted q => pair [false] (rationalFiniteVectorCode q) + | .exhausted E => pair [true] (rationalEllipsoidStateBinaryCode E) + +theorem rationalFeasibilityResultBinaryCode_injective {d : β„•} : + Function.Injective (@rationalFeasibilityResultBinaryCode d) := by + intro r s h + cases r with + | accepted q => + cases s with + | accepted z => + have hpayload := congrArg machinePairSecond h + simp only [rationalFeasibilityResultBinaryCode, + machinePairSecond_pair] at hpayload + exact congrArg RationalFeasibilityResult.accepted + (rationalFiniteVectorCode_injective hpayload) + | exhausted E => + have htag := congrArg machinePairFirst h + simp [rationalFeasibilityResultBinaryCode] at htag + | exhausted E => + cases s with + | accepted q => + have htag := congrArg machinePairFirst h + simp [rationalFeasibilityResultBinaryCode] at htag + | exhausted F => + have hpayload := congrArg machinePairSecond h + simp only [rationalFeasibilityResultBinaryCode, + machinePairSecond_pair] at hpayload + exact congrArg RationalFeasibilityResult.exhausted + (rationalEllipsoidStateBinaryCode_injective_fixed hpayload) + +/-! ## Polynomial-time field accessors -/ + +/-- Extracts the encoded ellipsoid dimension. -/ +def machineRationalEllipsoidDimensionWord (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the paired center and basis payload of an encoded ellipsoid. -/ +def machineRationalEllipsoidPayloadWord (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the encoded center vector from the ellipsoid payload. -/ +def machineRationalEllipsoidCenterWord (word : List Bool) : List Bool := + machinePairFirst (machineRationalEllipsoidPayloadWord word) + +/-- Extracts the encoded basis matrix from the ellipsoid payload. -/ +def machineRationalEllipsoidBasisWord (word : List Bool) : List Bool := + machinePairSecond (machineRationalEllipsoidPayloadWord word) + +theorem machineRationalEllipsoidDimensionWord_mem_FP : + machineRationalEllipsoidDimensionWord ∈ FP := + machinePairFirst_mem_FP + +theorem machineRationalEllipsoidPayloadWord_mem_FP : + machineRationalEllipsoidPayloadWord ∈ FP := + machinePairSecond_mem_FP + +theorem machineRationalEllipsoidCenterWord_mem_FP : + machineRationalEllipsoidCenterWord ∈ FP := by + simpa only [machineRationalEllipsoidCenterWord] using! + machineCompose_mem_FP machineRationalEllipsoidPayloadWord_mem_FP + machinePairFirst_mem_FP + +theorem machineRationalEllipsoidBasisWord_mem_FP : + machineRationalEllipsoidBasisWord ∈ FP := by + simpa only [machineRationalEllipsoidBasisWord] using! + machineCompose_mem_FP machineRationalEllipsoidPayloadWord_mem_FP + machinePairSecond_mem_FP + +@[simp] theorem machineRationalEllipsoidDimensionWord_encode {d : β„•} + (E : RationalEllipsoidState d) : + machineRationalEllipsoidDimensionWord + (rationalEllipsoidStateBinaryCode E) = d.bits := by + simp [machineRationalEllipsoidDimensionWord, + rationalEllipsoidStateBinaryCode] + +@[simp] theorem machineRationalEllipsoidCenterWord_encode {d : β„•} + (E : RationalEllipsoidState d) : + machineRationalEllipsoidCenterWord + (rationalEllipsoidStateBinaryCode E) = + rationalFiniteVectorCode E.center := by + simp [machineRationalEllipsoidCenterWord, + machineRationalEllipsoidPayloadWord, + rationalEllipsoidStateBinaryCode] + +@[simp] theorem machineRationalEllipsoidBasisWord_encode {d : β„•} + (E : RationalEllipsoidState d) : + machineRationalEllipsoidBasisWord + (rationalEllipsoidStateBinaryCode E) = + rationalSquareMatrixRowsCode E.basis := by + simp [machineRationalEllipsoidBasisWord, + machineRationalEllipsoidPayloadWord, + rationalEllipsoidStateBinaryCode] + +/-- Extracts the tag from a tagged rational result. -/ +def machineRationalTaggedResultTag (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the payload from a tagged rational result. -/ +def machineRationalTaggedResultPayload (word : List Bool) : List Bool := + machinePairSecond word + +theorem machineRationalTaggedResultTag_mem_FP : + machineRationalTaggedResultTag ∈ FP := + machinePairFirst_mem_FP + +theorem machineRationalTaggedResultPayload_mem_FP : + machineRationalTaggedResultPayload ∈ FP := + machinePairSecond_mem_FP + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidScalars.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidScalars.lean new file mode 100644 index 0000000000..e335b415f2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidScalars.lean @@ -0,0 +1,369 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorL1 + +/-! +# Polynomial-time coefficients for the rational ellipsoid update + +The square-root-free central update uses three dimension-dependent rational +coefficients. This module constructs them from the ordinary little-endian +binary word for the dimension, using only the verified unreduced rational +arithmetic machines. The raw formulas are kept explicit so that no field +operation is hidden in the executable layer. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw-rational constant one used in ellipsoid updates. -/ +def rawEllipsoidOne : RawRat := RawRat.ofNat 1 +/-- The raw-rational constant two used in ellipsoid updates. -/ +def rawEllipsoidTwo : RawRat := RawRat.ofNat 2 +/-- The raw-rational constant four used in ellipsoid updates. -/ +def rawEllipsoidFour : RawRat := RawRat.ofNat 4 + +/-- Embeds the ellipsoid dimension as a raw rational. -/ +def rawEllipsoidDimension (d : β„•) : RawRat := RawRat.ofNat d + +/-- The square of the ellipsoid dimension as a raw rational. -/ +def rawEllipsoidDimensionSquare (d : β„•) : RawRat := + (rawEllipsoidDimension d).mul (rawEllipsoidDimension d) + +/-- Four times the squared ellipsoid dimension as a raw rational. -/ +def rawEllipsoidFourDimensionSquare (d : β„•) : RawRat := + rawEllipsoidFour.mul (rawEllipsoidDimensionSquare d) + +/-- The raw-rational update parameter `alpha = 1/(4*d^2)`. -/ +def rawEllipsoidAlpha (d : β„•) : RawRat := + rawEllipsoidOne.div (rawEllipsoidFourDimensionSquare d) + +/-- The square of the ellipsoid update parameter `alpha`. -/ +def rawEllipsoidAlphaSquare (d : β„•) : RawRat := + (rawEllipsoidAlpha d).mul (rawEllipsoidAlpha d) + +/-- Twice the square of the ellipsoid update parameter `alpha`. -/ +def rawEllipsoidTwiceAlphaSquare (d : β„•) : RawRat := + rawEllipsoidTwo.mul (rawEllipsoidAlphaSquare d) + +/-- The perpendicular update scale `1 + 2*alpha^2`. -/ +def rawEllipsoidPerpScale (d : β„•) : RawRat := + rawEllipsoidOne.add (rawEllipsoidTwiceAlphaSquare d) + +/-- The update parameter `alpha` divided by the ellipsoid dimension. -/ +def rawEllipsoidAlphaOverDimension (d : β„•) : RawRat := + (rawEllipsoidAlpha d).div (rawEllipsoidDimension d) + +/-- The parallel update scale `1 - alpha/d`. -/ +def rawEllipsoidParallelScale (d : β„•) : RawRat := + rawEllipsoidOne.sub (rawEllipsoidAlphaOverDimension d) + +/-! ## Finite-word formulas -/ + +/-- Encodes binary dimension bits as a nonnegative raw rational with denominator one. -/ +def machineEllipsoidDimensionRawCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode word) [true] + +/-- Squares the encoded raw-rational ellipsoid dimension. -/ +def machineEllipsoidDimensionSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineEllipsoidDimensionRawCode word) + (machineEllipsoidDimensionRawCode word)) + +/-- Computes four times the encoded squared dimension. -/ +def machineEllipsoidFourDimensionSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawEllipsoidFour) + (machineEllipsoidDimensionSquareRawCode word)) + +/-- Computes the encoded update parameter `1/(4*d^2)`. -/ +def machineEllipsoidAlphaRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode rawEllipsoidOne) + (machineEllipsoidFourDimensionSquareRawCode word)) + +/-- Squares the encoded ellipsoid update parameter. -/ +def machineEllipsoidAlphaSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineEllipsoidAlphaRawCode word) + (machineEllipsoidAlphaRawCode word)) + +/-- Computes twice the encoded squared update parameter. -/ +def machineEllipsoidTwiceAlphaSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode rawEllipsoidTwo) + (machineEllipsoidAlphaSquareRawCode word)) + +/-- Computes the encoded perpendicular scale `1 + 2*alpha^2`. -/ +def machineEllipsoidPerpScaleRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawEllipsoidOne) + (machineEllipsoidTwiceAlphaSquareRawCode word)) + +/-- Divides the encoded update parameter by the dimension. -/ +def machineEllipsoidAlphaOverDimensionRawCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineEllipsoidAlphaRawCode word) + (machineEllipsoidDimensionRawCode word)) + +/-- Computes the encoded parallel scale `1 - alpha/d`. -/ +def machineEllipsoidParallelScaleRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawEllipsoidOne) + (machineRawRatNegCode + (machineEllipsoidAlphaOverDimensionRawCode word))) + +/-- Normalizes the ellipsoid update parameter into a rational entry code. -/ +def machineEllipsoidAlphaEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineEllipsoidAlphaRawCode word) + +/-- Normalizes the perpendicular update scale into a rational entry code. -/ +def machineEllipsoidPerpScaleEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineEllipsoidPerpScaleRawCode word) + +/-- Normalizes the parallel update scale into a rational entry code. -/ +def machineEllipsoidParallelScaleEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineEllipsoidParallelScaleRawCode word) + +/-! ## Polynomial-time closure -/ + +theorem machineEllipsoidDimensionRawCode_mem_FP : + machineEllipsoidDimensionRawCode ∈ FP := by + exact machinePair_mem_FP + (machineCompose_mem_FP id_mem_FP machineNaturalIntegerCode_mem_FP) + (machineConst_mem_FP [true]) + +theorem machineEllipsoidDimensionSquareRawCode_mem_FP : + machineEllipsoidDimensionSquareRawCode ∈ FP := by + simpa only [machineEllipsoidDimensionSquareRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineEllipsoidDimensionRawCode_mem_FP + machineEllipsoidDimensionRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineEllipsoidFourDimensionSquareRawCode_mem_FP : + machineEllipsoidFourDimensionSquareRawCode ∈ FP := by + simpa only [machineEllipsoidFourDimensionSquareRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidFour)) + machineEllipsoidDimensionSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineEllipsoidAlphaRawCode_mem_FP : + machineEllipsoidAlphaRawCode ∈ FP := by + simpa only [machineEllipsoidAlphaRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidOne)) + machineEllipsoidFourDimensionSquareRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +theorem machineEllipsoidAlphaSquareRawCode_mem_FP : + machineEllipsoidAlphaSquareRawCode ∈ FP := by + simpa only [machineEllipsoidAlphaSquareRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineEllipsoidAlphaRawCode_mem_FP + machineEllipsoidAlphaRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineEllipsoidTwiceAlphaSquareRawCode_mem_FP : + machineEllipsoidTwiceAlphaSquareRawCode ∈ FP := by + simpa only [machineEllipsoidTwiceAlphaSquareRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidTwo)) + machineEllipsoidAlphaSquareRawCode_mem_FP) + machineRawRatMulCode_mem_FP + +theorem machineEllipsoidPerpScaleRawCode_mem_FP : + machineEllipsoidPerpScaleRawCode ∈ FP := by + simpa only [machineEllipsoidPerpScaleRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidOne)) + machineEllipsoidTwiceAlphaSquareRawCode_mem_FP) + machineRawRatAddCode_mem_FP + +theorem machineEllipsoidAlphaOverDimensionRawCode_mem_FP : + machineEllipsoidAlphaOverDimensionRawCode ∈ FP := by + simpa only [machineEllipsoidAlphaOverDimensionRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP machineEllipsoidAlphaRawCode_mem_FP + machineEllipsoidDimensionRawCode_mem_FP) + machineRawRatDivCode_mem_FP + +theorem machineEllipsoidParallelScaleRawCode_mem_FP : + machineEllipsoidParallelScaleRawCode ∈ FP := by + have hneg := machineCompose_mem_FP + machineEllipsoidAlphaOverDimensionRawCode_mem_FP + machineRawRatNegCode_mem_FP + simpa only [machineEllipsoidParallelScaleRawCode] using! + machineCompose_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidOne)) + hneg) + machineRawRatAddCode_mem_FP + +theorem machineEllipsoidAlphaEntryCode_mem_FP : + machineEllipsoidAlphaEntryCode ∈ FP := by + simpa only [machineEllipsoidAlphaEntryCode] using! + machineCompose_mem_FP machineEllipsoidAlphaRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineEllipsoidPerpScaleEntryCode_mem_FP : + machineEllipsoidPerpScaleEntryCode ∈ FP := by + simpa only [machineEllipsoidPerpScaleEntryCode] using! + machineCompose_mem_FP machineEllipsoidPerpScaleRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineEllipsoidParallelScaleEntryCode_mem_FP : + machineEllipsoidParallelScaleEntryCode ∈ FP := by + simpa only [machineEllipsoidParallelScaleEntryCode] using! + machineCompose_mem_FP machineEllipsoidParallelScaleRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +/-! ## Exact semantics -/ + +@[simp] theorem machineEllipsoidDimensionRawCode_encode (d : β„•) : + machineEllipsoidDimensionRawCode d.bits = + rawRatBinaryCode (rawEllipsoidDimension d) := by + rw [machineEllipsoidDimensionRawCode, + machineNaturalIntegerCode_natBits] + simp [rawEllipsoidDimension, RawRat.ofNat, rawRatBinaryCode] + +@[simp] theorem machineEllipsoidDimensionSquareRawCode_encode (d : β„•) : + machineEllipsoidDimensionSquareRawCode d.bits = + rawRatBinaryCode (rawEllipsoidDimensionSquare d) := by + rw [machineEllipsoidDimensionSquareRawCode, + machineEllipsoidDimensionRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineEllipsoidFourDimensionSquareRawCode_encode (d : β„•) : + machineEllipsoidFourDimensionSquareRawCode d.bits = + rawRatBinaryCode (rawEllipsoidFourDimensionSquare d) := by + rw [machineEllipsoidFourDimensionSquareRawCode, + machineEllipsoidDimensionSquareRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineEllipsoidAlphaRawCode_encode (d : β„•) : + machineEllipsoidAlphaRawCode d.bits = + rawRatBinaryCode (rawEllipsoidAlpha d) := by + rw [machineEllipsoidAlphaRawCode, + machineEllipsoidFourDimensionSquareRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineEllipsoidAlphaSquareRawCode_encode (d : β„•) : + machineEllipsoidAlphaSquareRawCode d.bits = + rawRatBinaryCode (rawEllipsoidAlphaSquare d) := by + rw [machineEllipsoidAlphaSquareRawCode, + machineEllipsoidAlphaRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineEllipsoidTwiceAlphaSquareRawCode_encode (d : β„•) : + machineEllipsoidTwiceAlphaSquareRawCode d.bits = + rawRatBinaryCode (rawEllipsoidTwiceAlphaSquare d) := by + rw [machineEllipsoidTwiceAlphaSquareRawCode, + machineEllipsoidAlphaSquareRawCode_encode, + machineRawRatMulCode_encode] + rfl + +@[simp] theorem machineEllipsoidPerpScaleRawCode_encode (d : β„•) : + machineEllipsoidPerpScaleRawCode d.bits = + rawRatBinaryCode (rawEllipsoidPerpScale d) := by + rw [machineEllipsoidPerpScaleRawCode, + machineEllipsoidTwiceAlphaSquareRawCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineEllipsoidAlphaOverDimensionRawCode_encode (d : β„•) : + machineEllipsoidAlphaOverDimensionRawCode d.bits = + rawRatBinaryCode (rawEllipsoidAlphaOverDimension d) := by + rw [machineEllipsoidAlphaOverDimensionRawCode, + machineEllipsoidAlphaRawCode_encode, + machineEllipsoidDimensionRawCode_encode, + machineRawRatDivCode_encode] + rfl + +@[simp] theorem machineEllipsoidParallelScaleRawCode_encode (d : β„•) : + machineEllipsoidParallelScaleRawCode d.bits = + rawRatBinaryCode (rawEllipsoidParallelScale d) := by + rw [machineEllipsoidParallelScaleRawCode, + machineEllipsoidAlphaOverDimensionRawCode_encode, + machineRawRatNegCode_encode, + machineRawRatAddCode_encode] + rfl + +@[simp] theorem rawEllipsoidDimension_value (d : β„•) : + (rawEllipsoidDimension d).value = d := by + simp [rawEllipsoidDimension] + +@[simp] theorem rawEllipsoidAlpha_value (d : β„•) : + (rawEllipsoidAlpha d).value = rationalEllipsoidAlpha d := by + simp [rawEllipsoidAlpha, rawEllipsoidFourDimensionSquare, + rawEllipsoidDimensionSquare, rawEllipsoidFour, rawEllipsoidOne, + rationalEllipsoidAlpha] + ring + +@[simp] theorem rawEllipsoidPerpScale_value (d : β„•) : + (rawEllipsoidPerpScale d).value = rationalEllipsoidPerpScale d := by + simp [rawEllipsoidPerpScale, rawEllipsoidTwiceAlphaSquare, + rawEllipsoidAlphaSquare, rawEllipsoidTwo, rawEllipsoidOne, + rationalEllipsoidPerpScale, pow_two] + +@[simp] theorem rawEllipsoidParallelScale_value (d : β„•) : + (rawEllipsoidParallelScale d).value = + rationalEllipsoidParallelScale d := by + simp [rawEllipsoidParallelScale, rawEllipsoidAlphaOverDimension, + rawEllipsoidOne, rationalEllipsoidParallelScale] + +@[simp] theorem machineEllipsoidAlphaEntryCode_encode (d : β„•) : + machineEllipsoidAlphaEntryCode d.bits = + rationalEntryBinaryCode (rationalEllipsoidAlpha d) := by + rw [machineEllipsoidAlphaEntryCode, + machineEllipsoidAlphaRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawEllipsoidAlpha_value] + +@[simp] theorem machineEllipsoidPerpScaleEntryCode_encode (d : β„•) : + machineEllipsoidPerpScaleEntryCode d.bits = + rationalEntryBinaryCode (rationalEllipsoidPerpScale d) := by + rw [machineEllipsoidPerpScaleEntryCode, + machineEllipsoidPerpScaleRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawEllipsoidPerpScale_value] + +@[simp] theorem machineEllipsoidParallelScaleEntryCode_encode (d : β„•) : + machineEllipsoidParallelScaleEntryCode d.bits = + rationalEntryBinaryCode (rationalEllipsoidParallelScale d) := by + rw [machineEllipsoidParallelScaleEntryCode, + machineEllipsoidParallelScaleRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawEllipsoidParallelScale_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidUpdate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidUpdate.lean new file mode 100644 index 0000000000..d35fd0af38 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalEllipsoidUpdate.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalDirectionUpdateMatrix + +/-! +# Polynomial-time rational central ellipsoid update + +This module combines the verified center computation, the full rank-one +direction matrix, and exact matrix multiplication into the canonical code of +one complete rational ellipsoid state. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Builds the direction-update matrix from the dimension and pulled-back cut direction. -/ +def machineRationalEllipsoidUpdateDirectionMatrixCode + (word : List Bool) : List Bool := + machineRationalDirectionUpdateMatrixCode + (pair (machineRationalCenterUpdateDimensionUnary word) + (pair (machineRationalCenterUpdateDimensionBits word) + (machineRationalCenterUpdatePulledBackCode word))) + +/-- Multiplies the current ellipsoid basis by its direction-update matrix. -/ +def machineRationalEllipsoidUpdateBasisCode + (word : List Bool) : List Bool := + machineRationalMatrixMulCode + (pair (machineRationalCenterUpdateDimensionUnary word) + (pair (machineRationalCenterUpdateBasisWord word) + (machineRationalEllipsoidUpdateDirectionMatrixCode word))) + +/-- Input: `pair rationalEllipsoidStateBinaryCode cutVectorCode`. -/ +def machineRationalEllipsoidCentralUpdateCode + (word : List Bool) : List Bool := + pair (machineRationalCenterUpdateDimensionBits word) + (pair (machineRationalEllipsoidCenterUpdateCode word) + (machineRationalEllipsoidUpdateBasisCode word)) + +theorem machineRationalEllipsoidUpdateDirectionMatrixCode_mem_FP : + machineRationalEllipsoidUpdateDirectionMatrixCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalCenterUpdateDimensionUnary_mem_FP + (machinePair_mem_FP machineRationalCenterUpdateDimensionBits_mem_FP + machineRationalCenterUpdatePulledBackCode_mem_FP) + simpa only [machineRationalEllipsoidUpdateDirectionMatrixCode] using! + machineCompose_mem_FP hinput + machineRationalDirectionUpdateMatrixCode_mem_FP + +theorem machineRationalEllipsoidUpdateBasisCode_mem_FP : + machineRationalEllipsoidUpdateBasisCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalCenterUpdateDimensionUnary_mem_FP + (machinePair_mem_FP machineRationalCenterUpdateBasisWord_mem_FP + machineRationalEllipsoidUpdateDirectionMatrixCode_mem_FP) + simpa only [machineRationalEllipsoidUpdateBasisCode] using! + machineCompose_mem_FP hinput machineRationalMatrixMulCode_mem_FP + +theorem machineRationalEllipsoidCentralUpdateCode_mem_FP : + machineRationalEllipsoidCentralUpdateCode ∈ FP := by + exact machinePair_mem_FP machineRationalCenterUpdateDimensionBits_mem_FP + (machinePair_mem_FP machineRationalEllipsoidCenterUpdateCode_mem_FP + machineRationalEllipsoidUpdateBasisCode_mem_FP) + +@[simp] theorem machineRationalEllipsoidUpdateDirectionMatrixCode_encode + {d : β„•} (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalEllipsoidUpdateDirectionMatrixCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalSquareMatrixRowsCode + (rationalDirectionUpdateMatrix (rationalPulledBackNormal E a)) := by + rw [machineRationalEllipsoidUpdateDirectionMatrixCode] + simp only [machineRationalCenterUpdateDimensionUnary_encode, + machineRationalCenterUpdateDimensionBits, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidDimensionWord_encode, + machineRationalCenterUpdatePulledBackCode_encode] + change machineRationalDirectionUpdateMatrixCode + (rationalDirectionUpdateCanonicalWord + (rationalPulledBackNormal E a)) = _ + rw [machineRationalDirectionUpdateMatrixCode_encode] + +theorem rationalEllipsoidCentralUpdate_basis_eq {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + (rationalEllipsoidCentralUpdate E a).basis = + rationalMatrixMul E.basis + (rationalDirectionUpdateMatrix (rationalPulledBackNormal E a)) := by + simp only [rationalEllipsoidCentralUpdate, + rationalDirectionUpdateMatrix, rationalMatrixMul_eq_matrix_mul] + +@[simp] theorem machineRationalEllipsoidUpdateBasisCode_encode + {d : β„•} (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalEllipsoidUpdateBasisCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalSquareMatrixRowsCode + (rationalEllipsoidCentralUpdate E a).basis := by + rw [machineRationalEllipsoidUpdateBasisCode] + simp only [machineRationalCenterUpdateDimensionUnary_encode, + machineRationalCenterUpdateBasisWord, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidBasisWord_encode, + machineRationalEllipsoidUpdateDirectionMatrixCode_encode] + change machineRationalMatrixMulCode + (rationalMatrixMulCanonicalWord E.basis + (rationalDirectionUpdateMatrix (rationalPulledBackNormal E a))) = _ + rw [machineRationalMatrixMulCode_encode, + ← rationalEllipsoidCentralUpdate_basis_eq] + +@[simp] theorem machineRationalEllipsoidCentralUpdateCode_encode + {d : β„•} (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineRationalEllipsoidCentralUpdateCode + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a)) = + rationalEllipsoidStateBinaryCode + (rationalEllipsoidCentralUpdate E a) := by + rw [machineRationalEllipsoidCentralUpdateCode, + machineRationalEllipsoidCenterUpdateCode_encode, + machineRationalEllipsoidUpdateBasisCode_encode] + simp only [machineRationalCenterUpdateDimensionBits, + machineRationalCenterUpdateStateWord, machinePairFirst_pair, + machineRationalEllipsoidDimensionWord, + rationalEllipsoidStateBinaryCode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalExp.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalExp.lean new file mode 100644 index 0000000000..3aa6a0f57f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalExp.lean @@ -0,0 +1,447 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBoundedUnary +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalLogSeries + +/-! +# Guarded polynomial-time directed rational exponential + +The mathematical exponential routine uses + +`M = 2 * ceil (|s| + |s|^2 / loss) + 1` + +and returns `(1 + s/M)^M`. The binary code of `M` is always inexpensive to +compute, but a unary power ruler of length `M` is polynomial only on the +paper-specific domain where `M` has an a priori polynomial bound. Accordingly +this machine takes an explicit unary guard. It is polynomial-time on every +string and agrees exactly with the directed rational exponential whenever the +guard has length at least `M`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary guard bound from a rational exponential query. -/ +def machineExpGuard (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the argument and loss payload from a rational exponential query. -/ +def machineExpPayload (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the encoded raw-rational exponential argument. -/ +def machineExpArgumentCode (word : List Bool) : List Bool := + machinePairFirst (machineExpPayload word) + +/-- Extracts the encoded raw-rational exponential loss allowance. -/ +def machineExpLossCode (word : List Bool) : List Bool := + machinePairSecond (machineExpPayload word) + +/-- Reads the sign bit of the exponential argument's numerator. -/ +def machineExpArgumentSign (word : List Bool) : List Bool := + machineHeadBit (machinePairFirst (machineExpArgumentCode word)) + +/-- Selects the argument or its negation to encode its nonnegative magnitude. -/ +def machineExpMagnitudeCode (word : List Bool) : List Bool := + machineIfHead (machineExpArgumentSign word) + (machineRawRatNegCode (machineExpArgumentCode word)) + (machineExpArgumentCode word) + +/-- Squares the encoded magnitude of the exponential argument. -/ +def machineExpSquareCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineExpMagnitudeCode word) (machineExpMagnitudeCode word)) + +/-- Divides the squared argument magnitude by the loss allowance. -/ +def machineExpSquareOverLossCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineExpSquareCode word) (machineExpLossCode word)) + +/-- Adds the argument magnitude to its square divided by the loss allowance. -/ +def machineExpScheduleArgumentCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineExpMagnitudeCode word) + (machineExpSquareOverLossCode word)) + +/-- Computes the natural ceiling of the exponential scheduling expression. -/ +def machineExpCeilBits (word : List Bool) : List Bool := + machineRationalCeilNatBits (machineExpScheduleArgumentCode word) + +/-- Little-endian binary code of `2 * ceil(...) + 1`. -/ +def machineExpStepsBits (word : List Bool) : List Bool := + true :: machineExpCeilBits word + +/-- Converts the exponential step count into a unary ruler bounded by the supplied guard. -/ +def machineExpStepsRuler (word : List Bool) : List Bool := + machineBoundedUnary (pair (machineExpGuard word) (machineExpStepsBits word)) + +/-- Encodes the scheduled exponential step count as a raw rational with denominator one. -/ +def machineExpStepsRawRatCode (word : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineExpStepsBits word)) [true] + +/-- Divides the exponential argument by the scheduled step count. -/ +def machineExpScaledArgumentCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineExpArgumentCode word) (machineExpStepsRawRatCode word)) + +/-- Forms the rational exponential-approximation base `1 + s/N`. -/ +def machineExpBaseCode (word : List Bool) : List Bool := + machineRawRatAddCode + (pair rawRatOneCode (machineExpScaledArgumentCode word)) + +/-- Total guarded machine for the directed rational lower exponential. -/ +def machineBoundedRationalExpLowerCode (word : List Bool) : List Bool := + machineRationalPowerCode + (pair (machineExpStepsRuler word) (machineExpBaseCode word)) + +/-- Raw-entry variant used by certificate composition. It avoids decoding the +public one-natural-number rational output before the next rational operation. -/ +def machineBoundedRationalExpLowerRawPowerCode + (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineExpStepsRuler word) (machineExpBaseCode word)) + +/-- Normalizes the bounded raw exponential power approximation into a rational entry code. -/ +def machineBoundedRationalExpLowerRawEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineBoundedRationalExpLowerRawPowerCode word) + +theorem machineExpGuard_mem_FP : machineExpGuard ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineExpPayload_mem_FP : machineExpPayload ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineExpArgumentCode_mem_FP : + machineExpArgumentCode ∈ Complexity.FP := by + simpa only [machineExpArgumentCode] using! + machineCompose_mem_FP machineExpPayload_mem_FP machinePairFirst_mem_FP + +theorem machineExpLossCode_mem_FP : machineExpLossCode ∈ Complexity.FP := by + simpa only [machineExpLossCode] using! + machineCompose_mem_FP machineExpPayload_mem_FP machinePairSecond_mem_FP + +theorem machineExpArgumentSign_mem_FP : + machineExpArgumentSign ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineExpArgumentCode_mem_FP + machinePairFirst_mem_FP + simpa only [machineExpArgumentSign] using! + machineCompose_mem_FP hnum machineHeadBit_mem_FP + +theorem machineExpMagnitudeCode_mem_FP : + machineExpMagnitudeCode ∈ Complexity.FP := by + have hneg := machineCompose_mem_FP machineExpArgumentCode_mem_FP + machineRawRatNegCode_mem_FP + simpa only [machineExpMagnitudeCode] using! + machineIfHead_mem_FP machineExpArgumentSign_mem_FP hneg + machineExpArgumentCode_mem_FP + +theorem machineExpSquareCode_mem_FP : machineExpSquareCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpMagnitudeCode_mem_FP + machineExpMagnitudeCode_mem_FP + simpa only [machineExpSquareCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineExpSquareOverLossCode_mem_FP : + machineExpSquareOverLossCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpSquareCode_mem_FP + machineExpLossCode_mem_FP + simpa only [machineExpSquareOverLossCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineExpScheduleArgumentCode_mem_FP : + machineExpScheduleArgumentCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpMagnitudeCode_mem_FP + machineExpSquareOverLossCode_mem_FP + simpa only [machineExpScheduleArgumentCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineExpCeilBits_mem_FP : machineExpCeilBits ∈ Complexity.FP := by + simpa only [machineExpCeilBits] using! + machineCompose_mem_FP machineExpScheduleArgumentCode_mem_FP + machineRationalCeilNatBits_mem_FP + +theorem machineExpStepsBits_mem_FP : machineExpStepsBits ∈ Complexity.FP := by + simpa only [machineExpStepsBits] using! + machineCompose_mem_FP machineExpCeilBits_mem_FP + (machinePrepend_mem_FP true) + +theorem machineExpStepsRuler_mem_FP : + machineExpStepsRuler ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpGuard_mem_FP + machineExpStepsBits_mem_FP + simpa only [machineExpStepsRuler] using! + machineCompose_mem_FP hpair machineBoundedUnary_mem_FP + +theorem machineExpStepsRawRatCode_mem_FP : + machineExpStepsRawRatCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineExpStepsBits_mem_FP + (machinePrepend_mem_FP false) + exact machinePair_mem_FP hnum (machineConst_mem_FP [true]) + +theorem machineExpScaledArgumentCode_mem_FP : + machineExpScaledArgumentCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpArgumentCode_mem_FP + machineExpStepsRawRatCode_mem_FP + simpa only [machineExpScaledArgumentCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineExpBaseCode_mem_FP : machineExpBaseCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) + machineExpScaledArgumentCode_mem_FP + simpa only [machineExpBaseCode] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineBoundedRationalExpLowerCode_mem_FP : + machineBoundedRationalExpLowerCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpStepsRuler_mem_FP + machineExpBaseCode_mem_FP + simpa only [machineBoundedRationalExpLowerCode] using! + machineCompose_mem_FP hpair machineRationalPowerCode_mem_FP + +theorem machineBoundedRationalExpLowerRawPowerCode_mem_FP : + machineBoundedRationalExpLowerRawPowerCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineExpStepsRuler_mem_FP + machineExpBaseCode_mem_FP + simpa only [machineBoundedRationalExpLowerRawPowerCode] using! + machineCompose_mem_FP hpair machineRawRatPowerCode_mem_FP + +theorem machineBoundedRationalExpLowerRawEntryCode_mem_FP : + machineBoundedRationalExpLowerRawEntryCode ∈ Complexity.FP := by + simpa only [machineBoundedRationalExpLowerRawEntryCode] using! + machineCompose_mem_FP + machineBoundedRationalExpLowerRawPowerCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +/-! ## Exact semantics when the schedule fits the guard -/ + +namespace RawRat + +/-- Magnitude used only to choose the exponential schedule. -/ +def expMagnitude (q : RawRat) : RawRat := + match q.num with + | .ofNat _ => q + | .negSucc _ => q.neg + +/-- The scheduled number of rational exponential steps determined by argument magnitude and +loss. -/ +def expApproxSteps (s loss : RawRat) : β„• := + binaryRationalExpApproxSteps (expMagnitude s).value loss.value + +end RawRat + +@[simp] theorem machineExpGuard_encode + (guard : List Bool) (s loss : RawRat) : + machineExpGuard + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + guard := by + simp [machineExpGuard] + +@[simp] theorem machineExpArgumentCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpArgumentCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode s := by + simp [machineExpArgumentCode, machineExpPayload] + +@[simp] theorem machineExpLossCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpLossCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode loss := by + simp [machineExpLossCode, machineExpPayload] + +@[simp] theorem machineExpMagnitudeCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpMagnitudeCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode (RawRat.expMagnitude s) := by + rcases s with ⟨num, den, hden⟩ + cases num with + | ofNat n => + simp [machineExpMagnitudeCode, machineExpArgumentSign, + machineExpArgumentCode, machineExpPayload, rawRatBinaryCode, + integerBinaryCode, RawRat.expMagnitude] + | negSucc n => + simp only [machineExpMagnitudeCode, machineExpArgumentSign, + machineExpArgumentCode, machineExpPayload, rawRatBinaryCode, + integerBinaryCode, machinePairSecond_pair, machinePairFirst_pair, + machineHeadBit_cons, machineIfHead_true, RawRat.expMagnitude] + simpa only [rawRatBinaryCode] using! + (machineRawRatNegCode_encode + (⟨Int.negSucc n, den, hden⟩ : RawRat)) + +@[simp] theorem machineExpSquareCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpSquareCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode + ((RawRat.expMagnitude s).mul (RawRat.expMagnitude s)) := by + rw [machineExpSquareCode] + simp only [machineExpMagnitudeCode_encode, machineRawRatMulCode_encode] + +@[simp] theorem machineExpSquareOverLossCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpSquareOverLossCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode + (((RawRat.expMagnitude s).mul (RawRat.expMagnitude s)).div loss) := by + rw [machineExpSquareOverLossCode] + simp only [machineExpSquareCode_encode, machineExpLossCode_encode, + machineRawRatDivCode_encode] + +@[simp] theorem machineExpScheduleArgumentCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpScheduleArgumentCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode + ((RawRat.expMagnitude s).add + (((RawRat.expMagnitude s).mul (RawRat.expMagnitude s)).div loss)) := by + rw [machineExpScheduleArgumentCode] + simp only [machineExpMagnitudeCode_encode, + machineExpSquareOverLossCode_encode, machineRawRatAddCode_encode] + +@[simp] theorem machineExpCeilBits_encode + (guard : List Bool) (s loss : RawRat) : + machineExpCeilBits + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + (Int.toNat (binaryRatCeil + ((RawRat.expMagnitude s).value + + (RawRat.expMagnitude s).value ^ 2 / loss.value))).bits := by + rw [machineExpCeilBits, machineExpScheduleArgumentCode_encode, + machineRationalCeilNatBits_encode] + congr 2 + rw [RawRat.value_add, RawRat.value_div, RawRat.value_mul] + ring + +@[simp] theorem machineExpStepsBits_encode + (guard : List Bool) (s loss : RawRat) : + machineExpStepsBits + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + (RawRat.expApproxSteps s loss).bits := by + rw [machineExpStepsBits, machineExpCeilBits_encode] + simp [RawRat.expApproxSteps, binaryRationalExpApproxSteps, + binaryRationalCeilNat, binaryRatAdd_eq_add, + binaryRatDiv_eq_div, binaryRatPow_eq_pow] + +@[simp] theorem machineExpStepsRawRatCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpStepsRawRatCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode (RawRat.ofNat (RawRat.expApproxSteps s loss)) := by + rw [machineExpStepsRawRatCode, machineExpStepsBits_encode, + machineNaturalIntegerCode_natBits] + simp [rawRatBinaryCode, RawRat.ofNat] + +@[simp] theorem machineExpStepsRuler_encode + (guard : List Bool) (s loss : RawRat) + (hsteps : RawRat.expApproxSteps s loss ≀ guard.length) : + machineExpStepsRuler + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + List.replicate (RawRat.expApproxSteps s loss) true := by + rw [machineExpStepsRuler] + simp only [machineExpGuard_encode, machineExpStepsBits_encode] + exact machineBoundedUnary_encode_of_le guard _ hsteps + +@[simp] theorem machineExpScaledArgumentCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpScaledArgumentCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode (s.div (RawRat.ofNat (RawRat.expApproxSteps s loss))) := by + rw [machineExpScaledArgumentCode] + simp only [machineExpArgumentCode_encode, + machineExpStepsRawRatCode_encode, machineRawRatDivCode_encode] + +@[simp] theorem machineExpBaseCode_encode + (guard : List Bool) (s loss : RawRat) : + machineExpBaseCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode + (RawRat.one.add + (s.div (RawRat.ofNat (RawRat.expApproxSteps s loss)))) := by + rw [machineExpBaseCode] + simp only [rawRatOneCode, machineExpScaledArgumentCode_encode, + machineRawRatAddCode_encode] + +theorem binaryNormalizeRawRat_expBasePow_eq + (s loss : RawRat) : + binaryNormalizeRawRat + ((RawRat.one.add + (s.div (RawRat.ofNat (RawRat.expApproxSteps s loss)))).pow + (RawRat.expApproxSteps s loss)) = + binaryRationalExpLower s.value loss.value := by + rw [binaryNormalizeRawRat_eq_value, RawRat.value_pow, + RawRat.value_add, RawRat.value_one, RawRat.value_div, + RawRat.value_ofNat] + rcases s with ⟨num, den, hden⟩ + cases num with + | ofNat n => + have hs : 0 ≀ ((⟨Int.ofNat n, den, hden⟩ : RawRat).value) := by + change (0 : β„š) ≀ (n : β„š) / (den : β„š) + exact div_nonneg (Nat.cast_nonneg n) (Nat.cast_nonneg den) + rw [binaryRationalExpLower, + ite_eq_left ((binaryRatNonnegative_eq_true_iff _).2 hs), + binaryRationalPositiveExpLower] + simp [RawRat.expApproxSteps, RawRat.expMagnitude, + binaryRatAdd_eq_add, binaryRatDiv_eq_div, + binaryRatPow_eq_pow] + | negSucc n => + have hs : Β¬ 0 ≀ ((⟨Int.negSucc n, den, hden⟩ : RawRat).value) := by + rw [RawRat.value] + have hn : (0 : β„š) ≀ n := by positivity + have hnum : (((Int.negSucc n : β„€) : β„š)) < 0 := by + norm_num only [Int.cast_negSucc, Nat.cast_add, Nat.cast_one] + linarith + have hdenQ : (0 : β„š) < den := by exact_mod_cast hden + exact not_le_of_gt (div_neg_of_neg_of_pos hnum hdenQ) + have hflag : Β¬ binaryRatNonnegative + ((⟨Int.negSucc n, den, hden⟩ : RawRat).value) = true := + fun h => hs ((binaryRatNonnegative_eq_true_iff _).1 h) + rw [binaryRationalExpLower, ite_eq_right hflag, + binaryRationalNegativeExpLower] + simp [RawRat.expApproxSteps, RawRat.expMagnitude, + binaryRatNeg_eq_neg, binaryRatSub_eq_sub, + binaryRatDiv_eq_div, binaryRatPow_eq_pow, + RawRat.value_neg] + ring + +theorem machineBoundedRationalExpLowerCode_encode + (guard : List Bool) (s loss : RawRat) + (hsteps : RawRat.expApproxSteps s loss ≀ guard.length) : + machineBoundedRationalExpLowerCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rationalBinaryCode (binaryRationalExpLower s.value loss.value) := by + rw [machineBoundedRationalExpLowerCode, + machineExpStepsRuler_encode guard s loss hsteps, + machineExpBaseCode_encode, + machineRationalPowerCode_encode] + exact congrArg rationalBinaryCode + (binaryNormalizeRawRat_expBasePow_eq s loss) + +theorem machineBoundedRationalExpLowerRawEntryCode_encode + (guard : List Bool) (s loss : RawRat) + (hsteps : RawRat.expApproxSteps s loss ≀ guard.length) : + machineBoundedRationalExpLowerRawEntryCode + (pair guard (pair (rawRatBinaryCode s) (rawRatBinaryCode loss))) = + rawRatBinaryCode + (rawRatOfRat (binaryRationalExpLower s.value loss.value)) := by + rw [machineBoundedRationalExpLowerRawEntryCode, + machineBoundedRationalExpLowerRawPowerCode, + machineExpStepsRuler_encode guard s loss hsteps, + machineExpBaseCode_encode, + machineRawRatPowerCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_expBasePow_eq] + simp [rawRatBinaryCode, rawRatOfRat, rationalEntryBinaryCode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalFloor.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalFloor.lean new file mode 100644 index 0000000000..2ff09cc2ca --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalFloor.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary + +/-! +# Polynomial-time rational floor and ceiling + +This file specializes the verified dyadic-floor machine at precision zero. +Floor and ceiling are returned as canonical signed binary integers. The +natural ceiling used by later schedules is returned in ordinary binary, not +unary: converting an unrestricted binary integer to a word of that length +would not be a polynomial-time operation. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Canonical signed binary code of the floor of an unreduced rational. -/ +def machineRationalFloorIntegerCode (word : List Bool) : List Bool := + machineDyadicFloorIntegerCode (pair [] word) + +/-- Canonical signed binary code of the ceiling of an unreduced rational. -/ +def machineRationalCeilIntegerCode (word : List Bool) : List Bool := + machineIntegerNegCode + (machineRationalFloorIntegerCode (machineRawRatNegCode word)) + +/-- Convert the project's canonical signed-integer code to ordinary natural +bits using `Int.toNat` semantics. -/ +def machineIntegerToNatBits (word : List Bool) : List Bool := + machineIfHead word [] word.tail + +/-- Ordinary binary bits of the nonnegative natural ceiling. -/ +def machineRationalCeilNatBits (word : List Bool) : List Bool := + machineIntegerToNatBits (machineRationalCeilIntegerCode word) + +theorem machineRationalFloorIntegerCode_mem_FP : + machineRationalFloorIntegerCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP + simpa only [machineRationalFloorIntegerCode] using! + machineCompose_mem_FP hpair machineDyadicFloorIntegerCode_mem_FP + +theorem machineRationalCeilIntegerCode_mem_FP : + machineRationalCeilIntegerCode ∈ Complexity.FP := by + have hneg := machineCompose_mem_FP machineRawRatNegCode_mem_FP + machineRationalFloorIntegerCode_mem_FP + simpa only [machineRationalCeilIntegerCode] using! + machineCompose_mem_FP hneg machineIntegerNegCode_mem_FP + +theorem machineIntegerToNatBits_mem_FP : + machineIntegerToNatBits ∈ Complexity.FP := by + simpa only [machineIntegerToNatBits] using! + machineIfHead_mem_FP id_mem_FP (machineConst_mem_FP []) + machineTail_mem_FP + +theorem machineRationalCeilNatBits_mem_FP : + machineRationalCeilNatBits ∈ Complexity.FP := by + simpa only [machineRationalCeilNatBits] using! + machineCompose_mem_FP machineRationalCeilIntegerCode_mem_FP + machineIntegerToNatBits_mem_FP + +theorem binaryRawFloorInt_eq_binaryRatFloor (q : RawRat) : + binaryRawDyadicFloorInt 0 q = binaryRatFloor q.value := by + rw [binaryRatFloor_eq_floor, binaryRawDyadicFloorInt_eq_floor] + norm_num + +theorem machineRationalFloorIntegerCode_encode (q : RawRat) : + machineRationalFloorIntegerCode (rawRatBinaryCode q) = + integerBinaryCode (binaryRatFloor q.value) := by + rw [machineRationalFloorIntegerCode] + simpa only [List.replicate_zero] using! + (machineDyadicFloorIntegerCode_encode 0 q).trans + (congrArg integerBinaryCode (binaryRawFloorInt_eq_binaryRatFloor q)) + +theorem machineRationalCeilIntegerCode_encode (q : RawRat) : + machineRationalCeilIntegerCode (rawRatBinaryCode q) = + integerBinaryCode (binaryRatCeil q.value) := by + rw [machineRationalCeilIntegerCode, machineRawRatNegCode_encode, + machineRationalFloorIntegerCode_encode, machineIntegerNegCode_encode] + congr 1 + simp [binaryRatCeil, binaryRatFloor_eq_floor] + +@[simp] theorem machineIntegerToNatBits_encode (z : β„€) : + machineIntegerToNatBits (integerBinaryCode z) = z.toNat.bits := by + cases z with + | ofNat n => simp [machineIntegerToNatBits, integerBinaryCode] + | negSucc n => simp [machineIntegerToNatBits, integerBinaryCode] + +theorem machineRationalCeilNatBits_encode (q : RawRat) : + machineRationalCeilNatBits (rawRatBinaryCode q) = + (Int.toNat (binaryRatCeil q.value)).bits := by + rw [machineRationalCeilNatBits, machineRationalCeilIntegerCode_encode, + machineIntegerToNatBits_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalLogSeries.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalLogSeries.lean new file mode 100644 index 0000000000..cc7a3dad99 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalLogSeries.lean @@ -0,0 +1,765 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalFloor +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower +public import LeanPool.BeyondBethe.BeyondBethe.BinaryDirectedElementary + +/-! +# Polynomial-time rational logarithm-series loop + +The iteration count is a unary ruler. A state stores the partial sum, the +current odd power, the fixed square of the input, the current odd denominator, +and a quartic-width guard. The guard makes the function polynomial-time on +arbitrary strings. The semantic part below proves that none of the three +guarded updates is truncated on a well-formed input. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The binary encoding of the raw-rational constant zero. -/ +def rawRatZeroCode : List Bool := rawRatBinaryCode RawRat.zero + +/-- Encodes logarithmic-series state as sum, current odd power, squared base, odd denominator, +and bound. -/ +def machineLogSeriesPack + (sum power square odd bound : List Bool) : List Bool := + pair sum (pair power (pair square (pair odd bound))) + +/-- Extracts the partial sum from the logarithmic-series state. -/ +def machineLogSeriesSumField (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the current odd power from the logarithmic-series state. -/ +def machineLogSeriesPowerField (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed squared series base. -/ +def machineLogSeriesSquareField (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the binary odd denominator of the current series term. -/ +def machineLogSeriesOddField (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the width bound stored in the logarithmic-series state. -/ +def machineLogSeriesBoundField (state : List Bool) : List Bool := + machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Encodes the current odd denominator as a raw rational with denominator one. -/ +def machineLogSeriesOddRawRatCode (state : List Bool) : List Bool := + pair (machineNaturalIntegerCode (machineLogSeriesOddField state)) [true] + +/-- Divides the current odd power by its odd denominator to form the next series term. -/ +def machineLogSeriesTermCandidate (state : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineLogSeriesPowerField state) + (machineLogSeriesOddRawRatCode state)) + +/-- Adds the current series term to the partial sum. -/ +def machineLogSeriesSumCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineLogSeriesSumField state) + (machineLogSeriesTermCandidate state)) + +/-- Multiplies the current odd power by the squared base to obtain the next odd power. -/ +def machineLogSeriesPowerCandidate (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineLogSeriesPowerField state) + (machineLogSeriesSquareField state)) + +/-- Increments the odd denominator by two. -/ +def machineLogSeriesOddCandidate (state : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineLogSeriesOddField state) [false, true]) + +/-- Truncates a candidate state component to the stored logarithmic-series width bound. -/ +def machineLogSeriesClamp + (candidate : List Bool β†’ List Bool) (state : List Bool) : List Bool := + (candidate state).take (machineLogSeriesBoundField state).length + +/-- Updates bounded sum, odd power, and odd denominator while retaining the square and bound. -/ +def machineLogSeriesStep (state : List Bool) : List Bool := + machineLogSeriesPack + (machineLogSeriesClamp machineLogSeriesSumCandidate state) + (machineLogSeriesClamp machineLogSeriesPowerCandidate state) + (machineLogSeriesSquareField state) + (machineLogSeriesClamp machineLogSeriesOddCandidate state) + (machineLogSeriesBoundField state) + +/-- Extracts the unary term-count ruler from the logarithmic-series input. -/ +def machineLogSeriesInputRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded raw-rational base of the logarithmic series. -/ +def machineLogSeriesInputBase (word : List Bool) : List Bool := + machinePairSecond word + +/-- A quartic guard. Its length dominates the cubic bit growth of every +well-formed partial sum while remaining polynomial on arbitrary inputs. -/ +def machineLogSeriesInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineBinaryMulWidth word) + +/-- Squares the encoded series base for initialization. -/ +def machineLogSeriesInitialSquareCandidate (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineLogSeriesInputBase word) + (machineLogSeriesInputBase word)) + +/-- Initializes a zero sum, bounded base and square, odd denominator one, and input-derived +bound. -/ +def machineLogSeriesInit (word : List Bool) : List Bool := + let bound := machineLogSeriesInputBound word + machineLogSeriesPack rawRatZeroCode + (List.take bound.length (machineLogSeriesInputBase word)) + (List.take bound.length (machineLogSeriesInitialSquareCandidate word)) + [true] bound + +/-- Packs five copies of the input bound to bound the complete series state. -/ +def machineLogSeriesWidth (word : List Bool) : List Bool := + let bound := machineLogSeriesInputBound word + machineLogSeriesPack bound bound bound bound bound + +/-- Runs one logarithmic-series step per bit of the term-count ruler. -/ +def machineLogSeriesFinalState (word : List Bool) : List Bool := + (machineLogSeriesStep)^[(machineLogSeriesInputRuler word).length] + (machineLogSeriesInit word) + +/-- Extracts the raw partial sum after the scheduled logarithmic-series iterations. -/ +def machineRawRationalLogSeriesSumCode (word : List Bool) : List Bool := + machineLogSeriesSumField (machineLogSeriesFinalState word) + +/-- Normalizes the computed raw logarithmic-series sum into a rational encoding. -/ +def machineRationalLogSeriesSumCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRationalLogSeriesSumCode word) + +theorem machineLogSeriesSumField_mem_FP : + machineLogSeriesSumField ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineLogSeriesPowerField_mem_FP : + machineLogSeriesPowerField ∈ Complexity.FP := by + simpa only [machineLogSeriesPowerField] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineLogSeriesSquareField_mem_FP : + machineLogSeriesSquareField ∈ Complexity.FP := by + have hrest := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineLogSeriesSquareField] using! + machineCompose_mem_FP hrest machinePairFirst_mem_FP + +theorem machineLogSeriesOddField_mem_FP : + machineLogSeriesOddField ∈ Complexity.FP := by + have hrest2 := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have hrest3 := machineCompose_mem_FP hrest2 machinePairSecond_mem_FP + simpa only [machineLogSeriesOddField] using! + machineCompose_mem_FP hrest3 machinePairFirst_mem_FP + +theorem machineLogSeriesBoundField_mem_FP : + machineLogSeriesBoundField ∈ Complexity.FP := by + have hrest2 := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have hrest3 := machineCompose_mem_FP hrest2 machinePairSecond_mem_FP + simpa only [machineLogSeriesBoundField] using! + machineCompose_mem_FP hrest3 machinePairSecond_mem_FP + +theorem machineLogSeriesOddRawRatCode_mem_FP : + machineLogSeriesOddRawRatCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machineLogSeriesOddField_mem_FP + (machinePrepend_mem_FP false) + exact machinePair_mem_FP hnum (machineConst_mem_FP [true]) + +theorem machineLogSeriesTermCandidate_mem_FP : + machineLogSeriesTermCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineLogSeriesPowerField_mem_FP + machineLogSeriesOddRawRatCode_mem_FP + simpa only [machineLogSeriesTermCandidate] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineLogSeriesSumCandidate_mem_FP : + machineLogSeriesSumCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineLogSeriesSumField_mem_FP + machineLogSeriesTermCandidate_mem_FP + simpa only [machineLogSeriesSumCandidate] using! + machineCompose_mem_FP hpair machineRawRatAddCode_mem_FP + +theorem machineLogSeriesPowerCandidate_mem_FP : + machineLogSeriesPowerCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineLogSeriesPowerField_mem_FP + machineLogSeriesSquareField_mem_FP + simpa only [machineLogSeriesPowerCandidate] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineLogSeriesOddCandidate_mem_FP : + machineLogSeriesOddCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineLogSeriesOddField_mem_FP + (machineConst_mem_FP [false, true]) + simpa only [machineLogSeriesOddCandidate] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineLogSeriesClamp_mem_FP + {candidate : List Bool β†’ List Bool} (hcandidate : candidate ∈ Complexity.FP) : + (fun state => machineLogSeriesClamp candidate state) ∈ Complexity.FP := by + simpa only [machineLogSeriesClamp] using! + machineTake_mem_FP machineLogSeriesBoundField_mem_FP hcandidate + +theorem machineLogSeriesStep_mem_FP : + machineLogSeriesStep ∈ Complexity.FP := by + exact machinePair_mem_FP + (machineLogSeriesClamp_mem_FP machineLogSeriesSumCandidate_mem_FP) + (machinePair_mem_FP + (machineLogSeriesClamp_mem_FP machineLogSeriesPowerCandidate_mem_FP) + (machinePair_mem_FP machineLogSeriesSquareField_mem_FP + (machinePair_mem_FP + (machineLogSeriesClamp_mem_FP machineLogSeriesOddCandidate_mem_FP) + machineLogSeriesBoundField_mem_FP))) + +theorem machineLogSeriesInputRuler_mem_FP : + machineLogSeriesInputRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineLogSeriesInputBase_mem_FP : + machineLogSeriesInputBase ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineLogSeriesInputBound_mem_FP : + machineLogSeriesInputBound ∈ Complexity.FP := by + simpa only [machineLogSeriesInputBound] using! + machineCompose_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineLogSeriesInitialSquareCandidate_mem_FP : + machineLogSeriesInitialSquareCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineLogSeriesInputBase_mem_FP + machineLogSeriesInputBase_mem_FP + simpa only [machineLogSeriesInitialSquareCandidate] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineLogSeriesInit_mem_FP : machineLogSeriesInit ∈ Complexity.FP := by + have hbase := machineTake_mem_FP machineLogSeriesInputBound_mem_FP + machineLogSeriesInputBase_mem_FP + have hsquare := machineTake_mem_FP machineLogSeriesInputBound_mem_FP + machineLogSeriesInitialSquareCandidate_mem_FP + simpa only [machineLogSeriesInit, machineLogSeriesPack] using! + machinePair_mem_FP (machineConst_mem_FP rawRatZeroCode) + (machinePair_mem_FP hbase + (machinePair_mem_FP hsquare + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineLogSeriesInputBound_mem_FP))) + +theorem machineLogSeriesWidth_mem_FP : + machineLogSeriesWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineLogSeriesInputBound_mem_FP + (machinePair_mem_FP machineLogSeriesInputBound_mem_FP + (machinePair_mem_FP machineLogSeriesInputBound_mem_FP + (machinePair_mem_FP machineLogSeriesInputBound_mem_FP + machineLogSeriesInputBound_mem_FP))) + +/-- Bounds all five components of a canonically packed logarithmic-series state. -/ +def MachineLogSeriesStateBound (word state : List Bool) : Prop := + state = machineLogSeriesPack + (machineLogSeriesSumField state) + (machineLogSeriesPowerField state) + (machineLogSeriesSquareField state) + (machineLogSeriesOddField state) + (machineLogSeriesBoundField state) ∧ + (machineLogSeriesSumField state).length ≀ + (machineLogSeriesInputBound word).length ∧ + (machineLogSeriesPowerField state).length ≀ + (machineLogSeriesInputBound word).length ∧ + (machineLogSeriesSquareField state).length ≀ + (machineLogSeriesInputBound word).length ∧ + (machineLogSeriesOddField state).length ≀ + (machineLogSeriesInputBound word).length ∧ + (machineLogSeriesBoundField state).length ≀ + (machineLogSeriesInputBound word).length + +@[simp] theorem machineLogSeriesFields_pack + (sum power square odd bound : List Bool) : + machineLogSeriesSumField + (machineLogSeriesPack sum power square odd bound) = sum ∧ + machineLogSeriesPowerField + (machineLogSeriesPack sum power square odd bound) = power ∧ + machineLogSeriesSquareField + (machineLogSeriesPack sum power square odd bound) = square ∧ + machineLogSeriesOddField + (machineLogSeriesPack sum power square odd bound) = odd ∧ + machineLogSeriesBoundField + (machineLogSeriesPack sum power square odd bound) = bound := by + simp [machineLogSeriesPack, machineLogSeriesSumField, + machineLogSeriesPowerField, machineLogSeriesSquareField, + machineLogSeriesOddField, machineLogSeriesBoundField] + +theorem machineLogSeriesInputBound_nontrivial (word : List Bool) : + 5 ≀ (machineLogSeriesInputBound word).length := by + simp [machineLogSeriesInputBound, machineBinaryMulWidth] + nlinarith + +theorem machineLogSeriesInit_bound (word : List Bool) : + MachineLogSeriesStateBound word (machineLogSeriesInit word) := by + simp only [MachineLogSeriesStateBound, machineLogSeriesInit, + machineLogSeriesFields_pack] + have hbound := machineLogSeriesInputBound_nontrivial word + constructor + Β· trivial + constructor + Β· simp [rawRatZeroCode, rawRatBinaryCode, RawRat.zero, + integerBinaryCode] + omega + constructor + Β· exact List.length_take_le _ _ + constructor + Β· exact List.length_take_le _ _ + constructor + Β· simp + omega + Β· exact le_rfl + +theorem machineLogSeriesStep_bound {word state : List Bool} + (hstate : MachineLogSeriesStateBound word state) : + MachineLogSeriesStateBound word (machineLogSeriesStep state) := by + rcases hstate with ⟨_, hsum, hpower, hsquare, hodd, hbound⟩ + simp only [MachineLogSeriesStateBound, machineLogSeriesStep, + machineLogSeriesFields_pack] + constructor + Β· trivial + constructor + Β· exact (List.length_take_le _ _).trans hbound + constructor + Β· exact (List.length_take_le _ _).trans hbound + constructor + Β· exact hsquare + constructor + Β· exact (List.length_take_le _ _).trans hbound + Β· exact hbound + +theorem machineLogSeriesIterate_bound (word : List Bool) : βˆ€ k, + MachineLogSeriesStateBound word + ((machineLogSeriesStep)^[k] (machineLogSeriesInit word)) := by + intro k + induction k with + | zero => exact machineLogSeriesInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineLogSeriesStep_bound ih + +theorem machineLogSeriesPack_length_le_width + (word state : List Bool) (hstate : MachineLogSeriesStateBound word state) : + state.length ≀ (machineLogSeriesWidth word).length := by + rcases hstate with ⟨hdecomp, hsum, hpower, hsquare, hodd, hbound⟩ + rw [hdecomp] + simp only [machineLogSeriesPack, machineLogSeriesWidth, pair_length] + omega + +theorem machineLogSeriesIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineLogSeriesInputRuler word).length) : + ((machineLogSeriesStep)^[iterations] + (machineLogSeriesInit word)).length ≀ + (machineLogSeriesWidth word).length := + machineLogSeriesPack_length_le_width word _ + (machineLogSeriesIterate_bound word iterations) + +theorem machineLogSeriesFinalState_mem_FP : + machineLogSeriesFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineLogSeriesStep_mem_FP + machineLogSeriesInit_mem_FP machineLogSeriesInputRuler_mem_FP + machineLogSeriesWidth_mem_FP machineLogSeriesIterate_length_le_width + +theorem machineRawRationalLogSeriesSumCode_mem_FP : + machineRawRationalLogSeriesSumCode ∈ Complexity.FP := by + simpa only [machineRawRationalLogSeriesSumCode] using! + machineCompose_mem_FP machineLogSeriesFinalState_mem_FP + machineLogSeriesSumField_mem_FP + +theorem machineRationalLogSeriesSumCode_mem_FP : + machineRationalLogSeriesSumCode ∈ Complexity.FP := by + simpa only [machineRationalLogSeriesSumCode] using! + machineCompose_mem_FP machineRawRationalLogSeriesSumCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +/-! ## Exact semantics on well-formed inputs -/ + +namespace RawRat + +def ofNat (n : β„•) : RawRat := ⟨n, 1, by omega⟩ + +@[simp] theorem value_ofNat (n : β„•) : (ofNat n).value = n := by + simp [ofNat, value] + +/-- The odd powers `x, x^3, x^5, ...`, maintained by multiplication by the +fixed square. -/ +def logOddPower (x : RawRat) : β„• β†’ RawRat + | 0 => x + | k + 1 => (logOddPower x k).mul (x.mul x) + +/-- Unreduced partial sums of the odd logarithm series. -/ +def logSeriesSum (x : RawRat) : β„• β†’ RawRat + | 0 => zero + | k + 1 => + (logSeriesSum x k).add + ((logOddPower x k).div (ofNat (2 * k + 1))) + +@[simp] theorem value_logOddPower (x : RawRat) : βˆ€ k, + (logOddPower x k).value = x.value ^ (2 * k + 1) := by + intro k + induction k with + | zero => simp [logOddPower] + | succ k ih => + rw [logOddPower, value_mul, ih, value_mul] + calc + x.value ^ (2 * k + 1) * (x.value * x.value) = + x.value ^ (2 * k + 1) * x.value ^ 2 := by rw [pow_two] + _ = x.value ^ ((2 * k + 1) + 2) := (pow_add _ _ _).symm + _ = x.value ^ (2 * (k + 1) + 1) := by congr 1 <;> omega + +@[simp] theorem value_logSeriesSum (x : RawRat) : βˆ€ k, + (logSeriesSum x k).value = binaryRationalLogSeriesSum x.value k := by + intro k + induction k with + | zero => simp [logSeriesSum, binaryRationalLogSeriesSum] + | succ k ih => + rw [logSeriesSum, value_add, value_div, value_logOddPower, + value_ofNat, binaryRationalLogSeriesSum, binaryRatAdd_eq_add, + binaryRatDiv_eq_div, binaryRatPow_eq_pow, ih] + push_cast + rfl + +theorem width_ofNat_le (n : β„•) : rawRatWidth (ofNat n) ≀ n + 1 := by + have hpow : n < 2 ^ (n + 1) := by + induction n with + | zero => norm_num + | succ n ih => + rw [pow_succ] + have hpos : 0 < 2 ^ (n + 1) := by positivity + omega + rw [rawRatWidth, ofNat] + simp only [Int.natAbs_ofNat', Nat.size_one] + exact max_le (Nat.size_le.mpr hpow) (by omega) + +theorem width_logOddPower_le (x : RawRat) : βˆ€ k, + rawRatWidth (logOddPower x k) ≀ (2 * k + 1) * rawRatWidth x := by + intro k + induction k with + | zero => simp [logOddPower] + | succ k ih => + rw [logOddPower] + have hsquare := rawRatWidth_mul_le x x + exact (rawRatWidth_mul_le _ _).trans (by nlinarith) + +theorem width_logSeriesSum_le (x : RawRat) : βˆ€ k, + rawRatWidth (logSeriesSum x k) ≀ + 1 + k * ((2 * k + 1) * rawRatWidth x + 2 * k + 4) := by + intro k + induction k with + | zero => simp [logSeriesSum, rawRatWidth_zero] + | succ k ih => + rw [logSeriesSum] + have hp := width_logOddPower_le x k + have hn := width_ofNat_le (2 * k + 1) + have ht := rawRatWidth_div_le (logOddPower x k) + (ofNat (2 * k + 1)) + have ha := rawRatWidth_add_le (logSeriesSum x k) + ((logOddPower x k).div (ofNat (2 * k + 1))) + nlinarith + +end RawRat + +private theorem logSeriesIntegerNatAbs_size_le_code_length (z : β„€) : + z.natAbs.size ≀ (integerBinaryCode z).length := by + cases z with + | ofNat n => simp [integerBinaryCode, Nat.size_eq_bits_len] + | negSucc n => + have hs : (n + 1).size ≀ n.size + 1 := by + rw [Nat.size_le] + have hle : n + 1 ≀ 2 ^ n.size := + Nat.succ_le_iff.mpr (Nat.lt_size_self n) + have hlt : 2 ^ n.size < 2 ^ (n.size + 1) := by + rw [pow_succ] + have hpos : 0 < 2 ^ n.size := by positivity + omega + exact hle.trans_lt hlt + simpa [integerBinaryCode, Nat.size_eq_bits_len, + Nat.add_comm] using! hs + +private theorem logSeriesRawRatWidth_le_code_length (q : RawRat) : + rawRatWidth q ≀ (rawRatBinaryCode q).length := by + rw [rawRatWidth, rawRatBinaryCode, pair_length] + apply max_le + Β· have h := logSeriesIntegerNatAbs_size_le_code_length q.num + omega + Β· rw [Nat.size_eq_bits_len] + omega + +private theorem logSeriesRawRatCode_length_le_width (q : RawRat) : + (rawRatBinaryCode q).length ≀ 4 + 3 * rawRatWidth q := by + rw [rawRatBinaryCode, pair_length] + have hnum : (integerBinaryCode q.num).length ≀ 1 + rawRatWidth q := by + cases hqnum : q.num with + | ofNat n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have habs := rawRat_num_size_le_width q + simp only [hqnum, Int.natAbs_ofNat'] at habs + omega + | negSucc n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have hsize : n.size ≀ (n + 1).size := + Nat.size_le_size (Nat.le_succ n) + have habs : (n + 1).size ≀ rawRatWidth q := by + simpa only [hqnum, Int.natAbs_negSucc] using! + rawRat_num_size_le_width q + omega + have hden := rawRat_den_size_le_width q + have hdenbits : q.den.bits.length ≀ rawRatWidth q := by + simpa only [Nat.size_eq_bits_len] using! hden + omega + +private theorem logSeriesCode_length_le_inputBound + (q r : RawRat) (total k : β„•) (hk : k ≀ total) + (hr : rawRatWidth r ≀ + 1 + (k + 1) * + ((2 * (k + 1) + 1) * rawRatWidth q + 2 * (k + 1) + 4)) : + (rawRatBinaryCode r).length ≀ + (machineLogSeriesInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := by + let word := pair (List.replicate total true) (rawRatBinaryCode q) + have hcode := logSeriesRawRatCode_length_le_width r + have htotal : total ≀ word.length := by + simp only [word, pair_length, List.length_replicate] + omega + have hqcode : (rawRatBinaryCode q).length ≀ word.length := by + simp only [word, pair_length, List.length_replicate] + omega + have hqwidth := (logSeriesRawRatWidth_le_code_length q).trans hqcode + have hkword : k ≀ word.length := hk.trans htotal + have hrword : rawRatWidth r ≀ + 1 + (word.length + 1) * + ((2 * (word.length + 1) + 1) * word.length + + 2 * (word.length + 1) + 4) := by + have hk1 : k + 1 ≀ word.length + 1 := by omega + have hfirst : 2 * (k + 1) + 1 ≀ 2 * (word.length + 1) + 1 := by omega + have hmul : (2 * (k + 1) + 1) * rawRatWidth q ≀ + (2 * (word.length + 1) + 1) * word.length := + Nat.mul_le_mul hfirst hqwidth + have hinner : + (2 * (k + 1) + 1) * rawRatWidth q + 2 * (k + 1) + 4 ≀ + (2 * (word.length + 1) + 1) * word.length + + 2 * (word.length + 1) + 4 := by omega + have hproduct := Nat.mul_le_mul hk1 hinner + exact hr.trans (Nat.add_le_add_left hproduct 1) + calc + (rawRatBinaryCode r).length ≀ 4 + 3 * rawRatWidth r := hcode + _ ≀ 4 + 3 * (1 + (word.length + 1) * + ((2 * (word.length + 1) + 1) * word.length + + 2 * (word.length + 1) + 4)) := by omega + _ ≀ (machineLogSeriesInputBound word).length := by + simp [machineLogSeriesInputBound, machineBinaryMulWidth] + nlinarith [sq_nonneg (word.length * word.length * + (word.length + 1))] + +private theorem logSeriesSumCode_length_le_inputBound + (q : RawRat) (total k : β„•) (hk : k ≀ total) : + (rawRatBinaryCode (RawRat.logSeriesSum q k)).length ≀ + (machineLogSeriesInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := + logSeriesCode_length_le_inputBound q _ total k hk + ((RawRat.width_logSeriesSum_le q k).trans (by nlinarith)) + +private theorem logSeriesPowerCode_length_le_inputBound + (q : RawRat) (total k : β„•) (hk : k ≀ total) : + (rawRatBinaryCode (RawRat.logOddPower q k)).length ≀ + (machineLogSeriesInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := by + apply logSeriesCode_length_le_inputBound q _ total k hk + have hp := RawRat.width_logOddPower_le q k + exact hp.trans (by nlinarith) + +private theorem logSeriesSquareCode_length_le_inputBound + (q : RawRat) (total : β„•) : + (rawRatBinaryCode (q.mul q)).length ≀ + (machineLogSeriesInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := by + apply logSeriesCode_length_le_inputBound q _ total 0 (by omega) + have hsquare := rawRatWidth_mul_le q q + exact hsquare.trans (by nlinarith) + +private theorem logSeriesOddBits_length_le_inputBound + (q : RawRat) (total k : β„•) (hk : k ≀ total) : + (2 * k + 1).bits.length ≀ + (machineLogSeriesInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := by + have hsize : (2 * k + 1).bits.length ≀ 2 * k + 2 := by + have hw := RawRat.width_ofNat_le (2 * k + 1) + rw [rawRatWidth, RawRat.ofNat] at hw + simp only [Int.natAbs_ofNat', Nat.size_one] at hw + have hs := (le_max_left (2 * k + 1).size 1).trans hw + simpa only [Nat.size_eq_bits_len] using! hs + let word := pair (List.replicate total true) (rawRatBinaryCode q) + have htotal : total ≀ word.length := by + simp only [word, pair_length, List.length_replicate] + omega + have hkword : k ≀ word.length := hk.trans htotal + have hlarge : 2 * word.length + 2 ≀ + (machineLogSeriesInputBound word).length := by + simp [machineLogSeriesInputBound, machineBinaryMulWidth] + nlinarith + exact hsize.trans ((by omega : 2 * k + 2 ≀ 2 * word.length + 2).trans hlarge) + +/-- Encodes the semantic series state after `k` terms, with next odd power and denominator `2*k ++ 1`. -/ +def rawLogSeriesMachineState (q : RawRat) (total k : β„•) : List Bool := + let word := pair (List.replicate total true) (rawRatBinaryCode q) + machineLogSeriesPack + (rawRatBinaryCode (RawRat.logSeriesSum q k)) + (rawRatBinaryCode (RawRat.logOddPower q k)) + (rawRatBinaryCode (q.mul q)) + (2 * k + 1).bits + (machineLogSeriesInputBound word) + +theorem machineLogSeriesInit_encode (q : RawRat) (total : β„•) : + machineLogSeriesInit + (pair (List.replicate total true) (rawRatBinaryCode q)) = + rawLogSeriesMachineState q total 0 := by + let word := pair (List.replicate total true) (rawRatBinaryCode q) + have hbase : (rawRatBinaryCode q).length ≀ + (machineLogSeriesInputBound word).length := by + simpa only [RawRat.logOddPower] using! + logSeriesPowerCode_length_le_inputBound q total 0 (by omega) + have hsquare := logSeriesSquareCode_length_le_inputBound q total + rw [machineLogSeriesInit] + simp only [machineLogSeriesInputBase, machinePairSecond_pair, + machineLogSeriesInitialSquareCandidate, + machineRawRatMulCode_encode] + rw [(List.take_eq_self_iff _).2 hbase, + (List.take_eq_self_iff _).2 hsquare] + simp [rawLogSeriesMachineState, rawRatZeroCode, + RawRat.logSeriesSum, RawRat.logOddPower] + +@[simp] theorem machineLogSeriesOddRawRatCode_encode + (q : RawRat) (total k : β„•) : + machineLogSeriesOddRawRatCode (rawLogSeriesMachineState q total k) = + rawRatBinaryCode (RawRat.ofNat (2 * k + 1)) := by + rw [machineLogSeriesOddRawRatCode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + rw [machineNaturalIntegerCode_natBits] + simp [rawRatBinaryCode, RawRat.ofNat] + +@[simp] theorem machineLogSeriesTermCandidate_encode + (q : RawRat) (total k : β„•) : + machineLogSeriesTermCandidate (rawLogSeriesMachineState q total k) = + rawRatBinaryCode + ((RawRat.logOddPower q k).div (RawRat.ofNat (2 * k + 1))) := by + rw [machineLogSeriesTermCandidate, + machineLogSeriesOddRawRatCode_encode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + rw [machineRawRatDivCode_encode] + +@[simp] theorem machineLogSeriesSumCandidate_encode + (q : RawRat) (total k : β„•) : + machineLogSeriesSumCandidate (rawLogSeriesMachineState q total k) = + rawRatBinaryCode (RawRat.logSeriesSum q (k + 1)) := by + rw [machineLogSeriesSumCandidate, + machineLogSeriesTermCandidate_encode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + rw [machineRawRatAddCode_encode] + rfl + +@[simp] theorem machineLogSeriesPowerCandidate_encode + (q : RawRat) (total k : β„•) : + machineLogSeriesPowerCandidate (rawLogSeriesMachineState q total k) = + rawRatBinaryCode (RawRat.logOddPower q (k + 1)) := by + rw [machineLogSeriesPowerCandidate] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack, + machineRawRatMulCode_encode] + rw [RawRat.logOddPower] + +@[simp] theorem machineLogSeriesOddCandidate_encode + (q : RawRat) (total k : β„•) : + machineLogSeriesOddCandidate (rawLogSeriesMachineState q total k) = + (2 * (k + 1) + 1).bits := by + rw [machineLogSeriesOddCandidate] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + have htwo : ([false, true] : List Bool) = (2 : β„•).bits := by rfl + rw [htwo, machineBinaryAddBits_pair_natBits] + congr 1 + +theorem machineLogSeriesStep_encode + (q : RawRat) (total k : β„•) (hk : k + 1 ≀ total) : + machineLogSeriesStep (rawLogSeriesMachineState q total k) = + rawLogSeriesMachineState q total (k + 1) := by + let word := pair (List.replicate total true) (rawRatBinaryCode q) + have hsum := logSeriesSumCode_length_le_inputBound q total (k + 1) hk + have hpower := logSeriesPowerCode_length_le_inputBound q total (k + 1) hk + have hodd := logSeriesOddBits_length_le_inputBound q total (k + 1) hk + have hsumClamp : + machineLogSeriesClamp machineLogSeriesSumCandidate + (rawLogSeriesMachineState q total k) = + rawRatBinaryCode (RawRat.logSeriesSum q (k + 1)) := by + rw [machineLogSeriesClamp, machineLogSeriesSumCandidate_encode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + exact (List.take_eq_self_iff _).2 hsum + have hpowerClamp : + machineLogSeriesClamp machineLogSeriesPowerCandidate + (rawLogSeriesMachineState q total k) = + rawRatBinaryCode (RawRat.logOddPower q (k + 1)) := by + rw [machineLogSeriesClamp, machineLogSeriesPowerCandidate_encode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + exact (List.take_eq_self_iff _).2 hpower + have hoddClamp : + machineLogSeriesClamp machineLogSeriesOddCandidate + (rawLogSeriesMachineState q total k) = + (2 * (k + 1) + 1).bits := by + rw [machineLogSeriesClamp, machineLogSeriesOddCandidate_encode] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + exact (List.take_eq_self_iff _).2 hodd + rw [machineLogSeriesStep, hsumClamp, hpowerClamp, hoddClamp] + simp only [rawLogSeriesMachineState, machineLogSeriesFields_pack] + +theorem machineLogSeriesIterate_encode (q : RawRat) (total : β„•) : + βˆ€ k ≀ total, + (machineLogSeriesStep)^[k] + (machineLogSeriesInit + (pair (List.replicate total true) (rawRatBinaryCode q))) = + rawLogSeriesMachineState q total k := by + intro k hk + induction k with + | zero => exact machineLogSeriesInit_encode q total + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineLogSeriesStep_encode q total k hk + +theorem machineRawRationalLogSeriesSumCode_encode + (q : RawRat) (N : β„•) : + machineRawRationalLogSeriesSumCode + (pair (List.replicate N true) (rawRatBinaryCode q)) = + rawRatBinaryCode (RawRat.logSeriesSum q N) := by + rw [machineRawRationalLogSeriesSumCode, + machineLogSeriesFinalState] + simp only [machineLogSeriesInputRuler, machinePairFirst_pair, + List.length_replicate] + rw [machineLogSeriesIterate_encode q N N le_rfl] + simp [rawLogSeriesMachineState] + +theorem machineRationalLogSeriesSumCode_encode + (q : RawRat) (N : β„•) : + machineRationalLogSeriesSumCode + (pair (List.replicate N true) (rawRatBinaryCode q)) = + rationalBinaryCode (binaryRationalLogSeriesSum q.value N) := by + rw [machineRationalLogSeriesSumCode, + machineRawRationalLogSeriesSumCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, RawRat.value_logSeriesSum] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixColumn.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixColumn.lean new file mode 100644 index 0000000000..d0b58c320b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixColumn.lean @@ -0,0 +1,648 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorDot +public import Mathlib.Data.List.GetD + +/-! +# Polynomial-time extraction of rational matrix columns + +Rational ellipsoid bases are stored row by row. This transducer scans those +rows, reads one unary-indexed entry from each row, and returns the resulting +column as a canonical rational-vector word. It is total on arbitrary words; +the exactness theorem only assumes that the selected column exists in every +row. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary column index from a matrix-column query. -/ +def machineRationalMatrixColumnIndex (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded rows from a matrix-column query. -/ +def machineRationalMatrixColumnRows (word : List Bool) : List Bool := + machinePairSecond word + +/-- Encodes column-extraction state as remaining rows, reversed column, index, and width bound. -/ +def machineRationalMatrixColumnPack + (remaining accumulator column bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair column bound)) + +/-- Extracts the rows not yet processed by column extraction. -/ +def machineRationalMatrixColumnRemaining + (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reversed accumulated column entries. -/ +def machineRationalMatrixColumnAccumulator + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed unary column index from the scan state. -/ +def machineRationalMatrixColumnColumn + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the width bound stored in the column-extraction state. -/ +def machineRationalMatrixColumnBound + (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Reads the first unprocessed matrix row. -/ +def machineRationalMatrixColumnCurrentRow + (state : List Bool) : List Bool := + machineListHead (machineRationalMatrixColumnRemaining state) + +/-- Looks up the selected column entry in the current row. -/ +def machineRationalMatrixColumnCurrentEntry + (state : List Bool) : List Bool := + machineListIndex + (pair (machineRationalMatrixColumnColumn state) + (machineRationalMatrixColumnCurrentRow state)) + +/-- Prepends the current column entry to the reversed accumulator. -/ +def machineRationalMatrixColumnCandidate + (state : List Bool) : List Bool := + pair (machineRationalMatrixColumnCurrentEntry state) + (machineRationalMatrixColumnAccumulator state) + +/-- Truncates the candidate column accumulator to the stored width bound. -/ +def machineRationalMatrixColumnNextAccumulator + (state : List Bool) : List Bool := + (machineRationalMatrixColumnCandidate state).take + (machineRationalMatrixColumnBound state).length + +/-- Consumes one row and stores its selected column entry while retaining the index and bound. -/ +def machineRationalMatrixColumnAdvance + (state : List Bool) : List Bool := + machineRationalMatrixColumnPack + (machineListTail (machineRationalMatrixColumnRemaining state)) + (machineRationalMatrixColumnNextAccumulator state) + (machineRationalMatrixColumnColumn state) + (machineRationalMatrixColumnBound state) + +/-- Processes the next row, leaving exhausted column-extraction states fixed. -/ +def machineRationalMatrixColumnStep + (state : List Bool) : List Bool := + machineIfEmpty (machineRationalMatrixColumnRemaining state) state + (machineRationalMatrixColumnAdvance state) + +/-- Initializes column extraction with the source rows, empty accumulator, fixed index, and +input-word bound. -/ +def machineRationalMatrixColumnInit (word : List Bool) : List Bool := + machineRationalMatrixColumnPack + (machineRationalMatrixColumnRows word) [] + (machineRationalMatrixColumnIndex word) word + +/-- Packs four copies of the input word to bound a column-extraction state. -/ +def machineRationalMatrixColumnWidth (word : List Bool) : List Bool := + machineRationalMatrixColumnPack word word word word + +/-- Runs column extraction for one step per input bit. -/ +def machineRationalMatrixColumnFinalState + (word : List Bool) : List Bool := + (machineRationalMatrixColumnStep)^[word.length] + (machineRationalMatrixColumnInit word) + +/-- Extracts the selected column entries in reverse row order. -/ +def machineRationalMatrixColumnReversedCode + (word : List Bool) : List Bool := + machineRationalMatrixColumnAccumulator + (machineRationalMatrixColumnFinalState word) + +/-- Input: `pair columnUnary nestedRowsCode`. -/ +def machineRationalMatrixColumnCode (word : List Bool) : List Bool := + machineListReverse (machineRationalMatrixColumnReversedCode word) + +theorem machineRationalMatrixColumnIndex_mem_FP : + machineRationalMatrixColumnIndex ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalMatrixColumnRows_mem_FP : + machineRationalMatrixColumnRows ∈ FP := machinePairSecond_mem_FP + +theorem machineRationalMatrixColumnRemaining_mem_FP : + machineRationalMatrixColumnRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalMatrixColumnAccumulator_mem_FP : + machineRationalMatrixColumnAccumulator ∈ FP := by + simpa only [machineRationalMatrixColumnAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalMatrixColumnColumn_mem_FP : + machineRationalMatrixColumnColumn ∈ FP := by + simpa only [machineRationalMatrixColumnColumn] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineRationalMatrixColumnBound_mem_FP : + machineRationalMatrixColumnBound ∈ FP := by + simpa only [machineRationalMatrixColumnBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineRationalMatrixColumnCurrentRow_mem_FP : + machineRationalMatrixColumnCurrentRow ∈ FP := by + simpa only [machineRationalMatrixColumnCurrentRow] using! + machineCompose_mem_FP machineRationalMatrixColumnRemaining_mem_FP + machineListHead_mem_FP + +theorem machineRationalMatrixColumnCurrentEntry_mem_FP : + machineRationalMatrixColumnCurrentEntry ∈ FP := by + have hp := machinePair_mem_FP machineRationalMatrixColumnColumn_mem_FP + machineRationalMatrixColumnCurrentRow_mem_FP + simpa only [machineRationalMatrixColumnCurrentEntry] using! + machineCompose_mem_FP hp machineListIndex_mem_FP + +theorem machineRationalMatrixColumnCandidate_mem_FP : + machineRationalMatrixColumnCandidate ∈ FP := + machinePair_mem_FP machineRationalMatrixColumnCurrentEntry_mem_FP + machineRationalMatrixColumnAccumulator_mem_FP + +theorem machineRationalMatrixColumnNextAccumulator_mem_FP : + machineRationalMatrixColumnNextAccumulator ∈ FP := by + simpa only [machineRationalMatrixColumnNextAccumulator] using! + machineTake_mem_FP machineRationalMatrixColumnBound_mem_FP + machineRationalMatrixColumnCandidate_mem_FP + +theorem machineRationalMatrixColumnAdvance_mem_FP : + machineRationalMatrixColumnAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalMatrixColumnRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalMatrixColumnNextAccumulator_mem_FP + (machinePair_mem_FP machineRationalMatrixColumnColumn_mem_FP + machineRationalMatrixColumnBound_mem_FP)) + +theorem machineRationalMatrixColumnStep_mem_FP : + machineRationalMatrixColumnStep ∈ FP := + machineIfEmpty_mem_FP machineRationalMatrixColumnRemaining_mem_FP + id_mem_FP machineRationalMatrixColumnAdvance_mem_FP + +theorem machineRationalMatrixColumnInit_mem_FP : + machineRationalMatrixColumnInit ∈ FP := by + exact machinePair_mem_FP machineRationalMatrixColumnRows_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineRationalMatrixColumnIndex_mem_FP id_mem_FP)) + +theorem machineRationalMatrixColumnWidth_mem_FP : + machineRationalMatrixColumnWidth ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP id_mem_FP)) + +@[simp] theorem machineRationalMatrixColumnRemaining_pack (a b c d) : + machineRationalMatrixColumnRemaining + (machineRationalMatrixColumnPack a b c d) = a := by + simp [machineRationalMatrixColumnRemaining, + machineRationalMatrixColumnPack] + +@[simp] theorem machineRationalMatrixColumnAccumulator_pack (a b c d) : + machineRationalMatrixColumnAccumulator + (machineRationalMatrixColumnPack a b c d) = b := by + simp [machineRationalMatrixColumnAccumulator, + machineRationalMatrixColumnPack] + +@[simp] theorem machineRationalMatrixColumnColumn_pack (a b c d) : + machineRationalMatrixColumnColumn + (machineRationalMatrixColumnPack a b c d) = c := by + simp [machineRationalMatrixColumnColumn, + machineRationalMatrixColumnPack] + +@[simp] theorem machineRationalMatrixColumnBound_pack (a b c d) : + machineRationalMatrixColumnBound + (machineRationalMatrixColumnPack a b c d) = d := by + simp [machineRationalMatrixColumnBound, + machineRationalMatrixColumnPack] + +/-- Bounds remaining rows, accumulated entries, and the column index while retaining the input +word as bound. -/ +def MachineRationalMatrixColumnStateBound + (word state : List Bool) : Prop := + state = machineRationalMatrixColumnPack + (machineRationalMatrixColumnRemaining state) + (machineRationalMatrixColumnAccumulator state) + (machineRationalMatrixColumnColumn state) + (machineRationalMatrixColumnBound state) ∧ + (machineRationalMatrixColumnRemaining state).length ≀ word.length ∧ + (machineRationalMatrixColumnAccumulator state).length ≀ word.length ∧ + (machineRationalMatrixColumnColumn state).length ≀ word.length ∧ + machineRationalMatrixColumnBound state = word + +theorem machineRationalMatrixColumnInit_bound (word : List Bool) : + MachineRationalMatrixColumnStateBound word + (machineRationalMatrixColumnInit word) := by + simp only [MachineRationalMatrixColumnStateBound, + machineRationalMatrixColumnInit, + machineRationalMatrixColumnRemaining_pack, + machineRationalMatrixColumnAccumulator_pack, + machineRationalMatrixColumnColumn_pack, + machineRationalMatrixColumnBound_pack] + exact ⟨trivial, machinePairSecond_length_le word, by simp, + machinePairFirst_length_le word, trivial⟩ + +theorem machineRationalMatrixColumnStep_bound {word state : List Bool} + (hs : MachineRationalMatrixColumnStateBound word state) : + MachineRationalMatrixColumnStateBound word + (machineRationalMatrixColumnStep state) := by + rcases hs with ⟨hdecomp, hremaining, hacc, hcolumn, hbound⟩ + by_cases hnil : machineRationalMatrixColumnRemaining state = [] + Β· rw [machineRationalMatrixColumnStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hcolumn, hbound⟩ + Β· rw [machineRationalMatrixColumnStep] + cases hcode : machineRationalMatrixColumnRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineRationalMatrixColumnAdvance] + simp only [MachineRationalMatrixColumnStateBound, + machineRationalMatrixColumnRemaining_pack, + machineRationalMatrixColumnAccumulator_pack, + machineRationalMatrixColumnColumn_pack, + machineRationalMatrixColumnBound_pack] + refine ⟨trivial, ?_, ?_, hcolumn, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalMatrixColumnRemaining state)).trans hremaining + Β· rw [machineRationalMatrixColumnNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalMatrixColumnIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalMatrixColumnStateBound word + ((machineRationalMatrixColumnStep)^[k] + (machineRationalMatrixColumnInit word)) := by + intro k + induction k with + | zero => exact machineRationalMatrixColumnInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalMatrixColumnStep_bound ih + +theorem machineRationalMatrixColumnIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalMatrixColumnStep)^[iterations] + (machineRationalMatrixColumnInit word)).length ≀ + (machineRationalMatrixColumnWidth word).length := by + rcases machineRationalMatrixColumnIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hcolumn, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalMatrixColumnPack, + machineRationalMatrixColumnWidth, pair_length] + omega + +theorem machineRationalMatrixColumnFinalState_mem_FP : + machineRationalMatrixColumnFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalMatrixColumnStep_mem_FP + machineRationalMatrixColumnInit_mem_FP id_mem_FP + machineRationalMatrixColumnWidth_mem_FP + machineRationalMatrixColumnIterate_length_le_width + +theorem machineRationalMatrixColumnReversedCode_mem_FP : + machineRationalMatrixColumnReversedCode ∈ FP := by + simpa only [machineRationalMatrixColumnReversedCode] using! + machineCompose_mem_FP machineRationalMatrixColumnFinalState_mem_FP + machineRationalMatrixColumnAccumulator_mem_FP + +theorem machineRationalMatrixColumnCode_mem_FP : + machineRationalMatrixColumnCode ∈ FP := by + simpa only [machineRationalMatrixColumnCode] using! + machineCompose_mem_FP machineRationalMatrixColumnReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact semantics -/ + +/-- Selects column `j` from each rational row, using zero when the row has no such entry. -/ +def rationalColumnOfRows (rows : List (List β„š)) (j : β„•) : List β„š := + rows.map fun row => row.getD j 0 + +/-- Requires every supplied row to contain an entry at column index `j`. -/ +def RationalRowsHaveColumn (rows : List (List β„š)) (j : β„•) : Prop := + βˆ€ row ∈ rows, j < row.length + +theorem rationalEntryCode_getD_length_le + (row : List β„š) (j : β„•) (hj : j < row.length) : + (rationalEntryBinaryCode (row.getD j 0)).length ≀ + (binaryListCode rationalEntryBinaryCode row).length := by + have hlength := machineListIndex_length_le_data + (pair (List.replicate j true) + (binaryListCode rationalEntryBinaryCode row)) + have hencode := machineListIndex_binaryListCode + rationalEntryBinaryCode row j hj + rw [hencode, machineListIndexData, machinePairSecond_pair] at hlength + simpa only [List.getD_eq_getElem row 0 hj] using! hlength + +theorem rationalColumnOfRows_code_length_le + (j : β„•) : βˆ€ rows : List (List β„š), + RationalRowsHaveColumn rows j β†’ + (binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows rows j)).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + intro rows + induction rows with + | nil => intro h; simp [rationalColumnOfRows, binaryListCode] + | cons row rows ih => + intro hvalid + have hrow : j < row.length := hvalid row (by simp) + have htail : RationalRowsHaveColumn rows j := by + intro r hr + exact hvalid r (by simp [hr]) + have hentry := rationalEntryCode_getD_length_le row j hrow + have hrec := ih htail + have hrec' : + (binaryListCode rationalEntryBinaryCode + ((rows.map fun r => r.getD j 0))).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + rows).length := by + simpa only [rationalColumnOfRows] using! hrec + change + (pair (rationalEntryBinaryCode (row.getD j 0)) + (binaryListCode rationalEntryBinaryCode + (rows.map fun r => r.getD j 0))).length ≀ + (pair (binaryListCode rationalEntryBinaryCode row) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + rows)).length + simp only [pair_length] + omega + +theorem rationalColumnOfRows_take_reverse_code_length_le + (rows : List (List β„š)) (j k : β„•) + (hvalid : RationalRowsHaveColumn rows j) : + (binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows (rows.take k) j).reverse).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length := by + have hmap : rationalColumnOfRows (rows.take k) j = + (rationalColumnOfRows rows j).take k := by + simp [rationalColumnOfRows, List.map_take] + rw [hmap] + exact (binaryListCode_take_reverse_length_le + rationalEntryBinaryCode (rationalColumnOfRows rows j) k).trans + (rationalColumnOfRows_code_length_le j rows hvalid) + +/-- Encodes column extraction after `k` rows, with the selected entries accumulated in reverse +order. -/ +def machineRationalMatrixColumnSemanticState + (rows : List (List β„š)) (j k : β„•) + (bound : List Bool) : List Bool := + machineRationalMatrixColumnPack + (binaryListCode (binaryListCode rationalEntryBinaryCode) (rows.drop k)) + (binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows (rows.take k) j).reverse) + (List.replicate j true) bound + +theorem machineRationalMatrixColumnInit_semantics + (rows : List (List β„š)) (j : β„•) : + let word := pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + machineRationalMatrixColumnInit word = + machineRationalMatrixColumnSemanticState rows j 0 word := by + simp [machineRationalMatrixColumnInit, + machineRationalMatrixColumnSemanticState, + machineRationalMatrixColumnRows, + machineRationalMatrixColumnIndex, rationalColumnOfRows, + binaryListCode] + +theorem machineRationalMatrixColumnStep_semantics + (rows : List (List β„š)) (j k : β„•) (bound : List Bool) + (hk : k < rows.length) + (hvalid : RationalRowsHaveColumn rows j) + (hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + bound.length) : + machineRationalMatrixColumnStep + (machineRationalMatrixColumnSemanticState rows j k bound) = + machineRationalMatrixColumnSemanticState rows j (k + 1) bound := by + have hdrop := List.drop_eq_getElem_cons hk + have hrow : j < rows[k].length := + hvalid rows[k] (List.getElem_mem hk) + have hprefix : + rationalColumnOfRows (rows.take (k + 1)) j = + rationalColumnOfRows (rows.take k) j ++ [rows[k].getD j 0] := by + simp only [rationalColumnOfRows, List.map_take] + have hkm : k < + (rows.map fun row => row.getD j 0).length := by + simpa using! hk + simpa using! + (List.take_concat_get + (l := rows.map fun row => row.getD j 0) hkm).symm + have hreverse : + (rationalColumnOfRows (rows.take (k + 1)) j).reverse = + rows[k].getD j 0 :: + (rationalColumnOfRows (rows.take k) j).reverse := by + rw [hprefix, List.reverse_append] + simp + have hcand : + (binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows (rows.take (k + 1)) j).reverse).length ≀ + bound.length := + (rationalColumnOfRows_take_reverse_code_length_le + rows j (k + 1) hvalid).trans hbound + have hnonempty : + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rows.drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil + (binaryListCode rationalEntryBinaryCode) rows[k] + (rows.drop (k + 1)) + have hcandPair : + (pair (rationalEntryBinaryCode (rows[k].getD j 0)) + (binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows (rows.take k) j).reverse)).length ≀ + bound.length := by + simpa only [hreverse, binaryListCode] using! hcand + rw [machineRationalMatrixColumnStep] + simp only [machineRationalMatrixColumnSemanticState, + machineRationalMatrixColumnRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalMatrixColumnAdvance] + simp only [machineRationalMatrixColumnRemaining_pack, + machineRationalMatrixColumnAccumulator_pack, + machineRationalMatrixColumnColumn_pack, + machineRationalMatrixColumnBound_pack, + machineRationalMatrixColumnNextAccumulator, + machineRationalMatrixColumnCandidate, + machineRationalMatrixColumnCurrentEntry, + machineRationalMatrixColumnCurrentRow] + rw [hdrop, machineListHead_cons, machineListTail_cons, + machineListIndex_binaryListCode rationalEntryBinaryCode rows[k] j hrow] + rw [← List.getD_eq_getElem rows[k] 0 hrow] + rw [List.take_of_length_le hcandPair] + rw [hreverse] + rfl + +theorem machineRationalMatrixColumnIterate_semantics + (rows : List (List β„š)) (j : β„•) + (hvalid : RationalRowsHaveColumn rows j) : βˆ€ k ≀ rows.length, + let word := pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + (machineRationalMatrixColumnStep)^[k] + (machineRationalMatrixColumnInit word) = + machineRationalMatrixColumnSemanticState rows j k word := by + intro k hk + let word := pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + change (machineRationalMatrixColumnStep)^[k] + (machineRationalMatrixColumnInit word) = + machineRationalMatrixColumnSemanticState rows j k word + have hrowsBound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machinePairSecond word).length := by simp [word] + _ ≀ word.length := machinePairSecond_length_le word + induction k with + | zero => + simpa only [word] using! + (machineRationalMatrixColumnInit_semantics rows j) + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalMatrixColumnStep_semantics + rows j k word (by omega) hvalid hrowsBound + +theorem machineRationalMatrixColumn_done_iterate + (extra : β„•) (accumulator column bound : List Bool) : + (machineRationalMatrixColumnStep)^[extra] + (machineRationalMatrixColumnPack [] accumulator column bound) = + machineRationalMatrixColumnPack [] accumulator column bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalMatrixColumnStep] + +theorem machineRationalMatrixColumnReversedCode_encode + (rows : List (List β„š)) (j : β„•) + (hvalid : RationalRowsHaveColumn rows j) : + let word := pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + machineRationalMatrixColumnReversedCode word = + binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows rows j).reverse := by + let word := pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + change machineRationalMatrixColumnReversedCode word = _ + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + calc + _ = (machinePairSecond word).length := by simp [word] + _ ≀ word.length := machinePairSecond_length_le word + have hwork : rows.length ≀ word.length := + (list_length_le_binaryListCode_length + (binaryListCode rationalEntryBinaryCode) rows).trans hrowsCode + have hsplit : word.length = (word.length - rows.length) + rows.length := by + omega + rw [machineRationalMatrixColumnReversedCode, + machineRationalMatrixColumnFinalState, hsplit, + Function.iterate_add_apply, + machineRationalMatrixColumnIterate_semantics rows j hvalid + rows.length le_rfl] + simp only [machineRationalMatrixColumnSemanticState, + List.drop_length, List.take_length, + binaryListCode] + rw [machineRationalMatrixColumn_done_iterate] + simp + +@[simp] theorem machineRationalMatrixColumnCode_rows_encode + (rows : List (List β„š)) (j : β„•) + (hvalid : RationalRowsHaveColumn rows j) : + machineRationalMatrixColumnCode + (pair (List.replicate j true) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows)) = + binaryListCode rationalEntryBinaryCode + (rationalColumnOfRows rows j) := by + rw [machineRationalMatrixColumnCode, + machineRationalMatrixColumnReversedCode_encode rows j hvalid, + machineListReverse_encode, List.reverse_reverse] + +theorem rationalMatrixRows_haveColumn {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (j : Fin d) : + RationalRowsHaveColumn (rationalMatrixRows A) j.1 := by + intro row hrow + rw [rationalMatrixRows] at hrow + obtain ⟨i, hi⟩ := List.mem_ofFn.mp hrow + subst row + simp + +theorem rationalColumnOfRows_matrix {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (j : Fin d) : + rationalColumnOfRows (rationalMatrixRows A) j.1 = + List.ofFn (fun i : Fin d => A i j) := by + apply List.ext_getElem + Β· simp [rationalColumnOfRows, rationalMatrixRows] + Β· intro i hiLeft hiRight + simp only [rationalColumnOfRows, rationalMatrixRows, + List.getElem_map, List.getElem_ofFn] + have hj : j.1 < + (List.ofFn fun j' : Fin d => A ⟨i, by simpa using! hiRight⟩ j').length := by + simp + rw [List.getD_eq_getElem _ _ hj] + simp + +@[simp] theorem machineRationalMatrixColumnCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (j : Fin d) : + machineRationalMatrixColumnCode + (pair (List.replicate j.1 true) + (rationalSquareMatrixRowsCode A)) = + rationalFiniteVectorCode (fun i : Fin d => A i j) := by + rw [rationalSquareMatrixRowsCode, + machineRationalMatrixColumnCode_rows_encode + (rationalMatrixRows A) j.1 (rationalMatrixRows_haveColumn A j), + rationalColumnOfRows_matrix] + rfl + +/-! ## One coordinate of a transpose--vector product -/ + +/-- Input: +`pair columnUnary (pair nestedMatrixRowsCode rationalVectorCode)`. -/ +def machineRationalMatrixTransposeMulVectorEntryCode + (word : List Bool) : List Bool := + let column := machinePairFirst word + let payload := machinePairSecond word + let matrixRows := machinePairFirst payload + let vector := machinePairSecond payload + machineRationalVectorDotEntryCode + (pair + (machineRationalMatrixColumnCode (pair column matrixRows)) + vector) + +theorem machineRationalMatrixTransposeMulVectorEntryCode_mem_FP : + machineRationalMatrixTransposeMulVectorEntryCode ∈ FP := by + have hcolumn := machinePairFirst_mem_FP + have hpayload := machinePairSecond_mem_FP + have hmatrix := machineCompose_mem_FP hpayload machinePairFirst_mem_FP + have hvector := machineCompose_mem_FP hpayload machinePairSecond_mem_FP + have hcolumnInput := machinePair_mem_FP hcolumn hmatrix + have hcolumnCode := machineCompose_mem_FP hcolumnInput + machineRationalMatrixColumnCode_mem_FP + have hdotInput := machinePair_mem_FP hcolumnCode hvector + simpa only [machineRationalMatrixTransposeMulVectorEntryCode] using! + machineCompose_mem_FP hdotInput + machineRationalVectorDotEntryCode_mem_FP + +@[simp] theorem + machineRationalMatrixTransposeMulVectorEntryCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) (j : Fin d) : + machineRationalMatrixTransposeMulVectorEntryCode + (pair (List.replicate j.1 true) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v))) = + rationalEntryBinaryCode (βˆ‘ i, A i j * v i) := by + rw [machineRationalMatrixTransposeMulVectorEntryCode] + simp only [machinePairFirst_pair, machinePairSecond_pair] + rw [machineRationalMatrixColumnCode_encode, + machineRationalVectorDotEntryCode_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMul.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMul.lean new file mode 100644 index 0000000000..58ca9c9cf2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMul.lean @@ -0,0 +1,704 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMulVector + +/-! +# Polynomial-time rational matrix multiplication + +This module gives an ordinary finite-word implementation of exact square +matrix multiplication. A row of `A * B` is obtained as `Bα΅€` times the +corresponding row of `A`; the already verified transpose--vector machine +therefore supplies the arithmetic kernel. A bounded outer scan assembles +the rows. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The square rational matrix product, computed by summing entrywise products over the inner +index. -/ +def rationalMatrixMul {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : Matrix (Fin d) (Fin d) β„š := + fun i j ↦ βˆ‘ k, A i k * B k j + +theorem rationalMatrixMul_eq_matrix_mul {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + rationalMatrixMul A B = A * B := by + rfl + +/-- Encodes a unary dimension and the row encodings of two square rational matrices. -/ +def rationalMatrixMulCanonicalWord {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : List Bool := + pair (List.replicate d true) + (pair (rationalSquareMatrixRowsCode A) + (rationalSquareMatrixRowsCode B)) + +/-- Extracts the unary dimension ruler from a matrix-product query. -/ +def machineRationalMatrixMulDimensionUnary + (word : List Bool) : List Bool := machinePairFirst word + +/-- Extracts the paired left and right row encodings from a matrix-product query. -/ +def machineRationalMatrixMulMatrices + (word : List Bool) : List Bool := machinePairSecond word + +/-- Extracts the left matrix's encoded rows. -/ +def machineRationalMatrixMulLeftRows + (word : List Bool) : List Bool := + machinePairFirst (machineRationalMatrixMulMatrices word) + +/-- Extracts the right matrix's encoded rows. -/ +def machineRationalMatrixMulRightRows + (word : List Bool) : List Bool := + machinePairSecond (machineRationalMatrixMulMatrices word) + +/-- Input: `pair rowUnary canonicalMatrixMulWord`. -/ +def machineRationalMatrixMulRowCode + (word : List Bool) : List Bool := + let rowUnary := machinePairFirst word + let payload := machinePairSecond word + let leftRow := machineListIndex + (pair rowUnary (machineRationalMatrixMulLeftRows payload)) + machineRationalTransposeMulVectorCode + (pair (machineRationalMatrixMulDimensionUnary payload) + (pair (machineRationalMatrixMulRightRows payload) leftRow)) + +theorem machineRationalMatrixMulDimensionUnary_mem_FP : + machineRationalMatrixMulDimensionUnary ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalMatrixMulMatrices_mem_FP : + machineRationalMatrixMulMatrices ∈ FP := machinePairSecond_mem_FP + +theorem machineRationalMatrixMulLeftRows_mem_FP : + machineRationalMatrixMulLeftRows ∈ FP := by + simpa only [machineRationalMatrixMulLeftRows] using! + machineCompose_mem_FP machineRationalMatrixMulMatrices_mem_FP + machinePairFirst_mem_FP + +theorem machineRationalMatrixMulRightRows_mem_FP : + machineRationalMatrixMulRightRows ∈ FP := by + simpa only [machineRationalMatrixMulRightRows] using! + machineCompose_mem_FP machineRationalMatrixMulMatrices_mem_FP + machinePairSecond_mem_FP + +theorem machineRationalMatrixMulRowCode_mem_FP : + machineRationalMatrixMulRowCode ∈ FP := by + have hrow := machinePairFirst_mem_FP + have hpayload := machinePairSecond_mem_FP + have hleftRows := machineCompose_mem_FP hpayload + machineRationalMatrixMulLeftRows_mem_FP + have hleftRow := machineCompose_mem_FP + (machinePair_mem_FP hrow hleftRows) machineListIndex_mem_FP + have hdim := machineCompose_mem_FP hpayload + machineRationalMatrixMulDimensionUnary_mem_FP + have hrightRows := machineCompose_mem_FP hpayload + machineRationalMatrixMulRightRows_mem_FP + have hinput := machinePair_mem_FP hdim + (machinePair_mem_FP hrightRows hleftRow) + simpa only [machineRationalMatrixMulRowCode] using! + machineCompose_mem_FP hinput machineRationalTransposeMulVectorCode_mem_FP + +theorem rationalTransposeMulVector_row_eq_matrixMul {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i : Fin d) : + rationalTransposeMulVector B (fun k ↦ A i k) = + fun j ↦ rationalMatrixMul A B i j := by + funext j + simp only [rationalTransposeMulVector, rationalMatrixMul] + apply Finset.sum_congr rfl + intro k _ + exact mul_comm _ _ + +@[simp] theorem machineRationalMatrixMulRowCode_encode {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i : Fin d) : + machineRationalMatrixMulRowCode + (pair (List.replicate i.1 true) + (rationalMatrixMulCanonicalWord A B)) = + rationalFiniteVectorCode (fun j ↦ rationalMatrixMul A B i j) := by + rw [machineRationalMatrixMulRowCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineRationalMatrixMulLeftRows, + machineRationalMatrixMulRightRows, + machineRationalMatrixMulMatrices, + machineRationalMatrixMulDimensionUnary, + rationalMatrixMulCanonicalWord, + rationalSquareMatrixRowsCode] + rw [machineListIndex_binaryListCode] + Β· simp only [rationalMatrixRows, List.getElem_ofFn] + change machineRationalTransposeMulVectorCode + (rationalTransposeMulVectorCanonicalWord B (fun k ↦ A i k)) = _ + rw [machineRationalTransposeMulVectorCode_encode, + rationalTransposeMulVector_row_eq_matrixMul] + Β· simp [rationalMatrixRows] + +/-! ## A global ordinary-binary output bound -/ + +/-- Computes a product entry as the raw dot product of a left row with a right column. -/ +def rawRationalMatrixMulCoordinate {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : RawRat := + rawRatListDot RawRat.zero (List.ofFn fun k ↦ A i k) + (rationalColumnOfRows (rationalMatrixRows B) j.1) + +theorem rawRationalMatrixMulCoordinate_value {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : + (rawRationalMatrixMulCoordinate A B i j).value = + rationalMatrixMul A B i j := by + rw [rawRationalMatrixMulCoordinate, + rationalColumnOfRows_matrix, rawRatListDot_ofFn_value] + rfl + +theorem rawRationalMatrixMulCoordinate_width_le_word {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : + rawRatWidth (rawRationalMatrixMulCoordinate A B i j) ≀ + (rationalMatrixMulCanonicalWord A B).length := by + let row := List.ofFn fun k : Fin d ↦ A i k + let column := rationalColumnOfRows (rationalMatrixRows B) j.1 + have hwidth := rawRatWidth_listDot_le RawRat.zero row column + simp only [rawRatWidth_zero] at hwidth + have hcost := rawRatListDotCost_le_codeLength row column + have hrow : + (binaryListCode rationalEntryBinaryCode row).length ≀ + (rationalSquareMatrixRowsCode A).length := by + have helem := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) + (show row ∈ rationalMatrixRows A by + simp [rationalMatrixRows, row]) + simpa only [rationalSquareMatrixRowsCode] using! helem + have hcolumn : + (binaryListCode rationalEntryBinaryCode column).length ≀ + (rationalSquareMatrixRowsCode B).length := by + simpa only [column, rationalSquareMatrixRowsCode] using! + rationalColumnOfRows_code_length_le j.1 + (rationalMatrixRows B) (rationalMatrixRows_haveColumn B j) + have hcombined : + 1 + (binaryListCode rationalEntryBinaryCode row).length + + (binaryListCode rationalEntryBinaryCode column).length ≀ + (rationalMatrixMulCanonicalWord A B).length := by + simp only [rationalMatrixMulCanonicalWord, pair_length, + List.length_replicate] + omega + change rawRatWidth (rawRatListDot RawRat.zero row column) ≀ _ + omega + +theorem rationalMatrixMul_entry_code_length_le {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : + (rationalEntryBinaryCode (rationalMatrixMul A B i j)).length ≀ + 64 + 36 * (rationalMatrixMulCanonicalWord A B).length := by + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (rawRationalMatrixMulCoordinate A B i j) + rw [binaryNormalizeRawRat_eq_value, + rawRationalMatrixMulCoordinate_value] at hcanonical + exact hcanonical.trans (Nat.add_le_add_left + (Nat.mul_le_mul_left 36 + (rawRationalMatrixMulCoordinate_width_le_word A B i j)) 64) + +/-- Reuses the transpose-vector width bound for matrix-product state. -/ +def machineRationalMatrixMulInputBound (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineRationalMatrixMulInputBound_mem_FP : + machineRationalMatrixMulInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem rationalMatrixMul_code_length_le_cubic {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + (rationalSquareMatrixRowsCode (rationalMatrixMul A B)).length ≀ + d * (2 * (d * + (2 * (64 + 36 * (rationalMatrixMulCanonicalWord A B).length) + 2)) + + 2) := by + let L := 64 + 36 * (rationalMatrixMulCanonicalWord A B).length + have hentry : βˆ€ i j : Fin d, + (rationalEntryBinaryCode (rationalMatrixMul A B i j)).length ≀ L := by + intro i j + exact rationalMatrixMul_entry_code_length_le A B i j + rw [rationalSquareMatrixRowsCode, binaryListCode_length_eq_sum] + simp only [rationalMatrixRows, List.map_ofFn, List.sum_ofFn, + Function.comp_apply] + calc + (βˆ‘ i : Fin d, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalMatrixMul A B i j)).length + 2)) ≀ + βˆ‘ _i : Fin d, (2 * (d * (2 * L + 2)) + 2) := by + apply Finset.sum_le_sum + intro i _ + gcongr + rw [binaryListCode_length_eq_sum] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + calc + (βˆ‘ j : Fin d, + (2 * (rationalEntryBinaryCode + (rationalMatrixMul A B i j)).length + 2)) ≀ + βˆ‘ _j : Fin d, (2 * L + 2) := by + apply Finset.sum_le_sum + intro j _ + have h := hentry i j + omega + _ = d * (2 * L + 2) := by simp [mul_comm] + _ = d * (2 * (d * (2 * L + 2)) + 2) := by simp [mul_comm] + +theorem rationalMatrixMul_code_length_le_bound {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + (rationalSquareMatrixRowsCode (rationalMatrixMul A B)).length ≀ + (machineRationalMatrixMulInputBound + (rationalMatrixMulCanonicalWord A B)).length := by + let word := rationalMatrixMulCanonicalWord A B + let n := word.length + let x := 16 + n + let y := 16 + x ^ 2 + let z := 16 + y ^ 2 + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalMatrixMulCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hn4 : 4 ≀ n := by + simp only [n, word, rationalMatrixMulCanonicalWord, pair_length, + List.length_replicate] + omega + have hcubic := rationalMatrixMul_code_length_le_cubic A B + have hd' : d ≀ n := by simpa only [n] using! hd + have hdn : d * n ≀ n * n := Nat.mul_le_mul hd' le_rfl + have hdd : d * d ≀ n * n := Nat.mul_le_mul hd' hd' + have hddn : (d * d) * n ≀ (n * n) * n := + Nat.mul_le_mul hdd le_rfl + have hpoly : + d * (2 * (d * (2 * (64 + 36 * n) + 2)) + 2) ≀ + 211 * n ^ 3 := by + nlinarith + have hout : + (rationalSquareMatrixRowsCode (rationalMatrixMul A B)).length ≀ + 211 * n ^ 3 := by + apply hcubic.trans + simpa only [n, word] using! hpoly + have hnx : n ≀ x := by simp [x] + have hxpos : 0 < x := by omega + have h211 : 211 ≀ x ^ 2 := by + dsimp only [x] + nlinarith + have hnx3 : n ^ 3 ≀ x ^ 3 := Nat.pow_le_pow_left hnx 3 + have hto5 : 211 * n ^ 3 ≀ x ^ 5 := by + have h := Nat.mul_le_mul h211 hnx3 + simpa only [pow_succ, pow_two, mul_assoc, mul_left_comm, + mul_comm] using! h + have hto8 : x ^ 5 ≀ x ^ 8 := + Nat.pow_le_pow_right hxpos (by omega) + have hxy : x ^ 2 ≀ y := by simp [y] + have hx4y2 : x ^ 4 ≀ y ^ 2 := by + have h := Nat.pow_le_pow_left hxy 2 + simpa only [← pow_mul] using! h + have hyz : y ^ 2 ≀ z := by simp [z] + have hx4z : x ^ 4 ≀ z := hx4y2.trans hyz + have hx8z2 : x ^ 8 ≀ z ^ 2 := by + have h := Nat.pow_le_pow_left hx4z 2 + simpa only [← pow_mul] using! h + apply hout.trans + apply hto5.trans + apply hto8.trans + apply hx8z2.trans_eq + simp only [machineRationalMatrixMulInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, n, x, y, z, word, pow_two] + +/-! ## Bounded outer row scan -/ + +/-- Encodes the range of row indices to generate in the matrix product. -/ +def machineRationalMatrixMulIndices (word : List Bool) : List Bool := + machineUnaryRangeCode (machineRationalMatrixMulDimensionUnary word) + +/-- Computes the product row at the current scan index from the stored matrix payload. -/ +def machineRationalMatrixMulCurrentRow (state : List Bool) : List Bool := + machineRationalMatrixMulRowCode + (pair (machineRationalTransposeMulVectorCurrentIndex state) + (machineRationalTransposeMulVectorStatePayload state)) + +/-- Prepends the current product row to the reversed output accumulator. -/ +def machineRationalMatrixMulCandidate (state : List Bool) : List Bool := + pair (machineRationalMatrixMulCurrentRow state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate product-row accumulator to the stored bound. -/ +def machineRationalMatrixMulNextAccumulator + (state : List Bool) : List Bool := + (machineRationalMatrixMulCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Consumes one row index and updates the bounded product accumulator, retaining payload and +bound. -/ +def machineRationalMatrixMulAdvance (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineRationalMatrixMulNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Generates the next product row, leaving exhausted matrix-product scans fixed. -/ +def machineRationalMatrixMulStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineRationalMatrixMulAdvance state) + +/-- Initializes matrix multiplication with all row indices, empty output, input payload, and +width bound. -/ +def machineRationalMatrixMulInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineRationalMatrixMulIndices word) [] word + (machineRationalMatrixMulInputBound word) + +/-- Packs four copies of the matrix-product input bound to bound its scan state. -/ +def machineRationalMatrixMulWidth (word : List Bool) : List Bool := + let bound := machineRationalMatrixMulInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs matrix-product row generation for one step per input bit. -/ +def machineRationalMatrixMulFinalState (word : List Bool) : List Bool := + (machineRationalMatrixMulStep)^[word.length] + (machineRationalMatrixMulInit word) + +/-- Extracts the generated matrix-product rows in reverse order. -/ +def machineRationalMatrixMulReversedCode (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineRationalMatrixMulFinalState word) + +/-- Input: `pair dimensionUnary (pair leftRowsCode rightRowsCode)`. -/ +def machineRationalMatrixMulCode (word : List Bool) : List Bool := + machineListReverse (machineRationalMatrixMulReversedCode word) + +theorem machineRationalMatrixMulIndices_mem_FP : + machineRationalMatrixMulIndices ∈ FP := by + simpa only [machineRationalMatrixMulIndices] using! + machineCompose_mem_FP machineRationalMatrixMulDimensionUnary_mem_FP + machineUnaryRangeCode_mem_FP + +theorem machineRationalMatrixMulCurrentRow_mem_FP : + machineRationalMatrixMulCurrentRow ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalTransposeMulVectorCurrentIndex_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + simpa only [machineRationalMatrixMulCurrentRow] using! + machineCompose_mem_FP hinput machineRationalMatrixMulRowCode_mem_FP + +theorem machineRationalMatrixMulCandidate_mem_FP : + machineRationalMatrixMulCandidate ∈ FP := + machinePair_mem_FP machineRationalMatrixMulCurrentRow_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalMatrixMulNextAccumulator_mem_FP : + machineRationalMatrixMulNextAccumulator ∈ FP := by + simpa only [machineRationalMatrixMulNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineRationalMatrixMulCandidate_mem_FP + +theorem machineRationalMatrixMulAdvance_mem_FP : + machineRationalMatrixMulAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalMatrixMulNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineRationalMatrixMulStep_mem_FP : + machineRationalMatrixMulStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineRationalMatrixMulAdvance_mem_FP + +theorem machineRationalMatrixMulInit_mem_FP : + machineRationalMatrixMulInit ∈ FP := by + exact machinePair_mem_FP machineRationalMatrixMulIndices_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP id_mem_FP + machineRationalMatrixMulInputBound_mem_FP)) + +theorem machineRationalMatrixMulWidth_mem_FP : + machineRationalMatrixMulWidth ∈ FP := by + have hbound := machineRationalMatrixMulInputBound_mem_FP + exact machinePair_mem_FP hbound + (machinePair_mem_FP hbound (machinePair_mem_FP hbound hbound)) + +theorem machineRationalMatrixMulInit_bound (word : List Bool) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalMatrixMulInit word) := by + simp only [MachineRationalTransposeMulVectorStateBound, + machineRationalMatrixMulInit, + machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalMatrixMulInputBound] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineRationalMatrixMulIndices, + machineRationalMatrixMulDimensionUnary, + machineRationalTransposeMulVectorIndices, + machineRationalTransposeMulVectorDimension] using! + machineRationalTransposeMulVector_indices_le_bound word + Β· exact machineRationalTransposeMulVector_word_le_bound word + +theorem machineRationalMatrixMulStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalMatrixMulStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineRationalMatrixMulStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineRationalMatrixMulStep, hcode, machineIfEmpty_cons, + machineRationalMatrixMulAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineRationalMatrixMulNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalMatrixMulIterate_bound (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineRationalMatrixMulStep)^[k] + (machineRationalMatrixMulInit word)) := by + intro k + induction k with + | zero => exact machineRationalMatrixMulInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalMatrixMulStep_bound ih + +theorem machineRationalMatrixMulIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalMatrixMulStep)^[iterations] + (machineRationalMatrixMulInit word)).length ≀ + (machineRationalMatrixMulWidth word).length := by + rcases machineRationalMatrixMulIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp] + change (machineRationalTransposeMulVectorPack _ _ _ _).length ≀ _ + rw [hbound] + simp only [machineRationalTransposeMulVectorPack, + machineRationalMatrixMulWidth, machineRationalMatrixMulInputBound, + pair_length] + omega + +theorem machineRationalMatrixMulFinalState_mem_FP : + machineRationalMatrixMulFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalMatrixMulStep_mem_FP + machineRationalMatrixMulInit_mem_FP id_mem_FP + machineRationalMatrixMulWidth_mem_FP + machineRationalMatrixMulIterate_length_le_width + +theorem machineRationalMatrixMulReversedCode_mem_FP : + machineRationalMatrixMulReversedCode ∈ FP := by + simpa only [machineRationalMatrixMulReversedCode] using! + machineCompose_mem_FP machineRationalMatrixMulFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalMatrixMulCode_mem_FP : + machineRationalMatrixMulCode ∈ FP := by + simpa only [machineRationalMatrixMulCode] using! + machineCompose_mem_FP machineRationalMatrixMulReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact scan semantics -/ + +/-- Lists the first `k` rows of the rational matrix product. -/ +def rationalMatrixMulRowsPrefix {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (k : β„•) : List (List β„š) := + ((List.finRange d).take k).map + fun i ↦ List.ofFn fun j ↦ rationalMatrixMul A B i j + +/-- Encodes matrix multiplication after `k` rows, with remaining indices and reversed generated +rows. -/ +def machineRationalMatrixMulSemanticState {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (k : β„•) : List Bool := + let word := rationalMatrixMulCanonicalWord A B + machineRationalTransposeMulVectorPack + (binaryListCode finUnaryCode ((List.finRange d).drop k)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixMulRowsPrefix A B k).reverse) + word (machineRationalMatrixMulInputBound word) + +theorem machineRationalMatrixMulInit_semantics {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + machineRationalMatrixMulInit (rationalMatrixMulCanonicalWord A B) = + machineRationalMatrixMulSemanticState A B 0 := by + simp [machineRationalMatrixMulInit, + machineRationalMatrixMulSemanticState, + machineRationalMatrixMulIndices, + machineRationalMatrixMulDimensionUnary, + rationalMatrixMulCanonicalWord, machineUnaryRangeCode_encode, + finRangeUnaryCode, rationalMatrixMulRowsPrefix, binaryListCode] + +theorem rationalMatrixMulRowsPrefix_succ {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (k : β„•) (hk : k < d) : + rationalMatrixMulRowsPrefix A B (k + 1) = + rationalMatrixMulRowsPrefix A B k ++ + [List.ofFn fun j ↦ rationalMatrixMul A B ⟨k, hk⟩ j] := by + simp only [rationalMatrixMulRowsPrefix, List.map_take] + have hkm : k < (List.finRange d).length := by simpa + simpa [List.getElem_finRange] using! + congrArg (List.map fun i ↦ + List.ofFn fun j ↦ rationalMatrixMul A B i j) + (List.take_concat_get hkm).symm + +theorem machineRationalMatrixMulStep_semantics {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) (k : β„•) (hk : k < d) : + machineRationalMatrixMulStep + (machineRationalMatrixMulSemanticState A B k) = + machineRationalMatrixMulSemanticState A B (k + 1) := by + let word := rationalMatrixMulCanonicalWord A B + let i : Fin d := ⟨k, hk⟩ + have hdrop : + (List.finRange d).drop k = + i :: (List.finRange d).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.finRange d).length by simpa) using 1 + simp [i, List.getElem_finRange] + have hprefix := rationalMatrixMulRowsPrefix_succ A B k hk + have hreverse : + (rationalMatrixMulRowsPrefix A B (k + 1)).reverse = + (List.ofFn fun j ↦ rationalMatrixMul A B i j) :: + (rationalMatrixMulRowsPrefix A B k).reverse := by + rw [hprefix, List.reverse_append] + simp [i] + have hcand : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixMulRowsPrefix A B (k + 1)).reverse).length ≀ + (machineRationalMatrixMulInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (rationalMatrixMul A B)) (k + 1) + have hprefixEq : rationalMatrixMulRowsPrefix A B (k + 1) = + (rationalMatrixRows (rationalMatrixMul A B)).take (k + 1) := by + apply List.ext_getElem + Β· simp [rationalMatrixMulRowsPrefix, rationalMatrixRows] + Β· intro r hrLeft hrRight + simp [rationalMatrixMulRowsPrefix, rationalMatrixRows, + List.getElem_finRange] + rw [hprefixEq] + exact hprefixBound.trans (rationalMatrixMul_code_length_le_bound A B) + have hcandPair : + (pair + (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalMatrixMul A B i j)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixMulRowsPrefix A B k).reverse)).length ≀ + (machineRationalMatrixMulInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode finUnaryCode ((List.finRange d).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil finUnaryCode i + ((List.finRange d).drop (k + 1)) + rw [machineRationalMatrixMulStep] + simp only [machineRationalMatrixMulSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalMatrixMulAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalMatrixMulNextAccumulator, + machineRationalMatrixMulCandidate, + machineRationalMatrixMulCurrentRow, + machineRationalTransposeMulVectorCurrentIndex] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineRationalMatrixMulRowCode + (pair (finUnaryCode i) word)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixMulRowsPrefix A B k).reverse)).take + (machineRationalMatrixMulInputBound word).length) _ _ = _ + rw [show finUnaryCode i = List.replicate i.1 true by rfl, + machineRationalMatrixMulRowCode_encode] + change machineRationalTransposeMulVectorPack _ + ((pair (binaryListCode rationalEntryBinaryCode + (List.ofFn fun j ↦ rationalMatrixMul A B i j)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixMulRowsPrefix A B k).reverse)).take + (machineRationalMatrixMulInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineRationalMatrixMulIterate_semantics {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : βˆ€ k ≀ d, + (machineRationalMatrixMulStep)^[k] + (machineRationalMatrixMulInit (rationalMatrixMulCanonicalWord A B)) = + machineRationalMatrixMulSemanticState A B k := by + intro k hk + induction k with + | zero => exact machineRationalMatrixMulInit_semantics A B + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalMatrixMulStep_semantics A B k (by omega) + +theorem machineRationalMatrixMul_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineRationalMatrixMulStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalMatrixMulStep] + +theorem rationalMatrixMulRowsPrefix_all {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + rationalMatrixMulRowsPrefix A B d = + rationalMatrixRows (rationalMatrixMul A B) := by + apply List.ext_getElem + Β· simp [rationalMatrixMulRowsPrefix, rationalMatrixRows] + Β· intro i hiLeft hiRight + simp [rationalMatrixMulRowsPrefix, rationalMatrixRows, + List.getElem_finRange] + +theorem machineRationalMatrixMulReversedCode_encode {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + machineRationalMatrixMulReversedCode + (rationalMatrixMulCanonicalWord A B) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows (rationalMatrixMul A B)).reverse := by + let word := rationalMatrixMulCanonicalWord A B + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalMatrixMulCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hsplit : word.length = (word.length - d) + d := by omega + change machineRationalMatrixMulReversedCode word = _ + rw [machineRationalMatrixMulReversedCode, + machineRationalMatrixMulFinalState, hsplit, + Function.iterate_add_apply, + machineRationalMatrixMulIterate_semantics A B d le_rfl] + simp only [machineRationalMatrixMulSemanticState] + rw [show binaryListCode finUnaryCode ((List.finRange d).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineRationalMatrixMul_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [rationalMatrixMulRowsPrefix_all] + +@[simp] theorem machineRationalMatrixMulCode_encode {d : β„•} + (A B : Matrix (Fin d) (Fin d) β„š) : + machineRationalMatrixMulCode (rationalMatrixMulCanonicalWord A B) = + rationalSquareMatrixRowsCode (rationalMatrixMul A B) := by + rw [machineRationalMatrixMulCode, + machineRationalMatrixMulReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMulVector.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMulVector.lean new file mode 100644 index 0000000000..8f095acd36 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixMulVector.lean @@ -0,0 +1,569 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalizedDirection +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalTransposeMulVector + +/-! +# Polynomial-time rational matrix--vector multiplication + +The center update requires `E.basis * v`, whereas the pulled-back cut uses +`E.basisα΅€ * a`. This module begins with the row-coordinate primitive. Its +input is a unary row index followed by the nested row code and the rational +vector code; it extracts that row and invokes the already verified exact dot +product machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The rational matrix-vector product computed as row dot products. -/ +def rationalMatrixMulVector {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : Fin d β†’ β„š := + fun i ↦ βˆ‘ j, A i j * v j + +/-- Input: `pair rowUnary (pair nestedMatrixRowsCode rationalVectorCode)`. -/ +def machineRationalMatrixMulVectorEntryCode + (word : List Bool) : List Bool := + let row := machinePairFirst word + let payload := machinePairSecond word + let matrixRows := machinePairFirst payload + let vector := machinePairSecond payload + let rowCode := machineListIndex (pair row matrixRows) + machineRationalVectorDotEntryCode (pair rowCode vector) + +theorem machineRationalMatrixMulVectorEntryCode_mem_FP : + machineRationalMatrixMulVectorEntryCode ∈ FP := by + have hrow := machinePairFirst_mem_FP + have hpayload := machinePairSecond_mem_FP + have hmatrix := machineCompose_mem_FP hpayload machinePairFirst_mem_FP + have hvector := machineCompose_mem_FP hpayload machinePairSecond_mem_FP + have hrowInput := machinePair_mem_FP hrow hmatrix + have hrowCode := machineCompose_mem_FP hrowInput machineListIndex_mem_FP + have hdotInput := machinePair_mem_FP hrowCode hvector + simpa only [machineRationalMatrixMulVectorEntryCode] using! + machineCompose_mem_FP hdotInput + machineRationalVectorDotEntryCode_mem_FP + +@[simp] theorem machineRationalMatrixMulVectorEntryCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) (i : Fin d) : + machineRationalMatrixMulVectorEntryCode + (pair (List.replicate i.1 true) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v))) = + rationalEntryBinaryCode (rationalMatrixMulVector A v i) := by + rw [machineRationalMatrixMulVectorEntryCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + rationalSquareMatrixRowsCode] + rw [machineListIndex_binaryListCode] + Β· simp only [rationalMatrixRows, List.getElem_ofFn, + rationalFiniteVectorCode] + change machineRationalVectorDotEntryCode + (pair + (rationalFiniteVectorCode (fun j : Fin d ↦ A i j)) + (rationalFiniteVectorCode v)) = _ + rw [machineRationalVectorDotEntryCode_encode] + rfl + Β· simp [rationalMatrixRows] + +/-! ## The full vector -/ + +/-- Computes one matrix-vector product coordinate as a raw-rational dot product. -/ +def rawRationalMatrixCoordinate {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (i : Fin d) : RawRat := + rawRatListDot RawRat.zero (List.ofFn fun j ↦ A i j) (List.ofFn v) + +theorem rawRationalMatrixCoordinate_value {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (i : Fin d) : + (rawRationalMatrixCoordinate A v i).value = + rationalMatrixMulVector A v i := by + exact rawRatListDot_ofFn_value (fun j ↦ A i j) v + +/-- Encodes a unary dimension, square matrix rows, and rational vector for multiplication. -/ +def rationalMatrixMulVectorCanonicalWord {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : List Bool := + pair (List.replicate d true) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)) + +theorem rawRationalMatrixCoordinate_width_le_word {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (i : Fin d) : + rawRatWidth (rawRationalMatrixCoordinate A v i) ≀ + (rationalMatrixMulVectorCanonicalWord A v).length := by + let row := List.ofFn fun j : Fin d ↦ A i j + let vector := List.ofFn v + have hwidth := rawRatWidth_listDot_le RawRat.zero row vector + simp only [rawRatWidth_zero] at hwidth + have hcost := rawRatListDotCost_le_codeLength row vector + have hrow : + (binaryListCode rationalEntryBinaryCode row).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length := by + have helem := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) + (show row ∈ rationalMatrixRows A by + simp [rationalMatrixRows, row]) + simpa only [rationalMatrixRows, List.getElem_ofFn, row] using! helem + have hcombined : + 1 + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length + + (binaryListCode rationalEntryBinaryCode vector).length ≀ + (rationalMatrixMulVectorCanonicalWord A v).length := by + simp only [rationalMatrixMulVectorCanonicalWord, + rationalSquareMatrixRowsCode, rationalFiniteVectorCode, + vector, pair_length, List.length_replicate] + omega + change rawRatWidth (rawRatListDot RawRat.zero row vector) ≀ _ + omega + +theorem rationalMatrixMulVector_entry_code_length_le {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (i : Fin d) : + (rationalEntryBinaryCode + (rationalMatrixMulVector A v i)).length ≀ + 64 + 36 * (rationalMatrixMulVectorCanonicalWord A v).length := by + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (rawRationalMatrixCoordinate A v i) + rw [binaryNormalizeRawRat_eq_value, + rawRationalMatrixCoordinate_value] at hcanonical + exact hcanonical.trans (Nat.add_le_add_left + (Nat.mul_le_mul_left 36 + (rawRationalMatrixCoordinate_width_le_word A v i)) 64) + +/-- Reuses the transpose-vector input bound for matrix-vector multiplication. -/ +def machineRationalMatrixMulVectorInputBound + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineRationalMatrixMulVectorInputBound_mem_FP : + machineRationalMatrixMulVectorInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem rationalMatrixMulVector_code_length_le_bound {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + (rationalFiniteVectorCode (rationalMatrixMulVector A v)).length ≀ + (machineRationalMatrixMulVectorInputBound + (rationalMatrixMulVectorCanonicalWord A v)).length := by + let word := rationalMatrixMulVectorCanonicalWord A v + let B := 64 + 36 * word.length + have hdim : d ≀ word.length := by + have hfirst := machinePairFirst_length_le word + simpa only [word, rationalMatrixMulVectorCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! hfirst + have heach : βˆ€ q ∈ List.ofFn (rationalMatrixMulVector A v), + (rationalEntryBinaryCode q).length ≀ B := by + intro q hq + obtain ⟨i, rfl⟩ := List.mem_ofFn.mp hq + exact rationalMatrixMulVector_entry_code_length_le A v i + have hsum := List.sum_le_card_nsmul + ((List.ofFn (rationalMatrixMulVector A v)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + (2 * B + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum] + simp only [machineRationalMatrixMulVectorInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, List.length_map, List.length_ofFn, + Nat.nsmul_eq_mul] at hsum ⊒ + dsimp only [B, word] at hsum ⊒ + nlinarith [sq_nonneg + (rationalMatrixMulVectorCanonicalWord A v).length] + +/-! The state layout and the degree-eight envelope are shared with the +transpose--vector machine; only the one-coordinate routine changes. -/ + +/-- Computes the matrix-vector product entry at the current scan index. -/ +def machineRationalMatrixMulVectorCurrentEntry + (state : List Bool) : List Bool := + machineRationalMatrixMulVectorEntryCode + (pair (machineRationalTransposeMulVectorCurrentIndex state) + (machineRationalTransposeMulVectorStatePayload state)) + +/-- Prepends the current product entry to the reversed vector accumulator. -/ +def machineRationalMatrixMulVectorCandidate + (state : List Bool) : List Bool := + pair (machineRationalMatrixMulVectorCurrentEntry state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate product-vector accumulator to the stored width bound. -/ +def machineRationalMatrixMulVectorNextAccumulator + (state : List Bool) : List Bool := + (machineRationalMatrixMulVectorCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Consumes one coordinate index and updates the bounded product vector, retaining payload and +bound. -/ +def machineRationalMatrixMulVectorAdvance + (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineRationalMatrixMulVectorNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Generates the next product coordinate, leaving exhausted scans fixed. -/ +def machineRationalMatrixMulVectorStep + (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineRationalMatrixMulVectorAdvance state) + +/-- Reuses the transpose-vector state layout to initialize matrix-vector multiplication. -/ +def machineRationalMatrixMulVectorInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInit word + +/-- Reuses the transpose-vector width envelope for matrix-vector multiplication. -/ +def machineRationalMatrixMulVectorWidth (word : List Bool) : List Bool := + machineRationalTransposeMulVectorWidth word + +/-- Runs matrix-vector coordinate generation for one step per input bit. -/ +def machineRationalMatrixMulVectorFinalState + (word : List Bool) : List Bool := + (machineRationalMatrixMulVectorStep)^[word.length] + (machineRationalMatrixMulVectorInit word) + +/-- Extracts the generated matrix-vector product coordinates in reverse order. -/ +def machineRationalMatrixMulVectorReversedCode + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineRationalMatrixMulVectorFinalState word) + +/-- Reverses the accumulated matrix-vector product entries to restore row order. -/ +def machineRationalMatrixMulVectorCode + (word : List Bool) : List Bool := + machineListReverse (machineRationalMatrixMulVectorReversedCode word) + +theorem machineRationalMatrixMulVectorCurrentEntry_mem_FP : + machineRationalMatrixMulVectorCurrentEntry ∈ FP := by + have hp := machinePair_mem_FP + machineRationalTransposeMulVectorCurrentIndex_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + simpa only [machineRationalMatrixMulVectorCurrentEntry] using! + machineCompose_mem_FP hp + machineRationalMatrixMulVectorEntryCode_mem_FP + +theorem machineRationalMatrixMulVectorCandidate_mem_FP : + machineRationalMatrixMulVectorCandidate ∈ FP := + machinePair_mem_FP machineRationalMatrixMulVectorCurrentEntry_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalMatrixMulVectorNextAccumulator_mem_FP : + machineRationalMatrixMulVectorNextAccumulator ∈ FP := by + simpa only [machineRationalMatrixMulVectorNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineRationalMatrixMulVectorCandidate_mem_FP + +theorem machineRationalMatrixMulVectorAdvance_mem_FP : + machineRationalMatrixMulVectorAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalMatrixMulVectorNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineRationalMatrixMulVectorStep_mem_FP : + machineRationalMatrixMulVectorStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineRationalMatrixMulVectorAdvance_mem_FP + +theorem machineRationalMatrixMulVectorInit_mem_FP : + machineRationalMatrixMulVectorInit ∈ FP := + machineRationalTransposeMulVectorInit_mem_FP + +theorem machineRationalMatrixMulVectorWidth_mem_FP : + machineRationalMatrixMulVectorWidth ∈ FP := + machineRationalTransposeMulVectorWidth_mem_FP + +theorem machineRationalMatrixMulVectorStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalMatrixMulVectorStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineRationalMatrixMulVectorStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineRationalMatrixMulVectorStep, hcode, + machineIfEmpty_cons, machineRationalMatrixMulVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineRationalMatrixMulVectorNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalMatrixMulVectorIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineRationalMatrixMulVectorStep)^[k] + (machineRationalMatrixMulVectorInit word)) := by + intro k + induction k with + | zero => + simpa only [machineRationalMatrixMulVectorInit] using! + machineRationalTransposeMulVectorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalMatrixMulVectorStep_bound ih + +theorem machineRationalMatrixMulVectorIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalMatrixMulVectorStep)^[iterations] + (machineRationalMatrixMulVectorInit word)).length ≀ + (machineRationalMatrixMulVectorWidth word).length := by + rcases machineRationalMatrixMulVectorIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineRationalMatrixMulVectorWidth, + machineRationalTransposeMulVectorWidth, pair_length] + omega + +theorem machineRationalMatrixMulVectorFinalState_mem_FP : + machineRationalMatrixMulVectorFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalMatrixMulVectorStep_mem_FP + machineRationalMatrixMulVectorInit_mem_FP id_mem_FP + machineRationalMatrixMulVectorWidth_mem_FP + machineRationalMatrixMulVectorIterate_length_le_width + +theorem machineRationalMatrixMulVectorReversedCode_mem_FP : + machineRationalMatrixMulVectorReversedCode ∈ FP := by + simpa only [machineRationalMatrixMulVectorReversedCode] using! + machineCompose_mem_FP machineRationalMatrixMulVectorFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalMatrixMulVectorCode_mem_FP : + machineRationalMatrixMulVectorCode ∈ FP := by + simpa only [machineRationalMatrixMulVectorCode] using! + machineCompose_mem_FP + machineRationalMatrixMulVectorReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact iteration semantics -/ + +/-- Lists the first `k` coordinates of the rational matrix-vector product in row order. -/ +def rationalMatrixMulVectorPrefix {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) : List β„š := + ((List.finRange d).take k).map + fun i ↦ rationalMatrixMulVector A v i + +/-- Encodes the remaining row indices and reversed product prefix after `k` rows, retaining the +matrix-vector payload and input bound. -/ +def machineRationalMatrixMulVectorSemanticState {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) : List Bool := + let word := rationalMatrixMulVectorCanonicalWord A v + machineRationalTransposeMulVectorPack + (binaryListCode finUnaryCode ((List.finRange d).drop k)) + (binaryListCode rationalEntryBinaryCode + (rationalMatrixMulVectorPrefix A v k).reverse) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)) + (machineRationalMatrixMulVectorInputBound word) + +theorem machineRationalMatrixMulVectorInit_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalMatrixMulVectorInit + (rationalMatrixMulVectorCanonicalWord A v) = + machineRationalMatrixMulVectorSemanticState A v 0 := by + simp [machineRationalMatrixMulVectorInit, + machineRationalTransposeMulVectorInit, + machineRationalMatrixMulVectorSemanticState, + machineRationalTransposeMulVectorIndices, + machineRationalTransposeMulVectorDimension, + machineRationalTransposeMulVectorPayload, + rationalMatrixMulVectorCanonicalWord, + machineUnaryRangeCode_encode, finRangeUnaryCode, + rationalMatrixMulVectorPrefix, binaryListCode, + machineRationalMatrixMulVectorInputBound] + +theorem rationalMatrixMulVectorPrefix_succ {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) (hk : k < d) : + rationalMatrixMulVectorPrefix A v (k + 1) = + rationalMatrixMulVectorPrefix A v k ++ + [rationalMatrixMulVector A v ⟨k, hk⟩] := by + simp only [rationalMatrixMulVectorPrefix, List.map_take] + have hkm : k < (List.finRange d).length := by simpa + simpa [List.getElem_finRange] using! + congrArg (List.map fun i ↦ rationalMatrixMulVector A v i) + (List.take_concat_get hkm).symm + +theorem machineRationalMatrixMulVectorStep_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) (hk : k < d) : + machineRationalMatrixMulVectorStep + (machineRationalMatrixMulVectorSemanticState A v k) = + machineRationalMatrixMulVectorSemanticState A v (k + 1) := by + let word := rationalMatrixMulVectorCanonicalWord A v + let i : Fin d := ⟨k, hk⟩ + have hdrop : + (List.finRange d).drop k = + i :: (List.finRange d).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.finRange d).length by simpa) using 1 + simp [i, List.getElem_finRange] + have hprefix := rationalMatrixMulVectorPrefix_succ A v k hk + have hreverse : + (rationalMatrixMulVectorPrefix A v (k + 1)).reverse = + rationalMatrixMulVector A v i :: + (rationalMatrixMulVectorPrefix A v k).reverse := by + rw [hprefix, List.reverse_append] + simp [i] + have hcand : + (binaryListCode rationalEntryBinaryCode + (rationalMatrixMulVectorPrefix A v (k + 1)).reverse).length ≀ + (machineRationalMatrixMulVectorInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode + (List.ofFn (rationalMatrixMulVector A v)) (k + 1) + have hprefixEq : rationalMatrixMulVectorPrefix A v (k + 1) = + (List.ofFn (rationalMatrixMulVector A v)).take (k + 1) := by + apply List.ext_getElem + Β· simp [rationalMatrixMulVectorPrefix] + Β· intro r hrLeft hrRight + simp [rationalMatrixMulVectorPrefix, List.getElem_finRange] + rw [hprefixEq] + exact hprefixBound.trans + (rationalMatrixMulVector_code_length_le_bound A v) + have hcandPair : + (pair (rationalEntryBinaryCode + (rationalMatrixMulVector A v i)) + (binaryListCode rationalEntryBinaryCode + (rationalMatrixMulVectorPrefix A v k).reverse)).length ≀ + (machineRationalMatrixMulVectorInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode finUnaryCode ((List.finRange d).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil finUnaryCode i + ((List.finRange d).drop (k + 1)) + rw [machineRationalMatrixMulVectorStep] + simp only [machineRationalMatrixMulVectorSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalMatrixMulVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalMatrixMulVectorNextAccumulator, + machineRationalMatrixMulVectorCandidate, + machineRationalMatrixMulVectorCurrentEntry, + machineRationalTransposeMulVectorCurrentIndex] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineRationalMatrixMulVectorEntryCode + (pair (finUnaryCode i) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)))) + (binaryListCode rationalEntryBinaryCode + (rationalMatrixMulVectorPrefix A v k).reverse)).take + (machineRationalMatrixMulVectorInputBound word).length) _ _ = _ + rw [show finUnaryCode i = List.replicate i.1 true by rfl, + machineRationalMatrixMulVectorEntryCode_encode] + change machineRationalTransposeMulVectorPack _ + ((pair (rationalEntryBinaryCode + (rationalMatrixMulVector A v i)) + (binaryListCode rationalEntryBinaryCode + (rationalMatrixMulVectorPrefix A v k).reverse)).take + (machineRationalMatrixMulVectorInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineRationalMatrixMulVectorIterate_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : βˆ€ k ≀ d, + (machineRationalMatrixMulVectorStep)^[k] + (machineRationalMatrixMulVectorInit + (rationalMatrixMulVectorCanonicalWord A v)) = + machineRationalMatrixMulVectorSemanticState A v k := by + intro k hk + induction k with + | zero => exact machineRationalMatrixMulVectorInit_semantics A v + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalMatrixMulVectorStep_semantics A v k (by omega) + +theorem machineRationalMatrixMulVector_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineRationalMatrixMulVectorStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalMatrixMulVectorStep] + +theorem rationalMatrixMulVectorPrefix_all {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + rationalMatrixMulVectorPrefix A v d = + List.ofFn (rationalMatrixMulVector A v) := by + apply List.ext_getElem + Β· simp [rationalMatrixMulVectorPrefix] + Β· intro i hiLeft hiRight + simp [rationalMatrixMulVectorPrefix, List.getElem_finRange] + +theorem machineRationalMatrixMulVectorReversedCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalMatrixMulVectorReversedCode + (rationalMatrixMulVectorCanonicalWord A v) = + binaryListCode rationalEntryBinaryCode + (List.ofFn (rationalMatrixMulVector A v)).reverse := by + let word := rationalMatrixMulVectorCanonicalWord A v + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalMatrixMulVectorCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hsplit : word.length = (word.length - d) + d := by omega + change machineRationalMatrixMulVectorReversedCode word = _ + rw [machineRationalMatrixMulVectorReversedCode, + machineRationalMatrixMulVectorFinalState, hsplit, + Function.iterate_add_apply, + machineRationalMatrixMulVectorIterate_semantics A v d le_rfl] + simp only [machineRationalMatrixMulVectorSemanticState] + rw [show binaryListCode finUnaryCode ((List.finRange d).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineRationalMatrixMulVector_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [rationalMatrixMulVectorPrefix_all] + +@[simp] theorem machineRationalMatrixMulVectorCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalMatrixMulVectorCode + (rationalMatrixMulVectorCanonicalWord A v) = + rationalFiniteVectorCode (rationalMatrixMulVector A v) := by + rw [machineRationalMatrixMulVectorCode, + machineRationalMatrixMulVectorReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixUpdate.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixUpdate.lean new file mode 100644 index 0000000000..274fcb15b3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMatrixUpdate.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListUpdate +public import Mathlib.Tactic + +/-! +# Mutable rational-matrix memory + +The input is `pair rowUnary (pair columnUnary (pair replacement matrixWord))`. +The replacement is already a canonical rational-entry code. The routine +updates the selected entry of the right-nested row-major matrix encoding and +preserves the original binary dimension word. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary row index from a rational matrix-update request. -/ +def machineRationalMatrixUpdateRow (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the matrix-update payload following its row index. -/ +def machineRationalMatrixUpdateRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the unary column index from a rational matrix-update request. -/ +def machineRationalMatrixUpdateColumn (word : List Bool) : List Bool := + machinePairFirst (machineRationalMatrixUpdateRest word) + +/-- Extracts the replacement-and-matrix payload following the requested indices. -/ +def machineRationalMatrixUpdatePayload (word : List Bool) : List Bool := + machinePairSecond (machineRationalMatrixUpdateRest word) + +/-- Extracts the replacement entry from a rational matrix-update request. -/ +def machineRationalMatrixUpdateReplacement (word : List Bool) : List Bool := + machinePairFirst (machineRationalMatrixUpdatePayload word) + +/-- Extracts the encoded matrix from a rational matrix-update request. -/ +def machineRationalMatrixUpdateMatrix (word : List Bool) : List Bool := + machinePairSecond (machineRationalMatrixUpdatePayload word) + +/-- Reads the encoded row list of the matrix being updated. -/ +def machineRationalMatrixUpdateRows (word : List Bool) : List Bool := + machineMatrixRowsWord (machineRationalMatrixUpdateMatrix word) + +/-- Looks up the row selected by the unary matrix-update index. -/ +def machineRationalMatrixUpdateCurrentRow (word : List Bool) : List Bool := + machineListIndex + (pair (machineRationalMatrixUpdateRow word) + (machineRationalMatrixUpdateRows word)) + +/-- Replaces the selected column of the current row with the supplied entry. -/ +def machineRationalMatrixUpdateNewRow (word : List Bool) : List Bool := + machineListUpdate + (pair (machineRationalMatrixUpdateColumn word) + (pair (machineRationalMatrixUpdateReplacement word) + (machineRationalMatrixUpdateCurrentRow word))) + +/-- Replaces the selected matrix row with its updated row. -/ +def machineRationalMatrixUpdateNewRows (word : List Bool) : List Bool := + machineListUpdate + (pair (machineRationalMatrixUpdateRow word) + (pair (machineRationalMatrixUpdateNewRow word) + (machineRationalMatrixUpdateRows word))) + +/-- Reconstructs the matrix encoding from its unchanged dimension and updated row list. -/ +def machineRationalMatrixUpdateAtUnary (word : List Bool) : List Bool := + pair (machineMatrixDimensionWord (machineRationalMatrixUpdateMatrix word)) + (machineRationalMatrixUpdateNewRows word) + +theorem machineRationalMatrixUpdateRow_mem_FP : + machineRationalMatrixUpdateRow ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRationalMatrixUpdateRest_mem_FP : + machineRationalMatrixUpdateRest ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineRationalMatrixUpdateColumn_mem_FP : + machineRationalMatrixUpdateColumn ∈ Complexity.FP := by + simpa only [machineRationalMatrixUpdateColumn] using! + machineCompose_mem_FP machineRationalMatrixUpdateRest_mem_FP + machinePairFirst_mem_FP + +theorem machineRationalMatrixUpdatePayload_mem_FP : + machineRationalMatrixUpdatePayload ∈ Complexity.FP := by + simpa only [machineRationalMatrixUpdatePayload] using! + machineCompose_mem_FP machineRationalMatrixUpdateRest_mem_FP + machinePairSecond_mem_FP + +theorem machineRationalMatrixUpdateReplacement_mem_FP : + machineRationalMatrixUpdateReplacement ∈ Complexity.FP := by + simpa only [machineRationalMatrixUpdateReplacement] using! + machineCompose_mem_FP machineRationalMatrixUpdatePayload_mem_FP + machinePairFirst_mem_FP + +theorem machineRationalMatrixUpdateMatrix_mem_FP : + machineRationalMatrixUpdateMatrix ∈ Complexity.FP := by + simpa only [machineRationalMatrixUpdateMatrix] using! + machineCompose_mem_FP machineRationalMatrixUpdatePayload_mem_FP + machinePairSecond_mem_FP + +theorem machineRationalMatrixUpdateRows_mem_FP : + machineRationalMatrixUpdateRows ∈ Complexity.FP := by + simpa only [machineRationalMatrixUpdateRows] using! + machineCompose_mem_FP machineRationalMatrixUpdateMatrix_mem_FP + machineMatrixRowsWord_mem_FP + +theorem machineRationalMatrixUpdateCurrentRow_mem_FP : + machineRationalMatrixUpdateCurrentRow ∈ Complexity.FP := by + have hinput := machinePair_mem_FP machineRationalMatrixUpdateRow_mem_FP + machineRationalMatrixUpdateRows_mem_FP + simpa only [machineRationalMatrixUpdateCurrentRow] using! + machineCompose_mem_FP hinput machineListIndex_mem_FP + +theorem machineRationalMatrixUpdateNewRow_mem_FP : + machineRationalMatrixUpdateNewRow ∈ Complexity.FP := by + have hpayload := machinePair_mem_FP + machineRationalMatrixUpdateReplacement_mem_FP + machineRationalMatrixUpdateCurrentRow_mem_FP + have hinput := machinePair_mem_FP machineRationalMatrixUpdateColumn_mem_FP + hpayload + simpa only [machineRationalMatrixUpdateNewRow] using! + machineCompose_mem_FP hinput machineListUpdate_mem_FP + +theorem machineRationalMatrixUpdateNewRows_mem_FP : + machineRationalMatrixUpdateNewRows ∈ Complexity.FP := by + have hpayload := machinePair_mem_FP machineRationalMatrixUpdateNewRow_mem_FP + machineRationalMatrixUpdateRows_mem_FP + have hinput := machinePair_mem_FP machineRationalMatrixUpdateRow_mem_FP + hpayload + simpa only [machineRationalMatrixUpdateNewRows] using! + machineCompose_mem_FP hinput machineListUpdate_mem_FP + +theorem machineRationalMatrixUpdateAtUnary_mem_FP : + machineRationalMatrixUpdateAtUnary ∈ Complexity.FP := by + have hdimension := machineCompose_mem_FP + machineRationalMatrixUpdateMatrix_mem_FP machineMatrixDimensionWord_mem_FP + exact machinePair_mem_FP hdimension + machineRationalMatrixUpdateNewRows_mem_FP + +/-! ## Exact semantics -/ + +/-- Pairs a dimension word with an encoded nested list of rational rows. -/ +def rationalRowsWord (dimension : List Bool) + (rows : List (List β„š)) : List Bool := + pair dimension + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + +@[simp] theorem machineMatrixDimensionWord_rationalRowsWord + (dimension : List Bool) (rows : List (List β„š)) : + machineMatrixDimensionWord (rationalRowsWord dimension rows) = + dimension := by + simp [machineMatrixDimensionWord, rationalRowsWord] + +@[simp] theorem machineMatrixRowsWord_rationalRowsWord + (dimension : List Bool) (rows : List (List β„š)) : + machineMatrixRowsWord (rationalRowsWord dimension rows) = + binaryListCode (binaryListCode rationalEntryBinaryCode) rows := by + simp [machineMatrixRowsWord, rationalRowsWord] + +@[simp] theorem machineRationalMatrixUpdateAtUnary_rows + (dimension : List Bool) (rows : List (List β„š)) + (replacement : β„š) (i j : β„•) + (hi : i < rows.length) (hj : j < rows[i].length) : + machineRationalMatrixUpdateAtUnary + (pair (List.replicate i true) + (pair (List.replicate j true) + (pair (rationalEntryBinaryCode replacement) + (rationalRowsWord dimension rows)))) = + rationalRowsWord dimension + (rows.set i (rows[i].set j replacement)) := by + rw [machineRationalMatrixUpdateAtUnary] + simp only [machineRationalMatrixUpdateMatrix, + machineRationalMatrixUpdatePayload, machineRationalMatrixUpdateRest, + machineRationalMatrixUpdateRow, machineRationalMatrixUpdateColumn, + machineRationalMatrixUpdateReplacement, machinePairFirst_pair, + machinePairSecond_pair, machineMatrixDimensionWord_rationalRowsWord, + machineRationalMatrixUpdateNewRows, + machineRationalMatrixUpdateRows, + machineMatrixRowsWord_rationalRowsWord, + machineRationalMatrixUpdateNewRow, + machineRationalMatrixUpdateCurrentRow] + rw [machineListIndex_binaryListCode + (binaryListCode rationalEntryBinaryCode) rows i hi] + change pair dimension + (machineListUpdate + (pair (List.replicate i true) + (pair + (machineListUpdate + (machineListUpdateCanonicalInput rationalEntryBinaryCode + rows[i] replacement j)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows)))) = _ + rw [machineListUpdate_binaryListCode rationalEntryBinaryCode rows[i] + replacement j hj] + change pair dimension + (machineListUpdate + (machineListUpdateCanonicalInput + (binaryListCode rationalEntryBinaryCode) rows + (rows[i].set j replacement) i)) = _ + rw [machineListUpdate_binaryListCode + (binaryListCode rationalEntryBinaryCode) rows + (rows[i].set j replacement) i hi] + rfl + +@[simp] theorem machineRationalMatrixUpdateAtUnary_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (i j : Fin n) + (replacement : β„š) : + machineRationalMatrixUpdateAtUnary + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (pair (rationalEntryBinaryCode replacement) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)))) = + rationalRowsWord n.bits + ((rationalMatrixRows A).set i.1 + (((rationalMatrixRows A)[i.1]'(by simp [rationalMatrixRows])).set + j.1 replacement)) := by + change machineRationalMatrixUpdateAtUnary + (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) + (pair (rationalEntryBinaryCode replacement) + (rationalRowsWord n.bits (rationalMatrixRows A))))) = _ + exact machineRationalMatrixUpdateAtUnary_rows n.bits + (rationalMatrixRows A) replacement i.1 j.1 + (by simp [rationalMatrixRows]) (by simp [rationalMatrixRows]) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMin.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMin.lean new file mode 100644 index 0000000000..7e37d8cbf2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalMin.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalCompare +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalization + +/-! +# Exact finite-word minimum of two rationals + +The input is the pair of two raw-rational words. We compare their values and +return one of the original words; the public version then normalizes the +selected fraction. This is the minimum operation used in the rational +smoothing level. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Selects the lesser raw rational in a pair, choosing the left one when the comparison is +equal. -/ +def machineRawRatMinCode (word : List Bool) : List Bool := + machineIfHead (machineRawRatLeBit word) + (machinePairFirst word) (machinePairSecond word) + +/-- Normalizes the selected raw minimum into the rational binary output encoding. -/ +def machineRationalMinCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatMinCode word) + +theorem machineRawRatMinCode_mem_FP : + machineRawRatMinCode ∈ Complexity.FP := by + exact machineIfHead_mem_FP machineRawRatLeBit_mem_FP + machinePairFirst_mem_FP machinePairSecond_mem_FP + +theorem machineRationalMinCode_mem_FP : + machineRationalMinCode ∈ Complexity.FP := by + simpa only [machineRationalMinCode] using! + machineCompose_mem_FP machineRawRatMinCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +@[simp] theorem machineRawRatMinCode_encode (q r : RawRat) : + machineRawRatMinCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rawRatBinaryCode (if q.value ≀ r.value then q else r) := by + rw [machineRawRatMinCode, machineRawRatLeBit_encode] + by_cases h : q.value ≀ r.value <;> simp [h] + +@[simp] theorem machineRationalMinCode_encode (q r : RawRat) : + machineRationalMinCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rationalBinaryCode (min q.value r.value) := by + rw [machineRationalMinCode, machineRawRatMinCode_encode] + by_cases h : q.value ≀ r.value + Β· rw [ite_eq_left h, machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, min_eq_left h] + Β· have hrq : r.value ≀ q.value := le_of_not_ge h + rw [ite_eq_right h, machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, min_eq_right hrq] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalization.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalization.lean new file mode 100644 index 0000000000..cacb2253a3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalization.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude + +/-! +# Polynomial-time normalization of unreduced rationals + +An unreduced signed fraction is encoded as the pair of its +`integerBinaryCode` numerator and ordinary denominator bits. The machine +computes the absolute numerator, their gcd, both exact quotients, restores the +integer sign, and finally applies the public rational encoder. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a raw rational as its signed integer numerator paired with binary denominator bits. -/ +def rawRatBinaryCode (q : RawRat) : List Bool := + pair (integerBinaryCode q.num) q.den.bits + +/-- Computes the binary absolute value of a raw rational code's numerator. -/ +def machineRawRatNatAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits (machinePairFirst word) + +/-- Computes the binary greatest common divisor of numerator magnitude and denominator. -/ +def machineRawRatGcdBits (word : List Bool) : List Bool := + machineBinaryGcdBits + (pair (machineRawRatNatAbsBits word) (machinePairSecond word)) + +/-- Divides the numerator magnitude by its gcd with the denominator and extracts the quotient. -/ +def machineRawRatAbsQuotientBits (word : List Bool) : List Bool := + machinePairFirst + (machineBinaryDivModBits + (pair (machineRawRatNatAbsBits word) (machineRawRatGcdBits word))) + +/-- Divides the denominator by its gcd with the numerator magnitude and extracts the quotient. -/ +def machineRawRatDenQuotientBits (word : List Bool) : List Bool := + machinePairFirst + (machineBinaryDivModBits + (pair (machinePairSecond word) (machineRawRatGcdBits word))) + +/-- Builds a normalized rational-entry code from the gcd-reduced numerator magnitude, its +original sign, and the reduced denominator. -/ +def machineNormalizeRawRatEntryCode (word : List Bool) : List Bool := + pair + (machineIntegerCodeFromSignedAbs + (pair (machinePairFirst word) (machineRawRatAbsQuotientBits word))) + (machineRawRatDenQuotientBits word) + +/-- Public canonical rational output bits. -/ +def machineNormalizeRawRatBinaryCode (word : List Bool) : List Bool := + machineRationalBinaryCode (machineNormalizeRawRatEntryCode word) + +theorem machineRawRatNatAbsBits_mem_FP : + machineRawRatNatAbsBits ∈ Complexity.FP := by + simpa only [machineRawRatNatAbsBits] using! + machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineRawRatGcdBits_mem_FP : + machineRawRatGcdBits ∈ Complexity.FP := by + have hpair : (fun word => pair (machineRawRatNatAbsBits word) + (machinePairSecond word)) ∈ Complexity.FP := + machinePair_mem_FP machineRawRatNatAbsBits_mem_FP + machinePairSecond_mem_FP + simpa only [machineRawRatGcdBits] using! + machineCompose_mem_FP hpair machineBinaryGcdBits_mem_FP + +theorem machineRawRatAbsQuotientBits_mem_FP : + machineRawRatAbsQuotientBits ∈ Complexity.FP := by + have hpair : (fun word => pair (machineRawRatNatAbsBits word) + (machineRawRatGcdBits word)) ∈ Complexity.FP := + machinePair_mem_FP machineRawRatNatAbsBits_mem_FP + machineRawRatGcdBits_mem_FP + have hdiv := machineCompose_mem_FP hpair machineBinaryDivModBits_mem_FP + simpa only [machineRawRatAbsQuotientBits] using! + machineCompose_mem_FP hdiv machinePairFirst_mem_FP + +theorem machineRawRatDenQuotientBits_mem_FP : + machineRawRatDenQuotientBits ∈ Complexity.FP := by + have hpair : (fun word => pair (machinePairSecond word) + (machineRawRatGcdBits word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairSecond_mem_FP machineRawRatGcdBits_mem_FP + have hdiv := machineCompose_mem_FP hpair machineBinaryDivModBits_mem_FP + simpa only [machineRawRatDenQuotientBits] using! + machineCompose_mem_FP hdiv machinePairFirst_mem_FP + +theorem machineNormalizeRawRatEntryCode_mem_FP : + machineNormalizeRawRatEntryCode ∈ Complexity.FP := by + have hsignedPair : (fun word => pair (machinePairFirst word) + (machineRawRatAbsQuotientBits word)) ∈ Complexity.FP := + machinePair_mem_FP machinePairFirst_mem_FP + machineRawRatAbsQuotientBits_mem_FP + have hsigned := machineCompose_mem_FP hsignedPair + machineIntegerCodeFromSignedAbs_mem_FP + simpa only [machineNormalizeRawRatEntryCode] using! + machinePair_mem_FP hsigned machineRawRatDenQuotientBits_mem_FP + +theorem machineNormalizeRawRatBinaryCode_mem_FP : + machineNormalizeRawRatBinaryCode ∈ Complexity.FP := by + simpa only [machineNormalizeRawRatBinaryCode] using! + machineCompose_mem_FP machineNormalizeRawRatEntryCode_mem_FP + machineRationalBinaryCode_mem_FP + +theorem machineRawRatNatAbsBits_encode (q : RawRat) : + machineRawRatNatAbsBits (rawRatBinaryCode q) = q.num.natAbs.bits := by + simp [machineRawRatNatAbsBits, rawRatBinaryCode, + machineIntegerNatAbsBits_encode] + +theorem machineRawRatGcdBits_encode (q : RawRat) : + machineRawRatGcdBits (rawRatBinaryCode q) = + (Nat.gcd q.num.natAbs q.den).bits := by + rw [machineRawRatGcdBits, machineRawRatNatAbsBits_encode] + simp only [rawRatBinaryCode, machinePairSecond_pair] + rw [machineBinaryGcdBits_pair_natBits] + +theorem machineRawRatAbsQuotientBits_encode (q : RawRat) : + machineRawRatAbsQuotientBits (rawRatBinaryCode q) = + (q.num.natAbs / Nat.gcd q.num.natAbs q.den).bits := by + rw [machineRawRatAbsQuotientBits] + rw [machineRawRatNatAbsBits_encode, machineRawRatGcdBits_encode, + machineBinaryDivModBits_pair_natBits] + simp only [machinePairFirst_pair] + +theorem machineRawRatDenQuotientBits_encode (q : RawRat) : + machineRawRatDenQuotientBits (rawRatBinaryCode q) = + (q.den / Nat.gcd q.num.natAbs q.den).bits := by + rw [machineRawRatDenQuotientBits] + simp only [rawRatBinaryCode, machinePairSecond_pair] + have hg : machineRawRatGcdBits + (pair (integerBinaryCode q.num) q.den.bits) = + (Nat.gcd q.num.natAbs q.den).bits := by + simpa only [rawRatBinaryCode] using! machineRawRatGcdBits_encode q + rw [hg, machineBinaryDivModBits_pair_natBits] + simp only [machinePairFirst_pair] + +theorem machineNormalizeRawRatEntryCode_encode (q : RawRat) : + machineNormalizeRawRatEntryCode (rawRatBinaryCode q) = + rationalEntryBinaryCode (binaryNormalizeRawRat q) := by + let g := Nat.gcd q.num.natAbs q.den + have hgpos : 0 < g := Nat.gcd_pos_of_pos_right _ q.den_pos + have hgdvd : g ∣ q.num.natAbs := Nat.gcd_dvd_left _ _ + have hnum := machineIntegerCodeFromSignedAbs_div q.num g hgpos hgdvd + have hden : (binaryLongDiv q.den g).1 = q.den / g := by + simp [binaryLongDiv_eq_div_mod] + rw [machineNormalizeRawRatEntryCode] + simp only [rawRatBinaryCode, machinePairFirst_pair] + have habs : machineRawRatAbsQuotientBits + (pair (integerBinaryCode q.num) q.den.bits) = + (q.num.natAbs / Nat.gcd q.num.natAbs q.den).bits := by + simpa only [rawRatBinaryCode] using! + machineRawRatAbsQuotientBits_encode q + have hdenq : machineRawRatDenQuotientBits + (pair (integerBinaryCode q.num) q.den.bits) = + (q.den / Nat.gcd q.num.natAbs q.den).bits := by + simpa only [rawRatBinaryCode] using! + machineRawRatDenQuotientBits_encode q + rw [habs, hdenq] + change pair + (machineIntegerCodeFromSignedAbs + (pair (integerBinaryCode q.num) (q.num.natAbs / g).bits)) + (q.den / g).bits = _ + rw [hnum] + rw [← hden] + simp only [rationalEntryBinaryCode, binaryNormalizeRawRat] + rw [binaryEuclidBounded_eq_gcd] + +theorem machineNormalizeRawRatBinaryCode_encode (q : RawRat) : + machineNormalizeRawRatBinaryCode (rawRatBinaryCode q) = + rationalBinaryCode (binaryNormalizeRawRat q) := by + rw [machineNormalizeRawRatBinaryCode, + machineNormalizeRawRatEntryCode_encode, + machineRationalBinaryCode_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalizedDirection.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalizedDirection.lean new file mode 100644 index 0000000000..adcabfb2e2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalNormalizedDirection.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidScalars +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalRowDivide + +/-! +# Polynomial-time rational normalization of a cut direction + +The center update uses the vector `b / sum_i |b_i|`. The scalar is computed +by the verified `β„“1` fold and is passed, still as an unreduced rational word, +to the verified row-division fold. Thus the composition performs no decoding +and no hidden field arithmetic. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Divides every rational direction coordinate by the cut's L1 scale. -/ +def rationalNormalizedDirection {d : β„•} + (b : Fin d β†’ β„š) : Fin d β†’ β„š := + fun i ↦ b i / cutL1Scale b + +/-- Divides the encoded rational vector by its raw L1 norm to obtain its normalized direction. -/ +def machineRationalNormalizedDirectionCode + (word : List Bool) : List Bool := + machineRationalRowDivide + (pair (machineRationalVectorL1RawCode word) word) + +theorem machineRationalNormalizedDirectionCode_mem_FP : + machineRationalNormalizedDirectionCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalVectorL1RawCode_mem_FP id_mem_FP + simpa only [machineRationalNormalizedDirectionCode] using! + machineCompose_mem_FP hinput machineRationalRowDivide_mem_FP + +theorem rationalRowDivideValues_l1_ofFn {d : β„•} + (b : Fin d β†’ β„š) : + rationalRowDivideValues + (rawRatListL1Sum RawRat.zero (List.ofFn b)) (List.ofFn b) = + List.ofFn (rationalNormalizedDirection b) := by + rw [rationalRowDivideValues, List.map_ofFn] + apply congrArg List.ofFn + funext i + simp [rationalNormalizedDirection, binaryNormalizeRawRat_eq_value, + RawRat.value_div, rawRatOfRat_value, rawRatListL1Sum_ofFn_value, + cutL1Scale] + +@[simp] theorem machineRationalNormalizedDirectionCode_encode {d : β„•} + (b : Fin d β†’ β„š) : + machineRationalNormalizedDirectionCode (rationalFiniteVectorCode b) = + rationalFiniteVectorCode (rationalNormalizedDirection b) := by + rw [machineRationalNormalizedDirectionCode, + machineRationalVectorL1RawCode_encode] + change machineRationalRowDivide + (machineRationalRowDivideCanonicalInput + (rawRatListL1Sum RawRat.zero (List.ofFn b)) (List.ofFn b)) = _ + rw [machineRationalRowDivide_encode, + rationalRowDivideValues_l1_ofFn] + rfl + +theorem rationalNormalizedDirection_apply {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + rationalNormalizedDirection b i = b i / cutL1Scale b := rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalPower.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalPower.lean new file mode 100644 index 0000000000..32b918ad95 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalPower.lean @@ -0,0 +1,372 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary + +/-! +# A bounded polynomial-time rational power loop + +The exponent is a unary ruler. Each state also retains a quadratic-width +clamp computed from the original input. The clamp makes the total machine +polynomial-time even on malformed strings; a separate bit-growth proof shows +that it never truncates a well-formed unreduced power. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The raw rational binary code for the multiplicative identity. -/ +def rawRatOneCode : List Bool := rawRatBinaryCode RawRat.one + +/-- Packs the current power accumulator, fixed base, and length bound. -/ +def machineRawRatPowerPack (acc base bound : List Bool) : List Bool := + pair acc (pair base bound) + +/-- Extracts the raw power accumulator from an exponentiation state. -/ +def machineRawRatPowerAccField (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the fixed raw base from an exponentiation state. -/ +def machineRawRatPowerBaseField (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulator length-bound word from an exponentiation state. -/ +def machineRawRatPowerBoundField (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Multiplies the current raw power accumulator by the fixed base. -/ +def machineRawRatPowerCandidate (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineRawRatPowerAccField state) + (machineRawRatPowerBaseField state)) + +/-- Truncates the updated power accumulator to the stored bound length. -/ +def machineRawRatPowerNextAcc (state : List Bool) : List Bool := + (machineRawRatPowerCandidate state).take + (machineRawRatPowerBoundField state).length + +/-- Updates the bounded power accumulator while preserving its base and bound. -/ +def machineRawRatPowerStep (state : List Bool) : List Bool := + machineRawRatPowerPack (machineRawRatPowerNextAcc state) + (machineRawRatPowerBaseField state) + (machineRawRatPowerBoundField state) + +/-- Extracts the unary exponent ruler from a raw rational power request. -/ +def machineRawRatPowerInputRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the raw base code from a rational power request. -/ +def machineRawRatPowerInputBase (word : List Bool) : List Bool := + machinePairSecond word + +/-- Builds the power accumulator bound by concatenating four copies of the binary-multiplication +width word. -/ +def machineRawRatPowerInputBound (word : List Bool) : List Bool := + let square := machineBinaryMulWidth word + square ++ (square ++ (square ++ square)) + +/-- Initializes raw exponentiation with accumulator one, the requested base, and the computed +bound. -/ +def machineRawRatPowerInit (word : List Bool) : List Bool := + machineRawRatPowerPack rawRatOneCode + (machineRawRatPowerInputBase word) + (machineRawRatPowerInputBound word) + +/-- Packs three copies of the computed bound to bound the exponentiation state. -/ +def machineRawRatPowerWidth (word : List Bool) : List Bool := + let bound := machineRawRatPowerInputBound word + machineRawRatPowerPack bound bound bound + +/-- Iterates bounded multiplication for the length of the unary exponent ruler. -/ +def machineRawRatPowerFinalState (word : List Bool) : List Bool := + (machineRawRatPowerStep)^[(machineRawRatPowerInputRuler word).length] + (machineRawRatPowerInit word) + +/-- Extracts the final raw power accumulator. -/ +def machineRawRatPowerCode (word : List Bool) : List Bool := + machineRawRatPowerAccField (machineRawRatPowerFinalState word) + +/-- Normalizes the raw power result into the rational binary output encoding. -/ +def machineRationalPowerCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatPowerCode word) + +theorem machineRawRatPowerAccField_mem_FP : + machineRawRatPowerAccField ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineRawRatPowerBaseField_mem_FP : + machineRawRatPowerBaseField ∈ Complexity.FP := by + simpa only [machineRawRatPowerBaseField] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRawRatPowerBoundField_mem_FP : + machineRawRatPowerBoundField ∈ Complexity.FP := by + simpa only [machineRawRatPowerBoundField] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRawRatPowerCandidate_mem_FP : + machineRawRatPowerCandidate ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineRawRatPowerAccField_mem_FP + machineRawRatPowerBaseField_mem_FP + simpa only [machineRawRatPowerCandidate] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineRawRatPowerNextAcc_mem_FP : + machineRawRatPowerNextAcc ∈ Complexity.FP := by + simpa only [machineRawRatPowerNextAcc] using! + machineTake_mem_FP machineRawRatPowerBoundField_mem_FP + machineRawRatPowerCandidate_mem_FP + +theorem machineRawRatPowerStep_mem_FP : + machineRawRatPowerStep ∈ Complexity.FP := by + exact machinePair_mem_FP machineRawRatPowerNextAcc_mem_FP + (machinePair_mem_FP machineRawRatPowerBaseField_mem_FP + machineRawRatPowerBoundField_mem_FP) + +theorem machineRawRatPowerInputRuler_mem_FP : + machineRawRatPowerInputRuler ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineRawRatPowerInputBase_mem_FP : + machineRawRatPowerInputBase ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineRawRatPowerInputBound_mem_FP : + machineRawRatPowerInputBound ∈ Complexity.FP := + by + have hdouble := machineAppend_mem_FP machineBinaryMulWidth_mem_FP + machineBinaryMulWidth_mem_FP + have htriple := machineAppend_mem_FP machineBinaryMulWidth_mem_FP hdouble + have hquadruple := machineAppend_mem_FP machineBinaryMulWidth_mem_FP htriple + simpa only [machineRawRatPowerInputBound] using! + hquadruple + +theorem machineRawRatPowerInit_mem_FP : + machineRawRatPowerInit ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP rawRatOneCode) + (machinePair_mem_FP machineRawRatPowerInputBase_mem_FP + machineRawRatPowerInputBound_mem_FP) + +theorem machineRawRatPowerWidth_mem_FP : + machineRawRatPowerWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineRawRatPowerInputBound_mem_FP + (machinePair_mem_FP machineRawRatPowerInputBound_mem_FP + machineRawRatPowerInputBound_mem_FP) + +@[simp] theorem machineRawRatPowerAccField_pack (acc base bound) : + machineRawRatPowerAccField (machineRawRatPowerPack acc base bound) = acc := by + simp [machineRawRatPowerAccField, machineRawRatPowerPack] + +@[simp] theorem machineRawRatPowerBaseField_pack (acc base bound) : + machineRawRatPowerBaseField (machineRawRatPowerPack acc base bound) = base := by + simp [machineRawRatPowerBaseField, machineRawRatPowerPack] + +@[simp] theorem machineRawRatPowerBoundField_pack (acc base bound) : + machineRawRatPowerBoundField (machineRawRatPowerPack acc base bound) = bound := by + simp [machineRawRatPowerBoundField, machineRawRatPowerPack] + +/-- Total clamped accumulator used to prove the machine's arbitrary-input +length bound. -/ +def clampedRawRatPowerAcc (word : List Bool) : β„• β†’ List Bool + | 0 => rawRatOneCode + | k + 1 => + (machineRawRatMulCode + (pair (clampedRawRatPowerAcc word k) + (machineRawRatPowerInputBase word))).take + (machineRawRatPowerInputBound word).length + +theorem machineRawRatPowerStep_semantics (word : List Bool) (k : β„•) : + machineRawRatPowerStep + (machineRawRatPowerPack (clampedRawRatPowerAcc word k) + (machineRawRatPowerInputBase word) + (machineRawRatPowerInputBound word)) = + machineRawRatPowerPack (clampedRawRatPowerAcc word (k + 1)) + (machineRawRatPowerInputBase word) + (machineRawRatPowerInputBound word) := by + simp [machineRawRatPowerStep, machineRawRatPowerNextAcc, + machineRawRatPowerCandidate, clampedRawRatPowerAcc] + +theorem machineRawRatPowerIterate_semantics (word : List Bool) : βˆ€ k, + (machineRawRatPowerStep)^[k] (machineRawRatPowerInit word) = + machineRawRatPowerPack (clampedRawRatPowerAcc word k) + (machineRawRatPowerInputBase word) + (machineRawRatPowerInputBound word) := by + intro k + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih, + machineRawRatPowerStep_semantics] + +theorem machineRawRatPowerInputBase_length_le_bound (word : List Bool) : + (machineRawRatPowerInputBase word).length ≀ + (machineRawRatPowerInputBound word).length := by + have hbase := machinePairSecond_length_le word + simp only [machineRawRatPowerInputBase, machineRawRatPowerInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith + +theorem clampedRawRatPowerAcc_length_le_bound (word : List Bool) : βˆ€ k, + (clampedRawRatPowerAcc word k).length ≀ + (machineRawRatPowerInputBound word).length := by + intro k + cases k with + | zero => + simp [clampedRawRatPowerAcc, rawRatOneCode, rawRatBinaryCode, + RawRat.one, integerBinaryCode, machineRawRatPowerInputBound, + machineBinaryMulWidth] + nlinarith + | succ k => + simp only [clampedRawRatPowerAcc] + apply List.length_take_le + +theorem machineRawRatPowerIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineRawRatPowerInputRuler word).length) : + ((machineRawRatPowerStep)^[iterations] + (machineRawRatPowerInit word)).length ≀ + (machineRawRatPowerWidth word).length := by + rw [machineRawRatPowerIterate_semantics] + simp only [machineRawRatPowerPack, machineRawRatPowerWidth, pair_length] + have hacc := clampedRawRatPowerAcc_length_le_bound word iterations + have hbase := machineRawRatPowerInputBase_length_le_bound word + omega + +theorem machineRawRatPowerFinalState_mem_FP : + machineRawRatPowerFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineRawRatPowerStep_mem_FP + machineRawRatPowerInit_mem_FP machineRawRatPowerInputRuler_mem_FP + machineRawRatPowerWidth_mem_FP + machineRawRatPowerIterate_length_le_width + +theorem machineRawRatPowerCode_mem_FP : + machineRawRatPowerCode ∈ Complexity.FP := by + simpa only [machineRawRatPowerCode] using! + machineCompose_mem_FP machineRawRatPowerFinalState_mem_FP + machineRawRatPowerAccField_mem_FP + +theorem machineRationalPowerCode_mem_FP : + machineRationalPowerCode ∈ Complexity.FP := by + simpa only [machineRationalPowerCode] using! + machineCompose_mem_FP machineRawRatPowerCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +private theorem integerNatAbs_size_le_code_length (z : β„€) : + z.natAbs.size ≀ (integerBinaryCode z).length := by + cases z with + | ofNat n => + simp [integerBinaryCode, Nat.size_eq_bits_len] + | negSucc n => + have hs : (n + 1).size ≀ n.size + 1 := by + rw [Nat.size_le] + have hle : n + 1 ≀ 2 ^ n.size := + Nat.succ_le_iff.mpr (Nat.lt_size_self n) + have hlt : 2 ^ n.size < 2 ^ (n.size + 1) := by + rw [pow_succ] + have hpos : 0 < 2 ^ n.size := by positivity + omega + exact hle.trans_lt hlt + simpa [integerBinaryCode, Nat.size_eq_bits_len, + Nat.add_comm] using! hs + +private theorem rawRatWidth_le_code_length (q : RawRat) : + rawRatWidth q ≀ (rawRatBinaryCode q).length := by + rw [rawRatWidth, rawRatBinaryCode, pair_length] + apply max_le + Β· have h := integerNatAbs_size_le_code_length q.num + omega + Β· rw [Nat.size_eq_bits_len] + omega + +private theorem rawRatBinaryCode_length_le_width (q : RawRat) : + (rawRatBinaryCode q).length ≀ 4 + 3 * rawRatWidth q := by + rw [rawRatBinaryCode, pair_length] + have hnum : (integerBinaryCode q.num).length ≀ + 1 + rawRatWidth q := by + cases hqnum : q.num with + | ofNat n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have habs := rawRat_num_size_le_width q + simp only [hqnum, Int.natAbs_ofNat'] at habs + omega + | negSucc n => + simp only [integerBinaryCode, List.length_cons, + Nat.size_eq_bits_len] + have hsize : n.size ≀ (n + 1).size := + Nat.size_le_size (Nat.le_succ n) + have habs : (n + 1).size ≀ rawRatWidth q := by + simpa only [hqnum, Int.natAbs_negSucc] using! + rawRat_num_size_le_width q + have hnwidth : n.size ≀ rawRatWidth q := hsize.trans habs + omega + have hden := rawRat_den_size_le_width q + have hdenBits : q.den.bits.length ≀ rawRatWidth q := by + rw [Nat.size_eq_bits_len] + exact hden + omega + +private theorem rawRatPowerCode_length_le_inputBound + (q : RawRat) (total k : β„•) (hk : k ≀ total) : + (rawRatBinaryCode (q.pow k)).length ≀ + (machineRawRatPowerInputBound + (pair (List.replicate total true) (rawRatBinaryCode q))).length := by + let word := pair (List.replicate total true) (rawRatBinaryCode q) + have hcode := rawRatBinaryCode_length_le_width (q.pow k) + have hpow := RawRat.width_pow_le q k + have hqwidth := rawRatWidth_le_code_length q + have hraw : (rawRatBinaryCode q).length ≀ word.length := by + simp only [word, pair_length, List.length_replicate] + omega + have htotal : total ≀ word.length := by + simp only [word, pair_length, List.length_replicate] + omega + have hproduct : k * rawRatWidth q ≀ word.length * word.length := + Nat.mul_le_mul (hk.trans htotal) (hqwidth.trans hraw) + calc + (rawRatBinaryCode (q.pow k)).length + ≀ 4 + 3 * rawRatWidth (q.pow k) := hcode + _ ≀ 4 + 3 * (1 + k * rawRatWidth q) := by omega + _ ≀ 4 * ((16 + word.length) * (16 + word.length)) := by nlinarith + _ = (machineRawRatPowerInputBound word).length := by + simp [machineRawRatPowerInputBound, machineBinaryMulWidth] + ring + +theorem clampedRawRatPowerAcc_encode (q : RawRat) (total : β„•) : + βˆ€ k ≀ total, + clampedRawRatPowerAcc + (pair (List.replicate total true) (rawRatBinaryCode q)) k = + rawRatBinaryCode (q.pow k) := by + intro k hk + induction k with + | zero => rfl + | succ k ih => + rw [clampedRawRatPowerAcc, ih (by omega)] + simp only [machineRawRatPowerInputBase, machinePairSecond_pair, + machineRawRatMulCode_encode] + exact (List.take_eq_self_iff _).2 + (rawRatPowerCode_length_le_inputBound q total (k + 1) hk) + +theorem machineRawRatPowerCode_encode (q : RawRat) (k : β„•) : + machineRawRatPowerCode + (pair (List.replicate k true) (rawRatBinaryCode q)) = + rawRatBinaryCode (q.pow k) := by + simp only [machineRawRatPowerCode, machineRawRatPowerFinalState, + machineRawRatPowerInputRuler, machinePairFirst_pair, + List.length_replicate, machineRawRatPowerIterate_semantics, + machineRawRatPowerAccField_pack] + exact clampedRawRatPowerAcc_encode q k k le_rfl + +theorem machineRationalPowerCode_encode (q : RawRat) (k : β„•) : + machineRationalPowerCode + (pair (List.replicate k true) (rawRatBinaryCode q)) = + rationalBinaryCode (binaryNormalizeRawRat (q.pow k)) := by + rw [machineRationalPowerCode, machineRawRatPowerCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowAdd.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowAdd.lean new file mode 100644 index 0000000000..3d1b88adb2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowAdd.lean @@ -0,0 +1,674 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic +public import Mathlib.Tactic + +/-! +# Adding every entry of a rational row by one raw rational + +The input is `pair deltaRawCode rowCode`. Each output entry is normalized to +the numerator/denominator pair encoding required inside rational matrices. +This is deliberately not `machineRationalDivCode`, whose public output uses a +different one-natural encoding. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the fixed raw increment from a row-addition request. -/ +def machineRationalRowAddDelta (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded rational row from a row-addition request. -/ +def machineRationalRowAddRow (word : List Bool) : List Bool := + machinePairSecond word + +/-- Concatenates two copies of a word for row-addition width padding. -/ +def machineRationalRowAddPadTwo (word : List Bool) : List Bool := + word ++ word + +/-- Concatenates four copies of a word for row-addition width padding. -/ +def machineRationalRowAddPadFour (word : List Bool) : List Bool := + machineRationalRowAddPadTwo word ++ machineRationalRowAddPadTwo word + +/-- Concatenates eight copies of a word for row-addition width padding. -/ +def machineRationalRowAddPadEight (word : List Bool) : List Bool := + machineRationalRowAddPadFour word ++ machineRationalRowAddPadFour word + +/-- Concatenates sixteen copies of a word for row-addition width padding. -/ +def machineRationalRowAddPadSixteen (word : List Bool) : List Bool := + machineRationalRowAddPadEight word ++ machineRationalRowAddPadEight word + +/-- A coefficient-adjusted quadratic envelope. Sixteen copies before the +standard square provide enough room for every normalized output entry without +the impractical quartic padding used by an earlier draft. -/ +def machineRationalRowAddInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineRationalRowAddPadSixteen word) + +/-- Packs the unprocessed row, reversed output accumulator, fixed increment, and bound for row +addition. -/ +def machineRationalRowAddPack + (remaining accumulator delta bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair delta bound)) + +/-- Extracts the unprocessed encoded row from a row-addition state. -/ +def machineRationalRowAddRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reverse-order output accumulator from a row-addition state. -/ +def machineRationalRowAddAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed raw increment from a row-addition state. -/ +def machineRationalRowAddDeltaField (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulator length-bound word from a row-addition state. -/ +def machineRationalRowAddBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Adds the fixed increment to the next row entry in raw rational arithmetic. -/ +def machineRationalRowAddRawEntry (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineListHead (machineRationalRowAddRemaining state)) + (machineRationalRowAddDeltaField state)) + +/-- Normalizes the updated row entry into its rational entry encoding. -/ +def machineRationalRowAddEntry (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRationalRowAddRawEntry state) + +/-- Prepends the normalized updated entry to the reverse-order output accumulator. -/ +def machineRationalRowAddCandidate (state : List Bool) : List Bool := + pair (machineRationalRowAddEntry state) + (machineRationalRowAddAccumulator state) + +/-- Truncates the candidate row-addition accumulator to the stored bound length. -/ +def machineRationalRowAddNextAccumulator (state : List Bool) : List Bool := + (machineRationalRowAddCandidate state).take + (machineRationalRowAddBound state).length + +/-- Consumes the next row entry and stores the bounded updated accumulator, preserving increment +and bound. -/ +def machineRationalRowAddAdvance (state : List Bool) : List Bool := + machineRationalRowAddPack + (machineListTail (machineRationalRowAddRemaining state)) + (machineRationalRowAddNextAccumulator state) + (machineRationalRowAddDeltaField state) + (machineRationalRowAddBound state) + +/-- Fixes an exhausted row-addition state and otherwise processes one entry. -/ +def machineRationalRowAddStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalRowAddRemaining state) state + (machineRationalRowAddAdvance state) + +/-- Initializes row addition with the requested row, empty accumulator, fixed increment, and +computed bound. -/ +def machineRationalRowAddInit (word : List Bool) : List Bool := + machineRationalRowAddPack (machineRationalRowAddRow word) [] + (machineRationalRowAddDelta word) + (machineRationalRowAddInputBound word) + +/-- Packs input and bound words in the four-field layout to bound the row-addition state. -/ +def machineRationalRowAddWidth (word : List Bool) : List Bool := + let bound := machineRationalRowAddInputBound word + machineRationalRowAddPack word bound word bound + +/-- Runs the row-addition scan once per input bit from its initial state. -/ +def machineRationalRowAddFinalState (word : List Bool) : List Bool := + (machineRationalRowAddStep)^[word.length] + (machineRationalRowAddInit word) + +/-- Reverses the final accumulator to return the incremented rational row in its original order. -/ +def machineRationalRowAdd (word : List Bool) : List Bool := + machineListReverse + (machineRationalRowAddAccumulator + (machineRationalRowAddFinalState word)) + +theorem machineRationalRowAddDelta_mem_FP : + machineRationalRowAddDelta ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRationalRowAddRow_mem_FP : + machineRationalRowAddRow ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineRationalRowAddPadTwo_mem_FP : + machineRationalRowAddPadTwo ∈ Complexity.FP := + machineAppend_mem_FP id_mem_FP id_mem_FP + +theorem machineRationalRowAddPadFour_mem_FP : + machineRationalRowAddPadFour ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowAddPadTwo_mem_FP + machineRationalRowAddPadTwo_mem_FP + +theorem machineRationalRowAddPadEight_mem_FP : + machineRationalRowAddPadEight ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowAddPadFour_mem_FP + machineRationalRowAddPadFour_mem_FP + +theorem machineRationalRowAddPadSixteen_mem_FP : + machineRationalRowAddPadSixteen ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowAddPadEight_mem_FP + machineRationalRowAddPadEight_mem_FP + +theorem machineRationalRowAddInputBound_mem_FP : + machineRationalRowAddInputBound ∈ Complexity.FP := by + simpa only [machineRationalRowAddInputBound] using! + machineCompose_mem_FP machineRationalRowAddPadSixteen_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineRationalRowAddPadSixteen_length (word : List Bool) : + (machineRationalRowAddPadSixteen word).length = 16 * word.length := by + simp only [machineRationalRowAddPadSixteen, + machineRationalRowAddPadEight, + machineRationalRowAddPadFour, + machineRationalRowAddPadTwo, List.length_append] + omega + +theorem machineRationalRowAddInputBound_length_mono + {left right : List Bool} (h : left.length ≀ right.length) : + (machineRationalRowAddInputBound left).length ≀ + (machineRationalRowAddInputBound right).length := by + apply machineBinaryMulWidth_length_mono + rw [machineRationalRowAddPadSixteen_length, + machineRationalRowAddPadSixteen_length] + exact Nat.mul_le_mul_left 16 h + +theorem machineRationalRowAddRemaining_mem_FP : + machineRationalRowAddRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRationalRowAddAccumulator_mem_FP : + machineRationalRowAddAccumulator ∈ Complexity.FP := by + simpa only [machineRationalRowAddAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalRowAddDeltaField_mem_FP : + machineRationalRowAddDeltaField ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineRationalRowAddDeltaField] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineRationalRowAddBound_mem_FP : + machineRationalRowAddBound ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineRationalRowAddBound] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineRationalRowAddRawEntry_mem_FP : + machineRationalRowAddRawEntry ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP machineRationalRowAddRemaining_mem_FP + machineListHead_mem_FP + have hinput := machinePair_mem_FP hhead + machineRationalRowAddDeltaField_mem_FP + simpa only [machineRationalRowAddRawEntry] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineRationalRowAddEntry_mem_FP : + machineRationalRowAddEntry ∈ Complexity.FP := by + simpa only [machineRationalRowAddEntry] using! + machineCompose_mem_FP machineRationalRowAddRawEntry_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineRationalRowAddCandidate_mem_FP : + machineRationalRowAddCandidate ∈ Complexity.FP := + machinePair_mem_FP machineRationalRowAddEntry_mem_FP + machineRationalRowAddAccumulator_mem_FP + +theorem machineRationalRowAddNextAccumulator_mem_FP : + machineRationalRowAddNextAccumulator ∈ Complexity.FP := by + simpa only [machineRationalRowAddNextAccumulator] using! + machineTake_mem_FP machineRationalRowAddBound_mem_FP + machineRationalRowAddCandidate_mem_FP + +theorem machineRationalRowAddAdvance_mem_FP : + machineRationalRowAddAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineRationalRowAddRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalRowAddNextAccumulator_mem_FP + (machinePair_mem_FP machineRationalRowAddDeltaField_mem_FP + machineRationalRowAddBound_mem_FP)) + +theorem machineRationalRowAddStep_mem_FP : + machineRationalRowAddStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineRationalRowAddRemaining_mem_FP + id_mem_FP machineRationalRowAddAdvance_mem_FP + +theorem machineRationalRowAddInit_mem_FP : + machineRationalRowAddInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineRationalRowAddRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineRationalRowAddDelta_mem_FP + machineRationalRowAddInputBound_mem_FP)) + +theorem machineRationalRowAddWidth_mem_FP : + machineRationalRowAddWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRationalRowAddInputBound_mem_FP + (machinePair_mem_FP id_mem_FP + machineRationalRowAddInputBound_mem_FP)) + +@[simp] theorem machineRationalRowAddRemaining_pack (a b c d) : + machineRationalRowAddRemaining + (machineRationalRowAddPack a b c d) = a := by + simp [machineRationalRowAddRemaining, machineRationalRowAddPack] + +@[simp] theorem machineRationalRowAddAccumulator_pack (a b c d) : + machineRationalRowAddAccumulator + (machineRationalRowAddPack a b c d) = b := by + simp [machineRationalRowAddAccumulator, machineRationalRowAddPack] + +@[simp] theorem machineRationalRowAddDeltaField_pack (a b c d) : + machineRationalRowAddDeltaField + (machineRationalRowAddPack a b c d) = c := by + simp [machineRationalRowAddDeltaField, machineRationalRowAddPack] + +@[simp] theorem machineRationalRowAddBound_pack (a b c d) : + machineRationalRowAddBound + (machineRationalRowAddPack a b c d) = d := by + simp [machineRationalRowAddBound, machineRationalRowAddPack] + +/-- Requires exact row-addition state packing, input-bounded remaining row and increment, a +bounded accumulator, and the prescribed bound word. -/ +def MachineRationalRowAddStateBound (word state : List Bool) : Prop := + state = machineRationalRowAddPack + (machineRationalRowAddRemaining state) + (machineRationalRowAddAccumulator state) + (machineRationalRowAddDeltaField state) + (machineRationalRowAddBound state) ∧ + (machineRationalRowAddRemaining state).length ≀ word.length ∧ + (machineRationalRowAddAccumulator state).length ≀ + (machineRationalRowAddInputBound word).length ∧ + (machineRationalRowAddDeltaField state).length ≀ word.length ∧ + machineRationalRowAddBound state = + machineRationalRowAddInputBound word + +theorem machineRationalRowAddInit_bound (word : List Bool) : + MachineRationalRowAddStateBound word + (machineRationalRowAddInit word) := by + simp only [MachineRationalRowAddStateBound, + machineRationalRowAddInit, + machineRationalRowAddRemaining_pack, + machineRationalRowAddAccumulator_pack, + machineRationalRowAddDeltaField_pack, + machineRationalRowAddBound_pack] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineRationalRowAddRow] using! + machinePairSecond_length_le word + Β· simpa only [machineRationalRowAddDelta] using! + machinePairFirst_length_le word + +theorem machineRationalRowAddStep_bound {word state : List Bool} + (hstate : MachineRationalRowAddStateBound word state) : + MachineRationalRowAddStateBound word + (machineRationalRowAddStep state) := by + rcases hstate with + ⟨hdecomp, hremaining, haccumulator, hdelta, hbound⟩ + by_cases hnil : machineRationalRowAddRemaining state = [] + Β· rw [machineRationalRowAddStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, haccumulator, hdelta, hbound⟩ + Β· rw [machineRationalRowAddStep] + cases hremainingCode : machineRationalRowAddRemaining state with + | nil => exact False.elim (hnil hremainingCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineRationalRowAddAdvance] + simp only [MachineRationalRowAddStateBound, + machineRationalRowAddRemaining_pack, + machineRationalRowAddAccumulator_pack, + machineRationalRowAddDeltaField_pack, + machineRationalRowAddBound_pack] + refine ⟨trivial, ?_, ?_, hdelta, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalRowAddRemaining state)).trans hremaining + Β· rw [machineRationalRowAddNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalRowAddIterate_bound (word : List Bool) : βˆ€ k, + MachineRationalRowAddStateBound word + ((machineRationalRowAddStep)^[k] + (machineRationalRowAddInit word)) := by + intro k + induction k with + | zero => exact machineRationalRowAddInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalRowAddStep_bound ih + +theorem machineRationalRowAddIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineRationalRowAddStep)^[iterations] + (machineRationalRowAddInit word)).length ≀ + (machineRationalRowAddWidth word).length := by + rcases machineRationalRowAddIterate_bound word iterations with + ⟨hdecomp, hremaining, haccumulator, hdelta, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalRowAddPack, + machineRationalRowAddWidth, pair_length] + omega + +theorem machineRationalRowAddFinalState_mem_FP : + machineRationalRowAddFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineRationalRowAddStep_mem_FP + machineRationalRowAddInit_mem_FP id_mem_FP + machineRationalRowAddWidth_mem_FP + machineRationalRowAddIterate_length_le_width + +theorem machineRationalRowAdd_mem_FP : + machineRationalRowAdd ∈ Complexity.FP := by + have hacc := machineCompose_mem_FP + machineRationalRowAddFinalState_mem_FP + machineRationalRowAddAccumulator_mem_FP + simpa only [machineRationalRowAdd] using! + machineCompose_mem_FP hacc machineListReverse_mem_FP + +/-! ## Ordinary output-size estimate -/ + +private theorem natList_sum_le_length_mul {values : List β„•} {bound : β„•} + (h : βˆ€ value ∈ values, value ≀ bound) : + values.sum ≀ values.length * bound := by + induction values with + | nil => simp + | cons value values ih => + simp only [List.sum_cons, List.length_cons] + have hvalue := h value (by simp) + have htail : βˆ€ x ∈ values, x ≀ bound := by + intro x hx + exact h x (by simp [hx]) + have hi := ih htail + calc + value + values.sum ≀ bound + values.length * bound := + Nat.add_le_add hvalue hi + _ = (values.length + 1) * bound := by ring + +theorem machineRationalRowAdd_output_length_le_bound + (delta : RawRat) (row : List β„š) : + let word := pair (rawRatBinaryCode delta) + (binaryListCode rationalEntryBinaryCode row) + let output := row.map fun q ↦ + binaryNormalizeRawRat ((rawRatOfRat q).add delta) + (binaryListCode rationalEntryBinaryCode output).length ≀ + (machineRationalRowAddInputBound word).length := by + dsimp only + let word := pair (rawRatBinaryCode delta) + (binaryListCode rationalEntryBinaryCode row) + have hdelta : rawRatWidth delta ≀ word.length := by + have hcomponent : (rawRatBinaryCode delta).length ≀ word.length := by + simpa only [word, machinePairFirst_pair] using! + machinePairFirst_length_le word + exact (rawRatWidth_le_binaryCode_length delta).trans + hcomponent + have hrowLength : row.length ≀ word.length := by + have hcomponent : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact (binaryListCode_listLength_le rationalEntryBinaryCode row).trans + hcomponent + have hentry : βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).add delta))).length ≀ + 100 + 72 * word.length := by + intro q hq + have hqCode := binaryListCode_element_length_le + rationalEntryBinaryCode hq + have hqWidth : rawRatWidth (rawRatOfRat q) ≀ word.length := by + have hentryCode : + (rawRatBinaryCode (rawRatOfRat q)).length ≀ + (binaryListCode rationalEntryBinaryCode row).length := by + simpa only [rawRatBinaryCode_rawRatOfRat] using! hqCode + have hrowCode : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact (rawRatWidth_le_binaryCode_length (rawRatOfRat q)).trans + (hentryCode.trans hrowCode) + have hdiv := rawRatWidth_add_le (rawRatOfRat q) delta + have hnormalize := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + ((rawRatOfRat q).add delta) + omega + rw [binaryListCode_length_eq_sum] + have hterm : βˆ€ value ∈ + ((row.map fun q ↦ binaryNormalizeRawRat + ((rawRatOfRat q).add delta)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2), + value ≀ 202 + 144 * word.length := by + simp only [List.map_map] + intro value hvalue + rw [List.mem_map] at hvalue + rcases hvalue with ⟨q, hq, rfl⟩ + have := hentry q hq + simp only [Function.comp_apply] + omega + have hsum := natList_sum_le_length_mul hterm + simp only [List.length_map] at hsum + have hpoly : + word.length * (202 + 144 * word.length) ≀ + (machineRationalRowAddInputBound word).length := by + simp only [machineRationalRowAddInputBound, + machineBinaryMulWidth, + List.length_replicate, List.length_append] + rw [machineRationalRowAddPadSixteen_length] + nlinarith [sq_nonneg word.length] + exact hsum.trans <| (Nat.mul_le_mul_right _ hrowLength).trans hpoly + +/-! ## Exact semantics -/ + +/-- Adds the raw increment to each rational row entry and normalizes each resulting raw +fraction. -/ +def rationalRowAddValues (delta : RawRat) (row : List β„š) : List β„š := + row.map fun q ↦ binaryNormalizeRawRat ((rawRatOfRat q).add delta) + +/-- Encodes a raw increment paired with the rational row to update. -/ +def machineRationalRowAddCanonicalInput + (delta : RawRat) (row : List β„š) : List Bool := + pair (rawRatBinaryCode delta) + (binaryListCode rationalEntryBinaryCode row) + +/-- Encodes the unprocessed row suffix and reversed incremented prefix after `k` entries, +preserving increment and bound. -/ +def machineRationalRowAddSemanticState + (delta : RawRat) (row : List β„š) (k : β„•) : List Bool := + let output := rationalRowAddValues delta row + let word := machineRationalRowAddCanonicalInput delta row + machineRationalRowAddPack + (binaryListCode rationalEntryBinaryCode (row.drop k)) + (binaryListCode rationalEntryBinaryCode (output.take k).reverse) + (rawRatBinaryCode delta) + (machineRationalRowAddInputBound word) + +theorem machineRationalRowAddInit_semantics + (delta : RawRat) (row : List β„š) : + machineRationalRowAddInit + (machineRationalRowAddCanonicalInput delta row) = + machineRationalRowAddSemanticState delta row 0 := by + simp [machineRationalRowAddInit, + machineRationalRowAddCanonicalInput, + machineRationalRowAddSemanticState, + machineRationalRowAddRow, machineRationalRowAddDelta, + binaryListCode] + +theorem machineRationalRowAddEntry_semantics + (delta : RawRat) (row : List β„š) (k : β„•) (hk : k < row.length) : + machineRationalRowAddEntry + (machineRationalRowAddSemanticState delta row k) = + rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat row[k]).add delta)) := by + have hdrop := List.drop_eq_getElem_cons hk + rw [machineRationalRowAddEntry, + machineRationalRowAddRawEntry] + simp only [machineRationalRowAddSemanticState, + machineRationalRowAddRemaining_pack, + machineRationalRowAddDeltaField_pack, hdrop, + machineListHead_cons, ← rawRatBinaryCode_rawRatOfRat, + machineRawRatAddCode_encode, + machineNormalizeRawRatEntryCode_encode] + +theorem machineRationalRowAddStep_semantics + (delta : RawRat) (row : List β„š) (k : β„•) (hk : k < row.length) : + machineRationalRowAddStep + (machineRationalRowAddSemanticState delta row k) = + machineRationalRowAddSemanticState delta row (k + 1) := by + let output := rationalRowAddValues delta row + let word := machineRationalRowAddCanonicalInput delta row + have houtputLength : output.length = row.length := by + simp [output, rationalRowAddValues] + have hkoutput : k < output.length := by omega + have houtputGet : output[k] = + binaryNormalizeRawRat ((rawRatOfRat row[k]).add delta) := by + simp [output, rationalRowAddValues, List.getElem_map] + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hkoutput + have hprefix : (output.take (k + 1)).reverse = + output[k] :: (output.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := output.take k) (a := output[k])) + have hfullBound : + (binaryListCode rationalEntryBinaryCode output).length ≀ + (machineRationalRowAddInputBound word).length := by + simpa only [word, output, machineRationalRowAddCanonicalInput, + rationalRowAddValues] using! + machineRationalRowAdd_output_length_le_bound delta row + have hprefixLength : + (binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse).length ≀ + (machineRationalRowAddInputBound word).length := + (binaryListCode_take_reverse_length_le rationalEntryBinaryCode + output (k + 1)).trans hfullBound + have htakeBound : + (binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse).take + (machineRationalRowAddInputBound word).length = + binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hnonempty : + binaryListCode rationalEntryBinaryCode (row.drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil _ _ _ + rw [machineRationalRowAddStep] + simp only [machineRationalRowAddSemanticState, + machineRationalRowAddRemaining_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hnonempty, + machineRationalRowAddAdvance] + simp only [machineRationalRowAddRemaining_pack, + machineRationalRowAddAccumulator_pack, + machineRationalRowAddDeltaField_pack, + machineRationalRowAddBound_pack, + machineRationalRowAddNextAccumulator, + machineRationalRowAddCandidate] + have hentry : + machineRationalRowAddEntry + (machineRationalRowAddPack + (binaryListCode rationalEntryBinaryCode (row.drop k)) + (binaryListCode rationalEntryBinaryCode + (output.take k).reverse) + (rawRatBinaryCode delta) + (machineRationalRowAddInputBound word)) = + rationalEntryBinaryCode output[k] := by + rw [houtputGet] + simpa only [machineRationalRowAddSemanticState, output, word] using! + machineRationalRowAddEntry_semantics delta row k hk + rw [hentry] + rw [hdrop, machineListTail_cons] + change machineRationalRowAddPack + (binaryListCode rationalEntryBinaryCode (row.drop (k + 1))) + ((binaryListCode rationalEntryBinaryCode + (output[k] :: (output.take k).reverse)).take + (machineRationalRowAddInputBound word).length) + (rawRatBinaryCode delta) + (machineRationalRowAddInputBound word) = _ + rw [← hprefix, htakeBound] + +theorem machineRationalRowAddIterate_semantics + (delta : RawRat) (row : List β„š) : βˆ€ k ≀ row.length, + (machineRationalRowAddStep)^[k] + (machineRationalRowAddInit + (machineRationalRowAddCanonicalInput delta row)) = + machineRationalRowAddSemanticState delta row k := by + intro k hk + induction k with + | zero => exact machineRationalRowAddInit_semantics delta row + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalRowAddStep_semantics delta row k (by omega) + +theorem machineRationalRowAdd_done_iterate + (extra : β„•) (accumulator delta bound : List Bool) : + (machineRationalRowAddStep)^[extra] + (machineRationalRowAddPack [] accumulator delta bound) = + machineRationalRowAddPack [] accumulator delta bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalRowAddStep] + +theorem machineRationalRowAddFinalState_encode + (delta : RawRat) (row : List β„š) : + machineRationalRowAddFinalState + (machineRationalRowAddCanonicalInput delta row) = + machineRationalRowAddPack [] + (binaryListCode rationalEntryBinaryCode + (rationalRowAddValues delta row).reverse) + (rawRatBinaryCode delta) + (machineRationalRowAddInputBound + (machineRationalRowAddCanonicalInput delta row)) := by + let word := machineRationalRowAddCanonicalInput delta row + have hrowLength : row.length ≀ word.length := by + have hcomponent : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machineRationalRowAddCanonicalInput, + machinePairSecond_pair] using! + (show (machinePairSecond word).length ≀ word.length from + machinePairSecond_length_le word) + exact (binaryListCode_listLength_le rationalEntryBinaryCode row).trans + hcomponent + have htakeAll : + (rationalRowAddValues delta row).take row.length = + rationalRowAddValues delta row := by + have hlength : (rationalRowAddValues delta row).length = + row.length := by simp [rationalRowAddValues] + rw [← hlength, List.take_length] + have hsplit : word.length = + (word.length - row.length) + row.length := by omega + change (machineRationalRowAddStep)^[word.length] + (machineRationalRowAddInit word) = _ + rw [hsplit, Function.iterate_add_apply, + machineRationalRowAddIterate_semantics delta row row.length le_rfl] + simp only [machineRationalRowAddSemanticState, List.drop_length, + binaryListCode, word] + rw [htakeAll] + rw [machineRationalRowAdd_done_iterate] + +@[simp] theorem machineRationalRowAdd_encode + (delta : RawRat) (row : List β„š) : + machineRationalRowAdd + (machineRationalRowAddCanonicalInput delta row) = + binaryListCode rationalEntryBinaryCode + (rationalRowAddValues delta row) := by + rw [machineRationalRowAdd, + machineRationalRowAddFinalState_encode] + simp only [machineRationalRowAddAccumulator_pack, + machineListReverse_encode, List.reverse_reverse] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowDivide.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowDivide.lean new file mode 100644 index 0000000000..8071d8ff0e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalRowDivide.lean @@ -0,0 +1,673 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalUnary +public import Mathlib.Tactic + +/-! +# Dividing every entry of a rational row by one raw rational + +The input is `pair scaleRawCode rowCode`. Each output entry is normalized to +the numerator/denominator pair encoding required inside rational matrices. +This is deliberately not `machineRationalDivCode`, whose public output uses a +different one-natural encoding. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the fixed raw divisor from a row-division request. -/ +def machineRationalRowDivideScale (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded rational row from a row-division request. -/ +def machineRationalRowDivideRow (word : List Bool) : List Bool := + machinePairSecond word + +/-- Concatenates two copies of a word for row-division width padding. -/ +def machineRationalRowDividePadTwo (word : List Bool) : List Bool := + word ++ word + +/-- Concatenates four copies of a word for row-division width padding. -/ +def machineRationalRowDividePadFour (word : List Bool) : List Bool := + machineRationalRowDividePadTwo word ++ machineRationalRowDividePadTwo word + +/-- Concatenates eight copies of a word for row-division width padding. -/ +def machineRationalRowDividePadEight (word : List Bool) : List Bool := + machineRationalRowDividePadFour word ++ machineRationalRowDividePadFour word + +/-- Concatenates sixteen copies of a word for row-division width padding. -/ +def machineRationalRowDividePadSixteen (word : List Bool) : List Bool := + machineRationalRowDividePadEight word ++ machineRationalRowDividePadEight word + +/-- A coefficient-adjusted quadratic envelope. Sixteen copies before the +standard square provide enough room for every normalized output entry without +the impractical quartic padding used by an earlier draft. -/ +def machineRationalRowDivideInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth (machineRationalRowDividePadSixteen word) + +/-- Packs the unprocessed row, reversed output accumulator, fixed divisor, and bound for row +division. -/ +def machineRationalRowDividePack + (remaining accumulator scale bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair scale bound)) + +/-- Extracts the unprocessed encoded row from a row-division state. -/ +def machineRationalRowDivideRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the reverse-order output accumulator from a row-division state. -/ +def machineRationalRowDivideAccumulator (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed raw divisor from a row-division state. -/ +def machineRationalRowDivideScaleField (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulator length-bound word from a row-division state. -/ +def machineRationalRowDivideBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Divides the next row entry by the fixed scale in raw rational arithmetic. -/ +def machineRationalRowDivideRawEntry (state : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineListHead (machineRationalRowDivideRemaining state)) + (machineRationalRowDivideScaleField state)) + +/-- Normalizes the divided row entry into its rational entry encoding. -/ +def machineRationalRowDivideEntry (state : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRationalRowDivideRawEntry state) + +/-- Prepends the normalized divided entry to the reverse-order output accumulator. -/ +def machineRationalRowDivideCandidate (state : List Bool) : List Bool := + pair (machineRationalRowDivideEntry state) + (machineRationalRowDivideAccumulator state) + +/-- Truncates the candidate row-division accumulator to the stored bound length. -/ +def machineRationalRowDivideNextAccumulator (state : List Bool) : List Bool := + (machineRationalRowDivideCandidate state).take + (machineRationalRowDivideBound state).length + +/-- Consumes the next row entry and stores the bounded updated accumulator, preserving divisor +and bound. -/ +def machineRationalRowDivideAdvance (state : List Bool) : List Bool := + machineRationalRowDividePack + (machineListTail (machineRationalRowDivideRemaining state)) + (machineRationalRowDivideNextAccumulator state) + (machineRationalRowDivideScaleField state) + (machineRationalRowDivideBound state) + +/-- Fixes an exhausted row-division state and otherwise processes one entry. -/ +def machineRationalRowDivideStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalRowDivideRemaining state) state + (machineRationalRowDivideAdvance state) + +/-- Initializes row division with the requested row, empty accumulator, fixed divisor, and +computed bound. -/ +def machineRationalRowDivideInit (word : List Bool) : List Bool := + machineRationalRowDividePack (machineRationalRowDivideRow word) [] + (machineRationalRowDivideScale word) + (machineRationalRowDivideInputBound word) + +/-- Packs input and bound words in the four-field layout to bound the row-division state. -/ +def machineRationalRowDivideWidth (word : List Bool) : List Bool := + let bound := machineRationalRowDivideInputBound word + machineRationalRowDividePack word bound word bound + +/-- Runs the row-division scan once per input bit from its initial state. -/ +def machineRationalRowDivideFinalState (word : List Bool) : List Bool := + (machineRationalRowDivideStep)^[word.length] + (machineRationalRowDivideInit word) + +/-- Reverses the final accumulator to return the divided rational row in its original order. -/ +def machineRationalRowDivide (word : List Bool) : List Bool := + machineListReverse + (machineRationalRowDivideAccumulator + (machineRationalRowDivideFinalState word)) + +theorem machineRationalRowDivideScale_mem_FP : + machineRationalRowDivideScale ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRationalRowDivideRow_mem_FP : + machineRationalRowDivideRow ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineRationalRowDividePadTwo_mem_FP : + machineRationalRowDividePadTwo ∈ Complexity.FP := + machineAppend_mem_FP id_mem_FP id_mem_FP + +theorem machineRationalRowDividePadFour_mem_FP : + machineRationalRowDividePadFour ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowDividePadTwo_mem_FP + machineRationalRowDividePadTwo_mem_FP + +theorem machineRationalRowDividePadEight_mem_FP : + machineRationalRowDividePadEight ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowDividePadFour_mem_FP + machineRationalRowDividePadFour_mem_FP + +theorem machineRationalRowDividePadSixteen_mem_FP : + machineRationalRowDividePadSixteen ∈ Complexity.FP := + machineAppend_mem_FP machineRationalRowDividePadEight_mem_FP + machineRationalRowDividePadEight_mem_FP + +theorem machineRationalRowDivideInputBound_mem_FP : + machineRationalRowDivideInputBound ∈ Complexity.FP := by + simpa only [machineRationalRowDivideInputBound] using! + machineCompose_mem_FP machineRationalRowDividePadSixteen_mem_FP + machineBinaryMulWidth_mem_FP + +theorem machineRationalRowDividePadSixteen_length (word : List Bool) : + (machineRationalRowDividePadSixteen word).length = 16 * word.length := by + simp only [machineRationalRowDividePadSixteen, + machineRationalRowDividePadEight, + machineRationalRowDividePadFour, + machineRationalRowDividePadTwo, List.length_append] + omega + +theorem machineRationalRowDivideInputBound_length_mono + {left right : List Bool} (h : left.length ≀ right.length) : + (machineRationalRowDivideInputBound left).length ≀ + (machineRationalRowDivideInputBound right).length := by + apply machineBinaryMulWidth_length_mono + rw [machineRationalRowDividePadSixteen_length, + machineRationalRowDividePadSixteen_length] + exact Nat.mul_le_mul_left 16 h + +theorem machineRationalRowDivideRemaining_mem_FP : + machineRationalRowDivideRemaining ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineRationalRowDivideAccumulator_mem_FP : + machineRationalRowDivideAccumulator ∈ Complexity.FP := by + simpa only [machineRationalRowDivideAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalRowDivideScaleField_mem_FP : + machineRationalRowDivideScaleField ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineRationalRowDivideScaleField] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineRationalRowDivideBound_mem_FP : + machineRationalRowDivideBound ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineRationalRowDivideBound] using! + machineCompose_mem_FP htail machinePairSecond_mem_FP + +theorem machineRationalRowDivideRawEntry_mem_FP : + machineRationalRowDivideRawEntry ∈ Complexity.FP := by + have hhead := machineCompose_mem_FP machineRationalRowDivideRemaining_mem_FP + machineListHead_mem_FP + have hinput := machinePair_mem_FP hhead + machineRationalRowDivideScaleField_mem_FP + simpa only [machineRationalRowDivideRawEntry] using! + machineCompose_mem_FP hinput machineRawRatDivCode_mem_FP + +theorem machineRationalRowDivideEntry_mem_FP : + machineRationalRowDivideEntry ∈ Complexity.FP := by + simpa only [machineRationalRowDivideEntry] using! + machineCompose_mem_FP machineRationalRowDivideRawEntry_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineRationalRowDivideCandidate_mem_FP : + machineRationalRowDivideCandidate ∈ Complexity.FP := + machinePair_mem_FP machineRationalRowDivideEntry_mem_FP + machineRationalRowDivideAccumulator_mem_FP + +theorem machineRationalRowDivideNextAccumulator_mem_FP : + machineRationalRowDivideNextAccumulator ∈ Complexity.FP := by + simpa only [machineRationalRowDivideNextAccumulator] using! + machineTake_mem_FP machineRationalRowDivideBound_mem_FP + machineRationalRowDivideCandidate_mem_FP + +theorem machineRationalRowDivideAdvance_mem_FP : + machineRationalRowDivideAdvance ∈ Complexity.FP := by + have htail := machineCompose_mem_FP machineRationalRowDivideRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalRowDivideNextAccumulator_mem_FP + (machinePair_mem_FP machineRationalRowDivideScaleField_mem_FP + machineRationalRowDivideBound_mem_FP)) + +theorem machineRationalRowDivideStep_mem_FP : + machineRationalRowDivideStep ∈ Complexity.FP := by + exact machineIfEmpty_mem_FP machineRationalRowDivideRemaining_mem_FP + id_mem_FP machineRationalRowDivideAdvance_mem_FP + +theorem machineRationalRowDivideInit_mem_FP : + machineRationalRowDivideInit ∈ Complexity.FP := by + exact machinePair_mem_FP machineRationalRowDivideRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineRationalRowDivideScale_mem_FP + machineRationalRowDivideInputBound_mem_FP)) + +theorem machineRationalRowDivideWidth_mem_FP : + machineRationalRowDivideWidth ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRationalRowDivideInputBound_mem_FP + (machinePair_mem_FP id_mem_FP + machineRationalRowDivideInputBound_mem_FP)) + +@[simp] theorem machineRationalRowDivideRemaining_pack (a b c d) : + machineRationalRowDivideRemaining + (machineRationalRowDividePack a b c d) = a := by + simp [machineRationalRowDivideRemaining, machineRationalRowDividePack] + +@[simp] theorem machineRationalRowDivideAccumulator_pack (a b c d) : + machineRationalRowDivideAccumulator + (machineRationalRowDividePack a b c d) = b := by + simp [machineRationalRowDivideAccumulator, machineRationalRowDividePack] + +@[simp] theorem machineRationalRowDivideScaleField_pack (a b c d) : + machineRationalRowDivideScaleField + (machineRationalRowDividePack a b c d) = c := by + simp [machineRationalRowDivideScaleField, machineRationalRowDividePack] + +@[simp] theorem machineRationalRowDivideBound_pack (a b c d) : + machineRationalRowDivideBound + (machineRationalRowDividePack a b c d) = d := by + simp [machineRationalRowDivideBound, machineRationalRowDividePack] + +/-- Requires exact row-division state packing, input-bounded remaining row and divisor, a +bounded accumulator, and the prescribed bound word. -/ +def MachineRationalRowDivideStateBound (word state : List Bool) : Prop := + state = machineRationalRowDividePack + (machineRationalRowDivideRemaining state) + (machineRationalRowDivideAccumulator state) + (machineRationalRowDivideScaleField state) + (machineRationalRowDivideBound state) ∧ + (machineRationalRowDivideRemaining state).length ≀ word.length ∧ + (machineRationalRowDivideAccumulator state).length ≀ + (machineRationalRowDivideInputBound word).length ∧ + (machineRationalRowDivideScaleField state).length ≀ word.length ∧ + machineRationalRowDivideBound state = + machineRationalRowDivideInputBound word + +theorem machineRationalRowDivideInit_bound (word : List Bool) : + MachineRationalRowDivideStateBound word + (machineRationalRowDivideInit word) := by + simp only [MachineRationalRowDivideStateBound, + machineRationalRowDivideInit, + machineRationalRowDivideRemaining_pack, + machineRationalRowDivideAccumulator_pack, + machineRationalRowDivideScaleField_pack, + machineRationalRowDivideBound_pack] + refine ⟨trivial, ?_, by simp, ?_, trivial⟩ + Β· simpa only [machineRationalRowDivideRow] using! + machinePairSecond_length_le word + Β· simpa only [machineRationalRowDivideScale] using! + machinePairFirst_length_le word + +theorem machineRationalRowDivideStep_bound {word state : List Bool} + (hstate : MachineRationalRowDivideStateBound word state) : + MachineRationalRowDivideStateBound word + (machineRationalRowDivideStep state) := by + rcases hstate with + ⟨hdecomp, hremaining, haccumulator, hscale, hbound⟩ + by_cases hnil : machineRationalRowDivideRemaining state = [] + Β· rw [machineRationalRowDivideStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, haccumulator, hscale, hbound⟩ + Β· rw [machineRationalRowDivideStep] + cases hremainingCode : machineRationalRowDivideRemaining state with + | nil => exact False.elim (hnil hremainingCode) + | cons bit tail => + rw [machineIfEmpty_cons, machineRationalRowDivideAdvance] + simp only [MachineRationalRowDivideStateBound, + machineRationalRowDivideRemaining_pack, + machineRationalRowDivideAccumulator_pack, + machineRationalRowDivideScaleField_pack, + machineRationalRowDivideBound_pack] + refine ⟨trivial, ?_, ?_, hscale, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalRowDivideRemaining state)).trans hremaining + Β· rw [machineRationalRowDivideNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalRowDivideIterate_bound (word : List Bool) : βˆ€ k, + MachineRationalRowDivideStateBound word + ((machineRationalRowDivideStep)^[k] + (machineRationalRowDivideInit word)) := by + intro k + induction k with + | zero => exact machineRationalRowDivideInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalRowDivideStep_bound ih + +theorem machineRationalRowDivideIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineRationalRowDivideStep)^[iterations] + (machineRationalRowDivideInit word)).length ≀ + (machineRationalRowDivideWidth word).length := by + rcases machineRationalRowDivideIterate_bound word iterations with + ⟨hdecomp, hremaining, haccumulator, hscale, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalRowDividePack, + machineRationalRowDivideWidth, pair_length] + omega + +theorem machineRationalRowDivideFinalState_mem_FP : + machineRationalRowDivideFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineRationalRowDivideStep_mem_FP + machineRationalRowDivideInit_mem_FP id_mem_FP + machineRationalRowDivideWidth_mem_FP + machineRationalRowDivideIterate_length_le_width + +theorem machineRationalRowDivide_mem_FP : + machineRationalRowDivide ∈ Complexity.FP := by + have hacc := machineCompose_mem_FP + machineRationalRowDivideFinalState_mem_FP + machineRationalRowDivideAccumulator_mem_FP + simpa only [machineRationalRowDivide] using! + machineCompose_mem_FP hacc machineListReverse_mem_FP + +/-! ## Ordinary output-size estimate -/ + +private theorem natList_sum_le_length_mul {values : List β„•} {bound : β„•} + (h : βˆ€ value ∈ values, value ≀ bound) : + values.sum ≀ values.length * bound := by + induction values with + | nil => simp + | cons value values ih => + simp only [List.sum_cons, List.length_cons] + have hvalue := h value (by simp) + have htail : βˆ€ x ∈ values, x ≀ bound := by + intro x hx + exact h x (by simp [hx]) + have hi := ih htail + calc + value + values.sum ≀ bound + values.length * bound := + Nat.add_le_add hvalue hi + _ = (values.length + 1) * bound := by ring + +theorem machineRationalRowDivide_output_length_le_bound + (scale : RawRat) (row : List β„š) : + let word := pair (rawRatBinaryCode scale) + (binaryListCode rationalEntryBinaryCode row) + let output := row.map fun q ↦ + binaryNormalizeRawRat ((rawRatOfRat q).div scale) + (binaryListCode rationalEntryBinaryCode output).length ≀ + (machineRationalRowDivideInputBound word).length := by + dsimp only + let word := pair (rawRatBinaryCode scale) + (binaryListCode rationalEntryBinaryCode row) + have hscale : rawRatWidth scale ≀ word.length := by + have hcomponent : (rawRatBinaryCode scale).length ≀ word.length := by + simpa only [word, machinePairFirst_pair] using! + machinePairFirst_length_le word + exact (rawRatWidth_le_binaryCode_length scale).trans + hcomponent + have hrowLength : row.length ≀ word.length := by + have hcomponent : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact (binaryListCode_listLength_le rationalEntryBinaryCode row).trans + hcomponent + have hentry : βˆ€ q ∈ row, + (rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat q).div scale))).length ≀ + 64 + 72 * word.length := by + intro q hq + have hqCode := binaryListCode_element_length_le + rationalEntryBinaryCode hq + have hqWidth : rawRatWidth (rawRatOfRat q) ≀ word.length := by + have hentryCode : + (rawRatBinaryCode (rawRatOfRat q)).length ≀ + (binaryListCode rationalEntryBinaryCode row).length := by + simpa only [rawRatBinaryCode_rawRatOfRat] using! hqCode + have hrowCode : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact (rawRatWidth_le_binaryCode_length (rawRatOfRat q)).trans + (hentryCode.trans hrowCode) + have hdiv := rawRatWidth_div_le (rawRatOfRat q) scale + have hnormalize := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + ((rawRatOfRat q).div scale) + omega + rw [binaryListCode_length_eq_sum] + have hterm : βˆ€ value ∈ + ((row.map fun q ↦ binaryNormalizeRawRat + ((rawRatOfRat q).div scale)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2), + value ≀ 130 + 144 * word.length := by + simp only [List.map_map] + intro value hvalue + rw [List.mem_map] at hvalue + rcases hvalue with ⟨q, hq, rfl⟩ + have := hentry q hq + simp only [Function.comp_apply] + omega + have hsum := natList_sum_le_length_mul hterm + simp only [List.length_map] at hsum + have hpoly : + word.length * (130 + 144 * word.length) ≀ + (machineRationalRowDivideInputBound word).length := by + simp only [machineRationalRowDivideInputBound, + machineBinaryMulWidth, + List.length_replicate, List.length_append] + rw [machineRationalRowDividePadSixteen_length] + nlinarith [sq_nonneg word.length] + exact hsum.trans <| (Nat.mul_le_mul_right _ hrowLength).trans hpoly + +/-! ## Exact semantics -/ + +/-- Divides each rational row entry by the raw scale and normalizes each resulting raw fraction. -/ +def rationalRowDivideValues (scale : RawRat) (row : List β„š) : List β„š := + row.map fun q ↦ binaryNormalizeRawRat ((rawRatOfRat q).div scale) + +/-- Encodes a raw divisor paired with the rational row to divide. -/ +def machineRationalRowDivideCanonicalInput + (scale : RawRat) (row : List β„š) : List Bool := + pair (rawRatBinaryCode scale) + (binaryListCode rationalEntryBinaryCode row) + +/-- Encodes the unprocessed row suffix and reversed divided prefix after `k` entries, preserving +divisor and bound. -/ +def machineRationalRowDivideSemanticState + (scale : RawRat) (row : List β„š) (k : β„•) : List Bool := + let output := rationalRowDivideValues scale row + let word := machineRationalRowDivideCanonicalInput scale row + machineRationalRowDividePack + (binaryListCode rationalEntryBinaryCode (row.drop k)) + (binaryListCode rationalEntryBinaryCode (output.take k).reverse) + (rawRatBinaryCode scale) + (machineRationalRowDivideInputBound word) + +theorem machineRationalRowDivideInit_semantics + (scale : RawRat) (row : List β„š) : + machineRationalRowDivideInit + (machineRationalRowDivideCanonicalInput scale row) = + machineRationalRowDivideSemanticState scale row 0 := by + simp [machineRationalRowDivideInit, + machineRationalRowDivideCanonicalInput, + machineRationalRowDivideSemanticState, + machineRationalRowDivideRow, machineRationalRowDivideScale, + binaryListCode] + +theorem machineRationalRowDivideEntry_semantics + (scale : RawRat) (row : List β„š) (k : β„•) (hk : k < row.length) : + machineRationalRowDivideEntry + (machineRationalRowDivideSemanticState scale row k) = + rationalEntryBinaryCode + (binaryNormalizeRawRat ((rawRatOfRat row[k]).div scale)) := by + have hdrop := List.drop_eq_getElem_cons hk + rw [machineRationalRowDivideEntry, + machineRationalRowDivideRawEntry] + simp only [machineRationalRowDivideSemanticState, + machineRationalRowDivideRemaining_pack, + machineRationalRowDivideScaleField_pack, hdrop, + machineListHead_cons, ← rawRatBinaryCode_rawRatOfRat, + machineRawRatDivCode_encode, + machineNormalizeRawRatEntryCode_encode] + +theorem machineRationalRowDivideStep_semantics + (scale : RawRat) (row : List β„š) (k : β„•) (hk : k < row.length) : + machineRationalRowDivideStep + (machineRationalRowDivideSemanticState scale row k) = + machineRationalRowDivideSemanticState scale row (k + 1) := by + let output := rationalRowDivideValues scale row + let word := machineRationalRowDivideCanonicalInput scale row + have houtputLength : output.length = row.length := by + simp [output, rationalRowDivideValues] + have hkoutput : k < output.length := by omega + have houtputGet : output[k] = + binaryNormalizeRawRat ((rawRatOfRat row[k]).div scale) := by + simp [output, rationalRowDivideValues, List.getElem_map] + have hdrop := List.drop_eq_getElem_cons hk + have htake := List.take_concat_get hkoutput + have hprefix : (output.take (k + 1)).reverse = + output[k] :: (output.take k).reverse := by + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat (l := output.take k) (a := output[k])) + have hfullBound : + (binaryListCode rationalEntryBinaryCode output).length ≀ + (machineRationalRowDivideInputBound word).length := by + simpa only [word, output, machineRationalRowDivideCanonicalInput, + rationalRowDivideValues] using! + machineRationalRowDivide_output_length_le_bound scale row + have hprefixLength : + (binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse).length ≀ + (machineRationalRowDivideInputBound word).length := + (binaryListCode_take_reverse_length_le rationalEntryBinaryCode + output (k + 1)).trans hfullBound + have htakeBound : + (binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse).take + (machineRationalRowDivideInputBound word).length = + binaryListCode rationalEntryBinaryCode + (output.take (k + 1)).reverse := + List.take_of_length_le hprefixLength + have hnonempty : + binaryListCode rationalEntryBinaryCode (row.drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil _ _ _ + rw [machineRationalRowDivideStep] + simp only [machineRationalRowDivideSemanticState, + machineRationalRowDivideRemaining_pack] + rw [machineIfEmpty_of_ne_nil _ _ _ hnonempty, + machineRationalRowDivideAdvance] + simp only [machineRationalRowDivideRemaining_pack, + machineRationalRowDivideAccumulator_pack, + machineRationalRowDivideScaleField_pack, + machineRationalRowDivideBound_pack, + machineRationalRowDivideNextAccumulator, + machineRationalRowDivideCandidate] + have hentry : + machineRationalRowDivideEntry + (machineRationalRowDividePack + (binaryListCode rationalEntryBinaryCode (row.drop k)) + (binaryListCode rationalEntryBinaryCode + (output.take k).reverse) + (rawRatBinaryCode scale) + (machineRationalRowDivideInputBound word)) = + rationalEntryBinaryCode output[k] := by + rw [houtputGet] + simpa only [machineRationalRowDivideSemanticState, output, word] using! + machineRationalRowDivideEntry_semantics scale row k hk + rw [hentry] + rw [hdrop, machineListTail_cons] + change machineRationalRowDividePack + (binaryListCode rationalEntryBinaryCode (row.drop (k + 1))) + ((binaryListCode rationalEntryBinaryCode + (output[k] :: (output.take k).reverse)).take + (machineRationalRowDivideInputBound word).length) + (rawRatBinaryCode scale) + (machineRationalRowDivideInputBound word) = _ + rw [← hprefix, htakeBound] + +theorem machineRationalRowDivideIterate_semantics + (scale : RawRat) (row : List β„š) : βˆ€ k ≀ row.length, + (machineRationalRowDivideStep)^[k] + (machineRationalRowDivideInit + (machineRationalRowDivideCanonicalInput scale row)) = + machineRationalRowDivideSemanticState scale row k := by + intro k hk + induction k with + | zero => exact machineRationalRowDivideInit_semantics scale row + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalRowDivideStep_semantics scale row k (by omega) + +theorem machineRationalRowDivide_done_iterate + (extra : β„•) (accumulator scale bound : List Bool) : + (machineRationalRowDivideStep)^[extra] + (machineRationalRowDividePack [] accumulator scale bound) = + machineRationalRowDividePack [] accumulator scale bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalRowDivideStep] + +theorem machineRationalRowDivideFinalState_encode + (scale : RawRat) (row : List β„š) : + machineRationalRowDivideFinalState + (machineRationalRowDivideCanonicalInput scale row) = + machineRationalRowDividePack [] + (binaryListCode rationalEntryBinaryCode + (rationalRowDivideValues scale row).reverse) + (rawRatBinaryCode scale) + (machineRationalRowDivideInputBound + (machineRationalRowDivideCanonicalInput scale row)) := by + let word := machineRationalRowDivideCanonicalInput scale row + have hrowLength : row.length ≀ word.length := by + have hcomponent : + (binaryListCode rationalEntryBinaryCode row).length ≀ + word.length := by + simpa only [word, machineRationalRowDivideCanonicalInput, + machinePairSecond_pair] using! + (show (machinePairSecond word).length ≀ word.length from + machinePairSecond_length_le word) + exact (binaryListCode_listLength_le rationalEntryBinaryCode row).trans + hcomponent + have htakeAll : + (rationalRowDivideValues scale row).take row.length = + rationalRowDivideValues scale row := by + have hlength : (rationalRowDivideValues scale row).length = + row.length := by simp [rationalRowDivideValues] + rw [← hlength, List.take_length] + have hsplit : word.length = + (word.length - row.length) + row.length := by omega + change (machineRationalRowDivideStep)^[word.length] + (machineRationalRowDivideInit word) = _ + rw [hsplit, Function.iterate_add_apply, + machineRationalRowDivideIterate_semantics scale row row.length le_rfl] + simp only [machineRationalRowDivideSemanticState, List.drop_length, + binaryListCode, word] + rw [htakeAll] + rw [machineRationalRowDivide_done_iterate] + +@[simp] theorem machineRationalRowDivide_encode + (scale : RawRat) (row : List β„š) : + machineRationalRowDivide + (machineRationalRowDivideCanonicalInput scale row) = + binaryListCode rationalEntryBinaryCode + (rationalRowDivideValues scale row) := by + rw [machineRationalRowDivide, + machineRationalRowDivideFinalState_encode] + simp only [machineRationalRowDivideAccumulator_pack, + machineListReverse_encode, List.reverse_reverse] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalTransposeMulVector.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalTransposeMulVector.lean new file mode 100644 index 0000000000..5fcec2a451 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalTransposeMulVector.lean @@ -0,0 +1,708 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixColumn +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryRange + +/-! +# Polynomial-time rational transpose--vector multiplication + +This module maps the verified one-coordinate routine over all unary column +indices. The output is the canonical vector word for `Aα΅€ v`. A concrete +degree-eight word bounds every intermediate accumulator even on malformed +inputs; on canonical inputs a separate encoding estimate proves that the +clamp never truncates. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- The semantic transpose--vector product used by the exactness theorem. -/ +def rationalTransposeMulVector {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : Fin d β†’ β„š := + fun j ↦ βˆ‘ i, A i j * v i + +/-- Computes coordinate `j` of the transpose-matrix product as a raw dot product of column `j` +with the vector. -/ +def rawRationalTransposeCoordinate {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (j : Fin d) : RawRat := + rawRatListDot RawRat.zero + (rationalColumnOfRows (rationalMatrixRows A) j.1) + (List.ofFn v) + +theorem rawRationalTransposeCoordinate_value {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (j : Fin d) : + (rawRationalTransposeCoordinate A v j).value = + rationalTransposeMulVector A v j := by + rw [rawRationalTransposeCoordinate, + rationalColumnOfRows_matrix] + exact rawRatListDot_ofFn_value (fun i => A i j) v + +/-- Encodes unary dimension followed by the matrix rows and vector for transpose-matrix +multiplication. -/ +def rationalTransposeMulVectorCanonicalWord {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : List Bool := + pair (List.replicate d true) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)) + +theorem rawRationalTransposeCoordinate_width_le_word {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (j : Fin d) : + rawRatWidth (rawRationalTransposeCoordinate A v j) ≀ + (rationalTransposeMulVectorCanonicalWord A v).length := by + let column := rationalColumnOfRows (rationalMatrixRows A) j.1 + let vector := List.ofFn v + have hwidth := rawRatWidth_listDot_le RawRat.zero column vector + simp only [rawRatWidth_zero] at hwidth + have hcost := rawRatListDotCost_le_codeLength column vector + have hcolumn := rationalColumnOfRows_code_length_le j.1 + (rationalMatrixRows A) (rationalMatrixRows_haveColumn A j) + have hcolumn' : + (binaryListCode rationalEntryBinaryCode column).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length := by + simpa only [column] using! hcolumn + have hcombined : + 1 + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows A)).length + + (binaryListCode rationalEntryBinaryCode vector).length ≀ + (rationalTransposeMulVectorCanonicalWord A v).length := by + simp only [rationalTransposeMulVectorCanonicalWord, + rationalSquareMatrixRowsCode, rationalFiniteVectorCode, + vector, pair_length, List.length_replicate] + omega + change rawRatWidth + (rawRatListDot RawRat.zero column vector) ≀ _ + omega + +theorem rationalTransposeMulVector_entry_code_length_le {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (j : Fin d) : + (rationalEntryBinaryCode + (rationalTransposeMulVector A v j)).length ≀ + 64 + 36 * (rationalTransposeMulVectorCanonicalWord A v).length := by + have hcanonical := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (rawRationalTransposeCoordinate A v j) + rw [binaryNormalizeRawRat_eq_value, + rawRationalTransposeCoordinate_value] at hcanonical + exact hcanonical.trans (Nat.add_le_add_left + (Nat.mul_le_mul_left 36 + (rawRationalTransposeCoordinate_width_le_word A v j)) 64) + +/-- Applies the binary-multiplication width construction three times to bound transpose-matrix +vector computations. -/ +def machineRationalTransposeMulVectorInputBound + (word : List Bool) : List Bool := + machineBinaryMulWidth + (machineBinaryMulWidth (machineBinaryMulWidth word)) + +theorem machineRationalTransposeMulVectorInputBound_mem_FP : + machineRationalTransposeMulVectorInputBound ∈ FP := by + have h1 := machineBinaryMulWidth_mem_FP + have h2 := machineCompose_mem_FP h1 machineBinaryMulWidth_mem_FP + have h3 := machineCompose_mem_FP h2 machineBinaryMulWidth_mem_FP + simpa only [machineRationalTransposeMulVectorInputBound] using! h3 + +theorem rationalTransposeMulVector_code_length_le_bound {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + (rationalFiniteVectorCode + (rationalTransposeMulVector A v)).length ≀ + (machineRationalTransposeMulVectorInputBound + (rationalTransposeMulVectorCanonicalWord A v)).length := by + let word := rationalTransposeMulVectorCanonicalWord A v + let B := 64 + 36 * word.length + have hdim : d ≀ word.length := by + have hfirst := machinePairFirst_length_le word + simpa only [word, rationalTransposeMulVectorCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! hfirst + have heach : βˆ€ q ∈ List.ofFn (rationalTransposeMulVector A v), + (rationalEntryBinaryCode q).length ≀ B := by + intro q hq + obtain ⟨j, rfl⟩ := List.mem_ofFn.mp hq + exact rationalTransposeMulVector_entry_code_length_le A v j + have hsum := List.sum_le_card_nsmul + ((List.ofFn (rationalTransposeMulVector A v)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + (2 * B + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum] + simp only [machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, List.length_map, List.length_ofFn, + Nat.nsmul_eq_mul] at hsum ⊒ + dsimp only [B, word] at hsum ⊒ + nlinarith [sq_nonneg + (rationalTransposeMulVectorCanonicalWord A v).length] + +/-! ## Finite-word transducer -/ + +/-- Extracts the unary dimension from a transpose-matrix vector request. -/ +def machineRationalTransposeMulVectorDimension + (word : List Bool) : List Bool := machinePairFirst word + +/-- Extracts the matrix-and-vector payload from a transpose-matrix vector request. -/ +def machineRationalTransposeMulVectorPayload + (word : List Bool) : List Bool := machinePairSecond word + +/-- Builds the complete encoded coordinate-index range from the request's unary dimension. -/ +def machineRationalTransposeMulVectorIndices + (word : List Bool) : List Bool := + machineUnaryRangeCode + (machineRationalTransposeMulVectorDimension word) + +/-- Packs remaining indices, reversed output accumulator, fixed payload, and bound for a +coordinate scan. -/ +def machineRationalTransposeMulVectorPack + (remaining accumulator payload bound : List Bool) : List Bool := + pair remaining (pair accumulator (pair payload bound)) + +/-- Extracts the remaining coordinate indices from the scan state. -/ +def machineRationalTransposeMulVectorRemaining + (state : List Bool) : List Bool := machinePairFirst state + +/-- Extracts the reverse-order coordinate accumulator from the scan state. -/ +def machineRationalTransposeMulVectorAccumulator + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed matrix-and-vector payload from the scan state. -/ +def machineRationalTransposeMulVectorStatePayload + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulator length-bound word from the scan state. -/ +def machineRationalTransposeMulVectorBound + (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Reads the first remaining coordinate index of the scan. -/ +def machineRationalTransposeMulVectorCurrentIndex + (state : List Bool) : List Bool := + machineListHead (machineRationalTransposeMulVectorRemaining state) + +/-- Computes the transpose-matrix vector product entry at the current coordinate index. -/ +def machineRationalTransposeMulVectorCurrentEntry + (state : List Bool) : List Bool := + machineRationalMatrixTransposeMulVectorEntryCode + (pair (machineRationalTransposeMulVectorCurrentIndex state) + (machineRationalTransposeMulVectorStatePayload state)) + +/-- Prepends the current transpose-product entry to the reverse-order accumulator. -/ +def machineRationalTransposeMulVectorCandidate + (state : List Bool) : List Bool := + pair (machineRationalTransposeMulVectorCurrentEntry state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate coordinate accumulator to the stored bound length. -/ +def machineRationalTransposeMulVectorNextAccumulator + (state : List Bool) : List Bool := + (machineRationalTransposeMulVectorCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Drops the processed coordinate index and stores the bounded updated accumulator while +preserving payload and bound. -/ +def machineRationalTransposeMulVectorAdvance + (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineRationalTransposeMulVectorNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Fixes an exhausted coordinate scan and otherwise computes its next transpose-product entry. -/ +def machineRationalTransposeMulVectorStep + (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineRationalTransposeMulVectorAdvance state) + +/-- Initializes the transpose-product scan with all indices, empty accumulator, fixed payload, +and computed bound. -/ +def machineRationalTransposeMulVectorInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineRationalTransposeMulVectorIndices word) [] + (machineRationalTransposeMulVectorPayload word) + (machineRationalTransposeMulVectorInputBound word) + +/-- Packs four copies of the computed bound to bound the complete coordinate-scan state. -/ +def machineRationalTransposeMulVectorWidth (word : List Bool) : List Bool := + let bound := machineRationalTransposeMulVectorInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs the transpose-product scan once per input bit from its initial state. -/ +def machineRationalTransposeMulVectorFinalState + (word : List Bool) : List Bool := + (machineRationalTransposeMulVectorStep)^[word.length] + (machineRationalTransposeMulVectorInit word) + +/-- Extracts the transpose-product coordinates in reverse order from the final scan state. -/ +def machineRationalTransposeMulVectorReversedCode + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineRationalTransposeMulVectorFinalState word) + +/-- Input: `pair dimensionUnary (pair nestedMatrixRowsCode vectorCode)`. -/ +def machineRationalTransposeMulVectorCode + (word : List Bool) : List Bool := + machineListReverse + (machineRationalTransposeMulVectorReversedCode word) + +theorem machineRationalTransposeMulVectorDimension_mem_FP : + machineRationalTransposeMulVectorDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalTransposeMulVectorPayload_mem_FP : + machineRationalTransposeMulVectorPayload ∈ FP := machinePairSecond_mem_FP + +theorem machineRationalTransposeMulVectorIndices_mem_FP : + machineRationalTransposeMulVectorIndices ∈ FP := by + simpa only [machineRationalTransposeMulVectorIndices] using! + machineCompose_mem_FP machineRationalTransposeMulVectorDimension_mem_FP + machineUnaryRangeCode_mem_FP + +theorem machineRationalTransposeMulVectorRemaining_mem_FP : + machineRationalTransposeMulVectorRemaining ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalTransposeMulVectorAccumulator_mem_FP : + machineRationalTransposeMulVectorAccumulator ∈ FP := by + simpa only [machineRationalTransposeMulVectorAccumulator] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalTransposeMulVectorStatePayload_mem_FP : + machineRationalTransposeMulVectorStatePayload ∈ FP := by + simpa only [machineRationalTransposeMulVectorStatePayload] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) machinePairFirst_mem_FP + +theorem machineRationalTransposeMulVectorBound_mem_FP : + machineRationalTransposeMulVectorBound ∈ FP := by + simpa only [machineRationalTransposeMulVectorBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) machinePairSecond_mem_FP + +theorem machineRationalTransposeMulVectorCurrentIndex_mem_FP : + machineRationalTransposeMulVectorCurrentIndex ∈ FP := by + simpa only [machineRationalTransposeMulVectorCurrentIndex] using! + machineCompose_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + machineListHead_mem_FP + +theorem machineRationalTransposeMulVectorCurrentEntry_mem_FP : + machineRationalTransposeMulVectorCurrentEntry ∈ FP := by + have hp := machinePair_mem_FP + machineRationalTransposeMulVectorCurrentIndex_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + simpa only [machineRationalTransposeMulVectorCurrentEntry] using! + machineCompose_mem_FP hp + machineRationalMatrixTransposeMulVectorEntryCode_mem_FP + +theorem machineRationalTransposeMulVectorCandidate_mem_FP : + machineRationalTransposeMulVectorCandidate ∈ FP := + machinePair_mem_FP machineRationalTransposeMulVectorCurrentEntry_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalTransposeMulVectorNextAccumulator_mem_FP : + machineRationalTransposeMulVectorNextAccumulator ∈ FP := by + simpa only [machineRationalTransposeMulVectorNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineRationalTransposeMulVectorCandidate_mem_FP + +theorem machineRationalTransposeMulVectorAdvance_mem_FP : + machineRationalTransposeMulVectorAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalTransposeMulVectorNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineRationalTransposeMulVectorStep_mem_FP : + machineRationalTransposeMulVectorStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineRationalTransposeMulVectorAdvance_mem_FP + +theorem machineRationalTransposeMulVectorInit_mem_FP : + machineRationalTransposeMulVectorInit ∈ FP := by + exact machinePair_mem_FP machineRationalTransposeMulVectorIndices_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineRationalTransposeMulVectorPayload_mem_FP + machineRationalTransposeMulVectorInputBound_mem_FP)) + +theorem machineRationalTransposeMulVectorWidth_mem_FP : + machineRationalTransposeMulVectorWidth ∈ FP := by + exact machinePair_mem_FP machineRationalTransposeMulVectorInputBound_mem_FP + (machinePair_mem_FP machineRationalTransposeMulVectorInputBound_mem_FP + (machinePair_mem_FP machineRationalTransposeMulVectorInputBound_mem_FP + machineRationalTransposeMulVectorInputBound_mem_FP)) + +@[simp] theorem machineRationalTransposeMulVectorRemaining_pack (a b c d) : + machineRationalTransposeMulVectorRemaining + (machineRationalTransposeMulVectorPack a b c d) = a := by + simp [machineRationalTransposeMulVectorRemaining, + machineRationalTransposeMulVectorPack] + +@[simp] theorem machineRationalTransposeMulVectorAccumulator_pack (a b c d) : + machineRationalTransposeMulVectorAccumulator + (machineRationalTransposeMulVectorPack a b c d) = b := by + simp [machineRationalTransposeMulVectorAccumulator, + machineRationalTransposeMulVectorPack] + +@[simp] theorem machineRationalTransposeMulVectorStatePayload_pack (a b c d) : + machineRationalTransposeMulVectorStatePayload + (machineRationalTransposeMulVectorPack a b c d) = c := by + simp [machineRationalTransposeMulVectorStatePayload, + machineRationalTransposeMulVectorPack] + +@[simp] theorem machineRationalTransposeMulVectorBound_pack (a b c d) : + machineRationalTransposeMulVectorBound + (machineRationalTransposeMulVectorPack a b c d) = d := by + simp [machineRationalTransposeMulVectorBound, + machineRationalTransposeMulVectorPack] + +/-- Requires exact coordinate-state packing, all data fields bounded by the computed input +bound, and the prescribed bound word. -/ +def MachineRationalTransposeMulVectorStateBound + (word state : List Bool) : Prop := + let bound := machineRationalTransposeMulVectorInputBound word + state = machineRationalTransposeMulVectorPack + (machineRationalTransposeMulVectorRemaining state) + (machineRationalTransposeMulVectorAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) ∧ + (machineRationalTransposeMulVectorRemaining state).length ≀ bound.length ∧ + (machineRationalTransposeMulVectorAccumulator state).length ≀ bound.length ∧ + (machineRationalTransposeMulVectorStatePayload state).length ≀ bound.length ∧ + machineRationalTransposeMulVectorBound state = bound + +theorem machineRationalTransposeMulVector_word_le_bound (word : List Bool) : + word.length ≀ + (machineRationalTransposeMulVectorInputBound word).length := by + simp only [machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith [sq_nonneg word.length] + +theorem machineRationalTransposeMulVector_indices_le_bound + (word : List Bool) : + (machineRationalTransposeMulVectorIndices word).length ≀ + (machineRationalTransposeMulVectorInputBound word).length := by + have hrange := machineUnaryRangeCode_length_le_inputBound + (machineRationalTransposeMulVectorDimension word) + have hdimension := machinePairFirst_length_le word + have hdimension' : + (machineRationalTransposeMulVectorDimension word).length ≀ + word.length := by + simpa only [machineRationalTransposeMulVectorDimension] using! hdimension + have hmono := machineListUpdateInputBound_length_mono hdimension' + apply hrange.trans (hmono.trans ?_) + simp only [machineListUpdateInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith [sq_nonneg word.length] + +theorem machineRationalTransposeMulVectorInit_bound (word : List Bool) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalTransposeMulVectorInit word) := by + simp only [MachineRationalTransposeMulVectorStateBound, + machineRationalTransposeMulVectorInit, + machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, + machineRationalTransposeMulVector_indices_le_bound word, + by simp, ?_, trivial⟩ + exact (machinePairSecond_length_le word).trans + (machineRationalTransposeMulVector_word_le_bound word) + +theorem machineRationalTransposeMulVectorStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalTransposeMulVectorStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineRationalTransposeMulVectorStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· rw [machineRationalTransposeMulVectorStep] + cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineRationalTransposeMulVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineRationalTransposeMulVectorNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalTransposeMulVectorIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineRationalTransposeMulVectorStep)^[k] + (machineRationalTransposeMulVectorInit word)) := by + intro k + induction k with + | zero => exact machineRationalTransposeMulVectorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalTransposeMulVectorStep_bound ih + +theorem machineRationalTransposeMulVectorIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalTransposeMulVectorStep)^[iterations] + (machineRationalTransposeMulVectorInit word)).length ≀ + (machineRationalTransposeMulVectorWidth word).length := by + rcases machineRationalTransposeMulVectorIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineRationalTransposeMulVectorWidth, pair_length] + omega + +theorem machineRationalTransposeMulVectorFinalState_mem_FP : + machineRationalTransposeMulVectorFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalTransposeMulVectorStep_mem_FP + machineRationalTransposeMulVectorInit_mem_FP id_mem_FP + machineRationalTransposeMulVectorWidth_mem_FP + machineRationalTransposeMulVectorIterate_length_le_width + +theorem machineRationalTransposeMulVectorReversedCode_mem_FP : + machineRationalTransposeMulVectorReversedCode ∈ FP := by + simpa only [machineRationalTransposeMulVectorReversedCode] using! + machineCompose_mem_FP machineRationalTransposeMulVectorFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalTransposeMulVectorCode_mem_FP : + machineRationalTransposeMulVectorCode ∈ FP := by + simpa only [machineRationalTransposeMulVectorCode] using! + machineCompose_mem_FP + machineRationalTransposeMulVectorReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact iteration semantics -/ + +/-- Lists the first `k` coordinates of the rational transpose-matrix vector product. -/ +def rationalTransposePrefix {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) : List β„š := + ((List.finRange d).take k).map + fun j ↦ rationalTransposeMulVector A v j + +/-- Encodes the remaining coordinate indices and reversed transpose-product prefix after `k` +coordinates, retaining payload and bound. -/ +def machineRationalTransposeMulVectorSemanticState {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) : List Bool := + let word := rationalTransposeMulVectorCanonicalWord A v + machineRationalTransposeMulVectorPack + (binaryListCode finUnaryCode ((List.finRange d).drop k)) + (binaryListCode rationalEntryBinaryCode + (rationalTransposePrefix A v k).reverse) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)) + (machineRationalTransposeMulVectorInputBound word) + +theorem machineRationalTransposeMulVectorInit_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalTransposeMulVectorInit + (rationalTransposeMulVectorCanonicalWord A v) = + machineRationalTransposeMulVectorSemanticState A v 0 := by + simp [machineRationalTransposeMulVectorInit, + machineRationalTransposeMulVectorSemanticState, + machineRationalTransposeMulVectorIndices, + machineRationalTransposeMulVectorDimension, + machineRationalTransposeMulVectorPayload, + rationalTransposeMulVectorCanonicalWord, + machineUnaryRangeCode_encode, finRangeUnaryCode, + rationalTransposePrefix, binaryListCode] + +theorem rationalTransposePrefix_succ {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) (hk : k < d) : + rationalTransposePrefix A v (k + 1) = + rationalTransposePrefix A v k ++ + [rationalTransposeMulVector A v ⟨k, hk⟩] := by + simp only [rationalTransposePrefix, List.map_take] + have hkm : k < (List.finRange d).length := by simpa + simpa [List.getElem_finRange] using! + congrArg (List.map fun j ↦ rationalTransposeMulVector A v j) + (List.take_concat_get hkm).symm + +theorem machineRationalTransposeMulVectorStep_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) + (k : β„•) (hk : k < d) : + machineRationalTransposeMulVectorStep + (machineRationalTransposeMulVectorSemanticState A v k) = + machineRationalTransposeMulVectorSemanticState A v (k + 1) := by + let word := rationalTransposeMulVectorCanonicalWord A v + let j : Fin d := ⟨k, hk⟩ + have hdrop : + (List.finRange d).drop k = + j :: (List.finRange d).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.finRange d).length by simpa) using 1 + simp [j, List.getElem_finRange] + have hprefix := rationalTransposePrefix_succ A v k hk + have hreverse : + (rationalTransposePrefix A v (k + 1)).reverse = + rationalTransposeMulVector A v j :: + (rationalTransposePrefix A v k).reverse := by + rw [hprefix, List.reverse_append] + simp [j] + have hcand : + (binaryListCode rationalEntryBinaryCode + (rationalTransposePrefix A v (k + 1)).reverse).length ≀ + (machineRationalTransposeMulVectorInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode + (List.ofFn (rationalTransposeMulVector A v)) (k + 1) + have hprefixEq : rationalTransposePrefix A v (k + 1) = + (List.ofFn (rationalTransposeMulVector A v)).take (k + 1) := by + apply List.ext_getElem + Β· simp [rationalTransposePrefix] + Β· intro i hiLeft hiRight + simp [rationalTransposePrefix, List.getElem_finRange] + rw [hprefixEq] + exact hprefixBound.trans + (rationalTransposeMulVector_code_length_le_bound A v) + have hcandPair : + (pair (rationalEntryBinaryCode + (rationalTransposeMulVector A v j)) + (binaryListCode rationalEntryBinaryCode + (rationalTransposePrefix A v k).reverse)).length ≀ + (machineRationalTransposeMulVectorInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode finUnaryCode ((List.finRange d).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil finUnaryCode j + ((List.finRange d).drop (k + 1)) + rw [machineRationalTransposeMulVectorStep] + simp only [machineRationalTransposeMulVectorSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalTransposeMulVectorAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalTransposeMulVectorNextAccumulator, + machineRationalTransposeMulVectorCandidate, + machineRationalTransposeMulVectorCurrentEntry, + machineRationalTransposeMulVectorCurrentIndex] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineRationalMatrixTransposeMulVectorEntryCode + (pair (finUnaryCode j) + (pair (rationalSquareMatrixRowsCode A) + (rationalFiniteVectorCode v)))) + (binaryListCode rationalEntryBinaryCode + (rationalTransposePrefix A v k).reverse)).take + (machineRationalTransposeMulVectorInputBound word).length) _ _ = _ + rw [show finUnaryCode j = List.replicate j.1 true by rfl, + machineRationalMatrixTransposeMulVectorEntryCode_encode] + change machineRationalTransposeMulVectorPack _ + ((pair (rationalEntryBinaryCode + (rationalTransposeMulVector A v j)) + (binaryListCode rationalEntryBinaryCode + (rationalTransposePrefix A v k).reverse)).take + (machineRationalTransposeMulVectorInputBound word).length) _ _ = _ + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineRationalTransposeMulVectorIterate_semantics {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : βˆ€ k ≀ d, + (machineRationalTransposeMulVectorStep)^[k] + (machineRationalTransposeMulVectorInit + (rationalTransposeMulVectorCanonicalWord A v)) = + machineRationalTransposeMulVectorSemanticState A v k := by + intro k hk + induction k with + | zero => exact machineRationalTransposeMulVectorInit_semantics A v + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalTransposeMulVectorStep_semantics A v k (by omega) + +theorem machineRationalTransposeMulVector_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineRationalTransposeMulVectorStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalTransposeMulVectorStep] + +theorem rationalTransposePrefix_all {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + rationalTransposePrefix A v d = + List.ofFn (rationalTransposeMulVector A v) := by + apply List.ext_getElem + Β· simp [rationalTransposePrefix] + Β· intro i hiLeft hiRight + simp [rationalTransposePrefix, List.getElem_finRange] + +theorem machineRationalTransposeMulVectorReversedCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalTransposeMulVectorReversedCode + (rationalTransposeMulVectorCanonicalWord A v) = + binaryListCode rationalEntryBinaryCode + (List.ofFn (rationalTransposeMulVector A v)).reverse := by + let word := rationalTransposeMulVectorCanonicalWord A v + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalTransposeMulVectorCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hsplit : word.length = (word.length - d) + d := by omega + change machineRationalTransposeMulVectorReversedCode word = _ + rw [machineRationalTransposeMulVectorReversedCode, + machineRationalTransposeMulVectorFinalState, hsplit, + Function.iterate_add_apply, + machineRationalTransposeMulVectorIterate_semantics A v d le_rfl] + simp only [machineRationalTransposeMulVectorSemanticState] + rw [show binaryListCode finUnaryCode ((List.finRange d).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineRationalTransposeMulVector_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [rationalTransposePrefix_all] + +@[simp] theorem machineRationalTransposeMulVectorCode_encode {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (v : Fin d β†’ β„š) : + machineRationalTransposeMulVectorCode + (rationalTransposeMulVectorCanonicalWord A v) = + rationalFiniteVectorCode (rationalTransposeMulVector A v) := by + rw [machineRationalTransposeMulVectorCode, + machineRationalTransposeMulVectorReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +theorem rationalTransposeMulVector_eq_pulledBack {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + rationalTransposeMulVector E.basis a = + rationalPulledBackNormal E a := by + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalUnary.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalUnary.lean new file mode 100644 index 0000000000..37e301a3db --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalUnary.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalArithmetic +public import LeanPool.BeyondBethe.BeyondBethe.RawRationalBitBounds + +/-! +# Polynomial-time rational negation, inversion, and division + +The reciprocal machine handles zero explicitly and otherwise swaps the +positive denominator with the absolute numerator while preserving the +numerator sign. Division is multiplication by this verified reciprocal. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Negates a raw rational's signed numerator while preserving its denominator. -/ +def machineRawRatNegCode (word : List Bool) : List Bool := + pair (machineIntegerNegCode (machinePairFirst word)) + (machinePairSecond word) + +/-- Encodes the reciprocal of a nonzero raw rational using its old denominator with the original +numerator sign as the new numerator, and the old numerator magnitude as the new denominator. -/ +def machineRawRatInvNonzeroCode (word : List Bool) : List Bool := + pair + (machineCanonicalIntegerFromSignedAbs + (pair (machineHeadBit (machinePairFirst word)) + (machinePairSecond word))) + (machineIntegerNatAbsBits (machinePairFirst word)) + +/-- Returns canonical raw zero for a zero numerator and the signed reciprocal code otherwise. -/ +def machineRawRatInvCode (word : List Bool) : List Bool := + machineIfEmpty (machineIntegerNatAbsBits (machinePairFirst word)) + (pair [false] [true]) (machineRawRatInvNonzeroCode word) + +/-- Multiplies the left raw rational by the totalized reciprocal of the right. -/ +def machineRawRatDivCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machinePairFirst word) + (machineRawRatInvCode (machinePairSecond word))) + +/-- Normalizes a raw negation into the rational binary output encoding. -/ +def machineRationalNegCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatNegCode word) + +/-- Normalizes a totalized raw reciprocal into the rational binary output encoding. -/ +def machineRationalInvCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatInvCode word) + +/-- Normalizes a raw quotient into the rational binary output encoding. -/ +def machineRationalDivCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineRawRatDivCode word) + +theorem machineRawRatNegCode_mem_FP : machineRawRatNegCode ∈ Complexity.FP := by + have hnum := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNegCode_mem_FP + exact machinePair_mem_FP hnum machinePairSecond_mem_FP + +theorem machineRawRatInvNonzeroCode_mem_FP : + machineRawRatInvNonzeroCode ∈ Complexity.FP := by + have hsign := machineCompose_mem_FP machinePairFirst_mem_FP + machineHeadBit_mem_FP + have hsigned := machinePair_mem_FP hsign machinePairSecond_mem_FP + have hnum := machineCompose_mem_FP hsigned + machineCanonicalIntegerFromSignedAbs_mem_FP + have habs := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + exact machinePair_mem_FP hnum habs + +theorem machineRawRatInvCode_mem_FP : machineRawRatInvCode ∈ Complexity.FP := by + have habs := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + exact machineIfEmpty_mem_FP habs + (machineConst_mem_FP (pair [false] [true])) + machineRawRatInvNonzeroCode_mem_FP + +theorem machineRawRatDivCode_mem_FP : machineRawRatDivCode ∈ Complexity.FP := by + have hinv := machineCompose_mem_FP machinePairSecond_mem_FP + machineRawRatInvCode_mem_FP + have hpair := machinePair_mem_FP machinePairFirst_mem_FP hinv + simpa only [machineRawRatDivCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineRationalNegCode_mem_FP : machineRationalNegCode ∈ Complexity.FP := by + simpa only [machineRationalNegCode] using! + machineCompose_mem_FP machineRawRatNegCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineRationalInvCode_mem_FP : machineRationalInvCode ∈ Complexity.FP := by + simpa only [machineRationalInvCode] using! + machineCompose_mem_FP machineRawRatInvCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineRationalDivCode_mem_FP : machineRationalDivCode ∈ Complexity.FP := by + simpa only [machineRationalDivCode] using! + machineCompose_mem_FP machineRawRatDivCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +theorem machineRawRatNegCode_encode (q : RawRat) : + machineRawRatNegCode (rawRatBinaryCode q) = rawRatBinaryCode q.neg := by + simp [machineRawRatNegCode, rawRatBinaryCode, + machineIntegerNegCode_encode, RawRat.neg] + +theorem machineRawRatInvNonzeroCode_encode (q : RawRat) (hq : q.num β‰  0) : + machineRawRatInvNonzeroCode (rawRatBinaryCode q) = + rawRatBinaryCode q.inv := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat n => + cases n with + | zero => contradiction + | succ n => + simp only [machineRawRatInvNonzeroCode, rawRatBinaryCode, + machinePairFirst_pair, machinePairSecond_pair, + machineHeadBit_cons, machineIntegerNatAbsBits_encode, + RawRat.inv] + change pair + (machineCanonicalIntegerFromSignedAbs (pair [false] den.bits)) + (n + 1).bits = pair (integerBinaryCode (den : β„€)) (n + 1).bits + rw [machineCanonicalIntegerFromSignedAbs_pair] + rfl + | negSucc n => + simp only [machineRawRatInvNonzeroCode, rawRatBinaryCode, + machinePairFirst_pair, machinePairSecond_pair, + machineHeadBit_cons, machineIntegerNatAbsBits_encode, + RawRat.inv] + change pair + (machineCanonicalIntegerFromSignedAbs (pair [true] den.bits)) + (n + 1).bits = pair (integerBinaryCode (-(den : β„€))) (n + 1).bits + rw [machineCanonicalIntegerFromSignedAbs_pair] + simp [signedMagnitudeValue] + +theorem machineRawRatInvCode_encode (q : RawRat) : + machineRawRatInvCode (rawRatBinaryCode q) = rawRatBinaryCode q.inv := by + by_cases hq : q.num = 0 + Β· have habs : q.num.natAbs.bits = [] := by simp [hq] + rw [machineRawRatInvCode] + simp only [rawRatBinaryCode, machinePairFirst_pair, + machineIntegerNatAbsBits_encode, habs, machineIfEmpty_nil] + simp [RawRat.inv, RawRat.zero, hq, rawRatBinaryCode, + integerBinaryCode] + Β· have habs : q.num.natAbs.bits β‰  [] := + natBits_ne_nil_of_ne_zero (Int.natAbs_ne_zero.mpr hq) + rw [machineRawRatInvCode] + simp only [rawRatBinaryCode, machinePairFirst_pair, + machineIntegerNatAbsBits_encode] + rw [machineIfEmpty_of_ne_nil q.num.natAbs.bits + (pair [false] [true]) + (machineRawRatInvNonzeroCode + (pair (integerBinaryCode q.num) q.den.bits)) habs] + simpa only [rawRatBinaryCode] using! + machineRawRatInvNonzeroCode_encode q hq + +theorem machineRawRatDivCode_encode (q r : RawRat) : + machineRawRatDivCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rawRatBinaryCode (q.div r) := by + rw [machineRawRatDivCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineRawRatInvCode_encode, machineRawRatMulCode_encode, RawRat.div] + +theorem machineRationalNegCode_encode (q : RawRat) : + machineRationalNegCode (rawRatBinaryCode q) = + rationalBinaryCode (binaryNormalizeRawRat q.neg) := by + rw [machineRationalNegCode, machineRawRatNegCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +theorem machineRationalInvCode_encode (q : RawRat) : + machineRationalInvCode (rawRatBinaryCode q) = + rationalBinaryCode (binaryNormalizeRawRat q.inv) := by + rw [machineRationalInvCode, machineRawRatInvCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +theorem machineRationalDivCode_encode (q r : RawRat) : + machineRationalDivCode + (pair (rawRatBinaryCode q) (rawRatBinaryCode r)) = + rationalBinaryCode (binaryNormalizeRawRat (q.div r)) := by + rw [machineRationalDivCode, machineRawRatDivCode_encode, + machineNormalizeRawRatBinaryCode_encode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorDot.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorDot.lean new file mode 100644 index 0000000000..a3d12660d6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorDot.lean @@ -0,0 +1,713 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding + +/-! +# Polynomial-time dot products of rational vectors + +The central ellipsoid update repeatedly forms rational dot products. This +module implements the basic operation directly on two right-nested lists of +canonical rational entries. The accumulator is an unreduced rational. A +quadratic clamp makes the transducer polynomially bounded on every bitstring; +the semantic invariant proves that the clamp is inactive on canonical vector +inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Packs the unprocessed left and right vectors, raw dot-product accumulator, and bound. -/ +def machineRationalVectorDotPack + (left right acc bound : List Bool) : List Bool := + pair left (pair right (pair acc bound)) + +/-- Extracts the unprocessed left vector from a dot-product state. -/ +def machineRationalVectorDotLeft (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed right vector from a dot-product state. -/ +def machineRationalVectorDotRight (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the raw dot-product accumulator from the scan state. -/ +def machineRationalVectorDotAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulator length-bound word from a dot-product state. -/ +def machineRationalVectorDotBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Reads the next encoded entry of the left vector in a dot-product scan. -/ +def machineRationalVectorDotLeftEntry (state : List Bool) : List Bool := + machineListHead (machineRationalVectorDotLeft state) + +/-- Reads the next encoded entry of the right vector in a dot-product scan. -/ +def machineRationalVectorDotRightEntry (state : List Bool) : List Bool := + machineListHead (machineRationalVectorDotRight state) + +/-- Multiplies the two current vector entries in raw rational arithmetic. -/ +def machineRationalVectorDotProduct (state : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineRationalVectorDotLeftEntry state) + (machineRationalVectorDotRightEntry state)) + +/-- Adds the current entry product to the raw dot-product accumulator. -/ +def machineRationalVectorDotCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineRationalVectorDotAcc state) + (machineRationalVectorDotProduct state)) + +/-- Truncates the updated dot-product accumulator to the stored bound length. -/ +def machineRationalVectorDotNextAcc (state : List Bool) : List Bool := + (machineRationalVectorDotCandidate state).take + (machineRationalVectorDotBound state).length + +/-- Consumes one entry from each vector and stores the bounded updated dot-product accumulator. -/ +def machineRationalVectorDotAdvance (state : List Bool) : List Bool := + machineRationalVectorDotPack + (machineListTail (machineRationalVectorDotLeft state)) + (machineListTail (machineRationalVectorDotRight state)) + (machineRationalVectorDotNextAcc state) + (machineRationalVectorDotBound state) + +/-- Stop as soon as either input list is exhausted. -/ +def machineRationalVectorDotStep (state : List Bool) : List Bool := + machineIfEmpty (machineRationalVectorDotLeft state) state + (machineIfEmpty (machineRationalVectorDotRight state) state + (machineRationalVectorDotAdvance state)) + +/-- Applies the binary-multiplication width construction to bound the dot-product accumulator. -/ +def machineRationalVectorDotInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Initializes the dot-product scan with both input vectors, zero raw accumulator, and computed +bound. -/ +def machineRationalVectorDotInit (word : List Bool) : List Bool := + machineRationalVectorDotPack (machinePairFirst word) + (machinePairSecond word) (rawRatBinaryCode RawRat.zero) + (machineRationalVectorDotInputBound word) + +/-- Packs two input words and two bound words to bound the dot-product state. -/ +def machineRationalVectorDotWidth (word : List Bool) : List Bool := + let bound := machineRationalVectorDotInputBound word + machineRationalVectorDotPack word word bound bound + +/-- Runs the dot-product scan once per input bit from its initial state. -/ +def machineRationalVectorDotFinalState (word : List Bool) : List Bool := + (machineRationalVectorDotStep)^[word.length] + (machineRationalVectorDotInit word) + +/-- Unreduced rational code of the dot product. -/ +def machineRationalVectorDotRawCode (word : List Bool) : List Bool := + machineRationalVectorDotAcc + (machineRationalVectorDotFinalState word) + +/-- Canonical rational-entry code of the dot product. -/ +def machineRationalVectorDotEntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRationalVectorDotRawCode word) + +theorem machineRationalVectorDotLeft_mem_FP : + machineRationalVectorDotLeft ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalVectorDotRight_mem_FP : + machineRationalVectorDotRight ∈ FP := by + simpa only [machineRationalVectorDotRight] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalVectorDotAcc_mem_FP : + machineRationalVectorDotAcc ∈ FP := by + simpa only [machineRationalVectorDotAcc] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineRationalVectorDotBound_mem_FP : + machineRationalVectorDotBound ∈ FP := by + simpa only [machineRationalVectorDotBound] using! + machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineRationalVectorDotLeftEntry_mem_FP : + machineRationalVectorDotLeftEntry ∈ FP := by + simpa only [machineRationalVectorDotLeftEntry] using! + machineCompose_mem_FP machineRationalVectorDotLeft_mem_FP + machineListHead_mem_FP + +theorem machineRationalVectorDotRightEntry_mem_FP : + machineRationalVectorDotRightEntry ∈ FP := by + simpa only [machineRationalVectorDotRightEntry] using! + machineCompose_mem_FP machineRationalVectorDotRight_mem_FP + machineListHead_mem_FP + +theorem machineRationalVectorDotProduct_mem_FP : + machineRationalVectorDotProduct ∈ FP := by + have hp := machinePair_mem_FP machineRationalVectorDotLeftEntry_mem_FP + machineRationalVectorDotRightEntry_mem_FP + simpa only [machineRationalVectorDotProduct] using! + machineCompose_mem_FP hp machineRawRatMulCode_mem_FP + +theorem machineRationalVectorDotCandidate_mem_FP : + machineRationalVectorDotCandidate ∈ FP := by + have hp := machinePair_mem_FP machineRationalVectorDotAcc_mem_FP + machineRationalVectorDotProduct_mem_FP + simpa only [machineRationalVectorDotCandidate] using! + machineCompose_mem_FP hp machineRawRatAddCode_mem_FP + +theorem machineRationalVectorDotNextAcc_mem_FP : + machineRationalVectorDotNextAcc ∈ FP := by + simpa only [machineRationalVectorDotNextAcc] using! + machineTake_mem_FP machineRationalVectorDotBound_mem_FP + machineRationalVectorDotCandidate_mem_FP + +theorem machineRationalVectorDotAdvance_mem_FP : + machineRationalVectorDotAdvance ∈ FP := by + have hl := machineCompose_mem_FP machineRationalVectorDotLeft_mem_FP + machineListTail_mem_FP + have hr := machineCompose_mem_FP machineRationalVectorDotRight_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP hl + (machinePair_mem_FP hr + (machinePair_mem_FP machineRationalVectorDotNextAcc_mem_FP + machineRationalVectorDotBound_mem_FP)) + +theorem machineRationalVectorDotStep_mem_FP : + machineRationalVectorDotStep ∈ FP := by + have hinner := machineIfEmpty_mem_FP + machineRationalVectorDotRight_mem_FP id_mem_FP + machineRationalVectorDotAdvance_mem_FP + exact machineIfEmpty_mem_FP machineRationalVectorDotLeft_mem_FP + id_mem_FP hinner + +theorem machineRationalVectorDotInputBound_mem_FP : + machineRationalVectorDotInputBound ∈ FP := + machineBinaryMulWidth_mem_FP + +theorem machineRationalVectorDotInit_mem_FP : + machineRationalVectorDotInit ∈ FP := by + exact machinePair_mem_FP machinePairFirst_mem_FP + (machinePair_mem_FP machinePairSecond_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineRationalVectorDotInputBound_mem_FP)) + +theorem machineRationalVectorDotWidth_mem_FP : + machineRationalVectorDotWidth ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRationalVectorDotInputBound_mem_FP + machineRationalVectorDotInputBound_mem_FP)) + +@[simp] theorem machineRationalVectorDotLeft_pack (left right acc bound) : + machineRationalVectorDotLeft + (machineRationalVectorDotPack left right acc bound) = left := by + simp [machineRationalVectorDotLeft, machineRationalVectorDotPack] + +@[simp] theorem machineRationalVectorDotRight_pack (left right acc bound) : + machineRationalVectorDotRight + (machineRationalVectorDotPack left right acc bound) = right := by + simp [machineRationalVectorDotRight, machineRationalVectorDotPack] + +@[simp] theorem machineRationalVectorDotAcc_pack (left right acc bound) : + machineRationalVectorDotAcc + (machineRationalVectorDotPack left right acc bound) = acc := by + simp [machineRationalVectorDotAcc, machineRationalVectorDotPack] + +@[simp] theorem machineRationalVectorDotBound_pack (left right acc bound) : + machineRationalVectorDotBound + (machineRationalVectorDotPack left right acc bound) = bound := by + simp [machineRationalVectorDotBound, machineRationalVectorDotPack] + +/-- Requires exact dot-product state packing, input-bounded remaining vectors, a bounded +accumulator, and the prescribed bound word. -/ +def MachineRationalVectorDotStateBound + (word state : List Bool) : Prop := + state = machineRationalVectorDotPack + (machineRationalVectorDotLeft state) + (machineRationalVectorDotRight state) + (machineRationalVectorDotAcc state) + (machineRationalVectorDotBound state) ∧ + (machineRationalVectorDotLeft state).length ≀ word.length ∧ + (machineRationalVectorDotRight state).length ≀ word.length ∧ + (machineRationalVectorDotAcc state).length ≀ + (machineRationalVectorDotInputBound word).length ∧ + machineRationalVectorDotBound state = + machineRationalVectorDotInputBound word + +theorem machineRationalVectorDotInit_bound (word : List Bool) : + MachineRationalVectorDotStateBound word + (machineRationalVectorDotInit word) := by + simp only [MachineRationalVectorDotStateBound, + machineRationalVectorDotInit, machineRationalVectorDotLeft_pack, + machineRationalVectorDotRight_pack, machineRationalVectorDotAcc_pack, + machineRationalVectorDotBound_pack] + refine ⟨trivial, machinePairFirst_length_le word, + machinePairSecond_length_le word, ?_, trivial⟩ + simp [machineRationalVectorDotInputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.zero, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineRationalVectorDotStep_bound {word state : List Bool} + (hs : MachineRationalVectorDotStateBound word state) : + MachineRationalVectorDotStateBound word + (machineRationalVectorDotStep state) := by + rcases hs with ⟨hdecomp, hl, hr, hacc, hbound⟩ + by_cases hleft : machineRationalVectorDotLeft state = [] + Β· rw [machineRationalVectorDotStep, hleft, machineIfEmpty_nil] + exact ⟨hdecomp, hl, hr, hacc, hbound⟩ + Β· rw [machineRationalVectorDotStep] + cases hleftCode : machineRationalVectorDotLeft state with + | nil => exact False.elim (hleft hleftCode) + | cons bit tail => + rw [machineIfEmpty_cons] + by_cases hright : machineRationalVectorDotRight state = [] + Β· rw [hright, machineIfEmpty_nil] + exact ⟨hdecomp, hl, hr, hacc, hbound⟩ + Β· cases hrightCode : machineRationalVectorDotRight state with + | nil => exact False.elim (hright hrightCode) + | cons bit' tail' => + rw [machineIfEmpty_cons, + machineRationalVectorDotAdvance] + simp only [MachineRationalVectorDotStateBound, + machineRationalVectorDotLeft_pack, + machineRationalVectorDotRight_pack, + machineRationalVectorDotAcc_pack, + machineRationalVectorDotBound_pack] + refine ⟨trivial, ?_, ?_, ?_, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalVectorDotLeft state)).trans hl + Β· exact (machineListTail_length_le + (machineRationalVectorDotRight state)).trans hr + Β· rw [machineRationalVectorDotNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineRationalVectorDotIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalVectorDotStateBound word + ((machineRationalVectorDotStep)^[k] + (machineRationalVectorDotInit word)) := by + intro k + induction k with + | zero => exact machineRationalVectorDotInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalVectorDotStep_bound ih + +theorem machineRationalVectorDotIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalVectorDotStep)^[iterations] + (machineRationalVectorDotInit word)).length ≀ + (machineRationalVectorDotWidth word).length := by + rcases machineRationalVectorDotIterate_bound word iterations with + ⟨hdecomp, hl, hr, hacc, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalVectorDotPack, + machineRationalVectorDotWidth, pair_length] + omega + +theorem machineRationalVectorDotFinalState_mem_FP : + machineRationalVectorDotFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalVectorDotStep_mem_FP + machineRationalVectorDotInit_mem_FP id_mem_FP + machineRationalVectorDotWidth_mem_FP + machineRationalVectorDotIterate_length_le_width + +theorem machineRationalVectorDotRawCode_mem_FP : + machineRationalVectorDotRawCode ∈ FP := by + simpa only [machineRationalVectorDotRawCode] using! + machineCompose_mem_FP machineRationalVectorDotFinalState_mem_FP + machineRationalVectorDotAcc_mem_FP + +theorem machineRationalVectorDotEntryCode_mem_FP : + machineRationalVectorDotEntryCode ∈ FP := by + simpa only [machineRationalVectorDotEntryCode] using! + machineCompose_mem_FP machineRationalVectorDotRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +/-! ## Exact semantics -/ + +/-- Sums both input widths plus two per paired entry, stopping when either list is exhausted. -/ +def rawRatListDotCost : List β„š β†’ List β„š β†’ β„• + | q :: qs, r :: rs => + rawRatWidth (rawRatOfRat q) + rawRatWidth (rawRatOfRat r) + 2 + + rawRatListDotCost qs rs + | _, _ => 0 + +/-- Accumulates raw products of paired rational entries from left to right, stopping when either +list is exhausted. -/ +def rawRatListDot : RawRat β†’ List β„š β†’ List β„š β†’ RawRat + | acc, q :: qs, r :: rs => + rawRatListDot + (acc.add ((rawRatOfRat q).mul (rawRatOfRat r))) qs rs + | acc, _, _ => acc + +theorem rawRatWidth_listDot_le (acc : RawRat) : βˆ€ xs ys, + rawRatWidth (rawRatListDot acc xs ys) ≀ + rawRatWidth acc + rawRatListDotCost xs ys := by + intro xs + induction xs generalizing acc with + | nil => intro ys; simp [rawRatListDot, rawRatListDotCost] + | cons q qs ih => + intro ys + cases ys with + | nil => simp [rawRatListDot, rawRatListDotCost] + | cons r rs => + rw [rawRatListDot, rawRatListDotCost] + have hmul := rawRatWidth_mul_le + (rawRatOfRat q) (rawRatOfRat r) + have hadd := rawRatWidth_add_le acc + ((rawRatOfRat q).mul (rawRatOfRat r)) + have htail := ih + (acc.add ((rawRatOfRat q).mul (rawRatOfRat r))) rs + omega + +theorem rawRatListDotCost_le_codeLength : βˆ€ xs ys : List β„š, + rawRatListDotCost xs ys ≀ + (binaryListCode rationalEntryBinaryCode xs).length + + (binaryListCode rationalEntryBinaryCode ys).length := by + intro xs + induction xs with + | nil => intro ys; simp [rawRatListDotCost] + | cons q qs ih => + intro ys + cases ys with + | nil => simp [rawRatListDotCost] + | cons r rs => + rw [rawRatListDotCost, binaryListCode, binaryListCode, + pair_length, pair_length] + have hq : rawRatWidth (rawRatOfRat q) ≀ + (rationalEntryBinaryCode q).length := by + rw [← rawRatBinaryCode_rawRatOfRat] + exact rawRatWidth_le_binaryCode_length _ + have hr : rawRatWidth (rawRatOfRat r) ≀ + (rationalEntryBinaryCode r).length := by + rw [← rawRatBinaryCode_rawRatOfRat] + exact rawRatWidth_le_binaryCode_length _ + have htail := ih rs + omega + +structure RationalVectorDotSemState where + /-- The unprocessed left entries of the semantic dot-product scan. -/ + left : List β„š + /-- The unprocessed right entries of the semantic dot-product scan. -/ + right : List β„š + /-- The raw rational accumulator of the semantic dot-product scan. -/ + acc : RawRat + +/-- Adds one paired-entry product and drops both entries, fixing the semantic state when either +list is empty. -/ +def rationalVectorDotSemStep + (s : RationalVectorDotSemState) : RationalVectorDotSemState := + match s.left, s.right with + | q :: qs, r :: rs => + ⟨qs, rs, s.acc.add ((rawRatOfRat q).mul (rawRatOfRat r))⟩ + | _, _ => s + +/-- Encodes the semantic remaining vectors and raw dot-product accumulator with the supplied +bound. -/ +def rationalVectorDotSemCode (bound : List Bool) + (s : RationalVectorDotSemState) : List Bool := + machineRationalVectorDotPack + (binaryListCode rationalEntryBinaryCode s.left) + (binaryListCode rationalEntryBinaryCode s.right) + (rawRatBinaryCode s.acc) bound + +/-- Bounds the raw accumulator width plus the remaining paired-entry cost by the specified +budget. -/ +def RationalVectorDotSemInvariant (budget : β„•) + (s : RationalVectorDotSemState) : Prop := + rawRatWidth s.acc + rawRatListDotCost s.left s.right ≀ budget + +theorem rationalVectorDotSemStep_invariant {budget : β„•} + {s : RationalVectorDotSemState} + (hs : RationalVectorDotSemInvariant budget s) : + RationalVectorDotSemInvariant budget + (rationalVectorDotSemStep s) := by + rcases s with ⟨left, right, acc⟩ + cases left with + | nil => exact hs + | cons q qs => + cases right with + | nil => exact hs + | cons r rs => + have hmul := rawRatWidth_mul_le + (rawRatOfRat q) (rawRatOfRat r) + have hadd := rawRatWidth_add_le acc + ((rawRatOfRat q).mul (rawRatOfRat r)) + simp only [RationalVectorDotSemInvariant, + rationalVectorDotSemStep, rawRatListDotCost] at hs ⊒ + omega + +theorem rationalVectorDotBound_large (word : List Bool) : + 4 + 3 * (1 + word.length) ≀ + (machineRationalVectorDotInputBound word).length := by + simp only [machineRationalVectorDotInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith + +theorem machineRationalVectorDotStep_semantics + (word : List Bool) (s : RationalVectorDotSemState) + (hs : RationalVectorDotSemInvariant (1 + word.length) s) : + machineRationalVectorDotStep + (rationalVectorDotSemCode + (machineRationalVectorDotInputBound word) s) = + rationalVectorDotSemCode + (machineRationalVectorDotInputBound word) + (rationalVectorDotSemStep s) := by + rcases s with ⟨left, right, acc⟩ + cases left with + | nil => + simp [rationalVectorDotSemCode, rationalVectorDotSemStep, + machineRationalVectorDotStep, binaryListCode] + | cons q qs => + cases right with + | nil => + rw [rationalVectorDotSemCode, rationalVectorDotSemStep, + machineRationalVectorDotStep] + simp only [machineRationalVectorDotLeft_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp [binaryListCode, rationalVectorDotSemCode] + | cons r rs => + have hnext : + rawRatWidth + (acc.add ((rawRatOfRat q).mul (rawRatOfRat r))) ≀ + 1 + word.length := by + have hinv := rationalVectorDotSemStep_invariant hs + have hinv' : rawRatWidth + (acc.add ((rawRatOfRat q).mul (rawRatOfRat r))) + + rawRatListDotCost qs rs ≀ 1 + word.length := by + simpa only [RationalVectorDotSemInvariant, + rationalVectorDotSemStep, rawRatListDotCost, + Nat.add_zero] using! hinv + omega + have hcode : + (rawRatBinaryCode + (acc.add ((rawRatOfRat q).mul + (rawRatOfRat r)))).length ≀ + (machineRationalVectorDotInputBound word).length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans + (rationalVectorDotBound_large word)) + rw [rationalVectorDotSemCode, rationalVectorDotSemStep, + machineRationalVectorDotStep] + simp only [machineRationalVectorDotLeft_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineRationalVectorDotRight_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode r rs)] + simp only [machineRationalVectorDotAdvance, + machineRationalVectorDotLeft_pack, + machineRationalVectorDotRight_pack, + machineRationalVectorDotAcc_pack, + machineRationalVectorDotBound_pack, + machineListTail_cons, machineRationalVectorDotNextAcc, + machineRationalVectorDotCandidate, + machineRationalVectorDotProduct, + machineRationalVectorDotLeftEntry, + machineRationalVectorDotRightEntry, machineListHead_cons] + rw [← rawRatBinaryCode_rawRatOfRat q, + ← rawRatBinaryCode_rawRatOfRat r, + machineRawRatMulCode_encode, + machineRawRatAddCode_encode, + (List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineRationalVectorDotIterate_semantics + (word : List Bool) (s : RationalVectorDotSemState) + (hs : RationalVectorDotSemInvariant (1 + word.length) s) : βˆ€ k, + (machineRationalVectorDotStep)^[k] + (rationalVectorDotSemCode + (machineRationalVectorDotInputBound word) s) = + rationalVectorDotSemCode + (machineRationalVectorDotInputBound word) + ((rationalVectorDotSemStep)^[k] s) := by + intro k + have hinv : βˆ€ t : β„•, + RationalVectorDotSemInvariant (1 + word.length) + ((rationalVectorDotSemStep)^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact rationalVectorDotSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineRationalVectorDotStep_semantics word _ (hinv k) + +theorem rationalVectorDotSem_process : βˆ€ (xs ys : List β„š) + (acc : RawRat), xs.length = ys.length β†’ + (rationalVectorDotSemStep)^[xs.length] + ⟨xs, ys, acc⟩ = ⟨[], [], rawRatListDot acc xs ys⟩ := by + intro xs + induction xs with + | nil => + intro ys acc hlen + cases ys with + | nil => rfl + | cons r rs => simp at hlen + | cons q qs ih => + intro ys acc hlen + cases ys with + | nil => simp at hlen + | cons r rs => + rw [List.length_cons, Function.iterate_succ_apply, + rationalVectorDotSemStep, ih] + Β· rfl + Β· simpa using! Nat.succ.inj hlen + +theorem rationalVectorDotSem_done_iterate + (extra : β„•) (acc : RawRat) : + (rationalVectorDotSemStep)^[extra] + ⟨[], [], acc⟩ = ⟨[], [], acc⟩ := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + rfl + +theorem machineRationalVectorDot_done_iterate + (extra : β„•) (acc : RawRat) (bound : List Bool) : + (machineRationalVectorDotStep)^[extra] + (machineRationalVectorDotPack [] [] + (rawRatBinaryCode acc) bound) = + machineRationalVectorDotPack [] [] + (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalVectorDotStep] + +theorem machineRationalVectorDotFinalState_encode {n : β„•} + (v w : Fin n β†’ β„š) : + let word := pair (rationalFiniteVectorCode v) + (rationalFiniteVectorCode w) + machineRationalVectorDotFinalState word = + machineRationalVectorDotPack [] [] + (rawRatBinaryCode + (rawRatListDot RawRat.zero (List.ofFn v) (List.ofFn w))) + (machineRationalVectorDotInputBound word) := by + let left := List.ofFn v + let right := List.ofFn w + let word := pair (rationalFiniteVectorCode v) + (rationalFiniteVectorCode w) + let s : RationalVectorDotSemState := ⟨left, right, RawRat.zero⟩ + have hleftCode : + (binaryListCode rationalEntryBinaryCode left).length ≀ + word.length := by + calc + _ = (machinePairFirst word).length := by + simp [word, left, rationalFiniteVectorCode] + _ ≀ word.length := machinePairFirst_length_le word + have hrightCode : + (binaryListCode rationalEntryBinaryCode right).length ≀ + word.length := by + calc + _ = (machinePairSecond word).length := by + simp [word, right, rationalFiniteVectorCode] + _ ≀ word.length := machinePairSecond_length_le word + have hinv : RationalVectorDotSemInvariant (1 + word.length) s := by + simp only [RationalVectorDotSemInvariant, s, + rawRatWidth_zero] + have hcost := rawRatListDotCost_le_codeLength left right + have hcodes : + (binaryListCode rationalEntryBinaryCode left).length + + (binaryListCode rationalEntryBinaryCode right).length ≀ + word.length := by + simp only [word, rationalFiniteVectorCode, left, right, pair_length] + omega + omega + have hn : n ≀ word.length := by + have hlist := list_length_le_binaryListCode_length + rationalEntryBinaryCode left + simpa only [left, List.length_ofFn] using! hlist.trans hleftCode + have hsplit : word.length = (word.length - n) + n := by omega + have hinit : machineRationalVectorDotInit word = + rationalVectorDotSemCode + (machineRationalVectorDotInputBound word) s := by + simp [machineRationalVectorDotInit, rationalVectorDotSemCode, + s, word, left, right, rationalFiniteVectorCode] + have hprocess : + (rationalVectorDotSemStep)^[n] s = + ⟨[], [], rawRatListDot RawRat.zero left right⟩ := by + simpa [s, left, right] using! + (rationalVectorDotSem_process left right RawRat.zero + (by simp [left, right])) + change machineRationalVectorDotFinalState word = _ + rw [machineRationalVectorDotFinalState, hsplit, + Function.iterate_add_apply, hinit, + machineRationalVectorDotIterate_semantics word s hinv, hprocess] + simp only [rationalVectorDotSemCode, binaryListCode] + rw [machineRationalVectorDot_done_iterate] + +@[simp] theorem machineRationalVectorDotRawCode_encode {n : β„•} + (v w : Fin n β†’ β„š) : + machineRationalVectorDotRawCode + (pair (rationalFiniteVectorCode v) + (rationalFiniteVectorCode w)) = + rawRatBinaryCode + (rawRatListDot RawRat.zero (List.ofFn v) (List.ofFn w)) := by + rw [machineRationalVectorDotRawCode, + machineRationalVectorDotFinalState_encode] + simp + +theorem rawRatListDot_value (acc : RawRat) : βˆ€ xs ys : List β„š, + (rawRatListDot acc xs ys).value = + acc.value + (List.zipWith (fun q r : β„š => q * r) xs ys).sum := by + intro xs ys + induction xs generalizing acc ys with + | nil => simp [rawRatListDot] + | cons q qs ih => + cases ys with + | nil => simp [rawRatListDot] + | cons r rs => + rw [rawRatListDot, ih] + simp [RawRat.value_add, RawRat.value_mul, + rawRatOfRat_value, add_assoc] + +theorem rawRatListDot_ofFn_value {n : β„•} (v w : Fin n β†’ β„š) : + (rawRatListDot RawRat.zero (List.ofFn v) (List.ofFn w)).value = + βˆ‘ i, v i * w i := by + rw [rawRatListDot_value, RawRat.value_zero, zero_add] + have hzip : + List.zipWith (fun q r : β„š => q * r) + (List.ofFn v) (List.ofFn w) = + List.ofFn (fun i : Fin n => v i * w i) := by + apply List.ext_getElem + Β· simp + Β· intro i hiLeft hiRight + simp + rw [hzip, List.sum_ofFn] + +@[simp] theorem machineRationalVectorDotEntryCode_encode {n : β„•} + (v w : Fin n β†’ β„š) : + machineRationalVectorDotEntryCode + (pair (rationalFiniteVectorCode v) + (rationalFiniteVectorCode w)) = + rationalEntryBinaryCode (βˆ‘ i, v i * w i) := by + rw [machineRationalVectorDotEntryCode, + machineRationalVectorDotRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawRatListDot_ofFn_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorL1.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorL1.lean new file mode 100644 index 0000000000..f5329b9a6c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorL1.lean @@ -0,0 +1,579 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalEllipsoidEncoding + +/-! +# Polynomial-time rational `β„“1` norms + +The rational ellipsoid update normalizes a pulled-back cut by +`sum i, |b i|`. This module implements that quantity directly on the +right-nested finite-word encoding of a rational vector. The accumulator is +an unreduced rational. As in the other rational folds, a quadratic clamp +makes the transducer polynomially bounded on malformed words, while the +semantic invariant proves that the clamp is inactive on canonical inputs. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +namespace RawRat + +/-- Replace the signed numerator by its absolute value without changing the +positive denominator. -/ +def magnitude (q : RawRat) : RawRat := + ⟨Int.ofNat q.num.natAbs, q.den, q.den_pos⟩ + +@[simp] theorem magnitude_value (q : RawRat) : + q.magnitude.value = abs q.value := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat n => + have hdenQ : (0 : β„š) < den := by exact_mod_cast hden + simp [magnitude, value, abs_div, abs_of_pos hdenQ] + | negSucc n => + have hdenQ : (0 : β„š) < den := by exact_mod_cast hden + simp only [magnitude, value, Int.natAbs_negSucc, Int.cast_ofNat, + Int.cast_negSucc, Nat.cast_add, Nat.cast_one, abs_div, + abs_of_pos hdenQ] + rw [abs_neg, abs_of_nonneg (by positivity : (0 : β„š) ≀ n + 1)] + norm_num + +@[simp] theorem width_magnitude (q : RawRat) : + rawRatWidth q.magnitude = rawRatWidth q := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat n => simp [magnitude, rawRatWidth] + | negSucc n => + simp only [magnitude, rawRatWidth, Int.natAbs_negSucc] + simp only [Int.natAbs_ofNat'] + +end RawRat + +/-- Exact finite-word absolute value for an unreduced rational entry. -/ +def machineRawRatMagnitudeCode (word : List Bool) : List Bool := + pair + (machineCanonicalIntegerFromSignedAbs + (pair [false] + (machineIntegerNatAbsBits (machinePairFirst word)))) + (machinePairSecond word) + +theorem machineRawRatMagnitudeCode_mem_FP : + machineRawRatMagnitudeCode ∈ FP := by + have habs := machineCompose_mem_FP machinePairFirst_mem_FP + machineIntegerNatAbsBits_mem_FP + have hsigned := machinePair_mem_FP (machineConst_mem_FP [false]) habs + have hnum := machineCompose_mem_FP hsigned + machineCanonicalIntegerFromSignedAbs_mem_FP + exact machinePair_mem_FP hnum machinePairSecond_mem_FP + +@[simp] theorem machineRawRatMagnitudeCode_encode (q : RawRat) : + machineRawRatMagnitudeCode (rawRatBinaryCode q) = + rawRatBinaryCode q.magnitude := by + rw [machineRawRatMagnitudeCode, rawRatBinaryCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineIntegerNatAbsBits_encode, RawRat.magnitude] + rw [machineCanonicalIntegerFromSignedAbs_pair] + simp [signedMagnitudeValue, rawRatBinaryCode] + +/-- Packs the remaining vector, raw L1 accumulator, and bound word. -/ +def machineRationalVectorL1Pack + (current acc bound : List Bool) : List Bool := + pair current (pair acc bound) + +/-- Extracts the unprocessed vector from an L1 scan state. -/ +def machineRationalVectorL1Current (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the raw accumulated L1 sum from the scan state. -/ +def machineRationalVectorL1Acc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulator length-bound word from an L1 scan state. -/ +def machineRationalVectorL1Bound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the next rational entry of the L1 scan. -/ +def machineRationalVectorL1Entry (state : List Bool) : List Bool := + machineListHead (machineRationalVectorL1Current state) + +/-- Computes the raw magnitude of the next rational vector entry. -/ +def machineRationalVectorL1Magnitude (state : List Bool) : List Bool := + machineRawRatMagnitudeCode (machineRationalVectorL1Entry state) + +/-- Adds the next entry's magnitude to the raw L1 accumulator. -/ +def machineRationalVectorL1Candidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineRationalVectorL1Acc state) + (machineRationalVectorL1Magnitude state)) + +/-- Truncates the updated L1 accumulator to the stored bound length. -/ +def machineRationalVectorL1NextAcc (state : List Bool) : List Bool := + (machineRationalVectorL1Candidate state).take + (machineRationalVectorL1Bound state).length + +/-- Consumes the next vector entry and stores the bounded updated L1 accumulator. -/ +def machineRationalVectorL1Advance (state : List Bool) : List Bool := + machineRationalVectorL1Pack + (machineListTail (machineRationalVectorL1Current state)) + (machineRationalVectorL1NextAcc state) + (machineRationalVectorL1Bound state) + +/-- Fixes an exhausted L1 scan and otherwise processes its next entry. -/ +def machineRationalVectorL1Step (state : List Bool) : List Bool := + machineIfEmpty (machineRationalVectorL1Current state) state + (machineRationalVectorL1Advance state) + +/-- Applies the binary-multiplication width construction to bound the L1 accumulator. -/ +def machineRationalVectorL1InputBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Initializes the L1 scan with the input vector, zero raw accumulator, and computed bound. -/ +def machineRationalVectorL1Init (word : List Bool) : List Bool := + machineRationalVectorL1Pack word (rawRatBinaryCode RawRat.zero) + (machineRationalVectorL1InputBound word) + +/-- Packs the input vector and two bound words to bound the complete L1 scan state. -/ +def machineRationalVectorL1Width (word : List Bool) : List Bool := + let bound := machineRationalVectorL1InputBound word + machineRationalVectorL1Pack word bound bound + +/-- Runs the L1 scan once per input bit from its initial state. -/ +def machineRationalVectorL1FinalState (word : List Bool) : List Bool := + (machineRationalVectorL1Step)^[word.length] + (machineRationalVectorL1Init word) + +/-- Unreduced rational word for the exact `β„“1` norm. -/ +def machineRationalVectorL1RawCode (word : List Bool) : List Bool := + machineRationalVectorL1Acc (machineRationalVectorL1FinalState word) + +/-- Canonical rational-entry word for the exact `β„“1` norm. -/ +def machineRationalVectorL1EntryCode (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode (machineRationalVectorL1RawCode word) + +theorem machineRationalVectorL1Current_mem_FP : + machineRationalVectorL1Current ∈ FP := machinePairFirst_mem_FP + +theorem machineRationalVectorL1Acc_mem_FP : + machineRationalVectorL1Acc ∈ FP := by + simpa only [machineRationalVectorL1Acc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRationalVectorL1Bound_mem_FP : + machineRationalVectorL1Bound ∈ FP := by + simpa only [machineRationalVectorL1Bound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRationalVectorL1Entry_mem_FP : + machineRationalVectorL1Entry ∈ FP := by + simpa only [machineRationalVectorL1Entry] using! + machineCompose_mem_FP machineRationalVectorL1Current_mem_FP + machineListHead_mem_FP + +theorem machineRationalVectorL1Magnitude_mem_FP : + machineRationalVectorL1Magnitude ∈ FP := by + simpa only [machineRationalVectorL1Magnitude] using! + machineCompose_mem_FP machineRationalVectorL1Entry_mem_FP + machineRawRatMagnitudeCode_mem_FP + +theorem machineRationalVectorL1Candidate_mem_FP : + machineRationalVectorL1Candidate ∈ FP := by + have hp := machinePair_mem_FP machineRationalVectorL1Acc_mem_FP + machineRationalVectorL1Magnitude_mem_FP + simpa only [machineRationalVectorL1Candidate] using! + machineCompose_mem_FP hp machineRawRatAddCode_mem_FP + +theorem machineRationalVectorL1NextAcc_mem_FP : + machineRationalVectorL1NextAcc ∈ FP := by + simpa only [machineRationalVectorL1NextAcc] using! + machineTake_mem_FP machineRationalVectorL1Bound_mem_FP + machineRationalVectorL1Candidate_mem_FP + +theorem machineRationalVectorL1Advance_mem_FP : + machineRationalVectorL1Advance ∈ FP := by + have htail := machineCompose_mem_FP machineRationalVectorL1Current_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalVectorL1NextAcc_mem_FP + machineRationalVectorL1Bound_mem_FP) + +theorem machineRationalVectorL1Step_mem_FP : + machineRationalVectorL1Step ∈ FP := by + exact machineIfEmpty_mem_FP machineRationalVectorL1Current_mem_FP + id_mem_FP machineRationalVectorL1Advance_mem_FP + +theorem machineRationalVectorL1InputBound_mem_FP : + machineRationalVectorL1InputBound ∈ FP := + machineBinaryMulWidth_mem_FP + +theorem machineRationalVectorL1Init_mem_FP : + machineRationalVectorL1Init ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineRationalVectorL1InputBound_mem_FP) + +theorem machineRationalVectorL1Width_mem_FP : + machineRationalVectorL1Width ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRationalVectorL1InputBound_mem_FP + machineRationalVectorL1InputBound_mem_FP) + +@[simp] theorem machineRationalVectorL1Current_pack (current acc bound) : + machineRationalVectorL1Current + (machineRationalVectorL1Pack current acc bound) = current := by + simp [machineRationalVectorL1Current, machineRationalVectorL1Pack] + +@[simp] theorem machineRationalVectorL1Acc_pack (current acc bound) : + machineRationalVectorL1Acc + (machineRationalVectorL1Pack current acc bound) = acc := by + simp [machineRationalVectorL1Acc, machineRationalVectorL1Pack] + +@[simp] theorem machineRationalVectorL1Bound_pack (current acc bound) : + machineRationalVectorL1Bound + (machineRationalVectorL1Pack current acc bound) = bound := by + simp [machineRationalVectorL1Bound, machineRationalVectorL1Pack] + +/-- Requires exact L1 state packing, input-bounded remaining vector, a bounded accumulator, and +the prescribed bound word. -/ +def MachineRationalVectorL1StateBound + (word state : List Bool) : Prop := + state = machineRationalVectorL1Pack + (machineRationalVectorL1Current state) + (machineRationalVectorL1Acc state) + (machineRationalVectorL1Bound state) ∧ + (machineRationalVectorL1Current state).length ≀ word.length ∧ + (machineRationalVectorL1Acc state).length ≀ + (machineRationalVectorL1InputBound word).length ∧ + machineRationalVectorL1Bound state = + machineRationalVectorL1InputBound word + +theorem machineRationalVectorL1Init_bound (word : List Bool) : + MachineRationalVectorL1StateBound word + (machineRationalVectorL1Init word) := by + simp only [MachineRationalVectorL1StateBound, + machineRationalVectorL1Init, machineRationalVectorL1Current_pack, + machineRationalVectorL1Acc_pack, machineRationalVectorL1Bound_pack] + refine ⟨trivial, le_rfl, ?_, trivial⟩ + simp [machineRationalVectorL1InputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.zero, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineRationalVectorL1Step_bound {word state : List Bool} + (hs : MachineRationalVectorL1StateBound word state) : + MachineRationalVectorL1StateBound word + (machineRationalVectorL1Step state) := by + rcases hs with ⟨hdecomp, hcurrent, hacc, hbound⟩ + by_cases hnil : machineRationalVectorL1Current state = [] + Β· rw [machineRationalVectorL1Step, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hcurrent, hacc, hbound⟩ + Β· cases hcode : machineRationalVectorL1Current state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineRationalVectorL1Step, hcode, machineIfEmpty_cons, + machineRationalVectorL1Advance] + simp only [MachineRationalVectorL1StateBound, + machineRationalVectorL1Current_pack, + machineRationalVectorL1Acc_pack, + machineRationalVectorL1Bound_pack] + refine ⟨trivial, ?_, ?_, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalVectorL1Current state)).trans hcurrent + Β· rw [machineRationalVectorL1NextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineRationalVectorL1Iterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalVectorL1StateBound word + ((machineRationalVectorL1Step)^[k] + (machineRationalVectorL1Init word)) := by + intro k + induction k with + | zero => exact machineRationalVectorL1Init_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalVectorL1Step_bound ih + +theorem machineRationalVectorL1Iterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalVectorL1Step)^[iterations] + (machineRationalVectorL1Init word)).length ≀ + (machineRationalVectorL1Width word).length := by + rcases machineRationalVectorL1Iterate_bound word iterations with + ⟨hdecomp, hcurrent, hacc, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalVectorL1Pack, + machineRationalVectorL1Width, pair_length] + omega + +theorem machineRationalVectorL1FinalState_mem_FP : + machineRationalVectorL1FinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalVectorL1Step_mem_FP + machineRationalVectorL1Init_mem_FP id_mem_FP + machineRationalVectorL1Width_mem_FP + machineRationalVectorL1Iterate_length_le_width + +theorem machineRationalVectorL1RawCode_mem_FP : + machineRationalVectorL1RawCode ∈ FP := by + simpa only [machineRationalVectorL1RawCode] using! + machineCompose_mem_FP machineRationalVectorL1FinalState_mem_FP + machineRationalVectorL1Acc_mem_FP + +theorem machineRationalVectorL1EntryCode_mem_FP : + machineRationalVectorL1EntryCode ∈ FP := by + simpa only [machineRationalVectorL1EntryCode] using! + machineCompose_mem_FP machineRationalVectorL1RawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +/-! ## Exact semantics -/ + +/-- Adds rational entry magnitudes into a raw accumulator from left to right. -/ +def rawRatListL1Sum : RawRat β†’ List β„š β†’ RawRat + | acc, [] => acc + | acc, q :: qs => + rawRatListL1Sum (acc.add (rawRatOfRat q).magnitude) qs + +theorem rawRatWidth_listL1Sum_le (acc : RawRat) : βˆ€ xs : List β„š, + rawRatWidth (rawRatListL1Sum acc xs) ≀ + rawRatWidth acc + rawRatListCost xs := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRatListL1Sum, rawRatListCost] + | cons q qs ih => + rw [rawRatListL1Sum] + have hadd := rawRatWidth_add_le acc (rawRatOfRat q).magnitude + rw [RawRat.width_magnitude] at hadd + have htail := ih (acc.add (rawRatOfRat q).magnitude) + simp only [rawRatListCost, List.map_cons, List.sum_cons] at htail ⊒ + omega + +structure RationalVectorL1SemState where + /-- The unprocessed entries of the semantic L1 scan. -/ + current : List β„š + /-- The raw rational accumulator of the semantic L1 scan. -/ + acc : RawRat + +/-- Adds the next entry's magnitude and consumes it, fixing an exhausted semantic L1 state. -/ +def rationalVectorL1SemStep + (s : RationalVectorL1SemState) : RationalVectorL1SemState := + match s.current with + | q :: qs => ⟨qs, s.acc.add (rawRatOfRat q).magnitude⟩ + | [] => s + +/-- Encodes the semantic remaining vector and raw L1 accumulator with the supplied bound. -/ +def rationalVectorL1SemCode (bound : List Bool) + (s : RationalVectorL1SemState) : List Bool := + machineRationalVectorL1Pack + (binaryListCode rationalEntryBinaryCode s.current) + (rawRatBinaryCode s.acc) bound + +/-- Bounds the raw L1 accumulator width plus the remaining list cost by the specified budget. -/ +def RationalVectorL1SemInvariant (budget : β„•) + (s : RationalVectorL1SemState) : Prop := + rawRatWidth s.acc + rawRatListCost s.current ≀ budget + +theorem rationalVectorL1SemStep_invariant {budget : β„•} + {s : RationalVectorL1SemState} + (hs : RationalVectorL1SemInvariant budget s) : + RationalVectorL1SemInvariant budget (rationalVectorL1SemStep s) := by + rcases s with ⟨current, acc⟩ + cases current with + | nil => exact hs + | cons q qs => + have hadd := rawRatWidth_add_le acc (rawRatOfRat q).magnitude + rw [RawRat.width_magnitude] at hadd + simp only [RationalVectorL1SemInvariant, rationalVectorL1SemStep, + rawRatListCost, List.map_cons, List.sum_cons] at hs ⊒ + omega + +theorem rationalVectorL1Bound_large (word : List Bool) : + 4 + 3 * (1 + word.length) ≀ + (machineRationalVectorL1InputBound word).length := by + simp only [machineRationalVectorL1InputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith + +theorem machineRationalVectorL1Step_semantics + (word : List Bool) (s : RationalVectorL1SemState) + (hs : RationalVectorL1SemInvariant (1 + word.length) s) : + machineRationalVectorL1Step + (rationalVectorL1SemCode + (machineRationalVectorL1InputBound word) s) = + rationalVectorL1SemCode + (machineRationalVectorL1InputBound word) + (rationalVectorL1SemStep s) := by + rcases s with ⟨current, acc⟩ + cases current with + | nil => + simp [rationalVectorL1SemCode, rationalVectorL1SemStep, + machineRationalVectorL1Step, binaryListCode] + | cons q qs => + have hnext : + rawRatWidth (acc.add (rawRatOfRat q).magnitude) ≀ + 1 + word.length := by + have hinv := rationalVectorL1SemStep_invariant hs + have hinv' : + rawRatWidth (acc.add (rawRatOfRat q).magnitude) + + rawRatListCost qs ≀ 1 + word.length := by + simpa only [RationalVectorL1SemInvariant, + rationalVectorL1SemStep] using! hinv + omega + have hcode : + (rawRatBinaryCode + (acc.add (rawRatOfRat q).magnitude)).length ≀ + (machineRationalVectorL1InputBound word).length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans + (rationalVectorL1Bound_large word)) + rw [rationalVectorL1SemCode, rationalVectorL1SemStep, + machineRationalVectorL1Step] + simp only [machineRationalVectorL1Current_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineRationalVectorL1Advance, + machineRationalVectorL1Current_pack, + machineRationalVectorL1Acc_pack, + machineRationalVectorL1Bound_pack, + machineListTail_cons, machineRationalVectorL1NextAcc, + machineRationalVectorL1Candidate, + machineRationalVectorL1Magnitude, + machineRationalVectorL1Entry, machineListHead_cons] + rw [← rawRatBinaryCode_rawRatOfRat q, + machineRawRatMagnitudeCode_encode, + machineRawRatAddCode_encode, + (List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineRationalVectorL1Iterate_semantics + (word : List Bool) (s : RationalVectorL1SemState) + (hs : RationalVectorL1SemInvariant (1 + word.length) s) : βˆ€ k, + (machineRationalVectorL1Step)^[k] + (rationalVectorL1SemCode + (machineRationalVectorL1InputBound word) s) = + rationalVectorL1SemCode + (machineRationalVectorL1InputBound word) + ((rationalVectorL1SemStep)^[k] s) := by + intro k + have hinv : βˆ€ t : β„•, + RationalVectorL1SemInvariant (1 + word.length) + ((rationalVectorL1SemStep)^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact rationalVectorL1SemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineRationalVectorL1Step_semantics word _ (hinv k) + +theorem rationalVectorL1Sem_process : βˆ€ (xs : List β„š) (acc : RawRat), + (rationalVectorL1SemStep)^[xs.length] ⟨xs, acc⟩ = + ⟨[], rawRatListL1Sum acc xs⟩ := by + intro xs + induction xs with + | nil => intro acc; rfl + | cons q qs ih => + intro acc + rw [List.length_cons, Function.iterate_succ_apply, + rationalVectorL1SemStep, ih] + rfl + +theorem machineRationalVectorL1_done_iterate + (extra : β„•) (acc : RawRat) (bound : List Bool) : + (machineRationalVectorL1Step)^[extra] + (machineRationalVectorL1Pack [] (rawRatBinaryCode acc) bound) = + machineRationalVectorL1Pack [] (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalVectorL1Step] + +theorem machineRationalVectorL1FinalState_encode {n : β„•} + (v : Fin n β†’ β„š) : + let word := rationalFiniteVectorCode v + machineRationalVectorL1FinalState word = + machineRationalVectorL1Pack [] + (rawRatBinaryCode + (rawRatListL1Sum RawRat.zero (List.ofFn v))) + (machineRationalVectorL1InputBound word) := by + let xs := List.ofFn v + let word := rationalFiniteVectorCode v + let s : RationalVectorL1SemState := ⟨xs, RawRat.zero⟩ + have hcode : + (binaryListCode rationalEntryBinaryCode xs).length = word.length := by + simp [word, xs, rationalFiniteVectorCode] + have hinv : RationalVectorL1SemInvariant (1 + word.length) s := by + simp only [RationalVectorL1SemInvariant, s, rawRatWidth_zero] + have hcost := rawRatListCost_le_codeLength xs + omega + have hn : n ≀ word.length := by + have hlist := list_length_le_binaryListCode_length + rationalEntryBinaryCode xs + simpa only [xs, List.length_ofFn, hcode] using! hlist + have hsplit : word.length = (word.length - n) + n := by omega + have hinit : machineRationalVectorL1Init word = + rationalVectorL1SemCode + (machineRationalVectorL1InputBound word) s := by + simp [machineRationalVectorL1Init, rationalVectorL1SemCode, + s, word, xs, rationalFiniteVectorCode] + have hprocess : + (rationalVectorL1SemStep)^[n] s = + ⟨[], rawRatListL1Sum RawRat.zero xs⟩ := by + simpa [s, xs] using! rationalVectorL1Sem_process xs RawRat.zero + change machineRationalVectorL1FinalState word = _ + rw [machineRationalVectorL1FinalState, hsplit, + Function.iterate_add_apply, hinit, + machineRationalVectorL1Iterate_semantics word s hinv, hprocess] + simp only [rationalVectorL1SemCode, binaryListCode] + rw [machineRationalVectorL1_done_iterate] + +@[simp] theorem machineRationalVectorL1RawCode_encode {n : β„•} + (v : Fin n β†’ β„š) : + machineRationalVectorL1RawCode (rationalFiniteVectorCode v) = + rawRatBinaryCode + (rawRatListL1Sum RawRat.zero (List.ofFn v)) := by + rw [machineRationalVectorL1RawCode, + machineRationalVectorL1FinalState_encode] + simp + +theorem rawRatListL1Sum_value (acc : RawRat) : βˆ€ xs : List β„š, + (rawRatListL1Sum acc xs).value = + acc.value + (xs.map abs).sum := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRatListL1Sum] + | cons q qs ih => + rw [rawRatListL1Sum, ih] + simp [RawRat.value_add, rawRatOfRat_value, add_assoc] + +theorem rawRatListL1Sum_ofFn_value {n : β„•} (v : Fin n β†’ β„š) : + (rawRatListL1Sum RawRat.zero (List.ofFn v)).value = + βˆ‘ i, abs (v i) := by + rw [rawRatListL1Sum_value, RawRat.value_zero, zero_add] + simp only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + +@[simp] theorem machineRationalVectorL1EntryCode_encode {n : β„•} + (v : Fin n β†’ β„š) : + machineRationalVectorL1EntryCode (rationalFiniteVectorCode v) = + rationalEntryBinaryCode (cutL1Scale v) := by + rw [machineRationalVectorL1EntryCode, + machineRationalVectorL1RawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawRatListL1Sum_ofFn_value, cutL1Scale] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorScale.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorScale.lean new file mode 100644 index 0000000000..bfcdb469e6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorScale.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalNormalizedDirection + +/-! +# Polynomial-time rational vector scaling + +The input is a raw rational scalar followed by a canonically encoded rational +vector. We reduce scaling to the verified row-division machine: division by +`1 / s` is multiplication by `s`, including at `s = 0` under the field's total +inverse convention. The reciprocal remains an unreduced `RawRat` word, so +the composition performs no decoding or hidden rational arithmetic. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Multiplies every rational vector coordinate by the scalar `s`. -/ +def rationalVectorScale {d : β„•} + (s : β„š) (v : Fin d β†’ β„š) : Fin d β†’ β„š := + fun i ↦ s * v i + +/-- Computes raw one divided by the requested vector-scaling factor. -/ +def machineRationalVectorScaleReciprocalCode + (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode RawRat.one) (machinePairFirst word)) + +/-- Scales the encoded vector by dividing each entry by the totalized reciprocal of the +requested factor. -/ +def machineRationalVectorScaleCode + (word : List Bool) : List Bool := + machineRationalRowDivide + (pair (machineRationalVectorScaleReciprocalCode word) + (machinePairSecond word)) + +theorem machineRationalVectorScaleReciprocalCode_mem_FP : + machineRationalVectorScaleReciprocalCode ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machinePairFirst_mem_FP + simpa only [machineRationalVectorScaleReciprocalCode] using! + machineCompose_mem_FP hinput machineRawRatDivCode_mem_FP + +theorem machineRationalVectorScaleCode_mem_FP : + machineRationalVectorScaleCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRationalVectorScaleReciprocalCode_mem_FP machinePairSecond_mem_FP + simpa only [machineRationalVectorScaleCode] using! + machineCompose_mem_FP hinput machineRationalRowDivide_mem_FP + +theorem rationalRowDivideValues_reciprocal_ofFn {d : β„•} + (s : RawRat) (v : Fin d β†’ β„š) : + rationalRowDivideValues (RawRat.one.div s) (List.ofFn v) = + List.ofFn (rationalVectorScale s.value v) := by + rw [rationalRowDivideValues, List.map_ofFn] + apply congrArg List.ofFn + funext i + simp [rationalVectorScale, binaryNormalizeRawRat_eq_value, + RawRat.value_div, RawRat.value_one, rawRatOfRat_value] + ring + +@[simp] theorem machineRationalVectorScaleCode_encode {d : β„•} + (s : RawRat) (v : Fin d β†’ β„š) : + machineRationalVectorScaleCode + (pair (rawRatBinaryCode s) (rationalFiniteVectorCode v)) = + rationalFiniteVectorCode (rationalVectorScale s.value v) := by + rw [machineRationalVectorScaleCode, + machineRationalVectorScaleReciprocalCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + machineRawRatDivCode_encode] + change machineRationalRowDivide + (machineRationalRowDivideCanonicalInput + (RawRat.one.div s) (List.ofFn v)) = _ + rw [machineRationalRowDivide_encode, + rationalRowDivideValues_reciprocal_ofFn] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSub.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSub.lean new file mode 100644 index 0000000000..3ebc45e79b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSub.lean @@ -0,0 +1,574 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMatrixMulVector +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalVectorScale + +/-! +# Polynomial-time componentwise subtraction of rational vectors + +The canonical input stores a unary dimension followed by two rational-vector +words. A verified coordinate routine indexes both words, negates the second +raw rational, adds, and normalizes. A bounded finite-word scan maps this +routine over all coordinates and reverses its accumulator once at the end. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Subtracts rational vectors coordinatewise. -/ +def rationalVectorSub {d : β„•} + (x y : Fin d β†’ β„š) : Fin d β†’ β„š := + fun i ↦ x i - y i + +/-- Looks up both requested vector entries, subtracts them in raw arithmetic, and normalizes the +resulting entry code. -/ +def machineRationalVectorSubEntryCode + (word : List Bool) : List Bool := + let index := machinePairFirst word + let payload := machinePairSecond word + let xCode := machinePairFirst payload + let yCode := machinePairSecond payload + let xEntry := machineListIndex (pair index xCode) + let yEntry := machineListIndex (pair index yCode) + machineNormalizeRawRatEntryCode + (machineRawRatAddCode + (pair xEntry (machineRawRatNegCode yEntry))) + +theorem machineRationalVectorSubEntryCode_mem_FP : + machineRationalVectorSubEntryCode ∈ FP := by + have hindex := machinePairFirst_mem_FP + have hpayload := machinePairSecond_mem_FP + have hxCode := machineCompose_mem_FP hpayload machinePairFirst_mem_FP + have hyCode := machineCompose_mem_FP hpayload machinePairSecond_mem_FP + have hxInput := machinePair_mem_FP hindex hxCode + have hyInput := machinePair_mem_FP hindex hyCode + have hxEntry := machineCompose_mem_FP hxInput machineListIndex_mem_FP + have hyEntry := machineCompose_mem_FP hyInput machineListIndex_mem_FP + have hnegY := machineCompose_mem_FP hyEntry machineRawRatNegCode_mem_FP + have haddInput := machinePair_mem_FP hxEntry hnegY + have hadd := machineCompose_mem_FP haddInput machineRawRatAddCode_mem_FP + simpa only [machineRationalVectorSubEntryCode] using! + machineCompose_mem_FP hadd machineNormalizeRawRatEntryCode_mem_FP + +@[simp] theorem machineRationalVectorSubEntryCode_encode {d : β„•} + (x y : Fin d β†’ β„š) (i : Fin d) : + machineRationalVectorSubEntryCode + (pair (List.replicate i.1 true) + (pair (rationalFiniteVectorCode x) + (rationalFiniteVectorCode y))) = + rationalEntryBinaryCode (rationalVectorSub x y i) := by + rw [machineRationalVectorSubEntryCode] + simp only [machinePairFirst_pair, machinePairSecond_pair, + rationalFiniteVectorCode] + rw [machineListIndex_binaryListCode (k := i.1), + machineListIndex_binaryListCode (k := i.1)] + Β· simp only [List.getElem_ofFn, ← rawRatBinaryCode_rawRatOfRat, + machineRawRatNegCode_encode, machineRawRatAddCode_encode, + machineNormalizeRawRatEntryCode_encode] + simp [binaryNormalizeRawRat_eq_value, RawRat.value_add, + RawRat.value_neg, rawRatOfRat_value, rationalVectorSub, + sub_eq_add_neg] + Β· simp + Β· simp + +/-- Computes one rational vector-difference coordinate in raw arithmetic. -/ +def rawRationalVectorSubCoordinate {d : β„•} + (x y : Fin d β†’ β„š) (i : Fin d) : RawRat := + (rawRatOfRat (x i)).sub (rawRatOfRat (y i)) + +theorem rawRationalVectorSubCoordinate_value {d : β„•} + (x y : Fin d β†’ β„š) (i : Fin d) : + (rawRationalVectorSubCoordinate x y i).value = + rationalVectorSub x y i := by + simp [rawRationalVectorSubCoordinate, rationalVectorSub, + RawRat.sub, RawRat.value_add, RawRat.value_neg, rawRatOfRat_value, + sub_eq_add_neg] + +/-- Encodes unary dimension followed by both rational vectors for subtraction. -/ +def rationalVectorSubCanonicalWord {d : β„•} + (x y : Fin d β†’ β„š) : List Bool := + pair (List.replicate d true) + (pair (rationalFiniteVectorCode x) + (rationalFiniteVectorCode y)) + +theorem rawRationalVectorSubCoordinate_width_le {d : β„•} + (x y : Fin d β†’ β„š) (i : Fin d) : + rawRatWidth (rawRationalVectorSubCoordinate x y i) ≀ + 2 * (rationalVectorSubCanonicalWord x y).length + 1 := by + let word := rationalVectorSubCanonicalWord x y + have hxElem := binaryListCode_element_length_le + rationalEntryBinaryCode + (show x i ∈ List.ofFn x by simp) + have hyElem := binaryListCode_element_length_le + rationalEntryBinaryCode + (show y i ∈ List.ofFn y by simp) + have hxVector : (rationalFiniteVectorCode x).length ≀ word.length := by + have hinner := machinePairFirst_length_le + (pair (rationalFiniteVectorCode x) (rationalFiniteVectorCode y)) + have hpayload : + (pair (rationalFiniteVectorCode x) + (rationalFiniteVectorCode y)).length ≀ word.length := by + simpa only [word, rationalVectorSubCanonicalWord, + machinePairSecond_pair] using! machinePairSecond_length_le word + simpa only [machinePairFirst_pair] using! hinner.trans hpayload + have hyVector : (rationalFiniteVectorCode y).length ≀ word.length := by + have hinner := machinePairSecond_length_le + (pair (rationalFiniteVectorCode x) (rationalFiniteVectorCode y)) + have hpayload : + (pair (rationalFiniteVectorCode x) + (rationalFiniteVectorCode y)).length ≀ word.length := by + simpa only [word, rationalVectorSubCanonicalWord, + machinePairSecond_pair] using! machinePairSecond_length_le word + simpa only [machinePairSecond_pair] using! hinner.trans hpayload + have hxWidth : rawRatWidth (rawRatOfRat (x i)) ≀ word.length := by + have hxCode : + (rawRatBinaryCode (rawRatOfRat (x i))).length ≀ + (rationalFiniteVectorCode x).length := by + simpa only [rationalFiniteVectorCode, + rawRatBinaryCode_rawRatOfRat] using! hxElem + exact (rawRatWidth_le_binaryCode_length _).trans + (hxCode.trans hxVector) + have hyWidth : rawRatWidth (rawRatOfRat (y i)) ≀ word.length := by + have hyCode : + (rawRatBinaryCode (rawRatOfRat (y i))).length ≀ + (rationalFiniteVectorCode y).length := by + simpa only [rationalFiniteVectorCode, + rawRatBinaryCode_rawRatOfRat] using! hyElem + exact (rawRatWidth_le_binaryCode_length _).trans + (hyCode.trans hyVector) + change rawRatWidth ((rawRatOfRat (x i)).sub (rawRatOfRat (y i))) ≀ + 2 * word.length + 1 + exact (rawRatWidth_sub_le _ _).trans (by omega) + +theorem rationalVectorSub_entry_code_length_le {d : β„•} + (x y : Fin d β†’ β„š) (i : Fin d) : + (rationalEntryBinaryCode (rationalVectorSub x y i)).length ≀ + 100 + 72 * (rationalVectorSubCanonicalWord x y).length := by + have hnormalize := + rationalEntryBinaryCode_binaryNormalizeRawRat_length_le + (rawRationalVectorSubCoordinate x y i) + rw [binaryNormalizeRawRat_eq_value, + rawRationalVectorSubCoordinate_value] at hnormalize + have hwidth := rawRationalVectorSubCoordinate_width_le x y i + omega + +/-- Reuses the transpose-matrix vector input bound for the vector-subtraction scan. -/ +def machineRationalVectorSubInputBound + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorInputBound word + +theorem machineRationalVectorSubInputBound_mem_FP : + machineRationalVectorSubInputBound ∈ FP := + machineRationalTransposeMulVectorInputBound_mem_FP + +theorem rationalVectorSub_code_length_le_bound {d : β„•} + (x y : Fin d β†’ β„š) : + (rationalFiniteVectorCode (rationalVectorSub x y)).length ≀ + (machineRationalVectorSubInputBound + (rationalVectorSubCanonicalWord x y)).length := by + let word := rationalVectorSubCanonicalWord x y + let B := 100 + 72 * word.length + have hdim : d ≀ word.length := by + have hfirst := machinePairFirst_length_le word + simpa only [word, rationalVectorSubCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! hfirst + have heach : βˆ€ q ∈ List.ofFn (rationalVectorSub x y), + (rationalEntryBinaryCode q).length ≀ B := by + intro q hq + obtain ⟨i, rfl⟩ := List.mem_ofFn.mp hq + exact rationalVectorSub_entry_code_length_le x y i + have hsum := List.sum_le_card_nsmul + ((List.ofFn (rationalVectorSub x y)).map + fun q ↦ 2 * (rationalEntryBinaryCode q).length + 2) + (2 * B + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨q, hq, rfl⟩ := hvalue + have hq' := heach q hq + omega) + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum] + simp only [machineRationalVectorSubInputBound, + machineRationalTransposeMulVectorInputBound, + machineBinaryMulWidth, List.length_replicate, + List.length_append, List.length_map, List.length_ofFn, + Nat.nsmul_eq_mul] at hsum ⊒ + dsimp only [B, word] at hsum ⊒ + nlinarith [sq_nonneg (rationalVectorSubCanonicalWord x y).length] + +/-! ## Bounded scan -/ + +/-- Computes the normalized difference entry at the current scan index. -/ +def machineRationalVectorSubCurrentEntry + (state : List Bool) : List Bool := + machineRationalVectorSubEntryCode + (pair (machineRationalTransposeMulVectorCurrentIndex state) + (machineRationalTransposeMulVectorStatePayload state)) + +/-- Prepends the current difference entry to the reverse-order accumulator. -/ +def machineRationalVectorSubCandidate + (state : List Bool) : List Bool := + pair (machineRationalVectorSubCurrentEntry state) + (machineRationalTransposeMulVectorAccumulator state) + +/-- Truncates the candidate difference accumulator to the stored bound length. -/ +def machineRationalVectorSubNextAccumulator + (state : List Bool) : List Bool := + (machineRationalVectorSubCandidate state).take + (machineRationalTransposeMulVectorBound state).length + +/-- Consumes the current coordinate index and stores the bounded updated difference accumulator. -/ +def machineRationalVectorSubAdvance + (state : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineListTail (machineRationalTransposeMulVectorRemaining state)) + (machineRationalVectorSubNextAccumulator state) + (machineRationalTransposeMulVectorStatePayload state) + (machineRationalTransposeMulVectorBound state) + +/-- Fixes an exhausted vector-subtraction scan and otherwise computes its next entry. -/ +def machineRationalVectorSubStep + (state : List Bool) : List Bool := + machineIfEmpty (machineRationalTransposeMulVectorRemaining state) state + (machineRationalVectorSubAdvance state) + +/-- Initializes subtraction with all coordinate indices, empty accumulator, both-vector payload, +and computed bound. -/ +def machineRationalVectorSubInit (word : List Bool) : List Bool := + machineRationalTransposeMulVectorPack + (machineRationalTransposeMulVectorIndices word) [] + (machineRationalTransposeMulVectorPayload word) + (machineRationalVectorSubInputBound word) + +/-- Packs four copies of the computed bound to bound the vector-subtraction state. -/ +def machineRationalVectorSubWidth (word : List Bool) : List Bool := + let bound := machineRationalVectorSubInputBound word + machineRationalTransposeMulVectorPack bound bound bound bound + +/-- Runs the vector-subtraction scan once per input bit from its initial state. -/ +def machineRationalVectorSubFinalState + (word : List Bool) : List Bool := + (machineRationalVectorSubStep)^[word.length] + (machineRationalVectorSubInit word) + +/-- Extracts the difference entries in reverse order from the final scan state. -/ +def machineRationalVectorSubReversedCode + (word : List Bool) : List Bool := + machineRationalTransposeMulVectorAccumulator + (machineRationalVectorSubFinalState word) + +/-- Reverses the accumulated entries to return the difference vector in coordinate order. -/ +def machineRationalVectorSubCode + (word : List Bool) : List Bool := + machineListReverse (machineRationalVectorSubReversedCode word) + +theorem machineRationalVectorSubCurrentEntry_mem_FP : + machineRationalVectorSubCurrentEntry ∈ FP := by + have hp := machinePair_mem_FP + machineRationalTransposeMulVectorCurrentIndex_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + simpa only [machineRationalVectorSubCurrentEntry] using! + machineCompose_mem_FP hp machineRationalVectorSubEntryCode_mem_FP + +theorem machineRationalVectorSubCandidate_mem_FP : + machineRationalVectorSubCandidate ∈ FP := + machinePair_mem_FP machineRationalVectorSubCurrentEntry_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalVectorSubNextAccumulator_mem_FP : + machineRationalVectorSubNextAccumulator ∈ FP := by + simpa only [machineRationalVectorSubNextAccumulator] using! + machineTake_mem_FP machineRationalTransposeMulVectorBound_mem_FP + machineRationalVectorSubCandidate_mem_FP + +theorem machineRationalVectorSubAdvance_mem_FP : + machineRationalVectorSubAdvance ∈ FP := by + have htail := machineCompose_mem_FP + machineRationalTransposeMulVectorRemaining_mem_FP machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineRationalVectorSubNextAccumulator_mem_FP + (machinePair_mem_FP + machineRationalTransposeMulVectorStatePayload_mem_FP + machineRationalTransposeMulVectorBound_mem_FP)) + +theorem machineRationalVectorSubStep_mem_FP : + machineRationalVectorSubStep ∈ FP := + machineIfEmpty_mem_FP machineRationalTransposeMulVectorRemaining_mem_FP + id_mem_FP machineRationalVectorSubAdvance_mem_FP + +theorem machineRationalVectorSubInit_mem_FP : + machineRationalVectorSubInit ∈ FP := by + exact machinePair_mem_FP machineRationalTransposeMulVectorIndices_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineRationalTransposeMulVectorPayload_mem_FP + machineRationalVectorSubInputBound_mem_FP)) + +theorem machineRationalVectorSubWidth_mem_FP : + machineRationalVectorSubWidth ∈ FP := by + exact machinePair_mem_FP machineRationalVectorSubInputBound_mem_FP + (machinePair_mem_FP machineRationalVectorSubInputBound_mem_FP + (machinePair_mem_FP machineRationalVectorSubInputBound_mem_FP + machineRationalVectorSubInputBound_mem_FP)) + +theorem machineRationalVectorSubStep_bound {word state : List Bool} + (hs : MachineRationalTransposeMulVectorStateBound word state) : + MachineRationalTransposeMulVectorStateBound word + (machineRationalVectorSubStep state) := by + dsimp only [MachineRationalTransposeMulVectorStateBound] at hs ⊒ + rcases hs with ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + by_cases hnil : machineRationalTransposeMulVectorRemaining state = [] + Β· rw [machineRationalVectorSubStep, hnil, machineIfEmpty_nil] + exact ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + Β· cases hcode : machineRationalTransposeMulVectorRemaining state with + | nil => exact False.elim (hnil hcode) + | cons bit tail => + rw [machineRationalVectorSubStep, hcode, + machineIfEmpty_cons, machineRationalVectorSubAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack] + refine ⟨trivial, ?_, ?_, hpayload, hbound⟩ + Β· exact (machineListTail_length_le + (machineRationalTransposeMulVectorRemaining state)).trans + hremaining + Β· rw [machineRationalVectorSubNextAccumulator, hbound] + exact List.length_take_le _ _ + +theorem machineRationalVectorSubIterate_bound + (word : List Bool) : βˆ€ k, + MachineRationalTransposeMulVectorStateBound word + ((machineRationalVectorSubStep)^[k] + (machineRationalVectorSubInit word)) := by + intro k + induction k with + | zero => + simpa only [machineRationalVectorSubInit, + machineRationalVectorSubInputBound, + machineRationalTransposeMulVectorInit] using! + machineRationalTransposeMulVectorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRationalVectorSubStep_bound ih + +theorem machineRationalVectorSubIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ word.length) : + ((machineRationalVectorSubStep)^[iterations] + (machineRationalVectorSubInit word)).length ≀ + (machineRationalVectorSubWidth word).length := by + rcases machineRationalVectorSubIterate_bound word iterations with + ⟨hdecomp, hremaining, hacc, hpayload, hbound⟩ + rw [hdecomp, hbound] + simp only [machineRationalTransposeMulVectorPack, + machineRationalVectorSubWidth, machineRationalVectorSubInputBound, + pair_length] + omega + +theorem machineRationalVectorSubFinalState_mem_FP : + machineRationalVectorSubFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRationalVectorSubStep_mem_FP + machineRationalVectorSubInit_mem_FP id_mem_FP + machineRationalVectorSubWidth_mem_FP + machineRationalVectorSubIterate_length_le_width + +theorem machineRationalVectorSubReversedCode_mem_FP : + machineRationalVectorSubReversedCode ∈ FP := by + simpa only [machineRationalVectorSubReversedCode] using! + machineCompose_mem_FP machineRationalVectorSubFinalState_mem_FP + machineRationalTransposeMulVectorAccumulator_mem_FP + +theorem machineRationalVectorSubCode_mem_FP : + machineRationalVectorSubCode ∈ FP := by + simpa only [machineRationalVectorSubCode] using! + machineCompose_mem_FP machineRationalVectorSubReversedCode_mem_FP + machineListReverse_mem_FP + +/-! ## Exact scan semantics -/ + +/-- Lists the first `k` coordinates of the rational vector difference. -/ +def rationalVectorSubPrefix {d : β„•} + (x y : Fin d β†’ β„š) (k : β„•) : List β„š := + ((List.finRange d).take k).map fun i ↦ rationalVectorSub x y i + +/-- Encodes remaining coordinate indices and the reversed difference prefix after `k` +coordinates, retaining both vectors and the bound. -/ +def machineRationalVectorSubSemanticState {d : β„•} + (x y : Fin d β†’ β„š) (k : β„•) : List Bool := + let word := rationalVectorSubCanonicalWord x y + machineRationalTransposeMulVectorPack + (binaryListCode finUnaryCode ((List.finRange d).drop k)) + (binaryListCode rationalEntryBinaryCode + (rationalVectorSubPrefix x y k).reverse) + (pair (rationalFiniteVectorCode x) (rationalFiniteVectorCode y)) + (machineRationalVectorSubInputBound word) + +theorem machineRationalVectorSubInit_semantics {d : β„•} + (x y : Fin d β†’ β„š) : + machineRationalVectorSubInit (rationalVectorSubCanonicalWord x y) = + machineRationalVectorSubSemanticState x y 0 := by + simp [machineRationalVectorSubInit, + machineRationalVectorSubSemanticState, + machineRationalTransposeMulVectorIndices, + machineRationalTransposeMulVectorDimension, + machineRationalTransposeMulVectorPayload, + rationalVectorSubCanonicalWord, machineUnaryRangeCode_encode, + finRangeUnaryCode, rationalVectorSubPrefix, binaryListCode] + +theorem rationalVectorSubPrefix_succ {d : β„•} + (x y : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + rationalVectorSubPrefix x y (k + 1) = + rationalVectorSubPrefix x y k ++ + [rationalVectorSub x y ⟨k, hk⟩] := by + simp only [rationalVectorSubPrefix, List.map_take] + have hkm : k < (List.finRange d).length := by simpa + simpa [List.getElem_finRange] using! + congrArg (List.map fun i ↦ rationalVectorSub x y i) + (List.take_concat_get hkm).symm + +theorem machineRationalVectorSubStep_semantics {d : β„•} + (x y : Fin d β†’ β„š) (k : β„•) (hk : k < d) : + machineRationalVectorSubStep + (machineRationalVectorSubSemanticState x y k) = + machineRationalVectorSubSemanticState x y (k + 1) := by + let word := rationalVectorSubCanonicalWord x y + let i : Fin d := ⟨k, hk⟩ + have hdrop : + (List.finRange d).drop k = + i :: (List.finRange d).drop (k + 1) := by + convert List.drop_eq_getElem_cons + (show k < (List.finRange d).length by simpa) using 1 + simp [i, List.getElem_finRange] + have hprefix := rationalVectorSubPrefix_succ x y k hk + have hreverse : + (rationalVectorSubPrefix x y (k + 1)).reverse = + rationalVectorSub x y i :: + (rationalVectorSubPrefix x y k).reverse := by + rw [hprefix, List.reverse_append] + simp [i] + have hcand : + (binaryListCode rationalEntryBinaryCode + (rationalVectorSubPrefix x y (k + 1)).reverse).length ≀ + (machineRationalVectorSubInputBound word).length := by + have hprefixBound := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode (List.ofFn (rationalVectorSub x y)) (k + 1) + have hprefixEq : rationalVectorSubPrefix x y (k + 1) = + (List.ofFn (rationalVectorSub x y)).take (k + 1) := by + apply List.ext_getElem + Β· simp [rationalVectorSubPrefix] + Β· intro r hrLeft hrRight + simp [rationalVectorSubPrefix, List.getElem_finRange] + rw [hprefixEq] + exact hprefixBound.trans (rationalVectorSub_code_length_le_bound x y) + have hcandPair : + (pair (rationalEntryBinaryCode (rationalVectorSub x y i)) + (binaryListCode rationalEntryBinaryCode + (rationalVectorSubPrefix x y k).reverse)).length ≀ + (machineRationalVectorSubInputBound word).length := by + simpa only [hreverse, binaryListCode] using! hcand + have hnonempty : + binaryListCode finUnaryCode ((List.finRange d).drop k) β‰  [] := by + rw [hdrop] + exact binaryListCode_cons_ne_nil finUnaryCode i _ + rw [machineRationalVectorSubStep] + simp only [machineRationalVectorSubSemanticState, + machineRationalTransposeMulVectorRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ hnonempty, + machineRationalVectorSubAdvance] + simp only [machineRationalTransposeMulVectorRemaining_pack, + machineRationalTransposeMulVectorAccumulator_pack, + machineRationalTransposeMulVectorStatePayload_pack, + machineRationalTransposeMulVectorBound_pack, + machineRationalVectorSubNextAccumulator, + machineRationalVectorSubCandidate, + machineRationalVectorSubCurrentEntry, + machineRationalTransposeMulVectorCurrentIndex] + rw [hdrop, machineListHead_cons, machineListTail_cons] + change machineRationalTransposeMulVectorPack _ + ((pair (machineRationalVectorSubEntryCode + (pair (finUnaryCode i) + (pair (rationalFiniteVectorCode x) + (rationalFiniteVectorCode y)))) + (binaryListCode rationalEntryBinaryCode + (rationalVectorSubPrefix x y k).reverse)).take + (machineRationalVectorSubInputBound word).length) _ _ = _ + rw [show finUnaryCode i = List.replicate i.1 true by rfl, + machineRationalVectorSubEntryCode_encode] + rw [List.take_of_length_le hcandPair, hreverse] + rfl + +theorem machineRationalVectorSubIterate_semantics {d : β„•} + (x y : Fin d β†’ β„š) : βˆ€ k ≀ d, + (machineRationalVectorSubStep)^[k] + (machineRationalVectorSubInit (rationalVectorSubCanonicalWord x y)) = + machineRationalVectorSubSemanticState x y k := by + intro k hk + induction k with + | zero => exact machineRationalVectorSubInit_semantics x y + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRationalVectorSubStep_semantics x y k (by omega) + +theorem machineRationalVectorSub_done_iterate + (extra : β„•) (accumulator payload bound : List Bool) : + (machineRationalVectorSubStep)^[extra] + (machineRationalTransposeMulVectorPack [] accumulator payload bound) = + machineRationalTransposeMulVectorPack [] accumulator payload bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRationalVectorSubStep] + +theorem rationalVectorSubPrefix_all {d : β„•} + (x y : Fin d β†’ β„š) : + rationalVectorSubPrefix x y d = + List.ofFn (rationalVectorSub x y) := by + apply List.ext_getElem + Β· simp [rationalVectorSubPrefix] + Β· intro i hiLeft hiRight + simp [rationalVectorSubPrefix, List.getElem_finRange] + +theorem machineRationalVectorSubReversedCode_encode {d : β„•} + (x y : Fin d β†’ β„š) : + machineRationalVectorSubReversedCode + (rationalVectorSubCanonicalWord x y) = + binaryListCode rationalEntryBinaryCode + (List.ofFn (rationalVectorSub x y)).reverse := by + let word := rationalVectorSubCanonicalWord x y + have hd : d ≀ word.length := by + have h := machinePairFirst_length_le word + simpa only [word, rationalVectorSubCanonicalWord, + machinePairFirst_pair, List.length_replicate] using! h + have hsplit : word.length = (word.length - d) + d := by omega + change machineRationalVectorSubReversedCode word = _ + rw [machineRationalVectorSubReversedCode, + machineRationalVectorSubFinalState, hsplit, + Function.iterate_add_apply, + machineRationalVectorSubIterate_semantics x y d le_rfl] + simp only [machineRationalVectorSubSemanticState] + rw [show binaryListCode finUnaryCode ((List.finRange d).drop d) = [] by + rw [List.drop_eq_nil_of_le (by simp)] + rfl] + rw [machineRationalVectorSub_done_iterate] + simp only [machineRationalTransposeMulVectorAccumulator_pack] + rw [rationalVectorSubPrefix_all] + +@[simp] theorem machineRationalVectorSubCode_encode {d : β„•} + (x y : Fin d β†’ β„š) : + machineRationalVectorSubCode (rationalVectorSubCanonicalWord x y) = + rationalFiniteVectorCode (rationalVectorSub x y) := by + rw [machineRationalVectorSubCode, + machineRationalVectorSubReversedCode_encode, + machineListReverse_encode, List.reverse_reverse] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSum.lean new file mode 100644 index 0000000000..e5e19ce36b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRationalVectorSum.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerCertificateBoundary +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSum + +/-! +# Polynomial-time rational-vector summation + +Optimizer potentials are encoded as right-nested lists of canonical rational +entries. We reuse the verified clamped matrix fold by presenting such a list +as a one-row nested list. The semantic proof below is stated first for an +arbitrary rectangular list of rows; square matrices are not needed by the +fold itself. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +theorem machineMatrixRawSumFinalState_rows_encode + (rows : List (List β„š)) : + let word := pair [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + machineMatrixRawSumFinalState word = + machineMatrixRawSumPack [] [] + (rawRatBinaryCode (rawRatRowsSum RawRat.zero rows)) + (machineMatrixRawSumInputBound word) := by + let word := pair [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows) + let s : MatrixRawSumSemState := ⟨rows, [], RawRat.zero⟩ + have hrowsLength : + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows).length ≀ + word.length := by + simpa only [word] using! machinePairSecond_length_le word + have hinv : MatrixRawSumSemInvariant (1 + word.length) s := by + simp only [MatrixRawSumSemInvariant, s, rawRatListCost, + List.map_nil, List.sum_nil, rawRatWidth_zero, Nat.add_zero] + exact Nat.add_le_add_left + ((rawRatRowsCost_le_codeLength rows).trans hrowsLength) 1 + have hwork : matrixNonnegativeRowsWork rows ≀ word.length := + (binaryListCode_length_ge_work rows).trans hrowsLength + have hsplit : word.length = + (word.length - matrixNonnegativeRowsWork rows) + + matrixNonnegativeRowsWork rows := by omega + have hinit : machineMatrixRawSumInit word = + matrixRawSumSemCode (machineMatrixRawSumInputBound word) s := by + simp [machineMatrixRawSumInit, matrixRawSumSemCode, s, word, + binaryListCode, machineMatrixRowsWord] + change machineMatrixRawSumFinalState word = _ + rw [machineMatrixRawSumFinalState, hsplit, Function.iterate_add_apply, + hinit, machineMatrixRawSumIterate_semantics word s hinv, + matrixRawSumSem_processRows] + simp only [matrixRawSumSemCode, binaryListCode] + rw [machineMatrixRawSum_done_iterate] + +@[simp] theorem machineMatrixRawSumCode_rows_encode + (rows : List (List β„š)) : + machineMatrixRawSumCode + (pair [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) rows)) = + rawRatBinaryCode (rawRatRowsSum RawRat.zero rows) := by + rw [machineMatrixRawSumCode, + machineMatrixRawSumFinalState_rows_encode] + simp + +/-- View a canonical rational-vector word as the only row of a nested row +list. The unused matrix-dimension component is the empty word. -/ +def machineRationalVectorAsRowsWord (word : List Bool) : List Bool := + pair [] (pair word []) + +/-- Sums the encoded rational vector by viewing it as matrix rows and reusing the raw matrix-sum +machine. -/ +def machineRationalVectorRawSumCode (word : List Bool) : List Bool := + machineMatrixRawSumCode (machineRationalVectorAsRowsWord word) + +theorem machineRationalVectorAsRowsWord_mem_FP : + machineRationalVectorAsRowsWord ∈ Complexity.FP := by + exact machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP id_mem_FP (machineConst_mem_FP [])) + +theorem machineRationalVectorRawSumCode_mem_FP : + machineRationalVectorRawSumCode ∈ Complexity.FP := by + simpa only [machineRationalVectorRawSumCode] using! + machineCompose_mem_FP machineRationalVectorAsRowsWord_mem_FP + machineMatrixRawSumCode_mem_FP + +@[simp] theorem machineRationalVectorRawSumCode_encode {n : β„•} + (v : Fin n β†’ β„š) : + machineRationalVectorRawSumCode (rationalVectorBinaryCode v) = + rawRatBinaryCode + (rawRatListSum RawRat.zero (List.ofFn v)) := by + rw [machineRationalVectorRawSumCode, + machineRationalVectorAsRowsWord, rationalVectorBinaryCode] + change machineMatrixRawSumCode + (pair [] + (binaryListCode (binaryListCode rationalEntryBinaryCode) + [List.ofFn v])) = _ + rw [machineMatrixRawSumCode_rows_encode] + rfl + +theorem rawRatListSum_ofFn_value {n : β„•} (v : Fin n β†’ β„š) : + (rawRatListSum RawRat.zero (List.ofFn v)).value = βˆ‘ i, v i := by + rw [rawRatListSum_value, RawRat.value_zero, zero_add] + exact List.sum_ofFn + +theorem machineRationalVectorRawSumCode_value {n : β„•} + (v : Fin n β†’ β„š) : + RawRat.value (rawRatListSum RawRat.zero (List.ofFn v)) = βˆ‘ i, v i := + rawRatListSum_ofFn_value v + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRepeatPair.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRepeatPair.lean new file mode 100644 index 0000000000..b2499d3666 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRepeatPair.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBinaryMul +public import LeanPool.BeyondBethe.BeyondBethe.MachineFPBasics + +/-! # Machine Repeat Pair -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Polynomial-time repeated pairing + +`repeatPairCode n item tail` is the right-nested word obtained by prepending +`item` exactly `n` times to `tail`. This is the machine-level constructor for +constant rational vectors and, later, for the zero blocks of diagonal +matrices. Its iteration count is supplied in unary and its accumulator is +clamped by an explicit quadratic envelope. +-/ + +/-- Prepends `n` copies of an encoded item to the supplied tail through nested pairing. -/ +def repeatPairCode : β„• β†’ List Bool β†’ List Bool β†’ List Bool + | 0, _, tail => tail + | n + 1, item, tail => pair item (repeatPairCode n item tail) + +@[simp] theorem repeatPairCode_zero (item tail : List Bool) : + repeatPairCode 0 item tail = tail := rfl + +@[simp] theorem repeatPairCode_succ (n : β„•) (item tail : List Bool) : + repeatPairCode (n + 1) item tail = + pair item (repeatPairCode n item tail) := rfl + +theorem repeatPairCode_length (n : β„•) (item tail : List Bool) : + (repeatPairCode n item tail).length = + n * (2 * item.length + 2) + tail.length := by + induction n with + | zero => simp + | succ n ih => + rw [repeatPairCode_succ, pair_length, ih] + ring + +theorem repeatPairCode_binaryListCode {Ξ± : Type*} + (encode : Ξ± β†’ List Bool) (n : β„•) (x : Ξ±) (xs : List Ξ±) : + repeatPairCode n (encode x) (binaryListCode encode xs) = + binaryListCode encode (List.replicate n x ++ xs) := by + induction n with + | zero => simp [repeatPairCode] + | succ n ih => + rw [repeatPairCode_succ, ih] + simp only [List.replicate_succ, List.cons_append, binaryListCode] + +/-- Extracts the unary repetition ruler from a repeated-pair request. -/ +def machineRepeatPairRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the encoded item to repeat from a repeated-pair request. -/ +def machineRepeatPairItem (word : List Bool) : List Bool := + machinePairFirst (machinePairSecond word) + +/-- Extracts the encoded tail following the repeated items. -/ +def machineRepeatPairTail (word : List Bool) : List Bool := + machinePairSecond (machinePairSecond word) + +/-- Applies the binary-multiplication width construction to bound repeated pairing. -/ +def machineRepeatPairBound (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Packs the fixed repeated item, accumulated tail, and length bound. -/ +def machineRepeatPairPack + (item acc bound : List Bool) : List Bool := + pair item (pair acc bound) + +/-- Extracts the fixed item from a repeated-pair state. -/ +def machineRepeatPairStateItem (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the accumulated encoded tail from a repeated-pair state. -/ +def machineRepeatPairStateAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the length-bound word from a repeated-pair state. -/ +def machineRepeatPairStateBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Prepends one copy of the fixed item to the accumulated tail. -/ +def machineRepeatPairCandidate (state : List Bool) : List Bool := + pair (machineRepeatPairStateItem state) + (machineRepeatPairStateAcc state) + +/-- Truncates the candidate repeated-pair accumulator to the stored bound length. -/ +def machineRepeatPairNextAcc (state : List Bool) : List Bool := + (machineRepeatPairCandidate state).take + (machineRepeatPairStateBound state).length + +/-- Updates the bounded accumulator while preserving the repeated item and bound. -/ +def machineRepeatPairStep (state : List Bool) : List Bool := + machineRepeatPairPack (machineRepeatPairStateItem state) + (machineRepeatPairNextAcc state) + (machineRepeatPairStateBound state) + +/-- Initializes repeated pairing with the requested item, initial tail, and computed bound. -/ +def machineRepeatPairInit (word : List Bool) : List Bool := + machineRepeatPairPack (machineRepeatPairItem word) + (machineRepeatPairTail word) (machineRepeatPairBound word) + +/-- Packs three copies of the computed bound to bound the repeated-pair state. -/ +def machineRepeatPairWidth (word : List Bool) : List Bool := + machineRepeatPairPack (machineRepeatPairBound word) + (machineRepeatPairBound word) (machineRepeatPairBound word) + +/-- Iterates bounded pairing for the length of the unary repetition ruler. -/ +def machineRepeatPairFinalState (word : List Bool) : List Bool := + (machineRepeatPairStep)^[(machineRepeatPairRuler word).length] + (machineRepeatPairInit word) + +/-- Extracts the final repeated-pair accumulator. -/ +def machineRepeatPairCode (word : List Bool) : List Bool := + machineRepeatPairStateAcc (machineRepeatPairFinalState word) + +/-! ## Polynomial-time closure -/ + +theorem machineRepeatPairRuler_mem_FP : machineRepeatPairRuler ∈ FP := + machinePairFirst_mem_FP + +theorem machineRepeatPairItem_mem_FP : machineRepeatPairItem ∈ FP := by + simpa only [machineRepeatPairItem] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRepeatPairTail_mem_FP : machineRepeatPairTail ∈ FP := by + simpa only [machineRepeatPairTail] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRepeatPairBound_mem_FP : machineRepeatPairBound ∈ FP := + machineBinaryMulWidth_mem_FP + +theorem machineRepeatPairStateItem_mem_FP : + machineRepeatPairStateItem ∈ FP := machinePairFirst_mem_FP + +theorem machineRepeatPairStateAcc_mem_FP : + machineRepeatPairStateAcc ∈ FP := by + simpa only [machineRepeatPairStateAcc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRepeatPairStateBound_mem_FP : + machineRepeatPairStateBound ∈ FP := by + simpa only [machineRepeatPairStateBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineRepeatPairCandidate_mem_FP : + machineRepeatPairCandidate ∈ FP := + machinePair_mem_FP machineRepeatPairStateItem_mem_FP + machineRepeatPairStateAcc_mem_FP + +theorem machineRepeatPairNextAcc_mem_FP : + machineRepeatPairNextAcc ∈ FP := by + simpa only [machineRepeatPairNextAcc] using! + machineTake_mem_FP machineRepeatPairStateBound_mem_FP + machineRepeatPairCandidate_mem_FP + +theorem machineRepeatPairStep_mem_FP : machineRepeatPairStep ∈ FP := + machinePair_mem_FP machineRepeatPairStateItem_mem_FP + (machinePair_mem_FP machineRepeatPairNextAcc_mem_FP + machineRepeatPairStateBound_mem_FP) + +theorem machineRepeatPairInit_mem_FP : machineRepeatPairInit ∈ FP := + machinePair_mem_FP machineRepeatPairItem_mem_FP + (machinePair_mem_FP machineRepeatPairTail_mem_FP + machineRepeatPairBound_mem_FP) + +theorem machineRepeatPairWidth_mem_FP : machineRepeatPairWidth ∈ FP := + machinePair_mem_FP machineRepeatPairBound_mem_FP + (machinePair_mem_FP machineRepeatPairBound_mem_FP + machineRepeatPairBound_mem_FP) + +@[simp] theorem machineRepeatPairStateItem_pack (a b c) : + machineRepeatPairStateItem (machineRepeatPairPack a b c) = a := by + simp [machineRepeatPairStateItem, machineRepeatPairPack] + +@[simp] theorem machineRepeatPairStateAcc_pack (a b c) : + machineRepeatPairStateAcc (machineRepeatPairPack a b c) = b := by + simp [machineRepeatPairStateAcc, machineRepeatPairPack] + +@[simp] theorem machineRepeatPairStateBound_pack (a b c) : + machineRepeatPairStateBound (machineRepeatPairPack a b c) = c := by + simp [machineRepeatPairStateBound, machineRepeatPairPack] + +/-- Requires exact repeated-pair state packing and bounds all three field lengths by the +input-derived bound. -/ +def MachineRepeatPairStateBound (word state : List Bool) : Prop := + let B := (machineRepeatPairBound word).length + state = machineRepeatPairPack + (machineRepeatPairStateItem state) + (machineRepeatPairStateAcc state) + (machineRepeatPairStateBound state) ∧ + (machineRepeatPairStateItem state).length ≀ B ∧ + (machineRepeatPairStateAcc state).length ≀ B ∧ + (machineRepeatPairStateBound state).length ≀ B + +theorem machineRepeatPair_word_length_le_bound (word : List Bool) : + word.length ≀ (machineRepeatPairBound word).length := by + simp only [machineRepeatPairBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +theorem machineRepeatPairInit_bound (word : List Bool) : + MachineRepeatPairStateBound word (machineRepeatPairInit word) := by + simp only [MachineRepeatPairStateBound, machineRepeatPairInit, + machineRepeatPairStateItem_pack, machineRepeatPairStateAcc_pack, + machineRepeatPairStateBound_pack] + refine ⟨trivial, ?_, ?_, le_rfl⟩ + Β· exact (machinePairFirst_length_le (machinePairSecond word)).trans + ((machinePairSecond_length_le word).trans + (machineRepeatPair_word_length_le_bound word)) + Β· exact (machinePairSecond_length_le (machinePairSecond word)).trans + ((machinePairSecond_length_le word).trans + (machineRepeatPair_word_length_le_bound word)) + +theorem machineRepeatPairStep_bound {word state : List Bool} + (hstate : MachineRepeatPairStateBound word state) : + MachineRepeatPairStateBound word (machineRepeatPairStep state) := by + dsimp only [MachineRepeatPairStateBound] at hstate ⊒ + rcases hstate with ⟨_, hitem, _hacc, hbound⟩ + simp only [machineRepeatPairStep, machineRepeatPairStateItem_pack, + machineRepeatPairStateAcc_pack, machineRepeatPairStateBound_pack] + refine ⟨trivial, hitem, ?_, hbound⟩ + exact (List.length_take_le _ _).trans hbound + +theorem machineRepeatPairIterate_bound (word : List Bool) : βˆ€ k, + MachineRepeatPairStateBound word + ((machineRepeatPairStep)^[k] (machineRepeatPairInit word)) := by + intro k + induction k with + | zero => exact machineRepeatPairInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRepeatPairStep_bound ih + +theorem machineRepeatPairIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineRepeatPairRuler word).length) : + ((machineRepeatPairStep)^[iterations] + (machineRepeatPairInit word)).length ≀ + (machineRepeatPairWidth word).length := by + rcases machineRepeatPairIterate_bound word iterations with + ⟨hdecomp, hitem, hacc, hbound⟩ + rw [hdecomp] + simp only [machineRepeatPairPack, machineRepeatPairWidth, pair_length] + omega + +theorem machineRepeatPairFinalState_mem_FP : + machineRepeatPairFinalState ∈ FP := + Cobham.iterate_mem_FP machineRepeatPairStep_mem_FP + machineRepeatPairInit_mem_FP machineRepeatPairRuler_mem_FP + machineRepeatPairWidth_mem_FP machineRepeatPairIterate_length_le_width + +theorem machineRepeatPairCode_mem_FP : machineRepeatPairCode ∈ FP := by + simpa only [machineRepeatPairCode] using! + machineCompose_mem_FP machineRepeatPairFinalState_mem_FP + machineRepeatPairStateAcc_mem_FP + +/-! ## Exact semantics on well-formed unary calls -/ + +/-- Encodes unary repetition count `n` followed by the item and initial tail. -/ +def machineRepeatPairCanonicalInput + (n : β„•) (item tail : List Bool) : List Bool := + pair (List.replicate n true) (pair item tail) + +/-- Encodes the semantic state containing `k` repeated items before the original tail. -/ +def machineRepeatPairCanonicalState + (n : β„•) (item tail : List Bool) (k : β„•) : List Bool := + let word := machineRepeatPairCanonicalInput n item tail + machineRepeatPairPack item (repeatPairCode k item tail) + (machineRepeatPairBound word) + +theorem machineRepeatPair_candidate_length_le_bound + (n k : β„•) (item tail : List Bool) (hk : k + 1 ≀ n) : + (pair item (repeatPairCode k item tail)).length ≀ + (machineRepeatPairBound + (machineRepeatPairCanonicalInput n item tail)).length := by + let W := (machineRepeatPairCanonicalInput n item tail).length + have hnW : n ≀ W := by + simp only [W, machineRepeatPairCanonicalInput, pair_length, + List.length_replicate] + omega + have hiW : 2 * item.length + 2 ≀ W := by + simp only [W, machineRepeatPairCanonicalInput, pair_length, + List.length_replicate] + omega + have htW : tail.length ≀ W := by + simp only [W, machineRepeatPairCanonicalInput, pair_length, + List.length_replicate] + omega + have hkW : k + 1 ≀ W := hk.trans hnW + have hproduct := Nat.mul_le_mul hkW hiW + rw [pair_length, repeatPairCode_length] + simp only [machineRepeatPairBound, machineBinaryMulWidth, + List.length_replicate, List.length_append] + change 2 * item.length + 2 + + (k * (2 * item.length + 2) + tail.length) ≀ + (16 + W) * (16 + W) + calc + 2 * item.length + 2 + + (k * (2 * item.length + 2) + tail.length) = + (k + 1) * (2 * item.length + 2) + tail.length := by ring + _ ≀ W * W + W := Nat.add_le_add hproduct htW + _ ≀ (16 + W) * (16 + W) := by nlinarith + +theorem machineRepeatPairInit_semantics + (n : β„•) (item tail : List Bool) : + machineRepeatPairInit (machineRepeatPairCanonicalInput n item tail) = + machineRepeatPairCanonicalState n item tail 0 := by + simp [machineRepeatPairInit, machineRepeatPairCanonicalInput, + machineRepeatPairCanonicalState, machineRepeatPairItem, + machineRepeatPairTail] + +theorem machineRepeatPairStep_semantics + (n k : β„•) (item tail : List Bool) (hk : k < n) : + machineRepeatPairStep + (machineRepeatPairCanonicalState n item tail k) = + machineRepeatPairCanonicalState n item tail (k + 1) := by + have hbound := machineRepeatPair_candidate_length_le_bound + n k item tail (by omega) + have htake : + (pair item (repeatPairCode k item tail)).take + (machineRepeatPairBound + (machineRepeatPairCanonicalInput n item tail)).length = + pair item (repeatPairCode k item tail) := + List.take_of_length_le hbound + simp only [machineRepeatPairStep, machineRepeatPairCanonicalState, + machineRepeatPairStateItem_pack, machineRepeatPairStateAcc_pack, + machineRepeatPairStateBound_pack, machineRepeatPairNextAcc, + machineRepeatPairCandidate] + rw [htake] + rfl + +theorem machineRepeatPairIterate_semantics + (n : β„•) (item tail : List Bool) : βˆ€ k ≀ n, + (machineRepeatPairStep)^[k] + (machineRepeatPairInit + (machineRepeatPairCanonicalInput n item tail)) = + machineRepeatPairCanonicalState n item tail k := by + intro k hk + induction k with + | zero => exact machineRepeatPairInit_semantics n item tail + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineRepeatPairStep_semantics n k item tail (by omega) + +@[simp] theorem machineRepeatPairCode_encode + (n : β„•) (item tail : List Bool) : + machineRepeatPairCode (machineRepeatPairCanonicalInput n item tail) = + repeatPairCode n item tail := by + have hstate := congrArg machineRepeatPairStateAcc + (machineRepeatPairIterate_semantics n item tail n le_rfl) + simpa [machineRepeatPairCode, machineRepeatPairFinalState, + machineRepeatPairRuler, machineRepeatPairCanonicalInput, + machineRepeatPairCanonicalState] using! hstate + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRowComplementUpperSum.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRowComplementUpperSum.lean new file mode 100644 index 0000000000..62ad349366 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRowComplementUpperSum.lean @@ -0,0 +1,774 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyMatrixSum + +/-! +# A directed upper logarithm sum for one matrix row + +The four-core eligibility test repeatedly uses + +`sum_k scheduledLogUpper (1 - X i k) p`. + +This module realizes that row sum directly on the canonical optimizer word. +The input is `pair rowUnary optimizerWord`. As in the matrix-wide nearby +sum, the transducer is total on arbitrary strings and clamps its unreduced +rational accumulator by an explicit degree-eight word. The semantic proof +shows that the clamp is inactive on every canonical in-range row query. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Packs the source request, unprocessed row, raw upper-sum accumulator, and bound. -/ +def machineRowUpperPack + (source current acc bound : List Bool) : List Bool := + pair source (pair current (pair acc bound)) + +/-- Extracts the fixed request from a row-complement upper-sum state. -/ +def machineRowUpperSource (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unprocessed row suffix from a row-complement upper-sum state. -/ +def machineRowUpperCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the raw accumulated upper sum from the row scan state. -/ +def machineRowUpperAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the accumulator length-bound word from the row scan state. -/ +def machineRowUpperBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond state)) + +/-- Extracts the unary selected-row index from a row-complement upper-sum request. -/ +def machineRowUpperRowRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the optimizer payload from a row-complement upper-sum request. -/ +def machineRowUpperOptimizerWord (word : List Bool) : List Bool := + machinePairSecond word + +/-- Reads the encoded matrix from the optimizer payload of the row-sum request. -/ +def machineRowUpperMatrixWord (word : List Bool) : List Bool := + machineOptimizerMatrixWord (machineRowUpperOptimizerWord word) + +/-- Looks up the selected matrix row to initialize the upper-sum scan. -/ +def machineRowUpperInitialRow (word : List Bool) : List Bool := + machineListIndex + (pair (machineRowUpperRowRuler word) + (machineMatrixRowsWord (machineRowUpperMatrixWord word))) + +/-- Reads the next rational entry of the current row suffix. -/ +def machineRowUpperEntry (state : List Bool) : List Bool := + machineListHead (machineRowUpperCurrent state) + +/-- Packages certificate precision, zero reference parameter, and current entry for complement +evaluation. -/ +def machineRowUpperComplementInput (state : List Bool) : List Bool := + pair + (machineCertificateLogPrecisionRuler + (machineRowUpperOptimizerWord (machineRowUpperSource state))) + (pair (rawRatBinaryCode RawRat.zero) (machineRowUpperEntry state)) + +/-- Computes the normalized complement of the current row entry. -/ +def machineRowUpperComplementCode (state : List Bool) : List Bool := + machineNearbyCoordinateComplementCode + (machineRowUpperComplementInput state) + +/-- Computes the scheduled upper logarithm approximation of the current entry's complement at +certificate precision. -/ +def machineRowUpperLogRawCode (state : List Bool) : List Bool := + machineScheduledLogUpperRawCode + (pair + (machineCertificateLogPrecisionRuler + (machineRowUpperOptimizerWord (machineRowUpperSource state))) + (machineRowUpperComplementCode state)) + +/-- Adds the current complement-logarithm upper approximation to the raw accumulator. -/ +def machineRowUpperCandidate (state : List Bool) : List Bool := + machineRawRatAddCode + (pair (machineRowUpperAcc state) (machineRowUpperLogRawCode state)) + +/-- Truncates the updated upper-sum accumulator to the stored bound length. -/ +def machineRowUpperNextAcc (state : List Bool) : List Bool := + (machineRowUpperCandidate state).take (machineRowUpperBound state).length + +/-- Fixes an exhausted row scan and otherwise consumes one entry while accumulating its bounded +upper logarithm term. -/ +def machineRowUpperStep (state : List Bool) : List Bool := + machineIfEmpty (machineRowUpperCurrent state) state + (machineRowUpperPack + (machineRowUpperSource state) + (machineListTail (machineRowUpperCurrent state)) + (machineRowUpperNextAcc state) + (machineRowUpperBound state)) + +/-- Applies the binary-multiplication width construction three times to bound the row-complement +upper sum. -/ +def machineRowUpperInputBound (word : List Bool) : List Bool := + machineBinaryMulWidth + (machineBinaryMulWidth (machineBinaryMulWidth word)) + +/-- Initializes the row scan with its fixed request, selected matrix row, zero accumulator, and +computed bound. -/ +def machineRowUpperInit (word : List Bool) : List Bool := + machineRowUpperPack word (machineRowUpperInitialRow word) + (rawRatBinaryCode RawRat.zero) (machineRowUpperInputBound word) + +/-- Packs two input words and two bound words to bound the upper-sum scan state. -/ +def machineRowUpperWidth (word : List Bool) : List Bool := + let bound := machineRowUpperInputBound word + machineRowUpperPack word word bound bound + +/-- Runs the row-complement upper-sum scan once per input bit from its initial state. -/ +def machineRowUpperFinalState (word : List Bool) : List Bool := + (machineRowUpperStep)^[word.length] (machineRowUpperInit word) + +/-- Canonical raw-rational code for the directed upper complement-log row +sum, on every canonical in-range query. -/ +def machineRowComplementUpperSumRawCode (word : List Bool) : List Bool := + machineRowUpperAcc (machineRowUpperFinalState word) + +theorem machineRowUpperSource_mem_FP : machineRowUpperSource ∈ FP := + machinePairFirst_mem_FP + +theorem machineRowUpperCurrent_mem_FP : machineRowUpperCurrent ∈ FP := by + simpa only [machineRowUpperCurrent] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineRowUpperAcc_mem_FP : machineRowUpperAcc ∈ FP := by + simpa only [machineRowUpperAcc] using! machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairFirst_mem_FP + +theorem machineRowUpperBound_mem_FP : machineRowUpperBound ∈ FP := by + simpa only [machineRowUpperBound] using! machineCompose_mem_FP + (machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP) + machinePairSecond_mem_FP + +theorem machineRowUpperRowRuler_mem_FP : machineRowUpperRowRuler ∈ FP := + machinePairFirst_mem_FP + +theorem machineRowUpperOptimizerWord_mem_FP : + machineRowUpperOptimizerWord ∈ FP := machinePairSecond_mem_FP + +theorem machineRowUpperMatrixWord_mem_FP : machineRowUpperMatrixWord ∈ FP := by + simpa only [machineRowUpperMatrixWord] using! machineCompose_mem_FP + machineRowUpperOptimizerWord_mem_FP machineOptimizerMatrixWord_mem_FP + +theorem machineRowUpperInitialRow_mem_FP : machineRowUpperInitialRow ∈ FP := by + have hrows := machineCompose_mem_FP machineRowUpperMatrixWord_mem_FP + machineMatrixRowsWord_mem_FP + have hpair := machinePair_mem_FP machineRowUpperRowRuler_mem_FP hrows + simpa only [machineRowUpperInitialRow] using! + machineCompose_mem_FP hpair machineListIndex_mem_FP + +theorem machineRowUpperEntry_mem_FP : machineRowUpperEntry ∈ FP := by + simpa only [machineRowUpperEntry] using! machineCompose_mem_FP + machineRowUpperCurrent_mem_FP machineListHead_mem_FP + +theorem machineRowUpperComplementInput_mem_FP : + machineRowUpperComplementInput ∈ FP := by + have hsourceOptimizer := machineCompose_mem_FP machineRowUpperSource_mem_FP + machineRowUpperOptimizerWord_mem_FP + have hp := machineCompose_mem_FP hsourceOptimizer + machineCertificateLogPrecisionRuler_mem_FP + exact machinePair_mem_FP hp + (machinePair_mem_FP (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineRowUpperEntry_mem_FP) + +theorem machineRowUpperComplementCode_mem_FP : + machineRowUpperComplementCode ∈ FP := by + simpa only [machineRowUpperComplementCode] using! machineCompose_mem_FP + machineRowUpperComplementInput_mem_FP + machineNearbyCoordinateComplementCode_mem_FP + +theorem machineRowUpperLogRawCode_mem_FP : machineRowUpperLogRawCode ∈ FP := by + have hsourceOptimizer := machineCompose_mem_FP machineRowUpperSource_mem_FP + machineRowUpperOptimizerWord_mem_FP + have hp := machineCompose_mem_FP hsourceOptimizer + machineCertificateLogPrecisionRuler_mem_FP + have hpair := machinePair_mem_FP hp machineRowUpperComplementCode_mem_FP + simpa only [machineRowUpperLogRawCode] using! machineCompose_mem_FP hpair + machineScheduledLogUpperRawCode_mem_FP + +theorem machineRowUpperCandidate_mem_FP : machineRowUpperCandidate ∈ FP := by + have hpair := machinePair_mem_FP machineRowUpperAcc_mem_FP + machineRowUpperLogRawCode_mem_FP + simpa only [machineRowUpperCandidate] using! machineCompose_mem_FP hpair + machineRawRatAddCode_mem_FP + +theorem machineRowUpperNextAcc_mem_FP : machineRowUpperNextAcc ∈ FP := by + simpa only [machineRowUpperNextAcc] using! machineTake_mem_FP + machineRowUpperBound_mem_FP machineRowUpperCandidate_mem_FP + +theorem machineRowUpperStep_mem_FP : machineRowUpperStep ∈ FP := by + have htail := machineCompose_mem_FP machineRowUpperCurrent_mem_FP + machineListTail_mem_FP + have helse := machinePair_mem_FP machineRowUpperSource_mem_FP + (machinePair_mem_FP htail + (machinePair_mem_FP machineRowUpperNextAcc_mem_FP + machineRowUpperBound_mem_FP)) + exact machineIfEmpty_mem_FP machineRowUpperCurrent_mem_FP id_mem_FP helse + +theorem machineRowUpperInputBound_mem_FP : machineRowUpperInputBound ∈ FP := by + have h1 := machineBinaryMulWidth_mem_FP + have h2 := machineCompose_mem_FP h1 machineBinaryMulWidth_mem_FP + simpa only [machineRowUpperInputBound] using! + machineCompose_mem_FP h2 machineBinaryMulWidth_mem_FP + +theorem machineRowUpperInit_mem_FP : machineRowUpperInit ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRowUpperInitialRow_mem_FP + (machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.zero)) + machineRowUpperInputBound_mem_FP)) + +theorem machineRowUpperWidth_mem_FP : machineRowUpperWidth ∈ FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP id_mem_FP + (machinePair_mem_FP machineRowUpperInputBound_mem_FP + machineRowUpperInputBound_mem_FP)) + +@[simp] theorem machineRowUpperSource_pack (source current acc bound) : + machineRowUpperSource (machineRowUpperPack source current acc bound) = + source := by simp [machineRowUpperSource, machineRowUpperPack] + +@[simp] theorem machineRowUpperCurrent_pack (source current acc bound) : + machineRowUpperCurrent (machineRowUpperPack source current acc bound) = + current := by simp [machineRowUpperCurrent, machineRowUpperPack] + +@[simp] theorem machineRowUpperAcc_pack (source current acc bound) : + machineRowUpperAcc (machineRowUpperPack source current acc bound) = acc := by + simp [machineRowUpperAcc, machineRowUpperPack] + +@[simp] theorem machineRowUpperBound_pack (source current acc bound) : + machineRowUpperBound (machineRowUpperPack source current acc bound) = + bound := by simp [machineRowUpperBound, machineRowUpperPack] + +/-- Requires exact row-scan packing, the original source, input-bounded current row, bounded +accumulator, and prescribed bound word. -/ +def MachineRowUpperStateBound (word state : List Bool) : Prop := + state = machineRowUpperPack (machineRowUpperSource state) + (machineRowUpperCurrent state) (machineRowUpperAcc state) + (machineRowUpperBound state) ∧ + machineRowUpperSource state = word ∧ + (machineRowUpperCurrent state).length ≀ word.length ∧ + (machineRowUpperAcc state).length ≀ + (machineRowUpperInputBound word).length ∧ + machineRowUpperBound state = machineRowUpperInputBound word + +theorem machineRowUpperInit_bound (word : List Bool) : + MachineRowUpperStateBound word (machineRowUpperInit word) := by + simp only [MachineRowUpperStateBound, machineRowUpperInit, + machineRowUpperSource_pack, machineRowUpperCurrent_pack, + machineRowUpperAcc_pack, machineRowUpperBound_pack] + refine ⟨trivial, trivial, ?_, ?_, trivial⟩ + Β· have hindex := machineListIndex_length_le_data + (pair (machineRowUpperRowRuler word) + (machineMatrixRowsWord (machineRowUpperMatrixWord word))) + simp only [machineListIndexData, machinePairSecond_pair] at hindex + exact hindex.trans + ((machinePairSecond_length_le + (machineRowUpperMatrixWord word)).trans + ((machinePairFirst_length_le + (machineRowUpperOptimizerWord word)).trans + (machinePairSecond_length_le word))) + Β· simp [machineRowUpperInputBound, machineBinaryMulWidth, + rawRatBinaryCode, RawRat.zero, integerBinaryCode] + nlinarith [sq_nonneg (word.length + 16)] + +theorem machineRowUpperStep_bound {word state : List Bool} + (hstate : MachineRowUpperStateBound word state) : + MachineRowUpperStateBound word (machineRowUpperStep state) := by + rcases hstate with ⟨hdecomp, hsource, hcurrent, hacc, hbound⟩ + by_cases hc : machineRowUpperCurrent state = [] + Β· rw [machineRowUpperStep, hc, machineIfEmpty_nil] + exact ⟨hdecomp, hsource, hcurrent, hacc, hbound⟩ + Β· rw [machineRowUpperStep] + cases hcode : machineRowUpperCurrent state with + | nil => exact False.elim (hc hcode) + | cons bit tail => + rw [machineIfEmpty_cons] + simp only [MachineRowUpperStateBound, + machineRowUpperSource_pack, machineRowUpperCurrent_pack, + machineRowUpperAcc_pack, machineRowUpperBound_pack] + refine ⟨trivial, hsource, ?_, ?_, hbound⟩ + Β· have htail := machineListTail_length_le + (machineRowUpperCurrent state) + rw [hcode] at htail + rw [hcode] at hcurrent + exact htail.trans hcurrent + Β· rw [machineRowUpperNextAcc, hbound] + exact List.length_take_le _ _ + +theorem machineRowUpperIterate_bound (word : List Bool) : βˆ€ k, + MachineRowUpperStateBound word + ((machineRowUpperStep)^[k] (machineRowUpperInit word)) := by + intro k + induction k with + | zero => exact machineRowUpperInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineRowUpperStep_bound ih + +theorem machineRowUpperIterate_length_le_width + (word : List Bool) (iterations : β„•) (_ : iterations ≀ word.length) : + ((machineRowUpperStep)^[iterations] + (machineRowUpperInit word)).length ≀ (machineRowUpperWidth word).length := by + rcases machineRowUpperIterate_bound word iterations with + ⟨hdecomp, hsource, hcurrent, hacc, hbound⟩ + rw [hdecomp, hsource, hbound] + simp only [machineRowUpperPack, machineRowUpperWidth, pair_length] + omega + +theorem machineRowUpperFinalState_mem_FP : machineRowUpperFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineRowUpperStep_mem_FP + machineRowUpperInit_mem_FP id_mem_FP machineRowUpperWidth_mem_FP + machineRowUpperIterate_length_le_width + +theorem machineRowComplementUpperSumRawCode_mem_FP : + machineRowComplementUpperSumRawCode ∈ FP := by + simpa only [machineRowComplementUpperSumRawCode] using! machineCompose_mem_FP + machineRowUpperFinalState_mem_FP machineRowUpperAcc_mem_FP + +/-! ## Exact semantics -/ + +/-- Sums the raw widths of scheduled upper complement logarithms, adding one per row entry for +accumulator growth. -/ +def rawRowComplementUpperCost (p : β„•) (xs : List β„š) : β„• := + (xs.map fun q => rawRatWidth (rawScheduledLogUpper (1 - q) p) + 1).sum + +/-- Accumulates scheduled upper logarithms of entry complements from left to right at precision +`p`. -/ +def rawRowComplementUpperSum (p : β„•) : RawRat β†’ List β„š β†’ RawRat + | acc, [] => acc + | acc, q :: qs => + rawRowComplementUpperSum p + (acc.add (rawScheduledLogUpper (1 - q) p)) qs + +structure RowUpperSemState where + /-- The unprocessed rational row suffix of the semantic upper-sum scan. -/ + current : List β„š + /-- The raw rational accumulator of the semantic row upper-sum scan. -/ + acc : RawRat + +/-- Adds one scheduled upper complement logarithm and consumes its entry, fixing an exhausted +semantic state. -/ +def rowUpperSemStep (p : β„•) (s : RowUpperSemState) : RowUpperSemState := + match s.current with + | [] => s + | q :: qs => ⟨qs, s.acc.add (rawScheduledLogUpper (1 - q) p)⟩ + +/-- Encodes a semantic remaining row and raw upper-sum accumulator with the supplied source and +bound. -/ +def rowUpperSemCode (source bound : List Bool) + (s : RowUpperSemState) : List Bool := + machineRowUpperPack source + (binaryListCode rationalEntryBinaryCode s.current) + (rawRatBinaryCode s.acc) bound + +/-- Bounds the raw upper-sum accumulator width plus all remaining logarithm-term costs by the +supplied budget. -/ +def RowUpperSemInvariant (p budget : β„•) (s : RowUpperSemState) : Prop := + rawRatWidth s.acc + rawRowComplementUpperCost p s.current ≀ budget + +theorem rowUpperSemStep_invariant {p budget : β„•} {s : RowUpperSemState} + (hs : RowUpperSemInvariant p budget s) : + RowUpperSemInvariant p budget (rowUpperSemStep p s) := by + rcases s with ⟨current, acc⟩ + cases current with + | nil => exact hs + | cons q qs => + have hadd := rawRatWidth_add_le acc + (rawScheduledLogUpper (1 - q) p) + simp only [RowUpperSemInvariant, rowUpperSemStep, + rawRowComplementUpperCost, List.map_cons, List.sum_cons] at hs ⊒ + omega + +@[simp] theorem machineRowUpperInitialRow_encode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) (i : Fin n) : + machineRowUpperInitialRow + (pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + binaryListCode rationalEntryBinaryCode (List.ofFn (X i)) := by + rw [machineRowUpperInitialRow] + simp only [machineRowUpperRowRuler, machinePairFirst_pair, + machineRowUpperMatrixWord, machineRowUpperOptimizerWord, + machinePairSecond_pair, machineOptimizerMatrixWord_encode, + machineMatrixRowsWord_encode] + rw [machineListIndex_binaryListCode] + Β· simp [rationalMatrixRows, List.getElem_ofFn] + Β· simp [rationalMatrixRows] + +@[simp] theorem machineRowUpperComplementCode_semCode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rowRuler : List Bool) (q : β„š) (qs : List β„š) (acc : RawRat) + (bound : List Bool) : + machineRowUpperComplementCode + (rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound + ⟨q :: qs, acc⟩) = + rawRatBinaryCode (rawRatOfRat (1 - q)) := by + rw [machineRowUpperComplementCode, machineRowUpperComplementInput] + simp only [rowUpperSemCode, machineRowUpperSource_pack, + machineRowUpperOptimizerWord, machinePairSecond_pair, + machineCertificateLogPrecisionRuler_encode, machineRowUpperEntry, + machineRowUpperCurrent_pack, machineListHead_cons, + machineNearbyCoordinateComplementCode_encode] + +@[simp] theorem machineRowUpperLogRawCode_semCode {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rowRuler : List Bool) (q : β„š) (qs : List β„š) (acc : RawRat) + (bound : List Bool) : + machineRowUpperLogRawCode + (rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound + ⟨q :: qs, acc⟩) = + rawRatBinaryCode + (rawScheduledLogUpper (1 - q) (directedCertificatePrecision n)) := by + have hcomp := machineRowUpperComplementCode_semCode + X R C rowRuler q qs acc bound + dsimp only [rowUpperSemCode] at hcomp + rw [machineRowUpperLogRawCode] + simp only [rowUpperSemCode, machineRowUpperSource_pack, + machineRowUpperOptimizerWord, machinePairSecond_pair, + machineCertificateLogPrecisionRuler_encode] + rw [hcomp, machineScheduledLogUpperRawCode_encode] + +theorem machineRowUpperStep_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rowRuler bound : List Bool) (s : RowUpperSemState) (budget : β„•) + (hs : RowUpperSemInvariant (directedCertificatePrecision n) budget s) + (hlarge : 4 + 3 * budget ≀ bound.length) : + machineRowUpperStep + (rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound s) = + rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound + (rowUpperSemStep (directedCertificatePrecision n) s) := by + rcases s with ⟨current, acc⟩ + cases current with + | nil => + simp [rowUpperSemCode, rowUpperSemStep, machineRowUpperStep, + binaryListCode] + | cons q qs => + have hlog := machineRowUpperLogRawCode_semCode + X R C rowRuler q qs acc bound + dsimp only [rowUpperSemCode] at hlog + have hnext : rawRatWidth + (acc.add (rawScheduledLogUpper (1 - q) + (directedCertificatePrecision n))) ≀ budget := by + have hinv := rowUpperSemStep_invariant hs + have hinv' : rawRatWidth + (acc.add (rawScheduledLogUpper (1 - q) + (directedCertificatePrecision n))) + + rawRowComplementUpperCost (directedCertificatePrecision n) qs ≀ + budget := by + simpa only [RowUpperSemInvariant, rowUpperSemStep] using! hinv + omega + have hcode : + (rawRatBinaryCode + (acc.add (rawScheduledLogUpper (1 - q) + (directedCertificatePrecision n)))).length ≀ bound.length := + (rawRatBinaryCode_length_le_width _).trans + ((Nat.add_le_add_left (Nat.mul_le_mul_left 3 hnext) 4).trans hlarge) + rw [rowUpperSemCode, rowUpperSemStep, machineRowUpperStep] + simp only [machineRowUpperCurrent_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil rationalEntryBinaryCode q qs)] + simp only [machineRowUpperSource_pack, machineRowUpperCurrent_pack, + machineRowUpperAcc_pack, machineRowUpperBound_pack, + machineListTail_cons, machineRowUpperNextAcc, + machineRowUpperCandidate] + rw [hlog] + rw [machineRawRatAddCode_encode] + rw [(List.take_eq_self_iff _).mpr hcode] + rfl + +theorem machineRowUpperIterate_semantics {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (rowRuler bound : List Bool) (s : RowUpperSemState) (budget : β„•) + (hs : RowUpperSemInvariant (directedCertificatePrecision n) budget s) + (hlarge : 4 + 3 * budget ≀ bound.length) : βˆ€ k, + (machineRowUpperStep)^[k] + (rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound s) = + rowUpperSemCode + (pair rowRuler (rationalOptimizerOutputCode ⟨X, R, C⟩)) bound + ((rowUpperSemStep (directedCertificatePrecision n))^[k] s) := by + intro k + have hinv : βˆ€ t, RowUpperSemInvariant (directedCertificatePrecision n) + budget ((rowUpperSemStep (directedCertificatePrecision n))^[t] s) := by + intro t + induction t with + | zero => exact hs + | succ t iht => + rw [Function.iterate_succ_apply'] + exact rowUpperSemStep_invariant iht + induction k with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih] + exact machineRowUpperStep_semantics X R C rowRuler bound _ budget + (hinv k) hlarge + +theorem rowUpperSem_processList (p : β„•) (xs : List β„š) (acc : RawRat) : + (rowUpperSemStep p)^[xs.length] ⟨xs, acc⟩ = + ⟨[], rawRowComplementUpperSum p acc xs⟩ := by + induction xs generalizing acc with + | nil => rfl + | cons q qs ih => + rw [List.length_cons, Function.iterate_succ_apply, + rowUpperSemStep, ih] + rfl + +theorem machineRowUpper_done_iterate + (extra : β„•) (source : List Bool) (acc : RawRat) (bound : List Bool) : + (machineRowUpperStep)^[extra] + (machineRowUpperPack source [] (rawRatBinaryCode acc) bound) = + machineRowUpperPack source [] (rawRatBinaryCode acc) bound := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineRowUpperStep] + +/-- Provides the explicit polynomial width budget for an upper complement-logarithm term from an +input-width bound `L`. -/ +def rawRowComplementUpperInputWidthBudget (L : β„•) : β„• := + 64 * ((L + 400) + 2 * (44 + 12 * L) + 4) ^ 2 * + ((44 + 12 * L) + 2) + +theorem rawScheduledLogUpper_complement_width_le_query + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i j : Fin n) : + rawRatWidth (rawScheduledLogUpper (1 - X i j) + (directedCertificatePrecision n)) ≀ + rawRowComplementUpperInputWidthBudget + (pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)).length := by + let optimizer := rationalOptimizerOutputCode ⟨X, R, C⟩ + let word := pair (List.replicate i.1 true) optimizer + let L := word.length + have hentryCode : (rationalEntryBinaryCode (X i j)).length ≀ + optimizer.length := by + have hrow : List.ofFn (X i) ∈ rationalMatrixRows X := by + simp [rationalMatrixRows] + have hq : X i j ∈ List.ofFn (X i) := by simp + have hqCode := binaryListCode_element_length_le rationalEntryBinaryCode hq + have hrowCode := binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hrow + have hrowsCode : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (rationalMatrixRows X)).length ≀ optimizer.length := by + calc + _ = (machineMatrixRowsWord + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩)).length := by + simpa using! congrArg List.length (machineMatrixRowsWord_encode X).symm + _ ≀ (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length := by + simpa only [machineMatrixRowsWord] using! machinePairSecond_length_le + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩) + _ ≀ optimizer.length := by + simpa only [optimizer, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le optimizer + exact hqCode.trans (hrowCode.trans hrowsCode) + have hxWidth : rawRatWidth (rawRatOfRat (X i j)) ≀ L := by + have hentryRaw : + (rawRatBinaryCode (rawRatOfRat (X i j))).length ≀ optimizer.length := by + simpa only [rawRatBinaryCode_rawRatOfRat] using! hentryCode + have hoptimizerWord : optimizer.length ≀ word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact (rawRatWidth_le_binaryCode_length _).trans + (hentryRaw.trans hoptimizerWord) + have hcomp := rawRatWidth_complement_le (X i j) + have hcompL : rawRatWidth (rawRatOfRat (1 - X i j)) ≀ 44 + 12 * L := by + omega + have hn := matrix_dimension_le_code_length X + have hnL : n ≀ L := by + have hmatrix : + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length ≀ optimizer.length := by + simpa only [optimizer, rationalOptimizerOutputCode, + machinePairFirst_pair] using! machinePairFirst_length_le optimizer + have hoptimizerWord : optimizer.length ≀ word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact hn.trans (hmatrix.trans hoptimizerWord) + have hp : directedCertificatePrecision n ≀ L + 400 := by + rw [directedCertificatePrecision] + omega + simpa only [rawRowComplementUpperInputWidthBudget, L] using! + rawRatWidth_scheduledLogUpper_of_bounds_le (1 - X i j) hp hcompL + +theorem rawRowComplementUpperCost_le_query + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) : + rawRowComplementUpperCost (directedCertificatePrecision n) + (List.ofFn (X i)) ≀ + (pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)).length * + (rawRowComplementUpperInputWidthBudget + (pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)).length + 1) := by + let word := pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩) + let budget := rawRowComplementUpperInputWidthBudget word.length + have hpoint : βˆ€ q ∈ List.ofFn (X i), + rawRatWidth (rawScheduledLogUpper (1 - q) + (directedCertificatePrecision n)) ≀ budget := by + intro q hq + obtain ⟨j, rfl⟩ := List.mem_ofFn.mp hq + simpa only [word, budget] using! + rawScheduledLogUpper_complement_width_le_query X R C i j + have rawCost_le_uniform : βˆ€ xs : List β„š, + (βˆ€ q ∈ xs, rawRatWidth (rawScheduledLogUpper (1 - q) + (directedCertificatePrecision n)) ≀ budget) β†’ + rawRowComplementUpperCost (directedCertificatePrecision n) xs ≀ + xs.length * (budget + 1) := by + intro xs hxs + induction xs with + | nil => simp [rawRowComplementUpperCost] + | cons q qs ih => + have hq := hxs q (by simp) + have htail : βˆ€ r ∈ qs, + rawRatWidth (rawScheduledLogUpper (1 - r) + (directedCertificatePrecision n)) ≀ budget := by + intro r hr + exact hxs r (by simp [hr]) + have ih' := ih htail + have ih'' : + (qs.map fun r => rawRatWidth + (rawScheduledLogUpper (1 - r) + (directedCertificatePrecision n)) + 1).sum ≀ + qs.length * (budget + 1) := by + simpa only [rawRowComplementUpperCost] using! ih' + simp only [rawRowComplementUpperCost, List.map_cons, List.sum_cons, + List.length_cons, Nat.add_mul] + omega + have hcost := rawCost_le_uniform (List.ofFn (X i)) hpoint + have hn : (List.ofFn (X i)).length = n := by simp + have hnword : n ≀ word.length := by + have hnopt := matrix_dimension_le_code_length X + have hmatrix : + (rationalMatrixBinaryEncoding.encode ⟨n, X⟩).length ≀ + (rationalOptimizerOutputCode ⟨X, R, C⟩).length := by + simpa only [rationalOptimizerOutputCode, machinePairFirst_pair] using! + machinePairFirst_length_le + (rationalOptimizerOutputCode ⟨X, R, C⟩) + have hoptimizerWord : + (rationalOptimizerOutputCode ⟨X, R, C⟩).length ≀ word.length := by + simpa only [word, machinePairSecond_pair] using! + machinePairSecond_length_le word + exact hnopt.trans (hmatrix.trans hoptimizerWord) + rw [hn] at hcost + exact hcost.trans (Nat.mul_le_mul_right (budget + 1) hnword) + +theorem machineRowUpperInputBound_length_dominates (word : List Bool) : + 4 + 3 * (1 + word.length * + (rawRowComplementUpperInputWidthBudget word.length + 1)) ≀ + (machineRowUpperInputBound word).length := by + have hnear := machineNearbyMatrixInputBound_length_dominates word + have hbudget : rawRowComplementUpperInputWidthBudget word.length ≀ + rawNearbyCoordinateInputWidthBudget word.length := by + simp only [rawRowComplementUpperInputWidthBudget, + rawNearbyCoordinateInputWidthBudget] + omega + have hmul := Nat.mul_le_mul_left word.length + (Nat.add_le_add_right hbudget 1) + have htarget : + 4 + 3 * (1 + word.length * + (rawRowComplementUpperInputWidthBudget word.length + 1)) ≀ + 4 + 3 * (1 + word.length * + (rawNearbyCoordinateInputWidthBudget word.length + 1)) := by omega + simpa only [machineRowUpperInputBound, machineNearbyMatrixInputBound] using! + htarget.trans hnear + +@[simp] theorem machineRowComplementUpperSumRawCode_encode + {n : β„•} (X : Matrix (Fin n) (Fin n) β„š) (R C : Fin n β†’ β„š) + (i : Fin n) : + machineRowComplementUpperSumRawCode + (pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩)) = + rawRatBinaryCode + (rawRowComplementUpperSum (directedCertificatePrecision n) + RawRat.zero (List.ofFn (X i))) := by + let word := pair (List.replicate i.1 true) + (rationalOptimizerOutputCode ⟨X, R, C⟩) + let xs := List.ofFn (X i) + let p := directedCertificatePrecision n + let s : RowUpperSemState := ⟨xs, RawRat.zero⟩ + let budget := 1 + rawRowComplementUpperCost p xs + have hinv : RowUpperSemInvariant p budget s := by + simp [RowUpperSemInvariant, s, budget, rawRatWidth_zero] + have hrowCode : (binaryListCode rationalEntryBinaryCode xs).length ≀ + word.length := by + calc + _ = (machineRowUpperInitialRow word).length := by + simpa only [word, xs] using! congrArg List.length + (machineRowUpperInitialRow_encode X R C i).symm + _ ≀ word.length := by + have hindex := machineListIndex_length_le_data + (pair (machineRowUpperRowRuler word) + (machineMatrixRowsWord (machineRowUpperMatrixWord word))) + simp only [machineListIndexData, machinePairSecond_pair] at hindex + exact hindex.trans + ((machinePairSecond_length_le + (machineRowUpperMatrixWord word)).trans + ((machinePairFirst_length_le + (machineRowUpperOptimizerWord word)).trans + (machinePairSecond_length_le word))) + have hwork : xs.length ≀ word.length := by + exact (list_length_le_binaryListCode_length + rationalEntryBinaryCode xs).trans hrowCode + have hsplit : word.length = (word.length - xs.length) + xs.length := by omega + have hinit : machineRowUpperInit word = + rowUpperSemCode word (machineRowUpperInputBound word) s := by + simp [machineRowUpperInit, rowUpperSemCode, s, word, xs, + machineRowUpperInitialRow_encode] + have hcost := rawRowComplementUpperCost_le_query X R C i + have hruler := machineRowUpperInputBound_length_dominates word + have hlarge : 4 + 3 * budget ≀ + (machineRowUpperInputBound word).length := by + have hbudget : budget ≀ 1 + word.length * + (rawRowComplementUpperInputWidthBudget word.length + 1) := by + dsimp only [budget, p, xs, word] at hcost ⊒ + omega + exact (Nat.add_le_add_left (Nat.mul_le_mul_left 3 hbudget) 4).trans + hruler + rw [machineRowComplementUpperSumRawCode, machineRowUpperFinalState, + hsplit, Function.iterate_add_apply, hinit, + machineRowUpperIterate_semantics X R C (List.replicate i.1 true) + (machineRowUpperInputBound word) s budget hinv hlarge, + rowUpperSem_processList] + simp only [rowUpperSemCode, binaryListCode] + rw [machineRowUpper_done_iterate] + simp [machineRowUpperAcc_pack, xs] + +theorem rawRowComplementUpperSum_value (p : β„•) (acc : RawRat) : βˆ€ xs, + (rawRowComplementUpperSum p acc xs).value = + acc.value + (xs.map fun q => scheduledLogUpper (1 - q) p).sum := by + intro xs + induction xs generalizing acc with + | nil => simp [rawRowComplementUpperSum] + | cons q qs ih => + rw [rawRowComplementUpperSum, ih] + simp [rawScheduledLogUpper_value, add_assoc] + +theorem rawRowComplementUpperSum_matrix_value {n : β„•} + (X : Matrix (Fin n) (Fin n) β„š) (i : Fin n) (p : β„•) : + (rawRowComplementUpperSum p RawRat.zero (List.ofFn (X i))).value = + βˆ‘ k, scheduledLogUpper (1 - X i k) p := by + rw [rawRowComplementUpperSum_value] + simp [List.sum_ofFn] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineRowPairDisjoint.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineRowPairDisjoint.lean new file mode 100644 index 0000000000..1bd2c41994 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineRowPairDisjoint.lean @@ -0,0 +1,533 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertifiedPairEligibility +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse + +/-! +# Disjointness from an encoded row-pair list + +An ordered row pair is encoded as a pair of unary row rulers. The scanner +tests whether a candidate pair shares an endpoint with any selected pair. +It iterates for the bit-length of the selected-list encoding, so malformed +inputs remain polynomially bounded; after the encoded list is exhausted the +step stutters. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes an ordered row pair by pairing its two unary finite-index codes. -/ +def orderedRowPairCode {n : β„•} (q : Fin n Γ— Fin n) : List Bool := + pair (finUnaryCode q.1) (finUnaryCode q.2) + +/-- Extracts the first candidate row ruler from a row-pair disjointness request. -/ +def machineDisjointCandidateFirst (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the disjointness request payload after its first candidate row. -/ +def machineDisjointRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the second candidate row ruler from a row-pair disjointness request. -/ +def machineDisjointCandidateSecond (word : List Bool) : List Bool := + machinePairFirst (machineDisjointRest word) + +/-- Extracts the encoded list of already selected row pairs. -/ +def machineDisjointSelectedList (word : List Bool) : List Bool := + machinePairSecond (machineDisjointRest word) + +/-- Packs the unprocessed selected-pair list, accumulated conflict bit, and fixed request. -/ +def machineDisjointPack + (remaining conflict source : List Bool) : List Bool := + pair remaining (pair conflict source) + +/-- Extracts the remaining selected pairs from a disjointness scan state. -/ +def machineDisjointRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the accumulated conflict bit from a disjointness scan state. -/ +def machineDisjointConflict (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the fixed candidate-and-selected-list request from a disjointness state. -/ +def machineDisjointSource (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Reads the next selected row pair to compare with the candidate. -/ +def machineDisjointCurrentPair (state : List Bool) : List Bool := + machineListHead (machineDisjointRemaining state) + +/-- Extracts the first row ruler of the current selected pair. -/ +def machineDisjointCurrentFirst (state : List Bool) : List Bool := + machinePairFirst (machineDisjointCurrentPair state) + +/-- Extracts the second row ruler of the current selected pair. -/ +def machineDisjointCurrentSecond (state : List Bool) : List Bool := + machinePairSecond (machineDisjointCurrentPair state) + +/-- Tests equality of ruler lengths by computing and comparing their binary lengths. -/ +def machineUnaryRulersEqualBit (lhs rhs : List Bool) : List Bool := + machineBinaryNatEqBit (pair (machineLengthBits lhs) (machineLengthBits rhs)) + +/-- Compares the first candidate row with the first row of the current selected pair. -/ +def machineDisjointIFirstBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit + (machineDisjointCandidateFirst (machineDisjointSource state)) + (machineDisjointCurrentFirst state) + +/-- Compares the first candidate row with the second row of the current selected pair. -/ +def machineDisjointISecondBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit + (machineDisjointCandidateFirst (machineDisjointSource state)) + (machineDisjointCurrentSecond state) + +/-- Compares the second candidate row with the first row of the current selected pair. -/ +def machineDisjointJFirstBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit + (machineDisjointCandidateSecond (machineDisjointSource state)) + (machineDisjointCurrentFirst state) + +/-- Compares the second candidate row with the second row of the current selected pair. -/ +def machineDisjointJSecondBit (state : List Bool) : List Bool := + machineUnaryRulersEqualBit + (machineDisjointCandidateSecond (machineDisjointSource state)) + (machineDisjointCurrentSecond state) + +/-- Tests whether either candidate row coincides with either row of the current selected pair. -/ +def machineDisjointCurrentConflictBit (state : List Bool) : List Bool := + machineOrBit (machineDisjointIFirstBit state) + (machineOrBit (machineDisjointISecondBit state) + (machineOrBit (machineDisjointJFirstBit state) + (machineDisjointJSecondBit state))) + +/-- Pairs a false bit with the source request to form the disjointness scan's input-bound word. -/ +def machineDisjointInputBound (word : List Bool) : List Bool := + pair [false] word + +/-- Accumulates the current row-pair conflict using Boolean disjunction and truncates the result +to the input-bound length. -/ +def machineDisjointNextConflict (state : List Bool) : List Bool := + (machineOrBit (machineDisjointConflict state) + (machineDisjointCurrentConflictBit state)).take + (machineDisjointInputBound (machineDisjointSource state)).length + +/-- Consume the next encoded selected pair, update the accumulated conflict bit, and retain the +original input. -/ +def machineDisjointProcess (state : List Bool) : List Bool := + machineDisjointPack (machineListTail (machineDisjointRemaining state)) + (machineDisjointNextConflict state) (machineDisjointSource state) + +/-- Keep an exhausted disjointness scan fixed; otherwise process its next selected pair. -/ +def machineDisjointStep (state : List Bool) : List Bool := + machineIfEmpty (machineDisjointRemaining state) state + (machineDisjointProcess state) + +/-- Initialize the disjointness scan with the encoded selected list, a false conflict bit, and +the input word. -/ +def machineDisjointInit (word : List Bool) : List Bool := + machineDisjointPack (machineDisjointSelectedList word) [false] word + +/-- Pack three copies of the input bound to obtain a width envelope for a disjointness state. -/ +def machineDisjointWidth (word : List Bool) : List Bool := + let bound := machineDisjointInputBound word + machineDisjointPack bound bound bound + +/-- Run the disjointness scan for the encoded selected-list length from its initial state. -/ +def machineDisjointFinalState (word : List Bool) : List Bool := + (machineDisjointStep)^[(machineDisjointSelectedList word).length] + (machineDisjointInit word) + +/-- Extract the accumulated conflict bit after scanning the selected pairs. -/ +def machineRowPairConflictBit (word : List Bool) : List Bool := + machineDisjointConflict (machineDisjointFinalState word) + +/-- One bit, true exactly when the candidate is disjoint from every encoded +selected pair on canonical inputs. -/ +def machineRowPairDisjointBit (word : List Bool) : List Bool := + machineNotBit (machineRowPairConflictBit word) + +theorem machineDisjointCandidateFirst_mem_FP : + machineDisjointCandidateFirst ∈ FP := machinePairFirst_mem_FP + +theorem machineDisjointRest_mem_FP : machineDisjointRest ∈ FP := + machinePairSecond_mem_FP + +theorem machineDisjointCandidateSecond_mem_FP : + machineDisjointCandidateSecond ∈ FP := by + simpa only [machineDisjointCandidateSecond] using! machineCompose_mem_FP + machineDisjointRest_mem_FP machinePairFirst_mem_FP + +theorem machineDisjointSelectedList_mem_FP : + machineDisjointSelectedList ∈ FP := by + simpa only [machineDisjointSelectedList] using! machineCompose_mem_FP + machineDisjointRest_mem_FP machinePairSecond_mem_FP + +theorem machineDisjointRemaining_mem_FP : machineDisjointRemaining ∈ FP := + machinePairFirst_mem_FP + +theorem machineDisjointConflict_mem_FP : machineDisjointConflict ∈ FP := by + simpa only [machineDisjointConflict] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineDisjointSource_mem_FP : machineDisjointSource ∈ FP := by + simpa only [machineDisjointSource] using! machineCompose_mem_FP + machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineDisjointCurrentPair_mem_FP : + machineDisjointCurrentPair ∈ FP := by + simpa only [machineDisjointCurrentPair] using! machineCompose_mem_FP + machineDisjointRemaining_mem_FP machineListHead_mem_FP + +theorem machineDisjointCurrentFirst_mem_FP : + machineDisjointCurrentFirst ∈ FP := by + simpa only [machineDisjointCurrentFirst] using! machineCompose_mem_FP + machineDisjointCurrentPair_mem_FP machinePairFirst_mem_FP + +theorem machineDisjointCurrentSecond_mem_FP : + machineDisjointCurrentSecond ∈ FP := by + simpa only [machineDisjointCurrentSecond] using! machineCompose_mem_FP + machineDisjointCurrentPair_mem_FP machinePairSecond_mem_FP + +theorem machineUnaryRulersEqualBit_mem_FP + {lhs rhs : List Bool β†’ List Bool} (hlhs : lhs ∈ FP) (hrhs : rhs ∈ FP) : + (fun word ↦ machineUnaryRulersEqualBit (lhs word) (rhs word)) ∈ FP := by + have hl := machineCompose_mem_FP hlhs machineLengthBits_mem_FP + have hr := machineCompose_mem_FP hrhs machineLengthBits_mem_FP + have hinput := machinePair_mem_FP hl hr + simpa only [machineUnaryRulersEqualBit] using! machineCompose_mem_FP hinput + machineBinaryNatEqBit_mem_FP + +theorem machineDisjointIFirstBit_mem_FP : machineDisjointIFirstBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + (machineCompose_mem_FP machineDisjointSource_mem_FP + machineDisjointCandidateFirst_mem_FP) + machineDisjointCurrentFirst_mem_FP + +theorem machineDisjointISecondBit_mem_FP : machineDisjointISecondBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + (machineCompose_mem_FP machineDisjointSource_mem_FP + machineDisjointCandidateFirst_mem_FP) + machineDisjointCurrentSecond_mem_FP + +theorem machineDisjointJFirstBit_mem_FP : machineDisjointJFirstBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + (machineCompose_mem_FP machineDisjointSource_mem_FP + machineDisjointCandidateSecond_mem_FP) + machineDisjointCurrentFirst_mem_FP + +theorem machineDisjointJSecondBit_mem_FP : machineDisjointJSecondBit ∈ FP := by + exact machineUnaryRulersEqualBit_mem_FP + (machineCompose_mem_FP machineDisjointSource_mem_FP + machineDisjointCandidateSecond_mem_FP) + machineDisjointCurrentSecond_mem_FP + +theorem machineDisjointCurrentConflictBit_mem_FP : + machineDisjointCurrentConflictBit ∈ FP := by + exact machineOrBit_mem_FP machineDisjointIFirstBit_mem_FP + (machineOrBit_mem_FP machineDisjointISecondBit_mem_FP + (machineOrBit_mem_FP machineDisjointJFirstBit_mem_FP + machineDisjointJSecondBit_mem_FP)) + +theorem machineDisjointInputBound_mem_FP : machineDisjointInputBound ∈ FP := + machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP + +theorem machineDisjointNextConflict_mem_FP : + machineDisjointNextConflict ∈ FP := by + have hdata := machineOrBit_mem_FP machineDisjointConflict_mem_FP + machineDisjointCurrentConflictBit_mem_FP + have hbound := machineCompose_mem_FP machineDisjointSource_mem_FP + machineDisjointInputBound_mem_FP + simpa only [machineDisjointNextConflict] using! machineTake_mem_FP hbound hdata + +theorem machineDisjointProcess_mem_FP : machineDisjointProcess ∈ FP := by + have htail := machineCompose_mem_FP machineDisjointRemaining_mem_FP + machineListTail_mem_FP + exact machinePair_mem_FP htail + (machinePair_mem_FP machineDisjointNextConflict_mem_FP + machineDisjointSource_mem_FP) + +theorem machineDisjointStep_mem_FP : machineDisjointStep ∈ FP := by + simpa only [machineDisjointStep] using! machineIfEmpty_mem_FP + machineDisjointRemaining_mem_FP id_mem_FP machineDisjointProcess_mem_FP + +theorem machineDisjointInit_mem_FP : machineDisjointInit ∈ FP := + machinePair_mem_FP machineDisjointSelectedList_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP) + +theorem machineDisjointWidth_mem_FP : machineDisjointWidth ∈ FP := + machinePair_mem_FP machineDisjointInputBound_mem_FP + (machinePair_mem_FP machineDisjointInputBound_mem_FP + machineDisjointInputBound_mem_FP) + +@[simp] theorem machineDisjointRemaining_pack (remaining conflict source) : + machineDisjointRemaining (machineDisjointPack remaining conflict source) = + remaining := by simp [machineDisjointRemaining, machineDisjointPack] + +@[simp] theorem machineDisjointConflict_pack (remaining conflict source) : + machineDisjointConflict (machineDisjointPack remaining conflict source) = + conflict := by simp [machineDisjointConflict, machineDisjointPack] + +@[simp] theorem machineDisjointSource_pack (remaining conflict source) : + machineDisjointSource (machineDisjointPack remaining conflict source) = + source := by simp [machineDisjointSource, machineDisjointPack] + +/-- Require a correctly packed disjointness state, bounded remaining list and conflict word, and +unchanged source input. -/ +def MachineDisjointStateBound (word state : List Bool) : Prop := + let B := (machineDisjointInputBound word).length + state = machineDisjointPack (machineDisjointRemaining state) + (machineDisjointConflict state) (machineDisjointSource state) ∧ + (machineDisjointRemaining state).length ≀ B ∧ + (machineDisjointConflict state).length ≀ B ∧ + machineDisjointSource state = word + +theorem machineDisjointSelected_length_le (word : List Bool) : + (machineDisjointSelectedList word).length ≀ + (machineDisjointInputBound word).length := by + exact ((machinePairSecond_length_le (machineDisjointRest word)).trans + (machinePairSecond_length_le word)).trans + (by + simp only [machineDisjointInputBound, pair_length] + omega) + +theorem machineDisjoint_one_le_bound (word : List Bool) : + 1 ≀ (machineDisjointInputBound word).length := by + simp only [machineDisjointInputBound, pair_length] + omega + +theorem machineDisjoint_source_le_bound (word : List Bool) : + word.length ≀ (machineDisjointInputBound word).length := by + simp only [machineDisjointInputBound, pair_length] + omega + +theorem machineDisjointInit_bound (word : List Bool) : + MachineDisjointStateBound word (machineDisjointInit word) := by + simp only [MachineDisjointStateBound, machineDisjointInit, + machineDisjointRemaining_pack, machineDisjointConflict_pack, + machineDisjointSource_pack] + exact ⟨trivial, machineDisjointSelected_length_le word, + machineDisjoint_one_le_bound word, trivial⟩ + +theorem machineDisjointStep_bound {word state : List Bool} + (hstate : MachineDisjointStateBound word state) : + MachineDisjointStateBound word (machineDisjointStep state) := by + rcases hstate with ⟨hpack, hremaining, hconflict, hsource⟩ + by_cases hrem : machineDisjointRemaining state = [] + Β· rw [machineDisjointStep, hrem, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hconflict, hsource⟩ + Β· rw [machineDisjointStep] + cases hcode : machineDisjointRemaining state with + | nil => exact False.elim (hrem hcode) + | cons bit tail => + rw [machineIfEmpty_cons, machineDisjointProcess] + simp only [MachineDisjointStateBound, machineDisjointRemaining_pack, + machineDisjointConflict_pack, machineDisjointSource_pack] + refine ⟨trivial, ?_, ?_, hsource⟩ + Β· exact (machinePairSecond_length_le + (machineDisjointRemaining state)).trans hremaining + Β· simp only [machineDisjointNextConflict, List.length_take] + rw [hsource] + exact Nat.min_le_left _ _ + +theorem machineDisjointIterate_bound (word : List Bool) : βˆ€ k, + MachineDisjointStateBound word + ((machineDisjointStep)^[k] (machineDisjointInit word)) := by + intro k + induction k with + | zero => exact machineDisjointInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineDisjointStep_bound ih + +theorem machineDisjointIterate_length_le_width + (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineDisjointSelectedList word).length) : + ((machineDisjointStep)^[iterations] (machineDisjointInit word)).length ≀ + (machineDisjointWidth word).length := by + rcases machineDisjointIterate_bound word iterations with + ⟨hpack, hremaining, hconflict, hsource⟩ + have hsourceLength : (machineDisjointSource + ((machineDisjointStep)^[iterations] (machineDisjointInit word))).length ≀ + (machineDisjointInputBound word).length := by + rw [hsource] + exact machineDisjoint_source_le_bound word + rw [hpack] + simp only [machineDisjointPack, machineDisjointWidth, pair_length] + omega + +theorem machineDisjointFinalState_mem_FP : machineDisjointFinalState ∈ FP := by + exact Cobham.iterate_mem_FP machineDisjointStep_mem_FP + machineDisjointInit_mem_FP machineDisjointSelectedList_mem_FP + machineDisjointWidth_mem_FP machineDisjointIterate_length_le_width + +theorem machineRowPairConflictBit_mem_FP : machineRowPairConflictBit ∈ FP := by + simpa only [machineRowPairConflictBit] using! machineCompose_mem_FP + machineDisjointFinalState_mem_FP machineDisjointConflict_mem_FP + +theorem machineRowPairDisjointBit_mem_FP : machineRowPairDisjointBit ∈ FP := + machineNotBit_mem_FP machineRowPairConflictBit_mem_FP + +/-! ## Exact semantics -/ + +/-- Test whether either candidate endpoint occurs in any selected ordered pair. -/ +def orderedPairsConflict {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : Bool := + selected.any fun q ↦ decide (i = q.1 ∨ i = q.2 ∨ j = q.1 ∨ j = q.2) + +/-- Encode two candidate endpoints in unary together with the binary list of selected ordered +pairs. -/ +def machineDisjointInput {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : List Bool := + pair (finUnaryCode i) + (pair (finUnaryCode j) (binaryListCode orderedRowPairCode selected)) + +@[simp] theorem machineUnaryRulersEqualBit_encode {n : β„•} + (i j : Fin n) : + machineUnaryRulersEqualBit (finUnaryCode i) (finUnaryCode j) = + [decide (i = j)] := by + rw [machineUnaryRulersEqualBit] + simp only [machineLengthBits_encode, finUnaryCode, List.length_replicate, + machineBinaryNatEqBit_pair_natBits] + by_cases hval : i.1 = j.1 + Β· have h : i = j := Fin.ext hval + simp [hval, h] + Β· have h : i β‰  j := fun hij ↦ hval (congrArg Fin.val hij) + simp [hval, h] + +@[simp] theorem machineDisjointCurrentConflictBit_encode {n : β„•} + (i j x y : Fin n) (qs sourceSelected : List (Fin n Γ— Fin n)) + (conflict : Bool) : + machineDisjointCurrentConflictBit + (machineDisjointPack + (binaryListCode orderedRowPairCode ((x, y) :: qs)) [conflict] + (machineDisjointInput i j sourceSelected)) = + [decide (i = x ∨ i = y ∨ j = x ∨ j = y)] := by + simp only [machineDisjointCurrentConflictBit, machineDisjointIFirstBit, + machineDisjointISecondBit, machineDisjointJFirstBit, + machineDisjointJSecondBit, machineDisjointSource_pack, + machineDisjointCurrentFirst, machineDisjointCurrentSecond, + machineDisjointCurrentPair, machineDisjointRemaining_pack, + machineListHead_cons, orderedRowPairCode, machinePairFirst_pair, + machinePairSecond_pair, machineDisjointCandidateFirst, + machineDisjointCandidateSecond, machineDisjointRest, + machineDisjointInput, machineUnaryRulersEqualBit_encode, + machineOrBit_one] + by_cases hix : i = x <;> by_cases hiy : i = y <;> + by_cases hjx : j = x <;> by_cases hjy : j = y <;> + simp [hix, hiy, hjx, hjy] + +/-- Represent a disjointness scan after `k` pairs: retain the suffix and record conflicts with +the consumed prefix. -/ +def machineDisjointSemanticState {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) (k : β„•) : List Bool := + machineDisjointPack + (binaryListCode orderedRowPairCode (selected.drop k)) + [orderedPairsConflict i j (selected.take k)] + (machineDisjointInput i j selected) + +@[simp] theorem machineDisjointSemanticState_zero {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineDisjointSemanticState i j selected 0 = + machineDisjointInit (machineDisjointInput i j selected) := by + simp [machineDisjointSemanticState, machineDisjointInit, + machineDisjointInput, machineDisjointSelectedList, + machineDisjointRest, orderedPairsConflict] + +theorem machineDisjointSemanticState_step {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) + (k : β„•) (hk : k < selected.length) : + machineDisjointStep (machineDisjointSemanticState i j selected k) = + machineDisjointSemanticState i j selected (k + 1) := by + rw [machineDisjointSemanticState, List.drop_eq_getElem_cons hk, + machineDisjointStep] + simp only [machineDisjointRemaining_pack] + rw [machineIfEmpty_of_ne_nil_matrix _ _ _ + (binaryListCode_cons_ne_nil orderedRowPairCode selected[k] + (selected.drop (k + 1)))] + rw [machineDisjointProcess] + simp only [machineDisjointRemaining_pack, machineListTail_cons, + machineDisjointSource_pack, machineDisjointNextConflict, + machineDisjointConflict_pack] + rcases hp : selected[k] with ⟨x, y⟩ + rw [machineDisjointCurrentConflictBit_encode] + simp only [machineOrBit_one] + have hbound : 1 ≀ + (machineDisjointInputBound (machineDisjointInput i j selected)).length := + machineDisjoint_one_le_bound _ + rw [(List.take_eq_self_iff _).2 (by simpa using! hbound)] + rw [machineDisjointSemanticState] + apply congrArg (fun z : Bool ↦ machineDisjointPack + (binaryListCode orderedRowPairCode (selected.drop (k + 1))) [z] + (machineDisjointInput i j selected)) + rw [orderedPairsConflict, orderedPairsConflict, + ← List.take_concat_get hk, List.concat_eq_append, List.any_append] + simp [hp] + +theorem machineDisjointIterate_semantics {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : βˆ€ k ≀ selected.length, + (machineDisjointStep)^[k] + (machineDisjointInit (machineDisjointInput i j selected)) = + machineDisjointSemanticState i j selected k := by + intro k hk + induction k with + | zero => exact (machineDisjointSemanticState_zero i j selected).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega)] + exact machineDisjointSemanticState_step i j selected k (by omega) + +theorem machineDisjoint_done_iterate + (extra : β„•) (conflict source : List Bool) : + (machineDisjointStep)^[extra] + (machineDisjointPack [] conflict source) = + machineDisjointPack [] conflict source := by + induction extra with + | zero => rfl + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simp [machineDisjointStep] + +@[simp] theorem machineDisjointSelectedList_input {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineDisjointSelectedList (machineDisjointInput i j selected) = + binaryListCode orderedRowPairCode selected := by + simp [machineDisjointSelectedList, machineDisjointRest, + machineDisjointInput] + +@[simp] theorem machineRowPairConflictBit_encode {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineRowPairConflictBit (machineDisjointInput i j selected) = + [orderedPairsConflict i j selected] := by + rw [machineRowPairConflictBit, machineDisjointFinalState, + machineDisjointSelectedList_input] + let word := binaryListCode orderedRowPairCode selected + have hle : selected.length ≀ word.length := + binaryListCode_listLength_le orderedRowPairCode selected + have hsplit : word.length = (word.length - selected.length) + selected.length := by + omega + rw [hsplit, Function.iterate_add_apply, + machineDisjointIterate_semantics i j selected selected.length le_rfl] + simp only [machineDisjointSemanticState, List.drop_length, List.take_length] + change machineDisjointConflict + ((machineDisjointStep)^[word.length - selected.length] + (machineDisjointPack [] [orderedPairsConflict i j selected] + (machineDisjointInput i j selected))) = _ + rw [machineDisjoint_done_iterate] + simp only [machineDisjointConflict_pack] + +@[simp] theorem machineRowPairDisjointBit_encode {n : β„•} + (i j : Fin n) (selected : List (Fin n Γ— Fin n)) : + machineRowPairDisjointBit (machineDisjointInput i j selected) = + [!orderedPairsConflict i j selected] := by + rw [machineRowPairDisjointBit, machineRowPairConflictBit_encode, + machineNotBit_one] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLog.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLog.lean new file mode 100644 index 0000000000..0da4f48fb8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLog.lean @@ -0,0 +1,286 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineCertificateScales +public import LeanPool.BeyondBethe.BeyondBethe.MachineIntegerSignedMagnitude + +/-! +# The input-dependent directed-logarithm schedule + +`scheduledLogLower q p` uses `directedLogTerms q p`, not merely `p`, series +terms. This module computes that exact term count from the unary precision +ruler and the signed dyadic exponent of `q`, expands it under a quadratic +guard, and invokes the verified directed-logarithm machine. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the unary precision ruler from a scheduled-logarithm input. -/ +def machineScheduledLogPrecisionRuler (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the raw-rational argument code from a scheduled-logarithm input. -/ +def machineScheduledLogArgumentRawCode (word : List Bool) : List Bool := + machinePairSecond word + +/-- Encode the scheduled logarithm precision in binary from the unary ruler length. -/ +def machineScheduledLogPrecisionBits (word : List Bool) : List Bool := + machineLengthBits (machineScheduledLogPrecisionRuler word) + +/-- Compute the signed binary exponent code used in directed-logarithm reduction. -/ +def machineScheduledLogExponentIntegerCode (word : List Bool) : List Bool := + machineDirectedLogExponentIntegerCode word + +/-- Encode the absolute value of the directed logarithm exponent as a binary natural. -/ +def machineScheduledLogExponentAbsBits (word : List Bool) : List Bool := + machineIntegerNatAbsBits + (machineScheduledLogExponentIntegerCode word) + +/-- Add the precision and absolute exponent to form the main part of the logarithm term +schedule. -/ +def machineScheduledLogPrecisionPlusExponentBits + (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineScheduledLogPrecisionBits word) + (machineScheduledLogExponentAbsBits word)) + +/-- Encode the logarithm term count as precision plus absolute exponent plus two. -/ +def machineScheduledLogTermsBits (word : List Bool) : List Bool := + machineBinaryAddBits + (pair (machineScheduledLogPrecisionPlusExponentBits word) + (2 : β„•).bits) + +/-- A total quadratic guard. On canonical inputs it dominates the exact +input-dependent term count. -/ +def machineScheduledLogTermsGuard (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Convert the scheduled logarithm term count to a unary ruler, bounded by the quadratic guard. -/ +def machineScheduledLogTermsRuler (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineScheduledLogTermsGuard word) + (machineScheduledLogTermsBits word)) + +/-- Compute the raw lower logarithm code using the scheduled, guarded term ruler. -/ +def machineScheduledLogLowerRawCode (word : List Bool) : List Bool := + machineDirectedLogLowerRawCode + (pair (machineScheduledLogTermsRuler word) + (machineScheduledLogArgumentRawCode word)) + +/-- Compute the raw upper logarithm code using the scheduled, guarded term ruler. -/ +def machineScheduledLogUpperRawCode (word : List Bool) : List Bool := + machineDirectedLogUpperRawCode + (pair (machineScheduledLogTermsRuler word) + (machineScheduledLogArgumentRawCode word)) + +theorem machineScheduledLogPrecisionRuler_mem_FP : + machineScheduledLogPrecisionRuler ∈ Complexity.FP := + machinePairFirst_mem_FP + +theorem machineScheduledLogArgumentRawCode_mem_FP : + machineScheduledLogArgumentRawCode ∈ Complexity.FP := + machinePairSecond_mem_FP + +theorem machineScheduledLogPrecisionBits_mem_FP : + machineScheduledLogPrecisionBits ∈ Complexity.FP := by + simpa only [machineScheduledLogPrecisionBits] using! + machineCompose_mem_FP machineScheduledLogPrecisionRuler_mem_FP + machineLengthBits_mem_FP + +theorem machineScheduledLogExponentIntegerCode_mem_FP : + machineScheduledLogExponentIntegerCode ∈ Complexity.FP := by + simpa only [machineScheduledLogExponentIntegerCode] using! + machineDirectedLogExponentIntegerCode_mem_FP + +theorem machineScheduledLogExponentAbsBits_mem_FP : + machineScheduledLogExponentAbsBits ∈ Complexity.FP := by + simpa only [machineScheduledLogExponentAbsBits] using! + machineCompose_mem_FP machineScheduledLogExponentIntegerCode_mem_FP + machineIntegerNatAbsBits_mem_FP + +theorem machineScheduledLogPrecisionPlusExponentBits_mem_FP : + machineScheduledLogPrecisionPlusExponentBits ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineScheduledLogPrecisionBits_mem_FP + machineScheduledLogExponentAbsBits_mem_FP + simpa only [machineScheduledLogPrecisionPlusExponentBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineScheduledLogTermsBits_mem_FP : + machineScheduledLogTermsBits ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineScheduledLogPrecisionPlusExponentBits_mem_FP + (machineConst_mem_FP (2 : β„•).bits) + simpa only [machineScheduledLogTermsBits] using! + machineCompose_mem_FP hpair machineBinaryAddBits_mem_FP + +theorem machineScheduledLogTermsGuard_mem_FP : + machineScheduledLogTermsGuard ∈ Complexity.FP := + machineBinaryMulWidth_mem_FP + +theorem machineScheduledLogTermsRuler_mem_FP : + machineScheduledLogTermsRuler ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineScheduledLogTermsGuard_mem_FP + machineScheduledLogTermsBits_mem_FP + simpa only [machineScheduledLogTermsRuler] using! + machineCompose_mem_FP hpair machineBoundedUnary_mem_FP + +theorem machineScheduledLogLowerRawCode_mem_FP : + machineScheduledLogLowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineScheduledLogTermsRuler_mem_FP + machineScheduledLogArgumentRawCode_mem_FP + simpa only [machineScheduledLogLowerRawCode] using! + machineCompose_mem_FP hpair machineDirectedLogLowerRawCode_mem_FP + +theorem machineScheduledLogUpperRawCode_mem_FP : + machineScheduledLogUpperRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineScheduledLogTermsRuler_mem_FP + machineScheduledLogArgumentRawCode_mem_FP + simpa only [machineScheduledLogUpperRawCode] using! + machineCompose_mem_FP hpair machineDirectedLogUpperRawCode_mem_FP + +@[simp] theorem machineScheduledLogPrecisionBits_encode + (q : β„š) (p : β„•) : + machineScheduledLogPrecisionBits + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = p.bits := by + simp [machineScheduledLogPrecisionBits, + machineScheduledLogPrecisionRuler] + +@[simp] theorem machineScheduledLogExponentIntegerCode_encode + (q : β„š) (p : β„•) : + machineScheduledLogExponentIntegerCode + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + integerBinaryCode (rationalBinaryExponent q) := by + rw [machineScheduledLogExponentIntegerCode, + machineDirectedLogExponentIntegerCode_encode, + binaryRationalBinaryExponent_eq] + +@[simp] theorem machineScheduledLogExponentAbsBits_encode + (q : β„š) (p : β„•) : + machineScheduledLogExponentAbsBits + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + (rationalBinaryExponent q).natAbs.bits := by + rw [machineScheduledLogExponentAbsBits, + machineScheduledLogExponentIntegerCode_encode, + machineIntegerNatAbsBits_encode] + +@[simp] theorem machineScheduledLogTermsBits_encode + (q : β„š) (p : β„•) : + machineScheduledLogTermsBits + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + (directedLogTerms q p).bits := by + rw [machineScheduledLogTermsBits, + machineScheduledLogPrecisionPlusExponentBits, + machineScheduledLogPrecisionBits_encode, + machineScheduledLogExponentAbsBits_encode, + machineBinaryAddBits_pair_natBits] + change machineBinaryAddBits + (pair (p + (rationalBinaryExponent q).natAbs).bits (2 : β„•).bits) = _ + rw [machineBinaryAddBits_pair_natBits] + rfl + +theorem rationalBinaryExponent_natAbs_le_two_rawWidth (q : β„š) : + (rationalBinaryExponent q).natAbs ≀ + 2 * rawRatWidth (rawRatOfRat q) := by + have habs := Int.natAbs_sub_le + (Nat.log 2 q.num.natAbs : β„€) (Nat.log 2 q.den : β„€) + simp only [Int.natAbs_natCast] at habs + have hnum : Nat.log 2 q.num.natAbs ≀ + rawRatWidth (rawRatOfRat q) := by + rw [← binaryNatLog2_eq_log_two, binaryNatLog2] + exact (Nat.sub_le _ _).trans (le_max_left _ _) + have hden : Nat.log 2 q.den ≀ rawRatWidth (rawRatOfRat q) := by + rw [← binaryNatLog2_eq_log_two, binaryNatLog2] + exact (Nat.sub_le _ _).trans (le_max_right _ _) + rw [rationalBinaryExponent] + omega + +theorem directedLogTerms_le_scheduledLogGuard (q : β„š) (p : β„•) : + directedLogTerms q p ≀ + (machineScheduledLogTermsGuard + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q)))).length := by + let code := rawRatBinaryCode (rawRatOfRat q) + let word := pair (List.replicate p true) code + have hwidth := rawRatWidth_le_binaryCode_length (rawRatOfRat q) + have hexp := rationalBinaryExponent_natAbs_le_two_rawWidth q + have hword : word.length = 2 * p + code.length + 2 := by + simp [word] + omega + have hterms : directedLogTerms q p ≀ 3 * word.length + 2 := by + rw [directedLogTerms] + simp only [word, code] at hword ⊒ + omega + have hquad : 3 * word.length + 2 ≀ (word.length + 16) ^ 2 := by + nlinarith [sq_nonneg (word.length + 14)] + simpa only [machineScheduledLogTermsGuard, machineBinaryMulWidth, + List.length_replicate, List.length_append, pow_two, + List.length_cons, List.length_nil, Nat.zero_add, word, Nat.add_comm] using! + hterms.trans hquad + +@[simp] theorem machineScheduledLogTermsRuler_encode + (q : β„š) (p : β„•) : + machineScheduledLogTermsRuler + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + List.replicate (directedLogTerms q p) true := by + rw [machineScheduledLogTermsRuler, + machineScheduledLogTermsBits_encode, + machineBoundedUnary_encode_of_le] + exact directedLogTerms_le_scheduledLogGuard q p + +/-- Evaluate the raw lower logarithm approximation using the term count selected for `q` and +precision `p`. -/ +def rawScheduledLogLower (q : β„š) (p : β„•) : RawRat := + RawRat.logLower q (directedLogTerms q p) + +/-- Evaluate the raw upper logarithm approximation using the term count selected for `q` and +precision `p`. -/ +def rawScheduledLogUpper (q : β„š) (p : β„•) : RawRat := + RawRat.logUpper q (directedLogTerms q p) + +@[simp] theorem machineScheduledLogLowerRawCode_encode + (q : β„š) (p : β„•) : + machineScheduledLogLowerRawCode + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (rawScheduledLogLower q p) := by + rw [machineScheduledLogLowerRawCode, + machineScheduledLogTermsRuler_encode] + simp only [machineScheduledLogArgumentRawCode, machinePairSecond_pair, + machineDirectedLogLowerRawCode_encode, rawScheduledLogLower] + +@[simp] theorem machineScheduledLogUpperRawCode_encode + (q : β„š) (p : β„•) : + machineScheduledLogUpperRawCode + (pair (List.replicate p true) + (rawRatBinaryCode (rawRatOfRat q))) = + rawRatBinaryCode (rawScheduledLogUpper q p) := by + rw [machineScheduledLogUpperRawCode, + machineScheduledLogTermsRuler_encode] + simp only [machineScheduledLogArgumentRawCode, machinePairSecond_pair, + machineDirectedLogUpperRawCode_encode, rawScheduledLogUpper] + +theorem rawScheduledLogLower_value (q : β„š) (p : β„•) : + (rawScheduledLogLower q p).value = scheduledLogLower q p := by + simp [rawScheduledLogLower, scheduledLogLower, + RawRat.value_logLower, binaryDirectedLogLower_eq] + +theorem rawScheduledLogUpper_value (q : β„š) (p : β„•) : + (rawScheduledLogUpper q p).value = scheduledLogUpper q p := by + simp [rawScheduledLogUpper, scheduledLogUpper, + RawRat.value_logUpper, binaryDirectedLogUpper_eq] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLogWidth.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLogWidth.lean new file mode 100644 index 0000000000..a9438b0f3d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledLogWidth.lean @@ -0,0 +1,486 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineNearbyCoordinate + +/-! +# Explicit raw-width bounds for scheduled logarithms + +These lemmas bound the unreduced fractions produced by the directed logarithm +and by one nearby-Bethe coordinate. They are intentionally stated in terms of +the exact arithmetic definitions, so the matrix-fold clamp can later be proved +inactive without an abstract bit-complexity assumption. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- Polynomial width budget for an `N`-term raw logarithm series with input width `w`. -/ +def rawLogSeriesWidthBudget (w N : β„•) : β„• := + 1 + N * ((2 * N + 1) * w + 2 * N + 4) + +/-- Width budget for the raw unit-logarithm lower approximation after its rational parameter +transformation. -/ +def rawLogUnitLowerWidthBudget (w N : β„•) : β„• := + 3 + rawLogSeriesWidthBudget (2 * w + 4) N + +/-- Width budget for the raw error term in the `N`-term logarithm approximation. -/ +def rawLogSeriesErrorWidthBudget (w N : β„•) : β„• := + 6 + (2 * N + 3) * (2 * w + 4) + +/-- Combine lower-approximation and error widths to budget the raw unit-logarithm upper +approximation. -/ +def rawLogUnitUpperWidthBudget (w N : β„•) : β„• := + rawLogUnitLowerWidthBudget w N + + rawLogSeriesErrorWidthBudget w N + 1 + +/-- Combine exponent scaling and unit-logarithm bounds into a width budget for a directed +logarithm. -/ +def rawDirectedLogWidthBudget (w N : β„•) : β„• := + (2 * w + 2 + rawLogUnitUpperWidthBudget 2 N) + + rawLogUnitUpperWidthBudget (2 * w + 1) N + 1 + +/-- A deliberately coarse closed form for the exact syntactic budget above. +It is useful when composing the logarithm machine with matrix traversals: the +right-hand side exposes only the input width and the actual number of series +terms. -/ +theorem rawDirectedLogWidthBudget_le (w N : β„•) : + rawDirectedLogWidthBudget w N ≀ 64 * (N + 2) ^ 2 * (w + 2) := by + simp only [rawDirectedLogWidthBudget, rawLogUnitUpperWidthBudget, + rawLogUnitLowerWidthBudget, rawLogSeriesErrorWidthBudget, + rawLogSeriesWidthBudget] + nlinarith + +theorem rawRatWidth_ofInt_le (z : β„€) : + rawRatWidth (RawRat.ofInt z) ≀ z.natAbs.size + 1 := by + simp [RawRat.ofInt, rawRatWidth] + +theorem rawRatWidth_logScale_le (q : β„š) : + rawRatWidth (RawRat.logScale q) ≀ + rawRatWidth (rawRatOfRat q) + 1 := by + have hnum := rawRat_num_size_le_width (rawRatOfRat q) + have hden := rawRat_den_size_le_width (rawRatOfRat q) + simp only [rawRatOfRat] at hnum hden + rw [RawRat.logScale, rawRatWidth] + change max (2 ^ binaryNatLog2 q.num.natAbs).size + (2 ^ binaryNatLog2 q.den).size ≀ + rawRatWidth (⟨q.num, q.den, q.den_pos⟩ : RawRat) + 1 + rw [Nat.size_pow, Nat.size_pow, binaryNatLog2, binaryNatLog2] + apply max_le <;> omega + +theorem rawRatWidth_logResidual_le (q : β„š) : + rawRatWidth (RawRat.logResidual q) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 1 := by + rw [RawRat.logResidual] + have hdiv := rawRatWidth_div_le (rawRatOfRat q) (RawRat.logScale q) + have hscale := rawRatWidth_logScale_le q + omega + +theorem rawRatWidth_logUnit_le (q : β„š) : + rawRatWidth (RawRat.logUnit q) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 1 := by + rw [RawRat.logUnit] + split_ifs + Β· exact rawRatWidth_logResidual_le q + Β· exact (rawRatWidth_inv_le _).trans (rawRatWidth_logResidual_le q) + +theorem rawRatWidth_logUnitParameter_le (y : RawRat) : + rawRatWidth (RawRat.logUnitParameter y) ≀ 2 * rawRatWidth y + 4 := by + rw [RawRat.logUnitParameter] + have hneg : rawRatWidth RawRat.one.neg = 1 := by + rw [rawRatWidth_neg, rawRatWidth_one] + have hnum := rawRatWidth_add_le y RawRat.one.neg + have hden := rawRatWidth_add_le y RawRat.one + have hdiv := rawRatWidth_div_le (y.add RawRat.one.neg) (y.add RawRat.one) + rw [hneg] at hnum + rw [rawRatWidth_one] at hden + omega + +theorem rawLogSeriesWidthBudget_mono {w w' N : β„•} (h : w ≀ w') : + rawLogSeriesWidthBudget w N ≀ rawLogSeriesWidthBudget w' N := by + have hmul : (2 * N + 1) * w ≀ (2 * N + 1) * w' := + Nat.mul_le_mul_left _ h + have hinner : (2 * N + 1) * w + 2 * N + 4 ≀ + (2 * N + 1) * w' + 2 * N + 4 := by omega + simp only [rawLogSeriesWidthBudget] + exact Nat.add_le_add_left (Nat.mul_le_mul_left N hinner) 1 + +theorem rawLogUnitLowerWidthBudget_mono {w w' N : β„•} (h : w ≀ w') : + rawLogUnitLowerWidthBudget w N ≀ rawLogUnitLowerWidthBudget w' N := by + simp only [rawLogUnitLowerWidthBudget] + exact Nat.add_le_add_left + (rawLogSeriesWidthBudget_mono (by omega : 2 * w + 4 ≀ 2 * w' + 4)) 3 + +theorem rawLogSeriesErrorWidthBudget_mono {w w' N : β„•} (h : w ≀ w') : + rawLogSeriesErrorWidthBudget w N ≀ rawLogSeriesErrorWidthBudget w' N := by + have hinner : 2 * w + 4 ≀ 2 * w' + 4 := by omega + simp only [rawLogSeriesErrorWidthBudget] + exact Nat.add_le_add_left (Nat.mul_le_mul_left (2 * N + 3) hinner) 6 + +theorem rawLogUnitUpperWidthBudget_mono {w w' N : β„•} (h : w ≀ w') : + rawLogUnitUpperWidthBudget w N ≀ rawLogUnitUpperWidthBudget w' N := by + simp only [rawLogUnitUpperWidthBudget] + exact Nat.add_le_add_right + (Nat.add_le_add (rawLogUnitLowerWidthBudget_mono h) + (rawLogSeriesErrorWidthBudget_mono h)) 1 + +theorem rawRatWidth_logSeriesSum_budget (x : RawRat) (N : β„•) : + rawRatWidth (RawRat.logSeriesSum x N) ≀ + rawLogSeriesWidthBudget (rawRatWidth x) N := by + exact RawRat.width_logSeriesSum_le x N + +theorem rawRatWidth_logUnitLower_le (y : RawRat) (N : β„•) : + rawRatWidth (RawRat.logUnitLower y N) ≀ + rawLogUnitLowerWidthBudget (rawRatWidth y) N := by + rw [RawRat.logUnitLower] + have htwo := RawRat.width_ofNat_le 2 + have hx := rawRatWidth_logUnitParameter_le y + have hseries := RawRat.width_logSeriesSum_le + (RawRat.logUnitParameter y) N + have hmul := rawRatWidth_mul_le (RawRat.ofNat 2) + (RawRat.logSeriesSum (RawRat.logUnitParameter y) N) + simp only [rawLogUnitLowerWidthBudget, rawLogSeriesWidthBudget] + have hprod : + (2 * N + 1) * rawRatWidth (RawRat.logUnitParameter y) ≀ + (2 * N + 1) * (2 * rawRatWidth y + 4) := + Nat.mul_le_mul_left _ hx + have hinner : + (2 * N + 1) * rawRatWidth (RawRat.logUnitParameter y) + 2 * N + 4 ≀ + (2 * N + 1) * (2 * rawRatWidth y + 4) + 2 * N + 4 := by omega + have hseriesMono := Nat.mul_le_mul_left N hinner + omega + +theorem rawRatWidth_logSeriesError_le (y : RawRat) (N : β„•) : + rawRatWidth (RawRat.logSeriesError y N) ≀ + rawLogSeriesErrorWidthBudget (rawRatWidth y) N := by + let x := RawRat.logUnitParameter y + change rawRatWidth + ((RawRat.ofNat 2).mul + ((x.pow (2 * N + 1)).div + (RawRat.one.add (x.mul x).neg))) ≀ _ + have hx : rawRatWidth x ≀ 2 * rawRatWidth y + 4 := + rawRatWidth_logUnitParameter_le y + have hpow := RawRat.width_pow_le x (2 * N + 1) + have hsquare := rawRatWidth_mul_le x x + have hden := rawRatWidth_add_le RawRat.one (x.mul x).neg + rw [rawRatWidth_one, rawRatWidth_neg] at hden + have hdiv := rawRatWidth_div_le (x.pow (2 * N + 1)) + (RawRat.one.add (x.mul x).neg) + have htwo := RawRat.width_ofNat_le 2 + have hmul := rawRatWidth_mul_le (RawRat.ofNat 2) + ((x.pow (2 * N + 1)).div (RawRat.one.add (x.mul x).neg)) + simp only [rawLogSeriesErrorWidthBudget] + have hprod : + (2 * N + 3) * rawRatWidth x ≀ + (2 * N + 3) * (2 * rawRatWidth y + 4) := + Nat.mul_le_mul_left _ hx + have hdivBound : + rawRatWidth + ((x.pow (2 * N + 1)).div + (RawRat.one.add (x.mul x).neg)) ≀ + 3 + (2 * N + 3) * rawRatWidth x := by + have hdenBound : + rawRatWidth (RawRat.one.add (x.mul x).neg) ≀ + 2 * rawRatWidth x + 2 := by omega + calc + _ ≀ rawRatWidth (x.pow (2 * N + 1)) + + rawRatWidth (RawRat.one.add (x.mul x).neg) := hdiv + _ ≀ (1 + (2 * N + 1) * rawRatWidth x) + + (2 * rawRatWidth x + 2) := Nat.add_le_add hpow hdenBound + _ = 3 + (2 * N + 3) * rawRatWidth x := by ring + have hmulBound : + rawRatWidth + ((RawRat.ofNat 2).mul + ((x.pow (2 * N + 1)).div + (RawRat.one.add (x.mul x).neg))) ≀ + 6 + (2 * N + 3) * rawRatWidth x := by + calc + _ ≀ rawRatWidth (RawRat.ofNat 2) + + rawRatWidth + ((x.pow (2 * N + 1)).div + (RawRat.one.add (x.mul x).neg)) := hmul + _ ≀ 3 + (3 + (2 * N + 3) * rawRatWidth x) := + Nat.add_le_add htwo hdivBound + _ = 6 + (2 * N + 3) * rawRatWidth x := by omega + exact hmulBound.trans (Nat.add_le_add_left hprod 6) + +theorem rawRatWidth_logUnitUpper_le (y : RawRat) (N : β„•) : + rawRatWidth (RawRat.logUnitUpper y N) ≀ + rawLogUnitUpperWidthBudget (rawRatWidth y) N := by + rw [RawRat.logUnitUpper] + have hlo := rawRatWidth_logUnitLower_le y N + have herr := rawRatWidth_logSeriesError_le y N + have hadd := rawRatWidth_add_le (RawRat.logUnitLower y N) + (RawRat.logSeriesError y N) + simp only [rawLogUnitUpperWidthBudget] + omega + +theorem rawLogUnitLowerWidthBudget_le_upper (w N : β„•) : + rawLogUnitLowerWidthBudget w N ≀ rawLogUnitUpperWidthBudget w N := by + simp only [rawLogUnitUpperWidthBudget] + omega + +theorem rationalBinaryExponent_natAbs_size_le (q : β„š) : + (rationalBinaryExponent q).natAbs.size ≀ + 2 * rawRatWidth (rawRatOfRat q) + 1 := by + have hexp := rationalBinaryExponent_natAbs_le_two_rawWidth q + have hsize : (rationalBinaryExponent q).natAbs.size ≀ + (rationalBinaryExponent q).natAbs + 1 := by + rw [Nat.size_le] + exact (Nat.lt_two_pow_self + (n := (rationalBinaryExponent q).natAbs)).trans_le + (Nat.pow_le_pow_right (by decide) (Nat.le_succ _)) + omega + +theorem rawRatWidth_logIntegerLower_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logIntegerLower q N) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 2 + + rawLogUnitUpperWidthBudget 2 N := by + rw [RawRat.logIntegerLower, binaryRationalBinaryExponent_eq] + have hk := rationalBinaryExponent_natAbs_size_le q + have hint := rawRatWidth_ofInt_le (rationalBinaryExponent q) + have htwo : rawRatWidth (RawRat.ofNat 2) = 2 := by + decide + have hlo := rawRatWidth_logUnitLower_le (RawRat.ofNat 2) N + have hhi := rawRatWidth_logUnitUpper_le (RawRat.ofNat 2) N + rw [htwo] at hlo hhi + have hint' : + rawRatWidth (RawRat.ofInt (rationalBinaryExponent q)) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 2 := by omega + split_ifs with hsign + Β· have hmul := rawRatWidth_mul_le + (RawRat.ofInt (rationalBinaryExponent q)) + (RawRat.logUnitLower (RawRat.ofNat 2) N) + have hfactor : + rawRatWidth (RawRat.logUnitLower (RawRat.ofNat 2) N) ≀ + rawLogUnitUpperWidthBudget 2 N := + hlo.trans (rawLogUnitLowerWidthBudget_le_upper 2 N) + exact hmul.trans (Nat.add_le_add hint' hfactor) + Β· have hmul := rawRatWidth_mul_le + (RawRat.ofInt (rationalBinaryExponent q)) + (RawRat.logUnitUpper (RawRat.ofNat 2) N) + exact hmul.trans (Nat.add_le_add hint' hhi) + +theorem rawRatWidth_logIntegerUpper_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logIntegerUpper q N) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 2 + + rawLogUnitUpperWidthBudget 2 N := by + rw [RawRat.logIntegerUpper, binaryRationalBinaryExponent_eq] + have hk := rationalBinaryExponent_natAbs_size_le q + have hint := rawRatWidth_ofInt_le (rationalBinaryExponent q) + have htwo : rawRatWidth (RawRat.ofNat 2) = 2 := by + decide + have hlo := rawRatWidth_logUnitLower_le (RawRat.ofNat 2) N + have hhi := rawRatWidth_logUnitUpper_le (RawRat.ofNat 2) N + rw [htwo] at hlo hhi + have hint' : + rawRatWidth (RawRat.ofInt (rationalBinaryExponent q)) ≀ + 2 * rawRatWidth (rawRatOfRat q) + 2 := by omega + split_ifs with hsign + Β· have hmul := rawRatWidth_mul_le + (RawRat.ofInt (rationalBinaryExponent q)) + (RawRat.logUnitUpper (RawRat.ofNat 2) N) + exact hmul.trans (Nat.add_le_add hint' hhi) + Β· have hmul := rawRatWidth_mul_le + (RawRat.ofInt (rationalBinaryExponent q)) + (RawRat.logUnitLower (RawRat.ofNat 2) N) + have hfactor : + rawRatWidth (RawRat.logUnitLower (RawRat.ofNat 2) N) ≀ + rawLogUnitUpperWidthBudget 2 N := + hlo.trans (rawLogUnitLowerWidthBudget_le_upper 2 N) + exact hmul.trans (Nat.add_le_add hint' hfactor) + +theorem rawRatWidth_logResidualLower_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logResidualLower q N) ≀ + rawLogUnitUpperWidthBudget + (2 * rawRatWidth (rawRatOfRat q) + 1) N := by + rw [RawRat.logResidualLower] + have hy := rawRatWidth_logUnit_le q + have hlo := rawRatWidth_logUnitLower_le (RawRat.logUnit q) N + have hhi := rawRatWidth_logUnitUpper_le (RawRat.logUnit q) N + have hmono : + rawLogUnitUpperWidthBudget (rawRatWidth (RawRat.logUnit q)) N ≀ + rawLogUnitUpperWidthBudget + (2 * rawRatWidth (rawRatOfRat q) + 1) N := by + exact rawLogUnitUpperWidthBudget_mono hy + split_ifs + Β· exact hlo.trans + ((rawLogUnitLowerWidthBudget_le_upper _ _).trans hmono) + Β· rw [rawRatWidth_neg] + exact hhi.trans hmono + +theorem rawRatWidth_logResidualUpper_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logResidualUpper q N) ≀ + rawLogUnitUpperWidthBudget + (2 * rawRatWidth (rawRatOfRat q) + 1) N := by + rw [RawRat.logResidualUpper] + have hy := rawRatWidth_logUnit_le q + have hlo := rawRatWidth_logUnitLower_le (RawRat.logUnit q) N + have hhi := rawRatWidth_logUnitUpper_le (RawRat.logUnit q) N + have hmono : + rawLogUnitUpperWidthBudget (rawRatWidth (RawRat.logUnit q)) N ≀ + rawLogUnitUpperWidthBudget + (2 * rawRatWidth (rawRatOfRat q) + 1) N := by + exact rawLogUnitUpperWidthBudget_mono hy + split_ifs + Β· exact hhi.trans hmono + Β· rw [rawRatWidth_neg] + exact hlo.trans + ((rawLogUnitLowerWidthBudget_le_upper _ _).trans hmono) + +theorem rawRatWidth_logLower_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logLower q N) ≀ + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat q)) N := by + rw [RawRat.logLower] + have hint := rawRatWidth_logIntegerLower_le q N + have hres := rawRatWidth_logResidualLower_le q N + have hadd := rawRatWidth_add_le (RawRat.logIntegerLower q N) + (RawRat.logResidualLower q N) + exact hadd.trans (by + simp only [rawDirectedLogWidthBudget] + omega) + +theorem rawRatWidth_logUpper_le (q : β„š) (N : β„•) : + rawRatWidth (RawRat.logUpper q N) ≀ + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat q)) N := by + rw [RawRat.logUpper] + have hint := rawRatWidth_logIntegerUpper_le q N + have hres := rawRatWidth_logResidualUpper_le q N + have hadd := rawRatWidth_add_le (RawRat.logIntegerUpper q N) + (RawRat.logResidualUpper q N) + exact hadd.trans (by + simp only [rawDirectedLogWidthBudget] + omega) + +theorem rawRatWidth_scheduledLogLower_le (q : β„š) (p : β„•) : + rawRatWidth (rawScheduledLogLower q p) ≀ + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat q)) + (directedLogTerms q p) := by + exact rawRatWidth_logLower_le q (directedLogTerms q p) + +theorem rawRatWidth_scheduledLogUpper_le (q : β„š) (p : β„•) : + rawRatWidth (rawScheduledLogUpper q p) ≀ + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat q)) + (directedLogTerms q p) := by + exact rawRatWidth_logUpper_le q (directedLogTerms q p) + +theorem directedLogTerms_le_rawWidth (q : β„š) (p : β„•) : + directedLogTerms q p ≀ + p + 2 * rawRatWidth (rawRatOfRat q) + 2 := by + have h := rationalBinaryExponent_natAbs_le_two_rawWidth q + rw [directedLogTerms] + omega + +/-- Closed polynomial width bound for one scheduled lower logarithm. -/ +theorem rawRatWidth_scheduledLogLower_polynomial_le (q : β„š) (p : β„•) : + rawRatWidth (rawScheduledLogLower q p) ≀ + 64 * (p + 2 * rawRatWidth (rawRatOfRat q) + 4) ^ 2 * + (rawRatWidth (rawRatOfRat q) + 2) := by + have hterms0 := directedLogTerms_le_rawWidth q p + have hterms : directedLogTerms q p + 2 ≀ + p + 2 * rawRatWidth (rawRatOfRat q) + 4 := by omega + have hsquare : (directedLogTerms q p + 2) ^ 2 ≀ + (p + 2 * rawRatWidth (rawRatOfRat q) + 4) ^ 2 := + Nat.pow_le_pow_left hterms 2 + have hmul := Nat.mul_le_mul_right + (rawRatWidth (rawRatOfRat q) + 2) + (Nat.mul_le_mul_left 64 hsquare) + exact (rawRatWidth_scheduledLogLower_le q p).trans + ((rawDirectedLogWidthBudget_le + (rawRatWidth (rawRatOfRat q)) (directedLogTerms q p)).trans hmul) + +/-- Closed polynomial width bound for one scheduled upper logarithm. -/ +theorem rawRatWidth_scheduledLogUpper_polynomial_le (q : β„š) (p : β„•) : + rawRatWidth (rawScheduledLogUpper q p) ≀ + 64 * (p + 2 * rawRatWidth (rawRatOfRat q) + 4) ^ 2 * + (rawRatWidth (rawRatOfRat q) + 2) := by + have hterms0 := directedLogTerms_le_rawWidth q p + have hterms : directedLogTerms q p + 2 ≀ + p + 2 * rawRatWidth (rawRatOfRat q) + 4 := by omega + have hsquare : (directedLogTerms q p + 2) ^ 2 ≀ + (p + 2 * rawRatWidth (rawRatOfRat q) + 4) ^ 2 := + Nat.pow_le_pow_left hterms 2 + have hmul := Nat.mul_le_mul_right + (rawRatWidth (rawRatOfRat q) + 2) + (Nat.mul_le_mul_left 64 hsquare) + exact (rawRatWidth_scheduledLogUpper_le q p).trans + ((rawDirectedLogWidthBudget_le + (rawRatWidth (rawRatOfRat q)) (directedLogTerms q p)).trans hmul) + +theorem rawRatWidth_scheduledLogLower_of_bounds_le + (q : β„š) {p P W : β„•} (hp : p ≀ P) + (hw : rawRatWidth (rawRatOfRat q) ≀ W) : + rawRatWidth (rawScheduledLogLower q p) ≀ + 64 * (P + 2 * W + 4) ^ 2 * (W + 2) := by + have hbase : p + 2 * rawRatWidth (rawRatOfRat q) + 4 ≀ + P + 2 * W + 4 := by omega + have hpow := Nat.pow_le_pow_left hbase 2 + have hleft := Nat.mul_le_mul_left 64 hpow + have hright : rawRatWidth (rawRatOfRat q) + 2 ≀ W + 2 := by omega + exact (rawRatWidth_scheduledLogLower_polynomial_le q p).trans + (Nat.mul_le_mul hleft hright) + +theorem rawRatWidth_scheduledLogUpper_of_bounds_le + (q : β„š) {p P W : β„•} (hp : p ≀ P) + (hw : rawRatWidth (rawRatOfRat q) ≀ W) : + rawRatWidth (rawScheduledLogUpper q p) ≀ + 64 * (P + 2 * W + 4) ^ 2 * (W + 2) := by + have hbase : p + 2 * rawRatWidth (rawRatOfRat q) + 4 ≀ + P + 2 * W + 4 := by omega + have hpow := Nat.pow_le_pow_left hbase 2 + have hleft := Nat.mul_le_mul_left 64 hpow + have hright : rawRatWidth (rawRatOfRat q) + 2 ≀ W + 2 := by omega + exact (rawRatWidth_scheduledLogUpper_polynomial_le q p).trans + (Nat.mul_le_mul hleft hright) + +theorem rawRatWidth_complement_le (x : β„š) : + rawRatWidth (rawRatOfRat (1 - x)) ≀ + 44 + 12 * rawRatWidth (rawRatOfRat x) := by + let r := RawRat.one.add (rawRatOfRat x).neg + have hr : rawRatWidth r ≀ rawRatWidth (rawRatOfRat x) + 2 := by + have hadd := rawRatWidth_add_le RawRat.one (rawRatOfRat x).neg + rw [rawRatWidth_one, rawRatWidth_neg] at hadd + exact hadd.trans (by omega) + have hvalue : binaryNormalizeRawRat r = 1 - x := by + rw [binaryNormalizeRawRat_eq_value] + simp [r, RawRat.value_add, RawRat.value_one, RawRat.value_neg, + rawRatOfRat_value] + ring + have hcanonical := rawRatOfRat_width_le_encodedBitLength (1 - x) + rw [← hvalue] at hcanonical + have hnormalize := binaryNormalizeRawRat_encodedBitLength_le r + rw [← hvalue] + omega + +/-- Budget the raw nearby-Bethe coordinate using scheduled logarithms of `x` and `1 - x` and the +widths of `tau` and `x`. -/ +def rawNearbyCoordinateWidthBudget (tau : RawRat) (x : β„š) (p : β„•) : β„• := + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat (1 - x))) + (directedLogTerms (1 - x) p) + + rawRatWidth tau + rawRatWidth (rawRatOfRat x) + + rawDirectedLogWidthBudget (rawRatWidth (rawRatOfRat x)) + (directedLogTerms x p) + 1 + +theorem rawRatWidth_nearbyCoordinateLower_le + (tau : RawRat) (x : β„š) (p : β„•) : + rawRatWidth (rawNearbyCoordinateLower tau x p) ≀ + rawNearbyCoordinateWidthBudget tau x p := by + rw [rawNearbyCoordinateLower] + have hcomp := rawRatWidth_scheduledLogLower_le (1 - x) p + have htx := rawRatWidth_mul_le tau (rawRatOfRat x) + have hlogx := rawRatWidth_scheduledLogLower_le x p + have hweighted := rawRatWidth_mul_le (tau.mul (rawRatOfRat x)) + (rawScheduledLogLower x p) + have hadd := rawRatWidth_add_le (rawScheduledLogLower (1 - x) p) + ((tau.mul (rawRatOfRat x)).mul (rawScheduledLogLower x p)) + exact hadd.trans (by + simp only [rawNearbyCoordinateWidthBudget] + omega) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledRoundedEllipsoid.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledRoundedEllipsoid.lean new file mode 100644 index 0000000000..050bdf5a92 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledRoundedEllipsoid.lean @@ -0,0 +1,489 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDyadicFloorMatrix + +/-! +# Polynomial-time scheduled rounded ellipsoid update + +This module implements the determinant-independent rounded state transition. +The center and basis are floored at a unary precision. The rounded basis is +then left-multiplied by an explicitly constructed scalar diagonal matrix, +which realizes the prescribed inflation without another matrix mapper. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Represent the rounding-inflation denominator `1024 * d^4` as a raw rational. -/ +def rawRoundedInflationDenominator (d : β„•) : RawRat := + (RawRat.ofNat 1024).mul + ((rawEllipsoidDimensionSquare d).mul + (rawEllipsoidDimensionSquare d)) + +/-- Represent the inflation amount `1 / (1024 * d^4)` using total raw-rational division. -/ +def rawRoundedInflation (d : β„•) : RawRat := + rawEllipsoidOne.div (rawRoundedInflationDenominator d) + +/-- Add one to the raw rounding-inflation amount to obtain the basis scale factor. -/ +def rawRoundedInflationFactor (d : β„•) : RawRat := + rawEllipsoidOne.add (rawRoundedInflation d) + +@[simp] theorem rawRoundedInflation_value (d : β„•) : + (rawRoundedInflation d).value = roundedEllipsoidInflation d := by + simp [rawRoundedInflation, rawRoundedInflationDenominator, + roundedEllipsoidInflation, rawEllipsoidDimensionSquare, + rawEllipsoidOne, RawRat.value_one, RawRat.value_ofNat] + ring + +@[simp] theorem rawRoundedInflationFactor_value (d : β„•) : + (rawRoundedInflationFactor d).value = + 1 + roundedEllipsoidInflation d := by + simp [rawRoundedInflationFactor, rawEllipsoidOne, + RawRat.value_one, RawRat.value_ofNat] + +/-- Extract the unary precision ruler from a scheduled ellipsoid-rounding input. -/ +def machineScheduledRoundPrecision (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the encoded ellipsoid state from a scheduled-rounding input. -/ +def machineScheduledRoundState (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the binary dimension from the ellipsoid state being rounded. -/ +def machineScheduledRoundDimensionBits (word : List Bool) : List Bool := + machineRationalEllipsoidDimensionWord (machineScheduledRoundState word) + +/-- Convert the ellipsoid dimension to unary, bounded by the encoded state length. -/ +def machineScheduledRoundDimensionUnary (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineScheduledRoundState word) + (machineScheduledRoundDimensionBits word)) + +/-- Extract the rational center-vector code from the ellipsoid state being rounded. -/ +def machineScheduledRoundCenter (word : List Bool) : List Bool := + machineRationalEllipsoidCenterWord (machineScheduledRoundState word) + +/-- Extract the rational basis-matrix code from the ellipsoid state being rounded. -/ +def machineScheduledRoundBasis (word : List Bool) : List Bool := + machineRationalEllipsoidBasisWord (machineScheduledRoundState word) + +/-- Convert a binary dimension word into its raw-rational scalar code. -/ +def machineRoundedInflationDimensionRawCode + (word : List Bool) : List Bool := + machineEllipsoidDimensionRawCode word + +/-- Square the encoded dimension using raw-rational multiplication. -/ +def machineRoundedInflationDimensionSquareRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineRoundedInflationDimensionRawCode word) + (machineRoundedInflationDimensionRawCode word)) + +/-- Square the raw dimension square to encode its fourth power. -/ +def machineRoundedInflationDimensionFourthRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineRoundedInflationDimensionSquareRawCode word) + (machineRoundedInflationDimensionSquareRawCode word)) + +/-- Multiply the encoded fourth power of the dimension by 1024 to form the inflation +denominator. -/ +def machineRoundedInflationDenominatorRawCode + (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode (RawRat.ofNat 1024)) + (machineRoundedInflationDimensionFourthRawCode word)) + +/-- Divide raw rational one by the encoded inflation denominator. -/ +def machineRoundedInflationRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode rawEllipsoidOne) + (machineRoundedInflationDenominatorRawCode word)) + +/-- Add raw rational one to the encoded inflation amount. -/ +def machineRoundedInflationFactorRawCode + (word : List Bool) : List Bool := + machineRawRatAddCode + (pair (rawRatBinaryCode rawEllipsoidOne) + (machineRoundedInflationRawCode word)) + +/-- Normalize the raw inflation factor into a rational matrix-entry code. -/ +def machineRoundedInflationFactorEntryCode + (word : List Bool) : List Bool := + machineNormalizeRawRatEntryCode + (machineRoundedInflationFactorRawCode word) + +/-- Floor the ellipsoid center coordinates at the scheduled dyadic precision. -/ +def machineScheduledRoundCenterCode (word : List Bool) : List Bool := + machineDyadicFloorVectorCode + (pair (machineScheduledRoundPrecision word) + (machineScheduledRoundCenter word)) + +/-- Floor the ellipsoid basis entries at the scheduled dyadic precision. -/ +def machineScheduledRoundFlooredBasisCode + (word : List Bool) : List Bool := + machineDyadicFloorMatrixCode + (pair (machineScheduledRoundPrecision word) + (machineScheduledRoundBasis word)) + +/-- Construct the scalar diagonal matrix whose diagonal is the normalized rounding-inflation +factor. -/ +def machineScheduledRoundInflationDiagonalCode + (word : List Bool) : List Bool := + machineDiagonalBasisRowsCode + (pair (machineScheduledRoundDimensionUnary word) + (machineRoundedInflationFactorEntryCode + (machineScheduledRoundDimensionBits word))) + +/-- Left-multiply the dyadically floored basis by the scalar inflation diagonal matrix. -/ +def machineScheduledRoundBasisCode (word : List Bool) : List Bool := + machineRationalMatrixMulCode + (pair (machineScheduledRoundDimensionUnary word) + (pair (machineScheduledRoundInflationDiagonalCode word) + (machineScheduledRoundFlooredBasisCode word))) + +/-- Input: `pair precisionUnary rationalEllipsoidStateBinaryCode`. -/ +def machineScheduledRoundedEllipsoidCode (word : List Bool) : List Bool := + pair (machineScheduledRoundDimensionBits word) + (pair (machineScheduledRoundCenterCode word) + (machineScheduledRoundBasisCode word)) + +/-! ## Polynomial-time closure -/ + +theorem machineScheduledRoundPrecision_mem_FP : + machineScheduledRoundPrecision ∈ FP := machinePairFirst_mem_FP + +theorem machineScheduledRoundState_mem_FP : + machineScheduledRoundState ∈ FP := machinePairSecond_mem_FP + +theorem machineScheduledRoundDimensionBits_mem_FP : + machineScheduledRoundDimensionBits ∈ FP := by + simpa only [machineScheduledRoundDimensionBits] using! + machineCompose_mem_FP machineScheduledRoundState_mem_FP + machineRationalEllipsoidDimensionWord_mem_FP + +theorem machineScheduledRoundDimensionUnary_mem_FP : + machineScheduledRoundDimensionUnary ∈ FP := by + have hinput := machinePair_mem_FP machineScheduledRoundState_mem_FP + machineScheduledRoundDimensionBits_mem_FP + simpa only [machineScheduledRoundDimensionUnary] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineScheduledRoundCenter_mem_FP : + machineScheduledRoundCenter ∈ FP := by + simpa only [machineScheduledRoundCenter] using! + machineCompose_mem_FP machineScheduledRoundState_mem_FP + machineRationalEllipsoidCenterWord_mem_FP + +theorem machineScheduledRoundBasis_mem_FP : + machineScheduledRoundBasis ∈ FP := by + simpa only [machineScheduledRoundBasis] using! + machineCompose_mem_FP machineScheduledRoundState_mem_FP + machineRationalEllipsoidBasisWord_mem_FP + +theorem machineRoundedInflationDimensionRawCode_mem_FP : + machineRoundedInflationDimensionRawCode ∈ FP := + machineEllipsoidDimensionRawCode_mem_FP + +theorem machineRoundedInflationDimensionSquareRawCode_mem_FP : + machineRoundedInflationDimensionSquareRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRoundedInflationDimensionRawCode_mem_FP + machineRoundedInflationDimensionRawCode_mem_FP + simpa only [machineRoundedInflationDimensionSquareRawCode] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineRoundedInflationDimensionFourthRawCode_mem_FP : + machineRoundedInflationDimensionFourthRawCode ∈ FP := by + have hinput := machinePair_mem_FP + machineRoundedInflationDimensionSquareRawCode_mem_FP + machineRoundedInflationDimensionSquareRawCode_mem_FP + simpa only [machineRoundedInflationDimensionFourthRawCode] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineRoundedInflationDenominatorRawCode_mem_FP : + machineRoundedInflationDenominatorRawCode ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (RawRat.ofNat 1024))) + machineRoundedInflationDimensionFourthRawCode_mem_FP + simpa only [machineRoundedInflationDenominatorRawCode] using! + machineCompose_mem_FP hinput machineRawRatMulCode_mem_FP + +theorem machineRoundedInflationRawCode_mem_FP : + machineRoundedInflationRawCode ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidOne)) + machineRoundedInflationDenominatorRawCode_mem_FP + simpa only [machineRoundedInflationRawCode] using! + machineCompose_mem_FP hinput machineRawRatDivCode_mem_FP + +theorem machineRoundedInflationFactorRawCode_mem_FP : + machineRoundedInflationFactorRawCode ∈ FP := by + have hinput := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode rawEllipsoidOne)) + machineRoundedInflationRawCode_mem_FP + simpa only [machineRoundedInflationFactorRawCode] using! + machineCompose_mem_FP hinput machineRawRatAddCode_mem_FP + +theorem machineRoundedInflationFactorEntryCode_mem_FP : + machineRoundedInflationFactorEntryCode ∈ FP := by + simpa only [machineRoundedInflationFactorEntryCode] using! + machineCompose_mem_FP machineRoundedInflationFactorRawCode_mem_FP + machineNormalizeRawRatEntryCode_mem_FP + +theorem machineScheduledRoundCenterCode_mem_FP : + machineScheduledRoundCenterCode ∈ FP := by + have hinput := machinePair_mem_FP machineScheduledRoundPrecision_mem_FP + machineScheduledRoundCenter_mem_FP + simpa only [machineScheduledRoundCenterCode] using! + machineCompose_mem_FP hinput machineDyadicFloorVectorCode_mem_FP + +theorem machineScheduledRoundFlooredBasisCode_mem_FP : + machineScheduledRoundFlooredBasisCode ∈ FP := by + have hinput := machinePair_mem_FP machineScheduledRoundPrecision_mem_FP + machineScheduledRoundBasis_mem_FP + simpa only [machineScheduledRoundFlooredBasisCode] using! + machineCompose_mem_FP hinput machineDyadicFloorMatrixCode_mem_FP + +theorem machineScheduledRoundInflationDiagonalCode_mem_FP : + machineScheduledRoundInflationDiagonalCode ∈ FP := by + have hfactor := machineCompose_mem_FP + machineScheduledRoundDimensionBits_mem_FP + machineRoundedInflationFactorEntryCode_mem_FP + have hinput := machinePair_mem_FP + machineScheduledRoundDimensionUnary_mem_FP hfactor + simpa only [machineScheduledRoundInflationDiagonalCode] using! + machineCompose_mem_FP hinput machineDiagonalBasisRowsCode_mem_FP + +theorem machineScheduledRoundBasisCode_mem_FP : + machineScheduledRoundBasisCode ∈ FP := by + have hinput := machinePair_mem_FP + machineScheduledRoundDimensionUnary_mem_FP + (machinePair_mem_FP + machineScheduledRoundInflationDiagonalCode_mem_FP + machineScheduledRoundFlooredBasisCode_mem_FP) + simpa only [machineScheduledRoundBasisCode] using! + machineCompose_mem_FP hinput machineRationalMatrixMulCode_mem_FP + +theorem machineScheduledRoundedEllipsoidCode_mem_FP : + machineScheduledRoundedEllipsoidCode ∈ FP := + machinePair_mem_FP machineScheduledRoundDimensionBits_mem_FP + (machinePair_mem_FP machineScheduledRoundCenterCode_mem_FP + machineScheduledRoundBasisCode_mem_FP) + +/-! ## Exact semantics -/ + +@[simp] theorem machineScheduledRoundDimensionUnary_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundDimensionUnary + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + List.replicate d true := by + rw [machineScheduledRoundDimensionUnary] + simp only [machineScheduledRoundState, machinePairSecond_pair, + machineScheduledRoundDimensionBits, + machineRationalEllipsoidDimensionWord_encode] + exact machineBoundedUnary_encode_of_le + (rationalEllipsoidStateBinaryCode E) d + (rationalEllipsoid_dimension_le_state_code_length E) + +@[simp] theorem machineRoundedInflationDimensionRawCode_encode (d : β„•) : + machineRoundedInflationDimensionRawCode d.bits = + rawRatBinaryCode (rawEllipsoidDimension d) := by + exact machineEllipsoidDimensionRawCode_encode d + +@[simp] theorem machineRoundedInflationDimensionSquareRawCode_encode + (d : β„•) : + machineRoundedInflationDimensionSquareRawCode d.bits = + rawRatBinaryCode (rawEllipsoidDimensionSquare d) := by + rw [machineRoundedInflationDimensionSquareRawCode] + simp only [machineRoundedInflationDimensionRawCode_encode, + machineRawRatMulCode_encode, rawEllipsoidDimensionSquare] + +@[simp] theorem machineRoundedInflationDimensionFourthRawCode_encode + (d : β„•) : + machineRoundedInflationDimensionFourthRawCode d.bits = + rawRatBinaryCode ((rawEllipsoidDimensionSquare d).mul + (rawEllipsoidDimensionSquare d)) := by + rw [machineRoundedInflationDimensionFourthRawCode] + simp only [machineRoundedInflationDimensionSquareRawCode_encode, + machineRawRatMulCode_encode] + +@[simp] theorem machineRoundedInflationDenominatorRawCode_encode (d : β„•) : + machineRoundedInflationDenominatorRawCode d.bits = + rawRatBinaryCode (rawRoundedInflationDenominator d) := by + rw [machineRoundedInflationDenominatorRawCode] + simp only [machineRoundedInflationDimensionFourthRawCode_encode, + machineRawRatMulCode_encode, rawRoundedInflationDenominator] + +@[simp] theorem machineRoundedInflationRawCode_encode (d : β„•) : + machineRoundedInflationRawCode d.bits = + rawRatBinaryCode (rawRoundedInflation d) := by + rw [machineRoundedInflationRawCode] + simp only [machineRoundedInflationDenominatorRawCode_encode, + machineRawRatDivCode_encode, rawRoundedInflation] + +@[simp] theorem machineRoundedInflationFactorRawCode_encode (d : β„•) : + machineRoundedInflationFactorRawCode d.bits = + rawRatBinaryCode (rawRoundedInflationFactor d) := by + rw [machineRoundedInflationFactorRawCode] + simp only [machineRoundedInflationRawCode_encode, + machineRawRatAddCode_encode, rawRoundedInflationFactor] + +@[simp] theorem machineRoundedInflationFactorEntryCode_encode (d : β„•) : + machineRoundedInflationFactorEntryCode d.bits = + rationalEntryBinaryCode (1 + roundedEllipsoidInflation d) := by + rw [machineRoundedInflationFactorEntryCode, + machineRoundedInflationFactorRawCode_encode, + machineNormalizeRawRatEntryCode_encode, + binaryNormalizeRawRat_eq_value, + rawRoundedInflationFactor_value] + +@[simp] theorem machineScheduledRoundCenterCode_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundCenterCode + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + rationalFiniteVectorCode (dyadicFloorVector p E.center) := by + rw [machineScheduledRoundCenterCode] + simp only [machineScheduledRoundPrecision, machinePairFirst_pair, + machineScheduledRoundCenter, machineScheduledRoundState, + machinePairSecond_pair, machineRationalEllipsoidCenterWord_encode] + change machineDyadicFloorVectorCode + (dyadicFloorVectorCanonicalWord p E.center) = _ + rw [machineDyadicFloorVectorCode_encode] + +@[simp] theorem machineScheduledRoundFlooredBasisCode_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundFlooredBasisCode + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + rationalSquareMatrixRowsCode (dyadicFloorMatrix p E.basis) := by + rw [machineScheduledRoundFlooredBasisCode] + simp only [machineScheduledRoundPrecision, machinePairFirst_pair, + machineScheduledRoundBasis, machineScheduledRoundState, + machinePairSecond_pair, machineRationalEllipsoidBasisWord_encode] + change machineDyadicFloorMatrixCode + (dyadicFloorMatrixCanonicalWord p E.basis) = _ + rw [machineDyadicFloorMatrixCode_encode] + +@[simp] theorem machineScheduledRoundInflationDiagonalCode_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundInflationDiagonalCode + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + rationalSquareMatrixRowsCode + (rationalBallEllipsoid d 0 + (1 + roundedEllipsoidInflation d)).basis := by + rw [machineScheduledRoundInflationDiagonalCode] + simp only [machineScheduledRoundDimensionUnary_encode, + machineScheduledRoundDimensionBits, machineScheduledRoundState, + machinePairSecond_pair, machineRationalEllipsoidDimensionWord_encode, + machineRoundedInflationFactorEntryCode_encode] + exact machineDiagonalBasisRowsCode_encode d + (1 + roundedEllipsoidInflation d) + +theorem rationalMatrixMul_inflationDiagonal {d : β„•} + (s : β„š) (A : Matrix (Fin d) (Fin d) β„š) : + rationalMatrixMul (rationalBallEllipsoid d 0 s).basis A = + fun i j ↦ s * A i j := by + rw [rationalMatrixMul_eq_matrix_mul, + rationalBallEllipsoid_basis] + ext i j + rw [Matrix.diagonal_mul] + +@[simp] theorem machineScheduledRoundBasisCode_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundBasisCode + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + rationalSquareMatrixRowsCode + (scheduledRoundedEllipsoid p E).basis := by + rw [machineScheduledRoundBasisCode] + simp only [machineScheduledRoundDimensionUnary_encode, + machineScheduledRoundInflationDiagonalCode_encode, + machineScheduledRoundFlooredBasisCode_encode] + change machineRationalMatrixMulCode + (rationalMatrixMulCanonicalWord + (rationalBallEllipsoid d 0 + (1 + roundedEllipsoidInflation d)).basis + (dyadicFloorMatrix p E.basis)) = _ + rw [machineRationalMatrixMulCode_encode, + rationalMatrixMul_inflationDiagonal] + rfl + +@[simp] theorem machineScheduledRoundedEllipsoidCode_encode {d : β„•} + (p : β„•) (E : RationalEllipsoidState d) : + machineScheduledRoundedEllipsoidCode + (pair (List.replicate p true) + (rationalEllipsoidStateBinaryCode E)) = + rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoid p E) := by + rw [machineScheduledRoundedEllipsoidCode, + machineScheduledRoundCenterCode_encode, + machineScheduledRoundBasisCode_encode] + simp [machineScheduledRoundDimensionBits, + machineScheduledRoundState, machineRationalEllipsoidDimensionWord, + rationalEllipsoidStateBinaryCode, + scheduledRoundedEllipsoid] + +/-! ## Exact central update followed by scheduled rounding -/ + +/-- Extract the precision ruler for a central ellipsoid update followed by rounding. -/ +def machineScheduledCentralPrecision (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the paired ellipsoid state and cut used by the exact central update. -/ +def machineScheduledCentralStateAndCut (word : List Bool) : List Bool := + machinePairSecond word + +/-- Perform the exact rational central ellipsoid update and then round at the supplied +precision. -/ +def machineScheduledRoundedEllipsoidCentralUpdateCode + (word : List Bool) : List Bool := + machineScheduledRoundedEllipsoidCode + (pair (machineScheduledCentralPrecision word) + (machineRationalEllipsoidCentralUpdateCode + (machineScheduledCentralStateAndCut word))) + +theorem machineScheduledCentralPrecision_mem_FP : + machineScheduledCentralPrecision ∈ FP := machinePairFirst_mem_FP + +theorem machineScheduledCentralStateAndCut_mem_FP : + machineScheduledCentralStateAndCut ∈ FP := machinePairSecond_mem_FP + +theorem machineScheduledRoundedEllipsoidCentralUpdateCode_mem_FP : + machineScheduledRoundedEllipsoidCentralUpdateCode ∈ FP := by + have hupdate := machineCompose_mem_FP + machineScheduledCentralStateAndCut_mem_FP + machineRationalEllipsoidCentralUpdateCode_mem_FP + have hinput := machinePair_mem_FP machineScheduledCentralPrecision_mem_FP + hupdate + simpa only [machineScheduledRoundedEllipsoidCentralUpdateCode] using! + machineCompose_mem_FP hinput machineScheduledRoundedEllipsoidCode_mem_FP + +@[simp] theorem machineScheduledRoundedEllipsoidCentralUpdateCode_encode + {d : β„•} (p : β„•) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + machineScheduledRoundedEllipsoidCentralUpdateCode + (pair (List.replicate p true) + (pair (rationalEllipsoidStateBinaryCode E) + (rationalFiniteVectorCode a))) = + rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoidCentralUpdate p E a) := by + rw [machineScheduledRoundedEllipsoidCentralUpdateCode] + simp only [machineScheduledCentralPrecision, machinePairFirst_pair, + machineScheduledCentralStateAndCut, machinePairSecond_pair, + machineRationalEllipsoidCentralUpdateCode_encode] + rw [machineScheduledRoundedEllipsoidCode_encode] + rfl + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledStateEncodingBound.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledStateEncodingBound.lean new file mode 100644 index 0000000000..4d5f6a834e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineScheduledStateEncodingBound.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheFeasibilitySemantics +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import Mathlib.Tactic + +/-! +# Ordinary binary bounds for scheduled ellipsoid states + +The semantic feasibility proof bounds magnitudes and denominators. The +finite-word loop needs the corresponding bound on its concrete, nested binary +code. This file supplies that elementary bridge without changing encodings. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity +open scoped BigOperators + +/-- Encoding-length bound `8 + 2*K + 4*P` for a rational entry with magnitude and precision +parameters. -/ +def rationalEntryMachineCodeBound (K P : β„•) : β„• := + 8 + 2 * K + 4 * P + +/-- Bound a length-`d` encoded rational vector by summing entry and list-pairing costs. -/ +def rationalVectorMachineCodeBound (d K P : β„•) : β„• := + d * (2 * rationalEntryMachineCodeBound K P + 2) + +/-- Bound a square rational matrix encoding by summing vector-row and list-pairing costs. -/ +def rationalMatrixMachineCodeBound (d K P : β„•) : β„• := + d * (2 * rationalVectorMachineCodeBound d K P + 2) + +/-- Combine dimension, center, basis, and pairing costs into a rational ellipsoid-state encoding +bound. -/ +def rationalEllipsoidMachineCodeBound (d K P : β„•) : β„• := + 2 * (d + 1) + + 2 * (2 * rationalVectorMachineCodeBound d K P + + 2 * rationalMatrixMachineCodeBound d K P + 2) + 2 + +theorem integerBinaryCode_length_le_of_natAbs_le_two_pow + {z : β„€} {K : β„•} (h : z.natAbs ≀ 2 ^ K) : + (integerBinaryCode z).length ≀ K + 2 := by + cases z with + | ofNat n => + have hn : n ≀ 2 ^ K := by simpa using! h + have hs := nat_size_le_succ_of_le_two_pow hn + have hs' : n.bits.length ≀ K + 1 := by + simpa only [Nat.size_eq_bits_len] using! hs + simp only [integerBinaryCode, List.length_cons] + omega + | negSucc n => + have hn : n ≀ 2 ^ K := by + simp only [Int.natAbs_negSucc] at h + omega + have hs := nat_size_le_succ_of_le_two_pow hn + have hs' : n.bits.length ≀ K + 1 := by + simpa only [Nat.size_eq_bits_len] using! hs + simp only [integerBinaryCode, List.length_cons] + omega + +theorem rationalEntryBinaryCode_length_le_of_abs_and_den_bounds + {q : β„š} {K P : β„•} + (habs : abs q ≀ (2 : β„š) ^ K) + (hden : q.den ≀ 2 ^ P) : + (rationalEntryBinaryCode q).length ≀ + rationalEntryMachineCodeBound K P := by + have hnum := rat_num_natAbs_le_of_abs_and_den_bounds habs hden + have hnumCode := integerBinaryCode_length_le_of_natAbs_le_two_pow hnum + have hdenSize := nat_size_le_succ_of_le_two_pow hden + rw [rationalEntryBinaryCode, pair_length] + rw [← Nat.size_eq_bits_len] at hdenSize + simp only [rationalEntryMachineCodeBound] + omega + +theorem rationalFiniteVectorCode_length_le_of_bounds {d K P : β„•} + (v : Fin d β†’ β„š) + (habs : βˆ€ i, abs (v i) ≀ (2 : β„š) ^ K) + (hden : βˆ€ i, (v i).den ≀ 2 ^ P) : + (rationalFiniteVectorCode v).length ≀ + rationalVectorMachineCodeBound d K P := by + rw [rationalFiniteVectorCode, binaryListCode_length_eq_sum, + List.map_ofFn, List.sum_ofFn] + have hsum : (βˆ‘ i : Fin d, + (2 * (rationalEntryBinaryCode (v i)).length + 2)) ≀ + βˆ‘ _i : Fin d, (2 * rationalEntryMachineCodeBound K P + 2) := by + apply Finset.sum_le_sum + intro i _ + have hi := rationalEntryBinaryCode_length_le_of_abs_and_den_bounds + (habs i) (hden i) + omega + simpa only [rationalVectorMachineCodeBound, Finset.sum_const, + Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, + Nat.mul_comm] using! hsum + +theorem rationalSquareMatrixRowsCode_length_le_of_bounds {d K P : β„•} + (A : Matrix (Fin d) (Fin d) β„š) + (habs : βˆ€ i j, abs (A i j) ≀ (2 : β„š) ^ K) + (hden : βˆ€ i j, (A i j).den ≀ 2 ^ P) : + (rationalSquareMatrixRowsCode A).length ≀ + rationalMatrixMachineCodeBound d K P := by + rw [rationalSquareMatrixRowsCode, binaryListCode_length_eq_sum, + rationalMatrixRows, List.map_ofFn, List.sum_ofFn] + have hsum : (βˆ‘ i : Fin d, + (2 * (binaryListCode rationalEntryBinaryCode + (List.ofFn (A i))).length + 2)) ≀ + βˆ‘ _i : Fin d, (2 * rationalVectorMachineCodeBound d K P + 2) := by + apply Finset.sum_le_sum + intro i _ + have hi := rationalFiniteVectorCode_length_le_of_bounds + (A i) (habs i) (hden i) + simp only [rationalFiniteVectorCode] at hi + omega + simpa only [rationalMatrixMachineCodeBound, Finset.sum_const, + Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, + Nat.mul_comm] using! hsum + +theorem nat_bits_length_le_add_one (d : β„•) : + d.bits.length ≀ d + 1 := by + cases d with + | zero => simp + | succ k => + rw [Nat.size_eq_bits_len, Nat.size_le] + exact Nat.lt_two_pow_self.trans + (Nat.pow_lt_pow_right (by decide) (by omega)) + +theorem rationalEllipsoidStateBinaryCode_length_le_of_bounds {d K P : β„•} + (E : RationalEllipsoidState d) + (hcenterAbs : βˆ€ i, abs (E.center i) ≀ (2 : β„š) ^ K) + (hcenterDen : βˆ€ i, (E.center i).den ≀ 2 ^ P) + (hbasisAbs : βˆ€ i j, abs (E.basis i j) ≀ (2 : β„š) ^ K) + (hbasisDen : βˆ€ i j, (E.basis i j).den ≀ 2 ^ P) : + (rationalEllipsoidStateBinaryCode E).length ≀ + rationalEllipsoidMachineCodeBound d K P := by + have hc := rationalFiniteVectorCode_length_le_of_bounds + E.center hcenterAbs hcenterDen + have hB := rationalSquareMatrixRowsCode_length_le_of_bounds + E.basis hbasisAbs hbasisDen + have hd := nat_bits_length_le_add_one d + rw [rationalEllipsoidStateBinaryCode] + simp only [pair_length, rationalEllipsoidMachineCodeBound] + omega + +theorem scheduledRoundedEllipsoid_stateCode_length_le + {d K p : β„•} (hd : 0 < d) (U : RationalEllipsoidState d) + (hM : rationalStateAbsBound (scheduledRoundedEllipsoid p U) ≀ + (2 : β„š) ^ K) : + (rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoid p U)).length ≀ + rationalEllipsoidMachineCodeBound d K (p + 10 + 4 * d) := by + apply rationalEllipsoidStateBinaryCode_length_le_of_bounds + Β· intro i + exact (abs_center_entry_lt_rationalStateAbsBound + (scheduledRoundedEllipsoid p U) i).le.trans hM + Β· intro i + have hden := inflatedDyadicRound_center_den_le (p := p) + (roundedEllipsoidInflation d) U i + have hp : p ≀ p + 10 + 4 * d := by omega + exact hden.trans (Nat.pow_le_pow_right (by decide) hp) + Β· intro i j + exact (abs_basis_entry_lt_rationalStateAbsBound + (scheduledRoundedEllipsoid p U) i j).le.trans hM + Β· intro i j + exact inflatedDyadicRound_basis_den_le hd U i j + +theorem scheduledRoundedEllipsoidCentralUpdate_stateCode_length_le + {d K p : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (a : Fin d β†’ β„š) + (hM : rationalStateAbsBound + (scheduledRoundedEllipsoidCentralUpdate p E a) ≀ (2 : β„š) ^ K) : + (rationalEllipsoidStateBinaryCode + (scheduledRoundedEllipsoidCentralUpdate p E a)).length ≀ + rationalEllipsoidMachineCodeBound d K (p + 10 + 4 * d) := by + exact scheduledRoundedEllipsoid_stateCode_length_le hd + (rationalEllipsoidCentralUpdate E a) hM + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineSmallDimension.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineSmallDimension.lean new file mode 100644 index 0000000000..a2073e9063 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineSmallDimension.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineOutputEncoding + +/-! +# Exact order-zero and order-one matrix branches + +The completed permanent algorithm handles dimensions zero and one exactly. +This file realizes those branches directly from the canonical matrix code. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Test whether the encoded matrix dimension is zero. -/ +def machineMatrixDimensionZeroBit (word : List Bool) : List Bool := + machineBinaryNatEqBit + (pair (machineMatrixDimensionWord word) []) + +/-- Test whether the encoded matrix dimension is one. -/ +def machineMatrixDimensionOneBit (word : List Bool) : List Bool := + machineBinaryNatEqBit + (pair (machineMatrixDimensionWord word) [true]) + +/-- Extract the first encoded row from the matrix row list. -/ +def machineMatrixFirstRowCode (word : List Bool) : List Bool := + machineListHead (machineMatrixRowsWord word) + +/-- Extract the first entry code from the first encoded matrix row. -/ +def machineMatrixFirstEntryCode (word : List Bool) : List Bool := + machineListHead (machineMatrixFirstRowCode word) + +/-- Convert the first matrix entry into the rational binary output encoding. -/ +def machineMatrixFirstEntryOutput (word : List Bool) : List Bool := + machineRationalBinaryCode (machineMatrixFirstEntryCode word) + +/-- Return permanent one for dimension zero and the first entry for dimension one; return an +empty word otherwise. -/ +def machineSmallDimensionPermanentCode (word : List Bool) : List Bool := + machineIfHead (machineMatrixDimensionZeroBit word) + (rationalBinaryCode 1) + (machineIfHead (machineMatrixDimensionOneBit word) + (machineMatrixFirstEntryOutput word) []) + +theorem machineMatrixDimensionZeroBit_mem_FP : + machineMatrixDimensionZeroBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixDimensionWord_mem_FP + (machineConst_mem_FP []) + simpa only [machineMatrixDimensionZeroBit] using! + machineCompose_mem_FP hpair machineBinaryNatEqBit_mem_FP + +theorem machineMatrixDimensionOneBit_mem_FP : + machineMatrixDimensionOneBit ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineMatrixDimensionWord_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineMatrixDimensionOneBit] using! + machineCompose_mem_FP hpair machineBinaryNatEqBit_mem_FP + +theorem machineMatrixFirstRowCode_mem_FP : + machineMatrixFirstRowCode ∈ Complexity.FP := by + simpa only [machineMatrixFirstRowCode, machineListHead] using! + machineCompose_mem_FP machineMatrixRowsWord_mem_FP machinePairFirst_mem_FP + +theorem machineMatrixFirstEntryCode_mem_FP : + machineMatrixFirstEntryCode ∈ Complexity.FP := by + simpa only [machineMatrixFirstEntryCode, machineListHead] using! + machineCompose_mem_FP machineMatrixFirstRowCode_mem_FP + machinePairFirst_mem_FP + +theorem machineMatrixFirstEntryOutput_mem_FP : + machineMatrixFirstEntryOutput ∈ Complexity.FP := by + simpa only [machineMatrixFirstEntryOutput] using! + machineCompose_mem_FP machineMatrixFirstEntryCode_mem_FP + machineRationalBinaryCode_mem_FP + +theorem machineSmallDimensionPermanentCode_mem_FP : + machineSmallDimensionPermanentCode ∈ Complexity.FP := by + have hone := machineIfHead_mem_FP machineMatrixDimensionOneBit_mem_FP + machineMatrixFirstEntryOutput_mem_FP (machineConst_mem_FP []) + exact machineIfHead_mem_FP machineMatrixDimensionZeroBit_mem_FP + (machineConst_mem_FP (rationalBinaryCode 1)) hone + +@[simp] theorem machineMatrixDimensionZeroBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixDimensionZeroBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [decide (n = 0)] := by + rw [machineMatrixDimensionZeroBit, machineMatrixDimensionWord_encode, + show ([] : List Bool) = (0 : β„•).bits by rfl, + machineBinaryNatEqBit_pair_natBits] + simp + +@[simp] theorem machineMatrixDimensionOneBit_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + machineMatrixDimensionOneBit + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + [decide (n = 1)] := by + rw [machineMatrixDimensionOneBit, machineMatrixDimensionWord_encode, + show ([true] : List Bool) = (1 : β„•).bits by rfl, + machineBinaryNatEqBit_pair_natBits] + +@[simp] theorem machineMatrixFirstRowCode_encode + (A : Matrix (Fin 1) (Fin 1) β„š) : + machineMatrixFirstRowCode + (rationalMatrixBinaryEncoding.encode ⟨1, A⟩) = + binaryListCode rationalEntryBinaryCode [A 0 0] := by + simp [machineMatrixFirstRowCode, rationalMatrixRows] + +@[simp] theorem machineMatrixFirstEntryCode_encode + (A : Matrix (Fin 1) (Fin 1) β„š) : + machineMatrixFirstEntryCode + (rationalMatrixBinaryEncoding.encode ⟨1, A⟩) = + rationalEntryBinaryCode (A 0 0) := by + simp [machineMatrixFirstEntryCode] + +@[simp] theorem machineMatrixFirstEntryOutput_encode + (A : Matrix (Fin 1) (Fin 1) β„š) : + machineMatrixFirstEntryOutput + (rationalMatrixBinaryEncoding.encode ⟨1, A⟩) = + rationalBinaryCode (A 0 0) := by + simp [machineMatrixFirstEntryOutput, machineRationalBinaryCode_encode] + +theorem machineSmallDimensionPermanentCode_zero + (A : Matrix (Fin 0) (Fin 0) β„š) : + machineSmallDimensionPermanentCode + (rationalMatrixBinaryEncoding.encode ⟨0, A⟩) = + rationalBinaryCode (Matrix.permanent A) := by + simp [machineSmallDimensionPermanentCode, Matrix.permanent] + +theorem machineSmallDimensionPermanentCode_one + (A : Matrix (Fin 1) (Fin 1) β„š) : + machineSmallDimensionPermanentCode + (rationalMatrixBinaryEncoding.encode ⟨1, A⟩) = + rationalBinaryCode (Matrix.permanent A) := by + simp [machineSmallDimensionPermanentCode, Matrix.permanent_fin_one] + +theorem machineSmallDimensionPermanentCode_encode {n : β„•} + (hn : n < 2) (A : Matrix (Fin n) (Fin n) β„š) : + machineSmallDimensionPermanentCode + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩) = + rationalBinaryCode (Matrix.permanent A) := by + interval_cases n + Β· exact machineSmallDimensionPermanentCode_zero A + Β· exact machineSmallDimensionPermanentCode_one A + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothedMatrix.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothedMatrix.lean new file mode 100644 index 0000000000..92eff8e419 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothedMatrix.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixAddDelta +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixNormalizeEntries +public import LeanPool.BeyondBethe.BeyondBethe.MachineSmoothingDelta + +/-! +# The complete normalization-and-smoothing matrix transform + +The input is `pair chiRawCode matrixCode`. We normalize the matrix, compute +the raw smoothing witness from that normalized matrix, and add the witness to +every normalized entry. Keeping the smoothing witness in raw-fraction format +is essential: the canonical public rational output uses a different encoding +and cannot be fed directly to the matrix-entry arithmetic machines. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the raw smoothing parameter `chi` from the smoothing-and-matrix input. -/ +def machineSmoothedMatrixChiRawCode (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the matrix input code paired with the raw smoothing parameter. -/ +def machineSmoothedMatrixInputCode (word : List Bool) : List Bool := + machinePairSecond word + +/-- Normalize the matrix entries before computing and applying the smoothing increment. -/ +def machineSmoothedMatrixNormalizedCode (word : List Bool) : List Bool := + machineMatrixNormalizeEntries (machineSmoothedMatrixInputCode word) + +/-- Compute the raw smoothing increment from `chi` and the normalized input matrix. -/ +def machineSmoothedMatrixDeltaRawCode (word : List Bool) : List Bool := + machineSmoothingDeltaRawCode + (pair (machineSmoothedMatrixChiRawCode word) + (machineSmoothedMatrixNormalizedCode word)) + +/-- Add the computed raw smoothing increment to every normalized matrix entry. -/ +def machineSmoothedMatrixCode (word : List Bool) : List Bool := + machineMatrixAddDeltaEntries + (pair (machineSmoothedMatrixDeltaRawCode word) + (machineSmoothedMatrixNormalizedCode word)) + +theorem machineSmoothedMatrixChiRawCode_mem_FP : + machineSmoothedMatrixChiRawCode ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineSmoothedMatrixInputCode_mem_FP : + machineSmoothedMatrixInputCode ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineSmoothedMatrixNormalizedCode_mem_FP : + machineSmoothedMatrixNormalizedCode ∈ Complexity.FP := by + simpa only [machineSmoothedMatrixNormalizedCode] using! + machineCompose_mem_FP machineSmoothedMatrixInputCode_mem_FP + machineMatrixNormalizeEntries_mem_FP + +theorem machineSmoothedMatrixDeltaRawCode_mem_FP : + machineSmoothedMatrixDeltaRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSmoothedMatrixChiRawCode_mem_FP + machineSmoothedMatrixNormalizedCode_mem_FP + simpa only [machineSmoothedMatrixDeltaRawCode] using! + machineCompose_mem_FP hpair machineSmoothingDeltaRawCode_mem_FP + +theorem machineSmoothedMatrixCode_mem_FP : + machineSmoothedMatrixCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSmoothedMatrixDeltaRawCode_mem_FP + machineSmoothedMatrixNormalizedCode_mem_FP + simpa only [machineSmoothedMatrixCode] using! + machineCompose_mem_FP hpair machineMatrixAddDeltaEntries_mem_FP + +@[simp] theorem machineSmoothedMatrixNormalizedCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothedMatrixNormalizedCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalMatrixBinaryEncoding.encode + ⟨n, normalizedRationalMatrix A⟩ := by + simp [machineSmoothedMatrixNormalizedCode, + machineSmoothedMatrixInputCode] + +@[simp] theorem machineSmoothedMatrixDeltaRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothedMatrixDeltaRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode + (rawRationalSmoothingDelta (normalizedRationalMatrix A) Ο‡) := by + simp [machineSmoothedMatrixDeltaRawCode, + machineSmoothedMatrixChiRawCode] + +@[simp] theorem machineSmoothedMatrixCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothedMatrixCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalMatrixBinaryEncoding.encode + ⟨n, smoothedRationalMatrix A Ο‡.value⟩ := by + rw [machineSmoothedMatrixCode, + machineSmoothedMatrixDeltaRawCode_encode, + machineSmoothedMatrixNormalizedCode_encode] + change machineMatrixAddDeltaEntries + (machineMatrixAddDeltaCanonicalInput + (rawRationalSmoothingDelta (normalizedRationalMatrix A) Ο‡) + (normalizedRationalMatrix A)) = _ + rw [machineMatrixAddDeltaEntries_encode] + congr 2 + funext i j + simp only [rationalMatrixAddDeltaSemantic, smoothedRationalMatrix] + rw [rawRationalSmoothingDelta_value] + +@[simp] theorem machineSmoothedMatrixCode_rational {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) : + machineSmoothedMatrixCode + (pair (rawRatBinaryCode (rawRatOfRat Ο‡)) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalMatrixBinaryEncoding.encode + ⟨n, smoothedRationalMatrix A Ο‡βŸ© := by + rw [machineSmoothedMatrixCode_encode, rawRatOfRat_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothingDelta.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothingDelta.lean new file mode 100644 index 0000000000..9a0977bdb2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineSmoothingDelta.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineFactorial +public import LeanPool.BeyondBethe.BeyondBethe.MachineLengthBits +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixDimension +public import LeanPool.BeyondBethe.BeyondBethe.MachineMatrixSupportProduct +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalMin +public import LeanPool.BeyondBethe.BeyondBethe.MachineRationalPower + +/-! +# The rational smoothing level as a finite-word function + +The input is a pair consisting of an unreduced rational word for `chi` and a +canonical rational-matrix word. We assemble + +`min (1 / (2 * n)) (chi * supportFloor ^ n / (4 * n!))` + +from the verified finite-word primitives. The matrix dimension is first +converted to a guarded unary ruler; this same ruler drives both exponentiation +and factorial. All intermediate rational words remain unreduced until the +final minimum has selected a branch, at which point the selected fraction is +canonically normalized. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the raw `chi` code used in the smoothing-increment calculation. -/ +def machineSmoothingChiRawCode (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the matrix code used in the smoothing-increment calculation. -/ +def machineSmoothingMatrixCode (word : List Bool) : List Bool := + machinePairSecond word + +/-- Obtain the matrix dimension as a unary ruler for powers and factorials. -/ +def machineSmoothingDimensionRuler (word : List Bool) : List Bool := + machineMatrixDimensionUnary (machineSmoothingMatrixCode word) + +/-- Encode the unary dimension length as a nonnegative raw rational with denominator one. -/ +def machineSmoothingDimensionRawCode (word : List Bool) : List Bool := + pair (false :: machineLengthBits (machineSmoothingDimensionRuler word)) + (1 : β„•).bits + +/-- Compute the raw product of the nonzero matrix entries for the smoothing bound. -/ +def machineSmoothingSupportRawCode (word : List Bool) : List Bool := + machineMatrixSupportRawCode (machineSmoothingMatrixCode word) + +/-- Raise the raw support product to the dimension given by the unary ruler. -/ +def machineSmoothingSupportPowerRawCode (word : List Bool) : List Bool := + machineRawRatPowerCode + (pair (machineSmoothingDimensionRuler word) + (machineSmoothingSupportRawCode word)) + +/-- Encode the factorial of the matrix dimension as a raw rational. -/ +def machineSmoothingFactorialRawCode (word : List Bool) : List Bool := + machineFactorialRawRatCode (machineSmoothingDimensionRuler word) + +/-- Encode twice the matrix dimension as the first smoothing denominator. -/ +def machineSmoothingFirstDenominatorRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode (RawRat.ofNat 2)) + (machineSmoothingDimensionRawCode word)) + +/-- Encode the first smoothing candidate `1 / (2*n)` by total raw-rational division. -/ +def machineSmoothingFirstRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (rawRatBinaryCode RawRat.one) + (machineSmoothingFirstDenominatorRawCode word)) + +/-- Multiply the raw parameter `chi` by the dimension-th power of the support product. -/ +def machineSmoothingWeightedSupportRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (machineSmoothingChiRawCode word) + (machineSmoothingSupportPowerRawCode word)) + +/-- Encode four times the dimension factorial as the second smoothing denominator. -/ +def machineSmoothingSecondDenominatorRawCode (word : List Bool) : List Bool := + machineRawRatMulCode + (pair (rawRatBinaryCode (RawRat.ofNat 4)) + (machineSmoothingFactorialRawCode word)) + +/-- Divide the weighted support power by four times the dimension factorial. -/ +def machineSmoothingSecondRawCode (word : List Bool) : List Bool := + machineRawRatDivCode + (pair (machineSmoothingWeightedSupportRawCode word) + (machineSmoothingSecondDenominatorRawCode word)) + +/-- Select the smaller of the two raw-rational smoothing candidates. -/ +def machineSmoothingDeltaRawCode (word : List Bool) : List Bool := + machineRawRatMinCode + (pair (machineSmoothingFirstRawCode word) + (machineSmoothingSecondRawCode word)) + +/-- Normalize the selected raw smoothing increment into the rational binary output encoding. -/ +def machineSmoothingDeltaCode (word : List Bool) : List Bool := + machineNormalizeRawRatBinaryCode (machineSmoothingDeltaRawCode word) + +theorem machineSmoothingChiRawCode_mem_FP : + machineSmoothingChiRawCode ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineSmoothingMatrixCode_mem_FP : + machineSmoothingMatrixCode ∈ Complexity.FP := machinePairSecond_mem_FP + +theorem machineSmoothingDimensionRuler_mem_FP : + machineSmoothingDimensionRuler ∈ Complexity.FP := by + simpa only [machineSmoothingDimensionRuler] using! + machineCompose_mem_FP machineSmoothingMatrixCode_mem_FP + machineMatrixDimensionUnary_mem_FP + +theorem machineSmoothingDimensionRawCode_mem_FP : + machineSmoothingDimensionRawCode ∈ Complexity.FP := by + have hbits := machineCompose_mem_FP + machineSmoothingDimensionRuler_mem_FP machineLengthBits_mem_FP + have hnum := machineCompose_mem_FP hbits (machinePrepend_mem_FP false) + exact machinePair_mem_FP hnum (machineConst_mem_FP (1 : β„•).bits) + +theorem machineSmoothingSupportRawCode_mem_FP : + machineSmoothingSupportRawCode ∈ Complexity.FP := by + simpa only [machineSmoothingSupportRawCode] using! + machineCompose_mem_FP machineSmoothingMatrixCode_mem_FP + machineMatrixSupportRawCode_mem_FP + +theorem machineSmoothingSupportPowerRawCode_mem_FP : + machineSmoothingSupportPowerRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSmoothingDimensionRuler_mem_FP + machineSmoothingSupportRawCode_mem_FP + simpa only [machineSmoothingSupportPowerRawCode] using! + machineCompose_mem_FP hpair machineRawRatPowerCode_mem_FP + +theorem machineSmoothingFactorialRawCode_mem_FP : + machineSmoothingFactorialRawCode ∈ Complexity.FP := by + simpa only [machineSmoothingFactorialRawCode] using! + machineCompose_mem_FP machineSmoothingDimensionRuler_mem_FP + machineFactorialRawRatCode_mem_FP + +theorem machineSmoothingFirstDenominatorRawCode_mem_FP : + machineSmoothingFirstDenominatorRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (RawRat.ofNat 2))) + machineSmoothingDimensionRawCode_mem_FP + simpa only [machineSmoothingFirstDenominatorRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineSmoothingFirstRawCode_mem_FP : + machineSmoothingFirstRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode RawRat.one)) + machineSmoothingFirstDenominatorRawCode_mem_FP + simpa only [machineSmoothingFirstRawCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineSmoothingWeightedSupportRawCode_mem_FP : + machineSmoothingWeightedSupportRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSmoothingChiRawCode_mem_FP + machineSmoothingSupportPowerRawCode_mem_FP + simpa only [machineSmoothingWeightedSupportRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineSmoothingSecondDenominatorRawCode_mem_FP : + machineSmoothingSecondDenominatorRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + (machineConst_mem_FP (rawRatBinaryCode (RawRat.ofNat 4))) + machineSmoothingFactorialRawCode_mem_FP + simpa only [machineSmoothingSecondDenominatorRawCode] using! + machineCompose_mem_FP hpair machineRawRatMulCode_mem_FP + +theorem machineSmoothingSecondRawCode_mem_FP : + machineSmoothingSecondRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP + machineSmoothingWeightedSupportRawCode_mem_FP + machineSmoothingSecondDenominatorRawCode_mem_FP + simpa only [machineSmoothingSecondRawCode] using! + machineCompose_mem_FP hpair machineRawRatDivCode_mem_FP + +theorem machineSmoothingDeltaRawCode_mem_FP : + machineSmoothingDeltaRawCode ∈ Complexity.FP := by + have hpair := machinePair_mem_FP machineSmoothingFirstRawCode_mem_FP + machineSmoothingSecondRawCode_mem_FP + simpa only [machineSmoothingDeltaRawCode] using! + machineCompose_mem_FP hpair machineRawRatMinCode_mem_FP + +theorem machineSmoothingDeltaCode_mem_FP : + machineSmoothingDeltaCode ∈ Complexity.FP := by + simpa only [machineSmoothingDeltaCode] using! + machineCompose_mem_FP machineSmoothingDeltaRawCode_mem_FP + machineNormalizeRawRatBinaryCode_mem_FP + +/-! ## Exact semantics on canonical inputs -/ + +@[simp] theorem machineSmoothingDimensionRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingDimensionRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode (RawRat.ofNat n) := by + simp [machineSmoothingDimensionRawCode, machineSmoothingDimensionRuler, + machineSmoothingMatrixCode, rawRatBinaryCode, RawRat.ofNat, + integerBinaryCode] + +@[simp] theorem machineSmoothingSupportRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingSupportRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode + (rawRatRowsSupportProduct RawRat.one (rationalMatrixRows A)) := by + simp [machineSmoothingSupportRawCode, machineSmoothingMatrixCode] + +@[simp] theorem machineSmoothingSupportPowerRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingSupportPowerRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode + ((rawRatRowsSupportProduct RawRat.one + (rationalMatrixRows A)).pow n) := by + rw [machineSmoothingSupportPowerRawCode, + machineSmoothingDimensionRuler, machineSmoothingMatrixCode, + machinePairSecond_pair, machineMatrixDimensionUnary_encode, + machineSmoothingSupportRawCode_encode, + machineRawRatPowerCode_encode] + +@[simp] theorem machineSmoothingFactorialRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingFactorialRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode (RawRat.ofNat n.factorial) := by + simp [machineSmoothingFactorialRawCode, machineSmoothingDimensionRuler, + machineSmoothingMatrixCode] + +/-- The raw first smoothing candidate `1 / (2*n)`, using total division at zero. -/ +def rawRationalSmoothingFirst (n : β„•) : RawRat := + RawRat.one.div ((RawRat.ofNat 2).mul (RawRat.ofNat n)) + +/-- The raw second smoothing candidate: `chi` times the support product to power `n`, divided by +`4*n!`. -/ +def rawRationalSmoothingSecond {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : RawRat := + (Ο‡.mul ((rawRatRowsSupportProduct RawRat.one + (rationalMatrixRows A)).pow n)).div + ((RawRat.ofNat 4).mul (RawRat.ofNat n.factorial)) + +/-- Choose the raw smoothing candidate with smaller rational value, taking the first on +equality. -/ +def rawRationalSmoothingDelta {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : RawRat := + if (rawRationalSmoothingFirst n).value ≀ + (rawRationalSmoothingSecond A Ο‡).value then + rawRationalSmoothingFirst n + else + rawRationalSmoothingSecond A Ο‡ + +@[simp] theorem machineSmoothingDeltaRawCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingDeltaRawCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rawRatBinaryCode (rawRationalSmoothingDelta A Ο‡) := by + simp only [machineSmoothingDeltaRawCode, + machineSmoothingFirstRawCode, + machineSmoothingFirstDenominatorRawCode, + machineSmoothingSecondRawCode, + machineSmoothingWeightedSupportRawCode, + machineSmoothingSecondDenominatorRawCode, + machineSmoothingChiRawCode, machinePairFirst_pair, + machineSmoothingDimensionRawCode_encode, + machineSmoothingSupportPowerRawCode_encode, + machineSmoothingFactorialRawCode_encode, + machineRawRatMulCode_encode, machineRawRatDivCode_encode, + machineRawRatMinCode_encode, rawRationalSmoothingDelta, + rawRationalSmoothingFirst, rawRationalSmoothingSecond] + rfl + +theorem rawRationalSmoothingDelta_value {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + (rawRationalSmoothingDelta A Ο‡).value = + rationalSmoothingDelta A Ο‡.value := by + simp only [rawRationalSmoothingDelta, rawRationalSmoothingFirst, + rawRationalSmoothingSecond, RawRat.value_div, RawRat.value_mul, + RawRat.value_pow, RawRat.value_ofNat, RawRat.value_one, + rawRatRowsSupportProduct_eq_rationalSupportFloor, + rationalSmoothingDelta] + norm_num only [Nat.cast_ofNat] + by_cases h : + 1 / ((2 : β„š) * n) ≀ + Ο‡.value * rationalSupportFloor A ^ n / + ((4 : β„š) * n.factorial) + Β· rw [ite_eq_left h, min_eq_left h] + simp + Β· have hright : + Ο‡.value * rationalSupportFloor A ^ n / + ((4 : β„š) * n.factorial) ≀ + 1 / ((2 : β„š) * n) := le_of_not_ge h + rw [ite_eq_right h, min_eq_right hright] + simp [rawRatRowsSupportProduct_eq_rationalSupportFloor] + +theorem machineSmoothingDeltaCode_encode {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : RawRat) : + machineSmoothingDeltaCode + (pair (rawRatBinaryCode Ο‡) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalBinaryCode (rationalSmoothingDelta A Ο‡.value) := by + simp only [machineSmoothingDeltaCode, machineSmoothingDeltaRawCode, + machineSmoothingFirstRawCode, + machineSmoothingFirstDenominatorRawCode, + machineSmoothingSecondRawCode, + machineSmoothingWeightedSupportRawCode, + machineSmoothingSecondDenominatorRawCode, + machineSmoothingChiRawCode, machinePairFirst_pair, + machineSmoothingDimensionRawCode_encode, + machineSmoothingSupportPowerRawCode_encode, + machineSmoothingFactorialRawCode_encode, + machineRawRatMulCode_encode, machineRawRatDivCode_encode, + machineRawRatMinCode_encode, + machineNormalizeRawRatBinaryCode_encode, + binaryNormalizeRawRat_eq_value, rationalSmoothingDelta, + RawRat.value_div, RawRat.value_mul, RawRat.value_pow, + RawRat.value_ofNat, RawRat.value_one, + rawRatRowsSupportProduct_eq_rationalSupportFloor] + norm_num only [Nat.cast_ofNat] + by_cases h : + 1 / ((2 : β„š) * n) ≀ + Ο‡.value * rationalSupportFloor A ^ n / + ((4 : β„š) * n.factorial) + Β· rw [ite_eq_left h, min_eq_left h] + simp + Β· have hright : + Ο‡.value * rationalSupportFloor A ^ n / + ((4 : β„š) * n.factorial) ≀ + 1 / ((2 : β„š) * n) := le_of_not_ge h + rw [ite_eq_right h, min_eq_right hright] + simp [rawRatRowsSupportProduct_eq_rationalSupportFloor] + +@[simp] theorem machineSmoothingDeltaCode_rational {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) (Ο‡ : β„š) : + machineSmoothingDeltaCode + (pair (rawRatBinaryCode (rawRatOfRat Ο‡)) + (rationalMatrixBinaryEncoding.encode ⟨n, A⟩)) = + rationalBinaryCode (rationalSmoothingDelta A Ο‡) := by + rw [machineSmoothingDeltaCode_encode, rawRatOfRat_value] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineTrimHighZeros.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineTrimHighZeros.lean new file mode 100644 index 0000000000..607b68c4a9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineTrimHighZeros.lean @@ -0,0 +1,268 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBitAssembly +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs + +/-! +# Polynomial-time canonicalization of little-endian natural words + +A bit-graph machine may emit a polynomially bounded fixed-width word. The +public rational encoding uses canonical `Nat.bits`, so redundant high zeroes +must be removed. The implementation below is a length-bounded Cobham fold, +not a semantic list primitive assumed to be efficient. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the accumulator from the recursive fold state used to trim high zero bits. -/ +def machineTrimAcc (state : List Bool) : List Bool := + machinePairSecond (machinePairFirst state) + +/-- Discard a false bit when the trimming accumulator is empty; otherwise prepend it. -/ +def machineTrimFalseStep (state : List Bool) : List Bool := + machineIfEmpty (machineTrimAcc state) [] + (false :: machineTrimAcc state) + +/-- Prepend a true bit to the trimming accumulator. -/ +def machineTrimTrueStep (state : List Bool) : List Bool := + true :: machineTrimAcc state + +/-- Run the high-zero trimming fold with output clamped to the packed input length. -/ +def machineTrimPacked (packed : List Bool) : List Bool := + Cobham.recFoldClamp machineTrimFalseStep machineTrimTrueStep + packed.length [] + (machinePairFirst packed) (machinePairSecond packed) + +/-- Trim high zero bits by running the packed trimming fold with an empty auxiliary word. -/ +def machineTrimHighZeros (word : List Bool) : List Bool := + machineTrimPacked (pair [] word) + +theorem machineTrimAcc_mem_FP : machineTrimAcc ∈ Complexity.FP := by + simpa only [machineTrimAcc] using! + machineCompose_mem_FP machinePairFirst_mem_FP machinePairSecond_mem_FP + +theorem machineTrimFalseStep_mem_FP : + machineTrimFalseStep ∈ Complexity.FP := by + have hcons : (fun state => false :: machineTrimAcc state) ∈ + Complexity.FP := + machineCompose_mem_FP machineTrimAcc_mem_FP + (machinePrepend_mem_FP false) + exact machineIfEmpty_mem_FP machineTrimAcc_mem_FP + (machineConst_mem_FP []) hcons + +theorem machineTrimTrueStep_mem_FP : + machineTrimTrueStep ∈ Complexity.FP := by + simpa only [machineTrimTrueStep] using! + machineCompose_mem_FP machineTrimAcc_mem_FP + (machinePrepend_mem_FP true) + +theorem machineTrimPacked_mem_FP : machineTrimPacked ∈ Complexity.FP := by + simpa only [machineTrimPacked, Polynomial.eval_X] using! + Cobham.recFoldClamp_mem_FP machineTrimFalseStep_mem_FP + machineTrimTrueStep_mem_FP (machineConst_mem_FP []) Polynomial.X + +theorem machineTrimHighZeros_mem_FP : + machineTrimHighZeros ∈ Complexity.FP := by + have hpack : (fun word : List Bool => pair [] word) ∈ Complexity.FP := + machinePair_mem_FP (machineConst_mem_FP []) id_mem_FP + simpa only [machineTrimHighZeros] using! + machineCompose_mem_FP hpack machineTrimPacked_mem_FP + +theorem binaryTrimHighZeros_length_le : βˆ€ bits : List Bool, + (BinaryRippleSub.trimHighZeros bits).length ≀ bits.length := by + intro bits + induction bits with + | nil => rfl + | cons bit rest ih => + simp only [BinaryRippleSub.trimHighZeros] + cases htrim : BinaryRippleSub.trimHighZeros rest with + | nil => cases bit <;> simp + | cons high tail => + simp only [htrim, List.length_cons] at ih ⊒ + omega + +theorem machineTrim_recFold_eq : βˆ€ bits : List Bool, + Cobham.recFold machineTrimFalseStep machineTrimTrueStep [] [] bits = + BinaryRippleSub.trimHighZeros bits := by + intro bits + induction bits with + | nil => rfl + | cons bit rest ih => + simp only [Cobham.recFold] + cases bit with + | false => + simp only [Bool.false_eq, Bool.cond_false, machineTrimFalseStep, + machineTrimAcc, machinePairFirst_pair, machinePairSecond_pair, ih] + cases htrim : BinaryRippleSub.trimHighZeros rest with + | nil => simp [BinaryRippleSub.trimHighZeros, htrim] + | cons high tail => + simp [BinaryRippleSub.trimHighZeros, htrim] + | true => + simp only [Bool.cond_true, ih] + cases htrim : BinaryRippleSub.trimHighZeros rest <;> + simp [machineTrimTrueStep, machineTrimAcc, + BinaryRippleSub.trimHighZeros, htrim] + +/-- The concrete bounded fold removes precisely the redundant high zeroes. -/ +theorem machineTrimHighZeros_eq (word : List Bool) : + machineTrimHighZeros word = BinaryRippleSub.trimHighZeros word := by + rw [machineTrimHighZeros, machineTrimPacked] + have hbound : βˆ€ t : List Bool, t.length ≀ word.length β†’ + (Cobham.recFold machineTrimFalseStep machineTrimTrueStep [] [] t).length ≀ + (pair [] word).length := by + intro t ht + rw [machineTrim_recFold_eq] + have htrim := binaryTrimHighZeros_length_le t + simp only [pair_length, List.length_nil] + omega + simp only [machinePairFirst_pair, machinePairSecond_pair] + rw [Cobham.recFoldClamp_eq_recFold word hbound, + machineTrim_recFold_eq] + +/-- Assemble queried bits along the given ruler and trim high zeros to obtain a canonical binary +word. -/ +def machineAssembleCanonicalBits + (query ruler : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineTrimHighZeros (machineAssembleBits query ruler word) + +theorem machineAssembleCanonicalBits_mem_FP + {query ruler : List Bool β†’ List Bool} + (hquery : query ∈ Complexity.FP) (hruler : ruler ∈ Complexity.FP) : + machineAssembleCanonicalBits query ruler ∈ Complexity.FP := by + simpa only [machineAssembleCanonicalBits] using! + machineCompose_mem_FP (machineAssembleBits_mem_FP hquery hruler) + machineTrimHighZeros_mem_FP + +theorem replicate_false_succ_append (k : β„•) : + List.replicate (k + 1) false = List.replicate k false ++ [false] := by + induction k with + | zero => simp + | succ k ih => + calc + List.replicate (k + 1 + 1) false = + false :: List.replicate (k + 1) false := by + rw [List.replicate_succ] + _ = false :: (List.replicate k false ++ [false]) := by rw [ih] + _ = List.replicate (k + 1) false ++ [false] := by + rw [List.replicate_succ, List.cons_append] + +theorem binaryTrimHighZeros_append_false (bits : List Bool) : + BinaryRippleSub.trimHighZeros (bits ++ [false]) = + BinaryRippleSub.trimHighZeros bits := by + induction bits with + | nil => rfl + | cons bit rest ih => + rw [List.cons_append, BinaryRippleSub.trimHighZeros, ih] + cases htrim : BinaryRippleSub.trimHighZeros rest <;> + simp [BinaryRippleSub.trimHighZeros, htrim] + +theorem binaryTrimHighZeros_append_replicate_false + (bits : List Bool) : βˆ€ k : β„•, + BinaryRippleSub.trimHighZeros (bits ++ List.replicate k false) = + BinaryRippleSub.trimHighZeros bits := by + intro k + induction k with + | zero => simp + | succ k ih => + rw [replicate_false_succ_append, ← List.append_assoc, + binaryTrimHighZeros_append_false, ih] + +theorem assembledOutputBitLanguage_padded + (target : List Bool β†’ List Bool) (word : List Bool) : βˆ€ extra : β„•, + assembledQueryBits + (MachineRAMBridge.languageFlag (outputBitLanguage target)) word + ((target word).length + extra) = + target word ++ List.replicate extra false := by + intro extra + induction extra with + | zero => + simpa using! assembledQueryBits_eq_take + (MachineRAMBridge.languageFlag (outputBitLanguage target)) target + (outputBitLanguage_flag_pair target) word + (target word).length le_rfl + | succ extra ih => + rw [Nat.add_succ, assembledQueryBits, ih, + outputBitLanguage_flag_pair_all] + have hnone : + (target word)[(target word).length + extra]? = none := + List.getElem?_eq_none (by omega) + rw [hnone] + simp only [Option.getD_none, machineHeadBit_cons] + rw [replicate_false_succ_append, List.append_assoc] + +/-- With a polynomial upper bound on output width, bit-graph assembly followed +by verified high-zero trimming recovers any already-canonical target word. -/ +theorem machineAssembleCanonicalBits_realizes + (target ruler : List Bool β†’ List Bool) + (hruler : βˆ€ word, (target word).length ≀ (ruler word).length) + (hcanonical : βˆ€ word, + BinaryRippleSub.trimHighZeros (target word) = target word) : + machineAssembleCanonicalBits + (MachineRAMBridge.languageFlag (outputBitLanguage target)) ruler = + target := by + funext word + rw [machineAssembleCanonicalBits, machineAssembleBits_eq] + have hsum : (target word).length + + ((ruler word).length - (target word).length) = + (ruler word).length := Nat.add_sub_of_le (hruler word) + rw [← hsum, assembledOutputBitLanguage_padded, + machineTrimHighZeros_eq, + binaryTrimHighZeros_append_replicate_false, + hcanonical] + +/-- Upper-bound version of the RAM bit-graph reduction. This is the form +used for canonical natural and rational outputs. -/ +theorem canonicalTarget_mem_FP_of_ramBitProgram + (target ruler : List Bool β†’ List Bool) + (program : RAM.Program) (p : Polynomial β„•) + (hdecides : program.DecidesInTime (outputBitLanguage target) p.eval) + (hrulerFP : ruler ∈ Complexity.FP) + (hrulerLength : βˆ€ word, + (target word).length ≀ (ruler word).length) + (hcanonical : βˆ€ word, + BinaryRippleSub.trimHighZeros (target word) = target word) : + target ∈ Complexity.FP := by + let query := MachineRAMBridge.languageFlag (outputBitLanguage target) + have hqueryFP : query ∈ Complexity.FP := + MachineRAMBridge.languageFlag_mem_FP_of_ramProgram program p hdecides + have hassembly : machineAssembleCanonicalBits query ruler ∈ Complexity.FP := + machineAssembleCanonicalBits_mem_FP hqueryFP hrulerFP + have heq : machineAssembleCanonicalBits query ruler = target := + machineAssembleCanonicalBits_realizes target ruler hrulerLength hcanonical + rwa [heq] at hassembly + +/-- Scratch-register-prefix version of the upper-bound RAM bit-graph +reduction. -/ +theorem canonicalTarget_mem_FP_of_paddedRamBitProgram + (scratchRegisters : β„•) (target ruler : List Bool β†’ List Bool) + (program : RAM.Program) (p : Polynomial β„•) + (hdecides : program.DecidesInTime + (MachineRAMBridge.paddedLanguage scratchRegisters + (outputBitLanguage target)) p.eval) + (hrulerFP : ruler ∈ Complexity.FP) + (hrulerLength : βˆ€ word, + (target word).length ≀ (ruler word).length) + (hcanonical : βˆ€ word, + BinaryRippleSub.trimHighZeros (target word) = target word) : + target ∈ Complexity.FP := by + let query := MachineRAMBridge.languageFlag (outputBitLanguage target) + have hqueryFP : query ∈ Complexity.FP := + MachineRAMBridge.languageFlag_mem_FP_of_paddedRamProgram + scratchRegisters program p hdecides + have hassembly : machineAssembleCanonicalBits query ruler ∈ Complexity.FP := + machineAssembleCanonicalBits_mem_FP hqueryFP hrulerFP + have heq : machineAssembleCanonicalBits query ruler = target := + machineAssembleCanonicalBits_realizes target ruler hrulerLength hcanonical + rwa [heq] at hassembly + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryGridGenerator.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryGridGenerator.lean new file mode 100644 index 0000000000..0f9cc65e0b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryGridGenerator.lean @@ -0,0 +1,1342 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineDirectedNegativeObjectiveSum +public import LeanPool.BeyondBethe.BeyondBethe.MachineListReverse + +/-! +# A reusable finite-word generator for square rational grids + +Given a unary dimension `m`, an explicit accumulator bound, and an immutable +payload, this machine visits the pairs `(0,0),...,(m-1,m-1)` in row-major +order. A supplied entry machine receives `pair row (pair column payload)`. +Its output is prepended to an encoded-list accumulator. The explicit `take` +is part of the total machine; clients prove separately that their chosen bound +never truncates a canonical run. + +The generator is intentionally independent of the Bethe formulas. It will be +used both for the nonlinear affine-gradient vector and for complete floor-cut +vectors, avoiding two unrelated implementations of the same grid traversal. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extract the unary dimension ruler from a square-grid generator input. -/ +def machineUnaryGridGeneratorDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extract the paired output bound and payload from a grid-generator input. -/ +def machineUnaryGridGeneratorRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extract the output-width bound word supplied to the square-grid generator. -/ +def machineUnaryGridGeneratorInputBound (word : List Bool) : List Bool := + machinePairFirst (machineUnaryGridGeneratorRest word) + +/-- Extract the payload passed to each generated grid entry. -/ +def machineUnaryGridGeneratorInputPayload (word : List Bool) : List Bool := + machinePairSecond (machineUnaryGridGeneratorRest word) + +/-- Pack row, column, reversed accumulator, output bound, completion flag, and original input +into a scan state. -/ +def machineUnaryGridGeneratorPack + (row column accumulator bound done payload : List Bool) : List Bool := + pair row (pair column + (pair accumulator (pair bound (pair done payload)))) + +/-- Extract the current unary row ruler from a grid-generator state. -/ +def machineUnaryGridGeneratorRow (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extract the current unary column ruler from a grid-generator state. -/ +def machineUnaryGridGeneratorColumn (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extract the reversed encoded-entry accumulator from a grid-generator state. -/ +def machineUnaryGridGeneratorAccumulator + (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extract the output-width bound word from a grid-generator state. -/ +def machineUnaryGridGeneratorBound (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extract the completion flag word from a grid-generator state. -/ +def machineUnaryGridGeneratorDone (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Extract the original grid-generator input stored in the state. -/ +def machineUnaryGridGeneratorPayload (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +@[simp] theorem machineUnaryGridGeneratorRow_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorRow + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = row := by + simp [machineUnaryGridGeneratorRow, machineUnaryGridGeneratorPack] + +@[simp] theorem machineUnaryGridGeneratorColumn_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorColumn + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = column := by + simp [machineUnaryGridGeneratorColumn, machineUnaryGridGeneratorPack] + +@[simp] theorem machineUnaryGridGeneratorAccumulator_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorAccumulator + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = + accumulator := by + simp [machineUnaryGridGeneratorAccumulator, machineUnaryGridGeneratorPack] + +@[simp] theorem machineUnaryGridGeneratorBound_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorBound + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = bound := by + simp [machineUnaryGridGeneratorBound, machineUnaryGridGeneratorPack] + +@[simp] theorem machineUnaryGridGeneratorDone_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorDone + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = done := by + simp [machineUnaryGridGeneratorDone, machineUnaryGridGeneratorPack] + +@[simp] theorem machineUnaryGridGeneratorPayload_pack + (row column accumulator bound done payload : List Bool) : + machineUnaryGridGeneratorPayload + (machineUnaryGridGeneratorPack row column accumulator bound done payload) = payload := by + simp [machineUnaryGridGeneratorPayload, machineUnaryGridGeneratorPack] + +/-- Read the unary grid dimension from the original input stored in a scan state. -/ +def machineUnaryGridGeneratorStateDimension + (state : List Bool) : List Bool := + machineUnaryGridGeneratorDimension + (machineUnaryGridGeneratorPayload state) + +/-- Pair the current row and column rulers with the entry payload to form one entry-machine +input. -/ +def machineUnaryGridGeneratorEntryInput + (state : List Bool) : List Bool := + pair (machineUnaryGridGeneratorRow state) + (pair (machineUnaryGridGeneratorColumn state) + (machineUnaryGridGeneratorInputPayload + (machineUnaryGridGeneratorPayload state))) + +/-- Append one true bit to the row ruler, truncating to the stored input length. -/ +def machineUnaryGridGeneratorNextRow (state : List Bool) : List Bool := + (machineUnaryGridGeneratorRow state ++ [true]).take + (machineUnaryGridGeneratorPayload state).length + +/-- Append one true bit to the column ruler, truncating to the stored input length. -/ +def machineUnaryGridGeneratorNextColumn (state : List Bool) : List Bool := + (machineUnaryGridGeneratorColumn state ++ [true]).take + (machineUnaryGridGeneratorPayload state).length + +/-- Test whether the next column ruler reaches the grid dimension. -/ +def machineUnaryGridGeneratorColumnCompletesBit + (state : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineUnaryGridGeneratorNextColumn state) + (machineUnaryGridGeneratorStateDimension state)) + +/-- Test whether the next row ruler reaches the grid dimension. -/ +def machineUnaryGridGeneratorRowCompletesBit + (state : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineUnaryGridGeneratorNextRow state) + (machineUnaryGridGeneratorStateDimension state)) + +/-- Prepend the generated current entry to the encoded reversed accumulator. -/ +def machineUnaryGridGeneratorCandidate + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + pair (entry (machineUnaryGridGeneratorEntryInput state)) + (machineUnaryGridGeneratorAccumulator state) + +/-- Truncate the candidate accumulator to the supplied output-width bound. -/ +def machineUnaryGridGeneratorNextAccumulator + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + (machineUnaryGridGeneratorCandidate entry state).take + (machineUnaryGridGeneratorBound state).length + +/-- Store the current entry and set the grid completion flag while retaining the current +indices. -/ +def machineUnaryGridGeneratorFinish + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryGridGeneratorPack + (machineUnaryGridGeneratorRow state) + (machineUnaryGridGeneratorColumn state) + (machineUnaryGridGeneratorNextAccumulator entry state) + (machineUnaryGridGeneratorBound state) [true] + (machineUnaryGridGeneratorPayload state) + +/-- Store the current entry, advance the row ruler, and reset the column ruler. -/ +def machineUnaryGridGeneratorAdvanceRow + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryGridGeneratorPack + (machineUnaryGridGeneratorNextRow state) [] + (machineUnaryGridGeneratorNextAccumulator entry state) + (machineUnaryGridGeneratorBound state) + (machineUnaryGridGeneratorDone state) + (machineUnaryGridGeneratorPayload state) + +/-- Store the current entry and advance the column ruler within the current row. -/ +def machineUnaryGridGeneratorAdvanceColumn + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryGridGeneratorPack + (machineUnaryGridGeneratorRow state) + (machineUnaryGridGeneratorNextColumn state) + (machineUnaryGridGeneratorNextAccumulator entry state) + (machineUnaryGridGeneratorBound state) + (machineUnaryGridGeneratorDone state) + (machineUnaryGridGeneratorPayload state) + +/-- Process a grid entry, finishing at the last cell or advancing the row or column as +appropriate. -/ +def machineUnaryGridGeneratorProcess + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineIfHead (machineUnaryGridGeneratorColumnCompletesBit state) + (machineIfHead (machineUnaryGridGeneratorRowCompletesBit state) + (machineUnaryGridGeneratorFinish entry state) + (machineUnaryGridGeneratorAdvanceRow entry state)) + (machineUnaryGridGeneratorAdvanceColumn entry state) + +/-- Keep completed grid states fixed and otherwise process the current grid entry. -/ +def machineUnaryGridGeneratorStep + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineUnaryGridGeneratorDone state)) state + (machineUnaryGridGeneratorProcess entry state) + +/-- Initialize the grid scan with empty index rulers and accumulator, the supplied bound, and a +false completion flag. -/ +def machineUnaryGridGeneratorInit (word : List Bool) : List Bool := + machineUnaryGridGeneratorPack [] [] [] + (machineUnaryGridGeneratorInputBound word) [false] word + +/-- Encode the unary grid dimension length as a binary natural. -/ +def machineUnaryGridGeneratorDimensionBits + (word : List Bool) : List Bool := + machineLengthBits (machineUnaryGridGeneratorDimension word) + +/-- Square the encoded dimension to obtain the nominal number of grid-entry steps. -/ +def machineUnaryGridGeneratorWorkBits (word : List Bool) : List Bool := + machineBinaryMulBits + (pair (machineUnaryGridGeneratorDimensionBits word) + (machineUnaryGridGeneratorDimensionBits word)) + +/-- Construct the quadratic input-width guard for converting the grid work count to unary. -/ +def machineUnaryGridGeneratorGuard (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Convert the squared dimension to a unary iteration ruler bounded by the quadratic guard. -/ +def machineUnaryGridGeneratorRuler (word : List Bool) : List Bool := + machineBoundedUnary + (pair (machineUnaryGridGeneratorGuard word) + (machineUnaryGridGeneratorWorkBits word)) + +/-- Construct a state-width envelope by two iterated binary-width expansions of the padded +input. -/ +def machineUnaryGridGeneratorEnvelope (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 (word ++ List.replicate 16 false) + +/-- Pack six copies of the width envelope to bound the complete grid-generator state. -/ +def machineUnaryGridGeneratorWidth (word : List Bool) : List Bool := + let envelope := machineUnaryGridGeneratorEnvelope word + machineUnaryGridGeneratorPack envelope envelope envelope envelope + envelope envelope + +/-- Iterate the grid step for the guarded work-ruler length from the initial state. -/ +def machineUnaryGridGeneratorFinalState + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + (machineUnaryGridGeneratorStep entry)^[(machineUnaryGridGeneratorRuler word).length] + (machineUnaryGridGeneratorInit word) + +/-- Extract the reversed encoded-entry list after the guarded grid scan. -/ +def machineUnaryGridGeneratorReversedCode + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineUnaryGridGeneratorAccumulator + (machineUnaryGridGeneratorFinalState entry word) + +/-- Reverse the accumulated encoded entries to return them in grid traversal order. -/ +def machineUnaryGridGeneratorCode + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineListReverse (machineUnaryGridGeneratorReversedCode entry word) + +/-! ## Polynomial-time closure -/ + +theorem machineUnaryGridGeneratorDimension_mem_FP : + machineUnaryGridGeneratorDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorRest_mem_FP : + machineUnaryGridGeneratorRest ∈ FP := machinePairSecond_mem_FP + +theorem machineUnaryGridGeneratorInputBound_mem_FP : + machineUnaryGridGeneratorInputBound ∈ FP := by + simpa only [machineUnaryGridGeneratorInputBound] using! + machineCompose_mem_FP machineUnaryGridGeneratorRest_mem_FP + machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorInputPayload_mem_FP : + machineUnaryGridGeneratorInputPayload ∈ FP := by + simpa only [machineUnaryGridGeneratorInputPayload] using! + machineCompose_mem_FP machineUnaryGridGeneratorRest_mem_FP + machinePairSecond_mem_FP + +theorem machineUnaryGridGeneratorRow_mem_FP : + machineUnaryGridGeneratorRow ∈ FP := machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorColumn_mem_FP : + machineUnaryGridGeneratorColumn ∈ FP := by + simpa only [machineUnaryGridGeneratorColumn] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorAccumulator_mem_FP : + machineUnaryGridGeneratorAccumulator ∈ FP := by + have htail := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + simpa only [machineUnaryGridGeneratorAccumulator] using! + machineCompose_mem_FP htail machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorBound_mem_FP : + machineUnaryGridGeneratorBound ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + simpa only [machineUnaryGridGeneratorBound] using! + machineCompose_mem_FP htailThree machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorDone_mem_FP : + machineUnaryGridGeneratorDone ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + have htailFour := machineCompose_mem_FP htailThree machinePairSecond_mem_FP + simpa only [machineUnaryGridGeneratorDone] using! + machineCompose_mem_FP htailFour machinePairFirst_mem_FP + +theorem machineUnaryGridGeneratorPayload_mem_FP : + machineUnaryGridGeneratorPayload ∈ FP := by + have htailTwo := machineCompose_mem_FP machinePairSecond_mem_FP + machinePairSecond_mem_FP + have htailThree := machineCompose_mem_FP htailTwo machinePairSecond_mem_FP + have htailFour := machineCompose_mem_FP htailThree machinePairSecond_mem_FP + simpa only [machineUnaryGridGeneratorPayload] using! + machineCompose_mem_FP htailFour machinePairSecond_mem_FP + +theorem machineUnaryGridGeneratorStateDimension_mem_FP : + machineUnaryGridGeneratorStateDimension ∈ FP := by + simpa only [machineUnaryGridGeneratorStateDimension] using! + machineCompose_mem_FP machineUnaryGridGeneratorPayload_mem_FP + machineUnaryGridGeneratorDimension_mem_FP + +theorem machineUnaryGridGeneratorEntryInput_mem_FP : + machineUnaryGridGeneratorEntryInput ∈ FP := by + have hpayload := machineCompose_mem_FP + machineUnaryGridGeneratorPayload_mem_FP + machineUnaryGridGeneratorInputPayload_mem_FP + exact machinePair_mem_FP machineUnaryGridGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryGridGeneratorColumn_mem_FP hpayload) + +theorem machineUnaryGridGeneratorNextRow_mem_FP : + machineUnaryGridGeneratorNextRow ∈ FP := by + have happend := machineAppend_mem_FP machineUnaryGridGeneratorRow_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineUnaryGridGeneratorNextRow] using! + machineTake_mem_FP machineUnaryGridGeneratorPayload_mem_FP happend + +theorem machineUnaryGridGeneratorNextColumn_mem_FP : + machineUnaryGridGeneratorNextColumn ∈ FP := by + have happend := machineAppend_mem_FP machineUnaryGridGeneratorColumn_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineUnaryGridGeneratorNextColumn] using! + machineTake_mem_FP machineUnaryGridGeneratorPayload_mem_FP happend + +theorem machineUnaryGridGeneratorColumnCompletesBit_mem_FP : + machineUnaryGridGeneratorColumnCompletesBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineUnaryGridGeneratorNextColumn_mem_FP + machineUnaryGridGeneratorStateDimension_mem_FP + simpa only [machineUnaryGridGeneratorColumnCompletesBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineUnaryGridGeneratorRowCompletesBit_mem_FP : + machineUnaryGridGeneratorRowCompletesBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineUnaryGridGeneratorNextRow_mem_FP + machineUnaryGridGeneratorStateDimension_mem_FP + simpa only [machineUnaryGridGeneratorRowCompletesBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineUnaryGridGeneratorCandidate_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorCandidate entry ∈ FP := by + have hcurrent := machineCompose_mem_FP + machineUnaryGridGeneratorEntryInput_mem_FP hentry + exact machinePair_mem_FP hcurrent + machineUnaryGridGeneratorAccumulator_mem_FP + +theorem machineUnaryGridGeneratorNextAccumulator_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorNextAccumulator entry ∈ FP := by + simpa only [machineUnaryGridGeneratorNextAccumulator] using! + machineTake_mem_FP machineUnaryGridGeneratorBound_mem_FP + (machineUnaryGridGeneratorCandidate_mem_FP hentry) + +theorem machineUnaryGridGeneratorFinish_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorFinish entry ∈ FP := + machinePair_mem_FP machineUnaryGridGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryGridGeneratorColumn_mem_FP + (machinePair_mem_FP + (machineUnaryGridGeneratorNextAccumulator_mem_FP hentry) + (machinePair_mem_FP machineUnaryGridGeneratorBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineUnaryGridGeneratorPayload_mem_FP)))) + +theorem machineUnaryGridGeneratorAdvanceRow_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorAdvanceRow entry ∈ FP := + machinePair_mem_FP machineUnaryGridGeneratorNextRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP + (machineUnaryGridGeneratorNextAccumulator_mem_FP hentry) + (machinePair_mem_FP machineUnaryGridGeneratorBound_mem_FP + (machinePair_mem_FP machineUnaryGridGeneratorDone_mem_FP + machineUnaryGridGeneratorPayload_mem_FP)))) + +theorem machineUnaryGridGeneratorAdvanceColumn_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorAdvanceColumn entry ∈ FP := + machinePair_mem_FP machineUnaryGridGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryGridGeneratorNextColumn_mem_FP + (machinePair_mem_FP + (machineUnaryGridGeneratorNextAccumulator_mem_FP hentry) + (machinePair_mem_FP machineUnaryGridGeneratorBound_mem_FP + (machinePair_mem_FP machineUnaryGridGeneratorDone_mem_FP + machineUnaryGridGeneratorPayload_mem_FP)))) + +theorem machineUnaryGridGeneratorProcess_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorProcess entry ∈ FP := by + have hlast := machineIfHead_mem_FP + machineUnaryGridGeneratorRowCompletesBit_mem_FP + (machineUnaryGridGeneratorFinish_mem_FP hentry) + (machineUnaryGridGeneratorAdvanceRow_mem_FP hentry) + exact machineIfHead_mem_FP + machineUnaryGridGeneratorColumnCompletesBit_mem_FP hlast + (machineUnaryGridGeneratorAdvanceColumn_mem_FP hentry) + +theorem machineUnaryGridGeneratorStep_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorStep entry ∈ FP := by + have hdone := machineCompose_mem_FP machineUnaryGridGeneratorDone_mem_FP + machineHeadBit_mem_FP + exact machineIfHead_mem_FP hdone id_mem_FP + (machineUnaryGridGeneratorProcess_mem_FP hentry) + +theorem machineUnaryGridGeneratorInit_mem_FP : + machineUnaryGridGeneratorInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineUnaryGridGeneratorInputBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP)))) + +theorem machineUnaryGridGeneratorDimensionBits_mem_FP : + machineUnaryGridGeneratorDimensionBits ∈ FP := by + simpa only [machineUnaryGridGeneratorDimensionBits] using! + machineCompose_mem_FP machineUnaryGridGeneratorDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineUnaryGridGeneratorWorkBits_mem_FP : + machineUnaryGridGeneratorWorkBits ∈ FP := by + have hinput := machinePair_mem_FP + machineUnaryGridGeneratorDimensionBits_mem_FP + machineUnaryGridGeneratorDimensionBits_mem_FP + simpa only [machineUnaryGridGeneratorWorkBits] using! + machineCompose_mem_FP hinput machineBinaryMulBits_mem_FP + +theorem machineUnaryGridGeneratorGuard_mem_FP : + machineUnaryGridGeneratorGuard ∈ FP := machineBinaryMulWidth_mem_FP + +theorem machineUnaryGridGeneratorRuler_mem_FP : + machineUnaryGridGeneratorRuler ∈ FP := by + have hinput := machinePair_mem_FP machineUnaryGridGeneratorGuard_mem_FP + machineUnaryGridGeneratorWorkBits_mem_FP + simpa only [machineUnaryGridGeneratorRuler] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineUnaryGridGeneratorEnvelope_mem_FP : + machineUnaryGridGeneratorEnvelope ∈ FP := by + have hpadded := machineAppend_mem_FP id_mem_FP + (machineConst_mem_FP (List.replicate 16 false)) + simpa only [machineUnaryGridGeneratorEnvelope] using! + machineCompose_mem_FP hpadded (machineIteratedBinaryWidth_mem_FP 2) + +theorem machineUnaryGridGeneratorWidth_mem_FP : + machineUnaryGridGeneratorWidth ∈ FP := by + let h := machineUnaryGridGeneratorEnvelope_mem_FP + exact machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h (machinePair_mem_FP h h)))) + +/-- Require correct state packing, bounded indices and accumulator, the supplied output bound, a +one-bit flag, and unchanged input. -/ +def MachineUnaryGridGeneratorStateBound + (word state : List Bool) : Prop := + state = machineUnaryGridGeneratorPack + (machineUnaryGridGeneratorRow state) + (machineUnaryGridGeneratorColumn state) + (machineUnaryGridGeneratorAccumulator state) + (machineUnaryGridGeneratorBound state) + (machineUnaryGridGeneratorDone state) + (machineUnaryGridGeneratorPayload state) ∧ + (machineUnaryGridGeneratorRow state).length ≀ word.length ∧ + (machineUnaryGridGeneratorColumn state).length ≀ word.length ∧ + (machineUnaryGridGeneratorAccumulator state).length ≀ + (machineUnaryGridGeneratorInputBound word).length ∧ + machineUnaryGridGeneratorBound state = + machineUnaryGridGeneratorInputBound word ∧ + (machineUnaryGridGeneratorDone state).length ≀ 1 ∧ + machineUnaryGridGeneratorPayload state = word + +theorem machineUnaryGridGeneratorInit_bound (word : List Bool) : + MachineUnaryGridGeneratorStateBound word + (machineUnaryGridGeneratorInit word) := by + simp [MachineUnaryGridGeneratorStateBound, + machineUnaryGridGeneratorInit] + +theorem machineUnaryGridGeneratorStep_bound + {entry : List Bool β†’ List Bool} {word state : List Bool} + (hs : MachineUnaryGridGeneratorStateBound word state) : + MachineUnaryGridGeneratorStateBound word + (machineUnaryGridGeneratorStep entry state) := by + rcases hs with ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + have hnextAcc : + (machineUnaryGridGeneratorNextAccumulator entry state).length ≀ + (machineUnaryGridGeneratorInputBound word).length := by + rw [machineUnaryGridGeneratorNextAccumulator, hbound] + exact List.length_take_le _ _ + have hnextRow : (machineUnaryGridGeneratorNextRow state).length ≀ + word.length := by + rw [machineUnaryGridGeneratorNextRow, hpayload] + exact List.length_take_le _ _ + have hnextColumn : (machineUnaryGridGeneratorNextColumn state).length ≀ + word.length := by + rw [machineUnaryGridGeneratorNextColumn, hpayload] + exact List.length_take_le _ _ + have hfinish : MachineUnaryGridGeneratorStateBound word + (machineUnaryGridGeneratorFinish entry state) := by + simp only [MachineUnaryGridGeneratorStateBound, + machineUnaryGridGeneratorFinish, + machineUnaryGridGeneratorRow_pack, + machineUnaryGridGeneratorColumn_pack, + machineUnaryGridGeneratorAccumulator_pack, + machineUnaryGridGeneratorBound_pack, + machineUnaryGridGeneratorDone_pack, + machineUnaryGridGeneratorPayload_pack] + exact ⟨trivial, hrow, hcolumn, hnextAcc, hbound, by simp, hpayload⟩ + have hadvanceRow : MachineUnaryGridGeneratorStateBound word + (machineUnaryGridGeneratorAdvanceRow entry state) := by + simp only [MachineUnaryGridGeneratorStateBound, + machineUnaryGridGeneratorAdvanceRow, + machineUnaryGridGeneratorRow_pack, + machineUnaryGridGeneratorColumn_pack, + machineUnaryGridGeneratorAccumulator_pack, + machineUnaryGridGeneratorBound_pack, + machineUnaryGridGeneratorDone_pack, + machineUnaryGridGeneratorPayload_pack] + exact ⟨trivial, hnextRow, by simp, hnextAcc, hbound, hdone, hpayload⟩ + have hadvanceColumn : MachineUnaryGridGeneratorStateBound word + (machineUnaryGridGeneratorAdvanceColumn entry state) := by + simp only [MachineUnaryGridGeneratorStateBound, + machineUnaryGridGeneratorAdvanceColumn, + machineUnaryGridGeneratorRow_pack, + machineUnaryGridGeneratorColumn_pack, + machineUnaryGridGeneratorAccumulator_pack, + machineUnaryGridGeneratorBound_pack, + machineUnaryGridGeneratorDone_pack, + machineUnaryGridGeneratorPayload_pack] + exact ⟨trivial, hrow, hnextColumn, hnextAcc, hbound, hdone, hpayload⟩ + rw [machineUnaryGridGeneratorStep] + cases hdoneCode : machineUnaryGridGeneratorDone state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false, + machineUnaryGridGeneratorProcess] + cases hcolumnCode : machineUnaryGridGeneratorColumnCompletesBit state with + | nil => + have hlen : + (machineUnaryGridGeneratorColumnCompletesBit state).length = 1 := by + simp [machineUnaryGridGeneratorColumnCompletesBit] + rw [hcolumnCode] at hlen + simp at hlen + | cons columnBit columnTail => + cases columnBit with + | false => + rw [machineIfHead_false] + exact hadvanceColumn + | true => + rw [machineIfHead_true] + cases hrowCode : machineUnaryGridGeneratorRowCompletesBit state with + | nil => + have hlen : + (machineUnaryGridGeneratorRowCompletesBit state).length = 1 := by + simp [machineUnaryGridGeneratorRowCompletesBit] + rw [hrowCode] at hlen + simp at hlen + | cons rowBit rowTail => + cases rowBit with + | false => + rw [machineIfHead_false] + exact hadvanceRow + | true => + rw [machineIfHead_true] + exact hfinish + | cons doneBit doneTail => + cases doneBit with + | false => + rw [machineHeadBit_cons, machineIfHead_false, + machineUnaryGridGeneratorProcess] + cases hcolumnCode : machineUnaryGridGeneratorColumnCompletesBit state with + | nil => + have hlen : + (machineUnaryGridGeneratorColumnCompletesBit state).length = 1 := by + simp [machineUnaryGridGeneratorColumnCompletesBit] + rw [hcolumnCode] at hlen + simp at hlen + | cons columnBit columnTail => + cases columnBit with + | false => + rw [machineIfHead_false] + exact hadvanceColumn + | true => + rw [machineIfHead_true] + cases hrowCode : machineUnaryGridGeneratorRowCompletesBit state with + | nil => + have hlen : + (machineUnaryGridGeneratorRowCompletesBit state).length = 1 := by + simp [machineUnaryGridGeneratorRowCompletesBit] + rw [hrowCode] at hlen + simp at hlen + | cons rowBit rowTail => + cases rowBit with + | false => + rw [machineIfHead_false] + exact hadvanceRow + | true => + rw [machineIfHead_true] + exact hfinish + | true => + rw [machineHeadBit_cons, machineIfHead_true] + exact ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + +theorem machineUnaryGridGeneratorIterate_bound + (entry : List Bool β†’ List Bool) (word : List Bool) : βˆ€ k, + MachineUnaryGridGeneratorStateBound word + ((machineUnaryGridGeneratorStep entry)^[k] + (machineUnaryGridGeneratorInit word)) := by + intro k + induction k with + | zero => exact machineUnaryGridGeneratorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineUnaryGridGeneratorStep_bound ih + +theorem machineUnaryGridGeneratorEnvelope_word_le (word : List Bool) : + word.length ≀ (machineUnaryGridGeneratorEnvelope word).length := by + rw [machineUnaryGridGeneratorEnvelope, + machineIteratedBinaryWidth_length] + have hpadded : word.length ≀ (word ++ List.replicate 16 false).length := by + simp + exact hpadded.trans (certificateExpGuardWidth_self_le 2 _) + +theorem machineUnaryGridGeneratorEnvelope_pos (word : List Bool) : + 1 ≀ (machineUnaryGridGeneratorEnvelope word).length := by + have hword := machineUnaryGridGeneratorEnvelope_word_le word + by_cases hnil : word = [] + Β· subst word + norm_num [machineUnaryGridGeneratorEnvelope, + machineIteratedBinaryWidth_length, certificateExpGuardWidth] + Β· have hpos : 0 < word.length := List.length_pos_of_ne_nil hnil + have : 1 ≀ word.length := by omega + omega + +theorem machineUnaryGridGeneratorInputBound_le_envelope (word : List Bool) : + (machineUnaryGridGeneratorInputBound word).length ≀ + (machineUnaryGridGeneratorEnvelope word).length := + (machinePairFirst_length_le (machineUnaryGridGeneratorRest word)).trans + ((machinePairSecond_length_le word).trans + (machineUnaryGridGeneratorEnvelope_word_le word)) + +theorem machineUnaryGridGeneratorIterate_length_le_width + (entry : List Bool β†’ List Bool) (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineUnaryGridGeneratorRuler word).length) : + ((machineUnaryGridGeneratorStep entry)^[iterations] + (machineUnaryGridGeneratorInit word)).length ≀ + (machineUnaryGridGeneratorWidth word).length := by + rcases machineUnaryGridGeneratorIterate_bound entry word iterations with + ⟨hdecomp, hrow, hcolumn, hacc, hbound, hdone, hpayload⟩ + have hwe := machineUnaryGridGeneratorEnvelope_word_le word + have hbe := machineUnaryGridGeneratorInputBound_le_envelope word + have hepos := machineUnaryGridGeneratorEnvelope_pos word + rw [hdecomp, hbound, hpayload] + simp only [machineUnaryGridGeneratorPack, + machineUnaryGridGeneratorWidth, pair_length] + omega + +theorem machineUnaryGridGeneratorFinalState_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorFinalState entry ∈ FP := by + exact Cobham.iterate_mem_FP + (machineUnaryGridGeneratorStep_mem_FP hentry) + machineUnaryGridGeneratorInit_mem_FP + machineUnaryGridGeneratorRuler_mem_FP + machineUnaryGridGeneratorWidth_mem_FP + (machineUnaryGridGeneratorIterate_length_le_width entry) + +theorem machineUnaryGridGeneratorReversedCode_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorReversedCode entry ∈ FP := by + simpa only [machineUnaryGridGeneratorReversedCode] using! + machineCompose_mem_FP + (machineUnaryGridGeneratorFinalState_mem_FP hentry) + machineUnaryGridGeneratorAccumulator_mem_FP + +theorem machineUnaryGridGeneratorCode_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryGridGeneratorCode entry ∈ FP := by + simpa only [machineUnaryGridGeneratorCode] using! + machineCompose_mem_FP + (machineUnaryGridGeneratorReversedCode_mem_FP hentry) + machineListReverse_mem_FP + +/-! ## Canonical inputs and exact iteration ruler -/ + +/-- Encode a canonical grid input with dimension `m` in unary, an output bound, and an entry +payload. -/ +def machineUnaryGridGeneratorCanonicalWord + (m : β„•) (bound payload : List Bool) : List Bool := + pair (List.replicate m true) (pair bound payload) + +@[simp] theorem machineUnaryGridGeneratorDimension_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryGridGeneratorDimension + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + List.replicate m true := by + simp [machineUnaryGridGeneratorDimension, + machineUnaryGridGeneratorCanonicalWord] + +@[simp] theorem machineUnaryGridGeneratorInputBound_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryGridGeneratorInputBound + (machineUnaryGridGeneratorCanonicalWord m bound payload) = bound := by + simp [machineUnaryGridGeneratorInputBound, + machineUnaryGridGeneratorRest, + machineUnaryGridGeneratorCanonicalWord] + +@[simp] theorem machineUnaryGridGeneratorInputPayload_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryGridGeneratorInputPayload + (machineUnaryGridGeneratorCanonicalWord m bound payload) = payload := by + simp [machineUnaryGridGeneratorInputPayload, + machineUnaryGridGeneratorRest, + machineUnaryGridGeneratorCanonicalWord] + +@[simp] theorem machineUnaryGridGeneratorWorkBits_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryGridGeneratorWorkBits + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + (m * m).bits := by + rw [machineUnaryGridGeneratorWorkBits, + machineUnaryGridGeneratorDimensionBits, + machineUnaryGridGeneratorDimension_encode, + machineLengthBits_encode, List.length_replicate, + machineBinaryMulBits_pair_natBits] + +theorem machineUnaryGridGeneratorWork_le_guard + (m : β„•) (bound payload : List Bool) : + m * m ≀ + (machineUnaryGridGeneratorGuard + (machineUnaryGridGeneratorCanonicalWord m bound payload)).length := by + have hm : m ≀ + (machineUnaryGridGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryGridGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + simp only [machineUnaryGridGeneratorGuard, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +@[simp] theorem machineUnaryGridGeneratorRuler_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryGridGeneratorRuler + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + List.replicate (m * m) true := by + rw [machineUnaryGridGeneratorRuler, + machineUnaryGridGeneratorWorkBits_encode, + machineBoundedUnary_encode_of_le] + exact machineUnaryGridGeneratorWork_le_guard m bound payload + +/-! ## Typed row-major semantics -/ + +structure UnaryGridSemanticState (m : β„•) where + /-- Current row index of the semantic square-grid scan. -/ + row : Fin m + /-- Current column index of the semantic square-grid scan. -/ + column : Fin m + /-- Rational entries accumulated by the semantic grid scan, in reverse traversal order. -/ + accumulator : List β„š + /-- Whether the semantic grid scan has included its final entry. -/ + done : Bool + +/-- Initializes a nonempty square-grid scan at row and column zero with empty accumulator and +unset completion flag. -/ +def unaryGridSemanticInit {m : β„•} (hm : 0 < m) : + UnaryGridSemanticState m where + row := ⟨0, hm⟩ + column := ⟨0, hm⟩ + accumulator := [] + done := false + +/-- Prepends the current grid value, advances in row-major order, and marks the final position +complete; completed states are fixed. -/ +def unaryGridSemanticStep {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) : + UnaryGridSemanticState m := + if state.done then state + else + let nextAccumulator := f state.row state.column :: state.accumulator + if hcolumn : state.column.1 + 1 = m then + if hrow : state.row.1 + 1 = m then + { state with accumulator := nextAccumulator, done := true } + else + { state with + row := ⟨state.row.1 + 1, by omega⟩ + column := ⟨0, by omega⟩ + accumulator := nextAccumulator } + else + { state with + column := ⟨state.column.1 + 1, by omega⟩ + accumulator := nextAccumulator } + +/-- Encodes semantic grid indices, reverse-order accumulator, completion flag, bound, and +canonical fixed payload. -/ +def machineUnaryGridGeneratorSemanticCode {m : β„•} + (bound payload : List Bool) (state : UnaryGridSemanticState m) : + List Bool := + machineUnaryGridGeneratorPack + (List.replicate state.row.1 true) + (List.replicate state.column.1 true) + (binaryListCode rationalEntryBinaryCode state.accumulator) + bound [state.done] + (machineUnaryGridGeneratorCanonicalWord m bound payload) + +@[simp] theorem machineUnaryGridGeneratorEntryInput_semanticCode {m : β„•} + (bound payload : List Bool) (state : UnaryGridSemanticState m) : + machineUnaryGridGeneratorEntryInput + (machineUnaryGridGeneratorSemanticCode bound payload state) = + pair (List.replicate state.row.1 true) + (pair (List.replicate state.column.1 true) payload) := by + simp [machineUnaryGridGeneratorEntryInput, + machineUnaryGridGeneratorSemanticCode] + +@[simp] theorem machineUnaryGridGeneratorNextRow_semanticCode {m : β„•} + (bound payload : List Bool) (state : UnaryGridSemanticState m) : + machineUnaryGridGeneratorNextRow + (machineUnaryGridGeneratorSemanticCode bound payload state) = + List.replicate (state.row.1 + 1) true := by + have hlength : state.row.1 + 1 ≀ + (machineUnaryGridGeneratorCanonicalWord m bound payload).length := by + have hrow : state.row.1 + 1 ≀ m := by omega + have hm : m ≀ + (machineUnaryGridGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryGridGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + omega + rw [machineUnaryGridGeneratorNextRow] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorRow_pack, + machineUnaryGridGeneratorPayload_pack] + have happend : List.replicate state.row.1 true ++ [true] = + List.replicate (state.row.1 + 1) true := by + rw [show ([true] : List Bool) = List.replicate 1 true by rfl, + List.replicate_append_replicate] + rw [happend, List.take_of_length_le (by simpa using! hlength)] + +@[simp] theorem machineUnaryGridGeneratorNextColumn_semanticCode {m : β„•} + (bound payload : List Bool) (state : UnaryGridSemanticState m) : + machineUnaryGridGeneratorNextColumn + (machineUnaryGridGeneratorSemanticCode bound payload state) = + List.replicate (state.column.1 + 1) true := by + have hlength : state.column.1 + 1 ≀ + (machineUnaryGridGeneratorCanonicalWord m bound payload).length := by + have hcolumn : state.column.1 + 1 ≀ m := by omega + have hm : m ≀ + (machineUnaryGridGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryGridGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + omega + rw [machineUnaryGridGeneratorNextColumn] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorColumn_pack, + machineUnaryGridGeneratorPayload_pack] + have happend : List.replicate state.column.1 true ++ [true] = + List.replicate (state.column.1 + 1) true := by + rw [show ([true] : List Bool) = List.replicate 1 true by rfl, + List.replicate_append_replicate] + rw [happend, List.take_of_length_le (by simpa using! hlength)] + +@[simp] theorem machineUnaryGridGeneratorColumnCompletesBit_semanticCode + {m : β„•} (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryGridGeneratorColumnCompletesBit + (machineUnaryGridGeneratorSemanticCode bound payload state) = + [decide (state.column.1 + 1 = m)] := by + rw [machineUnaryGridGeneratorColumnCompletesBit, + machineUnaryGridGeneratorNextColumn_semanticCode, + machineUnaryGridGeneratorStateDimension] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorPayload_pack, + machineUnaryGridGeneratorDimension_encode, + machineUnaryRulersEqualBit_replicate, machineHeadBit_cons] + +@[simp] theorem machineUnaryGridGeneratorRowCompletesBit_semanticCode + {m : β„•} (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryGridGeneratorRowCompletesBit + (machineUnaryGridGeneratorSemanticCode bound payload state) = + [decide (state.row.1 + 1 = m)] := by + rw [machineUnaryGridGeneratorRowCompletesBit, + machineUnaryGridGeneratorNextRow_semanticCode, + machineUnaryGridGeneratorStateDimension] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorPayload_pack, + machineUnaryGridGeneratorDimension_encode, + machineUnaryRulersEqualBit_replicate, machineHeadBit_cons] + +theorem machineUnaryGridGeneratorStep_semanticCode {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) (state : UnaryGridSemanticState m) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hlarge : + (binaryListCode rationalEntryBinaryCode + (f state.row state.column :: state.accumulator)).length ≀ + bound.length) : + machineUnaryGridGeneratorStep entry + (machineUnaryGridGeneratorSemanticCode bound payload state) = + machineUnaryGridGeneratorSemanticCode bound payload + (unaryGridSemanticStep f state) := by + rcases state with ⟨row, column, accumulator, done⟩ + cases done + Β· have hcandidate : + machineUnaryGridGeneratorNextAccumulator entry + (machineUnaryGridGeneratorSemanticCode bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode rationalEntryBinaryCode + (f row column :: accumulator) := by + rw [machineUnaryGridGeneratorNextAccumulator, + machineUnaryGridGeneratorCandidate, + machineUnaryGridGeneratorEntryInput_semanticCode, + hentry] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorAccumulator_pack, + machineUnaryGridGeneratorBound_pack, binaryListCode] + exact List.take_of_length_le hlarge + by_cases hcolumn : column.1 + 1 = m + Β· by_cases hrow : row.1 + 1 = m + Β· have hdoneFalse : + machineHeadBit (machineUnaryGridGeneratorDone + (machineUnaryGridGeneratorSemanticCode bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryGridGeneratorSemanticCode] + rw [machineUnaryGridGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryGridGeneratorProcess, + machineUnaryGridGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_true, machineIfHead_true] + rw [machineUnaryGridGeneratorRowCompletesBit_semanticCode] + simp only [hrow, decide_true, machineIfHead_true] + rw [machineUnaryGridGeneratorFinish, hcandidate] + simp [unaryGridSemanticStep, hcolumn, hrow, + machineUnaryGridGeneratorSemanticCode] + Β· have hdoneFalse : + machineHeadBit (machineUnaryGridGeneratorDone + (machineUnaryGridGeneratorSemanticCode bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryGridGeneratorSemanticCode] + rw [machineUnaryGridGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryGridGeneratorProcess, + machineUnaryGridGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_true, machineIfHead_true] + rw [machineUnaryGridGeneratorRowCompletesBit_semanticCode] + simp only [hrow, decide_false, machineIfHead_false] + rw [machineUnaryGridGeneratorAdvanceRow, + machineUnaryGridGeneratorNextRow_semanticCode, hcandidate] + simp [unaryGridSemanticStep, hcolumn, hrow, + machineUnaryGridGeneratorSemanticCode] + Β· have hdoneFalse : + machineHeadBit (machineUnaryGridGeneratorDone + (machineUnaryGridGeneratorSemanticCode bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryGridGeneratorSemanticCode] + rw [machineUnaryGridGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryGridGeneratorProcess, + machineUnaryGridGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_false, machineIfHead_false] + rw [machineUnaryGridGeneratorAdvanceColumn, + machineUnaryGridGeneratorNextColumn_semanticCode, hcandidate] + simp [unaryGridSemanticStep, hcolumn, + machineUnaryGridGeneratorSemanticCode] + Β· simp [machineUnaryGridGeneratorStep, unaryGridSemanticStep, + machineUnaryGridGeneratorSemanticCode] + +/-- The row-major grid ordinal `row * m + column`. -/ +def unaryGridOrdinal {m : β„•} (row column : Fin m) : β„• := + row.1 * m + column.1 + +theorem unaryGridOrdinal_lt_square {m : β„•} + (row column : Fin m) : unaryGridOrdinal row column < m * m := by + rw [unaryGridOrdinal] + nlinarith [row.isLt, column.isLt] + +theorem unaryGridOrdinal_injective (m : β„•) : + Function.Injective + (fun ij : Fin m Γ— Fin m => unaryGridOrdinal ij.1 ij.2) := by + intro a b hab + have hmod := congrArg (fun q : β„• => q % m) hab + have hmpos : 0 < m := Nat.zero_lt_of_lt a.1.isLt + have hmodA : unaryGridOrdinal a.1 a.2 % m = a.2.1 := by + simp [unaryGridOrdinal, Nat.add_mod, Nat.mod_eq_of_lt a.2.isLt, + hmpos] + have hmodB : unaryGridOrdinal b.1 b.2 % m = b.2.1 := by + simp [unaryGridOrdinal, Nat.add_mod, Nat.mod_eq_of_lt b.2.isLt, + hmpos] + have hcolumn : a.2.1 = b.2.1 := by + calc + a.2.1 = unaryGridOrdinal a.1 a.2 % m := hmodA.symm + _ = unaryGridOrdinal b.1 b.2 % m := hmod + _ = b.2.1 := hmodB + have hrowMul : a.1.1 * m = b.1.1 * m := by + simp only [unaryGridOrdinal] at hab + rw [hcolumn] at hab + exact Nat.add_right_cancel hab + have hrow : a.1.1 = b.1.1 := + Nat.mul_right_cancel hmpos hrowMul + exact Prod.ext (Fin.ext hrow) (Fin.ext hcolumn) + +theorem unaryGridOrdinal_nextColumn {m : β„•} + (row column : Fin m) (hcolumn : column.1 + 1 β‰  m) : + unaryGridOrdinal row + ⟨column.1 + 1, show column.1 + 1 < m by omega⟩ = + unaryGridOrdinal row column + 1 := by + rw [unaryGridOrdinal, unaryGridOrdinal] + change row.1 * m + (column.1 + 1) = + row.1 * m + column.1 + 1 + ring + +theorem unaryGridOrdinal_nextRow {m : β„•} + (row column : Fin m) (hcolumn : column.1 + 1 = m) + (hrow : row.1 + 1 β‰  m) : + unaryGridOrdinal + ⟨row.1 + 1, show row.1 + 1 < m by omega⟩ + ⟨0, show 0 < m by omega⟩ = + unaryGridOrdinal row column + 1 := by + rw [unaryGridOrdinal, unaryGridOrdinal] + change (row.1 + 1) * m + 0 = row.1 * m + column.1 + 1 + calc + (row.1 + 1) * m + 0 = row.1 * m + m := by ring + _ = row.1 * m + column.1 + 1 := by omega + +theorem unaryGridOrdinal_last {m : β„•} + (row column : Fin m) (hcolumn : column.1 + 1 = m) + (hrow : row.1 + 1 = m) : + unaryGridOrdinal row column + 1 = m * m := by + simp [unaryGridOrdinal] + nlinarith + +/-- Lists all square-grid values in the order supplied by the finite product equivalence. -/ +def unaryGridValues {m : β„•} (f : Fin m β†’ Fin m β†’ β„š) : List β„š := + List.ofFn (fun k : Fin (m * m) => + f (finProdFinEquiv.symm k).1 (finProdFinEquiv.symm k).2) + +/-- Takes the first `k` values from the complete grid-value list. -/ +def unaryGridPrefix {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (k : β„•) : List β„š := + (unaryGridValues f).take k + +@[simp] theorem unaryGridValues_length {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) : (unaryGridValues f).length = m * m := by + simp [unaryGridValues] + +theorem unaryGridPrefix_succ_of_ordinal {m k : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (row column : Fin m) + (hordinal : unaryGridOrdinal row column = k) : + unaryGridPrefix f (k + 1) = + unaryGridPrefix f k ++ [f row column] := by + have hk : k < (unaryGridValues f).length := by + rw [unaryGridValues_length] + rw [← hordinal] + exact unaryGridOrdinal_lt_square row column + have hget : (unaryGridValues f)[k] = f row column := by + have hk' : k < m * m := by simpa using! hk + let ij : Fin m Γ— Fin m := (row, column) + have hfin : (⟨k, hk'⟩ : Fin (m * m)) = finProdFinEquiv ij := by + apply Fin.ext + change k = column.1 + m * row.1 + calc + k = row.1 * m + column.1 := hordinal.symm + _ = column.1 + m * row.1 := by ring + simp only [unaryGridValues, List.getElem_ofFn] + rw [hfin, Equiv.symm_apply_apply] + rw [unaryGridPrefix, unaryGridPrefix] + simpa only [List.concat_eq_append, hget] using! + (List.take_concat_get hk).symm + +/-- Relates a completed grid accumulator to all values in reverse order, or an unfinished +position at ordinal `k` to the reversed prefix. -/ +def UnaryGridValueInvariant {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (k : β„•) + (state : UnaryGridSemanticState m) : Prop := + (state.done = true ∧ m * m ≀ k ∧ + state.accumulator = (unaryGridValues f).reverse) ∨ + (state.done = false ∧ unaryGridOrdinal state.row state.column = k ∧ + state.accumulator = (unaryGridPrefix f k).reverse) + +theorem unaryGridSemanticInit_valueInvariant {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) : + UnaryGridValueInvariant f 0 (unaryGridSemanticInit hm) := by + right + simp [UnaryGridValueInvariant, unaryGridSemanticInit, + unaryGridOrdinal, unaryGridPrefix] + +theorem unaryGridSemanticStep_valueInvariant {m k : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hinvariant : UnaryGridValueInvariant f k state) : + UnaryGridValueInvariant f (k + 1) (unaryGridSemanticStep f state) := by + rcases hinvariant with hdone | hactive + Β· rcases hdone with ⟨hdone, hwork, haccumulator⟩ + have hstep : unaryGridSemanticStep f state = state := by + simp [unaryGridSemanticStep, hdone] + rw [hstep] + left + exact ⟨hdone, hwork.trans (by omega), haccumulator⟩ + Β· rcases hactive with ⟨hdone, hordinal, haccumulator⟩ + have hprefix := unaryGridPrefix_succ_of_ordinal + f state.row state.column hordinal + have hnextAccumulator : + f state.row state.column :: state.accumulator = + (unaryGridPrefix f (k + 1)).reverse := by + rw [hprefix, List.reverse_append, haccumulator] + rfl + by_cases hcolumn : state.column.1 + 1 = m + Β· by_cases hrow : state.row.1 + 1 = m + Β· have hstep : unaryGridSemanticStep f state = + { state with + accumulator := f state.row state.column :: state.accumulator + done := true } := by + simp [unaryGridSemanticStep, hdone, hcolumn, hrow] + rw [hstep] + left + refine ⟨rfl, ?_, ?_⟩ + Β· have htotal : k + 1 = m * m := by + rw [← hordinal] + exact unaryGridOrdinal_last state.row state.column hcolumn hrow + omega + Β· rw [hnextAccumulator] + have htotal : k + 1 = m * m := by + rw [← hordinal] + exact unaryGridOrdinal_last state.row state.column hcolumn hrow + rw [htotal, unaryGridPrefix, + List.take_of_length_le (by simp)] + Β· have hstep : unaryGridSemanticStep f state = + { state with + row := ⟨state.row.1 + 1, by omega⟩ + column := ⟨0, by omega⟩ + accumulator := f state.row state.column :: state.accumulator } := by + simp [unaryGridSemanticStep, hdone, hcolumn, hrow] + rw [hstep] + right + refine ⟨hdone, ?_, hnextAccumulator⟩ + rw [unaryGridOrdinal_nextRow state.row state.column hcolumn hrow, + hordinal] + Β· have hstep : unaryGridSemanticStep f state = + { state with + column := ⟨state.column.1 + 1, by omega⟩ + accumulator := f state.row state.column :: state.accumulator } := by + simp [unaryGridSemanticStep, hdone, hcolumn] + rw [hstep] + right + refine ⟨hdone, ?_, hnextAccumulator⟩ + rw [unaryGridOrdinal_nextColumn state.row state.column hcolumn, + hordinal] + +/-- Runs the semantic grid scan for exactly `k` steps from its nonempty initial state. -/ +def unaryGridSemanticStateAt {m : β„•} (hm : 0 < m) + (f : Fin m β†’ Fin m β†’ β„š) (k : β„•) : UnaryGridSemanticState m := + (unaryGridSemanticStep f)^[k] (unaryGridSemanticInit hm) + +theorem unaryGridSemanticStateAt_valueInvariant {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) : βˆ€ k, + UnaryGridValueInvariant f k (unaryGridSemanticStateAt hm f k) := by + intro k + induction k with + | zero => exact unaryGridSemanticInit_valueInvariant hm f + | succ k ih => + rw [unaryGridSemanticStateAt, Function.iterate_succ_apply'] + exact unaryGridSemanticStep_valueInvariant f _ ih + +theorem unaryGridSemanticStateAt_full_accumulator {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) : + (unaryGridSemanticStateAt hm f (m * m)).accumulator = + (unaryGridValues f).reverse := by + have hinvariant := unaryGridSemanticStateAt_valueInvariant hm f (m * m) + rcases hinvariant with hdone | hactive + Β· exact hdone.2.2 + Β· have hord := hactive.2.1 + have hlt := unaryGridOrdinal_lt_square + (unaryGridSemanticStateAt hm f (m * m)).row + (unaryGridSemanticStateAt hm f (m * m)).column + omega + +theorem unaryGridSemanticStateAt_active {m k : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) (hk : k < m * m) : + (unaryGridSemanticStateAt hm f k).done = false ∧ + unaryGridOrdinal (unaryGridSemanticStateAt hm f k).row + (unaryGridSemanticStateAt hm f k).column = k ∧ + (unaryGridSemanticStateAt hm f k).accumulator = + (unaryGridPrefix f k).reverse := by + have hinvariant := unaryGridSemanticStateAt_valueInvariant hm f k + rcases hinvariant with hdone | hactive + Β· omega + Β· exact hactive + +theorem machineUnaryGridGeneratorInit_semanticCode {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) : + machineUnaryGridGeneratorInit + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + machineUnaryGridGeneratorSemanticCode bound payload + (unaryGridSemanticInit hm) := by + rw [machineUnaryGridGeneratorInit, + machineUnaryGridGeneratorInputBound_encode] + simp [ + machineUnaryGridGeneratorSemanticCode, unaryGridSemanticInit, + machineUnaryGridGeneratorCanonicalWord, binaryListCode] + +theorem unaryGridSemanticStateAt_candidate_eq_prefix {m k : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) (hk : k < m * m) : + f (unaryGridSemanticStateAt hm f k).row + (unaryGridSemanticStateAt hm f k).column :: + (unaryGridSemanticStateAt hm f k).accumulator = + (unaryGridPrefix f (k + 1)).reverse := by + have hactive := unaryGridSemanticStateAt_active hm f hk + have hprefix := unaryGridPrefix_succ_of_ordinal f + (unaryGridSemanticStateAt hm f k).row + (unaryGridSemanticStateAt hm f k).column hactive.2.1 + rw [hactive.2.2, hprefix, List.reverse_append] + rfl + +theorem machineUnaryGridGeneratorIterate_semanticCode {m : β„•} + (hm : 0 < m) (entry : List Bool β†’ List Bool) + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode rationalEntryBinaryCode (unaryGridValues f)).length ≀ + bound.length) : + βˆ€ k, k ≀ m * m β†’ + (machineUnaryGridGeneratorStep entry)^[k] + (machineUnaryGridGeneratorInit + (machineUnaryGridGeneratorCanonicalWord m bound payload)) = + machineUnaryGridGeneratorSemanticCode bound payload + (unaryGridSemanticStateAt hm f k) := by + intro k hk + induction k with + | zero => exact machineUnaryGridGeneratorInit_semanticCode hm f bound payload + | succ k ih => + have hklt : k < m * m := by omega + rw [Function.iterate_succ_apply', ih (by omega)] + have hlarge : + (binaryListCode rationalEntryBinaryCode + (f (unaryGridSemanticStateAt hm f k).row + (unaryGridSemanticStateAt hm f k).column :: + (unaryGridSemanticStateAt hm f k).accumulator)).length ≀ + bound.length := by + rw [unaryGridSemanticStateAt_candidate_eq_prefix hm f hklt] + have hprefixBound := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode (unaryGridValues f) (k + 1) + simpa only [unaryGridPrefix] using! hprefixBound.trans hbound + have hstep := machineUnaryGridGeneratorStep_semanticCode entry f + bound payload (unaryGridSemanticStateAt hm f k) hentry hlarge + simpa only [unaryGridSemanticStateAt, + Function.iterate_succ_apply'] using! hstep + +theorem machineUnaryGridGeneratorReversedCode_encode_of_bound {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode rationalEntryBinaryCode (unaryGridValues f)).length ≀ + bound.length) : + machineUnaryGridGeneratorReversedCode entry + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + binaryListCode rationalEntryBinaryCode (unaryGridValues f).reverse := by + cases m with + | zero => + rw [machineUnaryGridGeneratorReversedCode, + machineUnaryGridGeneratorFinalState, + machineUnaryGridGeneratorRuler_encode] + simp [ + machineUnaryGridGeneratorInit, + machineUnaryGridGeneratorCanonicalWord, + unaryGridValues, binaryListCode] + | succ m => + have hm : 0 < m + 1 := by omega + rw [machineUnaryGridGeneratorReversedCode, + machineUnaryGridGeneratorFinalState, + machineUnaryGridGeneratorRuler_encode, List.length_replicate, + machineUnaryGridGeneratorIterate_semanticCode hm entry f bound payload + hentry hbound ((m + 1) * (m + 1)) le_rfl] + simp only [machineUnaryGridGeneratorSemanticCode, + machineUnaryGridGeneratorAccumulator_pack] + rw [unaryGridSemanticStateAt_full_accumulator hm f] + +theorem machineUnaryGridGeneratorCode_encode_of_bound {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode rationalEntryBinaryCode (unaryGridValues f)).length ≀ + bound.length) : + machineUnaryGridGeneratorCode entry + (machineUnaryGridGeneratorCanonicalWord m bound payload) = + binaryListCode rationalEntryBinaryCode (unaryGridValues f) := by + rw [machineUnaryGridGeneratorCode, + machineUnaryGridGeneratorReversedCode_encode_of_bound + entry f bound payload hentry hbound, + machineListReverse_encode, List.reverse_reverse] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryMatrixGenerator.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryMatrixGenerator.lean new file mode 100644 index 0000000000..9793bf52a6 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryMatrixGenerator.lean @@ -0,0 +1,1328 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineUnaryGridGenerator + +/-! +# A reusable finite-word generator for square rational matrices + +This is the nested-row counterpart of `machineUnaryGridGeneratorCode`. +Given a unary dimension, an accumulator bound, and an immutable payload, the +machine visits all matrix positions in row-major order. It stores the current +row and the completed rows in reverse order, and reverses them at the two +row boundaries. Thus its output is exactly the canonical nested-list matrix +code, not a flat list requiring an implicit decoder. + +Both accumulators are explicitly clamped on malformed inputs. The semantic +proof below shows that neither clamp is active on canonical inputs satisfying +the stated output-size bound. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Extracts the unary dimension from a matrix-generation request. -/ +def machineUnaryMatrixGeneratorDimension (word : List Bool) : List Bool := + machinePairFirst word + +/-- Extracts the bound-and-entry-payload portion of a matrix-generation request. -/ +def machineUnaryMatrixGeneratorRest (word : List Bool) : List Bool := + machinePairSecond word + +/-- Extracts the output-bound word from a matrix-generation request. -/ +def machineUnaryMatrixGeneratorInputBound (word : List Bool) : List Bool := + machinePairFirst (machineUnaryMatrixGeneratorRest word) + +/-- Extracts the fixed entry-function payload from a matrix-generation request. -/ +def machineUnaryMatrixGeneratorInputPayload (word : List Bool) : List Bool := + machinePairSecond (machineUnaryMatrixGeneratorRest word) + +/-- Packs row and column indices, reversed current row, reversed completed rows, bound, +completion flag, and fixed request. -/ +def machineUnaryMatrixGeneratorPack + (row column current rows bound done payload : List Bool) : List Bool := + pair row (pair column (pair current + (pair rows (pair bound (pair done payload))))) + +/-- Extracts the unary row index from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorRow (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the unary column index from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorColumn (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the reversed current-row accumulator from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorCurrent (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond state)) + +/-- Extracts the reverse-order completed-row accumulator from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorRows (state : List Bool) : List Bool := + machinePairFirst + (machinePairSecond (machinePairSecond (machinePairSecond state))) + +/-- Extracts the output-bound word from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorBound (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state)))) + +/-- Extracts the completion flag from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorDone (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))))) + +/-- Extracts the fixed request from a matrix-generation state. -/ +def machineUnaryMatrixGeneratorPayload (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond (machinePairSecond + (machinePairSecond (machinePairSecond (machinePairSecond state))))) + +@[simp] theorem machineUnaryMatrixGeneratorRow_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorRow + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = row := by + simp [machineUnaryMatrixGeneratorRow, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorColumn_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorColumn + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = column := by + simp [machineUnaryMatrixGeneratorColumn, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorCurrent_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorCurrent + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = current := by + simp [machineUnaryMatrixGeneratorCurrent, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorRows_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorRows + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = rows := by + simp [machineUnaryMatrixGeneratorRows, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorBound_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorBound + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = bound := by + simp [machineUnaryMatrixGeneratorBound, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorDone_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorDone + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = done := by + simp [machineUnaryMatrixGeneratorDone, machineUnaryMatrixGeneratorPack] + +@[simp] theorem machineUnaryMatrixGeneratorPayload_pack + (row column current rows bound done payload : List Bool) : + machineUnaryMatrixGeneratorPayload + (machineUnaryMatrixGeneratorPack row column current rows bound done payload) = payload := by + simp [machineUnaryMatrixGeneratorPayload, machineUnaryMatrixGeneratorPack] + +/-- Reads the requested unary dimension from the matrix-generation state's fixed payload. -/ +def machineUnaryMatrixGeneratorStateDimension (state : List Bool) : List Bool := + machineUnaryMatrixGeneratorDimension + (machineUnaryMatrixGeneratorPayload state) + +/-- Packages the current row and column with the fixed entry-function payload. -/ +def machineUnaryMatrixGeneratorEntryInput (state : List Bool) : List Bool := + pair (machineUnaryMatrixGeneratorRow state) + (pair (machineUnaryMatrixGeneratorColumn state) + (machineUnaryMatrixGeneratorInputPayload + (machineUnaryMatrixGeneratorPayload state))) + +/-- Increments the unary row index and truncates it to the length of the fixed request. -/ +def machineUnaryMatrixGeneratorNextRow (state : List Bool) : List Bool := + (machineUnaryMatrixGeneratorRow state ++ [true]).take + (machineUnaryMatrixGeneratorPayload state).length + +/-- Increments the unary column index and truncates it to the length of the fixed request. -/ +def machineUnaryMatrixGeneratorNextColumn (state : List Bool) : List Bool := + (machineUnaryMatrixGeneratorColumn state ++ [true]).take + (machineUnaryMatrixGeneratorPayload state).length + +/-- Tests whether the next column ruler has reached the requested dimension. -/ +def machineUnaryMatrixGeneratorColumnCompletesBit + (state : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineUnaryMatrixGeneratorNextColumn state) + (machineUnaryMatrixGeneratorStateDimension state)) + +/-- Tests whether the next row ruler has reached the requested dimension. -/ +def machineUnaryMatrixGeneratorRowCompletesBit + (state : List Bool) : List Bool := + machineHeadBit (machineUnaryRulersEqualBit + (machineUnaryMatrixGeneratorNextRow state) + (machineUnaryMatrixGeneratorStateDimension state)) + +/-- Prepends the generated current entry to the reversed current-row accumulator. -/ +def machineUnaryMatrixGeneratorCurrentCandidate + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + pair (entry (machineUnaryMatrixGeneratorEntryInput state)) + (machineUnaryMatrixGeneratorCurrent state) + +/-- Truncates the updated current-row accumulator to the stored output-bound length. -/ +def machineUnaryMatrixGeneratorNextCurrent + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + (machineUnaryMatrixGeneratorCurrentCandidate entry state).take + (machineUnaryMatrixGeneratorBound state).length + +/-- Reverses the updated current-row accumulator to obtain a completed row in column order. -/ +def machineUnaryMatrixGeneratorCompletedRow + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineListReverse (machineUnaryMatrixGeneratorNextCurrent entry state) + +/-- Prepends the completed current row to the reverse-order matrix accumulator. -/ +def machineUnaryMatrixGeneratorRowsCandidate + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + pair (machineUnaryMatrixGeneratorCompletedRow entry state) + (machineUnaryMatrixGeneratorRows state) + +/-- Truncates the updated completed-row accumulator to the stored output-bound length. -/ +def machineUnaryMatrixGeneratorNextRows + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + (machineUnaryMatrixGeneratorRowsCandidate entry state).take + (machineUnaryMatrixGeneratorBound state).length + +/-- Stores the final completed row, clears the current-row accumulator, and sets the matrix +completion flag. -/ +def machineUnaryMatrixGeneratorFinish + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryMatrixGeneratorPack + (machineUnaryMatrixGeneratorRow state) + (machineUnaryMatrixGeneratorColumn state) [] + (machineUnaryMatrixGeneratorNextRows entry state) + (machineUnaryMatrixGeneratorBound state) [true] + (machineUnaryMatrixGeneratorPayload state) + +/-- Stores the completed row, advances the row index, and resets the column and current-row +accumulators. -/ +def machineUnaryMatrixGeneratorAdvanceRow + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryMatrixGeneratorPack + (machineUnaryMatrixGeneratorNextRow state) [] [] + (machineUnaryMatrixGeneratorNextRows entry state) + (machineUnaryMatrixGeneratorBound state) + (machineUnaryMatrixGeneratorDone state) + (machineUnaryMatrixGeneratorPayload state) + +/-- Advances the column index and updates the bounded current row while retaining completed +rows. -/ +def machineUnaryMatrixGeneratorAdvanceColumn + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineUnaryMatrixGeneratorPack + (machineUnaryMatrixGeneratorRow state) + (machineUnaryMatrixGeneratorNextColumn state) + (machineUnaryMatrixGeneratorNextCurrent entry state) + (machineUnaryMatrixGeneratorRows state) + (machineUnaryMatrixGeneratorBound state) + (machineUnaryMatrixGeneratorDone state) + (machineUnaryMatrixGeneratorPayload state) + +/-- Finishes at the final row end, advances rows at other row ends, and otherwise generates the +next column. -/ +def machineUnaryMatrixGeneratorProcess + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineIfHead (machineUnaryMatrixGeneratorColumnCompletesBit state) + (machineIfHead (machineUnaryMatrixGeneratorRowCompletesBit state) + (machineUnaryMatrixGeneratorFinish entry state) + (machineUnaryMatrixGeneratorAdvanceRow entry state)) + (machineUnaryMatrixGeneratorAdvanceColumn entry state) + +/-- Fixes completed matrix-generation states and processes one entry otherwise. -/ +def machineUnaryMatrixGeneratorStep + (entry : List Bool β†’ List Bool) (state : List Bool) : List Bool := + machineIfHead (machineHeadBit (machineUnaryMatrixGeneratorDone state)) state + (machineUnaryMatrixGeneratorProcess entry state) + +/-- Initializes matrix generation with zero indices, empty row accumulators, supplied bound, and +unset completion flag. -/ +def machineUnaryMatrixGeneratorInit (word : List Bool) : List Bool := + machineUnaryMatrixGeneratorPack [] [] [] [] + (machineUnaryMatrixGeneratorInputBound word) [false] word + +/-- Converts the unary matrix dimension to its binary length. -/ +def machineUnaryMatrixGeneratorDimensionBits (word : List Bool) : List Bool := + machineLengthBits (machineUnaryMatrixGeneratorDimension word) + +/-- Computes the square of the matrix dimension in binary as the generation work count. -/ +def machineUnaryMatrixGeneratorWorkBits (word : List Bool) : List Bool := + machineBinaryMulBits (pair + (machineUnaryMatrixGeneratorDimensionBits word) + (machineUnaryMatrixGeneratorDimensionBits word)) + +/-- Applies the binary-multiplication width construction to guard conversion of the work count +to unary. -/ +def machineUnaryMatrixGeneratorGuard (word : List Bool) : List Bool := + machineBinaryMulWidth word + +/-- Converts the squared dimension to a bounded unary iteration ruler. -/ +def machineUnaryMatrixGeneratorRuler (word : List Bool) : List Bool := + machineBoundedUnary (pair (machineUnaryMatrixGeneratorGuard word) + (machineUnaryMatrixGeneratorWorkBits word)) + +/-- Adds sixteen padding bits and applies the binary-width construction twice to obtain a common +state-field envelope. -/ +def machineUnaryMatrixGeneratorEnvelope (word : List Bool) : List Bool := + machineIteratedBinaryWidth 2 (word ++ List.replicate 16 false) + +/-- Packs seven copies of the common envelope to bound the full matrix-generation state. -/ +def machineUnaryMatrixGeneratorWidth (word : List Bool) : List Bool := + let envelope := machineUnaryMatrixGeneratorEnvelope word + machineUnaryMatrixGeneratorPack envelope envelope envelope envelope + envelope envelope envelope + +/-- Iterates matrix generation for the length of the computed work ruler. -/ +def machineUnaryMatrixGeneratorFinalState + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + (machineUnaryMatrixGeneratorStep entry)^[(machineUnaryMatrixGeneratorRuler word).length] + (machineUnaryMatrixGeneratorInit word) + +/-- Extracts the completed matrix rows in reverse order from the final generation state. -/ +def machineUnaryMatrixGeneratorReversedRowsCode + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineUnaryMatrixGeneratorRows + (machineUnaryMatrixGeneratorFinalState entry word) + +/-- Reverses the accumulated completed rows to restore the original row order. -/ +def machineUnaryMatrixGeneratorRowsCode + (entry : List Bool β†’ List Bool) (word : List Bool) : List Bool := + machineListReverse (machineUnaryMatrixGeneratorReversedRowsCode entry word) + +/-! ## Polynomial-time closure + +The proof is deliberately structural: each accessor and transition is built +from already verified finite-word primitives, and the bounded iterator has an +explicit polynomial state envelope. +-/ + +theorem machineUnaryMatrixGeneratorDimension_mem_FP : + machineUnaryMatrixGeneratorDimension ∈ FP := machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorRest_mem_FP : + machineUnaryMatrixGeneratorRest ∈ FP := machinePairSecond_mem_FP + +theorem machineUnaryMatrixGeneratorInputBound_mem_FP : + machineUnaryMatrixGeneratorInputBound ∈ FP := by + simpa only [machineUnaryMatrixGeneratorInputBound] using! + machineCompose_mem_FP machineUnaryMatrixGeneratorRest_mem_FP + machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorInputPayload_mem_FP : + machineUnaryMatrixGeneratorInputPayload ∈ FP := by + simpa only [machineUnaryMatrixGeneratorInputPayload] using! + machineCompose_mem_FP machineUnaryMatrixGeneratorRest_mem_FP + machinePairSecond_mem_FP + +theorem machineUnaryMatrixGeneratorRow_mem_FP : + machineUnaryMatrixGeneratorRow ∈ FP := machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorColumn_mem_FP : + machineUnaryMatrixGeneratorColumn ∈ FP := by + simpa only [machineUnaryMatrixGeneratorColumn] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorCurrent_mem_FP : + machineUnaryMatrixGeneratorCurrent ∈ FP := by + have h := machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + simpa only [machineUnaryMatrixGeneratorCurrent] using! + machineCompose_mem_FP h machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorRows_mem_FP : + machineUnaryMatrixGeneratorRows ∈ FP := by + have hβ‚‚ := machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + have h₃ := machineCompose_mem_FP hβ‚‚ machinePairSecond_mem_FP + simpa only [machineUnaryMatrixGeneratorRows] using! + machineCompose_mem_FP h₃ machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorBound_mem_FP : + machineUnaryMatrixGeneratorBound ∈ FP := by + have hβ‚‚ := machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + have h₃ := machineCompose_mem_FP hβ‚‚ machinePairSecond_mem_FP + have hβ‚„ := machineCompose_mem_FP h₃ machinePairSecond_mem_FP + simpa only [machineUnaryMatrixGeneratorBound] using! + machineCompose_mem_FP hβ‚„ machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorDone_mem_FP : + machineUnaryMatrixGeneratorDone ∈ FP := by + have hβ‚‚ := machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + have h₃ := machineCompose_mem_FP hβ‚‚ machinePairSecond_mem_FP + have hβ‚„ := machineCompose_mem_FP h₃ machinePairSecond_mem_FP + have hβ‚… := machineCompose_mem_FP hβ‚„ machinePairSecond_mem_FP + simpa only [machineUnaryMatrixGeneratorDone] using! + machineCompose_mem_FP hβ‚… machinePairFirst_mem_FP + +theorem machineUnaryMatrixGeneratorPayload_mem_FP : + machineUnaryMatrixGeneratorPayload ∈ FP := by + have hβ‚‚ := machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + have h₃ := machineCompose_mem_FP hβ‚‚ machinePairSecond_mem_FP + have hβ‚„ := machineCompose_mem_FP h₃ machinePairSecond_mem_FP + have hβ‚… := machineCompose_mem_FP hβ‚„ machinePairSecond_mem_FP + simpa only [machineUnaryMatrixGeneratorPayload] using! + machineCompose_mem_FP hβ‚… machinePairSecond_mem_FP + +theorem machineUnaryMatrixGeneratorStateDimension_mem_FP : + machineUnaryMatrixGeneratorStateDimension ∈ FP := by + simpa only [machineUnaryMatrixGeneratorStateDimension] using! + machineCompose_mem_FP machineUnaryMatrixGeneratorPayload_mem_FP + machineUnaryMatrixGeneratorDimension_mem_FP + +theorem machineUnaryMatrixGeneratorEntryInput_mem_FP : + machineUnaryMatrixGeneratorEntryInput ∈ FP := by + have hpayload := machineCompose_mem_FP + machineUnaryMatrixGeneratorPayload_mem_FP + machineUnaryMatrixGeneratorInputPayload_mem_FP + exact machinePair_mem_FP machineUnaryMatrixGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorColumn_mem_FP hpayload) + +theorem machineUnaryMatrixGeneratorNextRow_mem_FP : + machineUnaryMatrixGeneratorNextRow ∈ FP := by + have happend := machineAppend_mem_FP machineUnaryMatrixGeneratorRow_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineUnaryMatrixGeneratorNextRow] using! + machineTake_mem_FP machineUnaryMatrixGeneratorPayload_mem_FP happend + +theorem machineUnaryMatrixGeneratorNextColumn_mem_FP : + machineUnaryMatrixGeneratorNextColumn ∈ FP := by + have happend := machineAppend_mem_FP machineUnaryMatrixGeneratorColumn_mem_FP + (machineConst_mem_FP [true]) + simpa only [machineUnaryMatrixGeneratorNextColumn] using! + machineTake_mem_FP machineUnaryMatrixGeneratorPayload_mem_FP happend + +theorem machineUnaryMatrixGeneratorColumnCompletesBit_mem_FP : + machineUnaryMatrixGeneratorColumnCompletesBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineUnaryMatrixGeneratorNextColumn_mem_FP + machineUnaryMatrixGeneratorStateDimension_mem_FP + simpa only [machineUnaryMatrixGeneratorColumnCompletesBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineUnaryMatrixGeneratorRowCompletesBit_mem_FP : + machineUnaryMatrixGeneratorRowCompletesBit ∈ FP := by + have heq := machineUnaryRulersEqualBit_mem_FP + machineUnaryMatrixGeneratorNextRow_mem_FP + machineUnaryMatrixGeneratorStateDimension_mem_FP + simpa only [machineUnaryMatrixGeneratorRowCompletesBit] using! + machineCompose_mem_FP heq machineHeadBit_mem_FP + +theorem machineUnaryMatrixGeneratorCurrentCandidate_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorCurrentCandidate entry ∈ FP := by + have hcurrentEntry := machineCompose_mem_FP + machineUnaryMatrixGeneratorEntryInput_mem_FP hentry + exact machinePair_mem_FP hcurrentEntry + machineUnaryMatrixGeneratorCurrent_mem_FP + +theorem machineUnaryMatrixGeneratorNextCurrent_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorNextCurrent entry ∈ FP := by + simpa only [machineUnaryMatrixGeneratorNextCurrent] using! + machineTake_mem_FP machineUnaryMatrixGeneratorBound_mem_FP + (machineUnaryMatrixGeneratorCurrentCandidate_mem_FP hentry) + +theorem machineUnaryMatrixGeneratorCompletedRow_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorCompletedRow entry ∈ FP := by + simpa only [machineUnaryMatrixGeneratorCompletedRow] using! + machineCompose_mem_FP + (machineUnaryMatrixGeneratorNextCurrent_mem_FP hentry) + machineListReverse_mem_FP + +theorem machineUnaryMatrixGeneratorRowsCandidate_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorRowsCandidate entry ∈ FP := + machinePair_mem_FP (machineUnaryMatrixGeneratorCompletedRow_mem_FP hentry) + machineUnaryMatrixGeneratorRows_mem_FP + +theorem machineUnaryMatrixGeneratorNextRows_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorNextRows entry ∈ FP := by + simpa only [machineUnaryMatrixGeneratorNextRows] using! + machineTake_mem_FP machineUnaryMatrixGeneratorBound_mem_FP + (machineUnaryMatrixGeneratorRowsCandidate_mem_FP hentry) + +theorem machineUnaryMatrixGeneratorFinish_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorFinish entry ∈ FP := + machinePair_mem_FP machineUnaryMatrixGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorColumn_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineUnaryMatrixGeneratorNextRows_mem_FP hentry) + (machinePair_mem_FP machineUnaryMatrixGeneratorBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [true]) + machineUnaryMatrixGeneratorPayload_mem_FP))))) + +theorem machineUnaryMatrixGeneratorAdvanceRow_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorAdvanceRow entry ∈ FP := + machinePair_mem_FP machineUnaryMatrixGeneratorNextRow_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineUnaryMatrixGeneratorNextRows_mem_FP hentry) + (machinePair_mem_FP machineUnaryMatrixGeneratorBound_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorDone_mem_FP + machineUnaryMatrixGeneratorPayload_mem_FP))))) + +theorem machineUnaryMatrixGeneratorAdvanceColumn_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorAdvanceColumn entry ∈ FP := + machinePair_mem_FP machineUnaryMatrixGeneratorRow_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorNextColumn_mem_FP + (machinePair_mem_FP (machineUnaryMatrixGeneratorNextCurrent_mem_FP hentry) + (machinePair_mem_FP machineUnaryMatrixGeneratorRows_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorBound_mem_FP + (machinePair_mem_FP machineUnaryMatrixGeneratorDone_mem_FP + machineUnaryMatrixGeneratorPayload_mem_FP))))) + +theorem machineUnaryMatrixGeneratorProcess_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorProcess entry ∈ FP := by + have hrow := machineIfHead_mem_FP + machineUnaryMatrixGeneratorRowCompletesBit_mem_FP + (machineUnaryMatrixGeneratorFinish_mem_FP hentry) + (machineUnaryMatrixGeneratorAdvanceRow_mem_FP hentry) + exact machineIfHead_mem_FP + machineUnaryMatrixGeneratorColumnCompletesBit_mem_FP hrow + (machineUnaryMatrixGeneratorAdvanceColumn_mem_FP hentry) + +theorem machineUnaryMatrixGeneratorStep_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorStep entry ∈ FP := by + have hdone := machineCompose_mem_FP machineUnaryMatrixGeneratorDone_mem_FP + machineHeadBit_mem_FP + exact machineIfHead_mem_FP hdone id_mem_FP + (machineUnaryMatrixGeneratorProcess_mem_FP hentry) + +theorem machineUnaryMatrixGeneratorInit_mem_FP : + machineUnaryMatrixGeneratorInit ∈ FP := + machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP (machineConst_mem_FP []) + (machinePair_mem_FP machineUnaryMatrixGeneratorInputBound_mem_FP + (machinePair_mem_FP (machineConst_mem_FP [false]) id_mem_FP))))) + +theorem machineUnaryMatrixGeneratorDimensionBits_mem_FP : + machineUnaryMatrixGeneratorDimensionBits ∈ FP := by + simpa only [machineUnaryMatrixGeneratorDimensionBits] using! + machineCompose_mem_FP machineUnaryMatrixGeneratorDimension_mem_FP + machineLengthBits_mem_FP + +theorem machineUnaryMatrixGeneratorWorkBits_mem_FP : + machineUnaryMatrixGeneratorWorkBits ∈ FP := by + have hinput := machinePair_mem_FP + machineUnaryMatrixGeneratorDimensionBits_mem_FP + machineUnaryMatrixGeneratorDimensionBits_mem_FP + simpa only [machineUnaryMatrixGeneratorWorkBits] using! + machineCompose_mem_FP hinput machineBinaryMulBits_mem_FP + +theorem machineUnaryMatrixGeneratorGuard_mem_FP : + machineUnaryMatrixGeneratorGuard ∈ FP := machineBinaryMulWidth_mem_FP + +theorem machineUnaryMatrixGeneratorRuler_mem_FP : + machineUnaryMatrixGeneratorRuler ∈ FP := by + have hinput := machinePair_mem_FP machineUnaryMatrixGeneratorGuard_mem_FP + machineUnaryMatrixGeneratorWorkBits_mem_FP + simpa only [machineUnaryMatrixGeneratorRuler] using! + machineCompose_mem_FP hinput machineBoundedUnary_mem_FP + +theorem machineUnaryMatrixGeneratorEnvelope_mem_FP : + machineUnaryMatrixGeneratorEnvelope ∈ FP := by + have hpadded := machineAppend_mem_FP id_mem_FP + (machineConst_mem_FP (List.replicate 16 false)) + simpa only [machineUnaryMatrixGeneratorEnvelope] using! + machineCompose_mem_FP hpadded (machineIteratedBinaryWidth_mem_FP 2) + +theorem machineUnaryMatrixGeneratorWidth_mem_FP : + machineUnaryMatrixGeneratorWidth ∈ FP := by + let h := machineUnaryMatrixGeneratorEnvelope_mem_FP + exact machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h + (machinePair_mem_FP h (machinePair_mem_FP h h))))) + +/-- Requires exact matrix-state packing, input-bounded indices, bounded current and completed +rows, fixed bound and request, and at most one completion bit. -/ +def MachineUnaryMatrixGeneratorStateBound + (word state : List Bool) : Prop := + state = machineUnaryMatrixGeneratorPack + (machineUnaryMatrixGeneratorRow state) + (machineUnaryMatrixGeneratorColumn state) + (machineUnaryMatrixGeneratorCurrent state) + (machineUnaryMatrixGeneratorRows state) + (machineUnaryMatrixGeneratorBound state) + (machineUnaryMatrixGeneratorDone state) + (machineUnaryMatrixGeneratorPayload state) ∧ + (machineUnaryMatrixGeneratorRow state).length ≀ word.length ∧ + (machineUnaryMatrixGeneratorColumn state).length ≀ word.length ∧ + (machineUnaryMatrixGeneratorCurrent state).length ≀ + (machineUnaryMatrixGeneratorInputBound word).length ∧ + (machineUnaryMatrixGeneratorRows state).length ≀ + (machineUnaryMatrixGeneratorInputBound word).length ∧ + machineUnaryMatrixGeneratorBound state = + machineUnaryMatrixGeneratorInputBound word ∧ + (machineUnaryMatrixGeneratorDone state).length ≀ 1 ∧ + machineUnaryMatrixGeneratorPayload state = word + +theorem machineUnaryMatrixGeneratorInit_bound (word : List Bool) : + MachineUnaryMatrixGeneratorStateBound word + (machineUnaryMatrixGeneratorInit word) := by + simp [MachineUnaryMatrixGeneratorStateBound, + machineUnaryMatrixGeneratorInit] + +theorem machineUnaryMatrixGeneratorStep_bound + {entry : List Bool β†’ List Bool} {word state : List Bool} + (hs : MachineUnaryMatrixGeneratorStateBound word state) : + MachineUnaryMatrixGeneratorStateBound word + (machineUnaryMatrixGeneratorStep entry state) := by + rcases hs with + ⟨hdecomp, hrow, hcolumn, hcurrent, hrows, hbound, hdone, hpayload⟩ + have hnextCurrent : + (machineUnaryMatrixGeneratorNextCurrent entry state).length ≀ + (machineUnaryMatrixGeneratorInputBound word).length := by + rw [machineUnaryMatrixGeneratorNextCurrent, hbound] + exact List.length_take_le _ _ + have hnextRows : + (machineUnaryMatrixGeneratorNextRows entry state).length ≀ + (machineUnaryMatrixGeneratorInputBound word).length := by + rw [machineUnaryMatrixGeneratorNextRows, hbound] + exact List.length_take_le _ _ + have hnextRow : (machineUnaryMatrixGeneratorNextRow state).length ≀ + word.length := by + rw [machineUnaryMatrixGeneratorNextRow, hpayload] + exact List.length_take_le _ _ + have hnextColumn : (machineUnaryMatrixGeneratorNextColumn state).length ≀ + word.length := by + rw [machineUnaryMatrixGeneratorNextColumn, hpayload] + exact List.length_take_le _ _ + have hfinish : MachineUnaryMatrixGeneratorStateBound word + (machineUnaryMatrixGeneratorFinish entry state) := by + simp only [MachineUnaryMatrixGeneratorStateBound, + machineUnaryMatrixGeneratorFinish, + machineUnaryMatrixGeneratorRow_pack, + machineUnaryMatrixGeneratorColumn_pack, + machineUnaryMatrixGeneratorCurrent_pack, + machineUnaryMatrixGeneratorRows_pack, + machineUnaryMatrixGeneratorBound_pack, + machineUnaryMatrixGeneratorDone_pack, + machineUnaryMatrixGeneratorPayload_pack] + exact ⟨trivial, hrow, hcolumn, by simp, hnextRows, hbound, by simp, + hpayload⟩ + have hadvanceRow : MachineUnaryMatrixGeneratorStateBound word + (machineUnaryMatrixGeneratorAdvanceRow entry state) := by + simp only [MachineUnaryMatrixGeneratorStateBound, + machineUnaryMatrixGeneratorAdvanceRow, + machineUnaryMatrixGeneratorRow_pack, + machineUnaryMatrixGeneratorColumn_pack, + machineUnaryMatrixGeneratorCurrent_pack, + machineUnaryMatrixGeneratorRows_pack, + machineUnaryMatrixGeneratorBound_pack, + machineUnaryMatrixGeneratorDone_pack, + machineUnaryMatrixGeneratorPayload_pack] + exact ⟨trivial, hnextRow, by simp, by simp, hnextRows, hbound, hdone, + hpayload⟩ + have hadvanceColumn : MachineUnaryMatrixGeneratorStateBound word + (machineUnaryMatrixGeneratorAdvanceColumn entry state) := by + simp only [MachineUnaryMatrixGeneratorStateBound, + machineUnaryMatrixGeneratorAdvanceColumn, + machineUnaryMatrixGeneratorRow_pack, + machineUnaryMatrixGeneratorColumn_pack, + machineUnaryMatrixGeneratorCurrent_pack, + machineUnaryMatrixGeneratorRows_pack, + machineUnaryMatrixGeneratorBound_pack, + machineUnaryMatrixGeneratorDone_pack, + machineUnaryMatrixGeneratorPayload_pack] + exact ⟨trivial, hrow, hnextColumn, hnextCurrent, hrows, hbound, hdone, + hpayload⟩ + rw [machineUnaryMatrixGeneratorStep] + cases hdoneCode : machineUnaryMatrixGeneratorDone state with + | nil => + rw [machineHeadBit_nil, machineIfHead_false, + machineUnaryMatrixGeneratorProcess] + cases hcolumnCode : machineUnaryMatrixGeneratorColumnCompletesBit state with + | nil => + have hlen : + (machineUnaryMatrixGeneratorColumnCompletesBit state).length = 1 := by + simp [machineUnaryMatrixGeneratorColumnCompletesBit] + rw [hcolumnCode] at hlen + simp at hlen + | cons columnBit columnTail => + cases columnBit with + | false => rw [machineIfHead_false]; exact hadvanceColumn + | true => + rw [machineIfHead_true] + cases hrowCode : machineUnaryMatrixGeneratorRowCompletesBit state with + | nil => + have hlen : + (machineUnaryMatrixGeneratorRowCompletesBit state).length = 1 := by + simp [machineUnaryMatrixGeneratorRowCompletesBit] + rw [hrowCode] at hlen + simp at hlen + | cons rowBit rowTail => + cases rowBit with + | false => rw [machineIfHead_false]; exact hadvanceRow + | true => rw [machineIfHead_true]; exact hfinish + | cons doneBit doneTail => + cases doneBit with + | false => + rw [machineHeadBit_cons, machineIfHead_false, + machineUnaryMatrixGeneratorProcess] + cases hcolumnCode : machineUnaryMatrixGeneratorColumnCompletesBit state with + | nil => + have hlen : + (machineUnaryMatrixGeneratorColumnCompletesBit state).length = 1 := by + simp [machineUnaryMatrixGeneratorColumnCompletesBit] + rw [hcolumnCode] at hlen + simp at hlen + | cons columnBit columnTail => + cases columnBit with + | false => rw [machineIfHead_false]; exact hadvanceColumn + | true => + rw [machineIfHead_true] + cases hrowCode : machineUnaryMatrixGeneratorRowCompletesBit state with + | nil => + have hlen : + (machineUnaryMatrixGeneratorRowCompletesBit state).length = 1 := by + simp [machineUnaryMatrixGeneratorRowCompletesBit] + rw [hrowCode] at hlen + simp at hlen + | cons rowBit rowTail => + cases rowBit with + | false => rw [machineIfHead_false]; exact hadvanceRow + | true => rw [machineIfHead_true]; exact hfinish + | true => + rw [machineHeadBit_cons, machineIfHead_true] + exact ⟨hdecomp, hrow, hcolumn, hcurrent, hrows, hbound, hdone, + hpayload⟩ + +theorem machineUnaryMatrixGeneratorIterate_bound + (entry : List Bool β†’ List Bool) (word : List Bool) : βˆ€ k, + MachineUnaryMatrixGeneratorStateBound word + ((machineUnaryMatrixGeneratorStep entry)^[k] + (machineUnaryMatrixGeneratorInit word)) := by + intro k + induction k with + | zero => exact machineUnaryMatrixGeneratorInit_bound word + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineUnaryMatrixGeneratorStep_bound ih + +theorem machineUnaryMatrixGeneratorEnvelope_word_le (word : List Bool) : + word.length ≀ (machineUnaryMatrixGeneratorEnvelope word).length := by + rw [machineUnaryMatrixGeneratorEnvelope, + machineIteratedBinaryWidth_length] + have hpadded : word.length ≀ (word ++ List.replicate 16 false).length := by + simp + exact hpadded.trans (certificateExpGuardWidth_self_le 2 _) + +theorem machineUnaryMatrixGeneratorEnvelope_pos (word : List Bool) : + 1 ≀ (machineUnaryMatrixGeneratorEnvelope word).length := by + have hword := machineUnaryMatrixGeneratorEnvelope_word_le word + by_cases hnil : word = [] + Β· subst word + norm_num [machineUnaryMatrixGeneratorEnvelope, + machineIteratedBinaryWidth_length, certificateExpGuardWidth] + Β· have hpos : 0 < word.length := List.length_pos_of_ne_nil hnil + have : 1 ≀ word.length := by omega + omega + +theorem machineUnaryMatrixGeneratorInputBound_le_envelope (word : List Bool) : + (machineUnaryMatrixGeneratorInputBound word).length ≀ + (machineUnaryMatrixGeneratorEnvelope word).length := + (machinePairFirst_length_le (machineUnaryMatrixGeneratorRest word)).trans + ((machinePairSecond_length_le word).trans + (machineUnaryMatrixGeneratorEnvelope_word_le word)) + +theorem machineUnaryMatrixGeneratorIterate_length_le_width + (entry : List Bool β†’ List Bool) (word : List Bool) (iterations : β„•) + (_ : iterations ≀ (machineUnaryMatrixGeneratorRuler word).length) : + ((machineUnaryMatrixGeneratorStep entry)^[iterations] + (machineUnaryMatrixGeneratorInit word)).length ≀ + (machineUnaryMatrixGeneratorWidth word).length := by + rcases machineUnaryMatrixGeneratorIterate_bound entry word iterations with + ⟨hdecomp, hrow, hcolumn, hcurrent, hrows, hbound, hdone, hpayload⟩ + have hwe := machineUnaryMatrixGeneratorEnvelope_word_le word + have hbe := machineUnaryMatrixGeneratorInputBound_le_envelope word + have hepos := machineUnaryMatrixGeneratorEnvelope_pos word + rw [hdecomp, hbound, hpayload] + simp only [machineUnaryMatrixGeneratorPack, + machineUnaryMatrixGeneratorWidth, pair_length] + omega + +theorem machineUnaryMatrixGeneratorFinalState_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorFinalState entry ∈ FP := + Cobham.iterate_mem_FP + (machineUnaryMatrixGeneratorStep_mem_FP hentry) + machineUnaryMatrixGeneratorInit_mem_FP + machineUnaryMatrixGeneratorRuler_mem_FP + machineUnaryMatrixGeneratorWidth_mem_FP + (machineUnaryMatrixGeneratorIterate_length_le_width entry) + +theorem machineUnaryMatrixGeneratorReversedRowsCode_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorReversedRowsCode entry ∈ FP := by + simpa only [machineUnaryMatrixGeneratorReversedRowsCode] using! + machineCompose_mem_FP + (machineUnaryMatrixGeneratorFinalState_mem_FP hentry) + machineUnaryMatrixGeneratorRows_mem_FP + +theorem machineUnaryMatrixGeneratorRowsCode_mem_FP + {entry : List Bool β†’ List Bool} (hentry : entry ∈ FP) : + machineUnaryMatrixGeneratorRowsCode entry ∈ FP := by + simpa only [machineUnaryMatrixGeneratorRowsCode] using! + machineCompose_mem_FP + (machineUnaryMatrixGeneratorReversedRowsCode_mem_FP hentry) + machineListReverse_mem_FP + +/-! ## Canonical inputs and exact traversal -/ + +/-- Encodes unary dimension `m` followed by the supplied output bound and fixed entry payload. -/ +def machineUnaryMatrixGeneratorCanonicalWord + (m : β„•) (bound payload : List Bool) : List Bool := + pair (List.replicate m true) (pair bound payload) + +@[simp] theorem machineUnaryMatrixGeneratorDimension_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryMatrixGeneratorDimension + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + List.replicate m true := by + simp [machineUnaryMatrixGeneratorDimension, + machineUnaryMatrixGeneratorCanonicalWord] + +@[simp] theorem machineUnaryMatrixGeneratorInputBound_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryMatrixGeneratorInputBound + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = bound := by + simp [machineUnaryMatrixGeneratorInputBound, + machineUnaryMatrixGeneratorRest, + machineUnaryMatrixGeneratorCanonicalWord] + +@[simp] theorem machineUnaryMatrixGeneratorInputPayload_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryMatrixGeneratorInputPayload + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = payload := by + simp [machineUnaryMatrixGeneratorInputPayload, + machineUnaryMatrixGeneratorRest, + machineUnaryMatrixGeneratorCanonicalWord] + +@[simp] theorem machineUnaryMatrixGeneratorWorkBits_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryMatrixGeneratorWorkBits + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + (m * m).bits := by + rw [machineUnaryMatrixGeneratorWorkBits, + machineUnaryMatrixGeneratorDimensionBits, + machineUnaryMatrixGeneratorDimension_encode, + machineLengthBits_encode, List.length_replicate, + machineBinaryMulBits_pair_natBits] + +theorem machineUnaryMatrixGeneratorWork_le_guard + (m : β„•) (bound payload : List Bool) : + m * m ≀ + (machineUnaryMatrixGeneratorGuard + (machineUnaryMatrixGeneratorCanonicalWord m bound payload)).length := by + have hm : m ≀ + (machineUnaryMatrixGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryMatrixGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + simp only [machineUnaryMatrixGeneratorGuard, machineBinaryMulWidth, + List.length_replicate, List.length_append] + nlinarith + +@[simp] theorem machineUnaryMatrixGeneratorRuler_encode + (m : β„•) (bound payload : List Bool) : + machineUnaryMatrixGeneratorRuler + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + List.replicate (m * m) true := by + rw [machineUnaryMatrixGeneratorRuler, + machineUnaryMatrixGeneratorWorkBits_encode, + machineBoundedUnary_encode_of_le] + exact machineUnaryMatrixGeneratorWork_le_guard m bound payload + +/-! ## Typed row-major semantics -/ + +/-- Lists the matrix rows and their entries in finite-index order. -/ +def unaryMatrixRows {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) : List (List β„š) := + List.ofFn fun i ↦ List.ofFn fun j ↦ f i j + +@[simp] theorem unaryMatrixRows_length {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) : (unaryMatrixRows f).length = m := by + simp [unaryMatrixRows] + +@[simp] theorem unaryMatrixRows_getElem {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (i : β„•) (hi : i < (unaryMatrixRows f).length) : + (unaryMatrixRows f)[i] = + List.ofFn (f ⟨i, by simpa using! hi⟩) := by + simp [unaryMatrixRows] + +/-- Returns the reversed processed prefix of the current row, or the empty row after completion. -/ +def unaryMatrixCurrent {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) : List β„š := + if state.done then [] + else (List.ofFn (f state.row)).take state.column.1 |>.reverse + +/-- Returns all completed rows in reverse order, using the whole matrix when the scan is +complete. -/ +def unaryMatrixCompletedRows {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) : + List (List β„š) := + if state.done then (unaryMatrixRows f).reverse + else ((unaryMatrixRows f).take state.row.1).reverse + +/-- Encodes the semantic grid position together with its reversed current-row prefix and +reversed completed rows. -/ +def machineUnaryMatrixGeneratorSemanticCode {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : List Bool := + machineUnaryMatrixGeneratorPack + (List.replicate state.row.1 true) + (List.replicate state.column.1 true) + (binaryListCode rationalEntryBinaryCode (unaryMatrixCurrent f state)) + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixCompletedRows f state)) + bound [state.done] + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) + +@[simp] theorem machineUnaryMatrixGeneratorEntryInput_semanticCode {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryMatrixGeneratorEntryInput + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + pair (List.replicate state.row.1 true) + (pair (List.replicate state.column.1 true) payload) := by + simp [machineUnaryMatrixGeneratorEntryInput, + machineUnaryMatrixGeneratorSemanticCode] + +@[simp] theorem machineUnaryMatrixGeneratorNextRow_semanticCode {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryMatrixGeneratorNextRow + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + List.replicate (state.row.1 + 1) true := by + have hlength : state.row.1 + 1 ≀ + (machineUnaryMatrixGeneratorCanonicalWord m bound payload).length := by + have hrow : state.row.1 + 1 ≀ m := by omega + have hm : m ≀ + (machineUnaryMatrixGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryMatrixGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + omega + rw [machineUnaryMatrixGeneratorNextRow] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorRow_pack, + machineUnaryMatrixGeneratorPayload_pack] + have happend : List.replicate state.row.1 true ++ [true] = + List.replicate (state.row.1 + 1) true := by + rw [show ([true] : List Bool) = List.replicate 1 true by rfl, + List.replicate_append_replicate] + rw [happend, List.take_of_length_le (by simpa using! hlength)] + +@[simp] theorem machineUnaryMatrixGeneratorNextColumn_semanticCode {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryMatrixGeneratorNextColumn + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + List.replicate (state.column.1 + 1) true := by + have hlength : state.column.1 + 1 ≀ + (machineUnaryMatrixGeneratorCanonicalWord m bound payload).length := by + have hcolumn : state.column.1 + 1 ≀ m := by omega + have hm : m ≀ + (machineUnaryMatrixGeneratorCanonicalWord m bound payload).length := by + simp only [machineUnaryMatrixGeneratorCanonicalWord, pair_length, + List.length_replicate] + omega + omega + rw [machineUnaryMatrixGeneratorNextColumn] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorColumn_pack, + machineUnaryMatrixGeneratorPayload_pack] + have happend : List.replicate state.column.1 true ++ [true] = + List.replicate (state.column.1 + 1) true := by + rw [show ([true] : List Bool) = List.replicate 1 true by rfl, + List.replicate_append_replicate] + rw [happend, List.take_of_length_le (by simpa using! hlength)] + +@[simp] theorem machineUnaryMatrixGeneratorColumnCompletesBit_semanticCode + {m : β„•} (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryMatrixGeneratorColumnCompletesBit + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + [decide (state.column.1 + 1 = m)] := by + rw [machineUnaryMatrixGeneratorColumnCompletesBit, + machineUnaryMatrixGeneratorNextColumn_semanticCode, + machineUnaryMatrixGeneratorStateDimension] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorPayload_pack, + machineUnaryMatrixGeneratorDimension_encode, + machineUnaryRulersEqualBit_replicate, machineHeadBit_cons] + +@[simp] theorem machineUnaryMatrixGeneratorRowCompletesBit_semanticCode + {m : β„•} (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (state : UnaryGridSemanticState m) : + machineUnaryMatrixGeneratorRowCompletesBit + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + [decide (state.row.1 + 1 = m)] := by + rw [machineUnaryMatrixGeneratorRowCompletesBit, + machineUnaryMatrixGeneratorNextRow_semanticCode, + machineUnaryMatrixGeneratorStateDimension] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorPayload_pack, + machineUnaryMatrixGeneratorDimension_encode, + machineUnaryRulersEqualBit_replicate, machineHeadBit_cons] + +theorem unaryMatrixCurrent_active {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) : + unaryMatrixCurrent f state = + ((List.ofFn (f state.row)).take state.column.1).reverse := by + simp [unaryMatrixCurrent, hdone] + +theorem unaryMatrixCompletedRows_active {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) : + unaryMatrixCompletedRows f state = + ((unaryMatrixRows f).take state.row.1).reverse := by + simp [unaryMatrixCompletedRows, hdone] + +theorem unaryMatrixCurrentCandidate_eq {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) : + f state.row state.column :: unaryMatrixCurrent f state = + ((List.ofFn (f state.row)).take (state.column.1 + 1)).reverse := by + rw [unaryMatrixCurrent_active f state hdone] + have hcolumn : state.column.1 < (List.ofFn (f state.row)).length := by + simp + have htake := List.take_concat_get hcolumn + have hget : (List.ofFn (f state.row))[state.column.1] = + f state.row state.column := by simp + rw [hget] at htake + rw [← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat + (l := (List.ofFn (f state.row)).take state.column.1) + (a := f state.row state.column)).symm + +theorem unaryMatrixRowsCandidate_eq {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) + (hcolumn : state.column.1 + 1 = m) : + (f state.row state.column :: unaryMatrixCurrent f state).reverse :: + unaryMatrixCompletedRows f state = + ((unaryMatrixRows f).take (state.row.1 + 1)).reverse := by + rw [unaryMatrixCurrentCandidate_eq f state hdone, + unaryMatrixCompletedRows_active f state hdone, + List.reverse_reverse] + have hfull : + (List.ofFn (f state.row)).take (state.column.1 + 1) = + List.ofFn (f state.row) := by + rw [hcolumn] + exact List.take_of_length_le (by simp) + rw [hfull] + have hrow : state.row.1 < (unaryMatrixRows f).length := by simp + have htake := List.take_concat_get hrow + have hget : (unaryMatrixRows f)[state.row.1] = + List.ofFn (f state.row) := by + simp [unaryMatrixRows] + rw [← hget, ← htake] + simpa only [List.concat_eq_append] using! + (List.reverse_concat + (l := (unaryMatrixRows f).take state.row.1) + (a := (unaryMatrixRows f)[state.row.1])).symm + +theorem unaryMatrixCurrentCandidate_code_length_le {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) : + (binaryListCode rationalEntryBinaryCode + (f state.row state.column :: unaryMatrixCurrent f state)).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length := by + rw [unaryMatrixCurrentCandidate_eq f state hdone] + have hprefix := binaryListCode_take_reverse_length_le + rationalEntryBinaryCode (List.ofFn (f state.row)) + (state.column.1 + 1) + have hmem : List.ofFn (f state.row) ∈ unaryMatrixRows f := by + rw [unaryMatrixRows] + exact List.mem_ofFn.mpr ⟨state.row, rfl⟩ + exact hprefix.trans (binaryListCode_element_length_le + (binaryListCode rationalEntryBinaryCode) hmem) + +theorem unaryMatrixRowsCandidate_code_length_le {m : β„•} + (f : Fin m β†’ Fin m β†’ β„š) (state : UnaryGridSemanticState m) + (hdone : state.done = false) + (hcolumn : state.column.1 + 1 = m) : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + ((f state.row state.column :: unaryMatrixCurrent f state).reverse :: + unaryMatrixCompletedRows f state)).length ≀ + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length := by + rw [unaryMatrixRowsCandidate_eq f state hdone hcolumn] + exact binaryListCode_take_reverse_length_le + (binaryListCode rationalEntryBinaryCode) (unaryMatrixRows f) + (state.row.1 + 1) + +theorem machineUnaryMatrixGeneratorStep_semanticCode {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) (state : UnaryGridSemanticState m) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length) : + machineUnaryMatrixGeneratorStep entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload state) = + machineUnaryMatrixGeneratorSemanticCode f bound payload + (unaryGridSemanticStep f state) := by + rcases state with ⟨row, column, accumulator, done⟩ + cases done + Β· have hcurrentCandidate : + machineUnaryMatrixGeneratorCurrentCandidate entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode rationalEntryBinaryCode + (f row column :: + unaryMatrixCurrent f ⟨row, column, accumulator, false⟩) := by + rw [machineUnaryMatrixGeneratorCurrentCandidate, + machineUnaryMatrixGeneratorEntryInput_semanticCode, hentry] + simp [machineUnaryMatrixGeneratorSemanticCode, binaryListCode] + have hcurrentLarge : + (binaryListCode rationalEntryBinaryCode + (f row column :: + unaryMatrixCurrent f ⟨row, column, accumulator, false⟩)).length ≀ + bound.length := + (unaryMatrixCurrentCandidate_code_length_le f + ⟨row, column, accumulator, false⟩ rfl).trans hbound + have hnextCurrent : + machineUnaryMatrixGeneratorNextCurrent entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode rationalEntryBinaryCode + (f row column :: + unaryMatrixCurrent f ⟨row, column, accumulator, false⟩) := by + rw [machineUnaryMatrixGeneratorNextCurrent, hcurrentCandidate] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorBound_pack] + exact List.take_of_length_le hcurrentLarge + have hcompletedRow : + machineUnaryMatrixGeneratorCompletedRow entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode rationalEntryBinaryCode + (f row column :: + unaryMatrixCurrent f + ⟨row, column, accumulator, false⟩).reverse := by + rw [machineUnaryMatrixGeneratorCompletedRow, hnextCurrent, + machineListReverse_encode] + have hcurrentEq := unaryMatrixCurrentCandidate_eq f + ⟨row, column, accumulator, false⟩ rfl + rw [hcurrentEq] at hnextCurrent + by_cases hcolumn : column.1 + 1 = m + Β· have hrowsCandidate : + machineUnaryMatrixGeneratorRowsCandidate entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + ((f row column :: + unaryMatrixCurrent f + ⟨row, column, accumulator, false⟩).reverse :: + unaryMatrixCompletedRows f + ⟨row, column, accumulator, false⟩) := by + rw [machineUnaryMatrixGeneratorRowsCandidate, hcompletedRow] + simp [machineUnaryMatrixGeneratorSemanticCode, binaryListCode] + have hrowsLarge : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + ((f row column :: + unaryMatrixCurrent f + ⟨row, column, accumulator, false⟩).reverse :: + unaryMatrixCompletedRows f + ⟨row, column, accumulator, false⟩)).length ≀ bound.length := + (unaryMatrixRowsCandidate_code_length_le f + ⟨row, column, accumulator, false⟩ rfl hcolumn).trans hbound + have hnextRows : + machineUnaryMatrixGeneratorNextRows entry + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + ((f row column :: + unaryMatrixCurrent f + ⟨row, column, accumulator, false⟩).reverse :: + unaryMatrixCompletedRows f + ⟨row, column, accumulator, false⟩) := by + rw [machineUnaryMatrixGeneratorNextRows, hrowsCandidate] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorBound_pack] + exact List.take_of_length_le hrowsLarge + have hrowsEq := unaryMatrixRowsCandidate_eq f + ⟨row, column, accumulator, false⟩ rfl hcolumn + rw [hrowsEq] at hnextRows + by_cases hrow : row.1 + 1 = m + Β· have htakeAll : (unaryMatrixRows f).take m = unaryMatrixRows f := by + exact List.take_of_length_le (by simp) + have hdoneFalse : + machineHeadBit (machineUnaryMatrixGeneratorDone + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryMatrixGeneratorSemanticCode] + rw [machineUnaryMatrixGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryMatrixGeneratorProcess, + machineUnaryMatrixGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_true, machineIfHead_true] + rw [machineUnaryMatrixGeneratorRowCompletesBit_semanticCode] + simp only [hrow, decide_true, machineIfHead_true] + rw [machineUnaryMatrixGeneratorFinish, hnextRows] + simp [unaryGridSemanticStep, hcolumn, hrow, + machineUnaryMatrixGeneratorSemanticCode, + unaryMatrixCurrent, unaryMatrixCompletedRows, + htakeAll, binaryListCode] + Β· have hdoneFalse : + machineHeadBit (machineUnaryMatrixGeneratorDone + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryMatrixGeneratorSemanticCode] + rw [machineUnaryMatrixGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryMatrixGeneratorProcess, + machineUnaryMatrixGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_true, machineIfHead_true] + rw [machineUnaryMatrixGeneratorRowCompletesBit_semanticCode] + simp only [hrow, decide_false, machineIfHead_false] + rw [machineUnaryMatrixGeneratorAdvanceRow, + machineUnaryMatrixGeneratorNextRow_semanticCode, hnextRows] + simp [unaryGridSemanticStep, hcolumn, hrow, + machineUnaryMatrixGeneratorSemanticCode, + unaryMatrixCurrent, unaryMatrixCompletedRows, binaryListCode] + Β· have hdoneFalse : + machineHeadBit (machineUnaryMatrixGeneratorDone + (machineUnaryMatrixGeneratorSemanticCode f bound payload + ⟨row, column, accumulator, false⟩)) = [false] := by + simp [machineUnaryMatrixGeneratorSemanticCode] + rw [machineUnaryMatrixGeneratorStep, hdoneFalse, + machineIfHead_false, machineUnaryMatrixGeneratorProcess, + machineUnaryMatrixGeneratorColumnCompletesBit_semanticCode] + simp only [hcolumn, decide_false, machineIfHead_false] + rw [machineUnaryMatrixGeneratorAdvanceColumn, + machineUnaryMatrixGeneratorNextColumn_semanticCode, hnextCurrent] + simp [unaryGridSemanticStep, hcolumn, + machineUnaryMatrixGeneratorSemanticCode, + unaryMatrixCurrent, unaryMatrixCompletedRows] + Β· simp [machineUnaryMatrixGeneratorStep, unaryGridSemanticStep, + machineUnaryMatrixGeneratorSemanticCode] + +theorem machineUnaryMatrixGeneratorInit_semanticCode {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) : + machineUnaryMatrixGeneratorInit + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + machineUnaryMatrixGeneratorSemanticCode f bound payload + (unaryGridSemanticInit hm) := by + rw [machineUnaryMatrixGeneratorInit, + machineUnaryMatrixGeneratorInputBound_encode] + simp [machineUnaryMatrixGeneratorSemanticCode, unaryGridSemanticInit, + machineUnaryMatrixGeneratorCanonicalWord, unaryMatrixCurrent, + unaryMatrixCompletedRows, binaryListCode] + +theorem machineUnaryMatrixGeneratorIterate_semanticCode {m : β„•} + (hm : 0 < m) (entry : List Bool β†’ List Bool) + (f : Fin m β†’ Fin m β†’ β„š) (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length) : βˆ€ k, + (machineUnaryMatrixGeneratorStep entry)^[k] + (machineUnaryMatrixGeneratorInit + (machineUnaryMatrixGeneratorCanonicalWord m bound payload)) = + machineUnaryMatrixGeneratorSemanticCode f bound payload + (unaryGridSemanticStateAt hm f k) := by + intro k + induction k with + | zero => exact machineUnaryMatrixGeneratorInit_semanticCode hm f bound payload + | succ k ih => + rw [Function.iterate_succ_apply', ih] + simpa only [unaryGridSemanticStateAt, + Function.iterate_succ_apply'] using! + machineUnaryMatrixGeneratorStep_semanticCode + entry f bound payload (unaryGridSemanticStateAt hm f k) + hentry hbound + +theorem unaryGridSemanticStateAt_full_done {m : β„•} + (hm : 0 < m) (f : Fin m β†’ Fin m β†’ β„š) : + (unaryGridSemanticStateAt hm f (m * m)).done = true := by + have hinvariant := unaryGridSemanticStateAt_valueInvariant hm f (m * m) + rcases hinvariant with hdone | hactive + Β· exact hdone.1 + Β· have hord := hactive.2.1 + have hlt := unaryGridOrdinal_lt_square + (unaryGridSemanticStateAt hm f (m * m)).row + (unaryGridSemanticStateAt hm f (m * m)).column + omega + +theorem machineUnaryMatrixGeneratorReversedRowsCode_encode_of_bound {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length) : + machineUnaryMatrixGeneratorReversedRowsCode entry + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f).reverse := by + cases m with + | zero => + rw [machineUnaryMatrixGeneratorReversedRowsCode, + machineUnaryMatrixGeneratorFinalState, + machineUnaryMatrixGeneratorRuler_encode] + simp [machineUnaryMatrixGeneratorInit, + machineUnaryMatrixGeneratorCanonicalWord, + unaryMatrixRows, binaryListCode] + | succ m => + have hm : 0 < m + 1 := by omega + rw [machineUnaryMatrixGeneratorReversedRowsCode, + machineUnaryMatrixGeneratorFinalState, + machineUnaryMatrixGeneratorRuler_encode, List.length_replicate, + machineUnaryMatrixGeneratorIterate_semanticCode hm entry f + bound payload hentry hbound ((m + 1) * (m + 1))] + simp only [machineUnaryMatrixGeneratorSemanticCode, + machineUnaryMatrixGeneratorRows_pack] + rw [unaryMatrixCompletedRows, + unaryGridSemanticStateAt_full_done hm f] + simp + +theorem machineUnaryMatrixGeneratorRowsCode_encode_of_bound {m : β„•} + (entry : List Bool β†’ List Bool) (f : Fin m β†’ Fin m β†’ β„š) + (bound payload : List Bool) + (hentry : βˆ€ i j, + entry (pair (List.replicate i.1 true) + (pair (List.replicate j.1 true) payload)) = + rationalEntryBinaryCode (f i j)) + (hbound : + (binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f)).length ≀ bound.length) : + machineUnaryMatrixGeneratorRowsCode entry + (machineUnaryMatrixGeneratorCanonicalWord m bound payload) = + binaryListCode (binaryListCode rationalEntryBinaryCode) + (unaryMatrixRows f) := by + rw [machineUnaryMatrixGeneratorRowsCode, + machineUnaryMatrixGeneratorReversedRowsCode_encode_of_bound + entry f bound payload hentry hbound, + machineListReverse_encode, List.reverse_reverse] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryRange.lean b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryRange.lean new file mode 100644 index 0000000000..efdb396fff --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MachineUnaryRange.lean @@ -0,0 +1,355 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineMateMemory +public import LeanPool.BeyondBethe.BeyondBethe.KuhnSmallStep + +/-! +# Constructing the unary column range + +The matching evaluator scans `List.finRange n`. This module constructs its +right-nested finite-word encoding from the unary dimension ruler. The +constructor counts down and prepends, so after `n` steps the values occur in +the required increasing order `0,1,...,n-1`. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Encodes a finite index as a ruler containing that many true bits. -/ +def finUnaryCode {n : β„•} (i : Fin n) : List Bool := + List.replicate i.1 true + +/-- Encodes the complete range of finite indices using unary codes in increasing order. -/ +def finRangeUnaryCode (n : β„•) : List Bool := + binaryListCode finUnaryCode (List.finRange n) + +/-- Packs the remaining unary countdown, accumulated encoded range, and bound. -/ +def machineUnaryRangePack + (remaining acc bound : List Bool) : List Bool := + pair remaining (pair acc bound) + +/-- Extracts the remaining countdown ruler from a unary-range state. -/ +def machineUnaryRangeRemaining (state : List Bool) : List Bool := + machinePairFirst state + +/-- Extracts the accumulated encoded index range from a unary-range state. -/ +def machineUnaryRangeAcc (state : List Bool) : List Bool := + machinePairFirst (machinePairSecond state) + +/-- Extracts the accumulator length-bound word from a unary-range state. -/ +def machineUnaryRangeBound (state : List Bool) : List Bool := + machinePairSecond (machinePairSecond state) + +/-- Prepends the predecessor countdown ruler to the accumulated range. -/ +def machineUnaryRangeCandidate (state : List Bool) : List Bool := + pair (machineUnaryRangeRemaining state).tail + (machineUnaryRangeAcc state) + +/-- Truncates the candidate range accumulator to the stored bound length. -/ +def machineUnaryRangeNextAcc (state : List Bool) : List Bool := + (machineUnaryRangeCandidate state).take + (machineUnaryRangeBound state).length + +/-- Fixes an exhausted countdown and otherwise decreases it while prepending the next bounded +range entry. -/ +def machineUnaryRangeStep (state : List Bool) : List Bool := + machineIfEmpty (machineUnaryRangeRemaining state) state + (machineUnaryRangePack (machineUnaryRangeRemaining state).tail + (machineUnaryRangeNextAcc state) (machineUnaryRangeBound state)) + +/-- Reuses the list-update input bound to bound unary-range generation. -/ +def machineUnaryRangeInputBound (ruler : List Bool) : List Bool := + machineListUpdateInputBound ruler + +/-- Initializes unary-range generation with the input countdown, empty accumulator, and computed +bound. -/ +def machineUnaryRangeInit (ruler : List Bool) : List Bool := + machineUnaryRangePack ruler [] (machineUnaryRangeInputBound ruler) + +/-- Packs three copies of the computed bound to bound the unary-range generation state. -/ +def machineUnaryRangeWidth (ruler : List Bool) : List Bool := + let bound := machineUnaryRangeInputBound ruler + machineUnaryRangePack bound bound bound + +/-- Runs unary-range generation once per bit of the input ruler. -/ +def machineUnaryRangeFinalState (ruler : List Bool) : List Bool := + (machineUnaryRangeStep)^[ruler.length] (machineUnaryRangeInit ruler) + +/-- Extracts the final encoded increasing index range. -/ +def machineUnaryRangeCode (ruler : List Bool) : List Bool := + machineUnaryRangeAcc (machineUnaryRangeFinalState ruler) + +theorem machineUnaryRangeRemaining_mem_FP : + machineUnaryRangeRemaining ∈ Complexity.FP := machinePairFirst_mem_FP + +theorem machineUnaryRangeAcc_mem_FP : + machineUnaryRangeAcc ∈ Complexity.FP := by + simpa only [machineUnaryRangeAcc] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairFirst_mem_FP + +theorem machineUnaryRangeBound_mem_FP : + machineUnaryRangeBound ∈ Complexity.FP := by + simpa only [machineUnaryRangeBound] using! + machineCompose_mem_FP machinePairSecond_mem_FP machinePairSecond_mem_FP + +theorem machineUnaryRangeCandidate_mem_FP : + machineUnaryRangeCandidate ∈ Complexity.FP := by + have hremainingTail := machineCompose_mem_FP + machineUnaryRangeRemaining_mem_FP machineTail_mem_FP + exact machinePair_mem_FP hremainingTail machineUnaryRangeAcc_mem_FP + +theorem machineUnaryRangeNextAcc_mem_FP : + machineUnaryRangeNextAcc ∈ Complexity.FP := by + simpa only [machineUnaryRangeNextAcc] using! + machineTake_mem_FP machineUnaryRangeBound_mem_FP + machineUnaryRangeCandidate_mem_FP + +theorem machineUnaryRangeStep_mem_FP : + machineUnaryRangeStep ∈ Complexity.FP := by + have hremainingTail := machineCompose_mem_FP + machineUnaryRangeRemaining_mem_FP machineTail_mem_FP + have hadvance := machinePair_mem_FP hremainingTail + (machinePair_mem_FP machineUnaryRangeNextAcc_mem_FP + machineUnaryRangeBound_mem_FP) + exact machineIfEmpty_mem_FP machineUnaryRangeRemaining_mem_FP id_mem_FP + hadvance + +theorem machineUnaryRangeInputBound_mem_FP : + machineUnaryRangeInputBound ∈ Complexity.FP := + machineListUpdateInputBound_mem_FP + +theorem machineUnaryRangeInit_mem_FP : + machineUnaryRangeInit ∈ Complexity.FP := by + exact machinePair_mem_FP id_mem_FP + (machinePair_mem_FP (machineConst_mem_FP []) + machineUnaryRangeInputBound_mem_FP) + +theorem machineUnaryRangeWidth_mem_FP : + machineUnaryRangeWidth ∈ Complexity.FP := by + exact machinePair_mem_FP machineUnaryRangeInputBound_mem_FP + (machinePair_mem_FP machineUnaryRangeInputBound_mem_FP + machineUnaryRangeInputBound_mem_FP) + +@[simp] theorem machineUnaryRangeRemaining_pack (a b c) : + machineUnaryRangeRemaining (machineUnaryRangePack a b c) = a := by + simp [machineUnaryRangeRemaining, machineUnaryRangePack] + +@[simp] theorem machineUnaryRangeAcc_pack (a b c) : + machineUnaryRangeAcc (machineUnaryRangePack a b c) = b := by + simp [machineUnaryRangeAcc, machineUnaryRangePack] + +@[simp] theorem machineUnaryRangeBound_pack (a b c) : + machineUnaryRangeBound (machineUnaryRangePack a b c) = c := by + simp [machineUnaryRangeBound, machineUnaryRangePack] + +/-- Requires exact unary-range state packing and bounds every field length by the input-derived +bound. -/ +def MachineUnaryRangeStateBound (ruler state : List Bool) : Prop := + let B := (machineUnaryRangeInputBound ruler).length + state = machineUnaryRangePack + (machineUnaryRangeRemaining state) + (machineUnaryRangeAcc state) + (machineUnaryRangeBound state) ∧ + (machineUnaryRangeRemaining state).length ≀ B ∧ + (machineUnaryRangeAcc state).length ≀ B ∧ + (machineUnaryRangeBound state).length ≀ B + +theorem machineUnaryRange_ruler_le_bound (ruler : List Bool) : + ruler.length ≀ (machineUnaryRangeInputBound ruler).length := by + simp only [machineUnaryRangeInputBound, machineListUpdateInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + nlinarith + +theorem machineUnaryRangeInit_bound (ruler : List Bool) : + MachineUnaryRangeStateBound ruler (machineUnaryRangeInit ruler) := by + simp only [MachineUnaryRangeStateBound, machineUnaryRangeInit, + machineUnaryRangeRemaining_pack, machineUnaryRangeAcc_pack, + machineUnaryRangeBound_pack] + exact ⟨trivial, machineUnaryRange_ruler_le_bound ruler, by simp, le_rfl⟩ + +theorem machineUnaryRangeStep_bound {ruler state : List Bool} + (hstate : MachineUnaryRangeStateBound ruler state) : + MachineUnaryRangeStateBound ruler (machineUnaryRangeStep state) := by + dsimp only [MachineUnaryRangeStateBound] at hstate ⊒ + rcases hstate with ⟨hpack, hremaining, hacc, hbound⟩ + cases hremainingEq : machineUnaryRangeRemaining state with + | nil => + rw [hremainingEq] at hpack hremaining + rw [machineUnaryRangeStep] + simp only [hremainingEq, machineIfEmpty_nil] + exact ⟨hpack, hremaining, hacc, hbound⟩ + | cons bit tail => + have htail : tail.length ≀ + (machineUnaryRangeInputBound ruler).length := by + rw [hremainingEq] at hremaining + simp only [List.length_cons] at hremaining + omega + rw [machineUnaryRangeStep] + simp only [hremainingEq, machineIfEmpty_cons, + machineUnaryRangeRemaining_pack, machineUnaryRangeAcc_pack, + machineUnaryRangeBound_pack] + refine ⟨trivial, htail, ?_, hbound⟩ + Β· simp only [machineUnaryRangeNextAcc, List.length_take] + exact (Nat.min_le_left _ _).trans hbound + +theorem machineUnaryRangeIterate_bound (ruler : List Bool) : βˆ€ k, + MachineUnaryRangeStateBound ruler + ((machineUnaryRangeStep)^[k] (machineUnaryRangeInit ruler)) := by + intro k + induction k with + | zero => simpa using! machineUnaryRangeInit_bound ruler + | succ k ih => + rw [Function.iterate_succ_apply'] + exact machineUnaryRangeStep_bound ih + +theorem machineUnaryRangeIterate_length_le_width + (ruler : List Bool) (iterations : β„•) + (_ : iterations ≀ ruler.length) : + ((machineUnaryRangeStep)^[iterations] + (machineUnaryRangeInit ruler)).length ≀ + (machineUnaryRangeWidth ruler).length := by + have hbound := machineUnaryRangeIterate_bound ruler iterations + dsimp only [MachineUnaryRangeStateBound] at hbound + rcases hbound with ⟨hpack, hremaining, hacc, hbound⟩ + rw [hpack] + simp only [machineUnaryRangePack, machineUnaryRangeWidth, pair_length] + omega + +theorem machineUnaryRangeFinalState_mem_FP : + machineUnaryRangeFinalState ∈ Complexity.FP := by + exact Cobham.iterate_mem_FP machineUnaryRangeStep_mem_FP + machineUnaryRangeInit_mem_FP id_mem_FP machineUnaryRangeWidth_mem_FP + machineUnaryRangeIterate_length_le_width + +theorem machineUnaryRangeCode_mem_FP : + machineUnaryRangeCode ∈ Complexity.FP := by + simpa only [machineUnaryRangeCode] using! + machineCompose_mem_FP machineUnaryRangeFinalState_mem_FP + machineUnaryRangeAcc_mem_FP + +/-! ## Exact semantics -/ + +/-- Encodes the remaining countdown `n - k` and the corresponding generated suffix of the finite +index range. -/ +def machineUnaryRangeSemanticState (n k : β„•) : List Bool := + machineUnaryRangePack (List.replicate (n - k) true) + (binaryListCode finUnaryCode ((List.finRange n).drop (n - k))) + (machineUnaryRangeInputBound (List.replicate n true)) + +theorem finRangeUnaryCode_length_le_bound (n : β„•) : + (finRangeUnaryCode n).length ≀ + (machineUnaryRangeInputBound (List.replicate n true)).length := by + rw [finRangeUnaryCode, binaryListCode_length_eq_sum] + have heach : βˆ€ i ∈ List.finRange n, + (finUnaryCode i).length ≀ n := by + intro i _ + simpa [finUnaryCode] using! i.isLt.le + have hsum : + ((List.finRange n).map fun i ↦ 2 * (finUnaryCode i).length + 2).sum ≀ + n * (2 * n + 2) := by + have h := List.sum_le_card_nsmul + ((List.finRange n).map fun i ↦ 2 * (finUnaryCode i).length + 2) + (2 * n + 2) (by + intro value hvalue + rw [List.mem_map] at hvalue + obtain ⟨i, hi, rfl⟩ := hvalue + have := heach i hi + omega) + simpa [List.length_finRange, Nat.nsmul_eq_mul] using! h + simp only [machineUnaryRangeInputBound, machineListUpdateInputBound, + machineBinaryMulWidth, List.length_replicate, List.length_append] + exact hsum.trans (by nlinarith) + +@[simp] theorem machineUnaryRangeSemanticState_zero (n : β„•) : + machineUnaryRangeSemanticState n 0 = + machineUnaryRangeInit (List.replicate n true) := by + rw [machineUnaryRangeSemanticState, machineUnaryRangeInit, + List.drop_eq_nil_of_le (by simp)] + rfl + +theorem machineUnaryRangeSemanticState_step (n k : β„•) (hk : k < n) : + machineUnaryRangeStep (machineUnaryRangeSemanticState n k) = + machineUnaryRangeSemanticState n (k + 1) := by + have hindex : n - k - 1 < (List.finRange n).length := by + simp only [List.length_finRange] + omega + have hdrop : + (List.finRange n).drop (n - k - 1) = + ⟨n - k - 1, by omega⟩ :: (List.finRange n).drop (n - k) := by + convert List.drop_eq_getElem_cons hindex using 1 <;> + simp [List.getElem_finRange] <;> omega + have hcandidateLength : + (pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode + ((List.finRange n).drop (n - k)))).length ≀ + (machineUnaryRangeInputBound (List.replicate n true)).length := by + rw [show pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode ((List.finRange n).drop (n - k))) = + binaryListCode finUnaryCode ((List.finRange n).drop (n - k - 1)) by + rw [hdrop] + rfl] + exact (binaryListCode_drop_length_le finUnaryCode (List.finRange n) + (n - k - 1)).trans (finRangeUnaryCode_length_le_bound n) + have hsub : n - k = (n - k - 1) + 1 := by omega + have htake : + (pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode + ((List.finRange n).drop (n - k)))).take + (machineUnaryRangeInputBound (List.replicate n true)).length = + pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode + ((List.finRange n).drop (n - k))) := + (List.take_eq_self_iff _).2 hcandidateLength + have htake' : + (pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode + ((List.finRange n).drop (n - k - 1 + 1)))).take + (machineUnaryRangeInputBound (List.replicate n true)).length = + pair (List.replicate (n - k - 1) true) + (binaryListCode finUnaryCode + ((List.finRange n).drop (n - k - 1 + 1))) := by + simpa only [← hsub] using! htake + have hnext : n - (k + 1) = n - k - 1 := by omega + rw [machineUnaryRangeSemanticState, hsub, List.replicate_succ, + machineUnaryRangeStep] + simp only [machineUnaryRangeSemanticState, + machineUnaryRangeRemaining_pack, machineIfEmpty_cons, + machineUnaryRangeAcc_pack, machineUnaryRangeBound_pack, + machineUnaryRangeNextAcc, machineUnaryRangeCandidate, + List.tail_cons, htake'] + unfold machineUnaryRangePack + apply congrArgβ‚‚ pair + Β· congr 1 + Β· apply congrArgβ‚‚ pair + Β· rw [hnext, hdrop] + rw [← hsub] + rfl + Β· rfl + +theorem machineUnaryRangeIterate_semantics (n k : β„•) (hk : k ≀ n) : + (machineUnaryRangeStep)^[k] + (machineUnaryRangeInit (List.replicate n true)) = + machineUnaryRangeSemanticState n k := by + induction k with + | zero => exact (machineUnaryRangeSemanticState_zero n).symm + | succ k ih => + rw [Function.iterate_succ_apply', ih (by omega), + machineUnaryRangeSemanticState_step n k (by omega)] + +@[simp] theorem machineUnaryRangeCode_encode (n : β„•) : + machineUnaryRangeCode (List.replicate n true) = finRangeUnaryCode n := by + rw [machineUnaryRangeCode, machineUnaryRangeFinalState, + List.length_replicate, machineUnaryRangeIterate_semantics n n le_rfl, + machineUnaryRangeSemanticState, machineUnaryRangeAcc_pack] + simp [finRangeUnaryCode] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Main.lean b/LeanPool/BeyondBethe/BeyondBethe/Main.lean new file mode 100644 index 0000000000..7235502cfc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Main.lean @@ -0,0 +1,262 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.FinalAssembly +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitPositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScales +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiList +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableReindex +public import LeanPool.BeyondBethe.BeyondBethe.MachineCompletedAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachinePositiveAlgorithm +public import LeanPool.BeyondBethe.BeyondBethe.MachineOptimizerCertificateBoundary +public import LeanPool.BeyondBethe.BeyondBethe.MachineExplicitCertificate +public import LeanPool.BeyondBethe.BeyondBethe.ExecutablePositiveRoutine +public import LeanPool.BeyondBethe.BeyondBethe.MachineExecutablePositiveAlgorithm + +/-! # Main -/ + +@[expose] public section + +namespace BeyondBethe + +/-- A faithful algorithmic statement of Theorem 1 contains both the +two-sided approximation guarantee and a concrete Turing-machine +polynomial-time claim. -/ +structure TheoremOneSpec where + /-- The approximation base, certified positive and strictly below `sqrt 2` by `guarantee`. -/ + c : ℝ + /-- The dimension-uniform rational matrix algorithm whose output approximates the permanent + within the certified factor `c^n`. -/ + alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š + guarantee : ApproximationGuarantee alg c + polynomialTime : RunsInPolynomialTime alg + +/-- The internally reconstructed source theorems imply the exact +positive-matrix certificate used by the numerical layer. -/ +theorem exists_exactPositiveCertificate : + βˆƒ Ξ΅ : ℝ, 0 < Ξ΅ ∧ ExactPositiveCertificate Ξ΅ := by + simpa only [ExactPositiveCertificate] using + exists_absolute_positiveMatrix_logApproximation + anariOveisGharanStableCoefficient + +/-- The one fixed rational algorithm used in the final theorem. -/ +def explicitTheoremOneAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š := + completedAlgorithm explicitCertifiedPositiveRoutine + (canonicalSmoothingParameter explicitCertifiedEpsilon) + +theorem explicitCertifiedEpsilon_le_quarter : + explicitCertifiedEpsilon ≀ (1 / 4 : β„š) := by + rw [explicitCertifiedEpsilon, explicitCertifiedEpsilon_eq] + have hΞ΄ : explicitDelta ≀ (1 / 200000 : β„š) := by + have hcast := explicitDelta_le_rowRatio + have hcast' : (explicitDelta : ℝ) ≀ ((1 / 200000 : β„š) : ℝ) := by + norm_num [explicitRowRatio] at hcast ⊒ + exact hcast + exact Rat.cast_le.mp hcast' + calc + explicitDelta - explicitXi ≀ explicitDelta := + sub_le_self _ explicitXi_pos.le + _ ≀ 1 / 200000 := hΞ΄ + _ ≀ 1 / 4 := by norm_num + +/-- The mathematical approximation guarantee of the fixed algorithm is +unconditional; no numerical-oracle interface remains in this statement. -/ +theorem explicitTheoremOneAlgorithm_guarantee : + ApproximationGuarantee explicitTheoremOneAlgorithm + (finalBase (explicitCertifiedEpsilon : ℝ)) := by + have hΞ΅q : 0 < explicitCertifiedEpsilon := explicitCertifiedEpsilon_pos + have hΞ΅ : 0 < (explicitCertifiedEpsilon : ℝ) := by + exact_mod_cast hΞ΅q + have hquarter : (explicitCertifiedEpsilon : ℝ) ≀ 1 / 4 := by + have hcast : (explicitCertifiedEpsilon : ℝ) ≀ ((1 / 4 : β„š) : ℝ) := by + exact_mod_cast explicitCertifiedEpsilon_le_quarter + norm_num at hcast ⊒ + exact hcast + have hΞ΅bound : (explicitCertifiedEpsilon : ℝ) ≀ Real.log 2 / 2 := by + nlinarith [Real.one_sub_inv_le_log_of_pos + (by norm_num : (0 : ℝ) < 2)] + refine ⟨finalBase_pos _, finalBase_lt_sqrtTwo hΞ΅, ?_⟩ + simpa only [explicitTheoremOneAlgorithm] using + completedAlgorithm_guarantee hΞ΅ hΞ΅bound + explicitCertifiedPositiveRoutine + (canonicalSmoothingParameter explicitCertifiedEpsilon) + (canonicalSmoothingParameter_pos hΞ΅q) + (canonicalSmoothingParameter_le_half hΞ΅q) + +theorem explicitTheoremOneAlgorithm_runsInPolynomialTime_of_rawPositiveMachine + {positiveMachine : List Bool β†’ List Bool} + (hpositiveFP : positiveMachine ∈ Complexity.FP) + (hrealizes : RawStringRealizes positiveMachine + explicitCertifiedPositiveRoutine.alg) : + RunsInPolynomialTime explicitTheoremOneAlgorithm := by + simpa only [explicitTheoremOneAlgorithm] using + completedAlgorithm_runsInPolynomialTime_of_rawMachine + explicitCertifiedPositiveRoutine hpositiveFP hrealizes + (canonicalSmoothingParameter explicitCertifiedEpsilon) + +theorem explicitTheoremOneAlgorithm_runsInPolynomialTime_of_positive_rawMachine + {positiveMachine : List Bool β†’ List Bool} + (hpositiveFP : positiveMachine ∈ Complexity.FP) + (hrealizes : PositiveRawStringRealizes positiveMachine + explicitCertifiedPositiveRoutine.alg) : + RunsInPolynomialTime explicitTheoremOneAlgorithm := by + simpa only [explicitTheoremOneAlgorithm] using + completedAlgorithm_runsInPolynomialTime_of_positive_rawMachine + explicitCertifiedPositiveRoutine hpositiveFP hrealizes + (canonicalSmoothingParameter explicitCertifiedEpsilon) + (canonicalSmoothingParameter_pos explicitCertifiedEpsilon_pos) + +/-- Compatibility statement for the earlier semantic optimizer: a raw-machine +proof for that particular tie-breaking choice still yields Theorem 1. -/ +theorem theoremOne_of_explicitPolynomialTime + (polynomialTime : RunsInPolynomialTime explicitTheoremOneAlgorithm) : + Nonempty TheoremOneSpec := by + exact ⟨ + { c := finalBase (explicitCertifiedEpsilon : ℝ) + alg := explicitTheoremOneAlgorithm + guarantee := explicitTheoremOneAlgorithm_guarantee + polynomialTime := polynomialTime }⟩ + +theorem theoremOne_of_normalizedCertificateMachine + {certificateMachine : List Bool β†’ List Bool} + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hrealizes : RawStringRealizes certificateMachine + explicitNormalizedCertificateAlgorithm) : + Nonempty TheoremOneSpec := by + let positiveMachine := machinePositiveAlgorithmRawCode certificateMachine + have hpositiveFP : positiveMachine ∈ Complexity.FP := + machinePositiveAlgorithmRawCode_mem_FP hcertificateFP + have hpositiveRealizes : + RawStringRealizes positiveMachine explicitPositiveAlgorithm := + machinePositiveAlgorithmRawCode_realizes hrealizes + exact theoremOne_of_explicitPolynomialTime + (explicitTheoremOneAlgorithm_runsInPolynomialTime_of_rawPositiveMachine + hpositiveFP hpositiveRealizes) + +theorem theoremOne_of_normalizedCertificateMachine_onPositive + {certificateMachine : List Bool β†’ List Bool} + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hrealizes : + NormalizedCertificateStringRealizesOnPositive certificateMachine) : + Nonempty TheoremOneSpec := by + let positiveMachine := machinePositiveAlgorithmRawCode certificateMachine + have hpositiveFP : positiveMachine ∈ Complexity.FP := + machinePositiveAlgorithmRawCode_mem_FP hcertificateFP + have hpositiveRealizes : + PositiveRawStringRealizes positiveMachine explicitPositiveAlgorithm := + machinePositiveAlgorithmRawCode_realizes_onPositive hrealizes + exact theoremOne_of_explicitPolynomialTime + (explicitTheoremOneAlgorithm_runsInPolynomialTime_of_positive_rawMachine + hpositiveFP hpositiveRealizes) + +/-- Machine-checked Theorem 1 from separate finite-word implementations of +the normalized optimizer and the directed certificate evaluator. -/ +theorem theoremOne_of_optimizer_and_certificate_machines + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizerFP : optimizerMachine ∈ Complexity.FP) + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hcertificate : CertificateEvaluatorStringRealizes certificateMachine) : + Nonempty TheoremOneSpec := by + let normalizedMachine := machineNormalizedCertificateFromParts + optimizerMachine certificateMachine + have hnormalizedFP : normalizedMachine ∈ Complexity.FP := + machineNormalizedCertificateFromParts_mem_FP + hoptimizerFP hcertificateFP + have hnormalizedRealizes : RawStringRealizes normalizedMachine + explicitNormalizedCertificateAlgorithm := + machineNormalizedCertificateFromParts_realizes + hoptimizer hcertificate + exact theoremOne_of_normalizedCertificateMachine + hnormalizedFP hnormalizedRealizes + +/-- Machine-checked Theorem 1 from machines whose certificate contract is +restricted to the positive normalized inputs used by the algorithm. -/ +theorem theoremOne_of_optimizer_and_certificate_machines_onPositive + {optimizerMachine certificateMachine : List Bool β†’ List Bool} + (hoptimizerFP : optimizerMachine ∈ Complexity.FP) + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) + (hcertificateFP : certificateMachine ∈ Complexity.FP) + (hcertificate : + CertificateEvaluatorStringRealizesOnPositiveNormalized certificateMachine) : + Nonempty TheoremOneSpec := by + let normalizedMachine := machineNormalizedCertificateFromParts + optimizerMachine certificateMachine + have hnormalizedFP : normalizedMachine ∈ Complexity.FP := + machineNormalizedCertificateFromParts_mem_FP + hoptimizerFP hcertificateFP + have hnormalizedRealizes : + NormalizedCertificateStringRealizesOnPositive normalizedMachine := + machineNormalizedCertificateFromParts_realizes_onPositive + hoptimizer hcertificate + exact theoremOne_of_normalizedCertificateMachine_onPositive + hnormalizedFP hnormalizedRealizes + +/-- Legacy modular assembly theorem for replacing the semantic optimizer by +any finite-word implementation satisfying the older exact-output contract. -/ +theorem theoremOne_of_optimizerMachine + {optimizerMachine : List Bool β†’ List Bool} + (hoptimizerFP : optimizerMachine ∈ Complexity.FP) + (hoptimizer : LargeOptimizerStringRealizes optimizerMachine) : + Nonempty TheoremOneSpec := by + exact theoremOne_of_optimizer_and_certificate_machines_onPositive + hoptimizerFP hoptimizer + machineExplicitCertificateValueRawCode_mem_FP + machineExplicitCertificateValueRawCode_realizes_onPositive + +/-! ## Unconditional executable Theorem 1 -/ + +/-- The completed rational algorithm using the verified row-major optimizer. -/ +def executableTheoremOneAlgorithm : + βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š := + completedAlgorithm executableCertifiedPositiveRoutine + (canonicalSmoothingParameter explicitCertifiedEpsilon) + +theorem executableTheoremOneAlgorithm_guarantee : + ApproximationGuarantee executableTheoremOneAlgorithm + (finalBase (explicitCertifiedEpsilon : ℝ)) := by + have hΞ΅q : 0 < explicitCertifiedEpsilon := explicitCertifiedEpsilon_pos + have hΞ΅ : 0 < (explicitCertifiedEpsilon : ℝ) := by + exact_mod_cast hΞ΅q + have hΞ΅bound : (explicitCertifiedEpsilon : ℝ) ≀ Real.log 2 / 2 := by + have hquarter : (explicitCertifiedEpsilon : ℝ) ≀ 1 / 4 := by + have hcast : (explicitCertifiedEpsilon : ℝ) ≀ ((1 / 4 : β„š) : ℝ) := by + exact_mod_cast explicitCertifiedEpsilon_le_quarter + norm_num at hcast ⊒ + exact hcast + nlinarith [Real.one_sub_inv_le_log_of_pos + (by norm_num : (0 : ℝ) < 2)] + refine ⟨finalBase_pos _, finalBase_lt_sqrtTwo hΞ΅, ?_⟩ + simpa only [executableTheoremOneAlgorithm] using + completedAlgorithm_guarantee hΞ΅ hΞ΅bound + executableCertifiedPositiveRoutine + (canonicalSmoothingParameter explicitCertifiedEpsilon) + (canonicalSmoothingParameter_pos hΞ΅q) + (canonicalSmoothingParameter_le_half hΞ΅q) + +theorem executableTheoremOneAlgorithm_runsInPolynomialTime : + RunsInPolynomialTime executableTheoremOneAlgorithm := by + simpa only [executableTheoremOneAlgorithm] using + completedAlgorithm_runsInPolynomialTime_of_positive_rawMachine + executableCertifiedPositiveRoutine + machineExecutablePositiveAlgorithmRawCode_mem_FP + machineExecutablePositiveAlgorithmRawCode_realizes_onPositive + (canonicalSmoothingParameter explicitCertifiedEpsilon) + (canonicalSmoothingParameter_pos explicitCertifiedEpsilon_pos) + +/-- Fully machine-checked Theorem 1. Both the approximation guarantee and the +ordinary finite-word polynomial-time implementation are constructed here. -/ +theorem theoremOne : Nonempty TheoremOneSpec := by + exact ⟨ + { c := finalBase (explicitCertifiedEpsilon : ℝ) + alg := executableTheoremOneAlgorithm + guarantee := executableTheoremOneAlgorithm_guarantee + polynomialTime := executableTheoremOneAlgorithm_runsInPolynomialTime }⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MatchingAlgorithm.lean b/LeanPool/BeyondBethe/BeyondBethe/MatchingAlgorithm.lean new file mode 100644 index 0000000000..5ad4289dd1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MatchingAlgorithm.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import Mathlib.Tactic + +/-! # Matching Algorithm -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Executable support matching + +This first executable decision procedure is the finite reference +specification. A polynomial augmenting-path implementation will be proved +extensionally equal to it below; the wrapper can therefore remain independent +of propositional decidability throughout that refinement. +-/ + +/-- Decides whether the matrix support contains a permutation selecting a nonzero entry in every +column. -/ +def supportMatchingDecision {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : Bool := + decide (βˆƒ Οƒ : Equiv.Perm (Fin n), βˆ€ i, A (Οƒ i) i β‰  0) + +theorem supportMatchingDecision_eq_true_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + supportMatchingDecision A = true ↔ Matrix.HasPerfectMatching A := by + simp [supportMatchingDecision, Matrix.HasPerfectMatching] + +theorem supportMatchingDecision_eq_false_iff {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + supportMatchingDecision A = false ↔ Β¬Matrix.HasPerfectMatching A := by + simp [supportMatchingDecision, Matrix.HasPerfectMatching] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/MatrixPerturbation.lean b/LeanPool/BeyondBethe/BeyondBethe/MatrixPerturbation.lean new file mode 100644 index 0000000000..b46fb941b3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/MatrixPerturbation.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DyadicRounding +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Algebra.Order.BigOperators.Ring.Finset +public import Mathlib.LinearAlgebra.Matrix.Adjugate +public import Mathlib.Tactic + +/-! # Matrix Perturbation -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Entrywise perturbation bounds for finite matrices + +These estimates are intentionally elementary. They expand the determinant +as a finite signed sum and bound each product by induction. This avoids +appealing to an unformalized operator-norm or numerical linear-algebra result +in the rounded ellipsoid proof. +-/ + +theorem abs_finset_prod_le_pow {ΞΉ : Type*} {s : Finset ΞΉ} + (f : ΞΉ β†’ ℝ) {M : ℝ} (hM : 0 ≀ M) + (hf : βˆ€ i ∈ s, abs (f i) ≀ M) : + abs (∏ i ∈ s, f i) ≀ M ^ s.card := by + classical + rw [Finset.abs_prod] + simpa using Finset.prod_le_prodβ‚€ (fun _ _ ↦ abs_nonneg _) + (fun i hi ↦ hf i hi) + +/-- A deliberately coarse but uniform product perturbation estimate. The +extra factor `M` in the usual sharp estimate is harmless here and makes the +induction valid without a separate zero-cardinality case in the exponent. -/ +theorem abs_finset_prod_sub_prod_le {ΞΉ : Type*} {s : Finset ΞΉ} + (f g : ΞΉ β†’ ℝ) {M Ξ΄ : ℝ} (hM : 1 ≀ M) (hΞ΄ : 0 ≀ Ξ΄) + (hf : βˆ€ i ∈ s, abs (f i) ≀ M) + (hg : βˆ€ i ∈ s, abs (g i) ≀ M) + (hfg : βˆ€ i ∈ s, abs (f i - g i) ≀ Ξ΄) : + abs ((∏ i ∈ s, f i) - ∏ i ∈ s, g i) ≀ + s.card * Ξ΄ * M ^ s.card := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => + have hM0 : 0 ≀ M := le_trans (by norm_num) hM + have hpow0 : 0 ≀ M ^ s.card := pow_nonneg hM0 _ + have hprodF : abs (∏ i ∈ s, f i) ≀ M ^ s.card := + abs_finset_prod_le_pow f hM0 (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi)) + have hih : abs ((∏ i ∈ s, f i) - ∏ i ∈ s, g i) ≀ + s.card * Ξ΄ * M ^ s.card := + ih (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi)) + (fun i hi ↦ hg i (Finset.mem_insert_of_mem hi)) + (fun i hi ↦ hfg i (Finset.mem_insert_of_mem hi)) + have hfirst : + abs ((f a - g a) * ∏ i ∈ s, f i) ≀ Ξ΄ * M ^ s.card := by + rw [abs_mul] + exact mul_le_mul (hfg a (Finset.mem_insert_self a s)) hprodF + (abs_nonneg _) hΞ΄ + have hsecond : + abs (g a * ((∏ i ∈ s, f i) - ∏ i ∈ s, g i)) ≀ + M * (s.card * Ξ΄ * M ^ s.card) := by + rw [abs_mul] + exact mul_le_mul (hg a (Finset.mem_insert_self a s)) hih + (abs_nonneg _) hM0 + have hpowStep : M ^ s.card ≀ M ^ (s.card + 1) := by + rw [pow_succ] + exact le_mul_of_one_le_right hpow0 hM + rw [Finset.prod_insert ha, Finset.prod_insert ha, + Finset.card_insert_of_notMem ha] + have hdecomp : + f a * ∏ i ∈ s, f i - g a * ∏ i ∈ s, g i = + (f a - g a) * ∏ i ∈ s, f i + + g a * ((∏ i ∈ s, f i) - ∏ i ∈ s, g i) := by ring + rw [hdecomp] + calc + abs ((f a - g a) * ∏ i ∈ s, f i + + g a * ((∏ i ∈ s, f i) - ∏ i ∈ s, g i)) ≀ + abs ((f a - g a) * ∏ i ∈ s, f i) + + abs (g a * ((∏ i ∈ s, f i) - ∏ i ∈ s, g i)) := + abs_add_le _ _ + _ ≀ Ξ΄ * M ^ s.card + M * (s.card * Ξ΄ * M ^ s.card) := + add_le_add hfirst hsecond + _ ≀ Ξ΄ * M ^ (s.card + 1) + + M * (s.card * Ξ΄ * M ^ s.card) := by + gcongr + _ = ((s.card + 1 : β„•) : ℝ) * Ξ΄ * M ^ (s.card + 1) := by + push_cast + rw [pow_succ] + ring + +/-- Entrywise perturbation bound for determinants. -/ +theorem abs_det_sub_det_le_of_entrywise {d : β„•} + (A B : Matrix (Fin d) (Fin d) ℝ) {M Ξ΄ : ℝ} + (hM : 1 ≀ M) (hΞ΄ : 0 ≀ Ξ΄) + (hA : βˆ€ i j, abs (A i j) ≀ M) + (hB : βˆ€ i j, abs (B i j) ≀ M) + (hAB : βˆ€ i j, abs (A i j - B i j) ≀ Ξ΄) : + abs (Matrix.det A - Matrix.det B) ≀ + d.factorial * (d * Ξ΄ * M ^ d) := by + rw [Matrix.det_apply, Matrix.det_apply, ← Finset.sum_sub_distrib] + calc + abs (βˆ‘ Οƒ : Equiv.Perm (Fin d), + (Οƒ.sign β€’ ∏ i, A (Οƒ i) i - Οƒ.sign β€’ ∏ i, B (Οƒ i) i)) ≀ + βˆ‘ Οƒ : Equiv.Perm (Fin d), + abs (Οƒ.sign β€’ ∏ i, A (Οƒ i) i - + Οƒ.sign β€’ ∏ i, B (Οƒ i) i) := Finset.abs_sum_le_sum_abs _ _ + _ ≀ βˆ‘ _Οƒ : Equiv.Perm (Fin d), d * Ξ΄ * M ^ d := by + apply Finset.sum_le_sum + intro Οƒ _ + rw [← smul_sub] + change (AbsoluteValue.abs : AbsoluteValue ℝ ℝ) + (Οƒ.sign β€’ ((∏ i, A (Οƒ i) i) - ∏ i, B (Οƒ i) i)) ≀ _ + rw [(AbsoluteValue.abs : AbsoluteValue ℝ ℝ).map_units_int_smul] + simpa [AbsoluteValue.abs, Fintype.card_fin] using + (abs_finset_prod_sub_prod_le + (s := (Finset.univ : Finset (Fin d))) + (fun i ↦ A (Οƒ i) i) (fun i ↦ B (Οƒ i) i) + hM hΞ΄ (fun i _ ↦ hA _ _) (fun i _ ↦ hB _ _) + (fun i _ ↦ hAB _ _)) + _ = d.factorial * (d * Ξ΄ * M ^ d) := by + simp [Fintype.card_perm] + +/-- The standard determinant bound, specialized to real square matrices. -/ +theorem abs_det_le_of_entrywise {d : β„•} + (A : Matrix (Fin d) (Fin d) ℝ) {M : ℝ} + (hA : βˆ€ i j, abs (A i j) ≀ M) : + abs (Matrix.det A) ≀ d.factorial * M ^ d := by + simpa [Fintype.card_fin, nsmul_eq_mul] using + (Matrix.det_le (abv := (AbsoluteValue.abs : AbsoluteValue ℝ ℝ)) + (A := A) (x := M) hA) + +/-- Determinant error caused by flooring every entry of a rational matrix to +one dyadic grid. The estimate is stated after casting to `ℝ`, exactly as it +is consumed by the ellipsoid volume proof. -/ +theorem abs_det_dyadicFloorMatrix_sub_det_le {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) {M : ℝ} + (hM : 1 ≀ M) (hA : βˆ€ i j, abs ((A i j : β„š) : ℝ) ≀ M) : + abs (Matrix.det (fun i j ↦ ((dyadicFloorMatrix p A i j : β„š) : ℝ)) - + Matrix.det (fun i j ↦ ((A i j : β„š) : ℝ))) ≀ + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * M) ^ d) := by + have hmesh0 : (0 : ℝ) ≀ (dyadicMesh p : ℝ) := by + exact_mod_cast dyadicMesh_nonneg p + have hmesh1 : (dyadicMesh p : ℝ) ≀ 1 := by + exact_mod_cast dyadicMesh_le_one p + have htwoM : (1 : ℝ) ≀ 2 * M := by linarith + apply abs_det_sub_det_le_of_entrywise _ _ htwoM hmesh0 + Β· intro i j + exact (abs_cast_dyadicFloorMatrix_le p A i j).le.trans + (by linarith [hA i j]) + Β· intro i j + exact (hA i j).trans (by linarith) + Β· intro i j + have h := cast_dyadicFloorMatrix_entry_error_lt p A i j + simpa only [Rat.cast_sub] using h.le + +/-- A determinant margin larger than the explicit rounding loss guarantees +that the rounded rational matrix remains nonsingular. -/ +theorem det_dyadicFloorMatrix_ne_zero_of_margin {d : β„•} + (p : β„•) (A : Matrix (Fin d) (Fin d) β„š) {M : ℝ} + (hM : 1 ≀ M) (hA : βˆ€ i j, abs ((A i j : β„š) : ℝ) ≀ M) + (hmargin : d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * M) ^ d) < + abs ((Matrix.det A : β„š) : ℝ)) : + Matrix.det (dyadicFloorMatrix p A) β‰  0 := by + intro hzero + have hpert := abs_det_dyadicFloorMatrix_sub_det_le p A hM hA + have hcastRound : + Matrix.det (fun i j ↦ ((dyadicFloorMatrix p A i j : β„š) : ℝ)) = 0 := by + rw [show (fun i j ↦ ((dyadicFloorMatrix p A i j : β„š) : ℝ)) = + (dyadicFloorMatrix p A).map (fun q : β„š ↦ (q : ℝ)) by rfl, + ← Rat.cast_det, hzero] + simp + have hcastA : + Matrix.det (fun i j ↦ ((A i j : β„š) : ℝ)) = + ((Matrix.det A : β„š) : ℝ) := by + rw [show (fun i j ↦ ((A i j : β„š) : ℝ)) = + A.map (fun q : β„š ↦ (q : ℝ)) by rfl, Rat.cast_det] + rw [hcastRound, hcastA, zero_sub, abs_neg] at hpert + exact (not_lt_of_ge hpert) hmargin + +theorem abs_adjugate_entry_le_of_entrywise {d : β„•} + (A : Matrix (Fin d) (Fin d) ℝ) {M : ℝ} (hM : 1 ≀ M) + (hA : βˆ€ i j, abs (A i j) ≀ M) (i j : Fin d) : + abs (A.adjugate i j) ≀ d.factorial * M ^ d := by + have hM0 : 0 ≀ M := by linarith + rw [Matrix.adjugate_apply] + apply abs_det_le_of_entrywise + intro k l + by_cases hkj : k = j + Β· subst k + by_cases hil : i = l + Β· subst l + simp [hM] + Β· simp [Matrix.updateRow_apply, hil, hM0] + Β· rw [Matrix.updateRow_apply, ite_eq_right hkj] + exact hA k l + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NearCase.lean b/LeanPool/BeyondBethe/BeyondBethe/NearCase.lean new file mode 100644 index 0000000000..666eb1e575 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NearCase.lean @@ -0,0 +1,1657 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CycleTransfer +public import LeanPool.BeyondBethe.BeyondBethe.CleanConstants +public import LeanPool.BeyondBethe.BeyondBethe.Completion +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.SourceBetheUpper +public import Mathlib.Data.Finset.Sort +public import Mathlib.Tactic + +/-! # Near Case -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The actual clean two-row factors of the alternating permutation. -/ +noncomputable def cleanCycleFactors + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) : Finset h.cycleFactorsFinset := by + classical + exact Finset.univ.filter fun c ↦ + (c : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c = 2 + +theorem cleanCycleFactors_card + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) : + (cleanCycleFactors Ξ· P h).card = cleanCycleCount Ξ· P h := by + classical + rw [cleanCycleCount] + calc + (cleanCycleFactors Ξ· P h).card = + βˆ‘ c : h.cycleFactorsFinset, + if (c : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c = 2 then 1 else 0 := by + simp [cleanCycleFactors] + _ = βˆ‘ c : h.cycleFactorsFinset, cleanCycleIndicator Ξ· P h c := by + apply Finset.sum_congr rfl + intro c _ + rfl + +theorem cleanCycleFactor_property + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) : + (c.1 : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c.1 = 2 := by + have hc := c.2 + change c.1 ∈ Finset.univ.filter (fun d : h.cycleFactorsFinset ↦ + (d : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h d = 2) at hc + exact (Finset.mem_filter.mp hc).2 + +/-- The two rows of a clean factor, in the ambient linear order. -/ +noncomputable def cleanCycleRow + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) : + Fin 2 β†’ Fin n := fun k ↦ + ((c.1 : Equiv.Perm (Fin n)).support.orderIsoOfFin + (cleanCycleFactor_property c).1 k).1 + +theorem cleanCycleRow_mem_support + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) (k : Fin 2) : + cleanCycleRow c k ∈ (c.1 : Equiv.Perm (Fin n)).support := by + exact ((c.1 : Equiv.Perm (Fin n)).support.orderIsoOfFin + (cleanCycleFactor_property c).1 k).2 + +theorem cleanCycleRow_injective + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) : + Function.Injective (cleanCycleRow c) := by + intro k l hkl + apply ((c.1 : Equiv.Perm (Fin n)).support.orderIsoOfFin + (cleanCycleFactor_property c).1).injective + exact Subtype.ext hkl + +theorem cleanCycleRows_ne + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) : + cleanCycleRow c 0 β‰  cleanCycleRow c 1 := by + intro hrs + have := cleanCycleRow_injective c hrs + norm_num at this + +theorem cleanCycleRow_mem_goodRows + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {h : Equiv.Perm (Fin n)} (c : cleanCycleFactors Ξ· P h) (k : Fin 2) : + cleanCycleRow c k ∈ goodRows Ξ· P := by + have hcard := cleanCycleFactor_property c + have hinter : + (c.1 : Equiv.Perm (Fin n)).support ∩ goodRows Ξ· P = + (c.1 : Equiv.Perm (Fin n)).support := by + apply Finset.eq_of_subset_of_card_le Finset.inter_subset_left + rw [hcard.1] + simpa [cycleGoodCount] using hcard.2.symm.le + have hmem := cleanCycleRow_mem_support c k + rw [← hinter] at hmem + exact (Finset.mem_inter.mp hmem).2 + +/-- On a two-row alternating component, the two perfect matchings cross: +the unordered pair of core columns is the same at both rows. -/ +theorem cleanCycle_core_columns + {n : β„•} {f g : Equiv.Perm (Fin n)} + {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : + let r := cleanCycleRow c 0 + let s := cleanCycleRow c 1 + r β‰  s ∧ f r β‰  g r ∧ f r = g s ∧ g r = f s := by + let h := alternatingRowPerm f g + let q : Equiv.Perm (Fin n) := c.1 + let r := cleanCycleRow c 0 + let s := cleanCycleRow c 1 + have hrs : r β‰  s := cleanCycleRows_ne c + have hrq : r ∈ q.support := cleanCycleRow_mem_support c 0 + have hsq : s ∈ q.support := cleanCycleRow_mem_support c 1 + have hpair : q.support = {r, s} := by + symm + apply Finset.eq_of_subset_of_card_le + Β· intro i hi + simp only [Finset.mem_insert, Finset.mem_singleton] at hi + rcases hi with rfl | rfl + Β· exact hrq + Β· exact hsq + Β· have hqcard : q.support.card = 2 := (cleanCycleFactor_property c).1 + simpa [hrs, hqcard] + have hqr_ne : q r β‰  r := Equiv.Perm.mem_support.mp hrq + have hqs_ne : q s β‰  s := Equiv.Perm.mem_support.mp hsq + have hqr_mem : q r ∈ q.support := by + rw [Equiv.Perm.mem_support] + exact mt q.injective.eq_iff.mp hqr_ne + have hqs_mem : q s ∈ q.support := by + rw [Equiv.Perm.mem_support] + exact mt q.injective.eq_iff.mp hqs_ne + have hqr : q r = s := by + rw [hpair] at hqr_mem + simp only [Finset.mem_insert, Finset.mem_singleton] at hqr_mem + exact hqr_mem.resolve_left hqr_ne + have hqs : q s = r := by + rw [hpair] at hqs_mem + simp only [Finset.mem_insert, Finset.mem_singleton] at hqs_mem + exact hqs_mem.resolve_right hqs_ne + have hfactor := Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.1.2 + have hhr : h r = s := by + rw [← hfactor.2 r hrq, hqr] + have hhs : h s = r := by + rw [← hfactor.2 s hsq, hqs] + have hfrgs : f r = g s := by + have := congrArg g hhr + simpa [h, alternatingRowPerm] using this + have hgrfs : g r = f s := by + have := congrArg g hhs + simpa [h, alternatingRowPerm] using this.symm + have hfg : f r β‰  g r := by + intro heq + have hfix : h r = r := (alternatingRowPerm_fixed_iff f g r).2 heq + exact hrs (hfix.symm.trans hhr) + exact ⟨hrs, hfg, hfrgs, hgrfs⟩ + +theorem twoMatching_core_mem_heavy_of_good + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + {i : Fin n} (hgood : IsGoodRow Ξ· (P i)) : + f i ∈ heavyCoordinates Ξ· (P i) ∧ + g i ∈ heavyCoordinates Ξ· (P i) ∧ f i β‰  g i := by + obtain ⟨a, b, hab, hdist⟩ := hgood + have hcore := goodRow_witness_mem_heavyCoordinates + (hP i).probability hab hdist + have ha := hheavy i a hcore.1 + have hb := hheavy i b hcore.2 + rcases ha with haf | hag <;> rcases hb with hbf | hbg + Β· exact False.elim (hab (haf.trans hbf.symm)) + Β· subst a + subst b + exact ⟨hcore.1, hcore.2, hab⟩ + Β· subst a + subst b + exact ⟨hcore.2, hcore.1, hab.symm⟩ + Β· exact False.elim (hab (hag.trans hbg.symm)) + +theorem univ_sdiff_coreOutside_of_ne + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) : + Finset.univ \ coreOutside a b = {a, b} := by + ext j + simp only [Finset.mem_sdiff, Finset.mem_univ, coreOutside, + Finset.mem_filter, true_and, Finset.mem_insert, Finset.mem_singleton] + tauto + +/-- Computes row `i`'s transfer cost on the two columns selected by `f` and `g`, using the +complement of their outside set. -/ +noncomputable def encodedCoreRowTransferCost + {n : β„•} (f g : Equiv.Perm (Fin n)) + (P U : Matrix (Fin n) (Fin n) ℝ) (i : Fin n) : ℝ := + transferCostOn (Finset.univ \ coreOutside (f i) (g i)) (P i) (U i) + +/-- Sums the encoded row-transfer costs over the two rows of a clean cycle. -/ +noncomputable def cleanCycleWeightedCost + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {f g : Equiv.Perm (Fin n)} + (U : Matrix (Fin n) (Fin n) ℝ) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : ℝ := + βˆ‘ k : Fin 2, encodedCoreRowTransferCost f g P U (cleanCycleRow c k) + +theorem cleanCycleWeightedCost_eq_support_sum + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {f g : Equiv.Perm (Fin n)} + (U : Matrix (Fin n) (Fin n) ℝ) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : + cleanCycleWeightedCost U c = + βˆ‘ i ∈ (c.1 : Equiv.Perm (Fin n)).support, + encodedCoreRowTransferCost f g P U i := by + let e := (c.1 : Equiv.Perm (Fin n)).support.orderIsoOfFin + (cleanCycleFactor_property c).1 + unfold cleanCycleWeightedCost + calc + (βˆ‘ k : Fin 2, encodedCoreRowTransferCost f g P U (cleanCycleRow c k)) = + βˆ‘ i : (c.1 : Equiv.Perm (Fin n)).support, + encodedCoreRowTransferCost f g P U i.1 := by + exact Equiv.sum_comp e.toEquiv + (fun i : (c.1 : Equiv.Perm (Fin n)).support ↦ + encodedCoreRowTransferCost f g P U i.1) + _ = βˆ‘ i ∈ (c.1 : Equiv.Perm (Fin n)).support, + encodedCoreRowTransferCost f g P U i := by + simpa using Finset.sum_coe_sort + (c.1 : Equiv.Perm (Fin n)).support + (encodedCoreRowTransferCost f g P U) + +theorem encodedCoreRowTransferCost_nonneg + {n : β„•} {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) (i : Fin n) : + 0 ≀ encodedCoreRowTransferCost f g P + (fun a b ↦ transferU Ο„ (X a) b) i := by + unfold encodedCoreRowTransferCost transferCostOn + apply Finset.sum_nonneg + intro j _ + exact mul_nonneg (hP.nonnegative i j) + (log_one_div_nonneg_of_pos_le_one + (transferU_pos (hXint i) j) + (transferU_le_one hΟ„ (hXint i) j)) + +/-- Clean factors are vertex-disjoint, so their weighted core costs are +bounded by the global core-transfer cost. -/ +theorem sum_cleanCycleWeightedCost_le_coreTransferCost + {n : β„•} {Ο„ Ξ· : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (hΟ„ : 0 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) : + (βˆ‘ c : cleanCycleFactors Ξ· P (alternatingRowPerm f g), + cleanCycleWeightedCost (fun i j ↦ transferU Ο„ (X i) j) c) ≀ + coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) := by + let S := cleanCycleFactors Ξ· P (alternatingRowPerm f g) + let t : (alternatingRowPerm f g).cycleFactorsFinset β†’ Finset (Fin n) := + fun c ↦ (c : Equiv.Perm (Fin n)).support + let w : Fin n β†’ ℝ := fun i ↦ encodedCoreRowTransferCost f g P + (fun a b ↦ transferU Ο„ (X a) b) i + have hpair : (↑S : Set (alternatingRowPerm f g).cycleFactorsFinset).PairwiseDisjoint t := by + intro c hc d hd hcd + have hcd' : (c : Equiv.Perm (Fin n)) β‰  d := by + intro heq + apply hcd + exact Subtype.ext heq + exact (alternatingRowPerm f g).cycleFactorsFinset_pairwise_disjoint + c.2 d.2 hcd' |>.disjoint_support + have hunion : (βˆ‘ c : S, βˆ‘ i ∈ t c.1, w i) = + βˆ‘ i ∈ S.biUnion t, w i := by + calc + (βˆ‘ c : S, βˆ‘ i ∈ t c.1, w i) = + βˆ‘ c ∈ S, βˆ‘ i ∈ t c, w i := by + simpa using Finset.sum_coe_sort S (fun c ↦ βˆ‘ i ∈ t c, w i) + _ = βˆ‘ i ∈ S.biUnion t, w i := (Finset.sum_biUnion hpair).symm + change (βˆ‘ c : S, cleanCycleWeightedCost + (fun a b => transferU Ο„ (X a) b) c) ≀ βˆ‘ i, w i + simp_rw [cleanCycleWeightedCost_eq_support_sum + (fun a b => transferU Ο„ (X a) b)] + change (βˆ‘ c : S, βˆ‘ i ∈ t c.1, w i) ≀ βˆ‘ i, w i + rw [hunion] + exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + (fun i _ _ ↦ encodedCoreRowTransferCost_nonneg hΟ„ hP hXint f g i) + +theorem cleanCycle_minCost_mul_fourCore + {n : β„•} {Ο„ Ξ· : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hΟ„ : 0 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : + (1 / 2 - Ξ·) * fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) ≀ + cleanCycleWeightedCost (fun i j ↦ transferU Ο„ (X i) j) c := by + let r := cleanCycleRow c 0 + let s := cleanCycleRow c 1 + let a := f r + let b := g r + have hcols := cleanCycle_core_columns c + have hrgood : IsGoodRow Ξ· (P r) := by + simpa [goodRows] using cleanCycleRow_mem_goodRows c 0 + have hsgood : IsGoodRow Ξ· (P s) := by + simpa [goodRows] using cleanCycleRow_mem_goodRows c 1 + have hrheavy := twoMatching_core_mem_heavy_of_good hP f g hheavy hrgood + have hsheavy := twoMatching_core_mem_heavy_of_good hP f g hheavy hsgood + have hra : 1 / 2 - Ξ· ≀ P r a := by + simpa [a, heavyCoordinates] using hrheavy.1 + have hrb : 1 / 2 - Ξ· ≀ P r b := by + simpa [b, heavyCoordinates] using hrheavy.2.1 + have hsa : 1 / 2 - Ξ· ≀ P s a := by + have : a = g s := hcols.2.2.1 + rw [this] + simpa [heavyCoordinates] using hsheavy.2.1 + have hsb : 1 / 2 - Ξ· ≀ P s b := by + have : b = f s := hcols.2.2.2 + rw [this] + simpa [heavyCoordinates] using hsheavy.1 + have hlog : βˆ€ i j, + 0 ≀ Real.log (1 / transferU Ο„ (X i) j) := fun i j ↦ + log_one_div_nonneg_of_pos_le_one (transferU_pos (hXint i) j) + (transferU_le_one hΟ„ (hXint i) j) + have hsaCore : coreOutside (f s) (g s) = coreOutside a b := by + rw [hcols.2.2.2.symm, hcols.2.2.1.symm, coreOutside_comm] + unfold cleanCycleWeightedCost + simp only [Fin.sum_univ_two] + rw [show cleanCycleRow c 0 = r by rfl, show cleanCycleRow c 1 = s by rfl] + unfold encodedCoreRowTransferCost + rw [hsaCore, univ_sdiff_coreOutside_of_ne hcols.2.1] + simp only [transferCostOn, Finset.sum_insert, + Finset.sum_singleton, Finset.mem_singleton, hcols.2.1, not_false_eq_true] + rw [fourCoreTransferCost] + nlinarith [mul_le_mul_of_nonneg_right hra (hlog r a), + mul_le_mul_of_nonneg_right hrb (hlog r b), + mul_le_mul_of_nonneg_right hsa (hlog s a), + mul_le_mul_of_nonneg_right hsb (hlog s b)] + +/-- Selects clean cycles whose associated four-core transfer cost exceeds the threshold `ΞΊ`. -/ +noncomputable def failedCleanCycles + {n : β„•} (ΞΊ Ο„ Ξ· : ℝ) + (P X : Matrix (Fin n) (Fin n) ℝ) + (f g : Equiv.Perm (Fin n)) : + Finset (cleanCycleFactors Ξ· P (alternatingRowPerm f g)) := by + classical + exact Finset.univ.filter fun c ↦ + ΞΊ < fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) + +/-- Selects the clean cycles outside the failed-cost set. -/ +noncomputable def successfulCleanCycles + {n : β„•} (ΞΊ Ο„ Ξ· : ℝ) + (P X : Matrix (Fin n) (Fin n) ℝ) + (f g : Equiv.Perm (Fin n)) : + Finset (cleanCycleFactors Ξ· P (alternatingRowPerm f g)) := + Finset.univ \ failedCleanCycles ΞΊ Ο„ Ξ· P X f g + +theorem cleanCycleWeightedCost_nonneg + {n : β„•} {Ο„ Ξ· : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) (hΟ„ : 0 ≀ Ο„) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : + 0 ≀ cleanCycleWeightedCost + (fun i j ↦ transferU Ο„ (X i) j) c := by + unfold cleanCycleWeightedCost + exact Finset.sum_nonneg fun k _ ↦ + encodedCoreRowTransferCost_nonneg hΟ„ hP hXint f g (cleanCycleRow c k) + +/-- The weighted Markov step on the actual clean alternating factors. -/ +theorem failedCleanCycles_count_mul_le_coreTransferCost + {n : β„•} {ΞΊ Ο„ Ξ· : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hPds : IsDoublyStochastic P) + (hΟ„ : 0 ≀ Ο„) (hfactor : 0 ≀ 1 / 2 - Ξ·) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) : + ((failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) * + ((1 / 2 - Ξ·) * ΞΊ) ≀ + coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) := by + let F := failedCleanCycles ΞΊ Ο„ Ξ· P X f g + let C := cleanCycleFactors Ξ· P (alternatingRowPerm f g) + let W : C β†’ ℝ := fun c ↦ cleanCycleWeightedCost + (fun i j ↦ transferU Ο„ (X i) j) c + have hpoint : βˆ€ c ∈ F, (1 / 2 - Ξ·) * ΞΊ ≀ W c := by + intro c hc + have hfail : ΞΊ < fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := by + simpa [F, failedCleanCycles] using hc + have hscaled : (1 / 2 - Ξ·) * ΞΊ ≀ + (1 / 2 - Ξ·) * fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := + mul_le_mul_of_nonneg_left hfail.le hfactor + exact hscaled.trans (cleanCycle_minCost_mul_fourCore + hP hΟ„ hXint f g hheavy c) + have hfailedSum : (F.card : ℝ) * ((1 / 2 - Ξ·) * ΞΊ) ≀ + βˆ‘ c ∈ F, W c := by + calc + (F.card : ℝ) * ((1 / 2 - Ξ·) * ΞΊ) = + βˆ‘ _c ∈ F, ((1 / 2 - Ξ·) * ΞΊ) := by simp + _ ≀ βˆ‘ c ∈ F, W c := Finset.sum_le_sum hpoint + have hsubset : F βŠ† Finset.univ := Finset.subset_univ F + have hsumAll : (βˆ‘ c ∈ F, W c) ≀ βˆ‘ c : C, W c := by + exact Finset.sum_le_sum_of_subset_of_nonneg hsubset + (fun c _ _ ↦ cleanCycleWeightedCost_nonneg hPds hΟ„ hXint f g c) + exact hfailedSum.trans (hsumAll.trans + (sum_cleanCycleWeightedCost_le_coreTransferCost hPds hΟ„ hXint f g)) + +theorem failedCleanCycles_count_le + {n : β„•} (hn : 0 < n) {ΞΊ Ο„ Ξ· Ξ΅tr : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hPds : IsDoublyStochastic P) + (hΟ„ : 0 ≀ Ο„) (hfactor : 0 ≀ 1 / 2 - Ξ·) + (hmin : 0 < (1 / 2 - Ξ·) * ΞΊ) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + (hcore : coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + Ξ΅tr * ((1 / 2 - Ξ·) * ΞΊ)) : + ((failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) ≀ Ξ΅tr * n := by + have hweighted := failedCleanCycles_count_mul_le_coreTransferCost + (ΞΊ := ΞΊ) hP hPds hΟ„ hfactor hXint f g hheavy + have hnR : 0 < (n : ℝ) := by exact_mod_cast hn + have htotal := (div_le_iffβ‚€ hnR).mp hcore + exact failedPair_count_le_transferError hmin hweighted (by + calc + coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) ≀ + (Ξ΅tr * ((1 / 2 - Ξ·) * ΞΊ)) * n := htotal + _ = Ξ΅tr * n * ((1 / 2 - Ξ·) * ΞΊ) := by ring) + +theorem successfulCleanCycles_card_add_failed + {n : β„•} (ΞΊ Ο„ Ξ· : ℝ) + (P X : Matrix (Fin n) (Fin n) ℝ) + (f g : Equiv.Perm (Fin n)) : + (successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card + + (failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card = + cleanCycleCount Ξ· P (alternatingRowPerm f g) := by + have hpart := Finset.card_sdiff_add_card_eq_card + (Finset.subset_univ (failedCleanCycles ΞΊ Ο„ Ξ· P X f g)) + simpa [successfulCleanCycles, Finset.card_univ, Fintype.card_coe, + cleanCycleFactors_card] using hpart + +/-- The exact clean-pair counting conclusion used in the near case. -/ +theorem successfulCleanCycles_count_ge_threeEighths + {n : β„•} {ΞΊ Ο„ Ξ· : ℝ} + {P X : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + (hbad : ((badRows Ξ· P).card : ℝ) ≀ n / 128) + (hlong : (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : ℝ) ≀ + n / 16) + (hfailed : ((failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) ≀ + n / 16) : + 3 * n / 8 ≀ + ((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) := by + have haccountNat := alternating_cleanCycle_count hP f g hheavy + have haccountCast : (n : ℝ) ≀ + 2 * ((badRows Ξ· P).card : ℝ) + + (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : ℝ) + + 2 * (cleanCycleCount Ξ· P (alternatingRowPerm f g) : ℝ) := by + exact_mod_cast haccountNat + have haccount : (n : ℝ) - 2 * (badRows Ξ· P).card - + longCycleGoodRows Ξ· P (alternatingRowPerm f g) ≀ + 2 * cleanCycleCount Ξ· P (alternatingRowPerm f g) := by + linarith + have hclean := cleanPair_count_ge_fiftyNine hbad hlong haccount + have hpartitionNat := successfulCleanCycles_card_add_failed + ΞΊ Ο„ Ξ· P X f g + have hpartitionCast : + ((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) + + ((failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) = + (cleanCycleCount Ξ· P (alternatingRowPerm f g) : ℝ) := by + exact_mod_cast hpartitionNat + have hpartition : + (cleanCycleCount Ξ· P (alternatingRowPerm f g) : ℝ) - + (failedCleanCycles ΞΊ Ο„ Ξ· P X f g).card ≀ + (successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card := by + linarith + exact successfulCleanPair_count_ge_threeEighths (Nat.cast_nonneg n) + hclean hfailed hpartition + +/-- Pointwise form: every successful clean factor receives the uniform gain +from Lemma 19. -/ +theorem successfulCleanCycle_gain + {n : β„•} {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· : ℝ} + (hgain : CleanPairGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + {A P X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {R C : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X R C) + (f g : Equiv.Perm (Fin n)) + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) + (hc : c ∈ successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g) : + Ξ³β‚€ ≀ Real.log + (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := by + let rscale : Fin n β†’ ℝ := fun i ↦ Real.exp (R i) + let cscale : Fin n β†’ ℝ := fun j ↦ Real.exp (C j) + have hmult : HasMultiplicativeKKT Ο„ A X rscale cscale := + hasMultiplicativeKKT_of_logKKT hA hXint hKKT + have hcost : fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) ≀ ΞΊβ‚€ := by + have hnot : Β¬ ΞΊβ‚€ < fourCoreTransferCost Ο„ X + (cleanCycleRow c 0) (cleanCycleRow c 1) + (f (cleanCycleRow c 0)) (g (cleanCycleRow c 0)) := by + simpa [successfulCleanCycles, failedCleanCycles] using hc + exact le_of_not_gt hnot + have hcols := cleanCycle_core_columns c + exact hgain hell hlogn hΞΎ hΞΎβ‚€ hΟ„scale hA hX hXint + (fun i ↦ Real.exp_pos _) (fun j ↦ Real.exp_pos _) hmult + hcols.1 hcols.2.1 hcost + +/-- Summed form of the preceding pointwise gain. -/ +theorem successfulCleanCycles_gain_sum + {n : β„•} {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· : ℝ} + (hgain : CleanPairGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + {A P X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {R C : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X R C) + (f g : Equiv.Perm (Fin n)) : + ((successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g).card : ℝ) * Ξ³β‚€ ≀ + βˆ‘ c ∈ successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g, + Real.log (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := by + have hpoint := successfulCleanCycle_gain hgain hell hlogn hΞΎ hΞΎβ‚€ + (P := P) (Ξ· := Ξ·) hΟ„scale hA hX hXint hKKT f g + calc + ((successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g).card : ℝ) * Ξ³β‚€ = + βˆ‘ _c ∈ successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g, Ξ³β‚€ := by simp + _ ≀ βˆ‘ c ∈ successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g, + Real.log (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := + Finset.sum_le_sum hpoint + +/-- An unordered pair of distinct rows. The ambient order gives it a +canonical orientation whenever a formula such as `pairGain` expects one. -/ +abbrev RowPair (n : β„•) := {q : Finset (Fin n) // q.card = 2} + +/-- Enumerates the two rows of a row pair through their increasing finite-set order isomorphism. -/ +def rowPairRow {n : β„•} (q : RowPair n) : Fin 2 β†’ Fin n := + fun k ↦ (q.1.orderIsoOfFin q.2 k).1 + +/-- Requires distinct selected row pairs to have disjoint underlying row sets. -/ +def IsRowMatching {n : β„•} (M : Finset (RowPair n)) : Prop := + (↑M : Set (RowPair n)).PairwiseDisjoint fun q ↦ q.1 + +/-- Assigns a row pair the nonnegative part of its logarithmic pair gain. -/ +noncomputable def rowPairWeight + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (q : RowPair n) : ℝ := + max 0 (Real.log (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) + +/-- Sums the row-pair weights over a selected matching. -/ +noncomputable def rowMatchingWeight + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + (M : Finset (RowPair n)) : ℝ := + βˆ‘ q ∈ M, rowPairWeight A X q + +/-- Enumerates all finite sets of row pairs satisfying pairwise disjointness. -/ +noncomputable def allRowMatchings (n : β„•) : Finset (Finset (RowPair n)) := by + classical + exact Finset.univ.filter IsRowMatching + +theorem allRowMatchings_nonempty (n : β„•) : + (allRowMatchings n).Nonempty := by + refine βŸ¨βˆ…, ?_⟩ + simp [allRowMatchings, IsRowMatching] + +/-- Takes the maximum total row-pair weight over all row matchings. -/ +noncomputable def maximumMatchingGain + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) : ℝ := + (allRowMatchings n).sup' (allRowMatchings_nonempty n) + (rowMatchingWeight A X) + +theorem rowMatchingWeight_le_maximum + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + {M : Finset (RowPair n)} (hM : IsRowMatching M) : + rowMatchingWeight A X M ≀ maximumMatchingGain A X := by + apply Finset.le_sup' + simpa [allRowMatchings] using hM + +theorem maximumMatchingGain_nonneg + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) : + 0 ≀ maximumMatchingGain A X := by + have h := rowMatchingWeight_le_maximum A X + (M := βˆ…) (by simp [IsRowMatching]) + simpa [rowMatchingWeight] using h + +theorem exists_maximumRowMatching + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) : + βˆƒ M : Finset (RowPair n), IsRowMatching M ∧ + rowMatchingWeight A X M = maximumMatchingGain A X := by + let S := allRowMatchings n + have hnonempty : S.Nonempty := allRowMatchings_nonempty n + have hexists : βˆƒ M ∈ S, + maximumMatchingGain A X ≀ rowMatchingWeight A X M := by + rw [maximumMatchingGain] + exact (Finset.le_sup'_iff hnonempty).mp le_rfl + obtain ⟨M, hMS, hle⟩ := hexists + have hM : IsRowMatching M := by + simpa [S, allRowMatchings] using hMS + exact ⟨M, hM, le_antisymm (rowMatchingWeight_le_maximum A X hM) hle⟩ + +/-- Delete the zero-weight pairs from a matching. Since the matching weights +are positive parts of logarithmic gains, this preserves the objective and +leaves only pairs whose multiplicative gain is strictly larger than one. -/ +noncomputable def positiveRowPairs + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + (M : Finset (RowPair n)) : Finset (RowPair n) := + M.filter fun q ↦ 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) + +theorem positiveRowPairs_subset + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + (M : Finset (RowPair n)) : + positiveRowPairs A X M βŠ† M := by + exact Finset.filter_subset _ _ + +theorem positiveRowPairs_isRowMatching + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} (hM : IsRowMatching M) : + IsRowMatching (positiveRowPairs A X M) := by + intro q hq q' hq' hne + exact hM (positiveRowPairs_subset A X M hq) + (positiveRowPairs_subset A X M hq') hne + +theorem positiveRowPairs_logGain_pos + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} {q : RowPair n} + (hq : q ∈ positiveRowPairs A X M) : + 0 < Real.log (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) := by + exact (Finset.mem_filter.mp hq).2 + +theorem positiveRowPairs_weight_eq + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + (M : Finset (RowPair n)) : + rowMatchingWeight A X (positiveRowPairs A X M) = + rowMatchingWeight A X M := by + rw [rowMatchingWeight, rowMatchingWeight, positiveRowPairs] + apply Finset.sum_subset (Finset.filter_subset _ _) + intro q hqM hqfilter + have hpos : Β¬ 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) := by + intro h + exact hqfilter (Finset.mem_filter.mpr ⟨hqM, h⟩) + have hnonpos : Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) ≀ 0 := + le_of_not_gt hpos + simp [rowPairWeight, max_eq_left hnonpos] + +theorem exists_positive_maximumRowMatching + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) : + βˆƒ M : Finset (RowPair n), IsRowMatching M ∧ + rowMatchingWeight A X M = maximumMatchingGain A X ∧ + βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) := by + obtain ⟨M, hM, hmax⟩ := exists_maximumRowMatching A X + refine ⟨positiveRowPairs A X M, positiveRowPairs_isRowMatching hM, + (positiveRowPairs_weight_eq A X M).trans hmax, ?_⟩ + intro q hq + exact positiveRowPairs_logGain_pos hq + +/-- Uses a clean two-cycle's support as its two-element row pair. -/ +noncomputable def cleanCycleRowPair + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {f g : Equiv.Perm (Fin n)} + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) : RowPair n := + ⟨(c.1 : Equiv.Perm (Fin n)).support, + (cleanCycleFactor_property c).1⟩ + +theorem rowPairRow_cleanCycleRowPair + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {f g : Equiv.Perm (Fin n)} + (c : cleanCycleFactors Ξ· P (alternatingRowPerm f g)) (k : Fin 2) : + rowPairRow (cleanCycleRowPair c) k = cleanCycleRow c k := by + rfl + +theorem cleanCycleRowPair_injective + {n : β„•} {Ξ· : ℝ} {P : Matrix (Fin n) (Fin n) ℝ} + {f g : Equiv.Perm (Fin n)} : + Function.Injective + (cleanCycleRowPair : + cleanCycleFactors Ξ· P (alternatingRowPerm f g) β†’ RowPair n) := by + intro c d heq + apply Subtype.ext + by_contra hcd + have hcd' : (c.1 : Equiv.Perm (Fin n)) β‰  d.1 := by + intro h + apply hcd + exact Subtype.ext h + have hdisj := (alternatingRowPerm f g).cycleFactorsFinset_pairwise_disjoint + c.1.2 d.1.2 hcd' |>.disjoint_support + have hsupp : (c.1 : Equiv.Perm (Fin n)).support = + (d.1 : Equiv.Perm (Fin n)).support := congrArg Subtype.val heq + have hr := cleanCycleRow_mem_support c 0 + exact (Finset.disjoint_left.mp hdisj) hr (by rwa [← hsupp]) + +/-- Maps successful clean cycles to their underlying row pairs. -/ +noncomputable def successfulRowPairs + {n : β„•} (ΞΊ Ο„ Ξ· : ℝ) + (P X : Matrix (Fin n) (Fin n) ℝ) + (f g : Equiv.Perm (Fin n)) : Finset (RowPair n) := + (successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).image cleanCycleRowPair + +theorem successfulRowPairs_isRowMatching + {n : β„•} (ΞΊ Ο„ Ξ· : ℝ) + (P X : Matrix (Fin n) (Fin n) ℝ) + (f g : Equiv.Perm (Fin n)) : + IsRowMatching (successfulRowPairs ΞΊ Ο„ Ξ· P X f g) := by + intro q hq q' hq' hqq' + obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hq + obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hq' + have hcd : c β‰  d := by + intro heq + subst d + exact hqq' rfl + have hcd' : (c.1 : Equiv.Perm (Fin n)) β‰  d.1 := by + intro heq + apply hcd + exact Subtype.ext (Subtype.ext heq) + exact (alternatingRowPerm f g).cycleFactorsFinset_pairwise_disjoint + c.1.2 d.1.2 hcd' |>.disjoint_support + +theorem successfulRowPairs_weight_eq + {n : β„•} {ΞΊ Ο„ Ξ· : ℝ} + {A P X : Matrix (Fin n) (Fin n) ℝ} + (f g : Equiv.Perm (Fin n)) + (hpositive : βˆ€ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + 0 ≀ Real.log + (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1))) : + rowMatchingWeight A X (successfulRowPairs ΞΊ Ο„ Ξ· P X f g) = + βˆ‘ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + Real.log (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := by + rw [rowMatchingWeight, successfulRowPairs, + Finset.sum_image (cleanCycleRowPair_injective.injOn)] + apply Finset.sum_congr rfl + intro c hc + rw [rowPairWeight, rowPairRow_cleanCycleRowPair, + rowPairRow_cleanCycleRowPair, max_eq_right (hpositive c hc)] + +/-- The computable maximum-weight matching dominates the disjoint successful +clean pairs used only in the analysis. -/ +theorem maximumMatchingGain_ge_successfulCleanCycles + {n : β„•} {ΞΊ Ο„ Ξ· Ξ³ : ℝ} + {A P X : Matrix (Fin n) (Fin n) ℝ} + (f g : Equiv.Perm (Fin n)) + (hΞ³ : 0 ≀ Ξ³) + (hpoint : βˆ€ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + Ξ³ ≀ Real.log + (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1))) : + ((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) * Ξ³ ≀ + maximumMatchingGain A X := by + have hpositive : βˆ€ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + 0 ≀ Real.log + (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := by + intro c hc + exact hΞ³.trans (hpoint c hc) + have hsum : ((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) * Ξ³ ≀ + βˆ‘ c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, + Real.log (pairGain A X (cleanCycleRow c 0) (cleanCycleRow c 1)) := by + calc + ((successfulCleanCycles ΞΊ Ο„ Ξ· P X f g).card : ℝ) * Ξ³ = + βˆ‘ _c ∈ successfulCleanCycles ΞΊ Ο„ Ξ· P X f g, Ξ³ := by simp + _ ≀ _ := Finset.sum_le_sum hpoint + rw [← successfulRowPairs_weight_eq f g hpositive] at hsum + exact hsum.trans (rowMatchingWeight_le_maximum A X + (successfulRowPairs_isRowMatching ΞΊ Ο„ Ξ· P X f g)) + +/-- Once the three exceptional sets have the advertised sizes, the clean +pair lemma and disjointness give the full near-case matching gain. -/ +theorem maximumMatchingGain_ge_threeEighths_of_structuralBounds + {n : β„•} (hn : 0 < n) + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· : ℝ} + (hgain : CleanPairGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hΞΊβ‚€ : 0 < ΞΊβ‚€) (hΞ³β‚€ : 0 ≀ Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + {A P X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hPds : IsDoublyStochastic P) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {R C : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X R C) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + (hΞ·half : Ξ· < 1 / 2) + (hbad : ((badRows Ξ· P).card : ℝ) ≀ n / 128) + (hlong : (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : ℝ) ≀ + n / 16) + (hcore : coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€)) : + 3 * Ξ³β‚€ / 8 * n ≀ maximumMatchingGain A X := by + have hellpos : 0 < ell := lt_of_lt_of_le (by norm_num) hell + have hΟ„ : 0 ≀ Ο„ := by + rw [hΟ„scale] + positivity + have hfactor : 0 ≀ 1 / 2 - Ξ· := (sub_pos.mpr hΞ·half).le + have hmin : 0 < (1 / 2 - Ξ·) * ΞΊβ‚€ := + mul_pos (sub_pos.mpr hΞ·half) hΞΊβ‚€ + have hfailed : ((failedCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g).card : ℝ) ≀ n / 16 := by + have hf := failedCleanCycles_count_le hn hP hPds hΟ„ + hfactor hmin hXint f g hheavy hcore + nlinarith + have hsuccess := successfulCleanCycles_count_ge_threeEighths hP f g + hheavy hbad hlong hfailed + have hmatching := maximumMatchingGain_ge_successfulCleanCycles + (A := A) (P := P) (X := X) (ΞΊ := ΞΊβ‚€) (Ο„ := Ο„) (Ξ· := Ξ·) + (Ξ³ := Ξ³β‚€) f g hΞ³β‚€ + (fun c hc ↦ successfulCleanCycle_gain hgain hell hlogn hΞΎ hΞΎβ‚€ + (P := P) (Ξ· := Ξ·) hΟ„scale hA hX hXint hKKT f g c hc) + have hfinal := matchingGain_ge_threeEighths hΞ³β‚€ hsuccess hmatching + nlinarith + +/-- The structural content of the near case, separated from the choice of +matching algorithm. It produces two perfect matchings whose alternating +permutation contains at least `3n/8` successful clean two-cycles. -/ +theorem nearCase_successfulCleanCycles_count_ge_threeEighths + (hrowInequality : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) + {ΞΊβ‚€ ell ΞΎ Ο„ Ξ· Ξ΄ : ℝ} + (hΞΊβ‚€ : 0 < ΞΊβ‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + (hΞ· : 0 < Ξ·) (hΞ·tenth : Ξ· ≀ 1 / 10) + (hrowSmall : Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128) + (hcycleSmall : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) ≀ 1 / 16) + (htransferSmall : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€)) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {R C : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X R C) + (hnear : betheSlack n (betheLogValue A) + (Real.log (Matrix.permanent A)) < Ξ΄ * n) : + βˆƒ f g : Equiv.Perm (Fin n), + 3 * n / 8 ≀ + ((successfulCleanCycles ΞΊβ‚€ Ο„ Ξ· (assignmentMarginal A) X f g).card : ℝ) := by + have hnpos : 0 < n := by omega + have hnR : 0 < (n : ℝ) := by exact_mod_cast hnpos + let P := assignmentMarginal A + let S := betheSlack n (betheLogValue A) + (Real.log (Matrix.permanent A)) + let D := gibbsSequentialDivergence A + have hPds : IsDoublyStochastic P := by + exact assignmentMarginal_doublyStochastic A + (fun i j ↦ (hA i j).le) + (permanent_pos_of_positive A hA).ne' + have hPstrict : βˆ€ i, IsStrictProbabilityVector (P i) := + assignmentMarginal_strictProbabilityVector A hA + have hseq : Real.log (Matrix.permanent A) = + betheObjective A P + (βˆ‘ i, rowCorrection (P i)) - D := by + exact gibbs_exact_sequential_identity A hA + have hdecomp : S = + betheSuboptimality (betheLogValue A) (betheObjective A P) + + (βˆ‘ i, rowDeficit (P i)) + D := + slack_decomposition_rowDeficit P hseq + have hsub0 : 0 ≀ + betheSuboptimality (betheLogValue A) (betheObjective A P) := by + rw [betheSuboptimality] + exact sub_nonneg.mpr + (betheObjective_le_betheLogValue_of_positive hA hPds) + have hrow0 : 0 ≀ βˆ‘ i, rowDeficit (P i) := + Finset.sum_nonneg fun i _ ↦ hrowInequality hn (P i) (hPstrict i).1 + have hD0 : 0 ≀ D := gibbsSequentialDivergence_nonneg A hA + have hterms := terms_le_slack_of_decomposition hsub0 hrow0 hD0 hdecomp + have hrowSum : (βˆ‘ i, rowDeficit (P i)) ≀ S := hterms.2.1 + have hDle : D ≀ S := hterms.2.2 + have hSlt : S < Ξ΄ * n := by simpa only [S] using hnear + have hd0 : 0 < (Ξ· / 3074) ^ 4 := pow_pos (div_pos hΞ· (by norm_num)) 4 + have hbadRaw := badRow_count_le_slack hrowInequality hn hΞ· hPstrict hrowSum + have hquot : S / (Ξ· / 3074) ^ 4 < + (Ξ΄ / (Ξ· / 3074) ^ 4) * n := by + calc + S / (Ξ· / 3074) ^ 4 < (Ξ΄ * n) / (Ξ· / 3074) ^ 4 := + (div_lt_div_iff_of_pos_right hd0).2 hSlt + _ = (Ξ΄ / (Ξ· / 3074) ^ 4) * n := by ring + have hbadError : ((badRows Ξ· P).card : ℝ) ≀ + (Ξ΄ / (Ξ· / 3074) ^ 4) * n := + hbadRaw.trans hquot.le + have hbad : ((badRows Ξ· P).card : ℝ) ≀ n / 128 := by + have hscaled := mul_le_mul_of_nonneg_right hrowSmall (Nat.cast_nonneg n) + nlinarith + obtain ⟨f, g, hheavy, hrobust⟩ := + exists_gibbs_robust_cycle_information A hA hΞ·.le hΞ·tenth + have hlongRaw := longRow_count_le_cycleError + (n := (n : ℝ)) (D := D) + (N := (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : ℝ)) + (bad := ((badRows Ξ· P).card : ℝ)) + (Ξ΄ := Ξ΄) (rowError := Ξ΄ / (Ξ· / 3074) ^ 4) + (Ο‰ := goodRowOmega Ξ·) + (cycleError := 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·)) + (Nat.cast_nonneg n) (hDle.trans_lt hSlt).le + hbadError + (by simpa only [P, D] using hrobust) rfl + have hlong : (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : ℝ) ≀ + n / 16 := by + have hscaled := mul_le_mul_of_nonneg_right hcycleSmall (Nat.cast_nonneg n) + nlinarith + have hbudget : Ο„ * (n * Real.log n) ≀ ΞΎ * n := + regularization_budget_of_paper_scale + (lt_of_lt_of_le (by norm_num) hell) hlogn hΞΎ hΟ„scale + have hΟ„ : 0 ≀ Ο„ := by rw [hΟ„scale]; positivity + have hcoreRaw := gibbs_twoMatching_coreTransferCost_normalized_le hnpos + A hA hΟ„ hbudget ⟨hΞ·.le, hΞ·tenth.trans (by norm_num)⟩ f g hheavy + hX hXint hKKT + have hSnorm : S / n < Ξ΄ := (div_lt_iffβ‚€ hnR).2 hSlt + have hbadNorm : ((badRows Ξ· P).card : ℝ) / n ≀ + Ξ΄ / (Ξ· / 3074) ^ 4 := by + exact (div_le_iffβ‚€ hnR).2 hbadError + have hcore : coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) := by + have hraw : coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + S / n + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * ((badRows Ξ· P).card : ℝ) / n := by + simpa only [P, S] using hcoreRaw + have hbadCoeff : 0 ≀ 1 + Real.log 2 := by + have := Real.log_pos (by norm_num : (1 : ℝ) < 2) + linarith + have htail := mul_le_mul_of_nonneg_left hbadNorm hbadCoeff + have hraw' : coreTransferCost (fun i ↦ coreOutside (f i) (g i)) P + (fun i j ↦ transferU Ο„ (X i) j) / n ≀ + S / n + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (((badRows Ξ· P).card : ℝ) / n) := by + convert hraw using 1 <;> ring + linarith + have hfactor : 0 ≀ 1 / 2 - Ξ· := + (sub_pos.mpr (hΞ·tenth.trans_lt (by norm_num))).le + have hmin : 0 < (1 / 2 - Ξ·) * ΞΊβ‚€ := + mul_pos (sub_pos.mpr (hΞ·tenth.trans_lt (by norm_num))) hΞΊβ‚€ + have hfailed : ((failedCleanCycles ΞΊβ‚€ Ο„ Ξ· P X f g).card : ℝ) ≀ + n / 16 := by + have hf := failedCleanCycles_count_le hnpos hPstrict hPds hΟ„ + hfactor hmin hXint f g hheavy hcore + nlinarith + have hsuccess := successfulCleanCycles_count_ge_threeEighths hPstrict f g + hheavy hbad hlong hfailed + refine ⟨f, g, ?_⟩ + simpa only [P] using hsuccess + +/-- Full structural near case for a positive matrix. The three displayed +smallness hypotheses are exactly the row, long-cycle, and transfer choices in +the paper's completion section. -/ +theorem nearCase_maximumMatchingGain_ge_threeEighths + (hrowInequality : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· Ξ΄ : ℝ} + (hgain : CleanPairGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hΞΊβ‚€ : 0 < ΞΊβ‚€) (hΞ³β‚€ : 0 ≀ Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + (hΞ· : 0 < Ξ·) (hΞ·tenth : Ξ· ≀ 1 / 10) + (hrowSmall : Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128) + (hcycleSmall : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) ≀ 1 / 16) + (htransferSmall : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€)) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {R C : Fin n β†’ ℝ} (hKKT : HasLogKKT Ο„ A X R C) + (hnear : betheSlack n (betheLogValue A) + (Real.log (Matrix.permanent A)) < Ξ΄ * n) : + 3 * Ξ³β‚€ / 8 * n ≀ maximumMatchingGain A X := by + obtain ⟨f, g, hsuccess⟩ := + nearCase_successfulCleanCycles_count_ge_threeEighths hrowInequality hn + hΞΊβ‚€ hell hlogn hΞΎ hΟ„scale hΞ· hΞ·tenth hrowSmall hcycleSmall + htransferSmall hA hX hXint hKKT hnear + have hmatching := maximumMatchingGain_ge_successfulCleanCycles + (A := A) (P := assignmentMarginal A) (X := X) + (ΞΊ := ΞΊβ‚€) (Ο„ := Ο„) (Ξ· := Ξ·) (Ξ³ := Ξ³β‚€) f g hΞ³β‚€ + (fun c hc ↦ successfulCleanCycle_gain hgain hell hlogn hΞΎ hΞΎβ‚€ + hΟ„scale hA hX hXint hKKT f g c hc) + have hfinal := matchingGain_ge_threeEighths hΞ³β‚€ hsuccess hmatching + nlinarith + +theorem rowPairRow_mem + {n : β„•} (q : RowPair n) (k : Fin 2) : rowPairRow q k ∈ q.1 := by + exact (q.1.orderIsoOfFin q.2 k).2 + +theorem rowPairRow_injective + {n : β„•} (q : RowPair n) : Function.Injective (rowPairRow q) := by + intro k l hkl + apply (q.1.orderIsoOfFin q.2).injective + exact Subtype.ext hkl + +theorem rowPairRow_ne + {n : β„•} (q : RowPair n) : rowPairRow q 0 β‰  rowPairRow q 1 := by + intro h + have hk := rowPairRow_injective q h + norm_num at hk + +/-- Takes the union of all rows occurring in the selected row pairs. -/ +noncomputable def matchingRows + {n : β„•} (M : Finset (RowPair n)) : Finset (Fin n) := + M.biUnion fun q ↦ q.1 + +/-- The subtype of rows absent from all selected row pairs. -/ +abbrev UnmatchedRow {n : β„•} (M : Finset (RowPair n)) := + {i : Fin n // i βˆ‰ matchingRows M} + +/-- A cluster is either a selected row pair or one unmatched row. -/ +abbrev MatchingCluster {n : β„•} (M : Finset (RowPair n)) := + M βŠ• UnmatchedRow M + +/-- Assigns size two to a matched pair cluster and size one to an unmatched-row cluster. -/ +def matchingClusterSize + {n : β„•} {M : Finset (RowPair n)} : MatchingCluster M β†’ β„• + | Sum.inl _ => 2 + | Sum.inr _ => 1 + +/-- Maps a cluster and its local position back to the corresponding original matrix row. -/ +noncomputable def matchingRowMap + {n : β„•} (M : Finset (RowPair n)) : + (Ξ£ c : MatchingCluster M, Fin (matchingClusterSize c)) β†’ Fin n + | ⟨Sum.inl q, k⟩ => rowPairRow q.1 k + | ⟨Sum.inr i, _⟩ => i.1 + +theorem matchingRowMap_bijective + {n : β„•} {M : Finset (RowPair n)} (hM : IsRowMatching M) : + Function.Bijective (matchingRowMap M) := by + constructor + Β· rintro ⟨c, k⟩ ⟨d, l⟩ heq + rcases c with q | i <;> rcases d with q' | i' + Β· change Fin 2 at k l + change rowPairRow q.1 k = rowPairRow q'.1 l at heq + have hqq : q = q' := by + by_contra hne + have hne' : q.1 β‰  q'.1 := by + intro h + exact hne (Subtype.ext h) + have hdisj := hM q.2 q'.2 hne' + exact (Finset.disjoint_left.mp hdisj) + (rowPairRow_mem q.1 k) (by rw [heq]; exact rowPairRow_mem q'.1 l) + subst q' + have hkl : k = l := rowPairRow_injective q.1 heq + subst l + rfl + Β· change Fin 2 at k + change rowPairRow q.1 k = i'.1 at heq + have hmatched : rowPairRow q.1 k ∈ matchingRows M := by + exact Finset.mem_biUnion.mpr ⟨q.1, q.2, rowPairRow_mem q.1 k⟩ + have : i'.1 ∈ matchingRows M := by rwa [← heq] + exact False.elim (i'.2 this) + Β· change Fin 2 at l + change i.1 = rowPairRow q'.1 l at heq + have hmatched : rowPairRow q'.1 l ∈ matchingRows M := by + exact Finset.mem_biUnion.mpr ⟨q'.1, q'.2, rowPairRow_mem q'.1 l⟩ + have : i.1 ∈ matchingRows M := by rwa [heq] + exact False.elim (i.2 this) + Β· have hii : i = i' := Subtype.ext heq + subst i' + change Fin 1 at k l + have hkl : k = l := Subsingleton.elim _ _ + subst l + rfl + Β· intro i + by_cases hi : i ∈ matchingRows M + Β· obtain ⟨q, hqM, hiq⟩ := Finset.mem_biUnion.mp hi + let qM : M := ⟨q, hqM⟩ + obtain ⟨k, hk⟩ := (q.1.orderIsoOfFin q.2).surjective ⟨i, hiq⟩ + exact ⟨⟨Sum.inl qM, k⟩, by exact congrArg Subtype.val hk⟩ + Β· let k : Fin (matchingClusterSize (Sum.inr ⟨i, hi⟩ : MatchingCluster M)) := + ⟨0, by simp [matchingClusterSize]⟩ + exact ⟨⟨Sum.inr ⟨i, hi⟩, k⟩, rfl⟩ + +/-- The row-labeling equivalence, written with an explicit forward map so its +action on a cluster is transparent to subsequent proofs. -/ +noncomputable def matchingRowsEquiv + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) : + (Ξ£ c : MatchingCluster M, Fin (matchingClusterSize c)) ≃ Fin n where + toFun := matchingRowMap M + invFun := Function.surjInv (matchingRowMap_bijective hM).2 + left_inv := Function.leftInverse_surjInv (matchingRowMap_bijective hM) + right_inv := Function.rightInverse_surjInv _ + +@[simp] theorem matchingRowsEquiv_apply + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) + (x : Ξ£ c : MatchingCluster M, Fin (matchingClusterSize c)) : + matchingRowsEquiv M hM x = matchingRowMap M x := rfl + +/-- Convert a disjoint row matching into the singleton/pair clustering used +by the paired-certificate theorem. -/ +noncomputable def rowClusteringOfMatching + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) : + RowClustering n where + Cluster := MatchingCluster M + clusterFintype := inferInstance + clusterDecidableEq := Classical.decEq _ + size := matchingClusterSize + rows := matchingRowsEquiv M hM + +theorem rowClusteringOfMatching_singletonPairs + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) : + IsSingletonPairClustering (rowClusteringOfMatching M hM) := by + intro c + rcases c with q | i + Β· exact Or.inr rfl + Β· exact Or.inl rfl + +theorem singletonClusterRow_rowClusteringOfMatching + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) + (i : UnmatchedRow M) : + singletonClusterRow (rowClusteringOfMatching M hM) (Sum.inr i) rfl = i.1 := by + rfl + +theorem pairClusterRow_rowClusteringOfMatching + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) + (q : M) (k : Fin 2) : + pairClusterRow (rowClusteringOfMatching M hM) (Sum.inl q) rfl k = + rowPairRow q.1 k := by + rfl + +theorem rowClusteringOfMatching_rows_pair + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) + (q : M) (k : Fin 2) : + (rowClusteringOfMatching M hM).rows ⟨Sum.inl q, k⟩ = + rowPairRow q.1 k := by + rfl + +theorem rowClusteringOfMatching_rows_singleton + {n : β„•} (M : Finset (RowPair n)) (hM : IsRowMatching M) + (i : UnmatchedRow M) (k : Fin 1) : + (rowClusteringOfMatching M hM).rows ⟨Sum.inr i, k⟩ = i.1 := by + have hk : k = 0 := Subsingleton.elim _ _ + subst k + rfl + +theorem pairCertificateValue_nonneg + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Nonnegative A) (hX : IsDoublyStochastic X) + {r s : Fin n} (hrs : r β‰  s) : + 0 ≀ pairCertificateValue A X r s := by + rw [pairCertificateValue] + apply mul_nonneg + Β· exact Finset.prod_nonneg fun j _ ↦ Real.rpow_nonneg + (sub_nonneg.mpr (pairAlpha_le_one hX hrs j)) _ + Β· exact polynomialCapacity_nonneg + (pairPolynomial_nonnegativeCoefficients (hA r) (hA s)) _ + +/-- Algebraic meaning of the gain ratio: a pair factor is its gain times the +two singleton factors that it replaces. -/ +theorem pairCertificateValue_eq_pairGain_mul_singletons + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (r s : Fin n) : + pairCertificateValue A X r s = + pairGain A X r s * (singletonFactor A X r * singletonFactor A X s) := by + have hr := singletonProductValue_eq_singletonFactor hcard hA hX hXpos r + have hs := singletonProductValue_eq_singletonFactor hcard hA hX hXpos s + have hden : singletonFactor A X r * singletonFactor A X s β‰  0 := + mul_ne_zero (Real.exp_ne_zero _) (Real.exp_ne_zero _) + rw [pairGain, hr, hs] + exact (div_mul_cancelβ‚€ _ hden).symm + +theorem pairCertificateValue_eq_exp_logGain_mul_singletons + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (r s : Fin n) (hrs : r β‰  s) + (hgain : 0 < Real.log (pairGain A X r s)) : + pairCertificateValue A X r s = + Real.exp (Real.log (pairGain A X r s)) * + (singletonFactor A X r * singletonFactor A X s) := by + have hgain0 : 0 ≀ pairGain A X r s := by + have hr := singletonProductValue_eq_singletonFactor hcard hA hX hXpos r + have hs := singletonProductValue_eq_singletonFactor hcard hA hX hXpos s + have hden : 0 ≀ singletonProductValue A X r * singletonProductValue A X s := by + rw [hr, hs] + exact mul_nonneg (Real.exp_pos _).le (Real.exp_pos _).le + rw [pairGain] + exact div_nonneg (pairCertificateValue_nonneg + (fun i j ↦ (hA i j).le) hX hrs) + hden + have hone : 1 < pairGain A X r s := (Real.log_pos_iff hgain0).mp hgain + rw [Real.exp_log (zero_lt_one.trans hone)] + exact pairCertificateValue_eq_pairGain_mul_singletons hcard hA hX hXpos r s + +/-- Assigns a matched pair cluster its logarithmic pair gain and an unmatched-row cluster zero +gain. -/ +noncomputable def matchingClusterLogGain + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) + {M : Finset (RowPair n)} : MatchingCluster M β†’ ℝ + | Sum.inl q => Real.log + (pairGain A X (rowPairRow q.1 0) (rowPairRow q.1 1)) + | Sum.inr _ => 0 + +theorem sum_matchingClusterLogGain_eq_rowMatchingWeight + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} + (hpositive : βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) : + βˆ‘ c : MatchingCluster M, matchingClusterLogGain A X c = + rowMatchingWeight A X M := by + rw [Fintype.sum_sum_type] + simp only [matchingClusterLogGain] + have hzero : (βˆ‘ _i : UnmatchedRow M, (0 : ℝ)) = 0 := by simp + rw [hzero, add_zero] + calc + (βˆ‘ q : M, Real.log + (pairGain A X (rowPairRow q.1 0) (rowPairRow q.1 1))) = + βˆ‘ q ∈ M, Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1)) := + by + simpa using (Finset.sum_coe_sort M (fun q : RowPair n ↦ + Real.log (pairGain A X (rowPairRow q 0) (rowPairRow q 1)))) + _ = rowMatchingWeight A X M := by + rw [rowMatchingWeight] + apply Finset.sum_congr rfl + intro q hq + rw [rowPairWeight, max_eq_right (hpositive q hq).le] + +theorem paperClusterFactor_rowClusteringOfMatching + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} (hM : IsRowMatching M) + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hpositive : βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) + (c : MatchingCluster M) : + paperClusterFactor A X (rowClusteringOfMatching M hM) + (rowClusteringOfMatching_singletonPairs M hM) c = + Real.exp (matchingClusterLogGain A X c) * + ∏ k, singletonFactor A X + ((rowClusteringOfMatching M hM).rows ⟨c, k⟩) := by + rcases c with q | i + Β· change pairCertificateValue A X (rowPairRow q.1 0) (rowPairRow q.1 1) = _ + rw [pairCertificateValue_eq_exp_logGain_mul_singletons hcard hA hX hXpos + (rowPairRow q.1 0) (rowPairRow q.1 1) (rowPairRow_ne q.1) + (hpositive q.1 q.2)] + rw [matchingClusterLogGain] + change Real.exp (Real.log (pairGain A X (rowPairRow q.1 0) (rowPairRow q.1 1))) * + (singletonFactor A X (rowPairRow q.1 0) * singletonFactor A X (rowPairRow q.1 1)) = + Real.exp (Real.log (pairGain A X (rowPairRow q.1 0) (rowPairRow q.1 1))) * + ∏ k : Fin 2, singletonFactor A X (rowPairRow q.1 k) + have hprod := Fin.prod_univ_two (fun k : Fin 2 ↦ + singletonFactor A X (rowPairRow q.1 k)) + exact congrArg (Real.exp + (Real.log (pairGain A X (rowPairRow q.1 0) (rowPairRow q.1 1))) * Β·) + hprod.symm + Β· change singletonFactor A X i.1 = _ + change singletonFactor A X i.1 = Real.exp 0 * + ∏ _k : Fin 1, singletonFactor A X i.1 + simp + +theorem prod_paperClusterFactor_rowClusteringOfMatching + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} (hM : IsRowMatching M) + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hpositive : βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) : + (∏ c, paperClusterFactor A X (rowClusteringOfMatching M hM) + (rowClusteringOfMatching_singletonPairs M hM) c) = + Real.exp (betheObjective A X + rowMatchingWeight A X M) := by + let hclusters := rowClusteringOfMatching_singletonPairs M hM + calc + (∏ c, paperClusterFactor A X (rowClusteringOfMatching M hM) hclusters c) = + ∏ c, (Real.exp (matchingClusterLogGain A X c) * + ∏ k, singletonFactor A X + ((rowClusteringOfMatching M hM).rows ⟨c, k⟩)) := by + apply Finset.prod_congr rfl + intro c _ + exact paperClusterFactor_rowClusteringOfMatching hM hcard hA hX hXpos + hpositive c + _ = (∏ c, Real.exp (matchingClusterLogGain A X c)) * + ∏ c, ∏ k, singletonFactor A X + ((rowClusteringOfMatching M hM).rows ⟨c, k⟩) := by + exact Finset.prod_mul_distrib + _ = Real.exp (βˆ‘ c : MatchingCluster M, matchingClusterLogGain A X c) * + ∏ s : Ξ£ c : (rowClusteringOfMatching M hM).Cluster, + Fin ((rowClusteringOfMatching M hM).size c), + singletonFactor A X ((rowClusteringOfMatching M hM).rows s) := by + rw [Real.exp_sum, ← Fintype.prod_sigma'] + _ = Real.exp (rowMatchingWeight A X M) * + ∏ i, singletonFactor A X i := by + rw [sum_matchingClusterLogGain_eq_rowMatchingWeight hpositive] + exact congrArg (Real.exp (rowMatchingWeight A X M) * Β·) + (Equiv.prod_comp (rowClusteringOfMatching M hM).rows + (singletonFactor A X)) + _ = Real.exp (rowMatchingWeight A X M) * + Real.exp (betheObjective A X) := by + rw [prod_singletonFactor_eq_exp_betheObjective] + _ = Real.exp (betheObjective A X + rowMatchingWeight A X M) := by + rw [← Real.exp_add] + congr 1 + ring + +/-- Every positive-gain row matching produces a certified lower bound. -/ +theorem exp_betheObjective_add_rowMatchingWeight_le_permanent + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} + {M : Finset (RowPair n)} (hM : IsRowMatching M) + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) + (hpositive : βˆ€ q ∈ M, 0 < Real.log + (pairGain A X (rowPairRow q 0) (rowPairRow q 1))) : + Real.exp (betheObjective A X + rowMatchingWeight A X M) ≀ + Matrix.permanent A := by + rw [← prod_paperClusterFactor_rowClusteringOfMatching hM hcard hA hX + hXpos hpositive] + exact pairedLowerCertificate_for_clustering stableCoefficient + (rowClusteringOfMatching M hM) hcard hA hX hXpos + (rowClusteringOfMatching_singletonPairs M hM) + +/-- The output based on a maximum-weight row matching remains below the +permanent. Zero-gain edges are deleted before applying the cluster theorem. -/ +theorem exp_betheObjective_add_maximumMatchingGain_le_permanent + {n : β„•} + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hcard : 2 ≀ n) (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hXpos : βˆ€ i j, 0 < X i j) : + Real.exp (betheObjective A X + maximumMatchingGain A X) ≀ + Matrix.permanent A := by + obtain ⟨M, hM, hmax, hpositive⟩ := exists_positive_maximumRowMatching A X + rw [← hmax] + exact exp_betheObjective_add_rowMatchingWeight_le_permanent + stableCoefficient hM hcard hA hX hXpos hpositive + +/-- Positive-matrix form of Proposition 20. Vontobel's concavity theorem, +the sharp row inequality, and the upper Bethe bound are proved internally. -/ +theorem positiveMatrix_logApproximation + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {n : β„•} (hn : 2 ≀ n) + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ ell ΞΎ Ο„ Ξ· Ξ΄ : ℝ} + (hgain : CleanPairGainGuarantee ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) + (hΞΊβ‚€ : 0 < ΞΊβ‚€) (hΞ³β‚€ : 0 < Ξ³β‚€) + (hell : 1 ≀ ell) (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€) (hΟ„scale : Ο„ = ΞΎ / (4 * ell)) + (hΞ· : 0 < Ξ·) (hΞ·tenth : Ξ· ≀ 1 / 10) + (hrowSmall : Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128) + (hcycleSmall : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) ≀ 1 / 16) + (htransferSmall : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€)) + (hΞΎΞ΄ : ΞΎ < Ξ΄) (hΞΎΞ³ : ΞΎ < 3 * Ξ³β‚€ / 8) + (A : Matrix (Fin n) (Fin n) ℝ) (hA : Matrix.Positive A) : + 0 < epsilonPlus Ξ΄ ΞΎ Ξ³β‚€ ∧ + βˆƒ X : Matrix (Fin n) (Fin n) ℝ, + IsDoublyStochastic X ∧ + (βˆ€ i, IsInteriorProbabilityVector (X i)) ∧ + Real.exp (betheObjective A X + maximumMatchingGain A X) ≀ + Matrix.permanent A ∧ + Real.log (Matrix.permanent A) - + (betheObjective A X + maximumMatchingGain A X) ≀ + (Real.log 2 / 2 - epsilonPlus Ξ΄ ΞΎ Ξ³β‚€) * n := by + obtain ⟨X, hX, hXint, _hmax, ⟨R, C, hKKT⟩, hobjective⟩ := + exists_regularizedOptimizer_at_paper_scale + (show 1 < n by omega) (lt_of_lt_of_le (by norm_num) hell) + hlogn hΞΎ hΟ„scale A hA + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlogBethe : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + have hupper : Real.log (Matrix.permanent A) ≀ + Real.log (bethePermanent A) + n * (Real.log 2 / 2) := by + rw [hlogBethe] + exact log_permanent_le_betheLogValue_add_log_two_half hn A hA + have hcertificate := + exp_betheObjective_add_maximumMatchingGain_le_permanent + stableCoefficient hn hA hX (fun i j ↦ (hXint i).2 j |>.1) + have hnearGain : betheSlack n (Real.log (bethePermanent A)) + (Real.log (Matrix.permanent A)) < Ξ΄ * n β†’ + 3 * Ξ³β‚€ / 8 * n ≀ maximumMatchingGain A X := by + intro hnear + rw [hlogBethe] at hnear + exact nearCase_maximumMatchingGain_ge_threeEighths + anariRezaeiRowInequality hn + hgain hΞΊβ‚€ hΞ³β‚€.le hell hlogn hΞΎ hΞΎβ‚€ hΟ„scale hΞ· hΞ·tenth + hrowSmall hcycleSmall htransferSmall hA hX hXint hKKT hnear + have hcases := completionCaseDisjunction + (logPermanent := Real.log (Matrix.permanent A)) + (logBethe := Real.log (bethePermanent A)) + (objective := betheObjective A X) + (gain := maximumMatchingGain A X) + (Ξ΄ := Ξ΄) (ΞΎ := ΞΎ) (Ξ³ := Ξ³β‚€) + hobjective (maximumMatchingGain_nonneg A X) hupper hnearGain + have hgap := positiveDichotomy_exponent hcases + exact ⟨epsilonPlus_pos hΞΎΞ΄ hΞΎΞ³, X, hX, hXint, hcertificate, hgap⟩ + +/-- The hierarchy of absolute scales used in the completion exists. We +parameterize `Ξ΄` as a small multiple of `(Ξ·/3074)^4`; this makes the apparent +singularity in the row-error ratio disappear. -/ +theorem exists_completion_scales + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : ℝ} (hΞΊβ‚€ : 0 < ΞΊβ‚€) (hΞΎβ‚€ : 0 < ΞΎβ‚€) (hΞ³β‚€ : 0 < Ξ³β‚€) : + βˆƒ Ξ· Ξ΄ ΞΎ : ℝ, + 0 < Ξ· ∧ Ξ· ≀ 1 / 10 ∧ 0 < Ξ΄ ∧ 0 < ΞΎ ∧ ΞΎ ≀ ΞΎβ‚€ ∧ + Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128 ∧ + 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) ≀ 1 / 16 ∧ + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) ∧ + ΞΎ < Ξ΄ ∧ ΞΎ < 3 * Ξ³β‚€ / 8 := by + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hΟ‰target : 0 < Real.log 2 / 384 := div_pos hlog (by norm_num) + have hΟ‰event : {x : ℝ | goodRowOmega x < Real.log 2 / 384} ∈ nhds 0 := + tendsto_goodRowOmega_zero (isOpen_Iio.mem_nhds hΟ‰target) + have hHcont : ContinuousAt (fun x : ℝ ↦ binaryEntropy x + x) 0 := + continuous_binaryEntropy.continuousAt.add continuousAt_id + have hHtarget : 0 < ΞΊβ‚€ / 256 := div_pos hΞΊβ‚€ (by norm_num) + have hHevent : {x : ℝ | binaryEntropy x + x < ΞΊβ‚€ / 256} ∈ nhds 0 := by + exact hHcont.eventually (isOpen_Iio.mem_nhds (by + simpa [binaryEntropy] using hHtarget)) + have hevent := Filter.inter_mem hΟ‰event hHevent + rw [Metric.mem_nhds_iff] at hevent + obtain ⟨a, ha, hball⟩ := hevent + let Ξ· : ℝ := min (a / 2) (1 / 20) + have hΞ· : 0 < Ξ· := lt_min (half_pos ha) (by norm_num) + have hΞ·twenty : Ξ· ≀ 1 / 20 := min_le_right _ _ + have hΞ·a : Ξ· < a := (min_le_left _ _).trans_lt (half_lt_self ha) + have hΞ·mem := hball (by + rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_of_pos hΞ·] + exact hΞ·a) + have hΟ‰small : goodRowOmega Ξ· < Real.log 2 / 384 := hΞ·mem.1 + have hHsmall : binaryEntropy Ξ· + Ξ· < ΞΊβ‚€ / 256 := hΞ·mem.2 + have hΞ·tenth : Ξ· ≀ 1 / 10 := hΞ·twenty.trans (by norm_num) + have hcycleBase : 6 / Real.log 2 * goodRowOmega Ξ· < 1 / 64 := by + have hcoef : 0 < 6 / Real.log 2 := div_pos (by norm_num) hlog + calc + 6 / Real.log 2 * goodRowOmega Ξ· < + 6 / Real.log 2 * (Real.log 2 / 384) := + mul_lt_mul_of_pos_left hΟ‰small hcoef + _ = 1 / 64 := by field_simp [hlog.ne'] <;> norm_num + have hΞ·ΞΊ : Ξ· * ΞΊβ‚€ ≀ (1 / 20) * ΞΊβ‚€ := + mul_le_mul_of_nonneg_right hΞ·twenty hΞΊβ‚€.le + have htransferBase : binaryEntropy Ξ· + Ξ· < + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) := by + nlinarith + let cycleMargin : ℝ := 1 / 16 - 6 / Real.log 2 * goodRowOmega Ξ· + let transferMargin : ℝ := + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) - (binaryEntropy Ξ· + Ξ·) + have hcycleMargin : 0 < cycleMargin := by + dsimp only [cycleMargin] + linarith + have htransferMargin : 0 < transferMargin := by + dsimp only [transferMargin] + linarith + let dβ‚€ : ℝ := (Ξ· / 3074) ^ 4 + have hdβ‚€ : 0 < dβ‚€ := pow_pos (div_pos hΞ· (by norm_num)) 4 + let cycleCoefficient : ℝ := + 6 / Real.log 2 * (dβ‚€ + (1 + Real.log 2 / 2)) + have hcycleCoefficient : 0 < cycleCoefficient := by + dsimp only [cycleCoefficient] + have hc : 0 < dβ‚€ + (1 + Real.log 2 / 2) := by positivity + exact mul_pos (div_pos (by norm_num) hlog) hc + let transferCoefficient : ℝ := dβ‚€ + (1 + Real.log 2) + have htransferCoefficient : 0 < transferCoefficient := by + dsimp only [transferCoefficient] + positivity + let r : ℝ := min (1 / 128) + (min (cycleMargin / (2 * cycleCoefficient)) + (transferMargin / (2 * transferCoefficient))) + have hr : 0 < r := by + dsimp only [r] + exact lt_min (by norm_num) (lt_min + (div_pos hcycleMargin (mul_pos (by norm_num) hcycleCoefficient)) + (div_pos htransferMargin (mul_pos (by norm_num) htransferCoefficient))) + have hr128 : r ≀ 1 / 128 := min_le_left _ _ + have hrcycle : r ≀ cycleMargin / (2 * cycleCoefficient) := + (min_le_right _ _).trans (min_le_left _ _) + have hrtransfer : r ≀ transferMargin / (2 * transferCoefficient) := + (min_le_right _ _).trans (min_le_right _ _) + have hcycleExtra : cycleCoefficient * r ≀ cycleMargin / 2 := by + calc + cycleCoefficient * r ≀ + cycleCoefficient * (cycleMargin / (2 * cycleCoefficient)) := + mul_le_mul_of_nonneg_left hrcycle hcycleCoefficient.le + _ = cycleMargin / 2 := by field_simp [hcycleCoefficient.ne'] + have htransferExtra : transferCoefficient * r ≀ transferMargin / 2 := by + calc + transferCoefficient * r ≀ + transferCoefficient * (transferMargin / (2 * transferCoefficient)) := + mul_le_mul_of_nonneg_left hrtransfer htransferCoefficient.le + _ = transferMargin / 2 := by field_simp [htransferCoefficient.ne'] + let Ξ΄ : ℝ := dβ‚€ * r + have hΞ΄ : 0 < Ξ΄ := mul_pos hdβ‚€ hr + have hratio : Ξ΄ / (Ξ· / 3074) ^ 4 = r := by + change dβ‚€ * r / dβ‚€ = r + exact mul_div_cancel_leftβ‚€ r hdβ‚€.ne' + have hcycle : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) < 1 / 16 := by + rw [hratio] + have hid : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * r + goodRowOmega Ξ·) = + 6 / Real.log 2 * goodRowOmega Ξ· + cycleCoefficient * r := by + dsimp only [Ξ΄, cycleCoefficient] + dsimp only [dβ‚€] + ring + rw [hid] + dsimp only [cycleMargin] at hcycleExtra + linarith + have htransferZero : + Ξ΄ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) < + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) := by + rw [hratio] + have hid : Ξ΄ + binaryEntropy Ξ· + Ξ· + (1 + Real.log 2) * r = + (binaryEntropy Ξ· + Ξ·) + transferCoefficient * r := by + dsimp only [Ξ΄, transferCoefficient] + ring + rw [hid] + dsimp only [transferMargin] at htransferExtra + linarith + let remaining : ℝ := (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) - + (Ξ΄ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4)) + have hremaining : 0 < remaining := by + dsimp only [remaining] + linarith + let ΞΎ : ℝ := min (ΞΎβ‚€ / 2) + (min (Ξ΄ / 2) (min (3 * Ξ³β‚€ / 16) (remaining / 4))) + have hΞΎ : 0 < ΞΎ := by + dsimp only [ΞΎ] + exact lt_min (half_pos hΞΎβ‚€) (lt_min (half_pos hΞ΄) (lt_min + (div_pos (mul_pos (by norm_num) hΞ³β‚€) (by norm_num)) + (div_pos hremaining (by norm_num)))) + have hΞΎΞΎβ‚€ : ΞΎ ≀ ΞΎβ‚€ := + (min_le_left _ _).trans (half_le_self hΞΎβ‚€.le) + have hΞΎΞ΄ : ΞΎ < Ξ΄ := + (min_le_right _ _).trans (min_le_left _ _) |>.trans_lt (half_lt_self hΞ΄) + have hΞΎΞ³ : ΞΎ < 3 * Ξ³β‚€ / 8 := by + have hle : ΞΎ ≀ 3 * Ξ³β‚€ / 16 := + (min_le_right _ _).trans ((min_le_right _ _).trans (min_le_left _ _)) + nlinarith + have hΞΎremaining : ΞΎ ≀ remaining / 4 := + (min_le_right _ _).trans ((min_le_right _ _).trans (min_le_right _ _)) + have htransfer : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * ΞΊβ‚€) := by + dsimp only [remaining] at hΞΎremaining + nlinarith + exact ⟨η, Ξ΄, ΞΎ, hΞ·, hΞ·tenth, hΞ΄, hΞΎ, hΞΎΞΎβ‚€, + by simpa [hratio] using hr128, hcycle.le, htransfer, hΞΎΞ΄, hξγ⟩ + +/-- The real paper scale `max 1 (log n / log 2)`. -/ +noncomputable def paperScaleEll (n : β„•) : ℝ := + max 1 (Real.log n / Real.log 2) + +theorem one_le_paperScaleEll (n : β„•) : 1 ≀ paperScaleEll n := by + exact le_max_left _ _ + +theorem log_le_paperScaleEll_mul_log_two (n : β„•) : + Real.log n ≀ paperScaleEll n * Real.log 2 := by + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hmax : Real.log n / Real.log 2 ≀ paperScaleEll n := + le_max_right _ _ + calc + Real.log n = (Real.log n / Real.log 2) * Real.log 2 := by + field_simp [hlog.ne'] + _ ≀ paperScaleEll n * Real.log 2 := + mul_le_mul_of_nonneg_right hmax hlog.le + +/-- Exact positive-matrix certificate property at logarithmic improvement +`epsilon`. This is the mathematical core of Theorem 1 before smoothing and +finite-precision evaluation. -/ +def ExactPositiveCertificate (Ξ΅ : ℝ) : Prop := + βˆ€ {n : β„•}, 2 ≀ n β†’ + βˆ€ A : Matrix (Fin n) (Fin n) ℝ, Matrix.Positive A β†’ + βˆƒ X : Matrix (Fin n) (Fin n) ℝ, + IsDoublyStochastic X ∧ + Real.exp (betheObjective A X + maximumMatchingGain A X) ≀ + Matrix.permanent A ∧ + Real.log (Matrix.permanent A) - + (betheObjective A X + maximumMatchingGain A X) ≀ + (Real.log 2 / 2 - Ξ΅) * n + +/-- Absolute positive-matrix approximation theorem, with all constants +chosen internally. This is the mathematical core of Theorem 1 before the +standard smoothing and finite-precision wrapper. -/ +theorem exists_absolute_positiveMatrix_logApproximation + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) : + βˆƒ Ξ΅ : ℝ, 0 < Ξ΅ ∧ βˆ€ {n : β„•}, 2 ≀ n β†’ + βˆ€ A : Matrix (Fin n) (Fin n) ℝ, Matrix.Positive A β†’ + βˆƒ X : Matrix (Fin n) (Fin n) ℝ, + IsDoublyStochastic X ∧ + Real.exp (betheObjective A X + maximumMatchingGain A X) ≀ + Matrix.permanent A ∧ + Real.log (Matrix.permanent A) - + (betheObjective A X + maximumMatchingGain A X) ≀ + (Real.log 2 / 2 - Ξ΅) * n := by + obtain ⟨κq, ΞΎq, Ξ³q, hΞΊq, hΞΎq, hΞ³q, hgain⟩ := + exists_rational_cleanPairGain_constants + have hΞΊ : 0 < (ΞΊq : ℝ) := by exact_mod_cast hΞΊq + have hΞΎβ‚€ : 0 < (ΞΎq : ℝ) := by exact_mod_cast hΞΎq + have hΞ³ : 0 < (Ξ³q : ℝ) := by exact_mod_cast hΞ³q + obtain ⟨η, Ξ΄, ΞΎ, hΞ·, hΞ·tenth, _hΞ΄, hΞΎ, hΞΎΞΎβ‚€, hrowSmall, + hcycleSmall, htransferSmall, hΞΎΞ΄, hξγ⟩ := + exists_completion_scales hΞΊ hΞΎβ‚€ hΞ³ + let Ξ΅ := epsilonPlus Ξ΄ ΞΎ (Ξ³q : ℝ) + have hΞ΅ : 0 < Ξ΅ := epsilonPlus_pos hΞΎΞ΄ hΞΎΞ³ + refine ⟨Ρ, hΞ΅, ?_⟩ + intro n hn A hA + let ell := paperScaleEll n + let Ο„ := ΞΎ / (4 * ell) + have hresult := positiveMatrix_logApproximation stableCoefficient hn + hgain hΞΊ hΞ³ + (one_le_paperScaleEll n) (log_le_paperScaleEll_mul_log_two n) + hΞΎ hΞΎΞΎβ‚€ (show Ο„ = ΞΎ / (4 * ell) by rfl) hΞ· hΞ·tenth + hrowSmall hcycleSmall htransferSmall hΞΎΞ΄ hΞΎΞ³ A hA + rcases hresult with ⟨hΞ΅', X, hX, _hXint, hcert, hgap⟩ + exact ⟨X, hX, hcert, by simpa only [Ξ΅] using hgap⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalAffine.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalAffine.lean new file mode 100644 index 0000000000..f64f278b8c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalAffine.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import Mathlib.Tactic + +/-! # Numerical Affine -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Exact rational coordinates for the Birkhoff affine hull + +The upper-left `n`-by-`n` block gives coordinates for matrices of order +`n+1`. The last row and column are recovered by the sum constraints. This +file makes the recovery map executable over the rationals and proves, without +any numerical tolerance, that its image has every row and column sum equal to +one. +-/ + +/-- Recover a matrix of order `n+1` from its upper-left `n`-by-`n` block. +The definition uses only finite sums and ring operations, so in particular it +maps rational coordinates to a rational matrix. -/ +def birkhoffAffineMap {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) : Matrix (Fin (n + 1)) (Fin (n + 1)) R := + Fin.snoc + (fun i ↦ Fin.snoc (Y i) (1 - βˆ‘ j, Y i j)) + (Fin.snoc + (fun j ↦ 1 - βˆ‘ i, Y i j) + ((βˆ‘ i, βˆ‘ j, Y i j) - (n - 1))) + +/-- Extract the upper-left affine coordinates from a square matrix of order +`n+1`. -/ +def birkhoffAffineCoordinates {n : β„•} {R : Type*} + (X : Matrix (Fin (n + 1)) (Fin (n + 1)) R) : + Matrix (Fin n) (Fin n) R := + fun i j ↦ X i.castSucc j.castSucc + +@[simp] theorem birkhoffAffineMap_castSucc_castSucc + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) (i j : Fin n) : + birkhoffAffineMap Y i.castSucc j.castSucc = Y i j := by + simp [birkhoffAffineMap] + +@[simp] theorem birkhoffAffineMap_castSucc_last + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) (i : Fin n) : + birkhoffAffineMap Y i.castSucc (Fin.last n) = 1 - βˆ‘ j, Y i j := by + simp [birkhoffAffineMap] + +@[simp] theorem birkhoffAffineMap_last_castSucc + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) (j : Fin n) : + birkhoffAffineMap Y (Fin.last n) j.castSucc = 1 - βˆ‘ i, Y i j := by + simp [birkhoffAffineMap] + +@[simp] theorem birkhoffAffineMap_last_last + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) : + birkhoffAffineMap Y (Fin.last n) (Fin.last n) = + (βˆ‘ i, βˆ‘ j, Y i j) - (n - 1) := by + simp [birkhoffAffineMap] + +/-- Every recovered row sums to one, identically over any commutative ring. -/ +theorem birkhoffAffineMap_row_sum + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) (i : Fin (n + 1)) : + βˆ‘ j, birkhoffAffineMap Y i j = 1 := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i + Β· rw [Fin.sum_univ_castSucc] + simp only [birkhoffAffineMap_last_castSucc, + birkhoffAffineMap_last_last] + rw [Finset.sum_sub_distrib] + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] + rw [Finset.sum_comm] + ring + Β· rw [Fin.sum_univ_castSucc] + simp + +/-- Every recovered column sums to one, identically over any commutative +ring. -/ +theorem birkhoffAffineMap_col_sum + {n : β„•} {R : Type*} [CommRing R] + (Y : Matrix (Fin n) (Fin n) R) (j : Fin (n + 1)) : + βˆ‘ i, birkhoffAffineMap Y i j = 1 := by + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· rw [Fin.sum_univ_castSucc] + simp only [birkhoffAffineMap_castSucc_last, + birkhoffAffineMap_last_last] + rw [Finset.sum_sub_distrib] + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] + ring + Β· rw [Fin.sum_univ_castSucc] + simp + +/-- A matrix in the Birkhoff affine hull is recovered exactly from its +upper-left block. -/ +theorem birkhoffAffineMap_coordinates_of_unit_sums + {n : β„•} {R : Type*} [CommRing R] + (X : Matrix (Fin (n + 1)) (Fin (n + 1)) R) + (hrow : βˆ€ i, βˆ‘ j, X i j = 1) + (hcol : βˆ€ j, βˆ‘ i, X i j = 1) : + birkhoffAffineMap (birkhoffAffineCoordinates X) = X := by + ext i j + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp only [birkhoffAffineMap_last_last, birkhoffAffineCoordinates] + have hlastCols : βˆ€ j : Fin n, + X (Fin.last n) j.castSucc = 1 - βˆ‘ i : Fin n, X i.castSucc j.castSucc := by + intro j + have h := hcol j.castSucc + rw [Fin.sum_univ_castSucc] at h + rw [← h] + ring + have hlastRow := hrow (Fin.last n) + rw [Fin.sum_univ_castSucc] at hlastRow + simp_rw [hlastCols] at hlastRow + rw [Finset.sum_sub_distrib, Finset.sum_const, Finset.card_univ, + Fintype.card_fin, nsmul_eq_mul] at hlastRow + rw [Finset.sum_comm] at hlastRow + push_cast at hlastRow ⊒ + linear_combination -hlastRow + Β· simp only [birkhoffAffineMap_last_castSucc, birkhoffAffineCoordinates] + have h := hcol j.castSucc + rw [Fin.sum_univ_castSucc] at h + rw [← h] + ring + Β· simp only [birkhoffAffineMap_castSucc_last, birkhoffAffineCoordinates] + have h := hrow i.castSucc + rw [Fin.sum_univ_castSucc] at h + rw [← h] + ring + Β· simp [birkhoffAffineCoordinates] + +/-- The affine recovery map commutes with matrix segments. -/ +theorem birkhoffAffineMap_affineCombination + {n : β„•} {t : ℝ} (Y Z : Matrix (Fin n) (Fin n) ℝ) : + birkhoffAffineMap (fun i j ↦ (1 - t) * Y i j + t * Z i j) = + fun i j ↦ (1 - t) * birkhoffAffineMap Y i j + + t * birkhoffAffineMap Z i j := by + let W : Matrix (Fin n) (Fin n) ℝ := fun i j => (1 - t) * Y i j + t * Z i j + change birkhoffAffineMap W = _ + ext i j + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· rw [birkhoffAffineMap_last_last W, birkhoffAffineMap_last_last Y, + birkhoffAffineMap_last_last Z] + simp only [W, Finset.sum_add_distrib] + have hY : + (βˆ‘ i, βˆ‘ j, (1 - t) * Y i j) = + (1 - t) * (βˆ‘ i, βˆ‘ j, Y i j) := by + calc + (βˆ‘ i, βˆ‘ j, (1 - t) * Y i j) = + βˆ‘ i, (1 - t) * βˆ‘ j, Y i j := by + apply Finset.sum_congr rfl + intro i _ + rw [Finset.mul_sum] + _ = (1 - t) * (βˆ‘ i, βˆ‘ j, Y i j) := by + rw [Finset.mul_sum] + have hZ : + (βˆ‘ i, βˆ‘ j, t * Z i j) = t * (βˆ‘ i, βˆ‘ j, Z i j) := by + calc + (βˆ‘ i, βˆ‘ j, t * Z i j) = βˆ‘ i, t * βˆ‘ j, Z i j := by + apply Finset.sum_congr rfl + intro i _ + rw [Finset.mul_sum] + _ = t * (βˆ‘ i, βˆ‘ j, Z i j) := by + rw [Finset.mul_sum] + rw [hY, hZ] + ring + Β· rw [birkhoffAffineMap_last_castSucc W j, birkhoffAffineMap_last_castSucc Y j, + birkhoffAffineMap_last_castSucc Z j] + simp only [W, Finset.sum_add_distrib] + repeat' rw [← Finset.mul_sum] + ring + Β· rw [birkhoffAffineMap_castSucc_last W i, birkhoffAffineMap_castSucc_last Y i, + birkhoffAffineMap_castSucc_last Z i] + simp only [W, Finset.sum_add_distrib] + repeat' rw [← Finset.mul_sum] + ring + Β· rw [birkhoffAffineMap_castSucc_castSucc W i j, + birkhoffAffineMap_castSucc_castSucc Y i j, birkhoffAffineMap_castSucc_castSucc Z i j] + +/-- The affine map lands in the Birkhoff affine hull exactly; only +nonnegativity remains to be checked by rational inequalities. -/ +theorem birkhoffAffineMap_has_unit_sums + {n : β„•} (Y : Matrix (Fin n) (Fin n) β„š) : + (βˆ€ i, βˆ‘ j, birkhoffAffineMap Y i j = 1) ∧ + (βˆ€ j, βˆ‘ i, birkhoffAffineMap Y i j = 1) := by + exact ⟨birkhoffAffineMap_row_sum Y, birkhoffAffineMap_col_sum Y⟩ + +/-- Rational coordinates are feasible exactly when the recovered entries are +nonnegative. -/ +theorem birkhoffAffineMap_doublyStochastic_iff + {n : β„•} (Y : Matrix (Fin n) (Fin n) β„š) : + IsDoublyStochastic + (fun i j ↦ ((birkhoffAffineMap Y i j : β„š) : ℝ)) ↔ + βˆ€ i j, 0 ≀ birkhoffAffineMap Y i j := by + constructor + Β· intro h i j + exact_mod_cast h.nonnegative i j + Β· intro h + refine ⟨?_, ?_, ?_⟩ + Β· intro i j + change 0 ≀ ((birkhoffAffineMap Y i j : β„š) : ℝ) + exact Rat.cast_nonneg.mpr (h i j) + Β· intro i + change βˆ‘ j, ((birkhoffAffineMap Y i j : β„š) : ℝ) = 1 + rw [← Rat.cast_sum] + norm_num [birkhoffAffineMap_row_sum] + Β· intro j + change βˆ‘ i, ((birkhoffAffineMap Y i j : β„š) : ℝ) = 1 + rw [← Rat.cast_sum] + norm_num [birkhoffAffineMap_col_sum] + +/-- Coordinatewise lower bounds make the recovered rational matrix an +interior doubly stochastic point. -/ +theorem birkhoffAffineMap_interior + {n : β„•} (hn : 0 < n) {Y : Matrix (Fin n) (Fin n) β„š} {Ξ΄ : β„š} + (hΞ΄ : 0 < Ξ΄) (hfloor : βˆ€ i j, Ξ΄ ≀ birkhoffAffineMap Y i j) : + IsDoublyStochastic + (fun i j ↦ ((birkhoffAffineMap Y i j : β„š) : ℝ)) ∧ + βˆ€ i, IsInteriorProbabilityVector + (fun j ↦ ((birkhoffAffineMap Y i j : β„š) : ℝ)) := by + have hds := (birkhoffAffineMap_doublyStochastic_iff Y).2 + (fun i j ↦ (hΞ΄.le.trans (hfloor i j))) + refine ⟨hds, fun i ↦ + ⟨⟨fun j ↦ hds.nonnegative i j, hds.row_sum i⟩, + fun j ↦ ⟨?_, ?_⟩⟩⟩ + Β· change 0 < ((birkhoffAffineMap Y i j : β„š) : ℝ) + exact Rat.cast_pos.mpr (hΞ΄.trans_le (hfloor i j)) + Β· exact hds.entry_lt_one_of_positive + (fun a b ↦ by exact_mod_cast hΞ΄.trans_le (hfloor a b)) + (by simp; omega) i j + +/-- In a probability row with at least two coordinates, a common entry floor +also gives the same floor for every complementary coordinate. -/ +theorem one_sub_entry_ge_of_common_floor + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) {X : Matrix ΞΉ ΞΉ ℝ} {Ξ΄ : ℝ} + (hX : IsDoublyStochastic X) (hfloor : βˆ€ i j, Ξ΄ ≀ X i j) + (i j : ΞΉ) : Ξ΄ ≀ 1 - X i j := by + obtain ⟨k, hkj⟩ := Fintype.exists_ne_of_one_lt_card hcard j + have hkMem : k ∈ Finset.univ.erase j := by + simp [hkj] + have hrest : X i k ≀ βˆ‘ l ∈ Finset.univ.erase j, X i l := by + exact Finset.single_le_sum + (fun l _ ↦ hX.nonnegative i l) hkMem + have hsum : βˆ‘ l ∈ Finset.univ.erase j, X i l = 1 - X i j := by + have htotal := hX.row_sum i + rw [← Finset.sum_erase_add _ _ (Finset.mem_univ j)] at htotal + linarith + rw [← hsum] + exact (hfloor i k).trans hrest + +/-- The uniform point has constant upper-left coordinates. -/ +def uniformAffineCoordinates (n : β„•) : Matrix (Fin n) (Fin n) β„š := + fun _ _ ↦ 1 / (n + 1) + +@[simp] theorem birkhoffAffineMap_uniformAffineCoordinates + (n : β„•) (i j : Fin (n + 1)) : + birkhoffAffineMap (uniformAffineCoordinates n) i j = 1 / (n + 1) := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp [uniformAffineCoordinates] + field_simp + ring + Β· simp [uniformAffineCoordinates] + field_simp + ring + Β· simp [uniformAffineCoordinates] + field_simp + ring + Β· simp [uniformAffineCoordinates] + +/-- In particular, the rational floor body is nonempty whenever its floor is +at most the uniform entry. -/ +theorem uniformAffineCoordinates_meets_floor + (n : β„•) {Ξ΄ : β„š} (hΞ΄ : Ξ΄ ≀ 1 / (n + 1)) : + βˆ€ i j, Ξ΄ ≀ birkhoffAffineMap (uniformAffineCoordinates n) i j := by + intro i j + simpa using hΞ΄ + +/-- Entrywise `β„“1` distance in the upper-left affine coordinates. -/ +def affineCoordinateL1Distance {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) : ℝ := + βˆ‘ i, βˆ‘ j, abs (Y i j - Z i j) + +theorem affineCoordinateL1Distance_nonneg {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) : + 0 ≀ affineCoordinateL1Distance Y Z := by + exact Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ abs_nonneg _ + +theorem affineCoordinate_abs_sub_le_l1 {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) (i j : Fin n) : + abs (Y i j - Z i j) ≀ affineCoordinateL1Distance Y Z := by + apply (Finset.single_le_sum + (fun a _ ↦ Finset.sum_nonneg fun b _ ↦ abs_nonneg (Y a b - Z a b)) + (Finset.mem_univ i)).trans' + exact Finset.single_le_sum + (fun b _ ↦ abs_nonneg (Y i b - Z i b)) (Finset.mem_univ j) + +theorem affineCoordinate_row_sum_abs_le_l1 {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) (i : Fin n) : + abs (βˆ‘ j, (Y i j - Z i j)) ≀ affineCoordinateL1Distance Y Z := by + refine (Finset.abs_sum_le_sum_abs _ _).trans ?_ + exact Finset.single_le_sum + (fun a _ ↦ Finset.sum_nonneg fun b _ ↦ abs_nonneg (Y a b - Z a b)) + (Finset.mem_univ i) + +theorem affineCoordinate_col_sum_abs_le_l1 {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) (j : Fin n) : + abs (βˆ‘ i, (Y i j - Z i j)) ≀ affineCoordinateL1Distance Y Z := by + refine (Finset.abs_sum_le_sum_abs _ _).trans ?_ + calc + βˆ‘ i, abs (Y i j - Z i j) ≀ + βˆ‘ i, βˆ‘ k, abs (Y i k - Z i k) := by + apply Finset.sum_le_sum + intro i _ + exact Finset.single_le_sum + (fun k _ ↦ abs_nonneg (Y i k - Z i k)) (Finset.mem_univ j) + _ = affineCoordinateL1Distance Y Z := rfl + +theorem affineCoordinate_total_sum_abs_le_l1 {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) : + abs (βˆ‘ i, βˆ‘ j, (Y i j - Z i j)) ≀ + affineCoordinateL1Distance Y Z := by + refine (Finset.abs_sum_le_sum_abs _ _).trans ?_ + apply Finset.sum_le_sum + intro i _ + exact Finset.abs_sum_le_sum_abs _ _ + +/-- The affine recovery map is entrywise 1-Lipschitz for the coordinate +`β„“1` distance. This single bound covers the upper-left block, recovered +row/column entries, and the corner entry. -/ +theorem birkhoffAffineMap_abs_sub_le_l1 {n : β„•} + (Y Z : Matrix (Fin n) (Fin n) ℝ) (i j : Fin (n + 1)) : + abs (birkhoffAffineMap Y i j - birkhoffAffineMap Z i j) ≀ + affineCoordinateL1Distance Y Z := by + refine Fin.lastCases ?_ (fun i ↦ ?_) i <;> + refine Fin.lastCases ?_ (fun j ↦ ?_) j + Β· simp only [birkhoffAffineMap_last_last] + have heq : + ((βˆ‘ i, βˆ‘ j, Y i j) - (n - 1 : ℝ)) - + ((βˆ‘ i, βˆ‘ j, Z i j) - (n - 1 : ℝ)) = + βˆ‘ i, βˆ‘ j, (Y i j - Z i j) := by + simp_rw [Finset.sum_sub_distrib] + ring + rw [heq] + exact affineCoordinate_total_sum_abs_le_l1 Y Z + Β· simp only [birkhoffAffineMap_last_castSucc] + have heq : + (1 - βˆ‘ i, Y i j) - (1 - βˆ‘ i, Z i j) = + -(βˆ‘ i, (Y i j - Z i j)) := by + rw [Finset.sum_sub_distrib] + ring + rw [heq, abs_neg] + exact affineCoordinate_col_sum_abs_le_l1 Y Z j + Β· simp only [birkhoffAffineMap_castSucc_last] + have heq : + (1 - βˆ‘ j, Y i j) - (1 - βˆ‘ j, Z i j) = + -(βˆ‘ j, (Y i j - Z i j)) := by + rw [Finset.sum_sub_distrib] + ring + rw [heq, abs_neg] + exact affineCoordinate_row_sum_abs_le_l1 Y Z i + Β· simpa only [birkhoffAffineMap_castSucc_castSucc] using + affineCoordinate_abs_sub_le_l1 Y Z i j + +/-- A weak optimizer may perturb the coordinate vector, but an `β„“1` +perturbation smaller than half the floor preserves an explicit positive +floor in the recovered matrix. -/ +theorem birkhoffAffineMap_floor_of_l1_near + {n : β„•} {Y Z : Matrix (Fin n) (Fin n) ℝ} {Ξ΄ Οƒ : ℝ} + (hY : βˆ€ i j, Ξ΄ ≀ birkhoffAffineMap Y i j) + (hnear : affineCoordinateL1Distance Y Z ≀ Οƒ) + (i j : Fin (n + 1)) : + Ξ΄ - Οƒ ≀ birkhoffAffineMap Z i j := by + have habs := (birkhoffAffineMap_abs_sub_le_l1 Y Z i j).trans hnear + have hupper := (abs_le.mp habs).2 + linarith [hY i j] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalCapacity.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalCapacity.lean new file mode 100644 index 0000000000..a3d1829d28 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalCapacity.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalInterior +public import Mathlib.Tactic + +/-! # Numerical Capacity -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Exact feasibility and interior mixing for capacity certificates + +These auxiliary lemmas record the feasibility-recovery argument for a generic +capacity routine. The final algorithm uses the explicit sparse witnesses in +`NumericalWitness` and therefore no longer invokes such a routine, but the +lemmas remain useful independent checks: affine mixing preserves the mass and +moment equalities, creates an explicit coordinate floor, and loses only a +controlled fraction of the entropy objective range. +-/ + +/-- Feasibility of a coefficient distribution for the entropy capacity +certificate. -/ +def IsCapacityDistribution + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] + (ΞΈ : ΞΊ β†’ ℝ) (E : ΞΊ β†’ Οƒ β†’ β„•) (Ξ± : Οƒ β†’ ℝ) : Prop := + IsProbabilityVector ΞΈ ∧ βˆ€ j, exponentMoment ΞΈ E j = Ξ± j + +/-- Coordinatewise affine interpolation of two coefficient distributions. -/ +def distributionSegment + {ΞΊ : Type*} (t : ℝ) (ΞΈ Ο† : ΞΊ β†’ ℝ) : ΞΊ β†’ ℝ := + fun e ↦ (1 - t) * ΞΈ e + t * Ο† e + +/-- Exact mass and moment constraints are preserved by rational affine +mixing. -/ +theorem distributionSegment_isCapacityDistribution + {ΞΊ Οƒ : Type*} [Fintype ΞΊ] + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {ΞΈ Ο† : ΞΊ β†’ ℝ} {E : ΞΊ β†’ Οƒ β†’ β„•} {Ξ± : Οƒ β†’ ℝ} + (hΞΈ : IsCapacityDistribution ΞΈ E Ξ±) + (hΟ† : IsCapacityDistribution Ο† E Ξ±) : + IsCapacityDistribution (distributionSegment t ΞΈ Ο†) E Ξ± := by + constructor + Β· constructor + Β· intro e + exact add_nonneg + (mul_nonneg (sub_nonneg.mpr ht1) (hΞΈ.1.nonnegative e)) + (mul_nonneg ht0 (hΟ†.1.nonnegative e)) + Β· simp_rw [distributionSegment, Finset.sum_add_distrib, + ← Finset.mul_sum, hΞΈ.1.sum_eq_one, hΟ†.1.sum_eq_one] + ring + Β· intro j + rw [exponentMoment] + simp_rw [distributionSegment, add_mul, Finset.sum_add_distrib, + mul_assoc, ← Finset.mul_sum] + rw [← exponentMoment, ← exponentMoment, hΞΈ.2 j, hΟ†.2 j] + ring + +theorem capacityCoordinate_eq + {c x : ℝ} (hc : 0 < c) : + x * Real.log (c / x) = x * Real.log c + Real.negMulLog x := by + by_cases hx0 : x = 0 + Β· simp [hx0] + Β· rw [Real.log_div hc.ne' hx0, Real.negMulLog_def] + ring + +/-- Concavity of the entropy capacity objective along a nonnegative segment. -/ +theorem entropyCapacityCertificate_segment_lower + {ΞΊ : Type*} [Fintype ΞΊ] + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {ΞΈ Ο† c : ΞΊ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΟ† : βˆ€ e, 0 ≀ Ο† e) + (hc : βˆ€ e, 0 < c e) : + (1 - t) * entropyCapacityCertificate ΞΈ c + + t * entropyCapacityCertificate Ο† c ≀ + entropyCapacityCertificate (distributionSegment t ΞΈ Ο†) c := by + simp only [entropyCapacityCertificate] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro e _ + rw [capacityCoordinate_eq (hc e), + capacityCoordinate_eq (hc e), + capacityCoordinate_eq (hc e)] + have hgap := negMulLog_segment_gap_nonneg ht0 ht1 (hΞΈ e) (hΟ† e) + dsimp only [distributionSegment] at hgap ⊒ + linarith + +/-- Mixing toward a point with coordinate floor `ρ` creates floor `tρ`. -/ +theorem distributionSegment_coordinate_floor + {ΞΊ : Type*} {t ρ : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {ΞΈ Ο† : ΞΊ β†’ ℝ} (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΟ† : βˆ€ e, ρ ≀ Ο† e) : + βˆ€ e, t * ρ ≀ distributionSegment t ΞΈ Ο† e := by + intro e + dsimp only [distributionSegment] + have hfirst : 0 ≀ (1 - t) * ΞΈ e := + mul_nonneg (sub_nonneg.mpr ht1) (hΞΈ e) + have hsecond := mul_le_mul_of_nonneg_left (hΟ† e) ht0 + linarith + +/-- The objective loss under interior mixing is at most the mixing weight +times the objective range between the two endpoints. -/ +theorem entropyCapacityCertificate_sub_segment_le + {ΞΊ : Type*} [Fintype ΞΊ] + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {ΞΈ Ο† c : ΞΊ β†’ ℝ} + (hΞΈ : βˆ€ e, 0 ≀ ΞΈ e) (hΟ† : βˆ€ e, 0 ≀ Ο† e) + (hc : βˆ€ e, 0 < c e) : + entropyCapacityCertificate ΞΈ c - + entropyCapacityCertificate (distributionSegment t ΞΈ Ο†) c ≀ + t * (entropyCapacityCertificate ΞΈ c - + entropyCapacityCertificate Ο† c) := by + have hconc := entropyCapacityCertificate_segment_lower ht0 ht1 hΞΈ hΟ† hc + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalInterior.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalInterior.lean new file mode 100644 index 0000000000..0298447dcf --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalInterior.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import Mathlib.Tactic + +/-! # Numerical Interior -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Quantitative interiority of the regularized optimizer + +This file proves the analytic part of the finite-precision truncation used by +the algorithm. The bounds are deliberately elementary: `x log x` terms are +controlled by entropy and by `negMulLog x ≀ 1 - x`. +-/ + +/-- A convenient range bound for the unregularized Bethe objective when all +matrix entries lie in `[m,1]`. -/ +noncomputable def numericalObjectiveRange (n : β„•) (m : ℝ) : ℝ := + n * Real.log (1 / m) + n * Real.log n + n + +/-- On a matrix with entries at most one, the Bethe objective is at most the +total row entropy. -/ +theorem betheObjective_le_totalRowEntropy + {n : Type*} [Fintype n] [DecidableEq n] + {A X : Matrix n n ℝ} (hApos : Matrix.Positive A) + (hAupper : βˆ€ i j, A i j ≀ 1) (hX : IsDoublyStochastic X) : + betheObjective A X ≀ totalRowEntropy X := by + simp only [betheObjective, betheRowObjective, totalRowEntropy, + shannonEntropy] + apply Finset.sum_le_sum + intro i _ + apply Finset.sum_le_sum + intro j _ + have hlogA : Real.log (A i j) ≀ 0 := + Real.log_nonpos (hApos i j).le (hAupper i j) + have hlinear : X i j * Real.log (A i j) ≀ 0 := + mul_nonpos_of_nonneg_of_nonpos (hX.nonnegative i j) hlogA + have hcomp : (1 - X i j) * Real.log (1 - X i j) ≀ 0 := + Real.mul_log_nonpos (sub_nonneg.mpr (hX.entry_le_one i j)) + (by linarith [hX.nonnegative i j]) + linarith + +/-- A lower bound on the Bethe objective using only a common lower bound on +the entries of the input matrix. -/ +theorem betheObjective_lower_of_entry_lower + {n : Type*} [Fintype n] [DecidableEq n] + {m : ℝ} (hm : 0 < m) {A X : Matrix n n ℝ} + (hAlower : βˆ€ i j, m ≀ A i j) (hX : IsDoublyStochastic X) : + Fintype.card n * Real.log m - Fintype.card n ≀ + betheObjective A X := by + simp only [betheObjective, betheRowObjective] + calc + Fintype.card n * Real.log m - Fintype.card n = + βˆ‘ _i : n, (Real.log m - 1) := by + simp [nsmul_eq_mul] + _ ≀ βˆ‘ i, βˆ‘ j, + (X i j * Real.log (A i j) + Real.negMulLog (X i j) + + (1 - X i j) * Real.log (1 - X i j)) := by + apply Finset.sum_le_sum + intro i _ + have hrow : Real.log m - 1 = βˆ‘ j, (X i j * Real.log m - X i j) := by + rw [Finset.sum_sub_distrib, ← Finset.sum_mul, hX.row_sum] + ring + rw [hrow] + apply Finset.sum_le_sum + intro j _ + have hlog : Real.log m ≀ Real.log (A i j) := + Real.log_le_log hm (hAlower i j) + have hlinear : X i j * Real.log m ≀ + X i j * Real.log (A i j) := + mul_le_mul_of_nonneg_left hlog (hX.nonnegative i j) + have hentropy : 0 ≀ Real.negMulLog (X i j) := + Real.negMulLog_nonneg (hX.nonnegative i j) (hX.entry_le_one i j) + have hcompNonneg : 0 ≀ 1 - X i j := + sub_nonneg.mpr (hX.entry_le_one i j) + have hcomp := Real.negMulLog_le_one_sub_self hcompNonneg + rw [Real.negMulLog_def] at hcomp + linarith + +/-- The unregularized objective changes by at most +`numericalObjectiveRange` between a feasible point and the Birkhoff +barycenter. -/ +theorem betheObjective_sub_uniform_le_range + {n : β„•} (hn : 1 < n) {m : ℝ} (hm : 0 < m) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hApos : Matrix.Positive A) (hAlower : βˆ€ i j, m ≀ A i j) + (hAupper : βˆ€ i j, A i j ≀ 1) (hX : IsDoublyStochastic X) : + betheObjective A X - betheObjective A (uniformBirkhoff n) ≀ + numericalObjectiveRange n m := by + have hn0 : 0 < n := by omega + letI : Nonempty (Fin n) := ⟨⟨0, hn0⟩⟩ + have hW := uniformBirkhoff_doublyStochastic hn0 + have hupper := (betheObjective_le_totalRowEntropy hApos hAupper hX).trans + (by simpa using totalRowEntropy_le hX) + have hlower := betheObjective_lower_of_entry_lower hm hAlower hW + have hloginv : Real.log (1 / m) = -Real.log m := by + rw [one_div, Real.log_inv] + dsimp only [numericalObjectiveRange] + rw [hloginv] + simp only [Fintype.card_fin] at hupper hlower + linarith + +/-- The directional entropy derivative from an interior regularized maximizer +toward the Birkhoff barycenter is controlled by the unregularized objective +range. -/ +theorem entropy_direction_to_uniform_mul_le_range + {n : β„•} (hn : 1 < n) {Ο„ m : ℝ} (hΟ„ : 0 < Ο„) (hm : 0 < m) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hApos : Matrix.Positive A) (hAlower : βˆ€ i j, m ≀ A i j) + (hAupper : βˆ€ i j, A i j ≀ 1) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ regularizedBetheObjective Ο„ A X) : + Ο„ * (βˆ‘ i, βˆ‘ j, (-1 - Real.log (X i j)) * + (uniformBirkhoff n i j - X i j)) ≀ + numericalObjectiveRange n m := by + have hW : IsDoublyStochastic (uniformBirkhoff n) := + uniformBirkhoff_doublyStochastic (show 0 < n by omega) + have hXint := regularizedBetheMaximizer_interior hn hΟ„ hApos hX hmax + have hDrow : βˆ€ i, βˆ‘ j, (uniformBirkhoff n i j - X i j) = 0 := by + intro i + simp_rw [Finset.sum_sub_distrib, hW.row_sum, hX.row_sum, sub_self] + have hDcol : βˆ€ j, βˆ‘ i, (uniformBirkhoff n i j - X i j) = 0 := by + intro j + simp_rw [Finset.sum_sub_distrib, hW.col_sum, hX.col_sum, sub_self] + have hstationary := regularizedBetheMaximizer_tangent_orthogonal + (D := fun i j ↦ uniformBirkhoff n i j - X i j) + hX hXint hmax hDrow hDcol + have hsupport := regularizedBetheObjective_sub_le_gradient + (A := A) (X := X) (Y := uniformBirkhoff n) (Ο„ := 0) + (by simpa using hn) (by norm_num) hX hW hXint + have hbetaLower : -numericalObjectiveRange n m ≀ + betheObjective A (uniformBirkhoff n) - betheObjective A X := by + have hrange := betheObjective_sub_uniform_le_range hn hm hApos + hAlower hAupper hX + linarith + have hbetheDirectional : -numericalObjectiveRange n m ≀ + βˆ‘ i, βˆ‘ j, regularizedBetheGradient 0 A X i j * + (uniformBirkhoff n i j - X i j) := by + rw [regularizedBetheObjective, regularizedBetheObjective] at hsupport + simp only [zero_mul, add_zero] at hsupport + exact hbetaLower.trans hsupport + have hgradient : βˆ€ i j, + regularizedBetheGradient Ο„ A X i j = + regularizedBetheGradient 0 A X i j + + Ο„ * (-1 - Real.log (X i j)) := by + intro i j + simp only [regularizedBetheGradient] + ring + have hdecomp : + (βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * + (uniformBirkhoff n i j - X i j)) = + (βˆ‘ i, βˆ‘ j, regularizedBetheGradient 0 A X i j * + (uniformBirkhoff n i j - X i j)) + + Ο„ * (βˆ‘ i, βˆ‘ j, (-1 - Real.log (X i j)) * + (uniformBirkhoff n i j - X i j)) := by + rw [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro j _ + rw [hgradient] + ring + rw [hdecomp] at hstationary + linarith + +/-- Exact formula for the entropy directional derivative toward the Birkhoff +barycenter. -/ +theorem entropy_direction_to_uniform_eq + {n : β„•} (hn : 0 < n) {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) : + (βˆ‘ i, βˆ‘ j, (-1 - Real.log (X i j)) * + (uniformBirkhoff n i j - X i j)) = + -totalRowEntropy X - + (1 / n) * (βˆ‘ i, βˆ‘ j, Real.log (X i j)) := by + let W := uniformBirkhoff n + have hW : IsDoublyStochastic W := uniformBirkhoff_doublyStochastic hn + have htotalDiff : βˆ‘ i, βˆ‘ j, (X i j - W i j) = 0 := by + simp_rw [Finset.sum_sub_distrib, hX.row_sum, hW.row_sum, sub_self] + have hentropy : (βˆ‘ i, βˆ‘ j, X i j * Real.log (X i j)) = + -totalRowEntropy X := by + rw [totalRowEntropy, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [shannonEntropy, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro j _ + rw [Real.negMulLog_def] + ring + have hWlog : (βˆ‘ i, βˆ‘ j, W i j * Real.log (X i j)) = + (1 / n) * (βˆ‘ i, βˆ‘ j, Real.log (X i j)) := by + dsimp only [W, uniformBirkhoff] + simp_rw [← Finset.mul_sum] + change (βˆ‘ i, βˆ‘ j, (-1 - Real.log (X i j)) * + (W i j - X i j)) = _ + calc + (βˆ‘ i, βˆ‘ j, (-1 - Real.log (X i j)) * (W i j - X i j)) = + (βˆ‘ i, βˆ‘ j, X i j * Real.log (X i j)) - + (βˆ‘ i, βˆ‘ j, W i j * Real.log (X i j)) + + βˆ‘ i, βˆ‘ j, (X i j - W i j) := by + rw [← Finset.sum_sub_distrib, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_sub_distrib, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro j _ + ring + _ = -totalRowEntropy X - + (1 / n) * (βˆ‘ i, βˆ‘ j, Real.log (X i j)) := by + rw [hentropy, hWlog, htotalDiff, add_zero] + +/-- Quantitative form of the interior bound. Every coordinate, not merely a +chosen minimum, obeys the same estimate. -/ +theorem regularizedBetheMaximizer_log_inv_entry_le + {n : β„•} (hn : 1 < n) {Ο„ m : ℝ} (hΟ„ : 0 < Ο„) (hm : 0 < m) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hApos : Matrix.Positive A) (hAlower : βˆ€ i j, m ≀ A i j) + (hAupper : βˆ€ i j, A i j ≀ 1) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ regularizedBetheObjective Ο„ A X) + (iβ‚€ jβ‚€ : Fin n) : + Real.log (1 / X iβ‚€ jβ‚€) ≀ + n * numericalObjectiveRange n m / Ο„ + n ^ 2 * Real.log n := by + have hn0 : 0 < n := by omega + letI : Nonempty (Fin n) := ⟨⟨0, hn0⟩⟩ + have hXint := regularizedBetheMaximizer_interior hn hΟ„ hApos hX hmax + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hdir := entropy_direction_to_uniform_mul_le_range hn hΟ„ hm + hApos hAlower hAupper hX hmax + rw [entropy_direction_to_uniform_eq hn0 hX] at hdir + have hentropy := totalRowEntropy_le hX + have hlognonpos : βˆ€ i j, Real.log (X i j) ≀ 0 := fun i j ↦ + Real.log_nonpos (hX.nonnegative i j) (hX.entry_le_one i j) + have hchosen : -Real.log (X iβ‚€ jβ‚€) ≀ + -(βˆ‘ i, βˆ‘ j, Real.log (X i j)) := by + have hnonneg : βˆ€ i j, 0 ≀ -Real.log (X i j) := fun i j ↦ + neg_nonneg.mpr (hlognonpos i j) + have hsingle : -Real.log (X iβ‚€ jβ‚€) ≀ + βˆ‘ j, -Real.log (X iβ‚€ j) := + Finset.single_le_sum (fun j _ ↦ hnonneg iβ‚€ j) (Finset.mem_univ jβ‚€) + have hrow : βˆ‘ j, -Real.log (X iβ‚€ j) ≀ + βˆ‘ i, βˆ‘ j, -Real.log (X i j) := + Finset.single_le_sum + (fun i _ ↦ Finset.sum_nonneg fun j _ ↦ hnonneg i j) + (Finset.mem_univ iβ‚€) + simpa only [Finset.sum_neg_distrib] using hsingle.trans hrow + have hloginv : Real.log (1 / X iβ‚€ jβ‚€) = -Real.log (X iβ‚€ jβ‚€) := by + rw [one_div, Real.log_inv] + have hnR : (0 : ℝ) < n := by exact_mod_cast hn0 + rw [hloginv] + simp only [Fintype.card_fin] at hentropy + have hscaledChosen := mul_le_mul_of_nonneg_left hchosen + (by positivity : 0 ≀ (1 / (n : ℝ))) + have hdirLower : + -(n : ℝ) * Real.log n + (1 / n) * (-Real.log (X iβ‚€ jβ‚€)) ≀ + -totalRowEntropy X - + (1 / n) * (βˆ‘ i, βˆ‘ j, Real.log (X i j)) := by + linarith + have hcore : Ο„ * (-(n : ℝ) * Real.log n + + (1 / n) * (-Real.log (X iβ‚€ jβ‚€))) ≀ + numericalObjectiveRange n m := + (mul_le_mul_of_nonneg_left hdirLower hΟ„.le).trans hdir + have hmul := mul_le_mul_of_nonneg_left hcore hnR.le + have halgebra : + (n : ℝ) * (Ο„ * (-(n : ℝ) * Real.log n + + (1 / n) * (-Real.log (X iβ‚€ jβ‚€)))) = + Ο„ * (-Real.log (X iβ‚€ jβ‚€) - + (n : ℝ) ^ 2 * Real.log n) := by + field_simp [hnR.ne'] + ring + rw [halgebra] at hmul + have hmul' : + (-Real.log (X iβ‚€ jβ‚€) - (n : ℝ) ^ 2 * Real.log n) * Ο„ ≀ + (n : ℝ) * numericalObjectiveRange n m := by + simpa only [mul_comm] using hmul + have hdiv := (le_div_iffβ‚€ hΟ„).2 hmul' + linarith + +/-- The complementary coordinates obey the same logarithmic bit bound. -/ +theorem regularizedBetheMaximizer_log_inv_one_sub_entry_le + {n : β„•} (hn : 1 < n) {Ο„ m : ℝ} (hΟ„ : 0 < Ο„) (hm : 0 < m) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hApos : Matrix.Positive A) (hAlower : βˆ€ i j, m ≀ A i j) + (hAupper : βˆ€ i j, A i j ≀ 1) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ regularizedBetheObjective Ο„ A X) + (iβ‚€ jβ‚€ : Fin n) : + Real.log (1 / (1 - X iβ‚€ jβ‚€)) ≀ + n * numericalObjectiveRange n m / Ο„ + n ^ 2 * Real.log n := by + obtain ⟨k, hkj⟩ := Fintype.exists_ne_of_one_lt_card + (by simpa using hn) jβ‚€ + have hXint := regularizedBetheMaximizer_interior hn hΟ„ hApos hX hmax + have hkpos : 0 < X iβ‚€ k := (hXint iβ‚€).2 k |>.1 + have hcompPos : 0 < 1 - X iβ‚€ jβ‚€ := + sub_pos.mpr ((hXint iβ‚€).2 jβ‚€ |>.2) + have hpair : X iβ‚€ jβ‚€ + X iβ‚€ k ≀ 1 := by + rw [← hX.row_sum iβ‚€] + calc + X iβ‚€ jβ‚€ + X iβ‚€ k = + βˆ‘ l ∈ ({jβ‚€, k} : Finset (Fin n)), X iβ‚€ l := by + rw [Finset.sum_pair hkj.symm] + _ ≀ βˆ‘ l, X iβ‚€ l := + Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) + (fun l _ _ ↦ hX.nonnegative iβ‚€ l) + have hkcomp : X iβ‚€ k ≀ 1 - X iβ‚€ jβ‚€ := by linarith + have hinv : 1 / (1 - X iβ‚€ jβ‚€) ≀ 1 / X iβ‚€ k := + one_div_le_one_div_of_le hkpos hkcomp + exact (Real.log_le_log (one_div_pos.mpr hcompPos) hinv).trans + (regularizedBetheMaximizer_log_inv_entry_le hn hΟ„ hm hApos + hAlower hAupper hX hmax iβ‚€ k) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalNearby.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalNearby.lean new file mode 100644 index 0000000000..37f8ba2e71 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalNearby.lean @@ -0,0 +1,305 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalScales +public import Mathlib.Tactic + +/-! # Numerical Nearby -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The nearby-matrix step in certified optimization + +An approximate KKT point for a rational input matrix is turned into an exact +KKT point for a nearby positive real matrix. This file proves the sign and +normalization-sensitive comparison used to transfer the permanent estimate +back to the input matrix. +-/ + +/-- Matrix for which the proposed point and potentials satisfy the +multiplicative KKT equations exactly. -/ +noncomputable def nearbyKKTMatrix + {ΞΉ : Type*} (Ο„ : ℝ) (X : Matrix ΞΉ ΞΉ ℝ) (r c : ΞΉ β†’ ℝ) : + Matrix ΞΉ ΞΉ ℝ := + fun i j ↦ Real.exp (r i + c j) * + (X i j) ^ (1 + Ο„) * (1 - X i j) + +/-- Coordinatewise approximate logarithmic KKT equations. -/ +def HasApproximateLogKKT + {ΞΉ : Type*} [Fintype ΞΉ] + (Ξ΅ Ο„ : ℝ) (A X : Matrix ΞΉ ΞΉ ℝ) (r c : ΞΉ β†’ ℝ) : Prop := + βˆ€ i j, abs (Real.log (A i j) - + (r i + c j + (1 + Ο„) * Real.log (X i j) + + Real.log (1 - X i j))) ≀ Ξ΅ + +theorem nearbyKKTMatrix_positive + {ΞΉ : Type*} {Ο„ : ℝ} {X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) : + Matrix.Positive (nearbyKKTMatrix Ο„ X r c) := by + intro i j + exact mul_pos (mul_pos (Real.exp_pos _) (Real.rpow_pos_of_pos (hXpos i j) _)) + (sub_pos.mpr (hXlt i j)) + +theorem log_nearbyKKTMatrix + {ΞΉ : Type*} {Ο„ : ℝ} {X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) (i j : ΞΉ) : + Real.log (nearbyKKTMatrix Ο„ X r c i j) = + r i + c j + (1 + Ο„) * Real.log (X i j) + + Real.log (1 - X i j) := by + have hx := hXpos i j + have hc : 0 < 1 - X i j := sub_pos.mpr (hXlt i j) + rw [nearbyKKTMatrix, + Real.log_mul + (mul_ne_zero (Real.exp_pos _).ne' + (Real.rpow_pos_of_pos hx _).ne') hc.ne', + Real.log_mul (Real.exp_pos _).ne' + (Real.rpow_pos_of_pos hx _).ne', + Real.log_exp, Real.log_rpow hx] + +theorem nearbyKKTMatrix_hasLogKKT + {ΞΉ : Type*} [Fintype ΞΉ] + {Ο„ : ℝ} {X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) : + HasLogKKT Ο„ (nearbyKKTMatrix Ο„ X r c) X r c := by + intro i j + exact log_nearbyKKTMatrix hXpos hXlt i j + +theorem approximateLogKKT_nearby_log_bounds + {ΞΉ : Type*} [Fintype ΞΉ] + {Ξ΅ Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (happrox : HasApproximateLogKKT Ξ΅ Ο„ A X r c) + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) (i j : ΞΉ) : + Real.log (nearbyKKTMatrix Ο„ X r c i j) - Ξ΅ ≀ + Real.log (A i j) ∧ + Real.log (A i j) ≀ + Real.log (nearbyKKTMatrix Ο„ X r c i j) + Ξ΅ := by + have h := (abs_le.mp (happrox i j)) + rw [← log_nearbyKKTMatrix hXpos hXlt i j] at h + constructor <;> linarith + +theorem approximateLogKKT_entrywise_comparison + {ΞΉ : Type*} [Fintype ΞΉ] + {Ξ΅ Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hApos : Matrix.Positive A) + (happrox : HasApproximateLogKKT Ξ΅ Ο„ A X r c) + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) (i j : ΞΉ) : + Real.exp (-Ξ΅) * nearbyKKTMatrix Ο„ X r c i j ≀ A i j ∧ + A i j ≀ Real.exp Ξ΅ * nearbyKKTMatrix Ο„ X r c i j := by + have hnearPos := nearbyKKTMatrix_positive + (Ο„ := Ο„) (r := r) (c := c) hXpos hXlt i j + obtain ⟨hlower, hupper⟩ := approximateLogKKT_nearby_log_bounds + happrox hXpos hXlt i j + have hlowerExp := Real.exp_le_exp.mpr hlower + have hupperExp := Real.exp_le_exp.mpr hupper + rw [Real.exp_sub, Real.exp_log hnearPos, Real.exp_log (hApos i j)] at hlowerExp + rw [Real.exp_add, Real.exp_log hnearPos, Real.exp_log (hApos i j)] at hupperExp + simpa [div_eq_mul_inv, Real.exp_neg, mul_comm] using + And.intro hlowerExp hupperExp + +theorem approximateLogKKT_permanent_comparison + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ξ΅ Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hApos : Matrix.Positive A) + (happrox : HasApproximateLogKKT Ξ΅ Ο„ A X r c) + (hXpos : βˆ€ i j, 0 < X i j) + (hXlt : βˆ€ i j, X i j < 1) : + (Real.exp (-Ξ΅)) ^ Fintype.card ΞΉ * + Matrix.permanent (nearbyKKTMatrix Ο„ X r c) ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.exp Ξ΅) ^ Fintype.card ΞΉ * + Matrix.permanent (nearbyKKTMatrix Ο„ X r c) := by + let A' := nearbyKKTMatrix Ο„ X r c + have hA'pos : Matrix.Positive A' := nearbyKKTMatrix_positive hXpos hXlt + have hlowerEntries : βˆ€ i j, Real.exp (-Ξ΅) * A' i j ≀ A i j := + fun i j ↦ (approximateLogKKT_entrywise_comparison hApos happrox + hXpos hXlt i j).1 + have hupperEntries : βˆ€ i j, A i j ≀ Real.exp Ξ΅ * A' i j := + fun i j ↦ (approximateLogKKT_entrywise_comparison hApos happrox + hXpos hXlt i j).2 + have hA0 : Matrix.Nonnegative A := fun i j ↦ (hApos i j).le + have hA'0 : Matrix.Nonnegative A' := fun i j ↦ (hA'pos i j).le + constructor + Β· rw [← Matrix.permanent_scale_real] + exact Matrix.permanent_mono_real + (fun i j ↦ mul_nonneg (Real.exp_pos _).le (hA'0 i j)) + hlowerEntries + Β· rw [← Matrix.permanent_scale_real] + exact Matrix.permanent_mono_real hA0 hupperEntries + +/-- Row entropy is concave along a matrix segment. -/ +theorem totalRowEntropy_segment_lower + {ΞΉ : Type*} [Fintype ΞΉ] + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : Matrix.Nonnegative X) (hY : Matrix.Nonnegative Y) : + (1 - t) * totalRowEntropy X + t * totalRowEntropy Y ≀ + totalRowEntropy (matrixSegment t X Y) := by + simp only [totalRowEntropy, shannonEntropy] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro i _ + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro j _ + have hgap := negMulLog_segment_gap_nonneg ht0 ht1 (hX i j) (hY i j) + dsimp only [matrixSegment] + linarith + +/-- Concavity of the entropy-regularized Bethe objective on the Birkhoff +polytope. -/ +theorem regularizedBetheObjective_segment_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ t : ℝ} (hΟ„ : 0 ≀ Ο„) (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + (A : Matrix ΞΉ ΞΉ ℝ) {X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) : + (1 - t) * regularizedBetheObjective Ο„ A X + + t * regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A (matrixSegment t X Y) := by + have hbethe := betheObjective_segment_lower hcard A X Y hX hY ht0 ht1 + have hsegment : betheMatrixSegment t X Y = matrixSegment t X Y := by + ext i j + rfl + rw [hsegment] at hbethe + have hentropy := totalRowEntropy_segment_lower ht0 ht1 + hX.nonnegative hY.nonnegative + have hscaled := mul_le_mul_of_nonneg_left hentropy hΟ„ + rw [regularizedBetheObjective, regularizedBetheObjective, + regularizedBetheObjective] + nlinarith + +/-- The one-dimensional restriction of the regularized objective to any +Birkhoff segment is concave. -/ +theorem regularizedBetheObjective_line_concave + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) (A : Matrix ΞΉ ΞΉ ℝ) + {X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) : + ConcaveOn ℝ (Set.Icc (0 : ℝ) 1) + (fun t ↦ regularizedBetheObjective Ο„ A (matrixSegment t X Y)) := by + refine ⟨convex_Icc 0 1, ?_⟩ + intro x hx y hy a b ha hb hab + have hsegX := matrixSegment_doublyStochastic hx.1 hx.2 hX hY + have hsegY := matrixSegment_doublyStochastic hy.1 hy.2 hX hY + have hb1 : b ≀ 1 := by linarith + have hmain := regularizedBetheObjective_segment_lower hcard hΟ„ hb hb1 A + hsegX hsegY + have hweight : 1 - b = a := by linarith + have hnested : matrixSegment b (matrixSegment x X Y) + (matrixSegment y X Y) = matrixSegment (a * x + b * y) X Y := by + ext i j + dsimp only [matrixSegment] + rw [hweight] + linear_combination (X i j) * hab + simpa only [smul_eq_mul, hweight, hnested] using hmain + +/-- First-order upper support inequality for the regularized objective. -/ +theorem regularizedBetheObjective_sub_le_gradient + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {A X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) : + regularizedBetheObjective Ο„ A Y - regularizedBetheObjective Ο„ A X ≀ + βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * (Y i j - X i j) := by + have hderiv : HasDerivAt + (fun t ↦ regularizedBetheObjective Ο„ A (matrixSegment t X Y)) + (βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * + (Y i j - X i j)) 0 := by + have hbase := hasDerivAt_regularizedBetheObjective_line + (Ο„ := Ο„) (A := A) (X := X) + (D := fun i j ↦ Y i j - X i j) hXint + convert hbase using 1 + funext t + congr 1 + ext i j + dsimp only [matrixSegment, linearMatrixPerturb] + ring + have hconc := regularizedBetheObjective_line_concave + hcard hΟ„ A hX hY + have hslope := hconc.slope_le_of_hasDerivAt + (Set.mem_Icc.mpr ⟨le_rfl, by norm_num⟩) + (Set.mem_Icc.mpr ⟨by norm_num, le_rfl⟩) + (by norm_num : (0 : ℝ) < 1) hderiv + have hzero : matrixSegment 0 X Y = X := by + ext i j + simp [matrixSegment] + have hone : matrixSegment 1 X Y = Y := by + ext i j + simp [matrixSegment] + simpa [slope, hzero, hone] using hslope + +/-- Exact logarithmic KKT equations are sufficient for global optimality of +the regularized objective. -/ +theorem regularizedBetheObjective_le_of_logKKT + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {A X : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r c : ΞΉ β†’ ℝ} (hKKT : HasLogKKT Ο„ A X r c) : + βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X := by + intro Y hY + have hsupport := regularizedBetheObjective_sub_le_gradient + (A := A) hcard hΟ„ hX hY hXint + have hgrad : βˆ€ i j, regularizedBetheGradient Ο„ A X i j = + r i + c j - (2 + Ο„) := by + intro i j + specialize hKKT i j + dsimp only [regularizedBetheGradient] + linarith + have hzero : + βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * + (Y i j - X i j) = 0 := by + simp_rw [hgrad] + have hpot := rowColumnPotential_sum_eq hY hX + (fun i ↦ r i - (2 + Ο„)) c + have hpot' : + (βˆ‘ i, βˆ‘ j, (r i + c j - (2 + Ο„)) * Y i j) = + βˆ‘ i, βˆ‘ j, (r i + c j - (2 + Ο„)) * X i j := by + convert hpot using 1 <;> + apply Finset.sum_congr rfl <;> intro i _ <;> + apply Finset.sum_congr rfl <;> intro j _ <;> ring + calc + (βˆ‘ i, βˆ‘ j, (r i + c j - (2 + Ο„)) * (Y i j - X i j)) = + (βˆ‘ i, βˆ‘ j, (r i + c j - (2 + Ο„)) * Y i j) - + βˆ‘ i, βˆ‘ j, (r i + c j - (2 + Ο„)) * X i j := by + simp_rw [mul_sub, Finset.sum_sub_distrib] + _ = 0 := sub_eq_zero.mpr hpot' + linarith + +/-- The nearby KKT matrix makes the proposed interior doubly stochastic point +an exact regularized optimizer. -/ +theorem nearbyKKTMatrix_exact_optimizer + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {X : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (r c : ΞΉ β†’ ℝ) : + βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ (nearbyKKTMatrix Ο„ X r c) Y ≀ + regularizedBetheObjective Ο„ (nearbyKKTMatrix Ο„ X r c) X := by + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hXlt : βˆ€ i j, X i j < 1 := fun i j ↦ (hXint i).2 j |>.2 + exact regularizedBetheObjective_le_of_logKKT hcard hΟ„ hX hXint + (nearbyKKTMatrix_hasLogKKT hXpos hXlt) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalPotentials.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalPotentials.lean new file mode 100644 index 0000000000..f536ace4b9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalPotentials.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalTransfer +public import Mathlib.Tactic + +/-! # Numerical Potentials -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Explicit row and column potentials + +Least-squares projection is unnecessary in the numerical argument. Fixing +one row and one column gives an explicit rational recovery map. Exact +row-plus-column matrices are recovered identically, while a coordinatewise +perturbation of size `delta` creates residual at most `4 * delta`. +-/ + +/-- Row potentials anchored at one column. -/ +def anchoredRowPotential + {ΞΉ ΞΊ : Type*} (G : Matrix ΞΉ ΞΊ ℝ) (j0 : ΞΊ) : ΞΉ β†’ ℝ := + fun i ↦ G i j0 + +/-- Column potentials anchored at one row and normalized to vanish at the +anchor column. -/ +def anchoredColumnPotential + {ΞΉ ΞΊ : Type*} (G : Matrix ΞΉ ΞΊ ℝ) (i0 : ΞΉ) (j0 : ΞΊ) : ΞΊ β†’ ℝ := + fun j ↦ G i0 j - G i0 j0 + +theorem anchoredPotentials_exact + {ΞΉ ΞΊ : Type*} (r : ΞΉ β†’ ℝ) (c : ΞΊ β†’ ℝ) + (i0 : ΞΉ) (j0 : ΞΊ) (i : ΞΉ) (j : ΞΊ) : + anchoredRowPotential (fun a b ↦ r a + c b) j0 i + + anchoredColumnPotential (fun a b ↦ r a + c b) i0 j0 j = + r i + c j := by + simp [anchoredRowPotential, anchoredColumnPotential] + +theorem abs_sub_sub_add_le_four + {a b c d Ξ΄ : ℝ} + (ha : abs a ≀ Ξ΄) (hb : abs b ≀ Ξ΄) + (hc : abs c ≀ Ξ΄) (hd : abs d ≀ Ξ΄) : + abs (a - b - c + d) ≀ 4 * Ξ΄ := by + calc + abs (a - b - c + d) = abs ((a - b) + (d - c)) := by ring + _ ≀ abs (a - b) + abs (d - c) := abs_add_le _ _ + _ ≀ (abs a + abs b) + (abs d + abs c) := + add_le_add (abs_sub a b) (abs_sub d c) + _ ≀ 4 * Ξ΄ := by linarith + +/-- Anchored potentials turn coordinatewise proximity to a row-plus-column +matrix into a coordinatewise KKT residual. -/ +theorem anchoredPotentials_residual_le + {ΞΉ ΞΊ : Type*} {G Gstar : Matrix ΞΉ ΞΊ ℝ} + {r : ΞΉ β†’ ℝ} {c : ΞΊ β†’ ℝ} {Ξ΄ : ℝ} + (hstar : βˆ€ i j, Gstar i j = r i + c j) + (hclose : βˆ€ i j, abs (G i j - Gstar i j) ≀ Ξ΄) + (i0 : ΞΉ) (j0 : ΞΊ) (i : ΞΉ) (j : ΞΊ) : + abs (G i j - + (anchoredRowPotential G j0 i + + anchoredColumnPotential G i0 j0 j)) ≀ 4 * Ξ΄ := by + have hid : G i j - + (anchoredRowPotential G j0 i + + anchoredColumnPotential G i0 j0 j) = + (G i j - Gstar i j) - (G i j0 - Gstar i j0) - + (G i0 j - Gstar i0 j) + (G i0 j0 - Gstar i0 j0) := by + simp only [anchoredRowPotential, anchoredColumnPotential] + rw [hstar i j, hstar i j0, hstar i0 j, hstar i0 j0] + ring + rw [hid] + exact abs_sub_sub_add_le_four + (hclose i j) (hclose i j0) (hclose i0 j) (hclose i0 j0) + +/-- If `Gtilde` is a rational approximation to a computable gradient `G`, +the same anchored potentials have residual `evaluationError + 4 * modelError` +for `G`. The statement separates elementary-function evaluation error from +the optimization error that moves the gradient away from the exact KKT +subspace. -/ +theorem anchoredPotentials_residual_of_evaluation + {ΞΉ ΞΊ : Type*} {G Gtilde Gstar : Matrix ΞΉ ΞΊ ℝ} + {r : ΞΉ β†’ ℝ} {c : ΞΊ β†’ ℝ} {modelError evaluationError : ℝ} + (hstar : βˆ€ i j, Gstar i j = r i + c j) + (hmodel : βˆ€ i j, abs (Gtilde i j - Gstar i j) ≀ modelError) + (heval : βˆ€ i j, abs (G i j - Gtilde i j) ≀ evaluationError) + (i0 : ΞΉ) (j0 : ΞΊ) (i : ΞΉ) (j : ΞΊ) : + abs (G i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j)) ≀ + evaluationError + 4 * modelError := by + have hres := anchoredPotentials_residual_le + hstar hmodel i0 j0 i j + have htriangle : abs (G i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j)) ≀ + abs (G i j - Gtilde i j) + + abs (Gtilde i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j)) := by + have hid : (G i j - Gtilde i j) + + (Gtilde i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j)) = + G i j - + (anchoredRowPotential Gtilde j0 i + + anchoredColumnPotential Gtilde i0 j0 j) := by ring + rw [← hid] + exact abs_add_le _ _ + exact htriangle.trans (add_le_add (heval i j) hres) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalScales.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalScales.lean new file mode 100644 index 0000000000..dfb51a793a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalScales.lean @@ -0,0 +1,486 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NearCase +public import Mathlib.Algebra.Order.Archimedean.Basic + +/-! # Numerical Scales -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Rational structural scales for the numerical algorithm + +The qualitative completion theorem chooses its hierarchy of constants in +`ℝ`. That is sufficient for the mathematical approximation theorem, but an +algorithm cannot use an unspecified real regularization parameter. This file +repeats the choice with rational points at every open step. The resulting +constants can be hard-coded in a Turing machine and the regularization scale +`ΞΎ / (4n)` is rational on every input dimension. +-/ + +/-- Rational data satisfying exactly the scale inequalities consumed by the +positive-matrix dichotomy. Analytic expressions are compared after casting +the rational constants to `ℝ`. -/ +structure RationalCompletionScales (ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š) where + /-- The positive rational concentration parameter, constrained by the certificate to be at + most one-tenth. -/ + Ξ· : β„š + /-- The positive rational error scale controlling the row, cycle, and transfer smallness + estimates. -/ + Ξ΄ : β„š + /-- The positive rational regularization numerator, bounded by the source scale and chosen + below the error and gain margins. -/ + ΞΎ : β„š + Ξ·_pos : 0 < Ξ· + Ξ·_le_tenth : (Ξ· : ℝ) ≀ 1 / 10 + Ξ΄_pos : 0 < Ξ΄ + ΞΎ_pos : 0 < ΞΎ + ΞΎ_le_source : ΞΎ ≀ ΞΎβ‚€ + row_small : + (Ξ΄ : ℝ) / ((Ξ· : ℝ) / 3074) ^ 4 ≀ 1 / 128 + cycle_small : + 6 / Real.log 2 * + ((Ξ΄ : ℝ) + (1 + Real.log 2 / 2) * + ((Ξ΄ : ℝ) / ((Ξ· : ℝ) / 3074) ^ 4) + + goodRowOmega (Ξ· : ℝ)) ≀ 1 / 16 + transfer_small : + (Ξ΄ : ℝ) + 2 * (ΞΎ : ℝ) + binaryEntropy (Ξ· : ℝ) + (Ξ· : ℝ) + + (1 + Real.log 2) * + ((Ξ΄ : ℝ) / ((Ξ· : ℝ) / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - (Ξ· : ℝ)) * (ΞΊβ‚€ : ℝ)) + ΞΎ_lt_Ξ΄ : ΞΎ < Ξ΄ + ΞΎ_lt_gain : ΞΎ < 3 * Ξ³β‚€ / 8 + +/-- A positive rational concentration parameter can satisfy both strict analytic margins. -/ +private theorem exists_rational_concentration_margins + {ΞΊβ‚€ : β„š} (hΞΊβ‚€ : 0 < ΞΊβ‚€) : + βˆƒ Ξ·q : β„š, 0 < Ξ·q ∧ (Ξ·q : ℝ) < 1 / 20 ∧ + goodRowOmega (Ξ·q : ℝ) < Real.log 2 / 384 ∧ + binaryEntropy (Ξ·q : ℝ) + (Ξ·q : ℝ) < (ΞΊβ‚€ : ℝ) / 256 := by + have hΞΊβ‚€r : 0 < (ΞΊβ‚€ : ℝ) := by exact_mod_cast hΞΊβ‚€ + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + have hΟ‰target : 0 < Real.log 2 / 384 := div_pos hlog (by norm_num) + have hΟ‰event : {x : ℝ | goodRowOmega x < Real.log 2 / 384} ∈ nhds 0 := + tendsto_goodRowOmega_zero (isOpen_Iio.mem_nhds hΟ‰target) + have hHcont : ContinuousAt (fun x : ℝ ↦ binaryEntropy x + x) 0 := + continuous_binaryEntropy.continuousAt.add continuousAt_id + have hHtarget : 0 < (ΞΊβ‚€ : ℝ) / 256 := div_pos hΞΊβ‚€r (by norm_num) + have hHevent : + {x : ℝ | binaryEntropy x + x < (ΞΊβ‚€ : ℝ) / 256} ∈ nhds 0 := by + exact hHcont.eventually (isOpen_Iio.mem_nhds (by + simpa [binaryEntropy] using hHtarget)) + have hevent := Filter.inter_mem hΟ‰event hHevent + rw [Metric.mem_nhds_iff] at hevent + obtain ⟨a, ha, hball⟩ := hevent + have hΞ·bound : 0 < min a (1 / 20 : ℝ) := lt_min ha (by norm_num) + obtain ⟨ηq, hΞ·q0r, hΞ·qbound⟩ := exists_pos_rat_lt hΞ·bound + have hΞ·q0 : 0 < Ξ·q := hΞ·q0r + let Ξ· : ℝ := (Ξ·q : ℝ) + have hΞ· : 0 < Ξ· := by + simpa only [Ξ·, Rat.cast_pos] using hΞ·q0r + have hΞ·twenty : Ξ· < 1 / 20 := + hΞ·qbound.trans_le (min_le_right _ _) + have hΞ·a : Ξ· < a := hΞ·qbound.trans_le (min_le_left _ _) + have hΞ·mem := hball (by + rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_of_pos hΞ·] + exact hΞ·a) + have hΟ‰small : goodRowOmega Ξ· < Real.log 2 / 384 := hΞ·mem.1 + have hHsmall : binaryEntropy Ξ· + Ξ· < (ΞΊβ‚€ : ℝ) / 256 := hΞ·mem.2 + exact ⟨ηq, hΞ·q0, hΞ·twenty, hΟ‰small, hHsmall⟩ + +/-- The completion hierarchy may be chosen rationally. The proof uses +rational density only inside strict margins, so no numerical approximation is +smuggled into the theorem. -/ +theorem exists_rational_completion_scales + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š} (hΞΊβ‚€ : 0 < ΞΊβ‚€) (hΞΎβ‚€ : 0 < ΞΎβ‚€) (hΞ³β‚€ : 0 < Ξ³β‚€) : + Nonempty (RationalCompletionScales ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) := by + have hΞΊβ‚€r : 0 < (ΞΊβ‚€ : ℝ) := by exact_mod_cast hΞΊβ‚€ + have hΞΎβ‚€r : 0 < (ΞΎβ‚€ : ℝ) := by exact_mod_cast hΞΎβ‚€ + have hΞ³β‚€r : 0 < (Ξ³β‚€ : ℝ) := by exact_mod_cast hΞ³β‚€ + have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num) + obtain ⟨ηq, hΞ·q0, hΞ·twenty, hΟ‰small, hHsmall⟩ := + exists_rational_concentration_margins hΞΊβ‚€ + let Ξ· : ℝ := (Ξ·q : ℝ) + have hΞ· : 0 < Ξ· := by simpa only [Ξ·, Rat.cast_pos] using hΞ·q0 + have hΞ·tenth : Ξ· ≀ 1 / 10 := hΞ·twenty.le.trans (by norm_num) + have hcycleBase : 6 / Real.log 2 * goodRowOmega Ξ· < 1 / 64 := by + have hcoef : 0 < 6 / Real.log 2 := div_pos (by norm_num) hlog + calc + 6 / Real.log 2 * goodRowOmega Ξ· < + 6 / Real.log 2 * (Real.log 2 / 384) := + mul_lt_mul_of_pos_left hΟ‰small hcoef + _ = 1 / 64 := by field_simp [hlog.ne'] <;> norm_num + have hΞ·ΞΊ : Ξ· * (ΞΊβ‚€ : ℝ) ≀ (1 / 20) * (ΞΊβ‚€ : ℝ) := + mul_le_mul_of_nonneg_right hΞ·twenty.le hΞΊβ‚€r.le + have htransferBase : binaryEntropy Ξ· + Ξ· < + (1 / 16) * ((1 / 2 - Ξ·) * (ΞΊβ‚€ : ℝ)) := by + nlinarith + let cycleMargin : ℝ := 1 / 16 - 6 / Real.log 2 * goodRowOmega Ξ· + let transferMargin : ℝ := + (1 / 16) * ((1 / 2 - Ξ·) * (ΞΊβ‚€ : ℝ)) - (binaryEntropy Ξ· + Ξ·) + have hcycleMargin : 0 < cycleMargin := by + dsimp only [cycleMargin] + linarith + have htransferMargin : 0 < transferMargin := by + dsimp only [transferMargin] + linarith + let dβ‚€q : β„š := (Ξ·q / 3074) ^ 4 + let dβ‚€ : ℝ := (dβ‚€q : β„š) + have hdβ‚€_cast : dβ‚€ = (Ξ· / 3074) ^ 4 := by + simp [dβ‚€, dβ‚€q, Ξ·] + have hdβ‚€ : 0 < dβ‚€ := by + rw [hdβ‚€_cast] + positivity + let cycleCoefficient : ℝ := + 6 / Real.log 2 * (dβ‚€ + (1 + Real.log 2 / 2)) + have hcycleCoefficient : 0 < cycleCoefficient := by + dsimp only [cycleCoefficient] + have hc : 0 < dβ‚€ + (1 + Real.log 2 / 2) := by positivity + exact mul_pos (div_pos (by norm_num) hlog) hc + let transferCoefficient : ℝ := dβ‚€ + (1 + Real.log 2) + have htransferCoefficient : 0 < transferCoefficient := by + dsimp only [transferCoefficient] + positivity + let rBound : ℝ := min (1 / 128) + (min (cycleMargin / (2 * cycleCoefficient)) + (transferMargin / (2 * transferCoefficient))) + have hrBound : 0 < rBound := by + dsimp only [rBound] + exact lt_min (by norm_num) (lt_min + (div_pos hcycleMargin (mul_pos (by norm_num) hcycleCoefficient)) + (div_pos htransferMargin (mul_pos (by norm_num) htransferCoefficient))) + obtain ⟨rq, hrq0r, hrqBound⟩ := exists_pos_rat_lt hrBound + have hrq0 : 0 < rq := hrq0r + let r : ℝ := (rq : ℝ) + have hr : 0 < r := by + simpa only [r, Rat.cast_pos] using hrq0r + have hr128 : r ≀ 1 / 128 := + hrqBound.le.trans (min_le_left _ _) + have hrcycle : r ≀ cycleMargin / (2 * cycleCoefficient) := + hrqBound.le.trans ((min_le_right _ _).trans (min_le_left _ _)) + have hrtransfer : r ≀ transferMargin / (2 * transferCoefficient) := + hrqBound.le.trans ((min_le_right _ _).trans (min_le_right _ _)) + have hcycleExtra : cycleCoefficient * r ≀ cycleMargin / 2 := by + calc + cycleCoefficient * r ≀ + cycleCoefficient * (cycleMargin / (2 * cycleCoefficient)) := + mul_le_mul_of_nonneg_left hrcycle hcycleCoefficient.le + _ = cycleMargin / 2 := by field_simp [hcycleCoefficient.ne'] + have htransferExtra : transferCoefficient * r ≀ transferMargin / 2 := by + calc + transferCoefficient * r ≀ + transferCoefficient * (transferMargin / (2 * transferCoefficient)) := + mul_le_mul_of_nonneg_left hrtransfer htransferCoefficient.le + _ = transferMargin / 2 := by field_simp [htransferCoefficient.ne'] + let Ξ΄q : β„š := dβ‚€q * rq + let Ξ΄ : ℝ := (Ξ΄q : β„š) + have hΞ΄_cast : Ξ΄ = dβ‚€ * r := by simp [Ξ΄, Ξ΄q, dβ‚€, r] + have hΞ΄ : 0 < Ξ΄ := by rw [hΞ΄_cast]; exact mul_pos hdβ‚€ hr + have hΞ΄q : 0 < Ξ΄q := by + dsimp only [Ξ΄q, dβ‚€q] + positivity + have hratio : Ξ΄ / (Ξ· / 3074) ^ 4 = r := by + rw [← hdβ‚€_cast, hΞ΄_cast] + exact mul_div_cancel_leftβ‚€ r hdβ‚€.ne' + have hcycle : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) + + goodRowOmega Ξ·) < 1 / 16 := by + rw [hratio] + have hid : 6 / Real.log 2 * + (Ξ΄ + (1 + Real.log 2 / 2) * r + goodRowOmega Ξ·) = + 6 / Real.log 2 * goodRowOmega Ξ· + cycleCoefficient * r := by + rw [hΞ΄_cast] + dsimp only [cycleCoefficient] + ring + rw [hid] + dsimp only [cycleMargin] at hcycleExtra + linarith + have htransferZero : + Ξ΄ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) < + (1 / 16) * ((1 / 2 - Ξ·) * (ΞΊβ‚€ : ℝ)) := by + rw [hratio] + have hid : Ξ΄ + binaryEntropy Ξ· + Ξ· + (1 + Real.log 2) * r = + (binaryEntropy Ξ· + Ξ·) + transferCoefficient * r := by + rw [hΞ΄_cast] + dsimp only [transferCoefficient] + ring + rw [hid] + dsimp only [transferMargin] at htransferExtra + linarith + let remaining : ℝ := (1 / 16) * ((1 / 2 - Ξ·) * (ΞΊβ‚€ : ℝ)) - + (Ξ΄ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4)) + have hremaining : 0 < remaining := by + dsimp only [remaining] + linarith + let ΞΎBound : ℝ := min (ΞΎβ‚€ : ℝ) + (min Ξ΄ (min (3 * (Ξ³β‚€ : ℝ) / 8) (remaining / 4))) + have hΞΎBound : 0 < ΞΎBound := by + dsimp only [ΞΎBound] + exact lt_min hΞΎβ‚€r (lt_min hΞ΄ (lt_min + (div_pos (mul_pos (by norm_num) hΞ³β‚€r) (by norm_num)) + (div_pos hremaining (by norm_num)))) + obtain ⟨ξq, hΞΎq0r, hΞΎqBound⟩ := exists_pos_rat_lt hΞΎBound + have hΞΎq0 : 0 < ΞΎq := by exact_mod_cast hΞΎq0r + let ΞΎ : ℝ := (ΞΎq : ℝ) + have hΞΎΞΎβ‚€r : ΞΎ < (ΞΎβ‚€ : ℝ) := + hΞΎqBound.trans_le (min_le_left _ _) + have hΞΎΞΎβ‚€ : ΞΎq ≀ ΞΎβ‚€ := by + have hcast : (ΞΎq : ℝ) ≀ (ΞΎβ‚€ : ℝ) := by + simpa only [ΞΎ] using hΞΎΞΎβ‚€r.le + exact_mod_cast hcast + have hΞΎΞ΄r : ΞΎ < Ξ΄ := + hΞΎqBound.trans_le ((min_le_right _ _).trans (min_le_left _ _)) + have hΞΎΞ΄ : ΞΎq < Ξ΄q := by + change (ΞΎq : ℝ) < (Ξ΄q : ℝ) at hΞΎΞ΄r + exact_mod_cast hΞΎΞ΄r + have hΞΎΞ³ : ΞΎ < 3 * (Ξ³β‚€ : ℝ) / 8 := + hΞΎqBound.trans_le ((min_le_right _ _).trans + ((min_le_right _ _).trans (min_le_left _ _))) + have hΞΎremaining : ΞΎ ≀ remaining / 4 := + hΞΎqBound.le.trans ((min_le_right _ _).trans + ((min_le_right _ _).trans (min_le_right _ _))) + have htransfer : + Ξ΄ + 2 * ΞΎ + binaryEntropy Ξ· + Ξ· + + (1 + Real.log 2) * (Ξ΄ / (Ξ· / 3074) ^ 4) ≀ + (1 / 16) * ((1 / 2 - Ξ·) * (ΞΊβ‚€ : ℝ)) := by + dsimp only [remaining] at hΞΎremaining + nlinarith + exact ⟨{ + Ξ· := Ξ·q + Ξ΄ := Ξ΄q + ΞΎ := ΞΎq + Ξ·_pos := hΞ·q0 + Ξ·_le_tenth := by simpa only [Ξ·] using hΞ·tenth + Ξ΄_pos := hΞ΄q + ΞΎ_pos := hΞΎq0 + ΞΎ_le_source := hΞΎΞΎβ‚€ + row_small := by + change Ξ΄ / (Ξ· / 3074) ^ 4 ≀ 1 / 128 + rw [hratio] + exact hr128 + cycle_small := by simpa only [Ξ΄, Ξ·] using hcycle.le + transfer_small := by simpa only [Ξ΄, ΞΎ, Ξ·] using htransfer + ΞΎ_lt_Ξ΄ := hΞΎΞ΄ + ΞΎ_lt_gain := by + have hcast : (ΞΎq : ℝ) < ((3 * Ξ³β‚€ / 8 : β„š) : ℝ) := by + norm_num only [Rat.cast_div, Rat.cast_mul, Rat.cast_ofNat] + simpa only [ΞΎ] using hΞΎΞ³ + exact_mod_cast hcast }⟩ + +/-- A rational version of the improvement left after the far/near dichotomy. -/ +def rationalEpsilonPlus + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š} (s : RationalCompletionScales ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) : β„š := + min (s.Ξ΄ - s.ΞΎ) (3 * Ξ³β‚€ / 8 - s.ΞΎ) + +theorem rationalEpsilonPlus_pos + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š} (s : RationalCompletionScales ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) : + 0 < rationalEpsilonPlus s := by + rw [rationalEpsilonPlus, lt_min_iff] + exact ⟨sub_pos.mpr s.ΞΎ_lt_Ξ΄, sub_pos.mpr s.ΞΎ_lt_gain⟩ + +theorem cast_rationalEpsilonPlus + {ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : β„š} (s : RationalCompletionScales ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€) : + ((rationalEpsilonPlus s : β„š) : ℝ) = + epsilonPlus (s.Ξ΄ : ℝ) (s.ΞΎ : ℝ) (Ξ³β‚€ : ℝ) := by + simp [rationalEpsilonPlus, epsilonPlus, Rat.cast_min] + +/-- The elementary dimension bound that permits the algorithm to use the +rational scale `ell = n`, instead of the nonrational expression +`max 1 (log n / log 2)`. -/ +theorem log_natCast_le_natCast_mul_log_two + {n : β„•} (hn : 1 ≀ n) : + Real.log n ≀ (n : ℝ) * Real.log 2 := by + have hnpos : (0 : ℝ) < n := by exact_mod_cast (Nat.zero_lt_of_lt hn) + have hpowpos : (0 : ℝ) < (2 : ℝ) ^ n := pow_pos (by norm_num) n + have hnat : n ≀ 2 ^ n := n.lt_two_pow_self.le + have hcast : (n : ℝ) ≀ (2 : ℝ) ^ n := by exact_mod_cast hnat + have hlog := Real.strictMonoOn_log.monotoneOn hnpos hpowpos hcast + rw [Real.log_pow] at hlog + simpa only [Nat.cast_ofNat] using hlog + +/-- All absolute constants needed by the structural argument, now retained +as rational data instead of being erased into an existential real constant. -/ +structure RationalStructuralScales where + /-- The positive rational transfer-cost threshold in the clean-pair gain guarantee. -/ + ΞΊβ‚€ : β„š + /-- The positive rational upper bound on the regularization numerator in the clean-pair + guarantee. -/ + ΞΎβ‚€ : β„š + /-- The positive rational lower bound on the logarithmic gain of eligible clean pairs. -/ + Ξ³β‚€ : β„š + ΞΊβ‚€_pos : 0 < ΞΊβ‚€ + ΞΎβ‚€_pos : 0 < ΞΎβ‚€ + Ξ³β‚€_pos : 0 < Ξ³β‚€ + cleanGain : CleanPairGainGuarantee (ΞΊβ‚€ : ℝ) (ΞΎβ‚€ : ℝ) (Ξ³β‚€ : ℝ) + /-- Rational completion parameters satisfying the smallness inequalities for these structural + constants. -/ + completion : RationalCompletionScales ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ + +theorem exists_rational_structuralScales : + Nonempty RationalStructuralScales := by + obtain βŸ¨ΞΊβ‚€, ΞΎβ‚€, Ξ³β‚€, hΞΊβ‚€, hΞΎβ‚€, hΞ³β‚€, hgain⟩ := + exists_rational_cleanPairGain_constants + obtain ⟨s⟩ := exists_rational_completion_scales hΞΊβ‚€ hΞΎβ‚€ hΞ³β‚€ + exact ⟨{ + ΞΊβ‚€ := ΞΊβ‚€ + ΞΎβ‚€ := ΞΎβ‚€ + Ξ³β‚€ := Ξ³β‚€ + ΞΊβ‚€_pos := hΞΊβ‚€ + ΞΎβ‚€_pos := hΞΎβ‚€ + Ξ³β‚€_pos := hΞ³β‚€ + cleanGain := hgain + completion := s }⟩ + +/-- The rational regularization parameter used in dimension `n`. -/ +def rationalRegularizationScale (s : RationalStructuralScales) (n : β„•) : β„š := + s.completion.ΞΎ / (4 * n) + +theorem cast_rationalRegularizationScale + (s : RationalStructuralScales) (n : β„•) : + ((rationalRegularizationScale s n : β„š) : ℝ) = + (s.completion.ΞΎ : ℝ) / (4 * (n : ℝ)) := by + simp [rationalRegularizationScale] + +theorem rationalRegularizationScale_pos + (s : RationalStructuralScales) {n : β„•} (hn : 0 < n) : + 0 < rationalRegularizationScale s n := by + rw [rationalRegularizationScale] + exact div_pos s.completion.ΞΎ_pos (by positivity) + +/-- The structural certificate applies to any exact optimizer at the rational +scale. This is the form needed after the numerical routine replaces its +approximate optimizer by a nearby matrix for which the KKT equations are +exact. -/ +theorem rationalScales_certificate_of_optimizer + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + (s : RationalStructuralScales) + {n : β„•} (hn : 2 ≀ n) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective + ((rationalRegularizationScale s n : β„š) : ℝ) A Y ≀ + regularizedBetheObjective + ((rationalRegularizationScale s n : β„š) : ℝ) A X) + (hKKT : βˆƒ r c : Fin n β†’ ℝ, + HasLogKKT ((rationalRegularizationScale s n : β„š) : ℝ) A X r c) : + Real.exp (betheObjective A X + maximumMatchingGain A X) ≀ + Matrix.permanent A ∧ + Real.log (Matrix.permanent A) - + (betheObjective A X + maximumMatchingGain A X) ≀ + (Real.log 2 / 2 - + ((rationalEpsilonPlus s.completion : β„š) : ℝ)) * n := by + let Ξ· : ℝ := (s.completion.Ξ· : ℝ) + let Ξ΄ : ℝ := (s.completion.Ξ΄ : ℝ) + let ΞΎ : ℝ := (s.completion.ΞΎ : ℝ) + let Ο„ : ℝ := ((rationalRegularizationScale s n : β„š) : ℝ) + obtain ⟨rscale, cscale, hKKT⟩ := hKKT + have hΞΊ : 0 < (s.ΞΊβ‚€ : ℝ) := by exact_mod_cast s.ΞΊβ‚€_pos + have hΞ³ : 0 < (s.Ξ³β‚€ : ℝ) := by exact_mod_cast s.Ξ³β‚€_pos + have hΞΎ : 0 < ΞΎ := by + simpa only [ΞΎ, Rat.cast_pos] using s.completion.ΞΎ_pos + have hΞΎΞΎβ‚€ : ΞΎ ≀ (s.ΞΎβ‚€ : ℝ) := by + have hcast : (s.completion.ΞΎ : ℝ) ≀ (s.ΞΎβ‚€ : ℝ) := by + exact_mod_cast s.completion.ΞΎ_le_source + simpa only [ΞΎ] using hcast + have hΟ„scale : Ο„ = ΞΎ / (4 * (n : ℝ)) := by + exact cast_rationalRegularizationScale s n + have hobjective : + Real.log (bethePermanent A) - ΞΎ * n ≀ betheObjective A X := by + have hbudget := regularization_budget_of_paper_scale + (show (0 : ℝ) < n by positivity) + (log_natCast_le_natCast_mul_log_two (show 1 ≀ n by omega)) + hΞΎ hΟ„scale + have hvalue := betheLogValue_le_regularizedMaximizer + (show 1 < n by omega) + (le_of_lt (by + change 0 < ((rationalRegularizationScale s n : β„š) : ℝ) + exact_mod_cast rationalRegularizationScale_pos s (show 0 < n by omega))) + hA hX hmax + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlogBethe : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + rw [hlogBethe] + linarith + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlogBethe : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + have hupper : Real.log (Matrix.permanent A) ≀ + Real.log (bethePermanent A) + n * (Real.log 2 / 2) := by + rw [hlogBethe] + exact log_permanent_le_betheLogValue_add_log_two_half hn A hA + have hcertificate := + exp_betheObjective_add_maximumMatchingGain_le_permanent + stableCoefficient hn hA hX (fun i j ↦ (hXint i).2 j |>.1) + have hnearGain : betheSlack n (Real.log (bethePermanent A)) + (Real.log (Matrix.permanent A)) < Ξ΄ * n β†’ + 3 * (s.Ξ³β‚€ : ℝ) / 8 * n ≀ maximumMatchingGain A X := by + intro hnear + rw [hlogBethe] at hnear + exact nearCase_maximumMatchingGain_ge_threeEighths + anariRezaeiRowInequality hn + s.cleanGain hΞΊ hΞ³.le + (show (1 : ℝ) ≀ n by exact_mod_cast (show 1 ≀ n by omega)) + (log_natCast_le_natCast_mul_log_two (show 1 ≀ n by omega)) + hΞΎ hΞΎΞΎβ‚€ hΟ„scale + (by exact_mod_cast s.completion.Ξ·_pos) + s.completion.Ξ·_le_tenth + s.completion.row_small s.completion.cycle_small + s.completion.transfer_small hA hX hXint hKKT hnear + have hcases := completionCaseDisjunction + (logPermanent := Real.log (Matrix.permanent A)) + (logBethe := Real.log (bethePermanent A)) + (objective := betheObjective A X) + (gain := maximumMatchingGain A X) + (Ξ΄ := Ξ΄) (ΞΎ := ΞΎ) (Ξ³ := (s.Ξ³β‚€ : ℝ)) + hobjective (maximumMatchingGain_nonneg A X) hupper hnearGain + have hgap := positiveDichotomy_exponent hcases + have hΞ΅cast := cast_rationalEpsilonPlus s.completion + constructor + Β· exact hcertificate + Β· simpa only [Ξ·, Ξ΄, ΞΎ, hΞ΅cast] using hgap + +/-- The positive-matrix certificate with a rational improvement constant and +an explicitly rational regularization scale. -/ +theorem rationalScales_exactPositiveCertificate + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + (s : RationalStructuralScales) : + ExactPositiveCertificate + ((rationalEpsilonPlus s.completion : β„š) : ℝ) := by + intro n hn A hA + let Ο„ : ℝ := ((rationalRegularizationScale s n : β„š) : ℝ) + have hΞΎ : 0 < (s.completion.ΞΎ : ℝ) := by + exact_mod_cast s.completion.ΞΎ_pos + have hΟ„scale : Ο„ = (s.completion.ΞΎ : ℝ) / (4 * (n : ℝ)) := by + exact cast_rationalRegularizationScale s n + obtain ⟨X, hX, hXint, hmax, hKKT, _hobjective⟩ := + exists_regularizedOptimizer_at_paper_scale + (show 1 < n by omega) + (show (0 : ℝ) < n by positivity) + (log_natCast_le_natCast_mul_log_two (show 1 ≀ n by omega)) + hΞΎ hΟ„scale A hA + obtain ⟨hlower, hgap⟩ := rationalScales_certificate_of_optimizer + stableCoefficient s hn hA hX hXint hmax hKKT + exact ⟨X, hX, hlower, hgap⟩ + +theorem exists_rational_exactPositiveCertificate + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) : + βˆƒ Ξ΅ : β„š, 0 < Ξ΅ ∧ ExactPositiveCertificate (Ξ΅ : ℝ) := by + obtain ⟨s⟩ := exists_rational_structuralScales + exact ⟨rationalEpsilonPlus s.completion, + rationalEpsilonPlus_pos s.completion, + rationalScales_exactPositiveCertificate stableCoefficient s⟩ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalTransfer.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalTransfer.lean new file mode 100644 index 0000000000..6eb4e93562 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalTransfer.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby + +/-! # Numerical Transfer -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Certified transfer from an approximate KKT point + +The numerical optimizer need not return the exact regularized maximizer for +the input matrix. It is enough to return an exactly doubly stochastic +interior matrix and row/column potentials satisfying the logarithmic KKT +equations approximately. The nearby matrix then has those KKT equations +exactly. This file combines the nearby-matrix comparison with the structural +certificate and records the complete two-sided loss: the transfer costs two +copies of the logarithmic KKT residual. +-/ + +/-- The logarithm of the one-sided certificate transferred from the nearby +matrix back to the input matrix. -/ +noncomputable def nearbyCertificateLog + {n : β„•} (error Ο„ : ℝ) (X : Matrix (Fin n) (Fin n) ℝ) + (r c : Fin n β†’ ℝ) : ℝ := + let A' := nearbyKKTMatrix Ο„ X r c + betheObjective A' X + maximumMatchingGain A' X - error * n + +/-- The positive certificate obtained from an approximate KKT point. -/ +noncomputable def nearbyCertificateValue + {n : β„•} (error Ο„ : ℝ) (X : Matrix (Fin n) (Fin n) ℝ) + (r c : Fin n β†’ ℝ) : ℝ := + Real.exp (nearbyCertificateLog error Ο„ X r c) + +theorem nearbyCertificateValue_pos + {n : β„•} (error Ο„ : ℝ) (X : Matrix (Fin n) (Fin n) ℝ) + (r c : Fin n β†’ ℝ) : + 0 < nearbyCertificateValue error Ο„ X r c := by + exact Real.exp_pos _ + +/-- An approximate logarithmic KKT certificate loses exactly two copies of +its residual in the final logarithmic approximation: one when comparing the +input permanent to the nearby permanent, and one in the downward shift that +preserves the lower-bound direction. -/ +theorem nearbyCertificate_twoSided + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + (s : RationalStructuralScales) + {n : β„•} (hn : 2 ≀ n) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {error : ℝ} {r c : Fin n β†’ ℝ} + (happrox : HasApproximateLogKKT error + ((rationalRegularizationScale s n : β„š) : ℝ) A X r c) : + nearbyCertificateValue error + ((rationalRegularizationScale s n : β„š) : ℝ) X r c ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.sqrt 2 * Real.exp + (-(((rationalEpsilonPlus s.completion : β„š) : ℝ) - + 2 * error))) ^ n * + nearbyCertificateValue error + ((rationalRegularizationScale s n : β„š) : ℝ) X r c := by + let Ο„ : ℝ := ((rationalRegularizationScale s n : β„š) : ℝ) + let A' := nearbyKKTMatrix Ο„ X r c + let F := betheObjective A' X + maximumMatchingGain A' X + let L := nearbyCertificateValue error Ο„ X r c + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hXlt : βˆ€ i j, X i j < 1 := fun i j ↦ (hXint i).2 j |>.2 + have hA' : Matrix.Positive A' := nearbyKKTMatrix_positive hXpos hXlt + have hΟ„ : 0 ≀ Ο„ := by + change 0 ≀ (((rationalRegularizationScale s n : β„š) : ℝ)) + exact_mod_cast (rationalRegularizationScale_pos s (show 0 < n by omega)).le + have hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A' Y ≀ + regularizedBetheObjective Ο„ A' X := by + have hcard : 1 < Fintype.card (Fin n) := by + simpa only [Fintype.card_fin] using (show 1 < n by omega) + exact nearbyKKTMatrix_exact_optimizer (ΞΉ := Fin n) hcard + hΟ„ hX hXint r c + have hstruct := rationalScales_certificate_of_optimizer + stableCoefficient s hn hA' hX hXint hmax + ⟨r, c, nearbyKKTMatrix_hasLogKKT hXpos hXlt⟩ + have hcompare := approximateLogKKT_permanent_comparison + hA (by simpa only [Ο„] using happrox) hXpos hXlt + have hcompare' : + (Real.exp (-error)) ^ n * Matrix.permanent A' ≀ + Matrix.permanent A ∧ + Matrix.permanent A ≀ + (Real.exp error) ^ n * Matrix.permanent A' := by + simpa only [A', Ο„, Fintype.card_fin] using hcompare + have hstructLower : Real.exp F ≀ Matrix.permanent A' := by + simpa only [F] using hstruct.1 + have hstructGap : Real.log (Matrix.permanent A') - F ≀ + (Real.log 2 / 2 - + ((rationalEpsilonPlus s.completion : β„š) : ℝ)) * n := by + simpa only [F] using hstruct.2 + have hperA : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hperA' : 0 < Matrix.permanent A' := permanent_pos_of_positive A' hA' + have hL : L = Real.exp (F - error * n) := by + simp only [L, nearbyCertificateValue, nearbyCertificateLog, A', F, Ο„] + have hfactor : Real.exp (F - error * n) = + (Real.exp (-error)) ^ n * Real.exp F := by + calc + Real.exp (F - error * n) = + Real.exp F * Real.exp (-(error * n)) := by + rw [sub_eq_add_neg, Real.exp_add] + _ = Real.exp F * Real.exp ((n : ℝ) * (-error)) := by + congr 2 + ring + _ = Real.exp F * (Real.exp (-error)) ^ n := by + rw [Real.exp_nat_mul] + _ = (Real.exp (-error)) ^ n * Real.exp F := by ring + constructor + Β· change L ≀ Matrix.permanent A + rw [hL, hfactor] + have hscaled : (Real.exp (-error)) ^ n * Real.exp F ≀ + (Real.exp (-error)) ^ n * Matrix.permanent A' := + mul_le_mul_of_nonneg_left hstructLower + (pow_nonneg (Real.exp_pos (-error)).le n) + exact hscaled.trans hcompare'.1 + Β· have hscalePos : 0 < (Real.exp error) ^ n * Matrix.permanent A' := + mul_pos (pow_pos (Real.exp_pos _) n) hperA' + have hlogCompare : Real.log (Matrix.permanent A) ≀ + Real.log ((Real.exp error) ^ n * Matrix.permanent A') := + Real.strictMonoOn_log.monotoneOn hperA hscalePos hcompare'.2 + have hlogScale : + Real.log ((Real.exp error) ^ n * Matrix.permanent A') = + error * n + Real.log (Matrix.permanent A') := by + rw [Real.log_mul (pow_ne_zero n (Real.exp_ne_zero error)) hperA'.ne', + Real.log_pow, Real.log_exp] + ring + have hgap : Real.log (Matrix.permanent A) - Real.log L ≀ + (Real.log 2 / 2 - + (((rationalEpsilonPlus s.completion : β„š) : ℝ) - + 2 * error)) * n := by + rw [hlogScale] at hlogCompare + rw [hL, Real.log_exp] + nlinarith [hstructGap] + change Matrix.permanent A ≀ + (Real.sqrt 2 * Real.exp + (-(((rationalEpsilonPlus s.completion : β„š) : ℝ) - + 2 * error))) ^ n * L + exact logGap_implies_positive_approximation + (by rw [hL]; exact Real.exp_pos _) hperA hgap + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/NumericalWitness.lean b/LeanPool/BeyondBethe/BeyondBethe/NumericalWitness.lean new file mode 100644 index 0000000000..efb718e2ef --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/NumericalWitness.lean @@ -0,0 +1,511 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CleanGain +public import LeanPool.BeyondBethe.BeyondBethe.NumericalCapacity +public import Mathlib.Tactic + +/-! # Numerical Witness -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Explicit finite witnesses for the pair gain + +The clean-pair proof already constructs a sparse feasible coefficient +distribution. Evaluating these distributions for every candidate pair of +core columns removes the need to solve a second convex program for each pair +capacity. This file records the exact logarithmic witness and its one-sided +comparison with the true pair gain. +-/ + +/-- The sparse coefficient distribution associated with candidate core +columns `a,b`. When the outside mass is zero, Lean's totalized division makes +the two arm families vanish and leaves the point mass on the core edge. -/ +noncomputable def explicitPairWitness + {n : β„•} (X : Matrix (Fin n) (Fin n) ℝ) + (r s a b : Fin n) : CapacityWitnessEdge (OutsideColumn a b) β†’ ℝ := + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + capacityWitnessMass ρ Ξ΄a Ξ΄b (fun l ↦ Ξ± l.1) + +/-- Logarithm of the explicit witness lower bound on `pairGain`. -/ +noncomputable def explicitPairWitnessLogGain + {n : β„•} (Ο„ : ℝ) (X : Matrix (Fin n) (Fin n) ℝ) + (r s a b : Fin n) : ℝ := + let Ξ± := pairAlpha X r s + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let ΞΈ := explicitPairWitness X r s a b + let coeff := cleanWitnessCoefficient Ur Us a b + let normalization := + -Real.log (rowZeta Ο„ (X r)) - Real.log (rowZeta Ο„ (X s)) + let productTerm := βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j) + let certificate := entropyCapacityCertificate ΞΈ coeff + normalization + productTerm + certificate + +/-- Algorithm-facing form of the clean-pair lemma. Unlike +`CleanPairGainGuarantee`, this statement does not mention the input matrix or +KKT multipliers: it says that the finite witness computed from `X` already +has the advertised gain. This is the form needed before directed rational +evaluation and threshold matching are introduced. -/ +def ExplicitPairWitnessGainGuarantee (ΞΊβ‚€ ΞΎβ‚€ Ξ³β‚€ : ℝ) : Prop := + βˆ€ {n : β„•} {ell ΞΎ Ο„ : ℝ} {X : Matrix (Fin n) (Fin n) ℝ}, + 1 ≀ ell β†’ + Real.log n ≀ ell * Real.log 2 β†’ + 0 < ΞΎ β†’ ΞΎ ≀ ΞΎβ‚€ β†’ Ο„ = ΞΎ / (4 * ell) β†’ + IsDoublyStochastic X β†’ + (βˆ€ i, IsInteriorProbabilityVector (X i)) β†’ + βˆ€ {r s a b : Fin n}, r β‰  s β†’ a β‰  b β†’ + fourCoreTransferCost Ο„ X r s a b ≀ ΞΊβ‚€ β†’ + Ξ³β‚€ ≀ explicitPairWitnessLogGain Ο„ X r s a b + +/-- For positive outside mass at most one, the explicit distribution is an +exactly feasible capacity witness. -/ +theorem explicitPairWitness_isCapacityDistribution_of_positiveLeakage + {n : β„•} {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b ≀ 1) : + IsCapacityDistribution (explicitPairWitness X r s a b) + (cleanWitnessExponent a b) (pairAlpha X r s) := by + constructor + Β· simpa only [explicitPairWitness] using + cleanWitness_pairAlpha_isProbabilityVector hX hrs hab hρ hρ1 + Β· simpa only [explicitPairWitness] using + cleanWitness_pairAlpha_moment hX hab hρ + +/-- The clean-pair analysis lower-bounds the explicit witness itself, not +merely the larger optimized capacity. This is the formal statement that +justifies replacing the capacity program by finite witness enumeration. -/ +theorem cleanGainLowerBound_le_explicitPairWitnessLogGain + {n : β„•} {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b < 1) : + cleanGainLowerBound ΞΊ Ο„ + (outsideMassTwo (pairAlpha X r s) a b) + (fun l : OutsideColumn a b ↦ pairAlpha X r s l.1) ≀ + explicitPairWitnessLogGain Ο„ X r s a b := by + let Ξ± := pairAlpha X r s + let ρ := outsideMassTwo Ξ± a b + let Ξ΄a := 1 - Ξ± a + let Ξ΄b := 1 - Ξ± b + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let ΞΈ := explicitPairWitness X r s a b + let coeff := cleanWitnessCoefficient Ur Us a b + have hcore := fourCoreTransfer_lower hΟ„ hXint hcost + have hΞ΄pos := pairAlpha_coreDeficit_pos hX hXint hrs hab hρ + have hΞ±pos : βˆ€ l : OutsideColumn a b, 0 < Ξ± l.1 := by + intro l + exact add_pos ((hXint r).2 l.1).1 ((hXint s).2 l.1).1 + have hΞ±sum : βˆ‘ l : OutsideColumn a b, Ξ± l.1 = ρ := + sum_outsideColumn_eq_outsideMassTwo Ξ± a b + have hΞ΄sum : Ξ΄a + Ξ΄b = ρ := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show βˆ‘ j, Ξ± j = 2 by + simpa only [Ξ±] using sum_pairAlpha hX r s] at hsplit + dsimp only [Ξ΄a, Ξ΄b, ρ] + linarith + have houtside : + -Ο„ * ρ * Real.log 2 + + (1 + Ο„) * + (βˆ‘ l : OutsideColumn a b, Ξ± l.1 * Real.log (Ξ± l.1)) ≀ + βˆ‘ l : OutsideColumn a b, + Ξ± l.1 * Real.log (Ur l.1 + Us l.1) := by + exact sum_alpha_log_pairTransfer_lower (a := a) (b := b) + hΟ„ (hXint r) (hXint s) + (by simpa only [Ξ±, ρ, pairAlpha] using hΞ±sum) + have hUr : βˆ€ j, 0 < Ur j := fun j ↦ transferU_pos (hXint r) j + have hUs : βˆ€ j, 0 < Us j := fun j ↦ transferU_pos (hXint s) j + have hcertificateLower : + (1 - ρ) * Real.log ((2 * (Real.exp (-ΞΊ)) ^ 2) / (1 - ρ)) + + ρ * Real.log (Real.exp (-ΞΊ)) - Ο„ * ρ * Real.log 2 + + Ο„ * (βˆ‘ l : OutsideColumn a b, Ξ± l.1 * Real.log (Ξ± l.1)) - + Ξ΄a * Real.log (Ξ΄a / ρ) - Ξ΄b * Real.log (Ξ΄b / ρ) ≀ + entropyCapacityCertificate ΞΈ coeff := by + dsimp only [ΞΈ, coeff, explicitPairWitness, Ξ±, ρ, Ξ΄a, Ξ΄b, + Ur, Us] + apply cleanWitness_capacity_theta_lower hab (Real.exp_pos _) hρ hρ1 + hΞ΄pos.1 hΞ΄pos.2 hΞ΄sum hΞ±pos hΞ±sum hUr hUs + Β· exact hcore.1 + Β· exact hcore.2.1 + Β· exact hcore.2.2.1 + Β· exact hcore.2.2.2 + Β· exact houtside + have hcard := two_lt_card_of_outsideMassTwo_pos hab hρ + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hΞ±lt : βˆ€ j, Ξ± j < 1 := fun j ↦ + pairAlpha_lt_one_of_positive hX hXpos hcard hrs j + have hsumDecomp : + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) = + Ξ΄a * Real.log Ξ΄a + Ξ΄b * Real.log Ξ΄b + + βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum + (fun j ↦ (1 - Ξ± j) * Real.log (1 - Ξ± j)) hab + rw [← sum_outsideColumn_eq_outsideMassTwo] at hsplit + dsimp only [Ξ΄a, Ξ΄b] + exact hsplit.symm + have houtsideFactor : + -ρ ≀ βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + calc + -ρ = βˆ‘ l : OutsideColumn a b, -Ξ± l.1 := by + rw [Finset.sum_neg_distrib, hΞ±sum] + _ ≀ βˆ‘ l : OutsideColumn a b, + (1 - Ξ± l.1) * Real.log (1 - Ξ± l.1) := by + apply Finset.sum_le_sum + intro l _ + exact neg_alpha_le_one_sub_mul_log (hΞ±lt l.1) + have hsumLower : + Ξ΄a * Real.log Ξ΄a + Ξ΄b * Real.log Ξ΄b - ρ ≀ + βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j) := by + rw [hsumDecomp] + linarith + have hcancel := core_entropy_cancellation + hΞ΄pos.1 hΞ΄pos.2 hρ hΞ΄sum + have hzetaR : rowZeta Ο„ (X r) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability r) + have hzetaS : rowZeta Ο„ (X s) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability s) + have hzetaRpos : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaSpos : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hlogNormalization : + 0 ≀ -Real.log (rowZeta Ο„ (X r)) - Real.log (rowZeta Ο„ (X s)) := by + have hrlog : Real.log (rowZeta Ο„ (X r)) ≀ 0 := + Real.log_nonpos hzetaRpos.le hzetaR + have hslog : Real.log (rowZeta Ο„ (X s)) ≀ 0 := + Real.log_nonpos hzetaSpos.le hzetaS + linarith + dsimp only [cleanGainLowerBound, explicitPairWitnessLogGain, Ξ±, ρ, + Ξ΄a, Ξ΄b, Ur, Us, ΞΈ, coeff] at * + linarith + +/-- At zero leakage the explicit point-mass witness retains the full core +coefficient. This is the boundary counterpart of +`cleanGainLowerBound_le_explicitPairWitnessLogGain`. -/ +theorem coreLowerBound_le_explicitPairWitnessLogGain_of_zeroLeakage + {n : β„•} {Ο„ ΞΊ : ℝ} (hΟ„ : 0 ≀ Ο„) + {X : Matrix (Fin n) (Fin n) ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hcost : fourCoreTransferCost Ο„ X r s a b ≀ ΞΊ) + (hzero : outsideMassTwo (pairAlpha X r s) a b = 0) : + Real.log (2 * (Real.exp (-ΞΊ)) ^ 2) ≀ + explicitPairWitnessLogGain Ο„ X r s a b := by + let Ξ± := pairAlpha X r s + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + letI : IsEmpty (OutsideColumn a b) := + isEmpty_outsideColumn_of_pairAlpha_outsideMass_eq_zero hX hXint hzero + have hzeroWitness := cleanWitness_pairAlpha_zero hX hrs hab hzero + (inferInstance : IsEmpty (OutsideColumn a b)) + have ha : Ξ± a = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hb : Ξ± b = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hΞ±one : βˆ€ j, Ξ± j = 1 := by + intro j + have hj : j = a ∨ j = b := by + by_contra h + push Not at h + let l : OutsideColumn a b := ⟨j, by + simp [outsideColumnFinset, h.1, h.2]⟩ + exact isEmptyElim l + exact hj.elim (fun h ↦ h β–Έ ha) (fun h ↦ h β–Έ hb) + have hΞΈ : explicitPairWitness X r s a b = + capacityWitnessMass 0 0 0 (fun l : OutsideColumn a b ↦ Ξ± l.1) := by + simp only [explicitPairWitness] + rw [show outsideMassTwo (pairAlpha X r s) a b = 0 from hzero] + rw [show 1 - pairAlpha X r s a = 0 by + simpa only [Ξ±] using sub_eq_zero.mpr ha.symm, + show 1 - pairAlpha X r s b = 0 by + simpa only [Ξ±] using sub_eq_zero.mpr hb.symm] + have hcertificate : + entropyCapacityCertificate (explicitPairWitness X r s a b) + (cleanWitnessCoefficient Ur Us a b) = + Real.log (cleanWitnessCoefficient Ur Us a b (Sum.inl ())) := by + rw [hΞΈ] + simp [entropyCapacityCertificate, capacityWitnessMass] + have hcore := fourCoreTransfer_lower hΟ„ hXint hcost + have hcoreCoeff := cleanWitnessCoefficient_core_lower + (Real.exp_pos _).le hcore.1 hcore.2.1 hcore.2.2.1 hcore.2.2.2 + have hcoreBase : 0 < 2 * (Real.exp (-ΞΊ)) ^ 2 := + mul_pos (by norm_num) (sq_pos_of_pos (Real.exp_pos _)) + have hlogCore : Real.log (2 * (Real.exp (-ΞΊ)) ^ 2) ≀ + Real.log (cleanWitnessCoefficient Ur Us a b (Sum.inl ())) := + Real.log_le_log hcoreBase hcoreCoeff + have hzetaR : rowZeta Ο„ (X r) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability r) + have hzetaS : rowZeta Ο„ (X s) ≀ 1 := + rowZeta_le_one hΟ„ (hX.row_probability s) + have hzetaRpos : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaSpos : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hlogNormalization : + 0 ≀ -Real.log (rowZeta Ο„ (X r)) - Real.log (rowZeta Ο„ (X s)) := by + have hrlog : Real.log (rowZeta Ο„ (X r)) ≀ 0 := + Real.log_nonpos hzetaRpos.le hzetaR + have hslog : Real.log (rowZeta Ο„ (X s)) ≀ 0 := + Real.log_nonpos hzetaSpos.le hzetaS + linarith + have hproductTerm : + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) = 0 := by + simp_rw [hΞ±one] + simp + dsimp only [explicitPairWitnessLogGain, Ξ±, Ur, Us] + rw [hproductTerm, hcertificate] + linarith + +/-- Every eligible explicit witness is a rigorous lower bound on the true +pair gain. Only the log-sum certificate direction of capacity is used. -/ +theorem explicitPairWitnessLogGain_le_log_pairGain_of_positiveLeakage + {n : β„•} {Ο„ : ℝ} {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hrscale : βˆ€ i, 0 < rscale i) (hcscale : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hρ : 0 < outsideMassTwo (pairAlpha X r s) a b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b ≀ 1) : + explicitPairWitnessLogGain Ο„ X r s a b ≀ + Real.log (pairGain A X r s) := by + let Ξ± := pairAlpha X r s + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let cap := polynomialCapacity Ξ± (pairPolynomial Ur Us) + let prodFactor := ∏ j, (1 - Ξ± j) ^ (1 - Ξ± j) + let scale := 1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s)) + let ΞΈ := explicitPairWitness X r s a b + let coeff := cleanWitnessCoefficient Ur Us a b + have hfeasible := explicitPairWitness_isCapacityDistribution_of_positiveLeakage + hX hrs hab hρ hρ1 + have hUr : βˆ€ j, 0 < Ur j := fun j ↦ transferU_pos (hXint r) j + have hUs : βˆ€ j, 0 < Us j := fun j ↦ transferU_pos (hXint s) j + have hcoeff : βˆ€ e, 0 < coeff e := by + simpa only [coeff] using cleanWitnessCoefficient_positive hUr hUs a b + have hcert : entropyCapacityCertificate ΞΈ coeff ≀ Real.log cap := by + dsimp only [ΞΈ, coeff, cap, Ξ±, Ur, Us] + exact cleanWitnessEntropyCertificate_le_log_pairPolynomialCapacity hab + hfeasible.1.nonnegative hfeasible.1.sum_eq_one + (by simpa only [coeff, Ur, Us] using hcoeff) hfeasible.2 + (fun j ↦ (hUr j).le) (fun j ↦ (hUs j).le) + have hcard : 2 < Fintype.card (Fin n) := + two_lt_card_of_outsideMassTwo_pos hab hρ + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hΞ±lt : βˆ€ j, Ξ± j < 1 := fun j ↦ + pairAlpha_lt_one_of_positive hX hXpos hcard hrs j + have hcomp : βˆ€ j, 0 < 1 - Ξ± j := fun j ↦ sub_pos.mpr (hΞ±lt j) + have hprodPos : 0 < prodFactor := by + dsimp only [prodFactor] + exact Finset.prod_pos fun j _ ↦ Real.rpow_pos_of_pos (hcomp j) _ + have hcapPos : 0 < cap := by + dsimp only [cap, Ξ±, Ur, Us] + exact pairTransferPolynomialCapacity_pos hX hXint hrs hab hρ hρ1 + have hzetaR : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaS : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hscalePos : 0 < scale := by + dsimp only [scale] + exact one_div_pos.mpr (mul_pos hzetaR hzetaS) + have hfactor := pairGain_factorization hApos hX hXint + hrscale hcscale hKKT r s + have hlogFactor : Real.log (pairGain A X r s) = + Real.log scale + + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) + + Real.log cap := by + rw [hfactor] + dsimp only [scale, prodFactor, cap, Ξ±, Ur, Us] + rw [Real.log_mul (mul_pos hscalePos hprodPos).ne' hcapPos.ne', + Real.log_mul hscalePos.ne' hprodPos.ne', + Real.log_prod (fun j _ ↦ + (Real.rpow_pos_of_pos (hcomp j) _).ne')] + simp_rw [Real.log_rpow (hcomp _)] + ring + rw [hlogFactor] + dsimp only [explicitPairWitnessLogGain, Ξ±, Ur, Us, ΞΈ, coeff, scale] + have hlogScale : Real.log + (1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s))) = + -Real.log (rowZeta Ο„ (X r)) - Real.log (rowZeta Ο„ (X s)) := by + rw [one_div, Real.log_inv, Real.log_mul hzetaR.ne' hzetaS.ne'] + ring + rw [hlogScale] + linarith + +/-- The point-mass witness is also a rigorous lower bound in the exact +zero-leakage boundary case. This branch is proved directly because the +complement factors are `0^0`, so a positivity argument through their +logarithms would be inappropriate. -/ +theorem explicitPairWitnessLogGain_le_log_pairGain_of_zeroLeakage + {n : β„•} {Ο„ : ℝ} {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hrscale : βˆ€ i, 0 < rscale i) (hcscale : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hzero : outsideMassTwo (pairAlpha X r s) a b = 0) : + explicitPairWitnessLogGain Ο„ X r s a b ≀ + Real.log (pairGain A X r s) := by + let Ξ± := pairAlpha X r s + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + let cap := polynomialCapacity Ξ± (pairPolynomial Ur Us) + let scale := 1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s)) + letI : IsEmpty (OutsideColumn a b) := + isEmpty_outsideColumn_of_pairAlpha_outsideMass_eq_zero hX hXint hzero + have hzeroWitness := cleanWitness_pairAlpha_zero hX hrs hab hzero + (inferInstance : IsEmpty (OutsideColumn a b)) + have ha : Ξ± a = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hb : Ξ± b = 1 := by + have hsplit := twoCore_add_outsideMassTwo_eq_sum Ξ± hab + rw [show outsideMassTwo Ξ± a b = 0 by simpa only [Ξ±] using hzero, + show βˆ‘ j, Ξ± j = 2 by simpa only [Ξ±] using sum_pairAlpha hX r s] + at hsplit + have hlea := pairAlpha_le_one hX hrs a + have hleb := pairAlpha_le_one hX hrs b + dsimp only [Ξ±] + linarith + have hΞ±one : βˆ€ j, Ξ± j = 1 := by + intro j + have hj : j = a ∨ j = b := by + by_contra h + push Not at h + let l : OutsideColumn a b := ⟨j, by + simp [outsideColumnFinset, h.1, h.2]⟩ + exact isEmptyElim l + exact hj.elim (fun h ↦ h β–Έ ha) (fun h ↦ h β–Έ hb) + have hΞΈ : explicitPairWitness X r s a b = + capacityWitnessMass 0 0 0 (fun l : OutsideColumn a b ↦ Ξ± l.1) := by + simp only [explicitPairWitness] + rw [show outsideMassTwo (pairAlpha X r s) a b = 0 from hzero] + rw [show 1 - pairAlpha X r s a = 0 by + simpa only [Ξ±] using sub_eq_zero.mpr ha.symm, + show 1 - pairAlpha X r s b = 0 by + simpa only [Ξ±] using sub_eq_zero.mpr hb.symm] + have hUr : βˆ€ j, 0 < Ur j := fun j ↦ transferU_pos (hXint r) j + have hUs : βˆ€ j, 0 < Us j := fun j ↦ transferU_pos (hXint s) j + have hcoeff : βˆ€ e, 0 < cleanWitnessCoefficient Ur Us a b e := + cleanWitnessCoefficient_positive hUr hUs a b + have hcert : entropyCapacityCertificate (explicitPairWitness X r s a b) + (cleanWitnessCoefficient Ur Us a b) ≀ Real.log cap := by + dsimp only [cap, Ξ±, Ur, Us] + exact cleanWitnessEntropyCertificate_le_log_pairPolynomialCapacity hab + (by simpa only [hΞΈ] using hzeroWitness.1.1) + (by simpa only [hΞΈ] using hzeroWitness.1.2) + (by simpa only [Ur, Us] using hcoeff) + (by simpa only [hΞΈ] using hzeroWitness.2) + (fun j ↦ (hUr j).le) (fun j ↦ (hUs j).le) + have hexp := exp_entropyCapacityCertificate_le_finitePolynomialCapacity + hzeroWitness.1.1 hzeroWitness.1.2 hcoeff hzeroWitness.2 + have hcapFinite := cleanWitnessCapacity_le_pairPolynomialCapacity hab + (u := Ur) (v := Us) (Ξ± := Ξ±) + (fun j ↦ (hUr j).le) (fun j ↦ (hUs j).le) + have hcapPos : 0 < cap := by + dsimp only [cap] + exact (Real.exp_pos _).trans_le (hexp.trans hcapFinite) + have hzetaR : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaS : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hscalePos : 0 < scale := by + dsimp only [scale] + exact one_div_pos.mpr (mul_pos hzetaR hzetaS) + have hfactor := pairGain_factorization hApos hX hXint + hrscale hcscale hKKT r s + have hgainEq : pairGain A X r s = scale * cap := by + rw [hfactor] + simp_rw [show βˆ€ j, pairAlpha X r s j = 1 by + simpa only [Ξ±] using hΞ±one] + simp [scale, cap, Ξ±, Ur, Us] + have hlogGain : Real.log (pairGain A X r s) = + Real.log scale + Real.log cap := by + rw [hgainEq, Real.log_mul hscalePos.ne' hcapPos.ne'] + have hlogScale : Real.log scale = + -Real.log (rowZeta Ο„ (X r)) - Real.log (rowZeta Ο„ (X s)) := by + dsimp only [scale] + rw [one_div, Real.log_inv, Real.log_mul hzetaR.ne' hzetaS.ne'] + ring + have hproductTerm : + (βˆ‘ j, (1 - Ξ± j) * Real.log (1 - Ξ± j)) = 0 := by + simp_rw [hΞ±one] + simp + rw [hlogGain, hlogScale] + dsimp only [explicitPairWitnessLogGain, Ξ±, Ur, Us] + rw [hproductTerm] + linarith + +/-- Unified algorithm-facing form: the sole numerical eligibility test is +that the rational outside mass is at most one. Nonnegativity is automatic +from double stochasticity, and exact zero is dispatched to the point-mass +branch. -/ +theorem explicitPairWitnessLogGain_le_log_pairGain_of_le_one + {n : β„•} {Ο„ : ℝ} {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hrscale : βˆ€ i, 0 < rscale i) (hcscale : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + {r s a b : Fin n} (hrs : r β‰  s) (hab : a β‰  b) + (hρ1 : outsideMassTwo (pairAlpha X r s) a b ≀ 1) : + explicitPairWitnessLogGain Ο„ X r s a b ≀ + Real.log (pairGain A X r s) := by + have hρnonneg : 0 ≀ outsideMassTwo (pairAlpha X r s) a b := by + dsimp only [outsideMassTwo] + exact Finset.sum_nonneg fun j _ ↦ pairAlpha_nonneg hX r s j + rcases hρnonneg.eq_or_lt with hzero | hpos + Β· exact explicitPairWitnessLogGain_le_log_pairGain_of_zeroLeakage + hApos hX hXint hrscale hcscale hKKT hrs hab hzero.symm + Β· exact explicitPairWitnessLogGain_le_log_pairGain_of_positiveLeakage + hApos hX hXint hrscale hcscale hKKT hrs hab hpos hρ1 + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Optimizer.lean b/LeanPool/BeyondBethe/BeyondBethe/Optimizer.lean new file mode 100644 index 0000000000..001e683617 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Optimizer.lean @@ -0,0 +1,772 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import LeanPool.BeyondBethe.BeyondBethe.SourceVontobel +public import Mathlib.Analysis.Calculus.LocalExtr.Basic +public import Mathlib.Topology.Instances.Matrix +public import Mathlib.Tactic + +/-! # Optimizer -/ + +@[expose] public section + +open scoped BigOperators Topology + +namespace BeyondBethe + +noncomputable section + +/-- The barycenter of the Birkhoff polytope. -/ +noncomputable def uniformBirkhoff (n : β„•) : Matrix (Fin n) (Fin n) ℝ := + fun _ _ ↦ 1 / n + +theorem uniformBirkhoff_doublyStochastic + {n : β„•} (hn : 0 < n) : + IsDoublyStochastic (uniformBirkhoff n) := by + refine ⟨?_, ?_, ?_⟩ + Β· intro i j + exact div_nonneg (by norm_num) (Nat.cast_nonneg n) + Β· intro i + simp [uniformBirkhoff, hn.ne'] + Β· intro j + simp [uniformBirkhoff, hn.ne'] + +theorem uniformBirkhoff_interior + {n : β„•} (hn : 1 < n) : + βˆ€ i, IsInteriorProbabilityVector (uniformBirkhoff n i) := by + intro i + have hn0 : 0 < n := by omega + refine ⟨(uniformBirkhoff_doublyStochastic hn0).row_probability i, ?_⟩ + intro j + constructor + Β· exact div_pos (by norm_num) (by exact_mod_cast hn0) + Β· rw [uniformBirkhoff] + exact (div_lt_one (by exact_mod_cast hn0)).2 (by exact_mod_cast hn) + +/-- The Birkhoff polytope is closed in the finite matrix space. -/ +theorem isClosed_doublyStochastic + {n : Type*} [Fintype n] : + IsClosed {X : Matrix n n ℝ | IsDoublyStochastic X} := by + have hnonneg : IsClosed + {X : Matrix n n ℝ | βˆ€ i j, 0 ≀ X i j} := by + simp only [show {X : Matrix n n ℝ | βˆ€ i j, 0 ≀ X i j} = + β‹‚ i, β‹‚ j, {X | 0 ≀ X i j} by ext X; simp] + exact isClosed_iInter fun i ↦ isClosed_iInter fun j ↦ + isClosed_le continuous_const (continuous_apply_apply i j) + have hrow : IsClosed + {X : Matrix n n ℝ | βˆ€ i, βˆ‘ j, X i j = 1} := by + simp only [show {X : Matrix n n ℝ | βˆ€ i, βˆ‘ j, X i j = 1} = + β‹‚ i, {X | βˆ‘ j, X i j = 1} by ext X; simp] + exact isClosed_iInter fun i ↦ isClosed_eq + (continuous_finsetSum Finset.univ fun j _ ↦ + continuous_apply_apply i j) continuous_const + have hcol : IsClosed + {X : Matrix n n ℝ | βˆ€ j, βˆ‘ i, X i j = 1} := by + simp only [show {X : Matrix n n ℝ | βˆ€ j, βˆ‘ i, X i j = 1} = + β‹‚ j, {X | βˆ‘ i, X i j = 1} by ext X; simp] + exact isClosed_iInter fun j ↦ isClosed_eq + (continuous_finsetSum Finset.univ fun i _ ↦ + continuous_apply_apply i j) continuous_const + simpa [IsDoublyStochastic, Matrix.Nonnegative, Set.setOf_and] using + hnonneg.inter (hrow.inter hcol) + +/-- The Birkhoff polytope is compact. -/ +theorem isCompact_doublyStochastic + {n : Type*} [Fintype n] [DecidableEq n] : + IsCompact {X : Matrix n n ℝ | IsDoublyStochastic X} := by + let box : Set (Matrix n n ℝ) := + Set.univ.pi fun _i ↦ Set.univ.pi fun _j ↦ Set.Icc 0 1 + have hbox : IsCompact box := + isCompact_univ_pi fun _i ↦ isCompact_univ_pi fun _j ↦ isCompact_Icc + apply hbox.of_isClosed_subset isClosed_doublyStochastic + intro X hX i _ j _ + exact ⟨hX.nonnegative i j, hX.entry_le_one i j⟩ + +theorem regularizedBetheCoordinate_eq_continuousForm + (Ο„ a x : ℝ) : + regularizedBetheCoordinate Ο„ a x = + x * Real.log a + (1 + Ο„) * Real.negMulLog x - + Real.negMulLog (1 - x) := by + rw [regularizedBetheCoordinate, Real.negMulLog_def] + ring + +/-- For a positive matrix the regularized objective is continuous even at +the boundary; `negMulLog` supplies the continuous extension at zero. -/ +theorem continuous_regularizedBetheObjective + {n : Type*} [Fintype n] + (Ο„ : ℝ) (A : Matrix n n ℝ) : + Continuous (regularizedBetheObjective Ο„ A) := by + rw [show regularizedBetheObjective Ο„ A = fun X ↦ + βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate Ο„ (A i j) (X i j) by + funext X + exact regularizedBetheObjective_eq_sum_coordinates Ο„ A X] + apply continuous_finsetSum + intro i _ + apply continuous_finsetSum + intro j _ + simp_rw [regularizedBetheCoordinate_eq_continuousForm] + fun_prop + +/-- A regularized maximizer exists on the Birkhoff polytope. -/ +theorem exists_regularizedBetheMaximizer + {n : β„•} (Ο„ : ℝ) (A : Matrix (Fin n) (Fin n) ℝ) : + βˆƒ X, IsDoublyStochastic X ∧ + βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X := by + have hne : ({X : Matrix (Fin n) (Fin n) ℝ | + IsDoublyStochastic X} : Set _).Nonempty := by + let I : Matrix (Fin n) (Fin n) ℝ := fun i j ↦ if i = j then 1 else 0 + refine ⟨I, ?_⟩ + refine ⟨(fun i j ↦ by by_cases h : i = j <;> simp [I, h]), ?_, ?_⟩ + Β· intro i + simp [I] + Β· intro j + simp [I] + obtain ⟨X, hX, hmax⟩ := isCompact_doublyStochastic.exists_isMaxOn + hne (continuous_regularizedBetheObjective Ο„ A).continuousOn + exact ⟨X, hX, fun Y hY ↦ hmax hY⟩ + +/-- Affine interpolation of two matrices. -/ +def matrixSegment + {n : Type*} (t : ℝ) (X Y : Matrix n n ℝ) : Matrix n n ℝ := + fun i j ↦ (1 - t) * X i j + t * Y i j + +theorem matrixSegment_doublyStochastic + {n : Type*} [Fintype n] + {t : ℝ} (htβ‚€ : 0 ≀ t) (ht₁ : t ≀ 1) + {X Y : Matrix n n ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) : + IsDoublyStochastic (matrixSegment t X Y) := by + refine ⟨?_, ?_, ?_⟩ + Β· intro i j + exact add_nonneg + (mul_nonneg (sub_nonneg.mpr ht₁) (hX.nonnegative i j)) + (mul_nonneg htβ‚€ (hY.nonnegative i j)) + Β· intro i + simp_rw [matrixSegment, Finset.sum_add_distrib, + ← Finset.mul_sum, hX.row_sum, hY.row_sum] + ring + Β· intro j + simp_rw [matrixSegment, Finset.sum_add_distrib, + ← Finset.mul_sum, hX.col_sum, hY.col_sum] + ring + +theorem negMulLog_segment_gap_nonneg + {t x y : ℝ} (htβ‚€ : 0 ≀ t) (ht₁ : t ≀ 1) + (hx : 0 ≀ x) (hy : 0 ≀ y) : + 0 ≀ Real.negMulLog ((1 - t) * x + t * y) - + ((1 - t) * Real.negMulLog x + t * Real.negMulLog y) := by + have hconc := Real.concaveOn_negMulLog.2 hx hy + (sub_nonneg.mpr ht₁) htβ‚€ (by ring : (1 - t) + t = 1) + simpa [smul_eq_mul] using sub_nonneg.mpr hconc + +theorem negMulLog_segment_gap_zero + (t y : ℝ) : + Real.negMulLog ((1 - t) * 0 + t * y) - + ((1 - t) * Real.negMulLog 0 + t * Real.negMulLog y) = + y * Real.negMulLog t := by + rw [Real.negMulLog_zero] + simp only [mul_zero, zero_add] + rw [Real.negMulLog_mul] + ring + +/-- Quantitative entropy barrier at a zero coordinate. Besides ordinary +concavity, mixing with the uniform matrix gains one copy of +`negMulLog t / n` from the chosen zero entry. -/ +theorem totalRowEntropy_matrixSegment_uniform_bonus + {n : β„•} (hn : 0 < n) + {X : Matrix (Fin n) (Fin n) ℝ} (hX : IsDoublyStochastic X) + {iβ‚€ jβ‚€ : Fin n} (hzero : X iβ‚€ jβ‚€ = 0) + {t : ℝ} (htβ‚€ : 0 ≀ t) (ht₁ : t ≀ 1) : + (1 - t) * totalRowEntropy X + + t * totalRowEntropy (uniformBirkhoff n) + + (1 / n) * Real.negMulLog t ≀ + totalRowEntropy (matrixSegment t X (uniformBirkhoff n)) := by + let gap : Fin n β†’ Fin n β†’ ℝ := fun i j ↦ + Real.negMulLog (matrixSegment t X (uniformBirkhoff n) i j) - + ((1 - t) * Real.negMulLog (X i j) + + t * Real.negMulLog (uniformBirkhoff n i j)) + have hgap : βˆ€ i j, 0 ≀ gap i j := by + intro i j + exact negMulLog_segment_gap_nonneg htβ‚€ ht₁ + (hX.nonnegative i j) + ((uniformBirkhoff_doublyStochastic hn).nonnegative i j) + have hspecial : gap iβ‚€ jβ‚€ = (1 / n) * Real.negMulLog t := by + dsimp [gap] + rw [matrixSegment, hzero] + calc + Real.negMulLog ((1 - t) * 0 + + t * uniformBirkhoff n iβ‚€ jβ‚€) - + ((1 - t) * Real.negMulLog 0 + + t * Real.negMulLog (uniformBirkhoff n iβ‚€ jβ‚€)) = + uniformBirkhoff n iβ‚€ jβ‚€ * Real.negMulLog t := + negMulLog_segment_gap_zero t (uniformBirkhoff n iβ‚€ jβ‚€) + _ = (1 / n) * Real.negMulLog t := by rfl + have hrow : gap iβ‚€ jβ‚€ ≀ βˆ‘ j, gap iβ‚€ j := + Finset.single_le_sum (fun j _ ↦ hgap iβ‚€ j) (Finset.mem_univ jβ‚€) + have hall : (βˆ‘ j, gap iβ‚€ j) ≀ βˆ‘ i, βˆ‘ j, gap i j := + Finset.single_le_sum + (fun i _ ↦ Finset.sum_nonneg fun j _ ↦ hgap i j) + (Finset.mem_univ iβ‚€) + rw [hspecial] at hrow + have hbonus := hrow.trans hall + simp_rw [gap, totalRowEntropy, shannonEntropy, + Finset.sum_sub_distrib, Finset.sum_add_distrib, + ← Finset.mul_sum] at hbonus ⊒ + simp_rw [matrixSegment] at hbonus ⊒ + linarith + +theorem negMulLog_exp_neg (K : ℝ) : + Real.negMulLog (Real.exp (-K)) = Real.exp (-K) * K := by + change -Real.exp (-K) * Real.log (Real.exp (-K)) = _ + rw [Real.log_exp] + ring + +/-- Concavity of the Bethe objective plus the quantitative entropy barrier +rules out every zero coordinate of a regularized maximizer. This proof +avoids coordinatewise asymptotic `O(t)` bookkeeping. -/ +theorem regularizedBetheMaximizer_positive + {n : β„•} (hn : 1 < n) + {Ο„ : ℝ} (hΟ„ : 0 < Ο„) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) : + βˆ€ i j, 0 < X i j := by + have hn0 : 0 < n := by omega + let W := uniformBirkhoff n + have hW : IsDoublyStochastic W := uniformBirkhoff_doublyStochastic hn0 + intro iβ‚€ jβ‚€ + by_contra hnot + have hzero : X iβ‚€ jβ‚€ = 0 := + le_antisymm (le_of_not_gt hnot) (hX.nonnegative iβ‚€ jβ‚€) + let d := regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A W + let K := (n : ℝ) / Ο„ * (|d| + 1) + let t := Real.exp (-K) + have hnR : (0 : ℝ) < n := by exact_mod_cast hn0 + have hK : 0 < K := by + dsimp [K] + exact mul_pos (div_pos hnR hΟ„) (by positivity) + have htβ‚€ : 0 < t := by + dsimp [t] + positivity + have ht₁ : t < 1 := by + dsimp [t] + simpa only [Real.exp_zero] using Real.exp_lt_exp.mpr (neg_neg_of_pos hK) + let Z := matrixSegment t X W + have hZ : IsDoublyStochastic Z := + matrixSegment_doublyStochastic htβ‚€.le ht₁.le hX hW + have hentropy : + (1 - t) * totalRowEntropy X + t * totalRowEntropy W + + (1 / n) * Real.negMulLog t ≀ totalRowEntropy Z := by + exact totalRowEntropy_matrixSegment_uniform_bonus hn0 hX hzero + htβ‚€.le ht₁.le + have hbeta : + (1 - t) * betheObjective A X + t * betheObjective A W ≀ + betheObjective A Z := by + have hc := betheObjective_segment_lower + (ΞΉ := Fin n) (by simpa using hn) A X W hX hW htβ‚€.le ht₁.le + have hseg : betheMatrixSegment t X W = Z := by + ext i j + simp [Z, matrixSegment, betheMatrixSegment, probabilitySegment] + rw [← hseg] + exact hc + have hscale : + Ο„ * ((1 / n) * Real.negMulLog t) = t * (|d| + 1) := by + rw [show Real.negMulLog t = t * K by + simpa [t] using negMulLog_exp_neg K] + dsimp [K] + field_simp [hΟ„.ne', hnR.ne'] + have hgain : + 0 < t * (regularizedBetheObjective Ο„ A W - + regularizedBetheObjective Ο„ A X) + + Ο„ * ((1 / n) * Real.negMulLog t) := by + rw [hscale] + have hd : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A W = d := by rfl + have habs : d ≀ |d| := le_abs_self d + rw [← hd] at habs + have hbracket : 0 < + (regularizedBetheObjective Ο„ A W - + regularizedBetheObjective Ο„ A X) + (|d| + 1) := by + linarith + nlinarith [mul_pos htβ‚€ hbracket] + have hbetter : regularizedBetheObjective Ο„ A X < + regularizedBetheObjective Ο„ A Z := by + have hentropyΟ„ := mul_le_mul_of_nonneg_left hentropy hΟ„.le + rw [regularizedBetheObjective, regularizedBetheObjective] at hgain + rw [regularizedBetheObjective, regularizedBetheObjective] + nlinarith + exact (not_lt_of_ge (hmax Z hZ)) hbetter + +theorem regularizedBetheMaximizer_interior + {n : β„•} (hn : 1 < n) + {Ο„ : ℝ} (hΟ„ : 0 < Ο„) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) : + βˆ€ i, IsInteriorProbabilityVector (X i) := by + have hpos := regularizedBetheMaximizer_positive hn hΟ„ hA hX hmax + intro i + exact ⟨hX.row_probability i, fun j ↦ + ⟨hpos i j, + hX.entry_lt_one_of_positive hpos (by simpa using hn) i j⟩⟩ + +/-- Coordinate derivative of the regularized Bethe objective. -/ +noncomputable def regularizedBetheGradient + {n : Type*} (Ο„ : ℝ) (A X : Matrix n n ℝ) (i j : n) : ℝ := + Real.log (A i j) - (1 + Ο„) * Real.log (X i j) - + Real.log (1 - X i j) - (2 + Ο„) + +theorem hasDerivAt_regularizedBetheCoordinate + {Ο„ a x : ℝ} (hxβ‚€ : x β‰  0) (hx₁ : 1 - x β‰  0) : + HasDerivAt (regularizedBetheCoordinate Ο„ a) + (Real.log a - (1 + Ο„) * Real.log x - + Real.log (1 - x) - (2 + Ο„)) x := by + have hlinear : HasDerivAt (fun y : ℝ ↦ y * Real.log a) + (Real.log a) x := by + convert! (hasDerivAt_id x).mul_const (Real.log a) using 1 <;> simp + have hentropy : HasDerivAt + (fun y : ℝ ↦ (1 + Ο„) * Real.negMulLog y) + ((1 + Ο„) * (-Real.log x - 1)) x := by + convert! (Real.hasDerivAt_negMulLog hxβ‚€).const_mul (1 + Ο„) using 1 + have hcomplementInner : HasDerivAt (fun y : ℝ ↦ 1 - y) (-1) x := by + convert! (hasDerivAt_neg' x).const_add 1 using 1 + have hcomplement : HasDerivAt + (fun y : ℝ ↦ Real.negMulLog (1 - y)) + ((-Real.log (1 - x) - 1) * (-1)) x := by + convert! (Real.hasDerivAt_negMulLog hx₁).comp x hcomplementInner using 1 + rw [show regularizedBetheCoordinate Ο„ a = fun y ↦ + y * Real.log a + (1 + Ο„) * Real.negMulLog y - + Real.negMulLog (1 - y) by + funext y + exact regularizedBetheCoordinate_eq_continuousForm Ο„ a y] + convert! (hlinear.add hentropy).sub hcomplement using 1 <;> ring + +/-- An affine perturbation in a matrix direction. -/ +def linearMatrixPerturb + {n : Type*} (X D : Matrix n n ℝ) (t : ℝ) : Matrix n n ℝ := + fun i j ↦ X i j + t * D i j + +theorem hasDerivAt_regularizedBetheObjective_line + {n : Type*} [Fintype n] + {Ο„ : ℝ} {A X D : Matrix n n ℝ} + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) : + HasDerivAt + (fun t ↦ regularizedBetheObjective Ο„ A + (linearMatrixPerturb X D t)) + (βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * D i j) 0 := by + rw [show (fun t ↦ regularizedBetheObjective Ο„ A + (linearMatrixPerturb X D t)) = fun t ↦ + βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate Ο„ (A i j) + (linearMatrixPerturb X D t i j) by + funext t + exact regularizedBetheObjective_eq_sum_coordinates Ο„ A _] + apply HasDerivAt.fun_sum + intro i _ + apply HasDerivAt.fun_sum + intro j _ + have hcoord := hasDerivAt_regularizedBetheCoordinate (Ο„ := Ο„) (a := A i j) + ((hXint i).2 j).1.ne' + (sub_pos.mpr ((hXint i).2 j).2).ne' + have hinner : HasDerivAt (fun t : ℝ ↦ X i j + t * D i j) + (D i j) 0 := by + convert! (hasDerivAt_const (0 : ℝ) (X i j)).add + ((hasDerivAt_id (0 : ℝ)).mul_const (D i j)) using 1 <;> simp + have hcoord' : HasDerivAt (regularizedBetheCoordinate Ο„ (A i j)) + (Real.log (A i j) - (1 + Ο„) * Real.log (X i j) - + Real.log (1 - X i j) - (2 + Ο„)) + ((fun t : ℝ ↦ X i j + t * D i j) 0) := by + convert! hcoord using 1 <;> simp + convert! hcoord'.comp 0 hinner using 1 <;> + simp [linearMatrixPerturb, regularizedBetheGradient] <;> ring + +/-- A strictly positive finite matrix remains nonnegative under all +sufficiently small affine perturbations. -/ +theorem eventually_linearMatrixPerturb_nonnegative + {n : Type*} [Fintype n] + {X D : Matrix n n ℝ} (hXpos : βˆ€ i j, 0 < X i j) : + βˆ€αΆ  t in 𝓝 (0 : ℝ), Matrix.Nonnegative (linearMatrixPerturb X D t) := by + classical + have hone : βˆ€ p : n Γ— n, + βˆ€αΆ  t in 𝓝 (0 : ℝ), 0 < linearMatrixPerturb X D t p.1 p.2 := by + intro p + have hcont : ContinuousAt + (fun t : ℝ ↦ linearMatrixPerturb X D t p.1 p.2) 0 := by + simp only [linearMatrixPerturb] + fun_prop + exact hcont.tendsto.eventually (Ioi_mem_nhds (by + simpa [linearMatrixPerturb] using hXpos p.1 p.2)) + have hfin : βˆ€ s : Finset (n Γ— n), + βˆ€αΆ  t in 𝓝 (0 : ℝ), βˆ€ p ∈ s, + 0 < linearMatrixPerturb X D t p.1 p.2 := by + intro s + induction s using Finset.induction_on with + | empty => simp + | @insert p s hp ih => + filter_upwards [hone p, ih] with t hpt hst + intro q hq + rw [Finset.mem_insert] at hq + rcases hq with rfl | hq + Β· exact hpt + Β· exact hst q hq + filter_upwards [hfin Finset.univ] with t ht i j + exact (ht (i, j) (Finset.mem_univ _)).le + +theorem linearMatrixPerturb_doublyStochastic + {n : Type*} [Fintype n] + {X D : Matrix n n ℝ} {t : ℝ} + (hX : IsDoublyStochastic X) + (hDrow : βˆ€ i, βˆ‘ j, D i j = 0) + (hDcol : βˆ€ j, βˆ‘ i, D i j = 0) + (hnonneg : Matrix.Nonnegative (linearMatrixPerturb X D t)) : + IsDoublyStochastic (linearMatrixPerturb X D t) := by + refine ⟨hnonneg, ?_, ?_⟩ + Β· intro i + simp_rw [linearMatrixPerturb, Finset.sum_add_distrib, ← Finset.mul_sum, + hX.row_sum, hDrow] + ring + Β· intro j + simp_rw [linearMatrixPerturb, Finset.sum_add_distrib, ← Finset.mul_sum, + hX.col_sum, hDcol] + ring + +/-- First-order optimality on the tangent space of the Birkhoff polytope. -/ +theorem regularizedBetheMaximizer_tangent_orthogonal + {n : Type*} [Fintype n] + {Ο„ : ℝ} {A X D : Matrix n n ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) + (hDrow : βˆ€ i, βˆ‘ j, D i j = 0) + (hDcol : βˆ€ j, βˆ‘ i, D i j = 0) : + βˆ‘ i, βˆ‘ j, regularizedBetheGradient Ο„ A X i j * D i j = 0 := by + have hXpos : βˆ€ i j, 0 < X i j := fun i j ↦ (hXint i).2 j |>.1 + have hfeasible : βˆ€αΆ  t in 𝓝 (0 : ℝ), + IsDoublyStochastic (linearMatrixPerturb X D t) := + (eventually_linearMatrixPerturb_nonnegative hXpos).mono fun _ ht ↦ + linearMatrixPerturb_doublyStochastic hX hDrow hDcol ht + have hlocal : IsLocalMax + (fun t ↦ regularizedBetheObjective Ο„ A + (linearMatrixPerturb X D t)) 0 := + hfeasible.mono fun t ht ↦ by + have hzeroPerturb : linearMatrixPerturb X D 0 = X := by + ext i j + simp [linearMatrixPerturb] + change regularizedBetheObjective Ο„ A (linearMatrixPerturb X D t) ≀ + regularizedBetheObjective Ο„ A (linearMatrixPerturb X D 0) + rw [hzeroPerturb] + exact hmax _ ht + exact hlocal.hasDerivAt_eq_zero + (hasDerivAt_regularizedBetheObjective_line hXint) + +/-- Signed difference of two coordinate atoms. -/ +def signedPair + {ΞΉ : Type*} [DecidableEq ΞΉ] (a b : ΞΉ) (x : ΞΉ) : ℝ := + (if a = x then 1 else 0) - (if b = x then 1 else 0) + +theorem sum_signedPair + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) : + βˆ‘ x, signedPair a b x = 0 := by + simp [signedPair, Finset.sum_sub_distrib] + +theorem sum_signedPair_mul + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b : ΞΉ} (hab : a β‰  b) (q : ΞΉ β†’ ℝ) : + βˆ‘ x, signedPair a b x * q x = q a - q b := by + simp [signedPair, sub_mul, Finset.sum_sub_distrib] + +/-- The elementary four-cycle direction in the tangent space of the +Birkhoff polytope. -/ +def rectangleDirection + {ΞΉ : Type*} [DecidableEq ΞΉ] + (i k j l : ΞΉ) : Matrix ΞΉ ΞΉ ℝ := + fun a b ↦ signedPair i k a * signedPair j l b + +theorem rectangleDirection_row_sum + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {i k j l : ΞΉ} (hjl : j β‰  l) : + βˆ€ a, βˆ‘ b, rectangleDirection i k j l a b = 0 := by + intro a + rw [show (βˆ‘ b, rectangleDirection i k j l a b) = + signedPair i k a * βˆ‘ b, signedPair j l b by + simp_rw [rectangleDirection, Finset.mul_sum]] + rw [sum_signedPair hjl, mul_zero] + +theorem rectangleDirection_col_sum + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {i k j l : ΞΉ} (hik : i β‰  k) : + βˆ€ b, βˆ‘ a, rectangleDirection i k j l a b = 0 := by + intro b + rw [show (βˆ‘ a, rectangleDirection i k j l a b) = + (βˆ‘ a, signedPair i k a) * signedPair j l b by + simp_rw [rectangleDirection, Finset.sum_mul]] + rw [sum_signedPair hik, zero_mul] + +theorem sum_mul_rectangleDirection + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (G : Matrix ΞΉ ΞΉ ℝ) {i k j l : ΞΉ} + (hik : i β‰  k) (hjl : j β‰  l) : + (βˆ‘ a, βˆ‘ b, G a b * rectangleDirection i k j l a b) = + G i j - G i l - G k j + G k l := by + have hinner : βˆ€ a, + (βˆ‘ b, G a b * rectangleDirection i k j l a b) = + signedPair i k a * (G a j - G a l) := by + intro a + calc + (βˆ‘ b, G a b * rectangleDirection i k j l a b) = + signedPair i k a * + βˆ‘ b, signedPair j l b * G a b := by + simp_rw [rectangleDirection] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro b _ + ring + _ = signedPair i k a * (G a j - G a l) := by + rw [sum_signedPair_mul hjl] + simp_rw [hinner] + rw [sum_signedPair_mul hik] + ring + +/-- The gradient at an interior maximizer has vanishing alternating sum on +every four-cycle. -/ +theorem regularizedGradient_rectangle_identity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) + {i k j l : ΞΉ} (hik : i β‰  k) (hjl : j β‰  l) : + regularizedBetheGradient Ο„ A X i j - + regularizedBetheGradient Ο„ A X i l - + regularizedBetheGradient Ο„ A X k j + + regularizedBetheGradient Ο„ A X k l = 0 := by + have htangent := regularizedBetheMaximizer_tangent_orthogonal + hX hXint hmax + (rectangleDirection_row_sum hjl) + (rectangleDirection_col_sum hik) + rw [sum_mul_rectangleDirection (regularizedBetheGradient Ο„ A X) hik hjl] at htangent + exact htangent + +/-- Any matrix with zero alternating sum on every rectangle is a sum of a +row potential and a column potential. -/ +theorem exists_rowColumnPotentials_of_rectangle_identity + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + (G : Matrix ΞΉ ΞΉ ℝ) + (hrect : βˆ€ {i k j l : ΞΉ}, i β‰  k β†’ j β‰  l β†’ + G i j - G i l - G k j + G k l = 0) : + βˆƒ r c : ΞΉ β†’ ℝ, βˆ€ i j, G i j = r i + c j := by + let iβ‚€ : ΞΉ := Classical.choice inferInstance + let jβ‚€ : ΞΉ := Classical.choice inferInstance + let r : ΞΉ β†’ ℝ := fun i ↦ G i jβ‚€ + let c : ΞΉ β†’ ℝ := fun j ↦ G iβ‚€ j - G iβ‚€ jβ‚€ + refine ⟨r, c, ?_⟩ + intro i j + by_cases hi : i = iβ‚€ + Β· subst i + simp [r, c] + by_cases hj : j = jβ‚€ + Β· subst j + simp [r, c] + have h := hrect hi hj + dsimp [r, c] + linarith + +/-- The logarithmic KKT factorization in paper Lemma 14. -/ +theorem exists_logKKT_of_regularizedBetheMaximizer + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + {Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) : + βˆƒ r c : ΞΉ β†’ ℝ, HasLogKKT Ο„ A X r c := by + obtain ⟨R, C, hRC⟩ := exists_rowColumnPotentials_of_rectangle_identity + (fun i j ↦ regularizedBetheGradient Ο„ A X i j) + (fun hik hjl ↦ regularizedGradient_rectangle_identity + hX hXint hmax hik hjl) + let r : ΞΉ β†’ ℝ := fun i ↦ R i + (2 + Ο„) + refine ⟨r, C, ?_⟩ + intro i j + have h := hRC i j + dsimp [regularizedBetheGradient, r] at h ⊒ + linarith + +theorem positiveMatrix_hasPerfectMatching + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {A : Matrix ΞΉ ΞΉ ℝ} (hA : Matrix.Positive A) : + Matrix.HasPerfectMatching A := by + refine ⟨Equiv.refl ΞΉ, ?_⟩ + intro i + exact (hA i i).ne' + +/-- A regularized maximizer is within the entropy-regularization budget of +the variational Bethe value. This proof uses the supremum definition and +does not assume that a separate unregularized maximizer has already been +chosen. -/ +theorem betheLogValue_le_regularizedMaximizer + {n : β„•} (hn : 1 < n) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) : + betheLogValue A ≀ betheObjective A X + + Ο„ * (n * Real.log n) := by + let W := uniformBirkhoff n + have hn0 : 0 < n := by omega + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp hn0 + have hW : IsDoublyStochastic W := uniformBirkhoff_doublyStochastic hn0 + have hsetNonempty : + ({v : ℝ | βˆƒ Y, BetheAdmissible A Y ∧ + betheObjective A Y = v} : Set ℝ).Nonempty := by + refine ⟨betheObjective A W, W, ?_, rfl⟩ + exact ⟨hW, fun i j hzero ↦ False.elim ((hA i j).ne' hzero)⟩ + rw [betheLogValue] + apply csSup_le hsetNonempty + intro v hv + obtain ⟨Y, hY, rfl⟩ := hv + have hnear := regularized_near_bethe hΟ„ A X Y hX hY.1 (hmax Y hY.1) + simpa using hnear + +/-- Every feasible value is bounded above by the variational Bethe value. +For positive matrices the support condition in `BetheAdmissible` is +automatic. Compactness supplies a finite upper bound for the supremum. -/ +theorem betheObjective_le_betheLogValue_of_positive + {n : β„•} {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) (hX : IsDoublyStochastic X) : + betheObjective A X ≀ betheLogValue A := by + obtain ⟨M, hM, hmax⟩ := exists_regularizedBetheMaximizer 0 A + have hmax' : βˆ€ Y, IsDoublyStochastic Y β†’ + betheObjective A Y ≀ betheObjective A M := by + intro Y hY + simpa [regularizedBetheObjective] using hmax Y hY + have hbdd : BddAbove + {v : ℝ | βˆƒ Y, BetheAdmissible A Y ∧ betheObjective A Y = v} := by + refine ⟨betheObjective A M, ?_⟩ + rintro v ⟨Y, hY, rfl⟩ + exact hmax' Y hY.1 + rw [betheLogValue] + apply le_csSup hbdd + exact ⟨X, ⟨hX, fun i j hzero ↦ False.elim ((hA i j).ne' hzero)⟩, rfl⟩ + +/-- The regularized objective gap at an arbitrary feasible comparison point +is at most its unregularized Bethe suboptimality plus the entropy budget. +This is the optimization input used in the global transfer estimate. -/ +theorem regularizedDifference_le_betheSuboptimality_add_budget + {n : β„•} (hn : 0 < n) {Ο„ ΞΎ : ℝ} (hΟ„ : 0 ≀ Ο„) + (hbudget : Ο„ * (n * Real.log n) ≀ ΞΎ * n) + {A X P : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) + (hX : IsDoublyStochastic X) (hP : IsDoublyStochastic P) : + regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A P ≀ + betheSuboptimality (betheLogValue A) (betheObjective A P) + ΞΎ * n := by + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp hn + have hbethe := betheObjective_le_betheLogValue_of_positive hA hX + have hHX : totalRowEntropy X ≀ n * Real.log n := by + simpa using totalRowEntropy_le hX + have hHP : 0 ≀ totalRowEntropy P := totalRowEntropy_nonneg hP + have hΟ„HX := mul_le_mul_of_nonneg_left hHX hΟ„ + have hΟ„HP : 0 ≀ Ο„ * totalRowEntropy P := mul_nonneg hΟ„ hHP + rw [regularizedBetheObjective, regularizedBetheObjective, + betheSuboptimality] + linarith + +/-- Paper Lemma 14, in the form consumed by the later transfer argument. +Existence, interiority, near-optimality, and the logarithmic KKT equations are +all proved; the only imported hypothesis is Vontobel's concavity theorem. -/ +theorem exists_regularizedOptimizer_with_logKKT + {n : β„•} (hn : 1 < n) + {Ο„ ΞΎ : ℝ} (hΟ„ : 0 < Ο„) + (hregularization : Ο„ * (n * Real.log n) ≀ ΞΎ * n) + (A : Matrix (Fin n) (Fin n) ℝ) (hA : Matrix.Positive A) : + βˆƒ X : Matrix (Fin n) (Fin n) ℝ, + IsDoublyStochastic X ∧ + (βˆ€ i, IsInteriorProbabilityVector (X i)) ∧ + (βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) ∧ + (βˆƒ r c : Fin n β†’ ℝ, HasLogKKT Ο„ A X r c) ∧ + Real.log (bethePermanent A) - ΞΎ * n ≀ betheObjective A X := by + have hn0 : 0 < n := by omega + letI : Nonempty (Fin n) := Fin.pos_iff_nonempty.mp hn0 + obtain ⟨X, hX, hmax⟩ := exists_regularizedBetheMaximizer Ο„ A + have hXint := regularizedBetheMaximizer_interior hn hΟ„ hA hX hmax + obtain ⟨r, c, hKKT⟩ := + exists_logKKT_of_regularizedBetheMaximizer hX hXint hmax + have hvalue := betheLogValue_le_regularizedMaximizer + hn hΟ„.le hA hX hmax + have hmatch := positiveMatrix_hasPerfectMatching hA + have hlog : Real.log (bethePermanent A) = betheLogValue A := by + rw [bethePermanent, ite_eq_left hmatch, Real.log_exp] + refine ⟨X, hX, hXint, hmax, ⟨r, c, hKKT⟩, ?_⟩ + rw [hlog] + nlinarith + +theorem regularization_budget_of_paper_scale + {n : β„•} {ell ΞΎ Ο„ : ℝ} + (hell : 0 < ell) + (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΟ„ : Ο„ = ΞΎ / (4 * ell)) : + Ο„ * (n * Real.log n) ≀ ΞΎ * n := by + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + have hlog2 : Real.log 2 ≀ 1 := by + have := Real.log_le_sub_one_of_pos (by norm_num : (0 : ℝ) < 2) + norm_num at this ⊒ + exact this + have hΟ„log : Ο„ * Real.log n ≀ ΞΎ := by + calc + Ο„ * Real.log n ≀ Ο„ * (ell * Real.log 2) := + mul_le_mul_of_nonneg_left hlogn hΟ„pos.le + _ = ΞΎ * Real.log 2 / 4 := by + rw [hΟ„] + field_simp [hell.ne'] + _ ≀ ΞΎ := by + have := mul_le_mul_of_nonneg_left hlog2 hΞΎ.le + nlinarith + calc + Ο„ * (n * Real.log n) = n * (Ο„ * Real.log n) := by ring + _ ≀ n * ΞΎ := mul_le_mul_of_nonneg_left hΟ„log (Nat.cast_nonneg n) + _ = ΞΎ * n := by ring + +theorem exists_regularizedOptimizer_at_paper_scale + {n : β„•} (hn : 1 < n) + {ell ΞΎ Ο„ : ℝ} (hell : 0 < ell) + (hlogn : Real.log n ≀ ell * Real.log 2) + (hΞΎ : 0 < ΞΎ) (hΟ„ : Ο„ = ΞΎ / (4 * ell)) + (A : Matrix (Fin n) (Fin n) ℝ) (hA : Matrix.Positive A) : + βˆƒ X : Matrix (Fin n) (Fin n) ℝ, + IsDoublyStochastic X ∧ + (βˆ€ i, IsInteriorProbabilityVector (X i)) ∧ + (βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective Ο„ A Y ≀ + regularizedBetheObjective Ο„ A X) ∧ + (βˆƒ r c : Fin n β†’ ℝ, HasLogKKT Ο„ A X r c) ∧ + Real.log (bethePermanent A) - ΞΎ * n ≀ betheObjective A X := by + have hΟ„pos : 0 < Ο„ := by rw [hΟ„]; positivity + exact exists_regularizedOptimizer_with_logKKT hn hΟ„pos + (regularization_budget_of_paper_scale hell hlogn hΞΎ hΟ„) A hA +end +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/OptimizerOutputEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/OptimizerOutputEncoding.lean new file mode 100644 index 0000000000..3411753943 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/OptimizerOutputEncoding.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec + +/-! +# Canonical finite-word encoding of optimizer output + +This dependency-light module fixes the typed optimizer output and its exact +right-nested binary encoding. It is shared by both the optimizer producer +and the certificate consumer, so neither side depends on the other's +correctness theorem. +-/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-- Rational data returned by a normalized regularized-Bethe optimizer. -/ +structure RationalOptimizerOutput (n : β„•) where + /-- The rational matrix returned by the optimizer. -/ + matrix : Matrix (Fin n) (Fin n) β„š + /-- The optimizer's rational potential indexed by matrix rows. -/ + rowPotential : Fin n β†’ β„š + /-- The optimizer's rational potential indexed by matrix columns. -/ + columnPotential : Fin n β†’ β„š + +/-- Canonical right-nested list encoding of a rational vector. -/ +def rationalVectorBinaryCode {n : β„•} (v : Fin n β†’ β„š) : List Bool := + binaryListCode rationalEntryBinaryCode (List.ofFn v) + +/-- Canonical optimizer-output word: matrix, then row and column potentials. -/ +def rationalOptimizerOutputCode {n : β„•} + (out : RationalOptimizerOutput n) : List Bool := + pair (rationalMatrixBinaryEncoding.encode ⟨n, out.matrix⟩) + (pair (rationalVectorBinaryCode out.rowPotential) + (rationalVectorBinaryCode out.columnPotential)) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/PairFactorization.lean b/LeanPool/BeyondBethe/BeyondBethe/PairFactorization.lean new file mode 100644 index 0000000000..e9b2657569 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/PairFactorization.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.CapacityScaling +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.Gain +public import LeanPool.BeyondBethe.BeyondBethe.TransferIdentity +public import Mathlib.Tactic + +/-! # Pair Factorization -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +/-- Multiplicative form of the KKT equations (paper (35)). -/ +def HasMultiplicativeKKT + {ΞΉ : Type*} [Fintype ΞΉ] + (Ο„ : ℝ) (A X : Matrix ΞΉ ΞΉ ℝ) (r c : ΞΉ β†’ ℝ) : Prop := + βˆ€ i j, A i j = r i * c j * (X i j) ^ (1 + Ο„) * (1 - X i j) + +theorem hasMultiplicativeKKT_of_logKKT + {ΞΉ : Type*} [Fintype ΞΉ] + {Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} {R C : ΞΉ β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hKKT : HasLogKKT Ο„ A X R C) : + HasMultiplicativeKKT Ο„ A X (fun i ↦ Real.exp (R i)) + (fun j ↦ Real.exp (C j)) := by + intro i j + have hx : 0 < X i j := (hXint i).2 j |>.1 + have hcomp : 0 < 1 - X i j := sub_pos.mpr ((hXint i).2 j |>.2) + calc + A i j = Real.exp (Real.log (A i j)) := + (Real.exp_log (hApos i j)).symm + _ = Real.exp (R i + C j + + (1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j)) := by + rw [hKKT i j] + _ = Real.exp (R i) * Real.exp (C j) * + (X i j) ^ (1 + Ο„) * (1 - X i j) := by + rw [Real.exp_add, Real.exp_add, Real.exp_add, + Real.rpow_def_of_pos hx, Real.exp_log hcomp] + ring + +theorem multiplicativeKKT_eq_row_column_transfer + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {A X : Matrix ΞΉ ΞΉ ℝ} {r c : ΞΉ β†’ ℝ} + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hKKT : HasMultiplicativeKKT Ο„ A X r c) (i j : ΞΉ) : + A i j = r i * complementProduct (X i) * c j * + transferU Ο„ (X i) j := by + rw [hKKT i j, transferU_eq_div_complementProduct (hXint i) j] + field_simp [ne_of_gt (complementProduct_pos (hXint i))] + +theorem pairPolynomial_eval_of_row_column_scaling + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b u v c z : ΞΉ β†’ ℝ} {R S : ℝ} + (ha : βˆ€ j, a j = R * c j * u j) + (hb : βˆ€ j, b j = S * c j * v j) : + (pairPolynomial a b).eval z = + (R * S) * (pairPolynomial u v).eval (fun j ↦ c j * z j) := by + rw [pairPolynomial_eval, pairPolynomial_eval] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro e _ + rw [ha e.1, hb e.2] + ring + +theorem pairPolynomial_capacity_of_row_column_scaling + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {a b u v c Ξ± : ΞΉ β†’ ℝ} {R S : ℝ} + (ha0 : βˆ€ j, 0 ≀ a j) (hb0 : βˆ€ j, 0 ≀ b j) + (hu0 : βˆ€ j, 0 ≀ u j) (hv0 : βˆ€ j, 0 ≀ v j) + (hR : 0 < R) (hS : 0 < S) (hc : βˆ€ j, 0 < c j) + (ha : βˆ€ j, a j = R * c j * u j) + (hb : βˆ€ j, b j = S * c j * v j) : + polynomialCapacity Ξ± (pairPolynomial a b) = + ((R * S) * realMonomial c Ξ±) * + polynomialCapacity Ξ± (pairPolynomial u v) := by + apply polynomialCapacity_eq_of_positive_diagonal_rescaling + (pairPolynomial_nonnegativeCoefficients ha0 hb0) + (pairPolynomial_nonnegativeCoefficients hu0 hv0) + (mul_pos hR hS) hc + intro z + exact pairPolynomial_eval_of_row_column_scaling (z := z) ha hb + +theorem singletonCoordinate_factorization + {a x r c Ο„ : ℝ} + (hx : 0 < x) (hx1 : x < 1) (hr : 0 < r) (hc : 0 < c) + (ha : a = r * c * x ^ (1 + Ο„) * (1 - x)) : + (a / x) ^ x * (1 - x) ^ (1 - x) = + r ^ x * c ^ x * x ^ (Ο„ * x) * (1 - x) := by + have hcomp : 0 < 1 - x := sub_pos.mpr hx1 + have hAx : a / x = r * c * x ^ Ο„ * (1 - x) := by + rw [ha, Real.rpow_add hx 1 Ο„, Real.rpow_one] + field_simp [hx.ne'] + rw [hAx] + rw [Real.mul_rpow (mul_nonneg + (mul_nonneg hr.le hc.le) (Real.rpow_nonneg hx.le Ο„)) hcomp.le] + rw [Real.mul_rpow (mul_nonneg hr.le hc.le) + (Real.rpow_nonneg hx.le Ο„)] + rw [Real.mul_rpow hr.le hc.le] + rw [← Real.rpow_mul hx.le Ο„ x] + have hcompPow : (1 - x) ^ x * (1 - x) ^ (1 - x) = 1 - x := by + rw [← Real.rpow_add hcomp x (1 - x)] + convert Real.rpow_one (1 - x) using 2 <;> ring + calc + r ^ x * c ^ x * x ^ (Ο„ * x) * (1 - x) ^ x * + (1 - x) ^ (1 - x) = + (r ^ x * c ^ x * x ^ (Ο„ * x)) * + ((1 - x) ^ x * (1 - x) ^ (1 - x)) := by ring + _ = r ^ x * c ^ x * x ^ (Ο„ * x) * (1 - x) := by + rw [hcompPow] + +/-- Paper (44), stated first for the explicit singleton product `S_i`. -/ +theorem singletonProductValue_factorized_of_multiplicativeKKT + {n : β„•} {Ο„ : ℝ} {A X : Matrix (Fin n) (Fin n) ℝ} + {r c : Fin n β†’ ℝ} + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hr : βˆ€ i, 0 < r i) (hc : βˆ€ j, 0 < c j) + (hKKT : HasMultiplicativeKKT Ο„ A X r c) (i : Fin n) : + singletonProductValue A X i = + r i * complementProduct (X i) * rowZeta Ο„ (X i) * + realMonomial c (X i) := by + rw [singletonProductValue, rowZeta, complementProduct, realMonomial] + simp_rw [singletonCoordinate_factorization + ((hXint i).2 _ |>.1) ((hXint i).2 _ |>.2) (hr i) (hc _) + (hKKT i _)] + have hrprod : (∏ j, (r i) ^ (X i j)) = r i := by + rw [← Real.rpow_sum_of_pos (hr i), hX.row_sum i, Real.rpow_one] + rw [show (∏ j, ((r i) ^ (X i j) * (c j) ^ (X i j) * + (X i j) ^ (Ο„ * X i j) * (1 - X i j))) = + (∏ j, (r i) ^ (X i j)) * (∏ j, (c j) ^ (X i j)) * + (∏ j, (X i j) ^ (Ο„ * X i j)) * + ∏ j, (1 - X i j) by + simp only [← Finset.prod_mul_distrib] + ] + rw [hrprod] + ring + +theorem realMonomial_pairAlpha + {ΞΉ : Type*} [Fintype ΞΉ] + (c : ΞΉ β†’ ℝ) (hc : βˆ€ j, 0 < c j) + (X : Matrix ΞΉ ΞΉ ℝ) (r s : ΞΉ) : + realMonomial c (pairAlpha X r s) = + realMonomial c (X r) * realMonomial c (X s) := by + rw [realMonomial, realMonomial, realMonomial, + ← Finset.prod_mul_distrib] + apply Finset.prod_congr rfl + intro j _ + exact Real.rpow_add (hc j) (X r j) (X s j) + +/-- The gain ratio `Gamma_rs` from paper (10), using the explicit singleton +products from paper (7). -/ +noncomputable def pairGain + {n : β„•} (A X : Matrix (Fin n) (Fin n) ℝ) (r s : Fin n) : ℝ := + pairCertificateValue A X r s / + (singletonProductValue A X r * singletonProductValue A X s) + +/-- Paper Lemma 18. Every KKT scaling and every capacity change of variables +is canceled explicitly. -/ +theorem pairGain_factorization + {n : β„•} {Ο„ : ℝ} {A X : Matrix (Fin n) (Fin n) ℝ} + {rscale cscale : Fin n β†’ ℝ} + (hApos : βˆ€ i j, 0 < A i j) + (hX : IsDoublyStochastic X) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hr : βˆ€ i, 0 < rscale i) (hc : βˆ€ j, 0 < cscale j) + (hKKT : HasMultiplicativeKKT Ο„ A X rscale cscale) + (r s : Fin n) : + pairGain A X r s = + 1 / (rowZeta Ο„ (X r) * rowZeta Ο„ (X s)) * + (∏ j, (1 - pairAlpha X r s j) ^ + (1 - pairAlpha X r s j)) * + polynomialCapacity (pairAlpha X r s) + (pairPolynomial (fun j ↦ transferU Ο„ (X r) j) + (fun j ↦ transferU Ο„ (X s) j)) := by + let qr := complementProduct (X r) + let qs := complementProduct (X s) + let Ur : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X r) j + let Us : Fin n β†’ ℝ := fun j ↦ transferU Ο„ (X s) j + have hqr : 0 < qr := complementProduct_pos (hXint r) + have hqs : 0 < qs := complementProduct_pos (hXint s) + have hUr : βˆ€ j, 0 < Ur j := fun j ↦ transferU_pos (hXint r) j + have hUs : βˆ€ j, 0 < Us j := fun j ↦ transferU_pos (hXint s) j + have hAr : βˆ€ j, A r j = (rscale r * qr) * cscale j * Ur j := by + intro j + simpa only [qr, Ur, mul_assoc] using + multiplicativeKKT_eq_row_column_transfer hXint hKKT r j + have hAs : βˆ€ j, A s j = (rscale s * qs) * cscale j * Us j := by + intro j + simpa only [qs, Us, mul_assoc] using + multiplicativeKKT_eq_row_column_transfer hXint hKKT s j + have hcap := pairPolynomial_capacity_of_row_column_scaling + (Ξ± := pairAlpha X r s) + (fun j ↦ (hApos r j).le) (fun j ↦ (hApos s j).le) + (fun j ↦ (hUr j).le) (fun j ↦ (hUs j).le) + (mul_pos (hr r) hqr) (mul_pos (hr s) hqs) hc hAr hAs + have hSr := singletonProductValue_factorized_of_multiplicativeKKT + hX hXint hr hc hKKT r + have hSs := singletonProductValue_factorized_of_multiplicativeKKT + hX hXint hr hc hKKT s + have hcAlpha := realMonomial_pairAlpha cscale hc X r s + have hzetaR : 0 < rowZeta Ο„ (X r) := + rowZeta_pos (fun j ↦ (hXint r).2 j |>.1) + have hzetaS : 0 < rowZeta Ο„ (X s) := + rowZeta_pos (fun j ↦ (hXint s).2 j |>.1) + have hcR : 0 < realMonomial cscale (X r) := + realMonomial_pos hc (X r) + have hcS : 0 < realMonomial cscale (X s) := + realMonomial_pos hc (X s) + rw [pairGain, pairCertificateValue, hcap, hSr, hSs, hcAlpha] + dsimp only [qr, qs, Ur, Us] at * + field_simp [ne_of_gt (hr r), ne_of_gt (hr s), hqr.ne', hqs.ne', + hzetaR.ne', hzetaS.ne', hcR.ne', hcS.ne'] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/PairStability.lean b/LeanPool/BeyondBethe/BeyondBethe/PairStability.lean new file mode 100644 index 0000000000..465c837798 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/PairStability.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.PairedCertificate + +/-! # Pair Stability -/ + +@[expose] public section + +open scoped BigOperators ComplexConjugate + +namespace BeyondBethe + +open MvPolynomial + +/-- The multivariate linear polynomial whose variable coefficients are `u`; coefficient +positivity is a separate hypothesis. -/ +noncomputable def positiveLinearPolynomial + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u : ΞΉ β†’ ℝ) : MvPolynomial ΞΉ ℝ := + βˆ‘ j, monomial (Finsupp.single j 1) (u j) + +theorem positiveLinearPolynomial_nonnegativeCoefficients + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u : ΞΉ β†’ ℝ} (hu : βˆ€ i, 0 ≀ u i) : + HasNonnegativeCoefficients (positiveLinearPolynomial u) := by + intro d + rw [positiveLinearPolynomial, coeff_sum] + apply Finset.sum_nonneg + intro i _ + rw [coeff_monomial] + split + Β· exact hu i + Β· exact le_rfl + +theorem positiveLinearPolynomial_isRealStable + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] [Nonempty ΞΉ] + {u : ΞΉ β†’ ℝ} (hu : βˆ€ i, 0 < u i) : + IsRealStable (positiveLinearPolynomial u) := by + intro z hz + rw [positiveLinearPolynomial, evalβ‚‚_sum] + simp only [evalβ‚‚_monomial, RingHom.id_apply, + Finsupp.prod_single_index, pow_one, one_mul] + have him : 0 < βˆ‘ i, u i * (z i).im := + Finset.sum_pos (fun i _ ↦ mul_pos (hu i) (hz i)) + Finset.univ_nonempty + intro heq + have hzero := congrArg Complex.im heq + simp at hzero + linarith + +/-- The finite real dot product of coordinate functions `a` and `x`. -/ +noncomputable def realDot + {ΞΉ : Type*} [Fintype ΞΉ] (a x : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i, a i * x i + +/-- The product of two linear forms with their diagonal quadratic contribution removed. -/ +noncomputable def pairQuadraticForm + {ΞΉ : Type*} [Fintype ΞΉ] (u v x : ΞΉ β†’ ℝ) : ℝ := + realDot u x * realDot v x - βˆ‘ i, u i * v i * x i ^ 2 + +/-- The symmetric bilinear polarization of the pair quadratic form. -/ +noncomputable def pairBilinearForm + {ΞΉ : Type*} [Fintype ΞΉ] (u v x y : ΞΉ β†’ ℝ) : ℝ := + realDot u x * realDot v y + realDot u y * realDot v x - + 2 * βˆ‘ i, u i * v i * x i * y i + +theorem realDot_mul_realDot + {ΞΉ : Type*} [Fintype ΞΉ] + (a b x y : ΞΉ β†’ ℝ) : + realDot a x * realDot b y = + βˆ‘ i, βˆ‘ j, a i * b j * x i * y j := by + simp only [realDot] + rw [Finset.mul_sum] + simp_rw [Finset.sum_mul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i _ + apply Finset.sum_congr rfl + intro j _ + ring + +theorem sum_offDiag_eq_sum_product_sub_diag + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (f : ΞΉ Γ— ΞΉ β†’ ℝ) : + (βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, f e) = + (βˆ‘ i, βˆ‘ j, f (i, j)) - βˆ‘ i, f (i, i) := by + have hunion : + (βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).diag βˆͺ Finset.univ.offDiag, f e) = + (βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).diag, f e) + + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, f e := + Finset.sum_union + (Finset.disjoint_diag_offDiag (Finset.univ : Finset ΞΉ)) + rw [Finset.diag_union_offDiag, Finset.sum_diag, + Finset.sum_product] at hunion + linarith + +theorem pairQuadraticForm_eq_offDiag + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v x : ΞΉ β†’ ℝ) : + pairQuadraticForm u v x = + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + u e.1 * v e.2 * x e.1 * x e.2 := by + rw [sum_offDiag_eq_sum_product_sub_diag] + simp only [pairQuadraticForm] + rw [realDot_mul_realDot] + apply congrArgβ‚‚ (Β· - Β·) rfl + apply Finset.sum_congr rfl + intro i _ + ring + +theorem pairBilinearForm_eq_offDiag + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v x y : ΞΉ β†’ ℝ) : + pairBilinearForm u v x y = + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + u e.1 * v e.2 * (x e.1 * y e.2 + y e.1 * x e.2) := by + rw [sum_offDiag_eq_sum_product_sub_diag] + simp only [pairBilinearForm] + rw [realDot_mul_realDot, realDot_mul_realDot] + simp_rw [mul_add, Finset.sum_add_distrib] + have hdiag : (βˆ‘ i, u i * v i * (y i * x i)) = + βˆ‘ i, u i * v i * (x i * y i) := by + apply Finset.sum_congr rfl + intro i _ + ring + rw [hdiag] + ring + +theorem pairPolynomial_eval_eq_quadraticForm + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v x : ΞΉ β†’ ℝ) : + (pairPolynomial u v).eval x = pairQuadraticForm u v x := by + rw [pairPolynomial_eval, pairQuadraticForm_eq_offDiag] + +theorem pairPolynomial_evalβ‚‚_complex + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) (z : ΞΉ β†’ β„‚) : + (pairPolynomial u v).evalβ‚‚ (algebraMap ℝ β„‚) z = + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + ((u e.1 * v e.2 : ℝ) : β„‚) * z e.1 * z e.2 := by + rw [pairPolynomial, evalβ‚‚_sum] + apply Finset.sum_congr rfl + intro e _ + rw [evalβ‚‚_monomial] + rw [Finsupp.prod_add_index] + Β· simp [Finsupp.prod_single_index, mul_assoc, mul_left_comm, mul_comm] + Β· simp + Β· intro a _ b c + exact pow_add (z a) b c + +theorem pairPolynomial_evalβ‚‚_complex_re + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) (z : ΞΉ β†’ β„‚) : + ((pairPolynomial u v).evalβ‚‚ (algebraMap ℝ β„‚) z).re = + pairQuadraticForm u v (fun i ↦ (z i).re) - + pairQuadraticForm u v (fun i ↦ (z i).im) := by + rw [pairPolynomial_evalβ‚‚_complex] + simp + rw [pairQuadraticForm_eq_offDiag, pairQuadraticForm_eq_offDiag] + +theorem pairPolynomial_evalβ‚‚_complex_im + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) (z : ΞΉ β†’ β„‚) : + ((pairPolynomial u v).evalβ‚‚ (algebraMap ℝ β„‚) z).im = + pairBilinearForm u v (fun i ↦ (z i).re) (fun i ↦ (z i).im) := by + rw [pairPolynomial_evalβ‚‚_complex] + simp + rw [pairBilinearForm_eq_offDiag] + ring + +theorem realDot_sub_mul + {ΞΉ : Type*} [Fintype ΞΉ] + (u x y : ΞΉ β†’ ℝ) (t : ℝ) : + realDot u (fun i ↦ x i - t * y i) = + realDot u x - t * realDot u y := by + simp only [realDot, mul_sub] + rw [Finset.sum_sub_distrib, Finset.mul_sum] + apply congrArgβ‚‚ (Β· - Β·) rfl + apply Finset.sum_congr rfl + intro i _ + ring + +theorem pairQuadraticForm_sub_mul + {ΞΉ : Type*} [Fintype ΞΉ] + (u v x y : ΞΉ β†’ ℝ) (t : ℝ) : + pairQuadraticForm u v (fun i ↦ x i - t * y i) = + pairQuadraticForm u v x - t * pairBilinearForm u v x y + + t ^ 2 * pairQuadraticForm u v y := by + have hdiag : + (βˆ‘ i, u i * v i * (x i - t * y i) ^ 2) = + (βˆ‘ i, u i * v i * x i ^ 2) - + 2 * t * (βˆ‘ i, u i * v i * x i * y i) + + t ^ 2 * (βˆ‘ i, u i * v i * y i ^ 2) := by + calc + (βˆ‘ i, u i * v i * (x i - t * y i) ^ 2) = + βˆ‘ i, (u i * v i * x i ^ 2 - + 2 * t * (u i * v i * x i * y i) + + t ^ 2 * (u i * v i * y i ^ 2)) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = (βˆ‘ i, u i * v i * x i ^ 2) - + 2 * t * (βˆ‘ i, u i * v i * x i * y i) + + t ^ 2 * (βˆ‘ i, u i * v i * y i ^ 2) := by + simp_rw [Finset.sum_add_distrib, Finset.sum_sub_distrib, + Finset.mul_sum] + simp only [pairQuadraticForm, pairBilinearForm, realDot_sub_mul, hdiag] + ring + +theorem pairQuadraticForm_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v y : ΞΉ β†’ ℝ} (hcard : 2 ≀ Fintype.card ΞΉ) + (hu : βˆ€ i, 0 < u i) (hv : βˆ€ i, 0 < v i) + (hy : βˆ€ i, 0 < y i) : + 0 < pairQuadraticForm u v y := by + rw [pairQuadraticForm_eq_offDiag] + apply Finset.sum_pos + Β· intro e he + exact mul_pos (mul_pos (mul_pos (hu e.1) (hv e.2)) (hy e.1)) (hy e.2) + Β· obtain ⟨i, j, hij⟩ := Fintype.one_lt_card_iff.mp (by omega : + 1 < Fintype.card ΞΉ) + exact ⟨(i, j), by simp [hij]⟩ + +/-- The quadratic form of the pair polynomial is nonpositive on the +bilinear-orthogonal complement of any positive direction. This is the +at-most-one-positive-direction argument needed in the stability proof; it +uses the hyperplane `dot(u,x)=0`, on which the form is visibly nonpositive. -/ +theorem pairQuadraticForm_nonpos_of_bilinear_zero + {ΞΉ : Type*} [Fintype ΞΉ] [Nonempty ΞΉ] + {u v x y : ΞΉ β†’ ℝ} + (hu : βˆ€ i, 0 < u i) (hv : βˆ€ i, 0 < v i) + (hy : βˆ€ i, 0 < y i) + (hypos : 0 < pairQuadraticForm u v y) + (horth : pairBilinearForm u v x y = 0) : + pairQuadraticForm u v x ≀ 0 := by + let uy := realDot u y + have huy : 0 < uy := by + dsimp [uy] + rw [realDot] + exact Finset.sum_pos (fun i _ ↦ mul_pos (hu i) (hy i)) + Finset.univ_nonempty + let t := realDot u x / uy + let z : ΞΉ β†’ ℝ := fun i ↦ x i - t * y i + have huz : realDot u z = 0 := by + change realDot u (fun i ↦ x i - t * y i) = 0 + rw [realDot_sub_mul] + dsimp [t] + rw [div_mul_cancelβ‚€ _ (ne_of_gt huy)] + ring + have hznonpos : pairQuadraticForm u v z ≀ 0 := by + rw [pairQuadraticForm, huz, zero_mul, zero_sub] + exact neg_nonpos.mpr (Finset.sum_nonneg fun i _ ↦ + mul_nonneg (mul_nonneg (le_of_lt (hu i)) (le_of_lt (hv i))) + (sq_nonneg (z i))) + have hshift : pairQuadraticForm u v z = + pairQuadraticForm u v x + t ^ 2 * pairQuadraticForm u v y := by + change pairQuadraticForm u v (fun i ↦ x i - t * y i) = _ + rw [pairQuadraticForm_sub_mul, horth] + ring + have hgain : 0 ≀ t ^ 2 * pairQuadraticForm u v y := + mul_nonneg (sq_nonneg t) (le_of_lt hypos) + linarith + +/-- The pair polynomial is real stable for positive row weights as soon as +there are at least two variables. This closes the quadratic-stability step +for the polynomial used in the paper without importing an eigenvalue or +inertia theorem: the hyperplane orthogonal to `u` already witnesses that the +quadratic form has at most one positive direction. -/ +theorem pairPolynomial_isRealStable_of_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} (hcard : 2 ≀ Fintype.card ΞΉ) + (hu : βˆ€ i, 0 < u i) (hv : βˆ€ i, 0 < v i) : + IsRealStable (pairPolynomial u v) := by + letI : Nonempty ΞΉ := Fintype.card_pos_iff.mp (by omega) + intro z hz hzero + let x : ΞΉ β†’ ℝ := fun i ↦ (z i).re + let y : ΞΉ β†’ ℝ := fun i ↦ (z i).im + have hypos : 0 < pairQuadraticForm u v y := + pairQuadraticForm_pos hcard hu hv (fun i ↦ hz i) + have hre : pairQuadraticForm u v x - pairQuadraticForm u v y = 0 := by + have h := congrArg Complex.re hzero + rw [pairPolynomial_evalβ‚‚_complex_re] at h + simpa [x, y] using h + have him : pairBilinearForm u v x y = 0 := by + have h := congrArg Complex.im hzero + rw [pairPolynomial_evalβ‚‚_complex_im] at h + simpa [x, y] using h + have hxnonpos : pairQuadraticForm u v x ≀ 0 := + pairQuadraticForm_nonpos_of_bilinear_zero hu hv (fun i ↦ hz i) + hypos him + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/PairedCertificate.lean b/LeanPool/BeyondBethe/BeyondBethe/PairedCertificate.lean new file mode 100644 index 0000000000..1784840e72 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/PairedCertificate.lean @@ -0,0 +1,490 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import Mathlib.Tactic + +/-! # Paired Certificate -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +/-- A partition of the row set into named clusters. The equivalence labels +each row by its cluster and its position inside that cluster. Pair +certificates use the special case in which every size is one or two, but the +coefficient identity below holds for arbitrary cluster sizes. -/ +structure RowClustering (n : β„•) where + /-- The type indexing the row clusters. -/ + Cluster : Type + clusterFintype : Fintype Cluster + clusterDecidableEq : DecidableEq Cluster + /-- The number of local row positions assigned to each cluster. -/ + size : Cluster β†’ β„• + /-- An equivalence identifying all cluster-local row positions with the original matrix rows. -/ + rows : (Ξ£ c, Fin (size c)) ≃ Fin n + +attribute [instance] RowClustering.clusterFintype +attribute [instance] RowClustering.clusterDecidableEq + +namespace RowClustering + +variable {n : β„•} (C : RowClustering n) + +/-- The cluster containing a row. -/ +noncomputable def clusterOfRow (i : Fin n) : C.Cluster := + (C.rows.symm i).1 + +/-- The cluster selected at each column by a permutation in Mathlib's +column-to-row orientation. -/ +noncomputable def clusterAssignment (Οƒ : Equiv.Perm (Fin n)) : + Fin n β†’ C.Cluster := + fun j ↦ C.clusterOfRow (Οƒ j) + +end RowClustering + +/-- Squarefree exponent vector selecting one cluster variable for each +column. -/ +noncomputable def selectorExponent + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype ΞΉ] + (h : ΞΉ β†’ ΞΊ) : ΞΊ Γ— ΞΉ β†’β‚€ β„• := + Finsupp.equivFunOnFinite.symm fun v ↦ if v.1 = h v.2 then 1 else 0 + +@[simp] +theorem selectorExponent_apply + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype ΞΉ] + (h : ΞΉ β†’ ΞΊ) (c : ΞΊ) (j : ΞΉ) : + selectorExponent h (c, j) = if c = h j then 1 else 0 := by + simp [selectorExponent] + +theorem selectorExponent_injective + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] [Fintype ΞΉ] + [DecidableEq ΞΉ] : + Function.Injective (selectorExponent : (ΞΉ β†’ ΞΊ) β†’ ΞΊ Γ— ΞΉ β†’β‚€ β„•) := by + intro h h' heq + funext j + have hj := congrArg (fun d : ΞΊ Γ— ΞΉ β†’β‚€ β„• ↦ d (h j, j)) heq + simp only [selectorExponent_apply, ite_eq_left rfl] at hj + by_contra hne + simp [hne] at hj + +theorem selectorExponent_eq_sum_single + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] (h : ΞΉ β†’ ΞΊ) : + selectorExponent h = + βˆ‘ j, Finsupp.single (h j, j) 1 := by + classical + ext ⟨c, j⟩ + simp [selectorExponent_apply, Finsupp.single_apply] + by_cases hc : c = h j + Β· subst c + have hs : ({x : ΞΉ | h x = h j ∧ x = j} : Finset ΞΉ) = {j} := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_singleton] + constructor + Β· intro hx + simpa using hx.2 + Β· intro hx + have hxj : x = j := by simpa using hx + subst x + simp + rw [hs] + simp + Β· have hs : ({x : ΞΉ | h x = c ∧ x = j} : Finset ΞΉ) = βˆ… := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + Β· intro hx + have hxj : x = j := hx.2 + subst x + exact (hc hx.1.symm).elim + Β· simp + rw [hs] + simp [hc] + +theorem selectorExponent_degree + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] (h : ΞΉ β†’ ΞΊ) : + Finsupp.degree (selectorExponent h) = Fintype.card ΞΉ := by + rw [selectorExponent_eq_sum_single, map_sum] + simp [Finsupp.degree_single] + +theorem monomial_selectorExponent + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] (h : ΞΉ β†’ ΞΊ) : + (monomial (selectorExponent h) 1 : MvPolynomial (ΞΊ Γ— ΞΉ) ℝ) = + ∏ j, X (h j, j) := by + rw [selectorExponent_eq_sum_single, monomial_sum_one] + simp [← X_pow_eq_monomial] + +/-- The column-selector polynomial written in its monomial expansion. It is +the expansion of `prod_j (sum_C z_{Cj})`. -/ +noncomputable def columnSelector + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : MvPolynomial (ΞΊ Γ— ΞΉ) ℝ := + βˆ‘ h : ΞΉ β†’ ΞΊ, monomial (selectorExponent h) 1 + +/-- The factored form of the column selector used for its stability proof. -/ +noncomputable def columnSelectorProduct + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : MvPolynomial (ΞΊ Γ— ΞΉ) ℝ := + ∏ j : ΞΉ, βˆ‘ c : ΞΊ, X (c, j) + +theorem columnSelector_eq_product + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + columnSelector ΞΊ ΞΉ = columnSelectorProduct ΞΊ ΞΉ := by + rw [columnSelectorProduct, Fintype.prod_sum, columnSelector] + apply Finset.sum_congr rfl + intro h _ + exact monomial_selectorExponent h + +/-- The column selector is real stable: at an upper-half-plane input, each +column factor has strictly positive imaginary part. -/ +theorem columnSelector_isRealStable + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] [Nonempty ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + IsRealStable (columnSelector ΞΊ ΞΉ) := by + rw [columnSelector_eq_product] + intro z hz + rw [columnSelectorProduct, MvPolynomial.evalβ‚‚_prod] + apply Finset.prod_ne_zero_iff.mpr + intro j _ + rw [MvPolynomial.evalβ‚‚_sum] + simp only [MvPolynomial.evalβ‚‚_X] + have him : 0 < βˆ‘ c : ΞΊ, (z (c, j)).im := + Finset.sum_pos (fun c _ ↦ hz (c, j)) Finset.univ_nonempty + intro heq + have hzero := congrArg Complex.im heq + simp at hzero + linarith + +theorem columnSelector_nonnegativeCoefficients + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + HasNonnegativeCoefficients (columnSelector ΞΊ ΞΉ) := by + intro d + rw [columnSelector, coeff_sum] + apply Finset.sum_nonneg + intro h _ + rw [coeff_monomial] + split <;> norm_num + +theorem columnSelector_isHomogeneous + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + (columnSelector ΞΊ ΞΉ).IsHomogeneous (Fintype.card ΞΉ) := by + rw [columnSelector] + apply MvPolynomial.IsHomogeneous.sum + intro h _ + exact isHomogeneous_monomial 1 (selectorExponent_degree h) + +theorem columnSelector_isMultiaffine + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + IsMultiaffine (columnSelector ΞΊ ΞΉ) := by + intro v + rw [columnSelector] + refine (degreeOf_sum_le v _ _).trans (Finset.sup_le ?_) + intro h _ + rw [degreeOf_monomial_eq _ _ one_ne_zero] + rcases v with ⟨c, j⟩ + rw [selectorExponent_apply] + split <;> simp + +theorem columnSelector_coeff_selectorExponent + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] (h : ΞΉ β†’ ΞΊ) : + (columnSelector ΞΊ ΞΉ).coeff (selectorExponent h) = 1 := by + rw [columnSelector, coeff_sum] + simp only [coeff_monomial] + have heq : βˆ€ h' : ΞΉ β†’ ΞΊ, + (selectorExponent h' = selectorExponent h) ↔ h' = h := fun h' ↦ + (selectorExponent_injective.eq_iff) + simp_rw [heq] + rw [Finset.sum_ite_eq' Finset.univ h] + simp + +theorem columnSelector_support + (ΞΊ ΞΉ : Type*) [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] : + (columnSelector ΞΊ ΞΉ).support = + Finset.univ.image (selectorExponent : (ΞΉ β†’ ΞΊ) β†’ ΞΊ Γ— ΞΉ β†’β‚€ β„•) := by + ext d + constructor + Β· intro hd + rw [mem_support_iff, columnSelector, coeff_sum] at hd + simp only [coeff_monomial] at hd + obtain ⟨h, _, hh⟩ := Finset.exists_ne_zero_of_sum_ne_zero hd + by_cases heq : selectorExponent h = d + Β· exact Finset.mem_image.mpr ⟨h, Finset.mem_univ h, heq⟩ + Β· simp [heq] at hh + Β· intro hd + obtain ⟨h, _, rfl⟩ := Finset.mem_image.mp hd + rw [mem_support_iff, columnSelector_coeff_selectorExponent h] + norm_num +theorem coefficientInnerProduct_eq_sum_right_support_of_coeff_one + {Οƒ : Type*} + (p q : MvPolynomial Οƒ ℝ) + (hq : βˆ€ d ∈ q.support, q.coeff d = 1) : + coefficientInnerProduct p q = βˆ‘ d ∈ q.support, p.coeff d := by + classical + rw [coefficientInnerProduct] + calc + (βˆ‘ d ∈ p.support.filter (Β· ∈ q.support), + p.coeff d * q.coeff d) = + βˆ‘ d ∈ p.support.filter (Β· ∈ q.support), p.coeff d := by + apply Finset.sum_congr rfl + intro d hd + rw [hq d (Finset.mem_filter.mp hd).2, mul_one] + _ = βˆ‘ d ∈ q.support, p.coeff d := by + apply Finset.sum_subset + Β· intro d hd + exact (Finset.mem_filter.mp hd).2 + Β· intro d hdq hdnot + by_contra hne + apply hdnot + exact Finset.mem_filter.mpr ⟨by + rwa [mem_support_iff], hdq⟩ + +/- Pairing with the column selector extracts exactly the coefficients whose +exponents choose one cluster for each column. -/ +theorem coefficientInnerProduct_columnSelector + {ΞΊ ΞΉ : Type*} [Fintype ΞΊ] [DecidableEq ΞΊ] + [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : MvPolynomial (ΞΊ Γ— ΞΉ) ℝ) : + coefficientInnerProduct p (columnSelector ΞΊ ΞΉ) = + βˆ‘ h : ΞΉ β†’ ΞΊ, p.coeff (selectorExponent h) := by + rw [coefficientInnerProduct_eq_sum_right_support_of_coeff_one] + Β· rw [columnSelector_support, + Finset.sum_image selectorExponent_injective.injOn] + Β· intro d hd + rw [columnSelector_support] at hd + obtain ⟨h, _, rfl⟩ := Finset.mem_image.mp hd + exact columnSelector_coeff_selectorExponent h + +/-- The cluster polynomial in expanded form. Permutations that differ only +inside a cluster contribute to the same monomial, so their weights add in its +coefficient exactly as in the paper's pair polynomial. -/ +noncomputable def expandedClusterPolynomial + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + MvPolynomial (C.Cluster Γ— Fin n) ℝ := + βˆ‘ Οƒ : Equiv.Perm (Fin n), + monomial (selectorExponent (C.clusterAssignment Οƒ)) + (∏ j, A (Οƒ j) j) + +theorem expandedClusterPolynomial_support + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + {d : C.Cluster Γ— Fin n β†’β‚€ β„•} + (hd : d ∈ (expandedClusterPolynomial A C).support) : + βˆƒ Οƒ : Equiv.Perm (Fin n), + d = selectorExponent (C.clusterAssignment Οƒ) := by + rw [mem_support_iff] at hd + rw [expandedClusterPolynomial, coeff_sum] at hd + simp only [coeff_monomial] at hd + obtain βŸ¨Οƒ, _, hΟƒβŸ© := Finset.exists_ne_zero_of_sum_ne_zero hd + by_cases heq : selectorExponent (C.clusterAssignment Οƒ) = d + Β· exact βŸ¨Οƒ, heq.symm⟩ + Β· simp [heq] at hΟƒ + +theorem columnSelector_coeff_of_mem_expandedClusterPolynomial + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) + {d : C.Cluster Γ— Fin n β†’β‚€ β„•} + (hd : d ∈ (expandedClusterPolynomial A C).support) : + (columnSelector C.Cluster (Fin n)).coeff d = 1 := by + obtain βŸ¨Οƒ, rfl⟩ := expandedClusterPolynomial_support A C hd + exact columnSelector_coeff_selectorExponent (C.clusterAssignment Οƒ) + +theorem sum_coeff_expandedClusterPolynomial_eq_permanent + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + (βˆ‘ d ∈ (expandedClusterPolynomial A C).support, + (expandedClusterPolynomial A C).coeff d) = Matrix.permanent A := by + let one : C.Cluster Γ— Fin n β†’ ℝ := fun _ ↦ 1 + have hevalCoeffs : + (expandedClusterPolynomial A C).eval one = + βˆ‘ d ∈ (expandedClusterPolynomial A C).support, + (expandedClusterPolynomial A C).coeff d := by + rw [eval_eq] + simp [one] + have hevalPerm : + (expandedClusterPolynomial A C).eval one = Matrix.permanent A := by + rw [expandedClusterPolynomial, eval_sum] + simp [eval_monomial, one, Matrix.permanent] + exact hevalCoeffs.symm.trans hevalPerm + +/- Paper equation (12): the same-monomial coefficient pairing of the +expanded cluster polynomial and the column selector is exactly the +permanent. This proof is purely finite and does not use real stability. -/ +theorem coefficientInnerProduct_cluster_selector_eq_permanent + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) (C : RowClustering n) : + coefficientInnerProduct (expandedClusterPolynomial A C) + (columnSelector C.Cluster (Fin n)) = Matrix.permanent A := by + let p := expandedClusterPolynomial A C + let q := columnSelector C.Cluster (Fin n) + change coefficientInnerProduct p q = Matrix.permanent A + rw [coefficientInnerProduct, Finset.sum_filter] + have hsum : (βˆ‘ d ∈ p.support, p.coeff d) = Matrix.permanent A := by + simpa only [p] using sum_coeff_expandedClusterPolynomial_eq_permanent A C + apply Eq.trans ?_ hsum + apply Finset.sum_congr rfl + intro d hd + have hcoeff : q.coeff d = 1 := + columnSelector_coeff_of_mem_expandedClusterPolynomial A C hd + have hmem : d ∈ q.support := by + rw [mem_support_iff, hcoeff] + norm_num + simp [hmem, hcoeff] + +/-- The two-row polynomial `Q_{rs}` from paper (9), written as a sum over +ordered off-diagonal pairs. The two orientations of `{j,k}` contribute the +two terms in its coefficient. -/ +noncomputable def pairPolynomial + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) : MvPolynomial ΞΉ ℝ := + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + monomial (Finsupp.single e.1 1 + Finsupp.single e.2 1) + (u e.1 * v e.2) + +theorem single_add_single_one_eq_iff + {ΞΉ : Type*} [DecidableEq ΞΉ] + {a b j k : ΞΉ} (hab : a β‰  b) (hjk : j β‰  k) : + Finsupp.single a 1 + Finsupp.single b 1 = + Finsupp.single j 1 + Finsupp.single k 1 ↔ + (a = j ∧ b = k) ∨ (a = k ∧ b = j) := by + rw [Finsupp.single_add_single_eq_single_add_single + (one_ne_zero : (1 : β„•) β‰  0) (one_ne_zero : (1 : β„•) β‰  0)] + simp [hab, hjk] + +/-- The coefficient of `z_j z_k` is the combined weight of the two internal +assignments, exactly as stated below paper (9). -/ +theorem pairPolynomial_coeff_two + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) {j k : ΞΉ} (hjk : j β‰  k) : + (pairPolynomial u v).coeff + (Finsupp.single j 1 + Finsupp.single k 1) = + u j * v k + u k * v j := by + classical + rw [pairPolynomial, coeff_sum] + simp only [coeff_monomial] + have hjkMem : (j, k) ∈ (Finset.univ : Finset ΞΉ).offDiag := by + simp [hjk] + have hkjMem : (k, j) ∈ (Finset.univ : Finset ΞΉ).offDiag := by + simp [Ne.symm hjk] + calc + (βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + if Finsupp.single e.1 1 + Finsupp.single e.2 1 = + Finsupp.single j 1 + Finsupp.single k 1 then + u e.1 * v e.2 else 0) = + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + if e = (j, k) ∨ e = (k, j) then u e.1 * v e.2 else 0 := by + apply Finset.sum_congr rfl + intro e he + have heNe : e.1 β‰  e.2 := (Finset.mem_offDiag.mp he).2.2 + have hiff : + (Finsupp.single e.1 1 + Finsupp.single e.2 1 = + Finsupp.single j 1 + Finsupp.single k 1) ↔ + e = (j, k) ∨ e = (k, j) := by + rw [single_add_single_one_eq_iff heNe hjk] + simp only [Prod.ext_iff] + by_cases h : Finsupp.single e.1 1 + Finsupp.single e.2 1 = + Finsupp.single j 1 + Finsupp.single k 1 + Β· simp [h, hiff.mp h] + Β· have hnot : Β¬(e = (j, k) ∨ e = (k, j)) := fun heq ↦ h (hiff.mpr heq) + simp [h, hnot] + _ = u j * v k + u k * v j := by + rw [← Finset.sum_filter, Finset.filter_or, + Finset.filter_eq' _ (j, k), Finset.filter_eq' _ (k, j)] + simp [hjkMem, hkjMem, hjk] + +/-- Evaluation of the pair polynomial in the ordered-pair form. -/ +theorem pairPolynomial_eval + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v z : ΞΉ β†’ ℝ) : + (pairPolynomial u v).eval z = + βˆ‘ e ∈ (Finset.univ : Finset ΞΉ).offDiag, + u e.1 * v e.2 * z e.1 * z e.2 := by + rw [pairPolynomial, eval_sum] + apply Finset.sum_congr rfl + intro e _ + rw [eval_monomial] + rw [Finsupp.prod_add_index] + Β· simp [Finsupp.prod_single_index, mul_assoc, mul_left_comm, mul_comm] + Β· simp + Β· intro a _ b c + exact pow_add (z a) b c + +theorem pairPolynomial_nonnegativeCoefficients + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {u v : ΞΉ β†’ ℝ} (hu : βˆ€ i, 0 ≀ u i) (hv : βˆ€ i, 0 ≀ v i) : + HasNonnegativeCoefficients (pairPolynomial u v) := by + intro d + rw [pairPolynomial, coeff_sum] + apply Finset.sum_nonneg + intro e _ + rw [coeff_monomial] + split + Β· exact mul_nonneg (hu e.1) (hv e.2) + Β· exact le_rfl + +theorem pairPolynomial_isHomogeneous + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) : + (pairPolynomial u v).IsHomogeneous 2 := by + rw [pairPolynomial] + apply MvPolynomial.IsHomogeneous.sum + intro e he + apply isHomogeneous_monomial + simp [map_add, Finsupp.degree_single] + +theorem pairPolynomial_isMultiaffine + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (u v : ΞΉ β†’ ℝ) : + IsMultiaffine (pairPolynomial u v) := by + intro i + rw [pairPolynomial] + refine (degreeOf_sum_le i _ _).trans (Finset.sup_le ?_) + intro e he + have hne : e.1 β‰  e.2 := (Finset.mem_offDiag.mp he).2.2 + by_cases hc : u e.1 * v e.2 = 0 + Β· simp [hc] + Β· rw [degreeOf_monomial_eq _ _ hc] + by_cases hi : i = e.1 + Β· subst i + simp [Finsupp.single_apply, hne] + Β· by_cases hi' : i = e.2 + Β· subst i + simp [Finsupp.single_apply, hne, Ne.symm hne] + Β· simp [Finsupp.single_apply, hi, hi'] + +/-- The formal Hessian matrix of `Q(u,v)`: diagonal entries vanish because +the polynomial is multiaffine, while off-diagonal entries are the paired +coefficients. -/ +def pairHessian + {ΞΉ : Type*} [DecidableEq ΞΉ] (u v : ΞΉ β†’ ℝ) : Matrix ΞΉ ΞΉ ℝ := + fun i j ↦ if i = j then 0 else u i * v j + v i * u j + +/-- Paper equation (11), the exact rank-two-minus-diagonal Hessian identity. -/ +theorem pairHessian_eq + {ΞΉ : Type*} [DecidableEq ΞΉ] (u v : ΞΉ β†’ ℝ) : + pairHessian u v = + Matrix.vecMulVec u v + Matrix.vecMulVec v u - + 2 β€’ Matrix.diagonal (fun i ↦ u i * v i) := by + ext i j + by_cases hij : i = j + Β· subst j + simp [pairHessian, Matrix.vecMulVec] + ring + Β· simp [pairHessian, Matrix.vecMulVec, Matrix.diagonal_apply, hij] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/PalomarComplexity.lean b/LeanPool/BeyondBethe/BeyondBethe/PalomarComplexity.lean new file mode 100644 index 0000000000..5db20ac082 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/PalomarComplexity.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham + +/-! +# A source-stable statement of polynomial time for Palomar + +Palomar compares the declarations exported from `Challenge.lean` and +`Solution.lean`. A recursive definition written with equation syntax acquires +module-private auxiliary declarations, so copying Complexitylib's definition +of recursion on notation into a standalone challenge does not produce the +same exported declaration. This file gives an equivalent presentation using +the public recursor `List.rec`. It is therefore declaration-stable when copied +to the Mathlib-only challenge. + +The final theorem below embeds Complexitylib's Cobham class into this +presentation. Together with Complexitylib's formalized Cobham theorem, this +shows that membership still has its usual meaning: deterministic polynomial +time on finite bitstrings. +-/ + +@[expose] public section + +namespace BeyondBethe.PalomarComplexity + +/-- Recursion on the bit notation of the first input, written directly with +`List.rec` so its declaration has no module-private equation compiler helper. -/ +def recNotation {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) + (x : List Bool) (v : Fin n β†’ List Bool) : List Bool := + List.rec g + (fun b tail recurse parameters => + (bif b then h₁ else hβ‚€) + (Fin.cons tail (Fin.cons (recurse parameters) parameters))) + x v + +@[simp] theorem recNotation_nil {n : β„•} + (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) + (v : Fin n β†’ List Bool) : + recNotation g hβ‚€ h₁ [] v = g v := by + rfl + +@[simp] theorem recNotation_cons {n : β„•} + (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) + (b : Bool) (tail : List Bool) (v : Fin n β†’ List Bool) : + recNotation g hβ‚€ h₁ (b :: tail) v = + (bif b then h₁ else hβ‚€) + (Fin.cons tail (Fin.cons (recNotation g hβ‚€ h₁ tail v) v)) := by + rfl + +/-- Cobham's algebra of polynomial-time bitstring functions, in a +source-stable presentation suitable for Palomar's challenge/solution +comparison. -/ +inductive Cobham : βˆ€ {n : β„•}, ((Fin n β†’ List Bool) β†’ List Bool) β†’ Prop + | proj {n : β„•} (i : Fin n) : Cobham fun v => v i + | empty {n : β„•} : Cobham fun _ : Fin n β†’ List Bool => [] + | bit (b : Bool) : Cobham fun v : Fin 1 β†’ List Bool => + b :: v ⟨0, Nat.zero_lt_succ 0⟩ + | smash : Cobham fun v : Fin 2 β†’ List Bool => + Complexity.smash + (v ⟨0, Nat.zero_lt_succ 1⟩) + (v ⟨1, Nat.succ_lt_succ (Nat.zero_lt_succ 0)⟩) + | comp {m n : β„•} {f : (Fin m β†’ List Bool) β†’ List Bool} + {gs : Fin m β†’ (Fin n β†’ List Bool) β†’ List Bool} : + Cobham f β†’ (βˆ€ i, Cobham (gs i)) β†’ + Cobham fun v => f fun i => gs i v + | boundedRec {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} + {hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool} + {j : (Fin (n + 1) β†’ List Bool) β†’ List Bool} : + Cobham g β†’ Cobham hβ‚€ β†’ Cobham h₁ β†’ Cobham j β†’ + (βˆ€ x v, (recNotation g hβ‚€ h₁ x v).length ≀ + (j (Fin.cons x v)).length) β†’ + Cobham fun v : Fin (n + 1) β†’ List Bool => + recNotation g hβ‚€ h₁ (v ⟨0, Nat.zero_lt_succ n⟩) (Fin.tail v) + +/-- The unary fragment of the source-stable Cobham algebra. -/ +def CobhamFP : Set (List Bool β†’ List Bool) := + {f | Cobham fun v : Fin 1 β†’ List Bool => + f (v ⟨0, Nat.zero_lt_succ 0⟩)} + +theorem recNotation_eq_complexity {n : β„•} + (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) : + recNotation g hβ‚€ h₁ = Complexity.recNotation g hβ‚€ h₁ := by + funext x v + induction x with + | nil => rfl + | cons b tail ih => + simp only [recNotation_cons, Complexity.recNotation_cons, ih] + +/-- Complexitylib's standard Cobham class embeds into the source-stable +presentation. -/ +theorem of_complexity_cobham {n : β„•} + {f : (Fin n β†’ List Bool) β†’ List Bool} + (hf : Complexity.Cobham f) : Cobham f := by + induction hf with + | proj i => exact .proj i + | empty => exact .empty + | bit b => exact .bit b + | smash => exact .smash + | comp hf hgs ihf ihgs => exact .comp ihf ihgs + | @boundedRec n g hβ‚€ h₁ j hg hhβ‚€ hh₁ hj hbound ihg ihhβ‚€ ihh₁ ihj => + have hstable : Cobham fun v : Fin (n + 1) β†’ List Bool => + recNotation g hβ‚€ h₁ (v ⟨0, Nat.zero_lt_succ n⟩) (Fin.tail v) := by + refine .boundedRec ihg ihhβ‚€ ihh₁ ihj ?_ + intro x v + simpa only [recNotation_eq_complexity] using! hbound x v + simpa only [recNotation_eq_complexity] using! hstable + +/-- The source-stable presentation also embeds back into Complexitylib's +standard Cobham class. -/ +theorem to_complexity_cobham {n : β„•} + {f : (Fin n β†’ List Bool) β†’ List Bool} + (hf : Cobham f) : Complexity.Cobham f := by + induction hf with + | proj i => exact .proj i + | empty => exact .empty + | bit b => exact .bit b + | smash => exact .smash + | comp hf hgs ihf ihgs => exact .comp ihf ihgs + | @boundedRec n g hβ‚€ h₁ j hg hhβ‚€ hh₁ hj hbound ihg ihhβ‚€ ihh₁ ihj => + have hstandard : Complexity.Cobham fun v : Fin (n + 1) β†’ List Bool => + Complexity.recNotation g hβ‚€ h₁ + (v ⟨0, Nat.zero_lt_succ n⟩) (Fin.tail v) := by + refine .boundedRec ihg ihhβ‚€ ihh₁ ihj ?_ + intro x v + simpa only [recNotation_eq_complexity] using! hbound x v + simpa only [recNotation_eq_complexity] using! hstandard + +/-- Every polynomial-time function in Complexitylib's Cobham presentation +belongs to the source-stable presentation used in the Palomar statement. -/ +theorem cobhamFP_of_complexity {f : List Bool β†’ List Bool} + (hf : f ∈ Complexity.CobhamFP) : f ∈ CobhamFP := + of_complexity_cobham hf + +/-- The Palomar-facing class is extensionally the usual Cobham class used by +Complexitylib. -/ +theorem cobhamFP_iff_complexity {f : List Bool β†’ List Bool} : + f ∈ CobhamFP ↔ f ∈ Complexity.CobhamFP := by + constructor + Β· intro hf + exact to_complexity_cobham hf + Β· exact cobhamFP_of_complexity + +end BeyondBethe.PalomarComplexity diff --git a/LeanPool/BeyondBethe/BeyondBethe/Permanent.lean b/LeanPool/BeyondBethe/BeyondBethe/Permanent.lean new file mode 100644 index 0000000000..049a63ee39 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Permanent.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import Mathlib.Algebra.Order.BigOperators.GroupWithZero.Finset +public import Mathlib.LinearAlgebra.Matrix.Permanent +public import Mathlib.Data.Real.Basic +public import Mathlib.Data.Rat.BigOperators + +/-! # Permanent -/ + +@[expose] public section + +namespace Matrix + +/-- Entrywise nonnegativity. -/ +def Nonnegative {m n : Type*} {R : Type*} [Zero R] [LE R] + (A : Matrix m n R) : Prop := + βˆ€ i j, 0 ≀ A i j + +/-- The positive support of `A` has a perfect matching, in the orientation +used by Mathlib's definition of the permanent. -/ +def HasPerfectMatching {n : Type*} [Fintype n] [DecidableEq n] + {R : Type*} [Zero R] (A : Matrix n n R) : Prop := + βˆƒ Οƒ : Equiv.Perm n, βˆ€ i, A (Οƒ i) i β‰  0 + +theorem permanent_fin_one {R : Type*} [CommSemiring R] + (A : Matrix (Fin 1) (Fin 1) R) : + permanent A = A 0 0 := by + simp + +theorem permanent_nonneg_real {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Nonnegative A) : + 0 ≀ permanent A := by + classical + rw [permanent] + exact Finset.sum_nonneg fun Οƒ _ ↦ + Finset.prod_nonneg fun i _ ↦ hA (Οƒ i) i + +theorem permanent_mono_real {n : Type*} [Fintype n] [DecidableEq n] + {A B : Matrix n n ℝ} (hA : Nonnegative A) + (hAB : βˆ€ i j, A i j ≀ B i j) : + permanent A ≀ permanent B := by + classical + rw [permanent, permanent] + apply Finset.sum_le_sum + intro Οƒ _ + exact Finset.prod_le_prodβ‚€ (fun i _ ↦ hA (Οƒ i) i) fun i _ ↦ hAB (Οƒ i) i + +/-- Degree-`n` homogeneity under global scaling, as used when the algorithm +normalizes the largest matrix entry. -/ +theorem permanent_scale_real {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (c : ℝ) : + permanent (c β€’ A) = c ^ Fintype.card n * permanent A := + permanent_smul A c + +/-- Casting a rational permanent to the reals is the same as first casting +the entries and then taking the real permanent. -/ +theorem cast_permanent_rat {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n β„š) : + ((permanent A : β„š) : ℝ) = permanent (fun i j ↦ (A i j : ℝ)) := by + classical + simp [permanent] + +theorem permanent_eq_zero_of_noPerfectMatching + {n : Type*} [Fintype n] [DecidableEq n] + {R : Type*} [CommSemiring R] (A : Matrix n n R) + (hA : Β¬HasPerfectMatching A) : + permanent A = 0 := by + classical + rw [permanent] + apply Finset.sum_eq_zero + intro Οƒ _ + have hzero : βˆƒ i, A (Οƒ i) i = 0 := by + by_contra hnone + apply hA + refine βŸ¨Οƒ, ?_⟩ + intro i hi + exact hnone ⟨i, hi⟩ + obtain ⟨i, hi⟩ := hzero + exact Finset.prod_eq_zero (Finset.mem_univ i) hi + +theorem permanent_pos_of_hasPerfectMatching + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) (hA : Nonnegative A) + (hmatch : HasPerfectMatching A) : + 0 < permanent A := by + classical + obtain βŸ¨Οƒ, hΟƒβŸ© := hmatch + rw [permanent] + apply Finset.sum_pos' + Β· exact fun Ο„ _ ↦ Finset.prod_nonneg fun i _ ↦ hA (Ο„ i) i + Β· refine βŸ¨Οƒ, Finset.mem_univ Οƒ, ?_⟩ + exact Finset.prod_pos fun i _ ↦ lt_of_le_of_ne (hA (Οƒ i) i) (Ne.symm (hΟƒ i)) + +/-- A perfect matching whose nonzero entries are at least `m` contributes at +least `m ^ |n|` to the permanent. -/ +theorem pow_card_le_permanent_of_hasPerfectMatching + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) {m : ℝ} (hm : 0 ≀ m) + (hA : Nonnegative A) + (hmin : βˆ€ i j, A i j β‰  0 β†’ m ≀ A i j) + (hmatch : HasPerfectMatching A) : + m ^ Fintype.card n ≀ permanent A := by + classical + obtain βŸ¨Οƒ, hΟƒβŸ© := hmatch + rw [permanent] + calc + m ^ Fintype.card n = ∏ _i : n, m := by simp + _ ≀ ∏ i : n, A (Οƒ i) i := by + exact Finset.prod_le_prodβ‚€ (fun _ _ ↦ hm) fun i _ ↦ hmin (Οƒ i) i (hΟƒ i) + _ ≀ βˆ‘ Ο„ : Equiv.Perm n, ∏ i : n, A (Ο„ i) i := by + exact Finset.single_le_sum + (fun Ο„ _ ↦ Finset.prod_nonneg fun i _ ↦ hA (Ο„ i) i) + (Finset.mem_univ Οƒ) + +end Matrix diff --git a/LeanPool/BeyondBethe/BeyondBethe/RationalEllipsoid.lean b/LeanPool/BeyondBethe/BeyondBethe/RationalEllipsoid.lean new file mode 100644 index 0000000000..ff0cbc5859 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RationalEllipsoid.lean @@ -0,0 +1,1365 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import Mathlib.Algebra.Order.Chebyshev +public import Mathlib.Analysis.SpecialFunctions.Log.Basic +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic +public import Mathlib.LinearAlgebra.Matrix.AbsoluteValue +public import Mathlib.LinearAlgebra.Matrix.SchurComplement +public import Mathlib.Tactic + +/-! # Rational Ellipsoid -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# A square-root-free rational ellipsoid update + +An ellipsoid is represented as the affine image of the Euclidean unit ball, +`c + B y`. Both `c` and `B` will be rational in the executable algorithm. +For a central cut with pulled-back normal `b = Bα΅€ a`, the usual optimal +ellipsoid update normalizes `b` by its Euclidean norm and therefore introduces +a square root. We instead normalize by the rational quantity `sum |bα΅’|` and +take a smaller center step. The update is weaker, but it still contracts +volume by an inverse-polynomial factor and keeps all stored data rational. +-/ + +/-- Explicit dot product, used over both `β„š` and `ℝ`. -/ +def finiteDot {d : β„•} {R : Type*} [CommSemiring R] + (x y : Fin d β†’ R) : R := + βˆ‘ i, x i * y i + +/-- Squared Euclidean norm, expressed without a square root. -/ +def finiteNormSq {d : β„•} {R : Type*} [CommSemiring R] + (x : Fin d β†’ R) : R := + finiteDot x x + +/-- Rational normalization used for a cut direction. -/ +def cutL1Scale {d : β„•} (b : Fin d β†’ β„š) : β„š := + βˆ‘ i, abs (b i) + +theorem finiteNormSq_nonneg {d : β„•} (x : Fin d β†’ ℝ) : + 0 ≀ finiteNormSq x := by + rw [finiteNormSq, finiteDot] + exact Finset.sum_nonneg fun i _ ↦ mul_self_nonneg (x i) + +theorem finiteNormSq_eq_zero_iff {d : β„•} (x : Fin d β†’ ℝ) : + finiteNormSq x = 0 ↔ x = 0 := by + rw [finiteNormSq, finiteDot, Finset.sum_mul_self_eq_zero_iff] + constructor + Β· intro h + ext i + simpa using h i (Finset.mem_univ i) + Β· intro h + subst x + simp + +theorem cutL1Scale_nonnegative {d : β„•} (b : Fin d β†’ β„š) : + 0 ≀ cutL1Scale b := by + rw [cutL1Scale] + exact Finset.sum_nonneg fun i _ ↦ abs_nonneg (b i) + +theorem cutL1Scale_pos {d : β„•} {b : Fin d β†’ β„š} (hb : b β‰  0) : + 0 < cutL1Scale b := by + have hnonneg : 0 ≀ βˆ‘ i, abs (b i) := + Finset.sum_nonneg fun i _ ↦ abs_nonneg (b i) + have hne : (βˆ‘ i, abs (b i)) β‰  0 := by + intro hzero + apply hb + ext i + exact abs_eq_zero.mp + ((Finset.sum_eq_zero_iff_of_nonneg + (fun i (_hi : i ∈ Finset.univ) ↦ abs_nonneg (b i))).1 + hzero i (Finset.mem_univ i)) + rw [cutL1Scale] + exact lt_of_le_of_ne hnonneg (Ne.symm hne) + +/-- The Euclidean norm is at most the `β„“1` norm. We state the squared form, +which is the one used by the rational update. -/ +theorem finiteNormSq_le_cutL1Scale_sq {d : β„•} (b : Fin d β†’ β„š) : + finiteNormSq b ≀ cutL1Scale b ^ 2 := by + let S : β„š := βˆ‘ i, abs (b i) + have hi : βˆ€ i, abs (b i) ≀ S := by + intro i + exact Finset.single_le_sum (fun j _ ↦ abs_nonneg (b j)) + (Finset.mem_univ i) + calc + finiteNormSq b = βˆ‘ i, (abs (b i)) ^ 2 := by + simp [finiteNormSq, finiteDot, sq] + _ ≀ βˆ‘ i, abs (b i) * S := by + apply Finset.sum_le_sum + intro i _ + rw [sq] + exact mul_le_mul_of_nonneg_left (hi i) (abs_nonneg _) + _ = S ^ 2 := by simp [S, sq, Finset.sum_mul] + _ = cutL1Scale b ^ 2 := by rw [cutL1Scale] + +/-- Cauchy--Schwarz gives the converse comparison with a factor equal to the +dimension. -/ +theorem cutL1Scale_sq_le_card_mul_normSq {d : β„•} (b : Fin d β†’ β„š) : + cutL1Scale b ^ 2 ≀ d * finiteNormSq b := by + rw [cutL1Scale, finiteNormSq, finiteDot] + simpa [sq, abs_mul_abs_self] using + (sq_sum_le_card_mul_sum_sq (s := Finset.univ) + (f := fun i ↦ abs (b i))) + +/-- Finite-dimensional Cauchy--Schwarz in the squared form needed below. -/ +theorem finiteDot_sq_le_normSq_mul_normSq {d : β„•} + (x y : Fin d β†’ ℝ) : + finiteDot x y ^ 2 ≀ finiteNormSq x * finiteNormSq y := by + simpa [finiteDot, finiteNormSq, sq, mul_comm] using + (Finset.sum_mul_sq_le_sq_mul_sq (s := Finset.univ) x y) + +theorem finiteDot_add_right {d : β„•} (x y z : Fin d β†’ ℝ) : + finiteDot x (fun i ↦ y i + z i) = finiteDot x y + finiteDot x z := by + simp [finiteDot, mul_add, Finset.sum_add_distrib] + +theorem finiteDot_smul_left {d : β„•} (a : ℝ) (x y : Fin d β†’ ℝ) : + finiteDot (fun i ↦ a * x i) y = a * finiteDot x y := by + rw [finiteDot, finiteDot] + calc + (βˆ‘ i, a * x i * y i) = βˆ‘ i, a * (x i * y i) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = a * βˆ‘ i, x i * y i := by rw [Finset.mul_sum] + +theorem finiteDot_smul_right {d : β„•} (a : ℝ) (x y : Fin d β†’ ℝ) : + finiteDot x (fun i ↦ a * y i) = a * finiteDot x y := by + rw [finiteDot, finiteDot] + calc + (βˆ‘ i, x i * (a * y i)) = βˆ‘ i, a * (x i * y i) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = a * βˆ‘ i, x i * y i := by rw [Finset.mul_sum] + +theorem finiteNormSq_smul {d : β„•} (a : ℝ) (x : Fin d β†’ ℝ) : + finiteNormSq (fun i ↦ a * x i) = a ^ 2 * finiteNormSq x := by + rw [finiteNormSq, finiteDot, finiteNormSq, finiteDot] + calc + (βˆ‘ i, a * x i * (a * x i)) = βˆ‘ i, a ^ 2 * (x i * x i) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = a ^ 2 * βˆ‘ i, x i * x i := by rw [Finset.mul_sum] + +theorem finiteNormSq_add {d : β„•} (x y : Fin d β†’ ℝ) : + finiteNormSq (fun i ↦ x i + y i) = + finiteNormSq x + 2 * finiteDot x y + finiteNormSq y := by + rw [finiteNormSq, finiteDot, finiteNormSq, finiteDot, + finiteDot] + calc + (βˆ‘ i, (x i + y i) * (x i + y i)) = + βˆ‘ i, (x i * x i + (2 * (x i * y i) + y i * y i)) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = (βˆ‘ i, x i * x i) + + 2 * (βˆ‘ i, x i * y i) + βˆ‘ i, y i * y i := by + simp only [Finset.sum_add_distrib, ← Finset.mul_sum] + ring + +/-- Center-step coefficient for dimension `d`. The update is used only for +positive dimensions. -/ +def rationalEllipsoidAlpha (d : β„•) : β„š := 1 / (4 * d ^ 2) + +/-- Expansion in directions orthogonal to the cut. -/ +def rationalEllipsoidPerpScale (d : β„•) : β„š := + 1 + 2 * rationalEllipsoidAlpha d ^ 2 + +/-- Contraction in the cut direction. -/ +def rationalEllipsoidParallelScale (d : β„•) : β„š := + 1 - rationalEllipsoidAlpha d / d + +theorem rationalEllipsoidAlpha_pos {d : β„•} (hd : 0 < d) : + 0 < rationalEllipsoidAlpha d := by + rw [rationalEllipsoidAlpha] + positivity + +theorem rationalEllipsoidAlpha_le_quarter {d : β„•} (hd : 0 < d) : + rationalEllipsoidAlpha d ≀ 1 / 4 := by + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + change (1 : β„š) / (4 * (d : β„š) ^ 2) ≀ 1 / 4 + rw [div_le_div_iffβ‚€ (by positivity) (by norm_num)] + nlinarith [sq_nonneg ((d : β„š) - 1)] + +theorem rationalEllipsoidParallelScale_pos {d : β„•} (hd : 0 < d) : + 0 < rationalEllipsoidParallelScale d := by + have ha0 := rationalEllipsoidAlpha_pos hd + have ha1 := rationalEllipsoidAlpha_le_quarter hd + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + rw [rationalEllipsoidParallelScale] + have had : rationalEllipsoidAlpha d / d ≀ 1 / 4 := by + exact (div_le_iffβ‚€ (by positivity : (0 : β„š) < d)).2 + (by nlinarith) + linarith + +theorem rationalEllipsoidParallelScale_le_one (d : β„•) : + rationalEllipsoidParallelScale d ≀ 1 := by + rw [rationalEllipsoidParallelScale] + by_cases hd : d = 0 + Β· simp [hd] + Β· have hdq : (0 : β„š) < d := by exact_mod_cast (Nat.pos_of_ne_zero hd) + have : 0 ≀ rationalEllipsoidAlpha d / d := + (div_pos (rationalEllipsoidAlpha_pos (Nat.pos_of_ne_zero hd)) hdq).le + linarith + +theorem rationalEllipsoidParallelScale_ge_three_quarters + {d : β„•} (hd : 0 < d) : + (3 / 4 : β„š) ≀ rationalEllipsoidParallelScale d := by + have ha := rationalEllipsoidAlpha_le_quarter hd + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have had : rationalEllipsoidAlpha d / d ≀ 1 / 4 := by + rw [div_le_iffβ‚€ (by positivity : (0 : β„š) < d)] + nlinarith + rw [rationalEllipsoidParallelScale] + linarith + +theorem rationalEllipsoidPerpScale_pos (d : β„•) : + 0 < rationalEllipsoidPerpScale d := by + rw [rationalEllipsoidPerpScale] + positivity + +theorem rationalEllipsoidParallel_lt_perp {d : β„•} (hd : 0 < d) : + rationalEllipsoidParallelScale d < rationalEllipsoidPerpScale d := by + have ha := rationalEllipsoidAlpha_pos hd + have hdq : (0 : β„š) < d := by exact_mod_cast hd + rw [rationalEllipsoidParallelScale, rationalEllipsoidPerpScale] + have had : 0 < rationalEllipsoidAlpha d / d := div_pos ha hdq + nlinarith [sq_nonneg (rationalEllipsoidAlpha d)] + +/-- A coarse lower bound on the exact determinant multiplier. It is used +for an all-input bit-growth bound; unlike the contraction estimate, no +transcendental inequality is needed. -/ +theorem rationalEllipsoid_volumeFactor_ge_half {d : β„•} (hd : 0 < d) : + (1 / 2 : ℝ) ≀ + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) := by + have hperp : (1 : ℝ) ≀ (rationalEllipsoidPerpScale d : ℝ) := by + rw [rationalEllipsoidPerpScale] + norm_num + positivity + have hpow : (1 : ℝ) ≀ + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) := + one_le_powβ‚€ hperp + have hparallel : (3 / 4 : ℝ) ≀ + (rationalEllipsoidParallelScale d : ℝ) := by + have hq := rationalEllipsoidParallelScale_ge_three_quarters hd + have hcast : (((3 / 4 : β„š) : β„š) : ℝ) ≀ + (rationalEllipsoidParallelScale d : ℝ) := Rat.cast_le.mpr hq + norm_num at hcast ⊒ + exact hcast + calc + (1 / 2 : ℝ) ≀ 1 * (3 / 4 : ℝ) := by norm_num + _ ≀ (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) := + mul_le_mul hpow hparallel (by norm_num) (by positivity) + +/-- Quantitative inverse-polynomial contraction of the determinant factor. +The proof uses only `1+x ≀ exp x`; no numerical estimate or square-root +normalization is hidden here. -/ +theorem rationalEllipsoid_volumeFactor_le_exp_neg {d : β„•} (hd : 0 < d) : + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) ≀ + Real.exp (-1 / (8 * (d : ℝ) ^ 3)) := by + let Ξ± : ℝ := (rationalEllipsoidAlpha d : ℝ) + let x : ℝ := 2 * Ξ± ^ 2 + let y : ℝ := Ξ± / d + have hΞ±0 : 0 < Ξ± := by + have hq := rationalEllipsoidAlpha_pos hd + have hc : (0 : ℝ) < (rationalEllipsoidAlpha d : ℝ) := by + exact_mod_cast hq + simpa only [Ξ±] using hc + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hx0 : 0 ≀ x := by simp [x]; positivity + have hy0 : 0 < y := div_pos hΞ±0 (by positivity) + have hA : (rationalEllipsoidPerpScale d : ℝ) = 1 + x := by + simp [rationalEllipsoidPerpScale, x, Ξ±] + have hp : (rationalEllipsoidParallelScale d : ℝ) = 1 - y := by + simp [rationalEllipsoidParallelScale, y, Ξ±] + have hp0 : 0 < 1 - y := by + rw [← hp] + have hq := rationalEllipsoidParallelScale_pos hd + exact (Rat.cast_pos (K := ℝ)).mpr hq + have hbase : 1 + x ≀ Real.exp x := by + simpa [add_comm] using Real.add_one_le_exp x + have hpow : (1 + x) ^ (d - 1) ≀ (Real.exp x) ^ (d - 1) := + pow_le_pow_leftβ‚€ (by positivity) hbase _ + have hparallel : 1 - y ≀ Real.exp (-y) := by + linarith [Real.add_one_le_exp (-y)] + have hfirst := mul_le_mul hpow hparallel hp0.le + (by positivity : 0 ≀ (Real.exp x) ^ (d - 1)) + have hexpEq : (Real.exp x) ^ (d - 1) * Real.exp (-y) = + Real.exp (((d - 1 : β„•) : ℝ) * x - y) := by + rw [← Real.exp_nat_mul, ← Real.exp_add] + congr 1 + have hΞ±formula : Ξ± = 1 / (4 * (d : ℝ) ^ 2) := by + simp [Ξ±, rationalEllipsoidAlpha] + have hexponent : (((d - 1 : β„•) : ℝ) * x - y) ≀ + -1 / (8 * (d : ℝ) ^ 3) := by + have hdsub : ((d - 1 : β„•) : ℝ) ≀ (d : ℝ) := by + exact_mod_cast Nat.sub_le d 1 + have hdpos : (0 : ℝ) < d := by positivity + dsimp only [x, y] + rw [hΞ±formula] + field_simp + nlinarith + calc + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) = + (1 + x) ^ (d - 1) * (1 - y) := by rw [hA, hp] + _ ≀ (Real.exp x) ^ (d - 1) * Real.exp (-y) := hfirst + _ = Real.exp (((d - 1 : β„•) : ℝ) * x - y) := hexpEq + _ ≀ Real.exp (-1 / (8 * (d : ℝ) ^ 3)) := Real.exp_le_exp.mpr hexponent + +theorem rationalEllipsoid_volumeFactor_lt_one {d : β„•} (hd : 0 < d) : + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) < 1 := by + calc + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) ≀ + Real.exp (-1 / (8 * (d : ℝ) ^ 3)) := + rationalEllipsoid_volumeFactor_le_exp_neg hd + _ < Real.exp 0 := Real.exp_lt_exp.mpr (by + have hdR : (0 : ℝ) < d := by exact_mod_cast hd + have : (0 : ℝ) < 1 / (8 * (d : ℝ) ^ 3) := by positivity + rw [show (-1 : ℝ) / (8 * (d : ℝ) ^ 3) = + -(1 / (8 * (d : ℝ) ^ 3)) by ring] + linarith) + _ = 1 := Real.exp_zero + +/-- A rationally stated version of the volume contraction. The weaker +constant is convenient when we later reserve part of the contraction for +rounding and inflation. -/ +theorem rationalEllipsoid_volumeFactor_le_one_sub {d : β„•} (hd : 0 < d) : + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) ≀ + 1 - 1 / (16 * (d : ℝ) ^ 3) := by + let x : ℝ := 1 / (8 * (d : ℝ) ^ 3) + have hx0 : 0 < x := by dsimp only [x]; positivity + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hx1 : x ≀ 1 := by + dsimp only [x] + have hden : (8 : ℝ) ≀ 8 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact (div_le_one (by positivity : (0 : ℝ) < 8 * (d : ℝ) ^ 3)).2 + (by nlinarith) + have hexpLower : 1 + x ≀ Real.exp x := by + simpa [add_comm] using Real.add_one_le_exp x + have hrecip : Real.exp (-x) ≀ 1 / (1 + x) := by + rw [Real.exp_neg, one_div] + exact (inv_le_invβ‚€ (by positivity : (0 : ℝ) < Real.exp x) + (by positivity : (0 : ℝ) < 1 + x)).2 hexpLower + have hrational : 1 / (1 + x) ≀ 1 - x / 2 := by + rw [div_le_iffβ‚€ (by positivity : (0 : ℝ) < 1 + x)] + nlinarith [mul_nonneg hx0.le (sub_nonneg.mpr hx1)] + calc + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) ≀ + Real.exp (-1 / (8 * (d : ℝ) ^ 3)) := + rationalEllipsoid_volumeFactor_le_exp_neg hd + _ = Real.exp (-x) := by + congr 1 + dsimp only [x] + ring + _ ≀ 1 / (1 + x) := hrecip + _ ≀ 1 - x / 2 := hrational + _ = 1 - 1 / (16 * (d : ℝ) ^ 3) := by + dsimp only [x] + ring + +/-- Rank-one linear update with prescribed scale `A` orthogonal to `b` and +scale `p` parallel to `b`. -/ +def directionUpdateMatrix {d : β„•} {R : Type*} + [Field R] [DecidableEq (Fin d)] + (A p : R) (b : Fin d β†’ R) : Matrix (Fin d) (Fin d) R := + fun i j ↦ A * (if i = j then 1 else 0) - + ((A - p) / finiteNormSq b) * b i * b j + +/-- Explicit inverse action for the rank-one update. -/ +def directionUpdatePreimage {d : β„•} {R : Type*} + [Field R] (A p : R) (b x : Fin d β†’ R) : Fin d β†’ R := + fun i ↦ x i / A + + (1 / p - 1 / A) * (finiteDot b x / finiteNormSq b) * b i + +theorem directionUpdateMatrix_mulVec {d : β„•} {R : Type*} + [Field R] [DecidableEq (Fin d)] + (A p : R) (b z : Fin d β†’ R) (i : Fin d) : + Matrix.mulVec (directionUpdateMatrix A p b) z i = + A * z i - ((A - p) / finiteNormSq b) * b i * finiteDot b z := by + simp only [Matrix.mulVec, directionUpdateMatrix, dotProduct, sub_mul, + Finset.sum_sub_distrib] + rw [show (βˆ‘ x, A * (if i = x then 1 else 0) * z x) = A * z i by simp] + congr 1 + rw [finiteDot] + rw [show + ((A - p) / finiteNormSq b) * b i * (βˆ‘ j, b j * z j) = + (((A - p) / finiteNormSq b) * b i) * (βˆ‘ j, b j * z j) by ring, + Finset.mul_sum] + apply Finset.sum_congr rfl + intro j _ + ring + +theorem finiteDot_directionUpdatePreimage {d : β„•} + {A p : ℝ} {b x : Fin d β†’ ℝ} + (hA : A β‰  0) (hp : p β‰  0) (hb : finiteNormSq b β‰  0) : + finiteDot b (directionUpdatePreimage A p b x) = + finiteDot b x / p := by + simp only [finiteDot, directionUpdatePreimage, mul_add, + Finset.sum_add_distrib] + rw [show (βˆ‘ i, b i * (x i / A)) = (βˆ‘ i, b i * x i) / A by + rw [Finset.sum_div]; congr 1; ext i; ring] + rw [show + (βˆ‘ i, b i * + ((1 / p - 1 / A) * + ((βˆ‘ j, b j * x j) / finiteNormSq b) * b i)) = + (1 / p - 1 / A) * + ((βˆ‘ j, b j * x j) / finiteNormSq b) * finiteNormSq b by + rw [finiteNormSq, finiteDot] + let C : ℝ := (1 / p - 1 / A) * + ((βˆ‘ j, b j * x j) / (βˆ‘ i, b i * b i)) + change (βˆ‘ i, b i * (C * b i)) = C * βˆ‘ i, b i * b i + calc + (βˆ‘ i, b i * (C * b i)) = βˆ‘ i, C * (b i * b i) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = C * βˆ‘ i, b i * b i := by rw [Finset.mul_sum]] + field_simp + ring + +theorem directionUpdateMatrix_preimage {d : β„•} + {A p : ℝ} {b x : Fin d β†’ ℝ} + (hA : A β‰  0) (hp : p β‰  0) (hb : finiteNormSq b β‰  0) : + Matrix.mulVec (directionUpdateMatrix A p b) + (directionUpdatePreimage A p b x) = x := by + ext i + rw [directionUpdateMatrix_mulVec, + finiteDot_directionUpdatePreimage hA hp hb] + simp only [directionUpdatePreimage] + field_simp + ring + +/-- Exact squared-norm formula for the explicit inverse action. -/ +theorem finiteNormSq_directionUpdatePreimage {d : β„•} + {A p : ℝ} {b x : Fin d β†’ ℝ} + (hA : A β‰  0) (hp : p β‰  0) (hb : finiteNormSq b β‰  0) : + finiteNormSq (directionUpdatePreimage A p b x) = + (finiteNormSq x - finiteDot b x ^ 2 / finiteNormSq b) / A ^ 2 + + finiteDot b x ^ 2 / (finiteNormSq b * p ^ 2) := by + let q := finiteDot b x + let s := finiteNormSq b + let k : ℝ := (1 / p - 1 / A) * (q / s) + have hpre : directionUpdatePreimage A p b x = + fun i ↦ (1 / A) * x i + k * b i := by + ext i + simp only [directionUpdatePreimage, k, q, s] + ring + rw [hpre, finiteNormSq_add, + finiteNormSq_smul, finiteDot_smul_left, finiteDot_smul_right, + finiteNormSq_smul] + change (1 / A) ^ 2 * finiteNormSq x + + 2 * ((1 / A) * (k * finiteDot x b)) + + k ^ 2 * finiteNormSq b = _ + have hcomm : finiteDot x b = finiteDot b x := by + simp [finiteDot, mul_comm] + rw [hcomm] + dsimp only [k] + dsimp only [q, s] + field_simp + ring + +/-- Point relative to the shifted center, in the old ellipsoid coordinates. -/ +noncomputable def directionShiftedPoint {d : β„•} (Ξ± u : ℝ) + (b y : Fin d β†’ ℝ) : Fin d β†’ ℝ := + fun i ↦ y i + (Ξ± / u) * b i +/-- The only scalar geometry needed for containment. The variable `t` is +the component of a unit-ball point in the cut direction and `h` is the +actual center displacement. A convex quadratic on `[-1,0]` is bounded by +its two endpoints. -/ +theorem rationalEllipsoid_scalar_containment + {d : β„•} (hd : 0 < d) {t h : ℝ} + (ht0 : t ≀ 0) (ht1 : -1 ≀ t) + (hh0 : (rationalEllipsoidAlpha d : ℝ) / d ≀ h) + (hh1 : h ≀ (rationalEllipsoidAlpha d : ℝ)) : + (1 - t ^ 2) / (rationalEllipsoidPerpScale d : ℝ) ^ 2 + + (t + h) ^ 2 / (rationalEllipsoidParallelScale d : ℝ) ^ 2 ≀ 1 := by + let Ξ± : ℝ := (rationalEllipsoidAlpha d : ℝ) + let A : ℝ := (rationalEllipsoidPerpScale d : ℝ) + let p : ℝ := (rationalEllipsoidParallelScale d : ℝ) + have hΞ±0 : 0 < Ξ± := by + have hq := rationalEllipsoidAlpha_pos hd + have hc : (0 : ℝ) < (rationalEllipsoidAlpha d : ℝ) := by + exact_mod_cast hq + simpa only [Ξ±] using hc + have hΞ±1 : Ξ± ≀ 1 / 4 := by + have hq := rationalEllipsoidAlpha_le_quarter hd + have hc : (rationalEllipsoidAlpha d : ℝ) ≀ (((1 / 4 : β„š) : ℝ)) := + Rat.cast_le.mpr hq + norm_num at hc ⊒ + simpa only [Ξ±] using hc + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hp0 : 0 < p := by + simpa [p] using (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidParallelScale_pos hd) + have hp1 : p ≀ 1 := by + simpa [p] using Rat.cast_le.mpr (rationalEllipsoidParallelScale_le_one d) + have hA0 : 0 < A := by + simpa [A] using (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidPerpScale_pos d) + have hpA : p < A := by + simpa [p, A] using (Rat.cast_lt (K := ℝ)).mpr (rationalEllipsoidParallel_lt_perp hd) + have hh0' : Ξ± / d ≀ h := by simpa [Ξ±] using hh0 + have hh1' : h ≀ Ξ± := by simpa [Ξ±] using hh1 + have hhpos : 0 ≀ h := by + have : 0 < Ξ± / (d : ℝ) := div_pos hΞ±0 (by positivity) + linarith + have hh_le_one : h ≀ 1 := hh1'.trans (hΞ±1.trans (by norm_num)) + have hp : p = 1 - Ξ± / d := by + simp [p, Ξ±, rationalEllipsoidParallelScale] + have hA : A = 1 + 2 * Ξ± ^ 2 := by + simp [A, Ξ±, rationalEllipsoidPerpScale] + have hendpointNeg : (1 - h) ^ 2 / p ^ 2 ≀ 1 := by + have hph : 1 - h ≀ p := by rw [hp]; linarith + have honeh0 : 0 ≀ 1 - h := sub_nonneg.mpr hh_le_one + rw [div_le_iffβ‚€ (sq_pos_of_pos hp0)] + nlinarith + have hp_ge_three_quarters : 3 / 4 ≀ p := by + rw [hp] + have : Ξ± / (d : ℝ) ≀ 1 / 4 := by + exact (div_le_iffβ‚€ (by positivity : (0 : ℝ) < d)).2 (by nlinarith) + linarith + have hendpointZero : 1 / A ^ 2 + h ^ 2 / p ^ 2 ≀ 1 := by + have hh_sq : h ^ 2 ≀ Ξ± ^ 2 := by nlinarith + have hp_sq : (9 / 16 : ℝ) ≀ p ^ 2 := by nlinarith + have hA_sq : 1 + 4 * Ξ± ^ 2 ≀ A ^ 2 := by rw [hA]; nlinarith [sq_nonneg Ξ±] + have hΞ±sq : Ξ± ^ 2 ≀ 1 / 16 := by nlinarith + have hfirst : 1 / A ^ 2 ≀ 1 / (1 + 4 * Ξ± ^ 2) := by + exact one_div_le_one_div_of_le (by positivity) hA_sq + have hsecond : h ^ 2 / p ^ 2 ≀ (16 / 9) * Ξ± ^ 2 := by + have := (div_le_div_iffβ‚€ (by positivity : (0 : ℝ) < p ^ 2) + (by norm_num : (0 : ℝ) < 9 / 16)).2 + (by nlinarith : h ^ 2 * (9 / 16 : ℝ) ≀ Ξ± ^ 2 * p ^ 2) + norm_num at this ⊒ + linarith + have hsum : 1 / (1 + 4 * Ξ± ^ 2) + (16 / 9) * Ξ± ^ 2 ≀ 1 := by + have hden : 0 < 1 + 4 * Ξ± ^ 2 := by positivity + have hid : + 1 / (1 + 4 * Ξ± ^ 2) + (16 / 9) * Ξ± ^ 2 = + (1 + (16 / 9) * Ξ± ^ 2 * (1 + 4 * Ξ± ^ 2)) / + (1 + 4 * Ξ± ^ 2) := by field_simp + rw [hid, div_le_one hden] + nlinarith + linarith + have hcoef : 0 ≀ 1 / p ^ 2 - 1 / A ^ 2 := by + have hp2 : p ^ 2 ≀ A ^ 2 := by nlinarith [hp0, hA0] + exact sub_nonneg.mpr (one_div_le_one_div_of_le (by positivity) hp2) + have htprod : t * (t + 1) ≀ 0 := mul_nonpos_of_nonpos_of_nonneg ht0 (by linarith) + have hchord : + (1 - t ^ 2) / A ^ 2 + (t + h) ^ 2 / p ^ 2 ≀ + (-t) * ((1 - h) ^ 2 / p ^ 2) + + (1 + t) * (1 / A ^ 2 + h ^ 2 / p ^ 2) := by + have hid : + ((-t) * ((1 - h) ^ 2 / p ^ 2) + + (1 + t) * (1 / A ^ 2 + h ^ 2 / p ^ 2)) - + ((1 - t ^ 2) / A ^ 2 + (t + h) ^ 2 / p ^ 2) = + -(1 / p ^ 2 - 1 / A ^ 2) * t * (t + 1) := by ring + rw [← sub_nonneg] + rw [hid] + rw [mul_assoc] + exact mul_nonneg_of_nonpos_of_nonpos (neg_nonpos.mpr hcoef) htprod + calc + (1 - t ^ 2) / + (rationalEllipsoidPerpScale d : ℝ) ^ 2 + + (t + h) ^ 2 / + (rationalEllipsoidParallelScale d : ℝ) ^ 2 = + (1 - t ^ 2) / A ^ 2 + (t + h) ^ 2 / p ^ 2 := by rfl + _ ≀ (-t) * ((1 - h) ^ 2 / p ^ 2) + + (1 + t) * (1 / A ^ 2 + h ^ 2 / p ^ 2) := hchord + _ ≀ (-t) * 1 + (1 + t) * 1 := by + exact add_le_add + (mul_le_mul_of_nonneg_left hendpointNeg (by linarith)) + (mul_le_mul_of_nonneg_left hendpointZero (by linarith)) + _ = 1 := by ring +/-- Full-dimensional containment for the rational update. The hypotheses on +`u` say that it approximates the Euclidean norm of `b` between factors `1` +and `sqrt d`. The executable choice `u = sum |bα΅’|` has exactly these +properties by the two elementary inequalities proved above. -/ +theorem rationalEllipsoid_direction_containment + {d : β„•} (hd : 0 < d) {b y : Fin d β†’ ℝ} {u : ℝ} + (hb : b β‰  0) (hu : 0 < u) + (hnormLower : finiteNormSq b ≀ u ^ 2) + (hnormUpper : u ^ 2 ≀ d * finiteNormSq b) + (hy : finiteNormSq y ≀ 1) + (hcut : finiteDot b y ≀ 0) : + finiteNormSq + (directionUpdatePreimage + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b + (directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) u b y)) ≀ 1 := by + let s : ℝ := finiteNormSq b + let r : ℝ := Real.sqrt s + let Ξ± : ℝ := (rationalEllipsoidAlpha d : ℝ) + let A : ℝ := (rationalEllipsoidPerpScale d : ℝ) + let p : ℝ := (rationalEllipsoidParallelScale d : ℝ) + let q : ℝ := finiteDot b y + let t : ℝ := q / r + let h : ℝ := Ξ± * r / u + let x : Fin d β†’ ℝ := directionShiftedPoint Ξ± u b y + have hs0 : 0 ≀ s := finiteNormSq_nonneg b + have hsne : s β‰  0 := by + intro hs + apply hb + exact (finiteNormSq_eq_zero_iff b).1 (by simpa [s] using hs) + have hspos : 0 < s := lt_of_le_of_ne hs0 (Ne.symm hsne) + have hrpos : 0 < r := by simpa [r] using Real.sqrt_pos.2 hspos + have hrsq : r ^ 2 = s := by simpa [r] using Real.sq_sqrt hs0 + have hApos : 0 < A := by + simpa [A] using (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidPerpScale_pos d) + have hppos : 0 < p := by + simpa [p] using (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidParallelScale_pos hd) + have hΞ±pos : 0 < Ξ± := by + simpa [Ξ±] using (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidAlpha_pos hd) + have hqcut : q ≀ 0 := by simpa [q] using hcut + have ht0 : t ≀ 0 := by + dsimp only [t] + exact div_nonpos_of_nonpos_of_nonneg hqcut hrpos.le + have hcauchy : q ^ 2 ≀ s * finiteNormSq y := by + simpa [q, s] using finiteDot_sq_le_normSq_mul_normSq b y + have htSq : t ^ 2 ≀ finiteNormSq y := by + dsimp only [t] + rw [div_pow, div_le_iffβ‚€ (sq_pos_of_pos hrpos), hrsq] + simpa [mul_comm] using hcauchy + have htSqOne : t ^ 2 ≀ 1 := htSq.trans hy + have htNegOne : -1 ≀ t := by nlinarith + have hrsqrt_le_u : r ≀ u := by + have : Real.sqrt s ≀ u := + (Real.sqrt_le_iff).2 ⟨hu.le, hnormLower⟩ + simpa only [r] using this + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hu_le_dsqrt : u ≀ d * r := by + have hds : (d : ℝ) * s ≀ (d : ℝ) ^ 2 * s := by + have : 0 ≀ (d : ℝ) := by positivity + nlinarith + have huSq : u ^ 2 ≀ ((d : ℝ) * r) ^ 2 := by + calc + u ^ 2 ≀ (d : ℝ) * s := by simpa [s] using hnormUpper + _ ≀ (d : ℝ) ^ 2 * s := hds + _ = ((d : ℝ) * r) ^ 2 := by rw [mul_pow, hrsq] + have hdr0 : 0 ≀ (d : ℝ) * r := mul_nonneg (by positivity) hrpos.le + nlinarith + have hhLower : Ξ± / (d : ℝ) ≀ h := by + dsimp only [h] + have hratio : 1 / (d : ℝ) ≀ r / u := by + exact (le_div_iffβ‚€ hu).2 (by + rw [one_div_mul_eq_div] + exact (div_le_iffβ‚€ (by positivity : (0 : ℝ) < d)).2 + (by simpa [mul_comm] using hu_le_dsqrt)) + have := mul_le_mul_of_nonneg_left hratio hΞ±pos.le + simpa [div_eq_mul_inv, mul_assoc] using this + have hhUpper : h ≀ Ξ± := by + dsimp only [h] + have hratio : r / u ≀ 1 := (div_le_one hu).2 hrsqrt_le_u + have := mul_le_mul_of_nonneg_left hratio hΞ±pos.le + calc + Ξ± * r / u = Ξ± * (r / u) := by ring + _ ≀ Ξ± := by simpa using this + have hdotx : finiteDot b x = q + (Ξ± / u) * s := by + dsimp only [x] + change finiteDot b (fun i ↦ y i + (Ξ± / u) * b i) = _ + rw [finiteDot_add_right, + finiteDot_smul_right] + rw [show finiteDot b b = finiteNormSq b by rfl] + have hnormx : finiteNormSq x = + finiteNormSq y + 2 * (Ξ± / u) * q + (Ξ± / u) ^ 2 * s := by + dsimp only [x] + change finiteNormSq (fun i ↦ y i + (Ξ± / u) * b i) = _ + rw [finiteNormSq_add, + finiteDot_smul_right, finiteNormSq_smul] + rw [show finiteDot y b = finiteDot b y by + simp [finiteDot, mul_comm]] + simp only [q, s] + ring + have hperp : + finiteNormSq x - finiteDot b x ^ 2 / s = + finiteNormSq y - t ^ 2 := by + rw [hnormx, hdotx] + dsimp only [t] + field_simp [hsne, hrpos.ne', hu.ne'] + ring_nf + rw [hrsq] + ring + have hparallel : finiteDot b x ^ 2 / (s * p ^ 2) = + (t + h) ^ 2 / p ^ 2 := by + rw [hdotx] + dsimp only [t, h] + have hr4 : r ^ 4 = s ^ 2 := by nlinarith [hrsq] + field_simp [hsne, hrpos.ne', hu.ne'] + ring_nf + rw [hrsq, hr4] + ring + have hinverse := finiteNormSq_directionUpdatePreimage + (A := A) (p := p) (b := b) (x := x) + hApos.ne' hppos.ne' hsne + have hscalar := rationalEllipsoid_scalar_containment hd ht0 htNegOne + (by simpa [Ξ±] using hhLower) (by simpa [Ξ±] using hhUpper) + change finiteNormSq (directionUpdatePreimage A p b x) ≀ 1 + rw [hinverse] + change (finiteNormSq x - finiteDot b x ^ 2 / s) / A ^ 2 + + finiteDot b x ^ 2 / (s * p ^ 2) ≀ 1 + rw [hperp, hparallel] + calc + (finiteNormSq y - t ^ 2) / A ^ 2 + (t + h) ^ 2 / p ^ 2 ≀ + (1 - t ^ 2) / A ^ 2 + (t + h) ^ 2 / p ^ 2 := by + gcongr + _ ≀ 1 := by simpa [A, p] using hscalar + +/-- Casting the executable `β„“1` normalization to the reals commutes with the +finite sum and absolute value. -/ +theorem cast_cutL1Scale {d : β„•} (b : Fin d β†’ β„š) : + (cutL1Scale b : ℝ) = βˆ‘ i, abs (b i : ℝ) := by + simp [cutL1Scale] + +theorem cast_finiteNormSq {d : β„•} (b : Fin d β†’ β„š) : + ((finiteNormSq b : β„š) : ℝ) = + finiteNormSq (fun i ↦ (b i : ℝ)) := by + simp [finiteNormSq, finiteDot] + +/-- Concrete containment theorem for the normalization actually computed by +the rational algorithm. -/ +theorem rationalEllipsoid_direction_containment_of_rational + {d : β„•} (hd : 0 < d) {bq : Fin d β†’ β„š} {y : Fin d β†’ ℝ} + (hbq : bq β‰  0) (hy : finiteNormSq y ≀ 1) + (hcut : finiteDot (fun i ↦ (bq i : ℝ)) y ≀ 0) : + finiteNormSq + (directionUpdatePreimage + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) + (fun i ↦ (bq i : ℝ)) + (directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) + (fun i ↦ (bq i : ℝ)) y)) ≀ 1 := by + let b : Fin d β†’ ℝ := fun i ↦ (bq i : ℝ) + have hb : b β‰  0 := by + intro h + apply hbq + ext i + have hi := congrFun h i + exact (Rat.cast_eq_zero (Ξ± := ℝ)).mp (by simpa [b] using hi) + have huq := cutL1Scale_pos hbq + have hu : 0 < (cutL1Scale bq : ℝ) := (Rat.cast_pos (K := ℝ)).mpr huq + have hlowerQ := finiteNormSq_le_cutL1Scale_sq bq + have hlower : finiteNormSq b ≀ (cutL1Scale bq : ℝ) ^ 2 := by + rw [← cast_finiteNormSq bq] + exact_mod_cast hlowerQ + have hupperQ := cutL1Scale_sq_le_card_mul_normSq bq + have hupper : (cutL1Scale bq : ℝ) ^ 2 ≀ d * finiteNormSq b := by + rw [← cast_finiteNormSq bq] + exact_mod_cast hupperQ + exact rationalEllipsoid_direction_containment hd hb hu hlower hupper hy + (by simpa [b] using hcut) + +/-- Entirely rational state stored by the cutting-plane algorithm. -/ +structure RationalEllipsoidState (d : β„•) where + /-- The rational center stored by the cutting-plane algorithm. -/ + center : Fin d β†’ β„š + /-- The rational basis matrix mapping unit-ball coordinates to ellipsoid displacements. -/ + basis : Matrix (Fin d) (Fin d) β„š + +/-- Pull a physical cut normal back to unit-ball coordinates. -/ +def rationalPulledBackNormal {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : Fin d β†’ β„š := + fun j ↦ βˆ‘ i, E.basis i j * a i + +/-- One square-root-free central-cut update. Division by zero is harmless in +the total Lean definition; correctness is invoked only when the pulled-back +normal is nonzero, in which case `cutL1Scale` is positive. -/ +def rationalEllipsoidCentralUpdate {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + RationalEllipsoidState d := + let b := rationalPulledBackNormal E a + let u := cutL1Scale b + let Ξ± := rationalEllipsoidAlpha d + let C := directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b + { center := fun i ↦ E.center i - + Ξ± * βˆ‘ j, E.basis i j * (b j / u) + basis := E.basis * C } + +/-- Real point represented by rational ellipsoid data and real unit-ball +coordinates. -/ +noncomputable def rationalEllipsoidPoint {d : β„•} + (E : RationalEllipsoidState d) (y : Fin d β†’ ℝ) : Fin d β†’ ℝ := + fun i ↦ (E.center i : ℝ) + βˆ‘ j, (E.basis i j : ℝ) * y j + +theorem cast_directionUpdateMatrix {d : β„•} + (A p : β„š) (b : Fin d β†’ β„š) (i j : Fin d) : + ((directionUpdateMatrix A p b i j : β„š) : ℝ) = + directionUpdateMatrix (A : ℝ) (p : ℝ) + (fun k ↦ (b k : ℝ)) i j := by + by_cases hij : i = j <;> + simp [directionUpdateMatrix, cast_finiteNormSq, hij] + +theorem cast_rationalPulledBackNormal {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) (j : Fin d) : + (rationalPulledBackNormal E a j : ℝ) = + βˆ‘ i, (E.basis i j : ℝ) * (a i : ℝ) := by + simp [rationalPulledBackNormal] + +/-- The stored rational rank-one matrix sends the explicit real preimage to +the shifted old coordinate exactly. -/ +theorem cast_directionUpdateMatrix_preimage {d : β„•} (hd : 0 < d) + {bq : Fin d β†’ β„š} (hbq : bq β‰  0) {y : Fin d β†’ ℝ} : + Matrix.mulVec + (fun i j ↦ + ((directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) bq i j : β„š) : ℝ)) + (directionUpdatePreimage + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) + (fun i ↦ (bq i : ℝ)) + (directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) + (fun i ↦ (bq i : ℝ)) y)) = + directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) + (fun i ↦ (bq i : ℝ)) y := by + let b : Fin d β†’ ℝ := fun i ↦ (bq i : ℝ) + have hb : b β‰  0 := by + intro h + apply hbq + ext i + exact (Rat.cast_eq_zero (Ξ± := ℝ)).mp (by simpa [b] using congrFun h i) + have hnorm : finiteNormSq b β‰  0 := by + intro h + exact hb ((finiteNormSq_eq_zero_iff b).1 h) + have hA : (0 : ℝ) < (rationalEllipsoidPerpScale d : ℝ) := + (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidPerpScale_pos d) + have hp : (0 : ℝ) < (rationalEllipsoidParallelScale d : ℝ) := + (Rat.cast_pos (K := ℝ)).mpr (rationalEllipsoidParallelScale_pos hd) + have hinv := directionUpdateMatrix_preimage + (A := (rationalEllipsoidPerpScale d : ℝ)) + (p := (rationalEllipsoidParallelScale d : ℝ)) + (b := b) + (x := directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) b y) + hA.ne' hp.ne' hnorm + simpa only [b, cast_directionUpdateMatrix] using hinv + +/-- Every point surviving a central cut in the old ellipsoid has an explicit +unit-ball coordinate in the updated rational ellipsoid. -/ +theorem rationalEllipsoidCentralUpdate_contains {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) {y : Fin d β†’ ℝ} + (hb : rationalPulledBackNormal E a β‰  0) + (hy : finiteNormSq y ≀ 1) + (hcut : finiteDot + (fun i ↦ (rationalPulledBackNormal E a i : ℝ)) y ≀ 0) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidCentralUpdate E a) y' = + rationalEllipsoidPoint E y := by + let bq := rationalPulledBackNormal E a + let b : Fin d β†’ ℝ := fun i ↦ (bq i : ℝ) + let y' := directionUpdatePreimage + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b + (directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) b y) + have hbq : bq β‰  0 := by simpa [bq] using hb + have hy' : finiteNormSq y' ≀ 1 := by + dsimp only [y'] + exact rationalEllipsoid_direction_containment_of_rational hd hbq hy + (by simpa [b, bq] using hcut) + refine ⟨y', hy', ?_⟩ + have hCy := cast_directionUpdateMatrix_preimage hd hbq (y := y) + change Matrix.mulVec + (fun i j ↦ + ((directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) bq i j : β„š) : ℝ)) y' = + directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) b y at hCy + have hCyReal : + Matrix.mulVec + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b) y' = + directionShiftedPoint + (rationalEllipsoidAlpha d : ℝ) (cutL1Scale bq : ℝ) b y := by + rw [← hCy] + congr 1 + ext j k + exact (cast_directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) bq j k).symm + ext i + rw [rationalEllipsoidPoint, rationalEllipsoidPoint] + simp only [rationalEllipsoidCentralUpdate] + simp only [Matrix.mul_apply] + push_cast + change (E.center i : ℝ) - + (rationalEllipsoidAlpha d : ℝ) * + (βˆ‘ x, (E.basis i x : ℝ) * + ((bq x : ℝ) / (cutL1Scale bq : ℝ))) + + (βˆ‘ j, + (βˆ‘ k, (E.basis i k : ℝ) * + ((directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) bq k j : β„š) : ℝ)) * y' j) = + (E.center i : ℝ) + βˆ‘ j, (E.basis i j : ℝ) * y j + have hbasis : + (βˆ‘ j, + (βˆ‘ k, (E.basis i k : ℝ) * + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j)) * y' j) = + βˆ‘ k, (E.basis i k : ℝ) * + (Matrix.mulVec + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b) y') k := by + simp only [Matrix.mulVec, dotProduct] + calc + (βˆ‘ j, + (βˆ‘ k, (E.basis i k : ℝ) * + directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j) * y' j) = + βˆ‘ j, βˆ‘ k, (E.basis i k : ℝ) * + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j * y' j) := by + apply Finset.sum_congr rfl + intro j _ + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro k _ + ring + _ = βˆ‘ k, βˆ‘ j, (E.basis i k : ℝ) * + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j * y' j) := + Finset.sum_comm + _ = βˆ‘ k, (E.basis i k : ℝ) * + βˆ‘ j, directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j * y' j := by + apply Finset.sum_congr rfl + intro k _ + rw [Finset.mul_sum] + rw [show + (βˆ‘ j, + (βˆ‘ k, (E.basis i k : ℝ) * + ((directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) bq k j : β„š) : ℝ)) * y' j) = + βˆ‘ j, + (βˆ‘ k, (E.basis i k : ℝ) * + (directionUpdateMatrix + (rationalEllipsoidPerpScale d : ℝ) + (rationalEllipsoidParallelScale d : ℝ) b k j)) * y' j by + apply Finset.sum_congr rfl + intro j _ + congr 1 + apply Finset.sum_congr rfl + intro k _ + rw [cast_directionUpdateMatrix] + ] + rw [hbasis] + rw [hCyReal] + simp only [directionShiftedPoint] + simp only [b] + ring_nf + simp only [Finset.sum_add_distrib, Finset.mul_sum] + have hcancel : + (βˆ‘ x, (rationalEllipsoidAlpha d : ℝ) * + ((E.basis i x : ℝ) * (bq x : ℝ) * + (cutL1Scale bq : ℝ)⁻¹)) = + βˆ‘ x, (rationalEllipsoidAlpha d : ℝ) * + (cutL1Scale bq : ℝ)⁻¹ * (E.basis i x : ℝ) * (bq x : ℝ) := by + apply Finset.sum_congr rfl + intro x _ + ring + rw [hcancel] + ring + +/-- Exact determinant of the rank-one direction update. -/ +theorem det_directionUpdateMatrix {d : β„•} (hd : 0 < d) + {R : Type*} [Field R] {A p : R} (hA : A β‰  0) {b : Fin d β†’ R} + (hb : finiteNormSq b β‰  0) : + Matrix.det (directionUpdateMatrix A p b) = A ^ (d - 1) * p := by + let v : Fin d β†’ R := fun i ↦ -((A - p) / (A * finiteNormSq b)) * b i + have hform : directionUpdateMatrix A p b = + A β€’ (1 + Matrix.vecMulVec b v) := by + ext i j + change A * (if i = j then 1 else 0) - + ((A - p) / finiteNormSq b) * b i * b j = + A * ((if i = j then 1 else 0) + b i * v j) + dsimp only [v] + by_cases hij : i = j + Β· subst j + simp only [ite_true] + field_simp [hA, hb] + ring + Β· simp only [hij, ite_false, zero_add, mul_zero] + field_simp [hA, hb] + ring + rw [hform, Matrix.det_smul] + rw [Matrix.vecMulVec_eq Unit, + Matrix.det_one_add_replicateCol_mul_replicateRow] + have hdot : v ⬝α΅₯ b = -(A - p) / A := by + rw [dotProduct] + let C : R := -((A - p) / (A * finiteNormSq b)) + change (βˆ‘ i, C * b i * b i) = _ + calc + (βˆ‘ i, C * b i * b i) = C * βˆ‘ i, b i * b i := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro i _ + ring + _ = C * finiteNormSq b := by rfl + _ = -(A - p) / A := by + dsimp only [C] + field_simp [hA, hb] + rw [hdot] + simp only [Fintype.card_fin] + have hdle : 1 ≀ d := hd + rw [show 1 + -(A - p) / A = p / A by + field_simp [hA] + ring] + rw [show d = (d - 1) + 1 by omega, pow_succ] + have hcancel : A * (p / A) = p := by field_simp [hA] + calc + A ^ (d - 1) * A * (p / A) = + A ^ (d - 1) * (A * (p / A)) := by ring + _ = A ^ (d - 1) * p := by rw [hcancel] + +/-- Consequently the stored basis determinant contracts by the explicit +factor from `rationalEllipsoid_volumeFactor_lt_one`. -/ +theorem det_rationalEllipsoidCentralUpdate {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + Matrix.det (rationalEllipsoidCentralUpdate E a).basis = + Matrix.det E.basis * + (rationalEllipsoidPerpScale d ^ (d - 1) * + rationalEllipsoidParallelScale d) := by + let b := rationalPulledBackNormal E a + have hbq : finiteNormSq b β‰  0 := by + intro hzero + apply hb + rw [finiteNormSq, finiteDot, + Finset.sum_mul_self_eq_zero_iff] at hzero + ext i + exact hzero i (Finset.mem_univ i) + rw [rationalEllipsoidCentralUpdate] + simp only + rw [Matrix.det_mul] + change Matrix.det E.basis * + Matrix.det (directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b) = _ + rw [det_directionUpdateMatrix hd + (rationalEllipsoidPerpScale_pos d).ne' hbq] + +/-- Apply a finite list of central cuts, in list order. -/ +def rationalEllipsoidIterate {d : β„•} : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ + RationalEllipsoidState d + | E, [] => E + | E, a :: cuts => + rationalEllipsoidIterate (rationalEllipsoidCentralUpdate E a) cuts + +/-- Every cut in a run has a nonzero pulled-back normal at the state where it +is used. This is exactly the side condition needed by the update proof. -/ +def RationalEllipsoidCutsNonzero {d : β„•} : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ Prop + | _, [] => True + | E, a :: cuts => + rationalPulledBackNormal E a β‰  0 ∧ + RationalEllipsoidCutsNonzero + (rationalEllipsoidCentralUpdate E a) cuts + +/-- Exact determinant after a finite valid rational cutting-plane run. -/ +theorem det_rationalEllipsoidIterate {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (cuts : List (Fin d β†’ β„š)) + (hnonzero : RationalEllipsoidCutsNonzero E cuts) : + Matrix.det (rationalEllipsoidIterate E cuts).basis = + Matrix.det E.basis * + (rationalEllipsoidPerpScale d ^ (d - 1) * + rationalEllipsoidParallelScale d) ^ cuts.length := by + induction cuts generalizing E with + | nil => simp [rationalEllipsoidIterate] + | cons a cuts ih => + rw [rationalEllipsoidIterate] + change rationalPulledBackNormal E a β‰  0 ∧ + RationalEllipsoidCutsNonzero + (rationalEllipsoidCentralUpdate E a) cuts at hnonzero + rw [ih (rationalEllipsoidCentralUpdate E a) hnonzero.2, + det_rationalEllipsoidCentralUpdate hd E a hnonzero.1] + simp only [List.length_cons, pow_succ] + ring + +/-- The determinant after `k` cuts is bounded by the explicit exponential +contraction. -/ +theorem abs_det_rationalEllipsoidIterate_le_exp {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (cuts : List (Fin d β†’ β„š)) + (hnonzero : RationalEllipsoidCutsNonzero E cuts) : + abs ((Matrix.det (rationalEllipsoidIterate E cuts).basis : β„š) : ℝ) ≀ + abs ((Matrix.det E.basis : β„š) : ℝ) * + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3)) := by + let q : ℝ := + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) + have hq0 : 0 ≀ q := by + exact mul_nonneg (pow_nonneg + (Rat.cast_nonneg.mpr (rationalEllipsoidPerpScale_pos d).le) _) + (Rat.cast_nonneg.mpr (rationalEllipsoidParallelScale_pos hd).le) + have hqexp : q ≀ Real.exp (-(1 : ℝ) / (8 * (d : ℝ) ^ 3)) := by + simpa [q] using rationalEllipsoid_volumeFactor_le_exp_neg hd + have hpow : q ^ cuts.length ≀ + Real.exp (-(1 : ℝ) / (8 * (d : ℝ) ^ 3)) ^ cuts.length := + pow_le_pow_leftβ‚€ hq0 hqexp _ + have hexp : + Real.exp (-(1 : ℝ) / (8 * (d : ℝ) ^ 3)) ^ cuts.length = + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3)) := by + rw [← Real.exp_nat_mul] + congr 1 + ring + rw [← hexp] + have hdet := det_rationalEllipsoidIterate hd E cuts hnonzero + have hdetReal : + ((Matrix.det (rationalEllipsoidIterate E cuts).basis : β„š) : ℝ) = + ((Matrix.det E.basis : β„š) : ℝ) * q ^ cuts.length := by + have hcast := congrArg (fun x : β„š ↦ (x : ℝ)) hdet + simpa [q] using hcast + rw [hdetReal, abs_mul] + have hqabs : abs q = q := abs_of_nonneg hq0 + rw [abs_pow, hqabs] + exact mul_le_mul_of_nonneg_left hpow (abs_nonneg _) + +/-- A coordinate of a point in the Euclidean unit ball has absolute value at +most one. -/ +theorem abs_coordinate_le_one_of_normSq_le_one {d : β„•} + {x : Fin d β†’ ℝ} (hx : finiteNormSq x ≀ 1) (i : Fin d) : + abs (x i) ≀ 1 := by + have hcoord : x i * x i ≀ finiteNormSq x := by + rw [finiteNormSq, finiteDot] + exact Finset.single_le_sum (fun j _ ↦ mul_self_nonneg (x j)) + (Finset.mem_univ i) + have hsquare : (abs (x i)) ^ 2 ≀ 1 := by + rw [sq_abs, sq] + exact hcoord.trans hx + nlinarith [abs_nonneg (x i)] + +/-- Difference matrix whose `k`th column joins two unit-ball coordinates. -/ +def unitBallDifferenceMatrix {d : β„•} + (yPlus yMinus : Fin d β†’ Fin d β†’ ℝ) : Matrix (Fin d) (Fin d) ℝ := + fun i k ↦ yPlus k i - yMinus k i + +theorem unitBallDifferenceMatrix_entry_le_two {d : β„•} + {yPlus yMinus : Fin d β†’ Fin d β†’ ℝ} + (hplus : βˆ€ k, finiteNormSq (yPlus k) ≀ 1) + (hminus : βˆ€ k, finiteNormSq (yMinus k) ≀ 1) + (i k : Fin d) : + abs (unitBallDifferenceMatrix yPlus yMinus i k) ≀ 2 := by + rw [unitBallDifferenceMatrix] + exact (abs_sub (yPlus k i) (yMinus k i)).trans + (by linarith [abs_coordinate_le_one_of_normSq_le_one (hplus k) i, + abs_coordinate_le_one_of_normSq_le_one (hminus k) i]) + +/-- Elementary substitute for the usual volume lower bound. If a linear +image of the unit ball contains the `2d` endpoints of the coordinate +diameters of a radius-`r` ball, its determinant is at least `r^d / d!`. +This follows from the Leibniz determinant bound, so no measure theory is +needed. -/ +theorem determinant_lower_of_coordinate_diameters {d : β„•} + (B : Matrix (Fin d) (Fin d) ℝ) {r : ℝ} (hr : 0 ≀ r) + {yPlus yMinus : Fin d β†’ Fin d β†’ ℝ} + (hplus : βˆ€ k, finiteNormSq (yPlus k) ≀ 1) + (hminus : βˆ€ k, finiteNormSq (yMinus k) ≀ 1) + (hdiameter : βˆ€ k, + Matrix.mulVec B (fun j ↦ yPlus k j - yMinus k j) = + fun i ↦ if i = k then 2 * r else 0) : + r ^ d ≀ Nat.factorial d * abs (Matrix.det B) := by + let V := unitBallDifferenceMatrix yPlus yMinus + have hBV : B * V = (2 * r) β€’ (1 : Matrix (Fin d) (Fin d) ℝ) := by + ext i k + rw [Matrix.mul_apply] + have hk := congrFun (hdiameter k) i + change (βˆ‘ x, B i x * V x k) = _ + rw [show (βˆ‘ x, B i x * V x k) = + Matrix.mulVec B (fun j ↦ yPlus k j - yMinus k j) i by rfl, + hk] + by_cases hik : i = k <;> simp [hik] + have hdetEq : Matrix.det B * Matrix.det V = (2 * r) ^ d := by + rw [← Matrix.det_mul, hBV, Matrix.det_smul, Matrix.det_one, + mul_one, Fintype.card_fin] + have hdetV : abs (Matrix.det V) ≀ Nat.factorial d * 2 ^ d := by + have h := Matrix.det_le (abv := (AbsoluteValue.abs : AbsoluteValue ℝ ℝ)) + (A := V) (x := (2 : ℝ)) + (fun i k ↦ unitBallDifferenceMatrix_entry_le_two hplus hminus i k) + simpa [Fintype.card_fin, nsmul_eq_mul] using h + have habsEq : abs (Matrix.det B) * abs (Matrix.det V) = (2 * r) ^ d := by + rw [← abs_mul, hdetEq, abs_of_nonneg (pow_nonneg (mul_nonneg (by norm_num) hr) _)] + have hscaled : (2 * r) ^ d ≀ + abs (Matrix.det B) * (Nat.factorial d * 2 ^ d) := by + rw [← habsEq] + exact mul_le_mul_of_nonneg_left hdetV (abs_nonneg _) + have htwo : (0 : ℝ) < 2 ^ d := by positivity + have hrewrite : (2 * r) ^ d = 2 ^ d * r ^ d := by rw [mul_pow] + rw [hrewrite] at hscaled + have hscaled' : 2 ^ d * r ^ d ≀ + 2 ^ d * (Nat.factorial d * abs (Matrix.det B)) := by + calc + 2 ^ d * r ^ d ≀ abs (Matrix.det B) * (Nat.factorial d * 2 ^ d) := hscaled + _ = 2 ^ d * (Nat.factorial d * abs (Matrix.det B)) := by ring + exact le_of_mul_le_mul_left hscaled' htwo + +/-- If a rational ellipsoid contains the coordinate endpoints of a real ball +of radius `r`, its (real-cast) basis determinant has the corresponding +algebraic lower bound. This is the exact finite substitute for the usual +statement that containment of an inner ball gives a lower volume bound. -/ +theorem rationalEllipsoid_determinant_lower_of_ball_endpoints {d : β„•} + (E : RationalEllipsoidState d) {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hplus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint E y = + fun i ↦ z i + if i = k then r else 0) + (hminus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint E y = + fun i ↦ z i - if i = k then r else 0) : + r ^ d ≀ Nat.factorial d * + abs (Matrix.det (fun i j ↦ (E.basis i j : ℝ))) := by + classical + choose yPlus hplusNorm hplusPoint using hplus + choose yMinus hminusNorm hminusPoint using hminus + apply determinant_lower_of_coordinate_diameters + (fun i j ↦ (E.basis i j : ℝ)) hr hplusNorm hminusNorm + intro k + ext i + have hp := congrFun (hplusPoint k) i + have hm := congrFun (hminusPoint k) i + rw [rationalEllipsoidPoint] at hp hm + change (βˆ‘ j, (E.basis i j : ℝ) * (yPlus k j - yMinus k j)) = _ + simp_rw [mul_sub] + rw [Finset.sum_sub_distrib] + by_cases hik : i = k <;> simp [hik] at hp hm ⊒ <;> linarith + +/-- The same lower bound written directly in terms of the stored rational +determinant. -/ +theorem rationalEllipsoid_storedDet_lower_of_ball_endpoints {d : β„•} + (E : RationalEllipsoidState d) {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hplus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint E y = + fun i ↦ z i + if i = k then r else 0) + (hminus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint E y = + fun i ↦ z i - if i = k then r else 0) : + r ^ d ≀ Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) := by + rw [Rat.cast_det] + change r ^ d ≀ Nat.factorial d * abs (Matrix.det (fun i j => (E.basis i j : ℝ))) + exact rationalEllipsoid_determinant_lower_of_ball_endpoints E hr hplus hminus + +/-- The elementary estimate `exp (-1) ≀ 1/2`, derived from the power-series +lower bound `2 ≀ exp 1`. -/ +theorem real_exp_neg_one_le_half : + Real.exp (-1) ≀ (1 / 2 : ℝ) := by + rw [Real.exp_neg] + have htwo : (2 : ℝ) ≀ Real.exp 1 := by + convert Real.add_one_le_exp (1 : ℝ) using 1 <;> norm_num + have hinv := one_div_le_one_div_of_le (by norm_num : (0 : ℝ) < 2) htwo + simpa [one_div] using hinv + +/-- After `8 d^3 M` cuts, the analytic contraction factor is at most +`2^{-M}`. Thus the iteration budget can be chosen using ordinary binary +lengths rather than a real logarithm. -/ +theorem exp_neg_cutRatio_le_half_pow {d M k : β„•} (hd : 0 < d) + (hk : 8 * d ^ 3 * M ≀ k) : + Real.exp (-(k : ℝ) / (8 * (d : ℝ) ^ 3)) ≀ (1 / 2 : ℝ) ^ M := by + have hden : (0 : ℝ) < 8 * (d : ℝ) ^ 3 := by positivity + have hkReal : (8 : ℝ) * (d : ℝ) ^ 3 * (M : ℝ) ≀ (k : ℝ) := by + exact_mod_cast hk + have hratio : (M : ℝ) ≀ (k : ℝ) / (8 * (d : ℝ) ^ 3) := by + rw [le_div_iffβ‚€ hden] + calc + (M : ℝ) * (8 * (d : ℝ) ^ 3) = + 8 * (d : ℝ) ^ 3 * (M : ℝ) := by ring + _ ≀ (k : ℝ) := hkReal + calc + Real.exp (-(k : ℝ) / (8 * (d : ℝ) ^ 3)) ≀ + Real.exp (-(M : ℝ)) := by + rw [Real.exp_le_exp] + convert neg_le_neg hratio using 1 <;> ring + _ = Real.exp (-1) ^ M := by + rw [show -(M : ℝ) = (M : ℝ) * (-1 : ℝ) by ring, + Real.exp_nat_mul] + _ ≀ (1 / 2 : ℝ) ^ M := + pow_le_pow_leftβ‚€ (Real.exp_pos (-1)).le real_exp_neg_one_le_half M + +/-- The determinant upper and lower bounds sandwich every run that still +contains the endpoints of a radius-`r` ball. -/ +theorem rationalEllipsoid_run_sandwich {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (cuts : List (Fin d β†’ β„š)) + (hnonzero : RationalEllipsoidCutsNonzero E cuts) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hplus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i + if i = k then r else 0) + (hminus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i - if i = k then r else 0) : + r ^ d ≀ Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3)) := by + have hlower := rationalEllipsoid_storedDet_lower_of_ball_endpoints + (rationalEllipsoidIterate E cuts) hr hplus hminus + have hupper := abs_det_rationalEllipsoidIterate_le_exp hd E cuts hnonzero + calc + r ^ d ≀ Nat.factorial d * + abs ((Matrix.det (rationalEllipsoidIterate E cuts).basis : β„š) : ℝ) := + hlower + _ ≀ Nat.factorial d * + (abs ((Matrix.det E.basis : β„š) : ℝ) * + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3))) := by + exact mul_le_mul_of_nonneg_left hupper (Nat.cast_nonneg _) + _ = Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3)) := by ring + +/-- A concrete dyadic budget rules out a run that continues to contain the +inner ball. -/ +theorem rationalEllipsoid_no_long_run {d M : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (cuts : List (Fin d β†’ β„š)) + (hnonzero : RationalEllipsoidCutsNonzero E cuts) + (hlength : 8 * d ^ 3 * M ≀ cuts.length) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hdyadic : Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M < r ^ d) + (hplus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i + if i = k then r else 0) + (hminus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i - if i = k then r else 0) : False := by + have hsandwich := rationalEllipsoid_run_sandwich hd E cuts hnonzero + hr hplus hminus + have hexp := exp_neg_cutRatio_le_half_pow hd hlength + have hnonneg : + 0 ≀ Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) := by + positivity + have hcontract : + Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + Real.exp (-(cuts.length : ℝ) / (8 * (d : ℝ) ^ 3)) ≀ + Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M := + mul_le_mul_of_nonneg_left hexp hnonneg + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RationalEncodingBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/RationalEncodingBounds.lean new file mode 100644 index 0000000000..409254397d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RationalEncodingBounds.lean @@ -0,0 +1,432 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidIterationBounds +public import Mathlib.Data.Rat.Lemmas +public import Mathlib.Tactic + +/-! # Rational Encoding Bounds -/ + +@[expose] public section + +namespace BeyondBethe + +open Complexity + +/-! +# Upper bounds for the canonical rational encoding + +The algorithm uses Complexitylib's parenthesized binary `DataEncode` +serialization. These lemmas give explicit upper bounds for that exact +encoding, rather than appealing to an informal notion of rational bit size. +-/ + +theorem bool_dataEncode_size_le_four (b : Bool) : + (DataEncode.encode b).size ≀ 4 := by + cases b <;> norm_num [DataEncode.encode, Data.size] + +theorem nat_encodedBitLength_le (n : β„•) : + encodedBitLength β„• n ≀ 2 + 4 * n.size := by + rw [encodedBitLength_eq_dataSize] + change (Data.l (n.bits.map fun b ↦ DataEncode.encode b)).size ≀ _ + rw [Data.size] + simp only [List.map_map] + have hsum : + ((n.bits.map fun b ↦ (DataEncode.encode b).size).sum) ≀ + 4 * n.bits.length := by + induction n.bits with + | nil => simp + | cons b bits ih => + simp only [List.map_cons, List.sum_cons, List.length_cons] + have hb := bool_dataEncode_size_le_four b + omega + have hadd := Nat.add_le_add_left hsum 2 + simpa only [Function.comp_apply, Nat.size_eq_bits_len] using! hadd + +theorem integer_encodedBitLength_le (z : β„€) : + encodedBitLength β„€ z ≀ 8 + 4 * z.natAbs.size := by + rw [encodedBitLength_eq_dataSize] + change (DataEncode.encode (integerPayload z)).size ≀ _ + rw [show DataEncode.encode (integerPayload z) = + Data.l [DataEncode.encode (integerPayload z).1, + DataEncode.encode (integerPayload z).2] by + exact DataEncode_pair _ _] + simp only [Data.size, List.map_cons, List.map_nil, List.sum_cons, + List.sum_nil, add_zero] + have hb := bool_dataEncode_size_le_four (integerPayload z).1 + have hn := nat_encodedBitLength_le (integerPayload z).2 + rw [encodedBitLength_eq_dataSize] at hn + have hn' : (DataEncode.encode (integerPayload z).2).size ≀ + 2 + 4 * z.natAbs.size := by + simpa only [integerPayload_snd] using! hn + omega + +theorem rational_encodedBitLength_le (q : β„š) : + encodedBitLength β„š q ≀ + 12 + 4 * (q.num.natAbs.size + q.den.size) := by + rw [encodedBitLength_eq_dataSize] + change (DataEncode.encode (rationalPayload q)).size ≀ _ + rw [show DataEncode.encode (rationalPayload q) = + Data.l [DataEncode.encode q.num, DataEncode.encode q.den] by + simpa only [rationalPayload] using! DataEncode_pair q.num q.den] + simp only [Data.size, List.map_cons, List.map_nil, List.sum_cons, + List.sum_nil, add_zero] + have hz := integer_encodedBitLength_le q.num + have hd := nat_encodedBitLength_le q.den + rw [encodedBitLength_eq_dataSize] at hz hd + omega + +theorem one_le_rational_encodedBitLength (q : β„š) : + 1 ≀ encodedBitLength β„š q := by + have h := denominator_encodedBitLength_lt_rational q + omega + +theorem nat_size_le_succ_of_le_two_pow {n P : β„•} + (h : n ≀ 2 ^ P) : n.size ≀ P + 1 := by + rw [Nat.size_le] + calc + n ≀ 2 ^ P := h + _ < 2 ^ (P + 1) := by + rw [pow_succ] + have hp : 0 < 2 ^ P := by positivity + omega + +theorem rat_abs_eq_numNatAbs_div_den (q : β„š) : + abs q = (q.num.natAbs : β„š) / q.den := by + rw [Rat.abs_def, Rat.divInt_eq_div] + norm_num + +theorem rat_num_natAbs_le_of_abs_and_den_bounds + {q : β„š} {K P : β„•} + (habs : abs q ≀ (2 : β„š) ^ K) + (hden : q.den ≀ 2 ^ P) : + q.num.natAbs ≀ 2 ^ (K + P) := by + have hdenQ : (q.den : β„š) ≀ (2 : β„š) ^ P := by exact_mod_cast hden + have hnumQ : (q.num.natAbs : β„š) ≀ + (2 : β„š) ^ K * q.den := by + rw [rat_abs_eq_numNatAbs_div_den] at habs + rw [div_le_iffβ‚€ (by positivity : (0 : β„š) < q.den)] at habs + simpa only [mul_comm] using! habs + have hboundQ : (q.num.natAbs : β„š) ≀ (2 : β„š) ^ (K + P) := by + calc + (q.num.natAbs : β„š) ≀ (2 : β„š) ^ K * q.den := hnumQ + _ ≀ (2 : β„š) ^ K * (2 : β„š) ^ P := + mul_le_mul_of_nonneg_left hdenQ (by positivity) + _ = (2 : β„š) ^ (K + P) := by rw [pow_add] + exact_mod_cast hboundQ + +theorem rational_encodedBitLength_le_of_abs_and_den_bounds + {q : β„š} {K P : β„•} + (habs : abs q ≀ (2 : β„š) ^ K) + (hden : q.den ≀ 2 ^ P) : + encodedBitLength β„š q ≀ 20 + 4 * K + 8 * P := by + have hnum := rat_num_natAbs_le_of_abs_and_den_bounds habs hden + have hnumSize := nat_size_le_succ_of_le_two_pow hnum + have hdenSize := nat_size_le_succ_of_le_two_pow hden + have hencode := rational_encodedBitLength_le q + omega + +theorem dyadicFloor_den_le (p : β„•) (q : β„š) : + (dyadicFloor p q).den ≀ 2 ^ p := by + let z : β„€ := Int.floor (q * (2 : β„š) ^ p) + have heq : dyadicFloor p q = Rat.divInt z (2 ^ p : β„€) := by + rw [dyadicFloor] + dsimp only [z] + rw [show (2 : β„š) ^ p = ((2 ^ p : β„•) : β„š) by norm_num, + ← Rat.intCast_div_eq_divInt] + norm_num + have hdvdZ : (((dyadicFloor p q).den : β„•) : β„€) ∣ (2 ^ p : β„€) := by + rw [heq] + exact Rat.den_dvd z (2 ^ p : β„€) + have hdvd : (dyadicFloor p q).den ∣ 2 ^ p := by + exact_mod_cast hdvdZ + exact Nat.le_of_dvd (by positivity) hdvd + +theorem abs_dyadicFloor_le_two_pow_succ {p K : β„•} {q : β„š} + (hq : abs q ≀ (2 : β„š) ^ K) : + abs (dyadicFloor p q) ≀ (2 : β„š) ^ (K + 1) := by + have hround := abs_dyadicFloor_le p q + have hmesh := dyadicMesh_le_one p + have hone : (1 : β„š) ≀ (2 : β„š) ^ K := one_le_powβ‚€ (by norm_num) + rw [pow_succ] + linarith + +/-- Exact encoding bound for the executable dyadic-floor primitive. -/ +theorem dyadicFloor_encodedBitLength_le {p K : β„•} {q : β„š} + (hq : abs q ≀ (2 : β„š) ^ K) : + encodedBitLength β„š (dyadicFloor p q) ≀ + 24 + 4 * K + 8 * p := by + have h := rational_encodedBitLength_le_of_abs_and_den_bounds + (abs_dyadicFloor_le_two_pow_succ (p := p) hq) + (dyadicFloor_den_le p q) + omega + +theorem roundedEllipsoidInflationFactor_den_dvd (d : β„•) : + (1 + roundedEllipsoidInflation d).den ∣ 1024 * d ^ 4 := by + let N := 1024 * d ^ 4 + have heq : roundedEllipsoidInflation d = Rat.divInt 1 (N : β„€) := by + rw [roundedEllipsoidInflation] + dsimp only [N] + rw [← Rat.intCast_div_eq_divInt] + norm_num + have hdenZ : (((roundedEllipsoidInflation d).den : β„•) : β„€) ∣ (N : β„€) := by + rw [heq] + exact Rat.den_dvd 1 (N : β„€) + have hden : (roundedEllipsoidInflation d).den ∣ N := by + exact_mod_cast hdenZ + have hadd : (1 + roundedEllipsoidInflation d).den ∣ + (roundedEllipsoidInflation d).den := by + simpa using! Rat.add_den_dvd (1 : β„š) (roundedEllipsoidInflation d) + exact hadd.trans hden + +theorem roundedEllipsoidInflationFactor_den_le {d : β„•} (hd : 0 < d) : + (1 + roundedEllipsoidInflation d).den ≀ 1024 * d ^ 4 := + Nat.le_of_dvd (by positivity) (roundedEllipsoidInflationFactor_den_dvd d) + +theorem roundedEllipsoidInflationDenominator_le_two_pow (d : β„•) : + (1024 * d ^ 4 : β„•) ≀ 2 ^ (10 + 4 * d) := by + have hdq := natCast_le_two_pow_self d + have hd4 : (d : β„š) ^ 4 ≀ ((2 : β„š) ^ d) ^ 4 := + pow_le_pow_leftβ‚€ (by positivity) hdq 4 + have hq : ((1024 * d ^ 4 : β„•) : β„š) ≀ + ((2 ^ (10 + 4 * d) : β„•) : β„š) := by + norm_num only [Nat.cast_mul, Nat.cast_pow, Nat.cast_ofNat] + calc + (1024 : β„š) * d ^ 4 ≀ 1024 * ((2 : β„š) ^ d) ^ 4 := + mul_le_mul_of_nonneg_left hd4 (by norm_num) + _ = (2 : β„š) ^ (10 + 4 * d) := by + rw [show (1024 : β„š) = 2 ^ 10 by norm_num, ← pow_mul, ← pow_add] + congr 1 + omega + exact_mod_cast hq + +theorem inflatedDyadicRound_center_den_le {d p : β„•} (Ξ· : β„š) + (U : RationalEllipsoidState d) (i : Fin d) : + ((inflatedDyadicRound p Ξ· U).center i).den ≀ 2 ^ p := by + change (dyadicFloor p (U.center i)).den ≀ 2 ^ p + exact dyadicFloor_den_le p (U.center i) + +theorem inflatedDyadicRound_basis_den_le {d p : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (i j : Fin d) : + ((inflatedDyadicRound p (roundedEllipsoidInflation d) U).basis i j).den ≀ + 2 ^ (p + 10 + 4 * d) := by + let f : β„š := 1 + roundedEllipsoidInflation d + let q : β„š := dyadicFloor p (U.basis i j) + have hdiv : (f * q).den ∣ f.den * q.den := Rat.mul_den_dvd f q + have hprodPos : 0 < f.den * q.den := by positivity + have hden : (f * q).den ≀ f.den * q.den := Nat.le_of_dvd hprodPos hdiv + have hf : f.den ≀ 1024 * d ^ 4 := by + dsimp only [f] + exact roundedEllipsoidInflationFactor_den_le hd + have hq : q.den ≀ 2 ^ p := by + dsimp only [q] + exact dyadicFloor_den_le p (U.basis i j) + have hN := roundedEllipsoidInflationDenominator_le_two_pow d + change (f * q).den ≀ 2 ^ (p + 10 + 4 * d) + calc + (f * q).den ≀ f.den * q.den := hden + _ ≀ (1024 * d ^ 4) * 2 ^ p := Nat.mul_le_mul hf hq + _ ≀ 2 ^ (10 + 4 * d) * 2 ^ p := Nat.mul_le_mul_right _ hN + _ = 2 ^ (p + 10 + 4 * d) := by + rw [← pow_add] + congr 1 + omega + +theorem adaptiveRoundedEllipsoid_center_den_le {d : β„•} + (U : RationalEllipsoidState d) (i : Fin d) : + ((adaptiveRoundedEllipsoid U).center i).den ≀ + 2 ^ roundedEllipsoidPrecision U := by + exact inflatedDyadicRound_center_den_le + (roundedEllipsoidInflation d) U i + +theorem adaptiveRoundedEllipsoid_basis_den_le {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (i j : Fin d) : + ((adaptiveRoundedEllipsoid U).basis i j).den ≀ + 2 ^ (roundedEllipsoidPrecision U + 10 + 4 * d) := by + exact inflatedDyadicRound_basis_den_le hd U i j + +theorem abs_center_entry_lt_rationalCenterAbsBound {d : β„•} + (c : Fin d β†’ β„š) (i : Fin d) : + abs (c i) < rationalCenterAbsBound c := by + rw [rationalCenterAbsBound] + have hi : abs (c i) ≀ βˆ‘ j, abs (c j) := + Finset.single_le_sum (fun j _ ↦ abs_nonneg (c j)) + (Finset.mem_univ i) + linarith + +theorem abs_center_entry_lt_rationalStateAbsBound {d : β„•} + (E : RationalEllipsoidState d) (i : Fin d) : + abs (E.center i) < rationalStateAbsBound E := by + rw [rationalStateAbsBound] + exact (abs_center_entry_lt_rationalCenterAbsBound E.center i).trans_le + (le_add_of_nonneg_right (by + linarith [rationalMatrixAbsBound_one_le E.basis])) + +theorem abs_basis_entry_lt_rationalStateAbsBound {d : β„•} + (E : RationalEllipsoidState d) (i j : Fin d) : + abs (E.basis i j) < rationalStateAbsBound E := by + rw [rationalStateAbsBound] + exact (abs_entry_lt_rationalMatrixAbsBound E.basis i j).trans_le + (le_add_of_nonneg_left (by + linarith [rationalCenterAbsBound_one_le E.center])) + +theorem adaptiveRoundedEllipsoid_center_encodedBitLength_le + {d K P : β„•} (U : RationalEllipsoidState d) + (hM : rationalStateAbsBound (adaptiveRoundedEllipsoid U) ≀ (2 : β„š) ^ K) + (hp : roundedEllipsoidPrecision U ≀ P) (i : Fin d) : + encodedBitLength β„š ((adaptiveRoundedEllipsoid U).center i) ≀ + 20 + 4 * K + 8 * P := by + have habs : abs ((adaptiveRoundedEllipsoid U).center i) ≀ (2 : β„š) ^ K := + (abs_center_entry_lt_rationalStateAbsBound + (adaptiveRoundedEllipsoid U) i).le.trans hM + have hden0 := adaptiveRoundedEllipsoid_center_den_le U i + have hpow : 2 ^ roundedEllipsoidPrecision U ≀ 2 ^ P := + Nat.pow_le_pow_right (by decide) hp + exact rational_encodedBitLength_le_of_abs_and_den_bounds habs + (hden0.trans hpow) + +theorem adaptiveRoundedEllipsoid_basis_encodedBitLength_le + {d K P : β„•} (hd : 0 < d) (U : RationalEllipsoidState d) + (hM : rationalStateAbsBound (adaptiveRoundedEllipsoid U) ≀ (2 : β„š) ^ K) + (hp : roundedEllipsoidPrecision U ≀ P) (i j : Fin d) : + encodedBitLength β„š ((adaptiveRoundedEllipsoid U).basis i j) ≀ + 100 + 4 * K + 8 * P + 32 * d := by + have habs : abs ((adaptiveRoundedEllipsoid U).basis i j) ≀ (2 : β„š) ^ K := + (abs_basis_entry_lt_rationalStateAbsBound + (adaptiveRoundedEllipsoid U) i j).le.trans hM + have hden0 := adaptiveRoundedEllipsoid_basis_den_le hd U i j + have hexp : roundedEllipsoidPrecision U + 10 + 4 * d ≀ + P + 10 + 4 * d := by omega + have hpow : 2 ^ (roundedEllipsoidPrecision U + 10 + 4 * d) ≀ + 2 ^ (P + 10 + 4 * d) := Nat.pow_le_pow_right (by decide) hexp + have h := rational_encodedBitLength_le_of_abs_and_den_bounds habs + (hden0.trans hpow) + omega + +/-- Canonical payload for a fixed-dimensional ellipsoid state. -/ +def rationalEllipsoidStatePayload {d : β„•} (E : RationalEllipsoidState d) : + List β„š Γ— List (List β„š) := + (List.ofFn E.center, rationalMatrixRows E.basis) + +/-- The encoded bit length of the ellipsoid state's center-vector and basis-row payload. -/ +def rationalEllipsoidStateEncodedBitLength {d : β„•} + (E : RationalEllipsoidState d) : β„• := + encodedBitLength (List β„š Γ— List (List β„š)) + (rationalEllipsoidStatePayload E) + +theorem dataEncode_list_ofFn_size {d : β„•} {Ξ± : Type} + [DataEncode Ξ±] (x : Fin d β†’ Ξ±) : + (DataEncode.encode (List.ofFn x)).size = + 2 + βˆ‘ i, (DataEncode.encode (x i)).size := by + change (Data.l ((List.ofFn x).map DataEncode.encode)).size = _ + rw [Data.size] + simpa only [List.map_ofFn, List.sum_ofFn, Function.comp_apply] + +theorem rationalMatrixInput_encodedBitLength_eq {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + encodedBitLength RationalMatrixInput ⟨n, A⟩ = + 4 + encodedBitLength β„• n + 2 * n + + βˆ‘ i, βˆ‘ j, encodedBitLength β„š (A i j) := by + rw [encodedBitLength_eq_dataSize] + change (DataEncode.encode (rationalMatrixInputPayload ⟨n, A⟩)).size = _ + simp only [rationalMatrixInputPayload, DataEncode_pair, Data.size, + List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, add_zero, + rationalMatrixRows, encodedBitLength_eq_dataSize] + rw [dataEncode_list_ofFn_size] + simp_rw [dataEncode_list_ofFn_size] + have htwo : (βˆ‘ _i : Fin n, (2 : β„•)) = 2 * n := by + simp [mul_comm] + rw [Finset.sum_add_distrib, htwo] + omega + +theorem rationalMatrixEntryBitBound_le_inputLength {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + rationalMatrixEntryBitBound A ≀ + encodedBitLength RationalMatrixInput ⟨n, A⟩ := by + rw [rationalMatrixInput_encodedBitLength_eq, rationalMatrixEntryBitBound] + omega + +theorem matrixDimensionSq_le_inputLength {n : β„•} + (A : Matrix (Fin n) (Fin n) β„š) : + n ^ 2 ≀ encodedBitLength RationalMatrixInput ⟨n, A⟩ := by + have hentries : n ^ 2 ≀ + βˆ‘ i, βˆ‘ j, encodedBitLength β„š (A i j) := by + calc + n ^ 2 = βˆ‘ _i : Fin n, βˆ‘ _j : Fin n, 1 := by simp; ring + _ ≀ βˆ‘ i, βˆ‘ j, encodedBitLength β„š (A i j) := by + apply Finset.sum_le_sum + intro i _ + apply Finset.sum_le_sum + intro j _ + exact one_le_rational_encodedBitLength (A i j) + rw [rationalMatrixInput_encodedBitLength_eq] + omega + +theorem rationalEllipsoidStateEncodedBitLength_eq {d : β„•} + (E : RationalEllipsoidState d) : + rationalEllipsoidStateEncodedBitLength E = + 6 + (βˆ‘ i, encodedBitLength β„š (E.center i)) + 2 * d + + βˆ‘ i, βˆ‘ j, encodedBitLength β„š (E.basis i j) := by + rw [rationalEllipsoidStateEncodedBitLength, + encodedBitLength_eq_dataSize] + simp only [rationalEllipsoidStatePayload, DataEncode_pair, Data.size, + List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, add_zero, + rationalMatrixRows, encodedBitLength_eq_dataSize] + rw [dataEncode_list_ofFn_size, dataEncode_list_ofFn_size] + simp_rw [dataEncode_list_ofFn_size] + have htwo : (βˆ‘ _i : Fin d, (2 : β„•)) = 2 * d := by + simp [mul_comm] + rw [Finset.sum_add_distrib] + rw [htwo] + omega + +/-- Total encoding size of one stored rounded state. -/ +theorem adaptiveRoundedEllipsoid_state_encodedBitLength_le + {d K P : β„•} (hd : 0 < d) (U : RationalEllipsoidState d) + (hM : rationalStateAbsBound (adaptiveRoundedEllipsoid U) ≀ (2 : β„š) ^ K) + (hp : roundedEllipsoidPrecision U ≀ P) : + rationalEllipsoidStateEncodedBitLength (adaptiveRoundedEllipsoid U) ≀ + 6 + d * (20 + 4 * K + 8 * P) + 2 * d + + d ^ 2 * (100 + 4 * K + 8 * P + 32 * d) := by + rw [rationalEllipsoidStateEncodedBitLength_eq] + have hc : (βˆ‘ i : Fin d, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).center i)) ≀ + βˆ‘ _i : Fin d, (20 + 4 * K + 8 * P) := by + apply Finset.sum_le_sum + intro i _ + exact adaptiveRoundedEllipsoid_center_encodedBitLength_le U hM hp i + have hB : (βˆ‘ i : Fin d, βˆ‘ j : Fin d, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).basis i j)) ≀ + βˆ‘ _i : Fin d, βˆ‘ _j : Fin d, + (100 + 4 * K + 8 * P + 32 * d) := by + apply Finset.sum_le_sum + intro i _ + apply Finset.sum_le_sum + intro j _ + exact adaptiveRoundedEllipsoid_basis_encodedBitLength_le hd U hM hp i j + have hc' : (βˆ‘ i : Fin d, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).center i)) ≀ + d * (20 + 4 * K + 8 * P) := by + simpa only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] using! hc + have hB' : (βˆ‘ i : Fin d, βˆ‘ j : Fin d, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).basis i j)) ≀ + d * (d * (100 + 4 * K + 8 * P + 32 * d)) := by + simpa only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, + nsmul_eq_mul] using! hB + calc + 6 + (βˆ‘ i, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).center i)) + 2 * d + + βˆ‘ i, βˆ‘ j, encodedBitLength β„š + ((adaptiveRoundedEllipsoid U).basis i j) ≀ + 6 + d * (20 + 4 * K + 8 * P) + 2 * d + + d * (d * (100 + 4 * K + 8 * P + 32 * d)) := by omega + _ = 6 + d * (20 + 4 * K + 8 * P) + 2 * d + + d ^ 2 * (100 + 4 * K + 8 * P + 32 * d) := by ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RationalEpigraphOracle.lean b/LeanPool/BeyondBethe/BeyondBethe/RationalEpigraphOracle.lean new file mode 100644 index 0000000000..82eab31ece --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RationalEpigraphOracle.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RationalLinearOracle +public import Mathlib.Tactic + +/-! # Rational Epigraph Oracle -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Directed rational cuts for a convex epigraph + +The first `d` coordinates are base variables and the last coordinate is the +epigraph height. A lower objective endpoint and an approximate gradient give +an entirely rational violation test. When the test succeeds, convexity and +the explicit gradient-error budget prove that the returned normal is a strict +central cut for the exact epigraph. +-/ + +/-- Projects an epigraph point to its first `d` base coordinates. -/ +def epigraphBase {d : β„•} {R : Type*} + (x : Fin (d + 1) β†’ R) : Fin d β†’ R := + fun i ↦ x i.castSucc + +/-- Reads the final height coordinate of an epigraph point. -/ +def epigraphHeight {d : β„•} {R : Type*} + (x : Fin (d + 1) β†’ R) : R := + x (Fin.last d) + +/-- Appends minus one to a base gradient to form the epigraph supporting normal. -/ +def epigraphNormal {d : β„•} {R : Type*} [Neg R] [OfNat R 1] + (g : Fin d β†’ R) : Fin (d + 1) β†’ R := + Fin.snoc g (-1) + +@[simp] theorem epigraphNormal_castSucc {d : β„•} {R : Type*} + [Neg R] [OfNat R 1] (g : Fin d β†’ R) (i : Fin d) : + epigraphNormal g i.castSucc = g i := by + simp [epigraphNormal] + +@[simp] theorem epigraphNormal_last {d : β„•} {R : Type*} + [Neg R] [OfNat R 1] (g : Fin d β†’ R) : + epigraphNormal g (Fin.last d) = -1 := by + simp [epigraphNormal] + +theorem epigraphNormal_ne_zero {d : β„•} (g : Fin d β†’ β„š) : + epigraphNormal g β‰  0 := by + intro hzero + have hlast := congrFun hzero (Fin.last d) + norm_num at hlast + +/-- Entrywise `l1` size of a vector. -/ +def vectorL1 {d : β„•} (x : Fin d β†’ ℝ) : ℝ := + βˆ‘ i, abs (x i) + +theorem vectorL1_nonneg {d : β„•} (x : Fin d β†’ ℝ) : + 0 ≀ vectorL1 x := + Finset.sum_nonneg fun i _ ↦ abs_nonneg (x i) + +theorem finiteDot_sub_le_error_mul_vectorL1 {d : β„•} + {G H D : Fin d β†’ ℝ} {e : ℝ} + (herr : βˆ€ i, abs (H i - G i) ≀ e) : + finiteDot H D - finiteDot G D ≀ e * vectorL1 D := by + rw [finiteDot, finiteDot, vectorL1, ← Finset.sum_sub_distrib, + Finset.mul_sum] + apply Finset.sum_le_sum + intro i _ + have hpoint : (H i - G i) * D i ≀ e * abs (D i) := by + calc + (H i - G i) * D i ≀ abs ((H i - G i) * D i) := le_abs_self _ + _ = abs (H i - G i) * abs (D i) := abs_mul _ _ + _ ≀ e * abs (D i) := + mul_le_mul_of_nonneg_right (herr i) (abs_nonneg _) + convert hpoint using 1 <;> ring + +/-- Dot product of an epigraph normal with an epigraph displacement. -/ +theorem epigraphNormal_dot_displacement {d : β„•} + (H : Fin d β†’ ℝ) (z q : Fin (d + 1) β†’ ℝ) : + finiteDot (epigraphNormal H) (fun i ↦ z i - q i) = + finiteDot H (fun i ↦ epigraphBase z i - epigraphBase q i) - + (epigraphHeight z - epigraphHeight q) := by + rw [finiteDot, Fin.sum_univ_castSucc] + simp [finiteDot, epigraphBase, epigraphHeight] + ring + +/-- Vector version of the tolerant supporting-hyperplane estimate. -/ +theorem approximateVectorEpigraphCut_valid {d : β„•} + {fY fZ lower t s e Dmax : ℝ} + {G H D : Fin d β†’ ℝ} + (hsupport : fY + finiteDot G D ≀ fZ) + (hlower : lower ≀ fY) + (hgradient : βˆ€ i, abs (H i - G i) ≀ e) + (hD : vectorL1 D ≀ Dmax) + (he : 0 ≀ e) (hepigraph : fZ ≀ s) : + finiteDot H D - (s - t) ≀ t - lower + e * Dmax := by + have hpair := finiteDot_sub_le_error_mul_vectorL1 (D := D) hgradient + have hscale := mul_le_mul_of_nonneg_left hD he + linarith + +/-- Executable lower endpoint and executable approximate gradient. -/ +structure DirectedEpigraphData (d : β„•) where + /-- The executable rational lower-endpoint function evaluated on a base point. -/ + lower : (Fin d β†’ β„š) β†’ β„š + /-- The executable rational approximate-gradient function evaluated on a base point. -/ + gradient : (Fin d β†’ β„š) β†’ Fin d β†’ β„š + +/-- The nonlinear oracle accepts unless the rational lower endpoint exceeds +the query height by more than the full gradient-error budget. -/ +def directedEpigraphOracle {d : β„•} + (data : DirectedEpigraphData d) (e Dmax : β„š) : + RationalCentralOracle (d + 1) := + fun E ↦ + let y := epigraphBase E.center + let t := epigraphHeight E.center + if t + e * Dmax < data.lower y then + .cut (epigraphNormal (data.gradient y)) + else .accept + +theorem directedEpigraphOracle_cut_ne_zero {d : β„•} + (data : DirectedEpigraphData d) (e Dmax : β„š) + (E : RationalEllipsoidState (d + 1)) + {a : Fin (d + 1) β†’ β„š} + (hresponse : directedEpigraphOracle data e Dmax E = .cut a) : + a β‰  0 := by + rw [directedEpigraphOracle] at hresponse + split at hresponse + Β· cases hresponse + exact epigraphNormal_ne_zero _ + Β· contradiction + +/-- A reported nonlinear cut is valid for any exact epigraph point satisfying +the displayed support, directed-value, directed-gradient, and radius bounds. -/ +theorem directedEpigraphOracle_cut_valid {d : β„•} + (data : DirectedEpigraphData d) {e Dmax : β„š} + (he : 0 ≀ e) (E : RationalEllipsoidState (d + 1)) + {a : Fin (d + 1) β†’ β„š} + (hresponse : directedEpigraphOracle data e Dmax E = .cut a) + {fY fZ : ℝ} {G : Fin d β†’ ℝ} {z : Fin (d + 1) β†’ ℝ} + (hsupport : fY + finiteDot G + (fun i ↦ epigraphBase z i - + ((epigraphBase E.center i : β„š) : ℝ)) ≀ fZ) + (hlower : (data.lower (epigraphBase E.center) : ℝ) ≀ fY) + (hgradient : βˆ€ i, abs + ((data.gradient (epigraphBase E.center) i : ℝ) - G i) ≀ (e : ℝ)) + (hD : vectorL1 + (fun i ↦ epigraphBase z i - + ((epigraphBase E.center i : β„š) : ℝ)) ≀ + (Dmax : ℝ)) + (hepigraph : fZ ≀ epigraphHeight z) : + a β‰  0 ∧ finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ z i - rationalCenterReal E i) < 0 := by + rw [directedEpigraphOracle] at hresponse + split at hresponse <;> rename_i hviolation + Β· cases hresponse + refine ⟨epigraphNormal_ne_zero _, ?_⟩ + have hbound := approximateVectorEpigraphCut_valid + (t := ((epigraphHeight E.center : β„š) : ℝ)) + (s := epigraphHeight z) hsupport hlower hgradient hD + (Rat.cast_nonneg.mpr he) hepigraph + have hviolationReal : + ((epigraphHeight E.center : β„š) : ℝ) + (e : ℝ) * (Dmax : ℝ) < + (data.lower (epigraphBase E.center) : ℝ) := by + exact_mod_cast hviolation + have hdot : finiteDot + (fun i ↦ ((epigraphNormal + (data.gradient (epigraphBase E.center)) i : β„š) : ℝ)) + (fun i ↦ z i - rationalCenterReal E i) = + finiteDot + (fun i ↦ (data.gradient (epigraphBase E.center) i : ℝ)) + (fun i ↦ epigraphBase z i - + ((epigraphBase E.center i : β„š) : ℝ)) - + (epigraphHeight z - ((epigraphHeight E.center : β„š) : ℝ)) := by + rw [finiteDot, Fin.sum_univ_castSucc] + simp [finiteDot, epigraphNormal, rationalCenterReal, + epigraphBase, epigraphHeight] + ring + rw [hdot] + norm_num only [Rat.cast_mul] at hbound + linarith + Β· contradiction + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RationalFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/RationalFeasibility.lean new file mode 100644 index 0000000000..ac2c9f02cf --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RationalFeasibility.lean @@ -0,0 +1,552 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RationalEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.AlgorithmicSpec +public import Mathlib.Tactic + +/-! # Rational Feasibility -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# An executable rational central-cut feasibility loop + +This file connects the square-root-free ellipsoid update to an actual finite +algorithm. The oracle either accepts the current rational center or returns a +rational central cut. The generic correctness theorem is deliberately +elementary: a valid cut preserves every target point, and a run long enough to +violate the determinant sandwich cannot be exhausted. +-/ + +/-- A target point belongs to the real ellipsoid represented by a rational +state if it has a real unit-ball preimage. -/ +def RationalEllipsoidContains {d : β„•} + (E : RationalEllipsoidState d) (x : Fin d β†’ ℝ) : Prop := + βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ rationalEllipsoidPoint E y = x + +/-- Real cast of a rational center. -/ +def rationalCenterReal {d : β„•} (E : RationalEllipsoidState d) : Fin d β†’ ℝ := + fun i ↦ (E.center i : ℝ) + +/-- Rational representation of the Euclidean ball of radius `R` centered at +`c`. -/ +def rationalBallEllipsoid (d : β„•) (c : Fin d β†’ β„š) (R : β„š) : + RationalEllipsoidState d where + center := c + basis := fun i j ↦ if i = j then R else 0 + +@[simp] theorem rationalBallEllipsoid_center {d : β„•} + (c : Fin d β†’ β„š) (R : β„š) : + (rationalBallEllipsoid d c R).center = c := rfl + +theorem rationalBallEllipsoid_basis {d : β„•} + (c : Fin d β†’ β„š) (R : β„š) : + (rationalBallEllipsoid d c R).basis = Matrix.diagonal (fun _ ↦ R) := by + ext i j + by_cases hij : i = j <;> simp [rationalBallEllipsoid, hij] + +theorem det_rationalBallEllipsoid {d : β„•} + (c : Fin d β†’ β„š) (R : β„š) : + Matrix.det (rationalBallEllipsoid d c R).basis = R ^ d := by + rw [rationalBallEllipsoid_basis, Matrix.det_diagonal] + simp + +/-- Every point in the ordinary radius-`R` ball has its explicit normalized +coordinate in the rational ball ellipsoid. -/ +theorem rationalBallEllipsoid_contains {d : β„•} + (c : Fin d β†’ β„š) {R : β„š} (hR : 0 < R) {x : Fin d β†’ ℝ} + (hx : finiteNormSq + (fun i ↦ x i - (c i : ℝ)) ≀ (R : ℝ) ^ 2) : + RationalEllipsoidContains (rationalBallEllipsoid d c R) x := by + let y : Fin d β†’ ℝ := fun i ↦ (x i - (c i : ℝ)) / (R : ℝ) + have hRreal : 0 < (R : ℝ) := Rat.cast_pos.mpr hR + have hyform : y = fun i ↦ ((R : ℝ)⁻¹) * (x i - (c i : ℝ)) := by + funext i + simp [y, div_eq_mul_inv, mul_comm] + have hynorm : finiteNormSq y ≀ 1 := by + rw [hyform, finiteNormSq_smul] + have hR2 : 0 < (R : ℝ) ^ 2 := sq_pos_of_pos hRreal + rw [inv_pow] + simpa [div_eq_mul_inv, mul_comm] using! (div_le_one hR2).2 hx + refine ⟨y, hynorm, ?_⟩ + ext i + rw [rationalEllipsoidPoint] + have hRne : (R : ℝ) β‰  0 := hRreal.ne' + change (c i : ℝ) + + βˆ‘ j, ((if i = j then R else 0 : β„š) : ℝ) * + ((x j - (c j : ℝ)) / (R : ℝ)) = x i + simp_rw [show βˆ€ j : Fin d, + ((if i = j then R else 0 : β„š) : ℝ) = + if i = j then (R : ℝ) else 0 by + intro j + by_cases hij : i = j <;> simp [hij]] + simp + field_simp [hRne] + ring + +/-- Binary exponent sufficient to dominate the determinant ratio between a +radius-`R` outer ball and a radius-`r` inner ball. -/ +def rationalBallDyadicExponent (d : β„•) (R r : β„š) : β„• := + d ^ 2 + encodedBitLength β„š R * d + encodedBitLength β„š r * d + 1 + +theorem factorial_le_two_pow_sq (d : β„•) : + d.factorial ≀ 2 ^ (d ^ 2) := by + calc + d.factorial ≀ d ^ d := Nat.factorial_le_pow d + _ ≀ (2 ^ d) ^ d := Nat.pow_le_pow_left d.lt_two_pow_self.le d + _ = 2 ^ (d ^ 2) := by simp [pow_mul, pow_two] + +/-- The dyadic exponent computed from ordinary encodings makes the initial +determinant upper bound strictly smaller than the inner-ball lower bound. -/ +theorem rationalBallDyadicExponent_works {d : β„•} (hd : 0 < d) + {R r : β„š} (hR : 0 < R) (hr : 0 < r) : + (d.factorial : β„š) * R ^ d * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r < r ^ d := by + let LR := encodedBitLength β„š R + let Lr := encodedBitLength β„š r + let A := d ^ 2 + LR * d + let C := Lr * d + have hfac : (d.factorial : β„š) ≀ (2 : β„š) ^ (d ^ 2) := by + exact_mod_cast factorial_le_two_pow_sq d + have hRup : R < (2 : β„š) ^ LR := by + simpa only [LR] using! positive_rational_lt_two_pow_encodedBitLength hR + have hRpow : R ^ d < (2 : β„š) ^ (LR * d) := by + calc + R ^ d < ((2 : β„š) ^ LR) ^ d := + pow_lt_pow_leftβ‚€ hRup hR.le hd.ne' + _ = (2 : β„š) ^ (LR * d) := by rw [← pow_mul] + have hrlow : (1 / 2 : β„š) ^ Lr < r := by + simpa only [Lr] using! dyadic_encodedBitLength_lt_positive_rational hr + have hrpow : ((1 / 2 : β„š) ^ Lr) ^ d < r ^ d := + pow_lt_pow_leftβ‚€ hrlow (by positivity) hd.ne' + have hM : rationalBallDyadicExponent d R r = A + C + 1 := by + simp only [rationalBallDyadicExponent, A, C, LR, Lr] + have hupper : + (d.factorial : β„š) * R ^ d * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r < + (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r := by + have hdyadicPos : 0 < + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r := by positivity + have hfactorialPos : (0 : β„š) < d.factorial := by positivity + have hrightNonneg : (0 : β„š) ≀ (2 : β„š) ^ (LR * d) := by positivity + have hproduct : (d.factorial : β„š) * R ^ d < + (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) := by + exact (mul_lt_mul_of_pos_left hRpow hfactorialPos).trans_le + (mul_le_mul_of_nonneg_right hfac hrightNonneg) + exact mul_lt_mul_of_pos_right + hproduct hdyadicPos + have hcollapse : + (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r = + (1 / 2 : β„š) ^ (C + 1) := by + have htwo : (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) = + (2 : β„š) ^ A := by + rw [← pow_add] + have hcancel : (2 : β„š) ^ A * (1 / 2 : β„š) ^ A = 1 := by + rw [← mul_pow] + norm_num + calc + (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r = + (2 : β„š) ^ A * (1 / 2 : β„š) ^ (A + (C + 1)) := by + rw [htwo, hM] + congr 2 <;> omega + _ = (2 : β„š) ^ A * + ((1 / 2 : β„š) ^ A * (1 / 2 : β„š) ^ (C + 1)) := by + congr 1 + rw [pow_add] + _ = (1 / 2 : β„š) ^ (C + 1) := by + rw [← mul_assoc, hcancel, one_mul] + have hstep : (1 / 2 : β„š) ^ (C + 1) < (1 / 2 : β„š) ^ C := by + rw [pow_succ] + have hpos : 0 < (1 / 2 : β„š) ^ C := by positivity + nlinarith + calc + (d.factorial : β„š) * R ^ d * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r < + (2 : β„š) ^ (d ^ 2) * (2 : β„š) ^ (LR * d) * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r := hupper + _ = (1 / 2 : β„š) ^ (C + 1) := hcollapse + _ < (1 / 2 : β„š) ^ C := hstep + _ = ((1 / 2 : β„š) ^ Lr) ^ d := by rw [← pow_mul] + _ < r ^ d := hrpow + +/-- Real determinant form consumed by the generic feasibility theorem. -/ +theorem rationalBallEllipsoid_dyadic_budget {d : β„•} (hd : 0 < d) + (c : Fin d β†’ β„š) {R r : β„š} (hR : 0 < R) (hr : 0 < r) : + d.factorial * + abs ((Matrix.det (rationalBallEllipsoid d c R).basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ rationalBallDyadicExponent d R r < (r : ℝ) ^ d := by + have hq := rationalBallDyadicExponent_works hd hR hr + rw [det_rationalBallEllipsoid, Rat.cast_pow, + abs_of_pos (pow_pos (Rat.cast_pos.mpr hR) _)] + have hcast : + (((d.factorial : β„š) * R ^ d * + (1 / 2 : β„š) ^ rationalBallDyadicExponent d R r : β„š) : ℝ) < + ((r ^ d : β„š) : ℝ) := (Rat.cast_lt (K := ℝ)).mpr hq + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat, Rat.cast_natCast] at hcast + simpa using! hcast + +/-- Pullback identity for the physical displacement from the ellipsoid +center. -/ +theorem physicalDot_point_sub_center_eq_pulledDot {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) (y : Fin d β†’ ℝ) : + finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ rationalEllipsoidPoint E y i - rationalCenterReal E i) = + finiteDot (fun j ↦ (rationalPulledBackNormal E a j : ℝ)) y := by + rw [finiteDot, finiteDot] + simp only [rationalEllipsoidPoint, rationalCenterReal, add_sub_cancel_left] + simp_rw [Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + rw [cast_rationalPulledBackNormal] + push_cast + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro i _ + ring + +theorem rationalPulledBackNormal_eq_transpose_mulVec {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + rationalPulledBackNormal E a = E.basis.transpose.mulVec a := by + ext j + simp [rationalPulledBackNormal, Matrix.mulVec, dotProduct, + Matrix.transpose_apply] + +/-- A nonsingular stored basis cannot annihilate a nonzero physical normal. -/ +theorem rationalPulledBackNormal_ne_zero_of_det_ne_zero {d : β„•} + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) (ha : a β‰  0) : + rationalPulledBackNormal E a β‰  0 := by + rw [rationalPulledBackNormal_eq_transpose_mulVec] + intro hzero + apply ha + have hdetT : Matrix.det E.basis.transpose β‰  0 := by + simpa [Matrix.det_transpose] using! hdet + have hunit : IsUnit (Matrix.det E.basis.transpose) := + (isUnit_iff_ne_zero).2 hdetT + have hinv := Matrix.nonsing_inv_mul E.basis.transpose hunit + calc + a = Matrix.mulVec (1 : Matrix (Fin d) (Fin d) β„š) a := by simp + _ = Matrix.mulVec (E.basis.transpose⁻¹ * E.basis.transpose) a := by + rw [hinv] + _ = Matrix.mulVec E.basis.transpose⁻¹ + (Matrix.mulVec E.basis.transpose a) := by + rw [Matrix.mulVec_mulVec] + _ = 0 := by rw [hzero]; simp + +theorem det_rationalEllipsoidCentralUpdate_ne_zero {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hpulled : rationalPulledBackNormal E a β‰  0) : + Matrix.det (rationalEllipsoidCentralUpdate E a).basis β‰  0 := by + rw [det_rationalEllipsoidCentralUpdate hd E a hpulled] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + +/-- A valid physical central cut preserves any contained target point. -/ +theorem rationalEllipsoidCentralUpdate_contains_point {d : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) {x : Fin d β†’ ℝ} + (hnonzero : rationalPulledBackNormal E a β‰  0) + (hcontains : RationalEllipsoidContains E x) + (hcut : finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ x i - rationalCenterReal E i) ≀ 0) : + RationalEllipsoidContains (rationalEllipsoidCentralUpdate E a) x := by + obtain ⟨y, hy, hpoint⟩ := hcontains + have hpulled : finiteDot + (fun j ↦ (rationalPulledBackNormal E a j : ℝ)) y ≀ 0 := by + rw [← physicalDot_point_sub_center_eq_pulledDot E a y] + simpa only [hpoint] using! hcut + obtain ⟨y', hy', hpoint'⟩ := + rationalEllipsoidCentralUpdate_contains hd E a hnonzero hy hpulled + exact ⟨y', hy', hpoint'.trans hpoint⟩ + +/-- The two possible responses of the central-cut oracle. -/ +inductive RationalCentralOracleResponse (d : β„•) + | accept + | cut (normal : Fin d β†’ β„š) +deriving DecidableEq + +/-- An oracle is executable data: it reads the complete rational ellipsoid +state and either accepts its center or returns a rational cut normal. -/ +abbrev RationalCentralOracle (d : β„•) := + RationalEllipsoidState d β†’ RationalCentralOracleResponse d + +/-- Semantic validity of every cut returned by an oracle for a target set +`K`. This is a property to be proved for the concrete oracle, not an +assumption built into the algorithm. -/ +def RationalCentralOracleValid {d : β„•} + (K : (Fin d β†’ ℝ) β†’ Prop) (oracle : RationalCentralOracle d) : Prop := + βˆ€ E a, oracle E = .cut a β†’ + a β‰  0 ∧ + βˆ€ x, K x β†’ finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ x i - rationalCenterReal E i) ≀ 0 + +/-- Optional semantic condition on acceptance. Concrete weak oracles use +`Good` for membership in the prescribed enlargement. -/ +def RationalCentralOracleAcceptsOnly {d : β„•} + (Good : (Fin d β†’ β„š) β†’ Prop) (oracle : RationalCentralOracle d) : Prop := + βˆ€ E, oracle E = .accept β†’ Good E.center + +/-- Result of the bounded feasibility loop. -/ +inductive RationalFeasibilityResult (d : β„•) + | accepted (point : Fin d β†’ β„š) + | exhausted (state : RationalEllipsoidState d) + +/-- Execute at most `budget` oracle calls. -/ +def runRationalFeasibility {d : β„•} + (oracle : RationalCentralOracle d) : + β„• β†’ RationalEllipsoidState d β†’ RationalFeasibilityResult d + | 0, E => .exhausted E + | budget + 1, E => + match oracle E with + | .accept => .accepted E.center + | .cut a => + runRationalFeasibility oracle budget + (rationalEllipsoidCentralUpdate E a) + +/-- The exact list of cuts executed before acceptance or exhaustion. -/ +def rationalFeasibilityCuts {d : β„•} + (oracle : RationalCentralOracle d) : + β„• β†’ RationalEllipsoidState d β†’ List (Fin d β†’ β„š) + | 0, _ => [] + | budget + 1, E => + match oracle E with + | .accept => [] + | .cut a => a :: rationalFeasibilityCuts oracle budget + (rationalEllipsoidCentralUpdate E a) + +theorem runRationalFeasibility_acceptsOnly {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} {oracle : RationalCentralOracle d} + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {budget : β„•} {E : RationalEllipsoidState d} {x : Fin d β†’ β„š} + (hrun : runRationalFeasibility oracle budget E = .accepted x) : + Good x := by + induction budget generalizing E with + | zero => simp [runRationalFeasibility] at hrun + | succ budget ih => + rw [runRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· cases hrun + exact haccept E hresponse + Β· exact ih hrun + +/-- If the loop exhausts its budget, every oracle call was a cut. -/ +theorem rationalFeasibilityCuts_length_of_exhausted {d : β„•} + (oracle : RationalCentralOracle d) {budget : β„•} + {E E' : RationalEllipsoidState d} + (hrun : runRationalFeasibility oracle budget E = .exhausted E') : + (rationalFeasibilityCuts oracle budget E).length = budget := by + induction budget generalizing E E' with + | zero => simp [rationalFeasibilityCuts] + | succ budget ih => + rw [runRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· contradiction + Β· rw [rationalFeasibilityCuts, hresponse] + simp only [List.length_cons] + rw [ih hrun] + +/-- The state returned on exhaustion is exactly the iteration of the recorded +cut list. -/ +theorem rationalEllipsoidIterate_cuts_eq_of_exhausted {d : β„•} + (oracle : RationalCentralOracle d) {budget : β„•} + {E E' : RationalEllipsoidState d} + (hrun : runRationalFeasibility oracle budget E = .exhausted E') : + rationalEllipsoidIterate E (rationalFeasibilityCuts oracle budget E) = E' := by + induction budget generalizing E E' with + | zero => simpa [runRationalFeasibility, rationalFeasibilityCuts] using! hrun + | succ budget ih => + rw [runRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· contradiction + Β· rw [rationalFeasibilityCuts, hresponse, + rationalEllipsoidIterate] + exact ih hrun + +/-- Validity of the concrete oracle supplies every nonzero-normal side +condition in an exhausted trace. -/ +theorem rationalFeasibilityCuts_nonzero_of_exhausted {d : β„•} + {K : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (hd : 0 < d) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runRationalFeasibility oracle budget E = .exhausted E') : + RationalEllipsoidCutsNonzero E + (rationalFeasibilityCuts oracle budget E) := by + induction budget generalizing E E' with + | zero => simp [rationalFeasibilityCuts, RationalEllipsoidCutsNonzero] + | succ budget ih => + rw [runRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· contradiction + Β· rw [rationalFeasibilityCuts, hresponse] + change rationalPulledBackNormal E _ β‰  0 ∧ _ + have hpulled := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E _ hdet (hvalid E _ hresponse).1 + exact ⟨hpulled, ih + (det_rationalEllipsoidCentralUpdate_ne_zero hd E _ hdet hpulled) + hrun⟩ + +/-- Every target point contained initially remains contained if a valid loop +exhausts its budget. -/ +theorem runRationalFeasibility_preserves_target_of_exhausted {d : β„•} + (hd : 0 < d) {K : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runRationalFeasibility oracle budget E = .exhausted E') + {x : Fin d β†’ ℝ} (hK : K x) + (hcontains : RationalEllipsoidContains E x) : + RationalEllipsoidContains E' x := by + induction budget generalizing E E' with + | zero => + simp only [runRationalFeasibility] at hrun + cases hrun + exact hcontains + | succ budget ih => + rw [runRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· contradiction + Β· have hcut := hvalid E _ hresponse + have hpulled := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E _ hdet hcut.1 + have hnext := rationalEllipsoidCentralUpdate_contains_point hd E _ + hpulled hcontains (hcut.2 x hK) + exact ih + (det_rationalEllipsoidCentralUpdate_ne_zero hd E _ hdet hpulled) + hrun hnext + +/-- Main generic termination theorem. If the target contains a radius-`r` +coordinate cross and the initial ellipsoid contains those endpoints, the +loop cannot exhaust a dyadic determinant budget. -/ +theorem runRationalFeasibility_not_exhausted_of_inner_cross + {d M : β„•} (hd : 0 < d) + {K : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hdyadic : Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M < r ^ d) + (hKplus : βˆ€ k, K (fun i ↦ z i + if i = k then r else 0)) + (hKminus : βˆ€ k, K (fun i ↦ z i - if i = k then r else 0)) + (hEplus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i + if i = k then r else 0)) + (hEminus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i - if i = k then r else 0)) + (E' : RationalEllipsoidState d) : + runRationalFeasibility oracle (8 * d ^ 3 * M) E β‰  .exhausted E' := by + intro hrun + let cuts := rationalFeasibilityCuts oracle (8 * d ^ 3 * M) E + have hlength : 8 * d ^ 3 * M ≀ cuts.length := by + rw [rationalFeasibilityCuts_length_of_exhausted oracle hrun] + have hstate := rationalEllipsoidIterate_cuts_eq_of_exhausted oracle hrun + have hnonzero := rationalFeasibilityCuts_nonzero_of_exhausted + hvalid hd hdet hrun + have hplus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i + if i = k then r else 0 := by + intro k + have hpreserve := runRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hKplus k) (hEplus k) + rw [← hstate] at hpreserve + exact hpreserve + have hminus : βˆ€ k, βˆƒ y : Fin d β†’ ℝ, finiteNormSq y ≀ 1 ∧ + rationalEllipsoidPoint (rationalEllipsoidIterate E cuts) y = + fun i ↦ z i - if i = k then r else 0 := by + intro k + have hpreserve := runRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hKminus k) (hEminus k) + rw [← hstate] at hpreserve + exact hpreserve + exact rationalEllipsoid_no_long_run hd E cuts hnonzero hlength hr hdyadic + hplus hminus + +/-- Fully explicit specialization to a rational outer ball and a rational +inner radius. Both the iteration count and the initial state are executable +from their displayed rational data. -/ +theorem runRationalFeasibility_ball_not_exhausted + {d : β„•} (hd : 0 < d) + {K : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (c : Fin d β†’ β„š) {R r : β„š} (hR : 0 < R) (hr : 0 < r) + {z : Fin d β†’ ℝ} + (hKplus : βˆ€ k, K (fun i ↦ z i + if i = k then (r : ℝ) else 0)) + (hKminus : βˆ€ k, K (fun i ↦ z i - if i = k then (r : ℝ) else 0)) + (houterPlus : βˆ€ k, finiteNormSq + (fun i ↦ (z i + if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) + (houterMinus : βˆ€ k, finiteNormSq + (fun i ↦ (z i - if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) + (E' : RationalEllipsoidState d) : + runRationalFeasibility oracle + (8 * d ^ 3 * rationalBallDyadicExponent d R r) + (rationalBallEllipsoid d c R) β‰  .exhausted E' := by + apply runRationalFeasibility_not_exhausted_of_inner_cross + hd hvalid (rationalBallEllipsoid d c R) + (by rw [det_rationalBallEllipsoid]; exact pow_ne_zero _ hR.ne') + (hr := Rat.cast_nonneg.mpr hr.le) + (rationalBallEllipsoid_dyadic_budget hd c hR hr) + hKplus hKminus + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterPlus k) + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterMinus k) + +/-- Data-producing form: under the same explicit ball hypotheses, a valid +oracle that accepts only `Good` points returns a concrete rational `Good` +point within the computed budget. -/ +theorem runRationalFeasibility_ball_accepts + {d : β„•} (hd : 0 < d) + {K : (Fin d β†’ ℝ) β†’ Prop} {Good : (Fin d β†’ β„š) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + (c : Fin d β†’ β„š) {R r : β„š} (hR : 0 < R) (hr : 0 < r) + {z : Fin d β†’ ℝ} + (hKplus : βˆ€ k, K (fun i ↦ z i + if i = k then (r : ℝ) else 0)) + (hKminus : βˆ€ k, K (fun i ↦ z i - if i = k then (r : ℝ) else 0)) + (houterPlus : βˆ€ k, finiteNormSq + (fun i ↦ (z i + if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) + (houterMinus : βˆ€ k, finiteNormSq + (fun i ↦ (z i - if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) : + βˆƒ x : Fin d β†’ β„š, + runRationalFeasibility oracle + (8 * d ^ 3 * rationalBallDyadicExponent d R r) + (rationalBallEllipsoid d c R) = .accepted x ∧ Good x := by + let result := runRationalFeasibility oracle + (8 * d ^ 3 * rationalBallDyadicExponent d R r) + (rationalBallEllipsoid d c R) + cases hresult : result with + | accepted x => + refine ⟨x, ?_, ?_⟩ + Β· simpa only [result] using! hresult + Β· exact runRationalFeasibility_acceptsOnly haccept + (by simpa only [result] using! hresult) + | exhausted E' => + exfalso + exact runRationalFeasibility_ball_not_exhausted hd hvalid c hR hr + hKplus hKminus houterPlus houterMinus E' + (by simpa only [result] using! hresult) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RationalLinearOracle.lean b/LeanPool/BeyondBethe/BeyondBethe/RationalLinearOracle.lean new file mode 100644 index 0000000000..f16b536c7a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RationalLinearOracle.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import Mathlib.Tactic + +/-! # Rational Linear Oracle -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Exact rational linear-constraint cuts + +The bounded Bethe epigraph has many rational linear inequalities. This file +implements their scan and proves that every reported violation is a strict +central cut for every point satisfying the inequality. +-/ + +structure RationalHalfspace (d : β„•) where + /-- The nonzero rational normal vector defining the halfspace. -/ + normal : Fin d β†’ β„š + /-- The rational upper offset in the halfspace inequality. -/ + offset : β„š + normal_ne_zero : normal β‰  0 + +/-- Requires the real point's dot product with the cast rational normal to be at most the cast +offset. -/ +def RationalHalfspace.SatisfiedBy {d : β„•} + (h : RationalHalfspace d) (x : Fin d β†’ ℝ) : Prop := + finiteDot (fun i ↦ (h.normal i : ℝ)) x ≀ (h.offset : ℝ) + +/-- Requires the rational point's dot product with the rational normal to be at most the offset. -/ +def RationalHalfspace.satisfiedByRational {d : β„•} + (h : RationalHalfspace d) (x : Fin d β†’ β„š) : Prop := + finiteDot h.normal x ≀ h.offset + +/-- First exactly violated inequality, in list order. -/ +def firstViolatedHalfspace {d : β„•} (x : Fin d β†’ β„š) : + List (RationalHalfspace d) β†’ Option (RationalHalfspace d) + | [] => none + | h :: hs => + if h.offset < finiteDot h.normal x then some h + else firstViolatedHalfspace x hs + +theorem firstViolatedHalfspace_mem {d : β„•} {x : Fin d β†’ β„š} + {hs : List (RationalHalfspace d)} {h : RationalHalfspace d} + (hfind : firstViolatedHalfspace x hs = some h) : h ∈ hs := by + induction hs with + | nil => simp [firstViolatedHalfspace] at hfind + | cons g hs ih => + rw [firstViolatedHalfspace] at hfind + split at hfind + Β· cases hfind + simp + Β· exact List.mem_cons_of_mem _ (ih hfind) + +theorem firstViolatedHalfspace_is_violated {d : β„•} {x : Fin d β†’ β„š} + {hs : List (RationalHalfspace d)} {h : RationalHalfspace d} + (hfind : firstViolatedHalfspace x hs = some h) : + h.offset < finiteDot h.normal x := by + induction hs with + | nil => simp [firstViolatedHalfspace] at hfind + | cons g hs ih => + rw [firstViolatedHalfspace] at hfind + split at hfind <;> rename_i htest + Β· cases hfind + exact htest + Β· exact ih hfind + +theorem firstViolatedHalfspace_eq_none_iff {d : β„•} + (x : Fin d β†’ β„š) (hs : List (RationalHalfspace d)) : + firstViolatedHalfspace x hs = none ↔ + βˆ€ h ∈ hs, h.satisfiedByRational x := by + induction hs with + | nil => simp [firstViolatedHalfspace] + | cons g hs ih => + rw [firstViolatedHalfspace] + split <;> rename_i htest + Β· constructor + Β· intro hnone + contradiction + Β· intro hall + exact ((not_lt_of_ge (hall g (by simp))) htest).elim + Β· rw [ih] + have hg : g.satisfiedByRational x := not_lt.mp htest + simp [hg] + +theorem finiteDot_sub_right_ratCast {d : β„•} + (a : Fin d β†’ β„š) (x : Fin d β†’ ℝ) (c : Fin d β†’ β„š) : + finiteDot (fun i ↦ (a i : ℝ)) (fun i ↦ x i - (c i : ℝ)) = + finiteDot (fun i ↦ (a i : ℝ)) x - + (finiteDot a c : β„š) := by + rw [finiteDot, finiteDot, finiteDot] + simp_rw [mul_sub] + rw [Finset.sum_sub_distrib, Rat.cast_sum] + simp only [Rat.cast_mul] + +/-- Every exact violation gives a strict physical central cut. -/ +theorem firstViolatedHalfspace_valid_cut {d : β„•} + {x : Fin d β†’ β„š} {hs : List (RationalHalfspace d)} + {h : RationalHalfspace d} + (hfind : firstViolatedHalfspace x hs = some h) + {z : Fin d β†’ ℝ} (hz : h.SatisfiedBy z) : + finiteDot (fun i ↦ (h.normal i : ℝ)) + (fun i ↦ z i - (x i : ℝ)) < 0 := by + have hviolateQ := firstViolatedHalfspace_is_violated hfind + have hviolate : (h.offset : ℝ) < (finiteDot h.normal x : β„š) := by + exact_mod_cast hviolateQ + rw [finiteDot_sub_right_ratCast] + exact sub_neg.mpr (hz.trans_lt hviolate) + +/-- Add an exact scan of rational linear inequalities in front of any other +central oracle. -/ +def withRationalLinearConstraints {d : β„•} + (constraints : List (RationalHalfspace d)) + (fallback : RationalCentralOracle d) : RationalCentralOracle d := + fun E ↦ + match firstViolatedHalfspace E.center constraints with + | some h => .cut h.normal + | none => fallback E + +/-- If every target point satisfies every listed inequality and the fallback +oracle is valid, then the combined executable oracle is valid. -/ +theorem withRationalLinearConstraints_valid {d : β„•} + {K : (Fin d β†’ ℝ) β†’ Prop} + (constraints : List (RationalHalfspace d)) + (hconstraints : βˆ€ x, K x β†’ βˆ€ h ∈ constraints, h.SatisfiedBy x) + (fallback : RationalCentralOracle d) + (hfallback : RationalCentralOracleValid K fallback) : + RationalCentralOracleValid K + (withRationalLinearConstraints constraints fallback) := by + intro E a hresponse + rw [withRationalLinearConstraints] at hresponse + split at hresponse <;> rename_i hfind + Β· rename_i h + cases hresponse + refine ⟨h.normal_ne_zero, ?_⟩ + intro x hx + exact (firstViolatedHalfspace_valid_cut hfind + (hconstraints x hx h (firstViolatedHalfspace_mem hfind))).le + Β· exact hfallback E a hresponse + +/-- Conditional form used for logarithmic oracles, whose correctness is only +needed after the exact positivity constraints have passed. -/ +theorem withRationalLinearConstraints_valid_of_passed {d : β„•} + {K : (Fin d β†’ ℝ) β†’ Prop} + (constraints : List (RationalHalfspace d)) + (hconstraints : βˆ€ x, K x β†’ βˆ€ h ∈ constraints, h.SatisfiedBy x) + (fallback : RationalCentralOracle d) + (hfallback : βˆ€ E a, + firstViolatedHalfspace E.center constraints = none β†’ + fallback E = .cut a β†’ + a β‰  0 ∧ βˆ€ x, K x β†’ finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ x i - rationalCenterReal E i) ≀ 0) : + RationalCentralOracleValid K + (withRationalLinearConstraints constraints fallback) := by + intro E a hresponse + rw [withRationalLinearConstraints] at hresponse + split at hresponse <;> rename_i hfind + Β· rename_i h + cases hresponse + refine ⟨h.normal_ne_zero, ?_⟩ + intro x hx + exact (firstViolatedHalfspace_valid_cut hfind + (hconstraints x hx h (firstViolatedHalfspace_mem hfind))).le + Β· exact hfallback E a hfind hresponse + +/-- Acceptance by the combined oracle comes from the fallback after every +linear inequality has passed. -/ +theorem withRationalLinearConstraints_acceptsOnly {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} + (constraints : List (RationalHalfspace d)) + (fallback : RationalCentralOracle d) + (hfallback : RationalCentralOracleAcceptsOnly Good fallback) : + RationalCentralOracleAcceptsOnly Good + (withRationalLinearConstraints constraints fallback) := by + intro E hresponse + rw [withRationalLinearConstraints] at hresponse + split at hresponse + Β· contradiction + Β· exact hfallback E hresponse + +theorem withRationalLinearConstraints_acceptsOnly_of_passed {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} + (constraints : List (RationalHalfspace d)) + (fallback : RationalCentralOracle d) + (hfallback : βˆ€ E, + firstViolatedHalfspace E.center constraints = none β†’ + fallback E = .accept β†’ Good E.center) : + RationalCentralOracleAcceptsOnly Good + (withRationalLinearConstraints constraints fallback) := by + intro E hresponse + rw [withRationalLinearConstraints] at hresponse + split at hresponse <;> rename_i hfind + Β· contradiction + Β· exact hfallback E hfind hresponse + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RawRational.lean b/LeanPool/BeyondBethe/BeyondBethe/RawRational.lean new file mode 100644 index 0000000000..77652c1339 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RawRational.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.BinaryLongDivision +public import Mathlib.Data.Rat.Lemmas +public import Mathlib.Tactic + +/-! # Raw Rational -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Unreduced rational arithmetic + +The machine implementation carries signed numerators and positive +denominators without reducing after every field operation. This avoids hiding +a gcd call inside each use of Lean's canonical `Rat` arithmetic. Reduction is +performed explicitly by `binaryNormalizeRawRat` using the verified division +and Euclid recurrences. +-/ + +/-- A signed fraction with a strictly positive, not necessarily reduced, +denominator. -/ +structure RawRat where + /-- The signed integer numerator of an unreduced rational representation. -/ + num : β„€ + /-- The positive natural-number denominator of an unreduced rational representation. -/ + den : β„• + den_pos : 0 < den +deriving DecidableEq + +namespace RawRat + +/-- The raw rational zero represented by numerator zero and denominator one. -/ +def zero : RawRat := ⟨0, 1, by omega⟩ + +/-- The raw rational one represented by numerator and denominator both one. -/ +def one : RawRat := ⟨1, 1, by omega⟩ + +/-- Mathematical value of an unreduced fraction. -/ +def value (q : RawRat) : β„š := (q.num : β„š) / (q.den : β„š) + +/-- Negates the numerator while preserving the positive denominator. -/ +def neg (q : RawRat) : RawRat := ⟨-q.num, q.den, q.den_pos⟩ + +/-- Adds raw fractions by cross-multiplying numerators and multiplying denominators, without +reduction. -/ +def add (q r : RawRat) : RawRat := + ⟨q.num * r.den + r.num * q.den, q.den * r.den, + Nat.mul_pos q.den_pos r.den_pos⟩ + +/-- Subtracts raw fractions by adding the negation of the second. -/ +def sub (q r : RawRat) : RawRat := add q (neg r) + +/-- Multiplies raw numerators and denominators without reducing the result. -/ +def mul (q r : RawRat) : RawRat := + ⟨q.num * r.num, q.den * r.den, Nat.mul_pos q.den_pos r.den_pos⟩ + +@[simp] theorem value_zero : zero.value = 0 := by + norm_num [zero, value] + +@[simp] theorem value_one : one.value = 1 := by + norm_num [one, value] + +@[simp] theorem value_neg (q : RawRat) : q.neg.value = -q.value := by + rw [neg, value, value] + push_cast + ring + +@[simp] theorem value_add (q r : RawRat) : (q.add r).value = q.value + r.value := by + rw [add, value, value, value] + push_cast + field_simp [Nat.ne_of_gt q.den_pos, Nat.ne_of_gt r.den_pos] + <;> ring + +@[simp] theorem value_sub (q r : RawRat) : (q.sub r).value = q.value - r.value := by + simp [sub, sub_eq_add_neg] + +@[simp] theorem value_mul (q r : RawRat) : (q.mul r).value = q.value * r.value := by + rw [mul, value, value, value] + push_cast + field_simp [Nat.ne_of_gt q.den_pos, Nat.ne_of_gt r.den_pos] + <;> ring + +end RawRat + +/-- Signed division by a positive natural, implemented by dividing the +absolute value and restoring the sign. -/ +def binaryIntDivNat (z : β„€) (d : β„•) : β„€ := + z.sign * ((binaryLongDiv z.natAbs d).1 : β„€) + +theorem binaryIntDivNat_eq_ediv {z : β„€} {d : β„•} + (hd : 0 < d) (hdvd : d ∣ z.natAbs) : + binaryIntDivNat z d = z / (d : β„€) := by + have hquot : (binaryLongDiv z.natAbs d).1 = z.natAbs / d := by + simp [binaryLongDiv_eq_div_mod] + have habs : z.natAbs = (z.natAbs / d) * d := + (Nat.div_mul_cancel hdvd).symm + apply (Int.ediv_eq_of_eq_mul_left (by exact_mod_cast hd.ne') ?_).symm + rw [binaryIntDivNat, hquot] + calc + z = z.sign * (z.natAbs : β„€) := (Int.sign_mul_natAbs z).symm + _ = z.sign * (((z.natAbs / d) * d : β„•) : β„€) := by rw [← habs] + _ = (z.sign * (z.natAbs / d : β„•)) * (d : β„€) := by + push_cast + ring + +/-- Explicit canonicalization of one unreduced fraction. -/ +def binaryNormalizeRawRat (q : RawRat) : β„š := + let g := binaryEuclidBounded q.num.natAbs q.den + have hgcd : g = Nat.gcd q.num.natAbs q.den := + binaryEuclidBounded_eq_gcd _ _ + have hgpos : 0 < g := by + rw [hgcd] + exact Nat.gcd_pos_of_pos_right _ q.den_pos + have hgdvdNum : g ∣ q.num.natAbs := by + rw [hgcd] + exact Nat.gcd_dvd_left _ _ + have hnum : binaryIntDivNat q.num g = q.num / (g : β„€) := + binaryIntDivNat_eq_ediv hgpos hgdvdNum + have hden : (binaryLongDiv q.den g).1 = q.den / g := by + simp [binaryLongDiv_eq_div_mod] + have hgdvdDen : g ∣ q.den := by + rw [hgcd] + exact Nat.gcd_dvd_right _ _ + have hdenPos : 0 < (binaryLongDiv q.den g).1 := by + rw [hden] + exact Nat.div_pos (Nat.le_of_dvd q.den_pos hgdvdDen) hgpos + have hreduced : + (binaryIntDivNat q.num g).natAbs.Coprime + (binaryLongDiv q.den g).1 := by + rw [hnum, hden, hgcd] + exact Rat.normalize.reduced (Nat.ne_of_gt q.den_pos) rfl + Rat.mk' (binaryIntDivNat q.num g) (binaryLongDiv q.den g).1 + (Nat.ne_of_gt hdenPos) hreduced + +theorem binaryNormalizeRawRat_eq_normalize (q : RawRat) : + binaryNormalizeRawRat q = + Rat.normalize q.num q.den (Nat.ne_of_gt q.den_pos) := by + let g := binaryEuclidBounded q.num.natAbs q.den + have hgcd : g = Nat.gcd q.num.natAbs q.den := + binaryEuclidBounded_eq_gcd _ _ + have hgpos : 0 < g := by + rw [hgcd] + exact Nat.gcd_pos_of_pos_right _ q.den_pos + have hgdvdNum : g ∣ q.num.natAbs := by + rw [hgcd] + exact Nat.gcd_dvd_left _ _ + have hnum : binaryIntDivNat q.num g = q.num / (g : β„€) := + binaryIntDivNat_eq_ediv hgpos hgdvdNum + have hden : (binaryLongDiv q.den g).1 = q.den / g := by + simp [binaryLongDiv_eq_div_mod] + rw [binaryNormalizeRawRat, Rat.normalize_eq] + apply Rat.ext + Β· simpa only [g, hgcd] using hnum + Β· simpa only [g, hgcd] using hden + +theorem binaryNormalizeRawRat_eq_value (q : RawRat) : + binaryNormalizeRawRat q = q.value := by + rw [binaryNormalizeRawRat_eq_normalize, + Rat.normalize_eq_mkRat (Nat.ne_of_gt q.den_pos)] + change mkRat q.num q.den = (q.num : β„š) / ((q.den : β„€) : β„š) + rw [Rat.intCast_div_eq_divInt] + simp [Rat.divInt, mkRat, Nat.ne_of_gt q.den_pos] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RawRationalBitBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/RawRationalBitBounds.lean new file mode 100644 index 0000000000..53e179ecd9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RawRationalBitBounds.lean @@ -0,0 +1,464 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RawRational +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import Mathlib.Tactic + +/-! # Raw Rational Bit Bounds -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Bit growth of the explicit unreduced rational arithmetic + +`RawRat` deliberately does not hide normalization inside field operations. +This file proves the elementary size bounds needed by the eventual machine +simulation. The common width counts the larger of the signed numerator's +absolute-value width and the positive denominator's width. +-/ + +/-- Binary width of an unreduced signed fraction. -/ +def rawRatWidth (q : RawRat) : β„• := + max q.num.natAbs.size q.den.size + +theorem rawRat_num_size_le_width (q : RawRat) : + q.num.natAbs.size ≀ rawRatWidth q := + le_max_left _ _ + +theorem rawRat_den_size_le_width (q : RawRat) : + q.den.size ≀ rawRatWidth q := + le_max_right _ _ + +theorem rawRat_num_lt_two_pow_width (q : RawRat) : + q.num.natAbs < 2 ^ rawRatWidth q := by + exact (Nat.lt_size_self q.num.natAbs).trans_le + (Nat.pow_le_pow_right (by decide) (rawRat_num_size_le_width q)) + +theorem rawRat_den_lt_two_pow_width (q : RawRat) : + q.den < 2 ^ rawRatWidth q := by + exact (Nat.lt_size_self q.den).trans_le + (Nat.pow_le_pow_right (by decide) (rawRat_den_size_le_width q)) + +theorem rawRatWidth_zero : rawRatWidth RawRat.zero = 1 := by + norm_num [rawRatWidth, RawRat.zero] + +theorem rawRatWidth_one : rawRatWidth RawRat.one = 1 := by + norm_num [rawRatWidth, RawRat.one] + +theorem rawRatWidth_neg (q : RawRat) : + rawRatWidth q.neg = rawRatWidth q := by + simp [rawRatWidth, RawRat.neg] + +namespace RawRat + +/-- Total reciprocal in the unreduced representation. The zero branch +agrees with the field convention `0⁻¹ = 0`; nonzero branches swap the +absolute numerator with the denominator and retain the sign. -/ +def inv (q : RawRat) : RawRat := + match q.num with + | .ofNat 0 => zero + | .ofNat (n + 1) => ⟨q.den, n + 1, by omega⟩ + | .negSucc n => ⟨-(q.den : β„€), n + 1, by omega⟩ + +@[simp] theorem value_inv (q : RawRat) : q.inv.value = q.value⁻¹ := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat n => + cases n with + | zero => simp [inv, value, zero] + | succ n => + simp only [inv, value, Int.cast_ofNat, Nat.cast_add, Nat.cast_one] + field_simp + <;> norm_num + <;> ring + | negSucc n => + simp only [inv, value, Int.cast_negSucc, Nat.cast_add, Nat.cast_one, + Int.cast_neg, Int.cast_ofNat, inv_div] + field_simp + <;> norm_num + <;> ring + +/-- Divides raw fractions by multiplying by the totalized reciprocal of the divisor. -/ +def div (q r : RawRat) : RawRat := q.mul r.inv + +@[simp] theorem value_div (q r : RawRat) : + (q.div r).value = q.value / r.value := by + simp [div, div_eq_mul_inv] + +end RawRat + +theorem rawRatWidth_inv_le (q : RawRat) : + rawRatWidth q.inv ≀ rawRatWidth q := by + rcases q with ⟨num, den, hden⟩ + cases num with + | ofNat n => + cases n with + | zero => + simp only [RawRat.inv, rawRatWidth_zero] + have hsize : 1 ≀ den.size := by + exact Nat.size_pos.mpr hden + exact hsize.trans (le_max_right _ _) + | succ n => + change max den.size (n + 1).size ≀ + max (Int.ofNat (n + 1)).natAbs.size den.size + rw [Int.natAbs_ofNat', max_comm] + | negSucc n => + change max (-(den : β„€)).natAbs.size (n + 1).size ≀ + max (Int.negSucc n).natAbs.size den.size + simp only [Int.natAbs_neg, Int.natAbs_natCast, Int.natAbs_negSucc] + rw [max_comm] + +private theorem mul_lt_two_pow_add + {a b u v : β„•} (ha : a < 2 ^ u) (hb : b < 2 ^ v) : + a * b < 2 ^ (u + v) := by + rw [pow_add] + nlinarith [show 0 < 2 ^ u by positivity, + show 0 < 2 ^ v by positivity] + +private theorem add_of_two_lt_two_pow_lt + {a b k : β„•} (ha : a < 2 ^ k) (hb : b < 2 ^ k) : + a + b < 2 ^ (k + 1) := by + rw [pow_succ] + omega + +/-- Multiplication adds the operand widths. -/ +theorem rawRatWidth_mul_le (q r : RawRat) : + rawRatWidth (q.mul r) ≀ rawRatWidth q + rawRatWidth r := by + apply max_le + Β· rw [RawRat.mul, Int.natAbs_mul, Nat.size_le] + exact mul_lt_two_pow_add + (rawRat_num_lt_two_pow_width q) + (rawRat_num_lt_two_pow_width r) + Β· rw [RawRat.mul, Nat.size_le] + exact mul_lt_two_pow_add + (rawRat_den_lt_two_pow_width q) + (rawRat_den_lt_two_pow_width r) + +theorem rawRatWidth_div_le (q r : RawRat) : + rawRatWidth (q.div r) ≀ rawRatWidth q + rawRatWidth r := by + exact (rawRatWidth_mul_le q r.inv).trans + (Nat.add_le_add_left (rawRatWidth_inv_le r) _) + +/-- Addition costs at most one carry bit beyond the sum of the operand +widths. This includes the cross-multiplied denominator representation. -/ +theorem rawRatWidth_add_le (q r : RawRat) : + rawRatWidth (q.add r) ≀ rawRatWidth q + rawRatWidth r + 1 := by + apply max_le + Β· rw [RawRat.add, Nat.size_le] + apply lt_of_le_of_lt (Int.natAbs_add_le _ _) + rw [Int.natAbs_mul, Int.natAbs_mul] + apply add_of_two_lt_two_pow_lt + Β· exact mul_lt_two_pow_add + (rawRat_num_lt_two_pow_width q) + (rawRat_den_lt_two_pow_width r) + Β· have h := mul_lt_two_pow_add + (rawRat_num_lt_two_pow_width r) + (rawRat_den_lt_two_pow_width q) + simpa only [Nat.add_comm] using! h + Β· rw [RawRat.add, Nat.size_le] + exact (mul_lt_two_pow_add + (rawRat_den_lt_two_pow_width q) + (rawRat_den_lt_two_pow_width r)).trans_le + (Nat.pow_le_pow_right (by decide) (by omega)) + +theorem rawRatWidth_sub_le (q r : RawRat) : + rawRatWidth (q.sub r) ≀ rawRatWidth q + rawRatWidth r + 1 := by + simpa only [RawRat.sub, rawRatWidth_neg] using! rawRatWidth_add_le q r.neg + +theorem rawRat_value_den_dvd (q : RawRat) : q.value.den ∣ q.den := by + have hz : (((q.value.den : β„•) : β„€) ∣ (q.den : β„€)) := by + rw [RawRat.value, + show ((q.den : β„•) : β„š) = ((q.den : β„€) : β„š) by norm_num, + Rat.intCast_div_eq_divInt] + exact Rat.den_dvd q.num (q.den : β„€) + exact_mod_cast hz + +theorem rawRat_value_den_le (q : RawRat) : q.value.den ≀ q.den := + Nat.le_of_dvd q.den_pos (rawRat_value_den_dvd q) + +theorem rawRat_value_abs_le_two_pow_width (q : RawRat) : + abs q.value ≀ (2 : β„š) ^ rawRatWidth q := by + have hden : (1 : β„š) ≀ q.den := by + exact_mod_cast q.den_pos + have hnum : (q.num.natAbs : β„š) ≀ (2 : β„š) ^ rawRatWidth q := by + exact_mod_cast (rawRat_num_lt_two_pow_width q).le + have habsnum : abs (q.num : β„š) = (q.num.natAbs : β„š) := by + rw [← Int.cast_abs] + norm_num + rw [RawRat.value, abs_div, habsnum, abs_of_nonneg (by positivity)] + exact (div_le_self (by positivity) hden).trans hnum + +/-- Canonicalization cannot create a large denominator and its exact +canonical `DataEncode` output has linear length in the unreduced width. -/ +theorem binaryNormalizeRawRat_encodedBitLength_le (q : RawRat) : + encodedBitLength β„š (binaryNormalizeRawRat q) ≀ + 20 + 12 * rawRatWidth q := by + rw [binaryNormalizeRawRat_eq_value] + have hden : q.value.den ≀ 2 ^ rawRatWidth q := + (rawRat_value_den_le q).trans (rawRat_den_lt_two_pow_width q).le + have h := rational_encodedBitLength_le_of_abs_and_den_bounds + (rawRat_value_abs_le_two_pow_width q) hden + omega + +namespace RawRat + +/-- Repeated multiplication in the unreduced representation. This is a +semantic reference for the fixed-budget machine loop; normalization can be +postponed until the end. -/ +def pow (q : RawRat) : β„• β†’ RawRat + | 0 => one + | k + 1 => (pow q k).mul q + +@[simp] theorem value_pow (q : RawRat) : βˆ€ k : β„•, + (q.pow k).value = q.value ^ k := by + intro k + induction k with + | zero => simp [pow] + | succ k ih => simp [pow, ih, pow_succ] + +/-- A length-`k` product has width at most the sum of the operand widths, +apart from the one-bit representation of the initial value `1`. -/ +theorem width_pow_le (q : RawRat) : βˆ€ k : β„•, + rawRatWidth (q.pow k) ≀ 1 + k * rawRatWidth q := by + intro k + induction k with + | zero => simp [pow, rawRatWidth_one] + | succ k ih => + rw [pow] + exact (rawRatWidth_mul_le _ _).trans (by + rw [Nat.succ_mul] + omega) + +/-- Unreduced left fold for a finite sum. -/ +def sum : List RawRat β†’ RawRat + | [] => zero + | q :: qs => q.add (sum qs) + +@[simp] theorem value_sum : βˆ€ qs : List RawRat, + (sum qs).value = (qs.map value).sum := by + intro qs + induction qs with + | nil => simp [sum] + | cons q qs ih => simp [sum, ih] + +theorem width_sum_le : βˆ€ qs : List RawRat, + rawRatWidth (sum qs) ≀ + 1 + (qs.map fun q ↦ rawRatWidth q + 1).sum := by + intro qs + induction qs with + | nil => simp [sum, rawRatWidth_zero] + | cons q qs ih => + rw [sum] + exact (rawRatWidth_add_le _ _).trans (by + simp only [List.map_cons, List.sum_cons] + omega) + +/-- Unreduced left fold for a finite product. -/ +def product : List RawRat β†’ RawRat + | [] => one + | q :: qs => q.mul (product qs) + +@[simp] theorem value_product : βˆ€ qs : List RawRat, + (product qs).value = (qs.map value).prod := by + intro qs + induction qs with + | nil => simp [product] + | cons q qs ih => simp [product, ih] + +theorem width_product_le : βˆ€ qs : List RawRat, + rawRatWidth (product qs) ≀ + 1 + (qs.map rawRatWidth).sum := by + intro qs + induction qs with + | nil => simp [product, rawRatWidth_one] + | cons q qs ih => + rw [product] + exact (rawRatWidth_mul_le _ _).trans (by + simp only [List.map_cons, List.sum_cons] + omega) + +end RawRat + +/-- Canonical rationals embed into `RawRat` without changing their value. -/ +def rawRatOfRat (q : β„š) : RawRat := + ⟨q.num, q.den, q.den_pos⟩ + +@[simp] theorem rawRatOfRat_value (q : β„š) : + (rawRatOfRat q).value = q := by + simpa only [rawRatOfRat, RawRat.value] using! q.num_div_den + +/-- The raw width of a canonical input is bounded by its exact project +encoding length. -/ +theorem rawRatOfRat_width_le_encodedBitLength (q : β„š) : + rawRatWidth (rawRatOfRat q) ≀ encodedBitLength β„š q := by + apply max_le + Β· exact (nat_size_le_encodedBitLength q.num.natAbs).trans + ((natAbs_encodedBitLength_lt_integer q.num).le.trans + (numerator_encodedBitLength_lt_rational q).le) + Β· exact (nat_size_le_encodedBitLength q.den).trans + (denominator_encodedBitLength_lt_rational q).le + +/-- Fully explicit addition: cross-multiply in `RawRat`, run verified bounded +Euclid, and return the canonical rational. -/ +def binaryRatAdd (q r : β„š) : β„š := + binaryNormalizeRawRat ((rawRatOfRat q).add (rawRatOfRat r)) + +theorem binaryRatAdd_eq_add (q r : β„š) : binaryRatAdd q r = q + r := by + simp [binaryRatAdd, binaryNormalizeRawRat_eq_value] + +/-- Subtracts rational inputs through raw arithmetic and binary normalization. -/ +def binaryRatSub (q r : β„š) : β„š := + binaryNormalizeRawRat ((rawRatOfRat q).sub (rawRatOfRat r)) + +theorem binaryRatSub_eq_sub (q r : β„š) : binaryRatSub q r = q - r := by + simp [binaryRatSub, binaryNormalizeRawRat_eq_value] + +/-- Negates a rational input through raw arithmetic and binary normalization. -/ +def binaryRatNeg (q : β„š) : β„š := + binaryNormalizeRawRat (rawRatOfRat q).neg + +theorem binaryRatNeg_eq_neg (q : β„š) : binaryRatNeg q = -q := by + simp [binaryRatNeg, binaryNormalizeRawRat_eq_value] + +/-- Multiplies rational inputs through raw arithmetic and binary normalization. -/ +def binaryRatMul (q r : β„š) : β„š := + binaryNormalizeRawRat ((rawRatOfRat q).mul (rawRatOfRat r)) + +theorem binaryRatMul_eq_mul (q r : β„š) : binaryRatMul q r = q * r := by + simp [binaryRatMul, binaryNormalizeRawRat_eq_value] + +/-- Computes a rational input's totalized reciprocal through raw arithmetic and binary +normalization. -/ +def binaryRatInv (q : β„š) : β„š := + binaryNormalizeRawRat (rawRatOfRat q).inv + +theorem binaryRatInv_eq_inv (q : β„š) : binaryRatInv q = q⁻¹ := by + simp [binaryRatInv, binaryNormalizeRawRat_eq_value] + +/-- Divides rational inputs through raw arithmetic and binary normalization. -/ +def binaryRatDiv (q r : β„š) : β„š := + binaryNormalizeRawRat ((rawRatOfRat q).div (rawRatOfRat r)) + +theorem binaryRatDiv_eq_div (q r : β„š) : binaryRatDiv q r = q / r := by + simp [binaryRatDiv, binaryNormalizeRawRat_eq_value] + +/-- Raises a rational input to a natural power in raw arithmetic and then normalizes it. -/ +def binaryRatPow (q : β„š) (k : β„•) : β„š := + binaryNormalizeRawRat ((rawRatOfRat q).pow k) + +theorem binaryRatPow_eq_pow (q : β„š) (k : β„•) : + binaryRatPow q k = q ^ k := by + simp [binaryRatPow, binaryNormalizeRawRat_eq_value] + +theorem binaryRatAdd_encodedBitLength_le (q r : β„š) : + encodedBitLength β„š (binaryRatAdd q r) ≀ + 32 + 12 * (encodedBitLength β„š q + encodedBitLength β„š r) := by + have hw := rawRatWidth_add_le (rawRatOfRat q) (rawRatOfRat r) + have hq := rawRatOfRat_width_le_encodedBitLength q + have hr := rawRatOfRat_width_le_encodedBitLength r + have hn := binaryNormalizeRawRat_encodedBitLength_le + ((rawRatOfRat q).add (rawRatOfRat r)) + change encodedBitLength β„š + (binaryNormalizeRawRat ((rawRatOfRat q).add (rawRatOfRat r))) ≀ _ + calc + _ ≀ 20 + 12 * rawRatWidth + ((rawRatOfRat q).add (rawRatOfRat r)) := hn + _ ≀ 20 + 12 * (encodedBitLength β„š q + + encodedBitLength β„š r + 1) := by omega + _ = 32 + 12 * (encodedBitLength β„š q + + encodedBitLength β„š r) := by ring + +theorem binaryRatSub_encodedBitLength_le (q r : β„š) : + encodedBitLength β„š (binaryRatSub q r) ≀ + 32 + 12 * (encodedBitLength β„š q + encodedBitLength β„š r) := by + have hw := rawRatWidth_sub_le (rawRatOfRat q) (rawRatOfRat r) + have hq := rawRatOfRat_width_le_encodedBitLength q + have hr := rawRatOfRat_width_le_encodedBitLength r + have hn := binaryNormalizeRawRat_encodedBitLength_le + ((rawRatOfRat q).sub (rawRatOfRat r)) + change encodedBitLength β„š + (binaryNormalizeRawRat ((rawRatOfRat q).sub (rawRatOfRat r))) ≀ _ + calc + _ ≀ 20 + 12 * rawRatWidth + ((rawRatOfRat q).sub (rawRatOfRat r)) := hn + _ ≀ 20 + 12 * (encodedBitLength β„š q + + encodedBitLength β„š r + 1) := by omega + _ = 32 + 12 * (encodedBitLength β„š q + + encodedBitLength β„š r) := by ring + +theorem binaryRatNeg_encodedBitLength_le (q : β„š) : + encodedBitLength β„š (binaryRatNeg q) ≀ + 20 + 12 * encodedBitLength β„š q := by + have hw := rawRatOfRat_width_le_encodedBitLength q + have hn := binaryNormalizeRawRat_encodedBitLength_le + (rawRatOfRat q).neg + change encodedBitLength β„š + (binaryNormalizeRawRat (rawRatOfRat q).neg) ≀ _ + rw [rawRatWidth_neg] at hn + omega + +theorem binaryRatMul_encodedBitLength_le (q r : β„š) : + encodedBitLength β„š (binaryRatMul q r) ≀ + 20 + 12 * (encodedBitLength β„š q + encodedBitLength β„š r) := by + have hw := rawRatWidth_mul_le (rawRatOfRat q) (rawRatOfRat r) + have hq := rawRatOfRat_width_le_encodedBitLength q + have hr := rawRatOfRat_width_le_encodedBitLength r + have hn := binaryNormalizeRawRat_encodedBitLength_le + ((rawRatOfRat q).mul (rawRatOfRat r)) + change encodedBitLength β„š + (binaryNormalizeRawRat ((rawRatOfRat q).mul (rawRatOfRat r))) ≀ _ + calc + _ ≀ 20 + 12 * rawRatWidth + ((rawRatOfRat q).mul (rawRatOfRat r)) := hn + _ ≀ 20 + 12 * (encodedBitLength β„š q + + encodedBitLength β„š r) := by omega + +theorem binaryRatInv_encodedBitLength_le (q : β„š) : + encodedBitLength β„š (binaryRatInv q) ≀ + 20 + 12 * encodedBitLength β„š q := by + have hw := rawRatWidth_inv_le (rawRatOfRat q) + have hq := rawRatOfRat_width_le_encodedBitLength q + have hn := binaryNormalizeRawRat_encodedBitLength_le + (rawRatOfRat q).inv + change encodedBitLength β„š + (binaryNormalizeRawRat (rawRatOfRat q).inv) ≀ _ + omega + +theorem binaryRatDiv_encodedBitLength_le (q r : β„š) : + encodedBitLength β„š (binaryRatDiv q r) ≀ + 20 + 12 * (encodedBitLength β„š q + encodedBitLength β„š r) := by + have hw := rawRatWidth_div_le (rawRatOfRat q) (rawRatOfRat r) + have hq := rawRatOfRat_width_le_encodedBitLength q + have hr := rawRatOfRat_width_le_encodedBitLength r + have hn := binaryNormalizeRawRat_encodedBitLength_le + ((rawRatOfRat q).div (rawRatOfRat r)) + change encodedBitLength β„š + (binaryNormalizeRawRat ((rawRatOfRat q).div (rawRatOfRat r))) ≀ _ + omega + +theorem binaryRatPow_encodedBitLength_le (q : β„š) (k : β„•) : + encodedBitLength β„š (binaryRatPow q k) ≀ + 32 + 12 * k * encodedBitLength β„š q := by + have hw := RawRat.width_pow_le (rawRatOfRat q) k + have hq := rawRatOfRat_width_le_encodedBitLength q + have hn := binaryNormalizeRawRat_encodedBitLength_le + ((rawRatOfRat q).pow k) + have hw' : rawRatWidth ((rawRatOfRat q).pow k) ≀ + 1 + k * encodedBitLength β„š q := + hw.trans (Nat.add_le_add_left (Nat.mul_le_mul_left k hq) 1) + change encodedBitLength β„š + (binaryNormalizeRawRat ((rawRatOfRat q).pow k)) ≀ _ + calc + _ ≀ 20 + 12 * rawRatWidth ((rawRatOfRat q).pow k) := hn + _ ≀ 20 + 12 * (1 + k * encodedBitLength β„š q) := by omega + _ = 32 + 12 * k * encodedBitLength β„š q := by ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RobustCycle.lean b/LeanPool/BeyondBethe/BeyondBethe/RobustCycle.lean new file mode 100644 index 0000000000..1f96165c8f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RobustCycle.lean @@ -0,0 +1,794 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.GoodRowScore +public import LeanPool.BeyondBethe.BeyondBethe.Sequential +public import LeanPool.BeyondBethe.BeyondBethe.Slack + +/-! # Robust Cycle -/ + +@[expose] public section + +namespace BeyondBethe + +/-- Inversion as an equivalence on permutations. The Gibbs layer represents +an assignment as `column -> row`, whereas the cycle layer represents it as +`row -> column`; this equivalence makes the conversion explicit. -/ +def permInverseEquiv {Ξ± : Type*} : Equiv.Perm Ξ± ≃ Equiv.Perm Ξ± where + toFun Οƒ := Οƒ.symm + invFun Οƒ := Οƒ.symm + left_inv Οƒ := by simp + right_inv Οƒ := by simp + +/-- The row-oriented version of a mass on Mathlib's column-oriented +permutations. -/ +noncomputable def rowOrientedMass + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (ΞΌ : Equiv.Perm Ξ± β†’ ℝ) : Equiv.Perm Ξ± β†’ ℝ := + pushforwardMass ΞΌ permInverseEquiv + +theorem rowOrientedMass_apply + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (ΞΌ : Equiv.Perm Ξ± β†’ ℝ) (Οƒ : Equiv.Perm Ξ±) : + rowOrientedMass ΞΌ Οƒ = ΞΌ Οƒ.symm := by + exact pushforwardMass_equiv_apply ΞΌ permInverseEquiv Οƒ + +theorem rowOrientedMass_isProbabilityVector + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + {ΞΌ : Equiv.Perm Ξ± β†’ ℝ} (hΞΌ : IsProbabilityVector ΞΌ) : + IsProbabilityVector (rowOrientedMass ΞΌ) := + pushforwardMass_isProbabilityVector ΞΌ hΞΌ permInverseEquiv + +theorem shannonEntropy_rowOrientedMass + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (ΞΌ : Equiv.Perm Ξ± β†’ ℝ) : + shannonEntropy (rowOrientedMass ΞΌ) = shannonEntropy ΞΌ := + shannonEntropy_pushforward_equiv ΞΌ permInverseEquiv + +/-- Evaluation of the row-oriented assignment has exactly the prescribed +row marginal. -/ +theorem rowOriented_evaluation_mass + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) (i j : Fin n) : + pushforwardMass (rowOrientedMass ΞΌ) (fun Οƒ ↦ Οƒ i) j = P i j := by + classical + rw [rowOrientedMass, pushforwardMass_comp] + rw [hmarg i j] + unfold pushforwardMass + apply Finset.sum_congr rfl + intro Οƒ _ + have heq : (permInverseEquiv Οƒ) i = j ↔ Οƒ j = i := by + change Οƒ.symm i = j ↔ Οƒ j = i + constructor + Β· intro h + simpa using (congrArg Οƒ h).symm + Β· intro h + simpa using (congrArg Οƒ.symm h).symm + by_cases h : Οƒ j = i + Β· simp [h, heq.mpr h] + Β· have hs : Β¬(permInverseEquiv Οƒ) i = j := fun hs ↦ h (heq.mp hs) + simp [h, hs] + +/-- Relabel the two core outcomes by `none` and retain every outside outcome +as `some j`. -/ +def coreOutcome {Ξ± : Type*} [DecidableEq Ξ±] (a b j : Ξ±) : Option Ξ± := + if j = a ∨ j = b then none else some j + +theorem twoMatchingEncoding_apply + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (f g Οƒ : Equiv.Perm Ξ±) (i : Ξ±) : + twoMatchingEncoding f g Οƒ i = coreOutcome (f i) (g i) (Οƒ i) := by + by_cases h : UsesCoreEdge f g Οƒ i + Β· have h' : Οƒ i = f i ∨ Οƒ i = g i := h + simp [twoMatchingEncoding, coreOutcome, h, h'] + Β· have h' : Β¬(Οƒ i = f i ∨ Οƒ i = g i) := h + simp [twoMatchingEncoding, coreOutcome, h, h'] + +theorem coordinateEncoding_mass + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (f g : Equiv.Perm (Fin n)) (i : Fin n) : + pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i) = + pushforwardMass (P i) (coreOutcome (f i) (g i)) := by + funext y + have hfun : (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i) = + coreOutcome (f i) (g i) ∘ (fun Οƒ ↦ Οƒ i) := by + funext Οƒ + exact twoMatchingEncoding_apply f g Οƒ i + rw [hfun, ← pushforwardMass_comp] + congr 1 + funext j + exact rowOriented_evaluation_mass hmarg i j + +theorem coreOutcome_none_mass + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (p : Ξ± β†’ ℝ) {a b : Ξ±} (hab : a β‰  b) : + pushforwardMass p (coreOutcome a b) none = p a + p b := by + unfold pushforwardMass + calc + (βˆ‘ j, if coreOutcome a b j = none then p j else 0) = + βˆ‘ j, if j = a ∨ j = b then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases h : j = a ∨ j = b <;> simp [coreOutcome, h] + _ = p a + p b := by + calc + (βˆ‘ j, if j = a ∨ j = b then p j else 0) = + βˆ‘ j, ((if j = a then p j else 0) + + (if j = b then p j else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp [hab] + Β· by_cases hjb : j = b <;> simp [hja, hjb, hab, Ne.symm hab] + _ = p a + p b := by rw [Finset.sum_add_distrib]; simp + +theorem coreOutcome_some_mass + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (p : Ξ± β†’ ℝ) (a b j : Ξ±) : + pushforwardMass p (coreOutcome a b) (some j) = + if a β‰  j ∧ b β‰  j then p j else 0 := by + unfold pushforwardMass + by_cases hj : a β‰  j ∧ b β‰  j + Β· rw [ite_eq_left hj, Finset.sum_eq_single j] + Β· simp [coreOutcome, hj.1.symm, hj.2.symm] + Β· intro k _ hkj + have hne : coreOutcome a b k β‰  some j := by + by_cases hk : k = a ∨ k = b + Β· simp [coreOutcome, hk] + Β· simp [coreOutcome, hk, hkj] + simp [hne] + Β· simp + Β· rw [ite_eq_right hj] + apply Finset.sum_eq_zero + intro k _ + by_cases hk : k = a ∨ k = b + Β· simp [coreOutcome, hk] + Β· have hkj : k β‰  j := by + intro h + subst k + exact hj ⟨fun h ↦ hk (Or.inl h.symm), fun h ↦ hk (Or.inr h.symm)⟩ + simp [coreOutcome, hk, hkj] + +/-- The rowwise encoding entropy is exactly the entropy obtained by merging +the two distinct core atoms. -/ +theorem coreOutcome_entropy_eq_twoCoreCoarsenedEntropy + {n : β„•} (p : Fin n β†’ ℝ) {a b : Fin n} (hab : a β‰  b) : + shannonEntropy (pushforwardMass p (coreOutcome a b)) = + twoCoreCoarsenedEntropy p a b := by + rw [shannonEntropy, Fintype.sum_option, coreOutcome_none_mass p hab] + simp_rw [coreOutcome_some_mass] + unfold twoCoreCoarsenedEntropy + congr 1 + apply Finset.sum_congr rfl + intro j _ + split_ifs <;> simp + +theorem coreOutcome_none_mass_same + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (p : Ξ± β†’ ℝ) (a : Ξ±) : + pushforwardMass p (coreOutcome a a) none = p a := by + unfold pushforwardMass + rw [Finset.sum_eq_single a] + Β· simp [coreOutcome] + Β· intro j _ hja + simp [coreOutcome, hja] + Β· simp + +theorem coreOutcome_entropy_same + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (p : Ξ± β†’ ℝ) (a : Ξ±) : + shannonEntropy (pushforwardMass p (coreOutcome a a)) = + shannonEntropy p := by + rw [shannonEntropy, Fintype.sum_option, coreOutcome_none_mass_same p a] + simp_rw [coreOutcome_some_mass] + have hout := sum_ite_ne_eq_sum_sub + (fun j ↦ Real.negMulLog (p j)) a + have hsimp : + (βˆ‘ x, Real.negMulLog (if a β‰  x ∧ a β‰  x then p x else 0)) = + βˆ‘ x, if x β‰  a then Real.negMulLog (p x) else 0 := by + apply Finset.sum_congr rfl + intro x _ + by_cases hxa : x = a + Β· subst x + simp + Β· have hax : a β‰  x := Ne.symm hxa + simp [hxa, hax] + rw [shannonEntropy] + rw [hsimp, hout] + ring + +theorem coreOutcome_entropy_le + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + (a b : Fin n) : + shannonEntropy (pushforwardMass p (coreOutcome a b)) ≀ + shannonEntropy p := by + by_cases hab : a = b + Β· subst b + exact (coreOutcome_entropy_same p a).le + Β· rw [coreOutcome_entropy_eq_twoCoreCoarsenedEntropy p hab] + have hu := hp.positive a + have hv := hp.positive b + have hsum : 0 < p a + p b := add_pos hu hv + have hr0 : 0 ≀ p a / (p a + p b) := div_nonneg hu.le hsum.le + have hr1 : p a / (p a + p b) ≀ 1 := + (div_le_one hsum).2 (le_add_of_nonneg_right hv.le) + have hbin : 0 ≀ binaryEntropy (p a / (p a + p b)) := by + rw [binaryEntropy_eq_realBinEntropy] + exact Real.binEntropy_nonneg hr0 hr1 + have hloss := entropy_loss_merge_two hu hv + have hent := entropy_sub_twoCoreCoarsenedEntropy p hab + rw [hloss] at hent + nlinarith + +theorem coreOutcome_comm + {Ξ± : Type*} [DecidableEq Ξ±] (a b : Ξ±) : + coreOutcome a b = coreOutcome b a := by + funext j + by_cases h : j = a ∨ j = b + Β· have h' : j = b ∨ j = a := h.elim Or.inr Or.inl + simp [coreOutcome, h, h'] + Β· have h' : Β¬(j = b ∨ j = a) := by + intro h' + exact h (h'.elim Or.inr Or.inl) + simp [coreOutcome, h, h'] + +theorem coreOutcome_eq_of_pair_membership + {Ξ± : Type*} [DecidableEq Ξ±] + {a b c d : Ξ±} (hab : a β‰  b) + (ha : a = c ∨ a = d) (hb : b = c ∨ b = d) : + coreOutcome c d = coreOutcome a b := by + rcases ha with ha | ha <;> rcases hb with hb | hb + Β· exact False.elim (hab (ha.trans hb.symm)) + Β· rw [ha, hb] + Β· rw [ha, hb, coreOutcome_comm] + Β· exact False.elim (hab (ha.trans hb.symm)) + +/-- The exact `LΒΉ` witness of a good row supplies two heavy coordinates. -/ +theorem goodRow_witness_mem_heavyCoordinates + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {Ξ· : ℝ} {a b : Fin n} (hab : a β‰  b) + (hdist : halfHalfL1Distance p a b ≀ Ξ·) : + a ∈ heavyCoordinates Ξ· p ∧ b ∈ heavyCoordinates Ξ· p := by + have hqβ‚€ : 0 ≀ 1 - p a - p b := by + have hsum : 0 ≀ + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_nonneg + intro j _ + split_ifs + Β· exact hp.nonnegative j + Β· exact le_rfl + rw [sum_away_from_two hp hab] at hsum + exact hsum + rw [halfHalfL1Distance_eq hp hab] at hdist + have haΞ· : |p a - 1 / 2| ≀ Ξ· := by + linarith [abs_nonneg (p b - 1 / 2)] + have hbΞ· : |p b - 1 / 2| ≀ Ξ· := by + linarith [abs_nonneg (p a - 1 / 2)] + have ha : 1 / 2 - Ξ· ≀ p a := by + linarith [neg_abs_le (p a - 1 / 2)] + have hb : 1 / 2 - Ξ· ≀ p b := by + linarith [neg_abs_le (p b - 1 / 2)] + simpa [heavyCoordinates] using And.intro ha hb + +/-- A good row has the paper's half-bit score relative to the coordinate of +the actual two-matching encoding. -/ +theorem goodRow_coordinateEncoding_score + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + {i : Fin n} (hgood : IsGoodRow Ξ· (P i)) : + Real.log 2 / 2 - goodRowOmega Ξ· ≀ + rowScore (P i) - + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) := by + obtain ⟨a, b, hab, hdist, hscore⟩ := + goodRow_score (hP i) hΞ·β‚€ hη₁ hgood + have hcore := goodRow_witness_mem_heavyCoordinates + (hP i).probability hab hdist + have ha := hheavy i a hcore.1 + have hb := hheavy i b hcore.2 + have houtcome : coreOutcome (f i) (g i) = coreOutcome a b := + coreOutcome_eq_of_pair_membership hab ha hb + have hentropy : + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) = + twoCoreCoarsenedEntropy (P i) a b := by + rw [coordinateEncoding_mass hmarg f g i, houtcome, + coreOutcome_entropy_eq_twoCoreCoarsenedEntropy (P i) hab] + rw [hentropy] + exact hscore + +/-- The coarse `-1` score bound for any row, relative to the same coordinate +encoding. -/ +theorem coordinateEncoding_score_ge_neg_one + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (f g : Equiv.Perm (Fin n)) (i : Fin n) : + -1 ≀ rowScore (P i) - + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) := by + have hrow := rowScore_ge_entropy_sub_one (hP i).probability + have hentropy : + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) ≀ + shannonEntropy (P i) := by + rw [coordinateEncoding_mass hmarg f g i] + exact coreOutcome_entropy_le (hP i) (f i) (g i) + linarith + +/-- Paper Lemma 9 with the joint encoding entropy replaced by the sum of its +coordinate entropies. -/ +theorem twoMatching_coreEncoding_sum_coordinates + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + (hΞΌ : IsProbabilityVector ΞΌ) (f g : Equiv.Perm (Fin n)) : + shannonEntropy ΞΌ ≀ + (βˆ‘ i, shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i))) + + (alternatingRowPerm f g).cycleFactorsFinset.card * Real.log 2 := by + let ΞΌr := rowOrientedMass ΞΌ + let Y := twoMatchingEncoding f g + have hΞΌr : IsProbabilityVector ΞΌr := rowOrientedMass_isProbabilityVector hΞΌ + have hcore := twoMatching_coreEncoding hΞΌr f g + have hY : IsProbabilityVector (pushforwardMass ΞΌr Y) := + pushforwardMass_isProbabilityVector ΞΌr hΞΌr Y + have hsub := functionEntropy_le_sum_coordinateEntropies hY + have hcoord (i : Fin n) : + pushforwardMass (pushforwardMass ΞΌr Y) (fun y ↦ y i) = + pushforwardMass ΞΌr (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i) := by + funext y + rw [pushforwardMass_comp] + congr 1 + simp_rw [hcoord] at hsub + rw [shannonEntropy_rowOrientedMass] at hcore + linarith + +/-- Selects the matrix rows satisfying the good-row predicate at threshold `Ξ·`. -/ +noncomputable def goodRows + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : Finset (Fin n) := by + classical + exact Finset.univ.filter fun i ↦ IsGoodRow Ξ· (P i) + +theorem goodRows_disjoint_badRows + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : + Disjoint (goodRows Ξ· P) (badRows Ξ· P) := by + classical + rw [Finset.disjoint_left] + intro i hgood hbad + simp [goodRows, badRows] at hgood hbad + exact hbad hgood + +theorem goodRows_union_badRows + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : + goodRows Ξ· P βˆͺ badRows Ξ· P = Finset.univ := by + classical + ext i + by_cases h : IsGoodRow Ξ· (P i) <;> simp [goodRows, badRows, h] + +theorem goodRows_card_add_badRows_card + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) : + (goodRows Ξ· P).card + (badRows Ξ· P).card = n := by + rw [← Finset.card_union_of_disjoint (goodRows_disjoint_badRows Ξ· P), + goodRows_union_badRows] + simp + +/-- Sum of the good-row and coarse bad-row estimates, before applying the +joint core-encoding inequality. -/ +theorem sum_coordinateEncoding_score_lower + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) : + ((goodRows Ξ· P).card : ℝ) * + (Real.log 2 / 2 - goodRowOmega Ξ·) - + (badRows Ξ· P).card ≀ + βˆ‘ i, (rowScore (P i) - + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i))) := by + let d : Fin n β†’ ℝ := fun i ↦ rowScore (P i) - + shannonEntropy (pushforwardMass (rowOrientedMass ΞΌ) + (fun Οƒ ↦ twoMatchingEncoding f g Οƒ i)) + have hgood : ((goodRows Ξ· P).card : ℝ) * + (Real.log 2 / 2 - goodRowOmega Ξ·) ≀ + βˆ‘ i ∈ goodRows Ξ· P, d i := by + calc + ((goodRows Ξ· P).card : ℝ) * + (Real.log 2 / 2 - goodRowOmega Ξ·) = + βˆ‘ i ∈ goodRows Ξ· P, + (Real.log 2 / 2 - goodRowOmega Ξ·) := by + rw [Finset.sum_const, nsmul_eq_mul] + _ ≀ βˆ‘ i ∈ goodRows Ξ· P, d i := by + apply Finset.sum_le_sum + intro i hi + have hi' : IsGoodRow Ξ· (P i) := by + simpa [goodRows] using hi + exact goodRow_coordinateEncoding_score hmarg hP hΞ·β‚€ hη₁ + f g hheavy hi' + have hbad : -((badRows Ξ· P).card : ℝ) ≀ + βˆ‘ i ∈ badRows Ξ· P, d i := by + calc + -((badRows Ξ· P).card : ℝ) = βˆ‘ i ∈ badRows Ξ· P, (-1 : ℝ) := by + rw [Finset.sum_const, nsmul_eq_mul] + ring + _ ≀ βˆ‘ i ∈ badRows Ξ· P, d i := by + apply Finset.sum_le_sum + intro i _ + exact coordinateEncoding_score_ge_neg_one hmarg hP f g i + have hpartition : (βˆ‘ i, d i) = + (βˆ‘ i ∈ goodRows Ξ· P, d i) + βˆ‘ i ∈ badRows Ξ· P, d i := by + rw [← Finset.sum_union (goodRows_disjoint_badRows Ξ· P), + goodRows_union_badRows] + change _ ≀ βˆ‘ i, d i + rw [hpartition] + linarith + +/-- The graph-indexed entropy-score inequality (paper (29)). -/ +theorem divergence_ge_good_bad_cycleScore + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hΞΌ : IsProbabilityVector ΞΌ) + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + {D : ℝ} (hD : D = -shannonEntropy ΞΌ + βˆ‘ i, rowScore (P i)) : + ((goodRows Ξ· P).card : ℝ) * + (Real.log 2 / 2 - goodRowOmega Ξ·) - + (badRows Ξ· P).card - + (alternatingRowPerm f g).cycleFactorsFinset.card * Real.log 2 ≀ D := by + have hcore := twoMatching_coreEncoding_sum_coordinates hΞΌ f g + have hrows := sum_coordinateEncoding_score_lower + hmarg hP hΞ·β‚€ hη₁ f g hheavy + rw [Finset.sum_sub_distrib] at hrows + rw [hD] + linarith + +theorem goodRow_mem_alternating_support + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + {i : Fin n} (hgood : IsGoodRow Ξ· (P i)) : + i ∈ (alternatingRowPerm f g).support := by + obtain ⟨a, b, hab, hdist⟩ := hgood + have hcore := goodRow_witness_mem_heavyCoordinates + (hP i).probability hab hdist + have ha := hheavy i a hcore.1 + have hb := hheavy i b hcore.2 + have hfg : f i β‰  g i := by + intro h + rcases ha with ha | ha <;> rcases hb with hb | hb + Β· exact hab (ha.trans hb.symm) + Β· exact hab (ha.trans (h.trans hb.symm)) + Β· exact hab (ha.trans (h.symm.trans hb.symm)) + Β· exact hab (ha.trans hb.symm) + rw [Equiv.Perm.mem_support] + intro hfix + exact hfg ((alternatingRowPerm_fixed_iff f g i).1 hfix) + +/-- The supports of the nontrivial cycle factors partition any set contained +in the support of the ambient permutation. -/ +theorem sum_cycleSupport_inter_card + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (h : Equiv.Perm Ξ±) (S : Finset Ξ±) (hS : S βŠ† h.support) : + (βˆ‘ c : h.cycleFactorsFinset, ((c : Equiv.Perm Ξ±).support ∩ S).card) = + S.card := by + let t : Equiv.Perm Ξ± β†’ Finset Ξ± := fun c ↦ c.support ∩ S + have hpair : (↑h.cycleFactorsFinset : Set (Equiv.Perm Ξ±)).PairwiseDisjoint t := by + intro c hc d hd hcd + have hdisj := h.cycleFactorsFinset_pairwise_disjoint hc hd hcd + exact hdisj.disjoint_support.mono inf_le_left inf_le_left + have hunion : h.cycleFactorsFinset.biUnion t = S := by + ext i + constructor + Β· intro hi + obtain ⟨c, _, hi⟩ := Finset.mem_biUnion.mp hi + exact (Finset.mem_inter.mp hi).2 + Β· intro hi + have hisupp := hS hi + obtain ⟨c, hc, hic⟩ := + Equiv.Perm.mem_support_iff_mem_support_of_mem_cycleFactorsFinset.mp hisupp + exact Finset.mem_biUnion.mpr ⟨c, hc, Finset.mem_inter.mpr ⟨hic, hi⟩⟩ + calc + (βˆ‘ c : h.cycleFactorsFinset, + ((c : Equiv.Perm Ξ±).support ∩ S).card) = + βˆ‘ c ∈ h.cycleFactorsFinset, (t c).card := by + simpa [t] using Finset.sum_coe_sort h.cycleFactorsFinset + (fun c ↦ (t c).card) + _ = (h.cycleFactorsFinset.biUnion t).card := + (Finset.card_biUnion hpair).symm + _ = S.card := by rw [hunion] + +theorem sum_cycleSupport_inter_card_le + {Ξ± : Type*} [Fintype Ξ±] [DecidableEq Ξ±] + (h : Equiv.Perm Ξ±) (S : Finset Ξ±) : + (βˆ‘ c : h.cycleFactorsFinset, ((c : Equiv.Perm Ξ±).support ∩ S).card) ≀ + S.card := by + let t : Equiv.Perm Ξ± β†’ Finset Ξ± := fun c ↦ c.support ∩ S + have hpair : (↑h.cycleFactorsFinset : Set (Equiv.Perm Ξ±)).PairwiseDisjoint t := by + intro c hc d hd hcd + have hdisj := h.cycleFactorsFinset_pairwise_disjoint hc hd hcd + exact hdisj.disjoint_support.mono inf_le_left inf_le_left + have hsubset : h.cycleFactorsFinset.biUnion t βŠ† S := by + intro i hi + obtain ⟨c, _, hi⟩ := Finset.mem_biUnion.mp hi + exact (Finset.mem_inter.mp hi).2 + have hcard := Finset.card_le_card hsubset + rw [Finset.card_biUnion hpair] at hcard + calc + (βˆ‘ c : h.cycleFactorsFinset, + ((c : Equiv.Perm Ξ±).support ∩ S).card) = + βˆ‘ c ∈ h.cycleFactorsFinset, (t c).card := by + simpa [t] using Finset.sum_coe_sort h.cycleFactorsFinset + (fun c ↦ (t c).card) + _ ≀ S.card := hcard + +/-- Counts the good rows in a permutation cycle factor's support. -/ +noncomputable def cycleGoodCount + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) (c : h.cycleFactorsFinset) : β„• := + ((c : Equiv.Perm (Fin n)).support ∩ goodRows Ξ· P).card + +/-- Counts the bad rows in a permutation cycle factor's support. -/ +noncomputable def cycleBadCount + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) (c : h.cycleFactorsFinset) : β„• := + ((c : Equiv.Perm (Fin n)).support ∩ badRows Ξ· P).card + +/-- Sums the long-component good-row contribution over all cycle factors of the permutation. -/ +noncomputable def longCycleGoodRows + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) : β„• := + βˆ‘ c : h.cycleFactorsFinset, + longComponentGoodRows (c : Equiv.Perm (Fin n)).support.card + (cycleGoodCount Ξ· P h c) + +/-- Indicator that a nontrivial alternating component has exactly two rows, +both of them good. Such a component is one of the paper's clean pairs. -/ +noncomputable def cleanCycleIndicator + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) (c : h.cycleFactorsFinset) : β„• := + if (c : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c = 2 then 1 else 0 + +/-- Sums clean-cycle indicators over the permutation's cycle factors. -/ +noncomputable def cleanCycleCount + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) : β„• := + βˆ‘ c : h.cycleFactorsFinset, cleanCycleIndicator Ξ· P h c + +theorem cycleGoodCount_add_cycleBadCount + {n : β„•} (Ξ· : ℝ) (P : Matrix (Fin n) (Fin n) ℝ) + (h : Equiv.Perm (Fin n)) (c : h.cycleFactorsFinset) : + cycleGoodCount Ξ· P h c + cycleBadCount Ξ· P h c = + (c : Equiv.Perm (Fin n)).support.card := by + have hdisj : Disjoint + ((c : Equiv.Perm (Fin n)).support ∩ goodRows Ξ· P) + ((c : Equiv.Perm (Fin n)).support ∩ badRows Ξ· P) := + (goodRows_disjoint_badRows Ξ· P).mono inf_le_right inf_le_right + rw [cycleGoodCount, cycleBadCount, + ← Finset.card_union_of_disjoint hdisj] + congr 1 + ext i + simp only [Finset.mem_union, Finset.mem_inter] + constructor + Β· rintro (⟨hi, _⟩ | ⟨hi, _⟩) <;> exact hi + Β· intro hi + have hcover : i ∈ goodRows Ξ· P βˆͺ badRows Ξ· P := by + rw [goodRows_union_badRows] + simp + rcases Finset.mem_union.mp hcover with hgood | hbad + Β· exact Or.inl ⟨hi, hgood⟩ + Β· exact Or.inr ⟨hi, hbad⟩ + +/-- Paper component accounting (30), now instantiated with the actual cycle +factors of the completed two-matching graph. -/ +theorem alternating_component_accounting + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) : + ((longCycleGoodRows Ξ· P (alternatingRowPerm f g) : β„•) : ℝ) / 6 - + ((badRows Ξ· P).card : ℝ) / 2 ≀ + ((goodRows Ξ· P).card : ℝ) / 2 - + ((alternatingRowPerm f g).cycleFactorsFinset.card : ℝ) := by + let h := alternatingRowPerm f g + let k : h.cycleFactorsFinset β†’ β„• := + fun c ↦ (c : Equiv.Perm (Fin n)).support.card + let gc : h.cycleFactorsFinset β†’ β„• := cycleGoodCount Ξ· P h + let bc : h.cycleFactorsFinset β†’ β„• := cycleBadCount Ξ· P h + have hk2 : βˆ€ c, 2 ≀ k c := by + intro c + exact (Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.property).1.two_le_card_support + have hpartition : βˆ€ c, gc c + bc c = k c := by + intro c + exact cycleGoodCount_add_cycleBadCount Ξ· P h c + have hcomp := component_accounting k gc bc + (fun c ↦ le_trans (by norm_num) (hk2 c)) hpartition + (fun c hc ↦ False.elim (by + have hc2 := hk2 c + omega)) + have hgoodSupport : goodRows Ξ· P βŠ† h.support := by + intro i hi + have hgood : IsGoodRow Ξ· (P i) := by simpa [goodRows] using hi + exact goodRow_mem_alternating_support hP f g hheavy hgood + have hgoodSum : (βˆ‘ c, gc c) = (goodRows Ξ· P).card := by + simpa [gc, cycleGoodCount] using + sum_cycleSupport_inter_card h (goodRows Ξ· P) hgoodSupport + have hbadSum : (βˆ‘ c, bc c) ≀ (badRows Ξ· P).card := by + simpa [bc, cycleBadCount] using + sum_cycleSupport_inter_card_le h (badRows Ξ· P) + have hm : (βˆ‘ c, nontrivialComponentCount (k c)) = + h.cycleFactorsFinset.card := by + calc + (βˆ‘ c, nontrivialComponentCount (k c)) = βˆ‘ _c, 1 := by + apply Finset.sum_congr rfl + intro c _ + simp [nontrivialComponentCount, hk2 c] + _ = h.cycleFactorsFinset.card := by simp + have hlong : (βˆ‘ c, longComponentGoodRows (k c) (gc c)) = + longCycleGoodRows Ξ· P h := by rfl + have hgoodSumR : (βˆ‘ c, (gc c : ℝ)) = + ((goodRows Ξ· P).card : ℝ) := by + exact_mod_cast hgoodSum + have hmR : (βˆ‘ c, (nontrivialComponentCount (k c) : ℝ)) = + (h.cycleFactorsFinset.card : ℝ) := by + exact_mod_cast hm + have hlongR : (βˆ‘ c, (longComponentGoodRows (k c) (gc c) : ℝ)) = + (longCycleGoodRows Ξ· P h : ℝ) := by + exact_mod_cast hlong + rw [hgoodSumR, hmR, hlongR] at hcomp + have hbadCast : (βˆ‘ c, (bc c : ℝ)) ≀ ((badRows Ξ· P).card : ℝ) := by + exact_mod_cast hbadSum + linarith + +/-- Full graph-indexed robust cycle-information inequality, paper Lemma 13. -/ +theorem robust_cycle_information_twoMatchings + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hΞΌ : IsProbabilityVector ΞΌ) + (hmarg : HasAssignmentMarginals ΞΌ P) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) + (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) + {D : ℝ} (hD : D = -shannonEntropy ΞΌ + βˆ‘ i, rowScore (P i)) : + Real.log 2 / 6 * + (longCycleGoodRows Ξ· P (alternatingRowPerm f g) : β„•) - + (1 + Real.log 2 / 2) * (badRows Ξ· P).card - + n * goodRowOmega Ξ· ≀ D := by + have hscore := divergence_ge_good_bad_cycleScore + hΞΌ hmarg hP hΞ·β‚€ hη₁ f g hheavy hD + have haccount := alternating_component_accounting hP f g hheavy + have hG : ((goodRows Ξ· P).card : ℝ) ≀ n := by + have hGNat : (goodRows Ξ· P).card ≀ n := by + simpa using Finset.card_le_univ (goodRows Ξ· P) + exact_mod_cast hGNat + exact robust_cycle_information_of_accounting + (goodRowOmega_nonneg Ξ·) hG hscore haccount + +/-- The exact graph-indexed form of paper (31): after discarding bad rows +and good rows in long components, the remaining rows occur in vertex-disjoint +clean two-row components. -/ +theorem alternating_cleanCycle_count + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + {Ξ· : ℝ} (f g : Equiv.Perm (Fin n)) + (hheavy : βˆ€ i j, j ∈ heavyCoordinates Ξ· (P i) β†’ + j = f i ∨ j = g i) : + n ≀ 2 * (badRows Ξ· P).card + + longCycleGoodRows Ξ· P (alternatingRowPerm f g) + + 2 * cleanCycleCount Ξ· P (alternatingRowPerm f g) := by + let h := alternatingRowPerm f g + let k : h.cycleFactorsFinset β†’ β„• := + fun c ↦ (c : Equiv.Perm (Fin n)).support.card + let gc : h.cycleFactorsFinset β†’ β„• := cycleGoodCount Ξ· P h + let bc : h.cycleFactorsFinset β†’ β„• := cycleBadCount Ξ· P h + have hk2 : βˆ€ c, 2 ≀ k c := by + intro c + exact (Equiv.Perm.mem_cycleFactorsFinset_iff.mp c.property).1.two_le_card_support + have hpoint : βˆ€ c, gc c ≀ + 2 * cleanCycleIndicator Ξ· P h c + bc c + + longComponentGoodRows (k c) (gc c) := by + intro c + have hpart : gc c + bc c = k c := + cycleGoodCount_add_cycleBadCount Ξ· P h c + by_cases hk3 : 3 ≀ k c + Β· simp [cleanCycleIndicator, longComponentGoodRows, hk3] + Β· have hc2 := hk2 c + have hkEq : k c = 2 := by omega + by_cases hg2 : gc c = 2 + Β· have hclean : + (c : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c = 2 := by + simpa [k, gc] using And.intro hkEq hg2 + rw [cleanCycleIndicator, ite_eq_left hclean] + simp [longComponentGoodRows, hkEq] + omega + Β· have hgb : gc c ≀ bc c := by omega + have hnotclean : Β¬((c : Equiv.Perm (Fin n)).support.card = 2 ∧ + cycleGoodCount Ξ· P h c = 2) := by + intro hclean + exact hg2 (by simpa [gc] using hclean.2) + rw [cleanCycleIndicator, ite_eq_right hnotclean] + simp [longComponentGoodRows, hkEq] + exact hgb + have hsum := Finset.sum_le_sum (s := Finset.univ) + (fun c _ ↦ hpoint c) + have hsum' : (βˆ‘ c, gc c) ≀ + 2 * cleanCycleCount Ξ· P h + (βˆ‘ c, bc c) + + longCycleGoodRows Ξ· P h := by + simpa [cleanCycleCount, longCycleGoodRows, + Finset.sum_add_distrib, Finset.mul_sum] using hsum + have hgoodSupport : goodRows Ξ· P βŠ† h.support := by + intro i hi + have hgood : IsGoodRow Ξ· (P i) := by simpa [goodRows] using hi + exact goodRow_mem_alternating_support hP f g hheavy hgood + have hgoodSum : (βˆ‘ c, gc c) = (goodRows Ξ· P).card := by + simpa [gc, cycleGoodCount] using + sum_cycleSupport_inter_card h (goodRows Ξ· P) hgoodSupport + have hbadSum : (βˆ‘ c, bc c) ≀ (badRows Ξ· P).card := by + simpa [bc, cycleBadCount] using + sum_cycleSupport_inter_card_le h (badRows Ξ· P) + have hrows := goodRows_card_add_badRows_card (Ξ· := Ξ·) P + rw [hgoodSum] at hsum' + have hfinal : n ≀ 2 * (badRows Ξ· P).card + + longCycleGoodRows Ξ· P h + 2 * cleanCycleCount Ξ· P h := by + omega + simpa [h] using hfinal + +/-- Paper Lemma 13 for the Gibbs law of a positive matrix, with the completed +heavy graph and its two perfect matchings constructed rather than assumed. -/ +theorem exists_gibbs_robust_cycle_information + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) + (hA : βˆ€ i j, 0 < A i j) + {Ξ· : ℝ} (hΞ·β‚€ : 0 ≀ Ξ·) (hη₁ : Ξ· ≀ 1 / 10) : + βˆƒ f g : Equiv.Perm (Fin n), + (βˆ€ i j, j ∈ heavyCoordinates Ξ· (assignmentMarginal A i) β†’ + j = f i ∨ j = g i) ∧ + Real.log 2 / 6 * + (longCycleGoodRows Ξ· (assignmentMarginal A) + (alternatingRowPerm f g) : β„•) - + (1 + Real.log 2 / 2) * + (badRows Ξ· (assignmentMarginal A)).card - + n * goodRowOmega Ξ· ≀ gibbsSequentialDivergence A := by + have hper := permanent_pos_of_positive A hA + have hDS : IsDoublyStochastic (assignmentMarginal A) := + assignmentMarginal_doublyStochastic A + (fun i j ↦ (hA i j).le) hper.ne' + obtain ⟨f, g, hheavy⟩ := + exists_heavyCompletion_twoMatchings hDS hη₁ + refine ⟨f, g, hheavy, ?_⟩ + exact robust_cycle_information_twoMatchings + (gibbsProbability_isProbabilityVector A hA) + (gibbs_hasAssignmentMarginals A) + (assignmentMarginal_strictProbabilityVector A hA) + hΞ·β‚€ hη₁ f g hheavy + (gibbsSequentialDivergence_eq_entropy A hA) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoid.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoid.lean new file mode 100644 index 0000000000..b6f781fb36 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoid.lean @@ -0,0 +1,374 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MatrixPerturbation +public import Mathlib.Tactic + +/-! # Rounded Ellipsoid -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Containment tools for a rounded rational ellipsoid + +After an exact central-cut update we floor the center and basis to a fixed +dyadic grid and inflate the rounded basis. The lemmas below construct the +new unit-ball coordinate explicitly with the adjugate formula and bound it +entry by entry. Thus nonsingularity and containment are quantitative +consequences of displayed inequalities, not numerical assumptions. +-/ + +/-- Floor the center and basis, then inflate the basis by `1 + Ξ·`. -/ +def inflatedDyadicRound {d : β„•} (p : β„•) (Ξ· : β„š) + (E : RationalEllipsoidState d) : RationalEllipsoidState d where + center := dyadicFloorVector p E.center + basis := fun i j ↦ (1 + Ξ·) * dyadicFloorMatrix p E.basis i j + +/-- The bounded-bit central-cut update: perform the exact rational update, +then round and inflate. -/ +def roundedRationalEllipsoidCentralUpdate {d : β„•} + (p : β„•) (Ξ· : β„š) (E : RationalEllipsoidState d) + (a : Fin d β†’ β„š) : RationalEllipsoidState d := + inflatedDyadicRound p Ξ· (rationalEllipsoidCentralUpdate E a) + +@[simp] theorem inflatedDyadicRound_center {d : β„•} (p : β„•) (Ξ· : β„š) + (E : RationalEllipsoidState d) : + (inflatedDyadicRound p Ξ· E).center = dyadicFloorVector p E.center := rfl + +@[simp] theorem inflatedDyadicRound_basis_apply {d : β„•} (p : β„•) (Ξ· : β„š) + (E : RationalEllipsoidState d) (i j : Fin d) : + (inflatedDyadicRound p Ξ· E).basis i j = + (1 + Ξ·) * dyadicFloorMatrix p E.basis i j := rfl + +/-- Cramer's-rule correction solving `A v = e`. This is used only to exhibit +a real preimage in the correctness proof; it is not part of the executable +state. -/ +noncomputable def adjugateCorrection {d : β„•} (A : Matrix (Fin d) (Fin d) ℝ) + (e : Fin d β†’ ℝ) : Fin d β†’ ℝ := + (Matrix.det A)⁻¹ β€’ Matrix.cramer A e + +theorem mulVec_adjugateCorrection {d : β„•} + (A : Matrix (Fin d) (Fin d) ℝ) (e : Fin d β†’ ℝ) + (hdet : Matrix.det A β‰  0) : + Matrix.mulVec A (adjugateCorrection A e) = e := by + rw [adjugateCorrection, Matrix.mulVec_smul, Matrix.mulVec_cramer] + ext i + simp [hdet] + +theorem finiteNormSq_le_card_mul_sq_of_abs_le {d : β„•} + (v : Fin d β†’ ℝ) {V : ℝ} (hV : 0 ≀ V) + (hv : βˆ€ i, abs (v i) ≀ V) : + finiteNormSq v ≀ d * V ^ 2 := by + rw [finiteNormSq, finiteDot, + show (d : ℝ) * V ^ 2 = βˆ‘ _i : Fin d, V ^ 2 by simp] + apply Finset.sum_le_sum + intro i _ + have habs0 : 0 ≀ abs (v i) := abs_nonneg _ + calc + v i * v i = abs (v i) ^ 2 := by rw [sq_abs, sq] + _ ≀ V ^ 2 := (sq_le_sqβ‚€ habs0 hV).2 (hv i) + +/-- Entrywise bound for the adjugate correction. -/ +theorem abs_adjugateCorrection_le {d : β„•} + (A : Matrix (Fin d) (Fin d) ℝ) (e : Fin d β†’ ℝ) + {D M E : ℝ} (hD : 0 < D) (hdet : D ≀ abs (Matrix.det A)) + (hM : 1 ≀ M) (hA : βˆ€ i j, abs (A i j) ≀ M) + (he : βˆ€ i, abs (e i) ≀ E) (hE : 0 ≀ E) (i : Fin d) : + abs (adjugateCorrection A e i) ≀ + (d * (d.factorial * M ^ d) * E) / D := by + have hdet0 : Matrix.det A β‰  0 := by + intro hz + rw [hz, abs_zero] at hdet + linarith + have hcramer : abs (Matrix.cramer A e i) ≀ + d * (d.factorial * M ^ d) * E := by + rw [Matrix.cramer_eq_adjugate_mulVec, Matrix.mulVec, dotProduct] + calc + abs (βˆ‘ j, A.adjugate i j * e j) ≀ + βˆ‘ j, abs (A.adjugate i j * e j) := + Finset.abs_sum_le_sum_abs _ _ + _ ≀ βˆ‘ _j : Fin d, (d.factorial * M ^ d) * E := by + apply Finset.sum_le_sum + intro j _ + rw [abs_mul] + exact mul_le_mul + (abs_adjugate_entry_le_of_entrywise A hM hA i j) (he j) + (abs_nonneg _) (by positivity) + _ = d * (d.factorial * M ^ d) * E := by simp; ring + rw [adjugateCorrection, Pi.smul_apply, smul_eq_mul, abs_mul] + have hdetAbs : 0 < abs (Matrix.det A) := abs_pos.mpr hdet0 + have hinv : (abs (Matrix.det A))⁻¹ ≀ D⁻¹ := by + exact (inv_le_invβ‚€ hdetAbs hD).2 hdet + calc + abs ((Matrix.det A)⁻¹) * abs (Matrix.cramer A e i) = + (abs (Matrix.det A))⁻¹ * abs (Matrix.cramer A e i) := by + rw [abs_inv] + _ ≀ + D⁻¹ * (d * (d.factorial * M ^ d) * E) := by + exact mul_le_mul hinv hcramer (abs_nonneg _) (inv_nonneg.mpr hD.le) + _ = (d * (d.factorial * M ^ d) * E) / D := by + rw [div_eq_mul_inv] + ring + +/-- A small correction keeps the sum of an old unit vector and the +correction inside the ball inflated by `1 + Ξ·`. -/ +theorem finiteNormSq_add_le_inflation_sq {d : β„•} + {y v : Fin d β†’ ℝ} {Ξ· : ℝ} (hΞ· : 0 ≀ Ξ·) + (hy : finiteNormSq y ≀ 1) (hv : finiteNormSq v ≀ Ξ· ^ 2) : + finiteNormSq (fun i ↦ y i + v i) ≀ (1 + Ξ·) ^ 2 := by + have hv0 := finiteNormSq_nonneg v + have hdotSq := finiteDot_sq_le_normSq_mul_normSq y v + have hynonneg := finiteNormSq_nonneg y + have hprod : finiteNormSq y * finiteNormSq v ≀ Ξ· ^ 2 := by + calc + finiteNormSq y * finiteNormSq v ≀ 1 * finiteNormSq v := by + exact mul_le_mul_of_nonneg_right hy hv0 + _ ≀ Ξ· ^ 2 := by simpa using hv + have habsdot : abs (finiteDot y v) ≀ Ξ· := by + have hsquare : abs (finiteDot y v) ^ 2 ≀ Ξ· ^ 2 := by + rw [sq_abs] + exact hdotSq.trans hprod + nlinarith [abs_nonneg (finiteDot y v)] + rw [finiteNormSq_add] + nlinarith [le_abs_self (finiteDot y v)] + +/-- Quantitative containment after dyadic rounding and inflation. All +quantities controlling the inverse are explicit: `D` is a determinant lower +bound, `M` is an entry bound for the rounded basis, and the final displayed +inequality is precisely the rounding-smallness condition. -/ +theorem inflatedDyadicRound_contains {d : β„•} (hd : 0 < d) + (p : β„•) (Ξ· : β„š) (E : RationalEllipsoidState d) + {D M : ℝ} (hΞ· : 0 ≀ Ξ·) (hD : 0 < D) (hM : 1 ≀ M) + (hA : βˆ€ i j, + abs (((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)) ≀ M) + (hdet : D ≀ abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)))) + (hsmall : + d * + ((d * (d.factorial * M ^ d) * + ((d + 1 : β„•) * (dyadicMesh p : ℝ))) / D) ^ 2 ≀ + (Ξ· : ℝ) ^ 2) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint (inflatedDyadicRound p Ξ· E) y' = + rationalEllipsoidPoint E y := by + let A : Matrix (Fin d) (Fin d) ℝ := + fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ) + let e : Fin d β†’ ℝ := fun i ↦ + (E.center i : ℝ) - (dyadicFloorVector p E.center i : ℝ) + + βˆ‘ j, ((E.basis i j : ℝ) - A i j) * y j + let v : Fin d β†’ ℝ := adjugateCorrection A e + let s : ℝ := 1 + (Ξ· : ℝ) + let y' : Fin d β†’ ℝ := fun i ↦ s⁻¹ * (y i + v i) + have hΞ·R : 0 ≀ (Ξ· : ℝ) := Rat.cast_nonneg.mpr hΞ· + have hs : 0 < s := by dsimp only [s]; linarith + have hdetA : D ≀ abs (Matrix.det A) := by simpa only [A] using hdet + have hdet0 : Matrix.det A β‰  0 := by + intro hz + rw [hz, abs_zero] at hdetA + linarith + have hycoord : βˆ€ j, abs (y j) ≀ 1 := + fun j ↦ abs_coordinate_le_one_of_normSq_le_one hy j + have hcenter : βˆ€ i, + abs ((E.center i : ℝ) - + (dyadicFloorVector p E.center i : ℝ)) ≀ (dyadicMesh p : ℝ) := by + intro i + have h := abs_dyadicFloor_sub_lt p (E.center i) + have hcast : abs (((dyadicFloor p (E.center i) - E.center i : β„š) : ℝ)) < + (dyadicMesh p : ℝ) := by exact_mod_cast h + rw [Rat.cast_sub, abs_sub_comm] at hcast + simpa only [dyadicFloorVector] using hcast.le + have hbasis : βˆ€ i j, + abs ((E.basis i j : ℝ) - A i j) ≀ (dyadicMesh p : ℝ) := by + intro i j + have h := cast_dyadicFloorMatrix_entry_error_lt p E.basis i j + rw [Rat.cast_sub, abs_sub_comm] at h + simpa only [A] using h.le + have hmesh0 : (0 : ℝ) ≀ (dyadicMesh p : ℝ) := by + exact_mod_cast dyadicMesh_nonneg p + have he : βˆ€ i, + abs (e i) ≀ ((d + 1 : β„•) : ℝ) * (dyadicMesh p : ℝ) := by + intro i + dsimp only [e] + calc + abs ((E.center i : ℝ) - + (dyadicFloorVector p E.center i : ℝ) + + βˆ‘ j, ((E.basis i j : ℝ) - A i j) * y j) ≀ + abs ((E.center i : ℝ) - + (dyadicFloorVector p E.center i : ℝ)) + + abs (βˆ‘ j, ((E.basis i j : ℝ) - A i j) * y j) := + abs_add_le _ _ + _ ≀ (dyadicMesh p : ℝ) + + βˆ‘ j, abs (((E.basis i j : ℝ) - A i j) * y j) := + add_le_add (hcenter i) (Finset.abs_sum_le_sum_abs _ _) + _ ≀ (dyadicMesh p : ℝ) + + βˆ‘ _j : Fin d, (dyadicMesh p : ℝ) := by + gcongr with j + rw [abs_mul] + calc + abs ((E.basis i j : ℝ) - A i j) * abs (y j) ≀ + (dyadicMesh p : ℝ) * 1 := + mul_le_mul (hbasis i j) (hycoord j) (abs_nonneg _) hmesh0 + _ = (dyadicMesh p : ℝ) := mul_one _ + _ = ((d + 1 : β„•) : ℝ) * (dyadicMesh p : ℝ) := by + simp + ring + let V : ℝ := + (d * (d.factorial * M ^ d) * + (((d + 1 : β„•) : ℝ) * (dyadicMesh p : ℝ))) / D + have hV0 : 0 ≀ V := by + dsimp only [V] + positivity + have hvcoord : βˆ€ i, abs (v i) ≀ V := by + intro i + dsimp only [v, V] + exact abs_adjugateCorrection_le A e hD hdetA hM + (by simpa only [A] using hA) he (by positivity) i + have hvnorm : finiteNormSq v ≀ (Ξ· : ℝ) ^ 2 := by + have hvbound := finiteNormSq_le_card_mul_sq_of_abs_le v hV0 hvcoord + exact hvbound.trans (by simpa only [V] using hsmall) + have hadd : finiteNormSq (fun i ↦ y i + v i) ≀ s ^ 2 := by + simpa only [s] using finiteNormSq_add_le_inflation_sq hΞ·R hy hvnorm + have hy' : finiteNormSq y' ≀ 1 := by + have hs2 : 0 < s ^ 2 := sq_pos_of_pos hs + rw [show y' = fun i ↦ s⁻¹ * (y i + v i) by rfl, + finiteNormSq_smul] + rw [inv_pow] + calc + (s ^ 2)⁻¹ * finiteNormSq (fun i ↦ y i + v i) ≀ + (s ^ 2)⁻¹ * s ^ 2 := + mul_le_mul_of_nonneg_left hadd (inv_nonneg.mpr hs2.le) + _ = 1 := inv_mul_cancelβ‚€ hs2.ne' + refine ⟨y', hy', ?_⟩ + have hAv : Matrix.mulVec A v = e := + mulVec_adjugateCorrection A e hdet0 + ext i + rw [rationalEllipsoidPoint, rationalEllipsoidPoint] + change + (dyadicFloorVector p E.center i : ℝ) + + βˆ‘ j, (((1 + Ξ·) * dyadicFloorMatrix p E.basis i j : β„š) : ℝ) * y' j = + (E.center i : ℝ) + βˆ‘ j, (E.basis i j : ℝ) * y j + have hsCast : ((1 + Ξ· : β„š) : ℝ) = s := by simp [s] + simp_rw [Rat.cast_mul, hsCast] + have hcancel : βˆ€ j, s * A i j * y' j = A i j * (y j + v j) := by + intro j + dsimp only [y'] + field_simp [hs.ne'] + rw [show + (βˆ‘ j, s * ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ) * y' j) = + βˆ‘ j, A i j * (y j + v j) by + apply Finset.sum_congr rfl + intro j _ + simpa only [A] using hcancel j] + rw [show (βˆ‘ j, A i j * (y j + v j)) = + βˆ‘ j, A i j * y j + Matrix.mulVec A v i by + simp [Matrix.mulVec, dotProduct, mul_add, Finset.sum_add_distrib]] + rw [hAv] + dsimp only [e] + ring_nf + rw [Finset.sum_sub_distrib] + ring + +/-- Exact determinant formula for the stored rounded-and-inflated basis. -/ +theorem det_inflatedDyadicRound_basis {d : β„•} (p : β„•) (Ξ· : β„š) + (E : RationalEllipsoidState d) : + Matrix.det (inflatedDyadicRound p Ξ· E).basis = + (1 + Ξ·) ^ d * Matrix.det (dyadicFloorMatrix p E.basis) := by + have hbasis : (inflatedDyadicRound p Ξ· E).basis = + (1 + Ξ·) β€’ dyadicFloorMatrix p E.basis := by + ext i j + simp [inflatedDyadicRound, Matrix.smul_apply] + rw [hbasis, Matrix.det_smul, Fintype.card_fin] + +/-- Determinant upper bound after rounding and inflation. -/ +theorem abs_det_inflatedDyadicRound_le {d : β„•} + (p : β„•) (Ξ· : β„š) (E : RationalEllipsoidState d) + {M : ℝ} (hΞ· : 0 ≀ Ξ·) (hM : 1 ≀ M) + (hE : βˆ€ i j, abs ((E.basis i j : β„š) : ℝ) ≀ M) : + abs ((Matrix.det (inflatedDyadicRound p Ξ· E).basis : β„š) : ℝ) ≀ + (1 + (Ξ· : ℝ)) ^ d * + (abs ((Matrix.det E.basis : β„š) : ℝ) + + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * M) ^ d)) := by + have hscale : 0 ≀ (1 + (Ξ· : ℝ)) ^ d := by + exact pow_nonneg (by exact_mod_cast (show (0 : β„š) ≀ 1 + Ξ· by linarith)) _ + have hpert := abs_det_dyadicFloorMatrix_sub_det_le p E.basis hM hE + have hround : + abs ((Matrix.det (dyadicFloorMatrix p E.basis) : β„š) : ℝ) ≀ + abs ((Matrix.det E.basis : β„š) : ℝ) + + d.factorial * (d * (dyadicMesh p : ℝ) * (2 * M) ^ d) := by + have htriangle : + abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ))) ≀ + abs (Matrix.det (fun i j ↦ ((E.basis i j : β„š) : ℝ))) + + abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)) - + Matrix.det (fun i j ↦ ((E.basis i j : β„š) : ℝ))) := by + have := abs_add_le + (Matrix.det (fun i j ↦ ((E.basis i j : β„š) : ℝ))) + (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)) - + Matrix.det (fun i j ↦ ((E.basis i j : β„š) : ℝ))) + convert this using 1 <;> ring + have hcastRound : + Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)) = + ((Matrix.det (dyadicFloorMatrix p E.basis) : β„š) : ℝ) := by + rw [show (fun i j ↦ ((dyadicFloorMatrix p E.basis i j : β„š) : ℝ)) = + (dyadicFloorMatrix p E.basis).map (fun q : β„š ↦ (q : ℝ)) by rfl, + Rat.cast_det] + have hcastE : + Matrix.det (fun i j ↦ ((E.basis i j : β„š) : ℝ)) = + ((Matrix.det E.basis : β„š) : ℝ) := by + rw [show (fun i j ↦ ((E.basis i j : β„š) : ℝ)) = + E.basis.map (fun q : β„š ↦ (q : ℝ)) by rfl, Rat.cast_det] + rw [hcastRound, hcastE] at htriangle hpert + linarith + rw [det_inflatedDyadicRound_basis] + rw [Rat.cast_mul, Rat.cast_pow, Rat.cast_add, Rat.cast_one] + rw [abs_mul, abs_pow, + abs_of_nonneg (by exact_mod_cast (show (0 : β„š) ≀ 1 + Ξ· by linarith))] + exact mul_le_mul_of_nonneg_left hround hscale + +/-- A valid central cut followed by sufficiently fine rounding preserves +every surviving point. -/ +theorem roundedRationalEllipsoidCentralUpdate_contains {d : β„•} + (hd : 0 < d) (p : β„•) (Ξ· : β„š) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + {D M : ℝ} (hΞ· : 0 ≀ Ξ·) (hD : 0 < D) (hM : 1 ≀ M) + (hA : βˆ€ i j, + abs (((dyadicFloorMatrix p + (rationalEllipsoidCentralUpdate E a).basis i j : β„š) : ℝ)) ≀ M) + (hdet : D ≀ abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p + (rationalEllipsoidCentralUpdate E a).basis i j : β„š) : ℝ)))) + (hsmall : + d * + ((d * (d.factorial * M ^ d) * + ((d + 1 : β„•) * (dyadicMesh p : ℝ))) / D) ^ 2 ≀ + (Ξ· : ℝ) ^ 2) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) + (hb : rationalPulledBackNormal E a β‰  0) + (hcut : finiteDot + (fun i ↦ (rationalPulledBackNormal E a i : ℝ)) y ≀ 0) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint + (roundedRationalEllipsoidCentralUpdate p Ξ· E a) y' = + rationalEllipsoidPoint E y := by + obtain ⟨z, hz, hpoint⟩ := + rationalEllipsoidCentralUpdate_contains hd E a hb hy hcut + obtain ⟨z', hz', hrounded⟩ := inflatedDyadicRound_contains hd p Ξ· + (rationalEllipsoidCentralUpdate E a) hΞ· hD hM hA hdet hsmall hz + refine ⟨z', hz', ?_⟩ + rw [roundedRationalEllipsoidCentralUpdate, hrounded, hpoint] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidBitBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidBitBounds.lean new file mode 100644 index 0000000000..4d23d77551 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidBitBounds.lean @@ -0,0 +1,544 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AdaptiveRoundedEllipsoid +public import Mathlib.Tactic + +/-! # Rounded Ellipsoid Bit Bounds -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Magnitude bounds for the bounded-bit ellipsoid + +The estimates in this file are deliberately coarse. Their purpose is to +show that the logarithm of every stored magnitude grows only linearly with +the number of cuts. Together with the determinant lower bound, this gives +a global polynomial bound on the magnitude-sensitive rounding precision. +-/ + +theorem natCast_le_two_pow_self (n : β„•) : + (n : β„š) ≀ (2 : β„š) ^ n := by + induction n with + | zero => norm_num + | succ n ih => + by_cases hn : n = 0 + Β· subst n + norm_num + Β· have hone : (1 : β„š) ≀ (2 : β„š) ^ n := one_le_powβ‚€ (by norm_num) + rw [pow_succ] + push_cast at ih ⊒ + nlinarith + +theorem factorialCast_le_two_pow_sq (d : β„•) : + (d.factorial : β„š) ≀ (2 : β„š) ^ (d ^ 2) := by + have hfac : d.factorial ≀ d ^ d := Nat.factorial_le_pow d + have hd : (d : β„š) ≀ (2 : β„š) ^ d := natCast_le_two_pow_self d + have hpow : (d : β„š) ^ d ≀ ((2 : β„š) ^ d) ^ d := + pow_le_pow_leftβ‚€ (by positivity) hd d + calc + (d.factorial : β„š) ≀ ((d ^ d : β„•) : β„š) := by exact_mod_cast hfac + _ = (d : β„š) ^ d := by norm_num + _ ≀ ((2 : β„š) ^ d) ^ d := hpow + _ = (2 : β„š) ^ (d ^ 2) := by rw [← pow_mul, pow_two] + +/-- Binary exponent dominating the common adaptive-rounding denominator +when `M ≀ 2^K`. -/ +def roundedEllipsoidDenominatorExponent (d K : β„•) : β„• := + 12 + 8 * d + d ^ 2 + d * K + +theorem roundedEllipsoidCoarseDenominator_le_two_pow + {d K : β„•} {M : β„š} (hM0 : 0 ≀ M) + (hM : M ≀ (2 : β„š) ^ K) : + roundedEllipsoidCoarseDenominator d M ≀ + (2 : β„š) ^ roundedEllipsoidDenominatorExponent d K := by + have hd : (d : β„š) ≀ (2 : β„š) ^ d := natCast_le_two_pow_self d + have hdsix : (d : β„š) ^ 6 ≀ ((2 : β„š) ^ d) ^ 6 := + pow_le_pow_leftβ‚€ (by positivity) hd 6 + have hdsucc : ((d + 1 : β„•) : β„š) ≀ (2 : β„š) ^ (d + 1) := + natCast_le_two_pow_self (d + 1) + have hfac := factorialCast_le_two_pow_sq d + have htwoM : 2 * M ≀ (2 : β„š) ^ (K + 1) := by + rw [pow_succ] + nlinarith + have htwoM0 : 0 ≀ 2 * M := mul_nonneg (by norm_num) hM0 + have hlast : (2 * M) ^ d ≀ ((2 : β„š) ^ (K + 1)) ^ d := + pow_le_pow_leftβ‚€ htwoM0 htwoM d + norm_num only [Nat.cast_add, Nat.cast_one] at hdsucc + have hexponents : + 11 + d * 6 + (d + 1) + d ^ 2 + (K + 1) * d = + roundedEllipsoidDenominatorExponent d K := by + rw [roundedEllipsoidDenominatorExponent] + ring + rw [roundedEllipsoidCoarseDenominator] + calc + 2048 * (d : β„š) ^ 6 * (d + 1) * d.factorial * (2 * M) ^ d ≀ + (2 : β„š) ^ 11 * ((2 : β„š) ^ d) ^ 6 * + (2 : β„š) ^ (d + 1) * (2 : β„š) ^ (d ^ 2) * + ((2 : β„š) ^ (K + 1)) ^ d := by + norm_num only [show (2048 : β„š) = 2 ^ 11 by norm_num] + gcongr + _ = (2 : β„š) ^ roundedEllipsoidDenominatorExponent d K := by + rw [← pow_mul, ← pow_mul] + simp only [← pow_add] + rw [hexponents] + +/-- A dyadic lower bound on the determinant and an upper bound on the basis +magnitude give an explicit upper bound on the next rounding precision. -/ +theorem roundedEllipsoidPrecision_le_of_magnitude_bounds {d L K : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det U.basis)) + (hM : rationalMatrixAbsBound U.basis ≀ (2 : β„š) ^ K) : + roundedEllipsoidPrecision U ≀ + L + roundedEllipsoidDenominatorExponent d K + 2 := by + let M := rationalMatrixAbsBound U.basis + let Ξ” := abs (Matrix.det U.basis) + let Q := roundedEllipsoidCoarseDenominator d M + let e := roundedEllipsoidDenominatorExponent d K + have hΞ”0 : 0 < Ξ” := + (dyadicMesh_pos L).trans_le (by simpa only [Ξ”] using hdetLower) + have hdet : Matrix.det U.basis β‰  0 := abs_pos.mp hΞ”0 + have hM0 : 0 ≀ M := (rationalMatrixAbsBound_pos U.basis).le + have hQ0 : 0 < Q := roundedEllipsoidCoarseDenominator_pos hd + (rationalMatrixAbsBound_pos U.basis) + have hQ : Q ≀ (2 : β„š) ^ e := by + simpa only [Q, M, e] using + roundedEllipsoidCoarseDenominator_le_two_pow hM0 hM + have hdyadic : dyadicMesh (L + e) ≀ Ξ” / Q := by + rw [dyadicMesh, pow_add] + rw [div_le_div_iffβ‚€ + (by positivity : (0 : β„š) < (2 : β„š) ^ L * (2 : β„š) ^ e) hQ0] + have hbase : (1 : β„š) ≀ Ξ” * (2 : β„š) ^ L := by + rw [← div_le_iffβ‚€ (by positivity : (0 : β„š) < (2 : β„š) ^ L)] + simpa only [dyadicMesh, Ξ”] using hdetLower + calc + 1 * Q = Q := by ring + _ ≀ (2 : β„š) ^ e := hQ + _ = 1 * (2 : β„š) ^ e := by ring + _ ≀ (Ξ” * (2 : β„š) ^ L) * (2 : β„š) ^ e := + mul_le_mul_of_nonneg_right hbase (by positivity) + _ = Ξ” * ((2 : β„š) ^ L * (2 : β„š) ^ e) := by ring + have htarget : dyadicMesh (L + e) ≀ roundedEllipsoidMeshTarget U := + hdyadic.trans (abs_det_div_coarseDenominator_le_meshTarget hd U) + rw [roundedEllipsoidPrecision] + exact positiveDyadicPrecision_le_of_dyadicMesh_le + (roundedEllipsoidMeshTarget_pos hd U hdet) htarget + +theorem coordinate_sq_le_finiteNormSq_rat {d : β„•} + (b : Fin d β†’ β„š) (i : Fin d) : + b i ^ 2 ≀ finiteNormSq b := by + rw [finiteNormSq, finiteDot, sq] + exact Finset.single_le_sum + (fun j _ ↦ mul_self_nonneg (b j)) (Finset.mem_univ i) + +theorem abs_mul_le_finiteNormSq_rat {d : β„•} + (b : Fin d β†’ β„š) (i j : Fin d) : + abs (b i * b j) ≀ finiteNormSq b := by + let x := abs (b i) + let y := abs (b j) + let N := finiteNormSq b + have hxi : x ^ 2 ≀ N := by + dsimp only [x, N] + simpa only [sq_abs] using coordinate_sq_le_finiteNormSq_rat b i + have hyi : y ^ 2 ≀ N := by + dsimp only [y, N] + simpa only [sq_abs] using coordinate_sq_le_finiteNormSq_rat b j + have hxy : 2 * x * y ≀ x ^ 2 + y ^ 2 := by + nlinarith [sq_nonneg (x - y)] + have hnonneg : 0 ≀ x * y := mul_nonneg (abs_nonneg _) (abs_nonneg _) + rw [abs_mul] + dsimp only [x, y, N] at hxi hyi hxy hnonneg ⊒ + nlinarith + +theorem rationalEllipsoidPerpScale_le_two {d : β„•} (hd : 0 < d) : + rationalEllipsoidPerpScale d ≀ 2 := by + have ha0 := rationalEllipsoidAlpha_pos hd + have ha := rationalEllipsoidAlpha_le_quarter hd + rw [rationalEllipsoidPerpScale] + nlinarith [sq_nonneg (rationalEllipsoidAlpha d - 1 / 4)] + +/-- Every entry of the square-root-free direction update has a universal +constant bound, independent of the scale of the cut normal. -/ +theorem abs_directionUpdateMatrix_le_four {d : β„•} (hd : 0 < d) + {b : Fin d β†’ β„š} (hb : b β‰  0) (i j : Fin d) : + abs (directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b i j) ≀ 4 := by + let A := rationalEllipsoidPerpScale d + let P := rationalEllipsoidParallelScale d + let N := finiteNormSq b + have hN0 : 0 < N := by + dsimp only [N, finiteNormSq, finiteDot] + have hnonneg : 0 ≀ βˆ‘ k, b k * b k := + Finset.sum_nonneg fun k _ ↦ mul_self_nonneg (b k) + have hne : (βˆ‘ k, b k * b k) β‰  0 := by + intro hz + apply hb + ext k + have hk := (Finset.sum_eq_zero_iff_of_nonneg + (fun l (_hl : l ∈ Finset.univ) ↦ mul_self_nonneg (b l))).1 + hz k (Finset.mem_univ k) + exact (mul_self_eq_zero.mp hk) + exact lt_of_le_of_ne hnonneg (Ne.symm hne) + have hA0 : 0 ≀ A := by + dsimp only [A] + exact (rationalEllipsoidPerpScale_pos d).le + have hA2 : A ≀ 2 := by + dsimp only [A] + exact rationalEllipsoidPerpScale_le_two hd + have hP0 : 0 ≀ P := by + dsimp only [P] + exact (rationalEllipsoidParallelScale_pos hd).le + have hdiff0 : 0 ≀ A - P := by + dsimp only [A, P] + exact sub_nonneg.mpr (rationalEllipsoidParallel_lt_perp hd).le + have hdiff2 : A - P ≀ 2 := by linarith + have hratio : abs (b i * b j) / N ≀ 1 := by + rw [div_le_one hN0] + exact abs_mul_le_finiteNormSq_rat b i j + have hratio0 : 0 ≀ abs (b i * b j) / N := + div_nonneg (abs_nonneg _) hN0.le + have hterm : + abs (((A - P) / N) * b i * b j) ≀ 2 := by + rw [show ((A - P) / N) * b i * b j = + (A - P) * (b i * b j) / N by ring, + abs_div, abs_mul, abs_of_nonneg hdiff0, abs_of_pos hN0] + rw [div_eq_mul_inv, mul_assoc, ← div_eq_mul_inv] + calc + (A - P) * (abs (b i * b j) / N) ≀ 2 * 1 := + mul_le_mul hdiff2 hratio hratio0 (by norm_num) + _ = 2 := by norm_num + have hdiag : abs (A * (if i = j then 1 else 0)) ≀ 2 := by + by_cases hij : i = j + Β· simp [hij, abs_of_nonneg hA0, hA2] + Β· simp [hij] + rw [directionUpdateMatrix] + exact (abs_sub _ _).trans (by linarith) + +/-- One exact cut increases the total basis `ℓ₁` magnitude by at most a +factor `4d`. -/ +theorem rationalEllipsoidCentralUpdate_basis_abs_sum_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + (βˆ‘ i, βˆ‘ j, abs ((rationalEllipsoidCentralUpdate E a).basis i j)) ≀ + 4 * d * (βˆ‘ i, βˆ‘ j, abs (E.basis i j)) := by + let b := rationalPulledBackNormal E a + let C := directionUpdateMatrix + (rationalEllipsoidPerpScale d) + (rationalEllipsoidParallelScale d) b + have hC : βˆ€ i j, abs (C i j) ≀ 4 := by + intro i j + exact abs_directionUpdateMatrix_le_four hd hb i j + have hentry : βˆ€ i j, + abs ((rationalEllipsoidCentralUpdate E a).basis i j) ≀ + βˆ‘ k, 4 * abs (E.basis i k) := by + intro i j + change abs ((E.basis * C) i j) ≀ _ + rw [Matrix.mul_apply] + calc + abs (βˆ‘ k, E.basis i k * C k j) ≀ + βˆ‘ k, abs (E.basis i k * C k j) := + Finset.abs_sum_le_sum_abs _ _ + _ ≀ βˆ‘ k, 4 * abs (E.basis i k) := by + apply Finset.sum_le_sum + intro k _ + rw [abs_mul] + nlinarith [abs_nonneg (E.basis i k), hC k j] + calc + (βˆ‘ i, βˆ‘ j, + abs ((rationalEllipsoidCentralUpdate E a).basis i j)) ≀ + βˆ‘ i, βˆ‘ _j : Fin d, βˆ‘ k, 4 * abs (E.basis i k) := by + exact Finset.sum_le_sum fun i _ ↦ + Finset.sum_le_sum fun j _ ↦ hentry i j + _ = 4 * d * (βˆ‘ i, βˆ‘ j, abs (E.basis i j)) := by + simp [Finset.mul_sum] + ring + +theorem rationalMatrixAbsBound_centralUpdate_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalMatrixAbsBound (rationalEllipsoidCentralUpdate E a).basis ≀ + 5 * d * rationalMatrixAbsBound E.basis := by + have hsum := rationalEllipsoidCentralUpdate_basis_abs_sum_le hd E a hb + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hT : 0 ≀ βˆ‘ i, βˆ‘ j, abs (E.basis i j) := + Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ abs_nonneg _ + rw [rationalMatrixAbsBound, rationalMatrixAbsBound] + calc + 1 + βˆ‘ i, βˆ‘ j, + abs ((rationalEllipsoidCentralUpdate E a).basis i j) ≀ + 1 + 4 * d * (βˆ‘ i, βˆ‘ j, abs (E.basis i j)) := + by simpa only [add_comm] using add_le_add_left hsum 1 + _ ≀ 5 * d * (1 + βˆ‘ i, βˆ‘ j, abs (E.basis i j)) := by + have hd0 : (0 : β„š) ≀ d := by positivity + nlinarith [mul_nonneg hd0 hT] + +/-- Positive `ℓ₁` magnitude bounds for centers and complete states. -/ +def rationalCenterAbsBound {d : β„•} (c : Fin d β†’ β„š) : β„š := + 1 + βˆ‘ i, abs (c i) + +/-- Adds the rational absolute bounds for an ellipsoid state's center and basis matrix. -/ +def rationalStateAbsBound {d : β„•} (E : RationalEllipsoidState d) : β„š := + rationalCenterAbsBound E.center + rationalMatrixAbsBound E.basis + +theorem rationalCenterAbsBound_one_le {d : β„•} (c : Fin d β†’ β„š) : + 1 ≀ rationalCenterAbsBound c := by + rw [rationalCenterAbsBound] + exact le_add_of_nonneg_right (Finset.sum_nonneg fun i _ ↦ abs_nonneg _) + +theorem rationalStateAbsBound_two_le {d : β„•} + (E : RationalEllipsoidState d) : + 2 ≀ rationalStateAbsBound E := by + rw [rationalStateAbsBound] + linarith [rationalCenterAbsBound_one_le E.center, + rationalMatrixAbsBound_one_le E.basis] + +theorem rationalMatrixAbsBound_le_rationalStateAbsBound {d : β„•} + (E : RationalEllipsoidState d) : + rationalMatrixAbsBound E.basis ≀ rationalStateAbsBound E := by + rw [rationalStateAbsBound] + linarith [rationalCenterAbsBound_one_le E.center] + +theorem abs_div_cutL1Scale_le_one {d : β„•} {b : Fin d β†’ β„š} + (hb : b β‰  0) (j : Fin d) : + abs (b j / cutL1Scale b) ≀ 1 := by + have hu := cutL1Scale_pos hb + rw [abs_div, abs_of_pos hu, div_le_one hu] + rw [cutL1Scale] + exact Finset.single_le_sum (fun k _ ↦ abs_nonneg (b k)) + (Finset.mem_univ j) + +theorem rationalCenterAbsBound_centralUpdate_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalCenterAbsBound (rationalEllipsoidCentralUpdate E a).center ≀ + rationalCenterAbsBound E.center + rationalMatrixAbsBound E.basis := by + let b := rationalPulledBackNormal E a + let u := cutL1Scale b + let Ξ± := rationalEllipsoidAlpha d + have hΞ±0 : 0 ≀ Ξ± := by + dsimp only [Ξ±] + exact (rationalEllipsoidAlpha_pos hd).le + have hΞ±1 : Ξ± ≀ 1 := by + dsimp only [Ξ±] + exact (rationalEllipsoidAlpha_le_quarter hd).trans (by norm_num) + have hratio : βˆ€ j, abs (b j / u) ≀ 1 := by + intro j + simpa only [b, u] using abs_div_cutL1Scale_le_one hb j + have hentry : βˆ€ i, + abs ((rationalEllipsoidCentralUpdate E a).center i) ≀ + abs (E.center i) + βˆ‘ j, abs (E.basis i j) := by + intro i + change abs (E.center i - Ξ± * βˆ‘ j, E.basis i j * (b j / u)) ≀ _ + calc + abs (E.center i - Ξ± * βˆ‘ j, E.basis i j * (b j / u)) ≀ + abs (E.center i) + abs (Ξ± * βˆ‘ j, + E.basis i j * (b j / u)) := abs_sub _ _ + _ ≀ abs (E.center i) + Ξ± * + βˆ‘ j, abs (E.basis i j * (b j / u)) := by + rw [abs_mul, abs_of_nonneg hΞ±0] + gcongr + exact Finset.abs_sum_le_sum_abs _ _ + _ ≀ abs (E.center i) + Ξ± * βˆ‘ j, abs (E.basis i j) := by + have hs : (βˆ‘ j, abs (E.basis i j * (b j / u))) ≀ + βˆ‘ j, abs (E.basis i j) := by + apply Finset.sum_le_sum + intro j _ + rw [abs_mul] + simpa only [mul_one] using mul_le_mul_of_nonneg_left + (hratio j) (abs_nonneg (E.basis i j)) + have hm := mul_le_mul_of_nonneg_left hs hΞ±0 + simpa only [add_comm] using + add_le_add_left hm (abs (E.center i)) + _ ≀ abs (E.center i) + βˆ‘ j, abs (E.basis i j) := by + have hrow : 0 ≀ βˆ‘ j, abs (E.basis i j) := + Finset.sum_nonneg fun j _ ↦ abs_nonneg _ + nlinarith + rw [rationalCenterAbsBound, rationalCenterAbsBound, + rationalMatrixAbsBound] + calc + 1 + βˆ‘ i, + abs ((rationalEllipsoidCentralUpdate E a).center i) ≀ + 1 + βˆ‘ i, (abs (E.center i) + βˆ‘ j, abs (E.basis i j)) := by + gcongr with i + exact hentry i + _ = (1 + βˆ‘ i, abs (E.center i)) + + (1 + βˆ‘ i, βˆ‘ j, abs (E.basis i j)) - 1 := by + rw [Finset.sum_add_distrib] + ring + _ ≀ (1 + βˆ‘ i, abs (E.center i)) + + (1 + βˆ‘ i, βˆ‘ j, abs (E.basis i j)) := by linarith + +theorem rationalStateAbsBound_centralUpdate_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalStateAbsBound (rationalEllipsoidCentralUpdate E a) ≀ + 6 * d * rationalStateAbsBound E := by + have hc := rationalCenterAbsBound_centralUpdate_le hd E a hb + have hB := rationalMatrixAbsBound_centralUpdate_le hd E a hb + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hc0 := rationalCenterAbsBound_one_le E.center + have hB0 := rationalMatrixAbsBound_one_le E.basis + rw [rationalStateAbsBound, rationalStateAbsBound] + calc + rationalCenterAbsBound (rationalEllipsoidCentralUpdate E a).center + + rationalMatrixAbsBound (rationalEllipsoidCentralUpdate E a).basis ≀ + (rationalCenterAbsBound E.center + rationalMatrixAbsBound E.basis) + + 5 * d * rationalMatrixAbsBound E.basis := add_le_add hc hB + _ ≀ 6 * d * + (rationalCenterAbsBound E.center + rationalMatrixAbsBound E.basis) := by + have hd0 : (0 : β„š) ≀ d := by positivity + have hBnonneg : 0 ≀ rationalMatrixAbsBound E.basis := by linarith + nlinarith [mul_nonneg hd0 hBnonneg] + +theorem roundedEllipsoidInflation_le_one {d : β„•} (hd : 0 < d) : + roundedEllipsoidInflation d ≀ 1 := by + rw [roundedEllipsoidInflation] + have hden : (1 : β„š) ≀ 1024 * d ^ 4 := by + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hd4 : (1 : β„š) ≀ (d : β„š) ^ 4 := one_le_powβ‚€ hdq + norm_num only [Nat.cast_pow, Nat.cast_ofNat] + nlinarith + exact (div_le_one (by positivity : (0 : β„š) < 1024 * d ^ 4)).2 hden + +/-- Rounding and inflation preserve a polynomial one-step magnitude bound. -/ +theorem rationalMatrixAbsBound_adaptiveRounded_le {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalMatrixAbsBound (adaptiveRoundedEllipsoid U).basis ≀ + 5 * d ^ 2 * rationalMatrixAbsBound U.basis := by + let M := rationalMatrixAbsBound U.basis + let p := roundedEllipsoidPrecision U + let Ξ· := roundedEllipsoidInflation d + have hM1 : (1 : β„š) ≀ M := rationalMatrixAbsBound_one_le U.basis + have hΞ·0 : 0 ≀ Ξ· := by + dsimp only [Ξ·] + exact roundedEllipsoidInflation_nonneg d + have hΞ·1 : Ξ· ≀ 1 := by + dsimp only [Ξ·] + exact roundedEllipsoidInflation_le_one hd + have hentry : βˆ€ i j, + abs ((adaptiveRoundedEllipsoid U).basis i j) ≀ 4 * M := by + intro i j + have hround := abs_dyadicFloor_le p (U.basis i j) + have hmesh := dyadicMesh_le_one p + have hU := (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hfloor : abs (dyadicFloor p (U.basis i j)) ≀ 2 * M := by + linarith + rw [adaptiveRoundedEllipsoid, inflatedDyadicRound_basis_apply, abs_mul, + abs_of_nonneg (by linarith : 0 ≀ 1 + Ξ·)] + calc + (1 + Ξ·) * abs (dyadicFloor p (U.basis i j)) ≀ 2 * (2 * M) := + mul_le_mul (by linarith) hfloor (abs_nonneg _) (by linarith) + _ = 4 * M := by ring + rw [rationalMatrixAbsBound] + calc + 1 + βˆ‘ i, βˆ‘ j, abs ((adaptiveRoundedEllipsoid U).basis i j) ≀ + 1 + βˆ‘ _i : Fin d, βˆ‘ _j : Fin d, 4 * M := by + have hs0 : (βˆ‘ i : Fin d, βˆ‘ j : Fin d, + abs ((adaptiveRoundedEllipsoid U).basis i j)) ≀ + βˆ‘ _i : Fin d, βˆ‘ _j : Fin d, 4 * M := by + apply Finset.sum_le_sum + intro i _ + apply Finset.sum_le_sum + intro j _ + exact hentry i j + have hs := add_le_add_left hs0 1 + simpa only [add_comm] using hs + _ = 1 + d ^ 2 * (4 * M) := by simp; ring + _ ≀ 5 * d ^ 2 * M := by + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + nlinarith [sq_nonneg ((d : β„š) - 1)] + +theorem rationalCenterAbsBound_adaptiveRounded_le {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalCenterAbsBound (adaptiveRoundedEllipsoid U).center ≀ + rationalCenterAbsBound U.center + d := by + let p := roundedEllipsoidPrecision U + have hentry : βˆ€ i, + abs ((adaptiveRoundedEllipsoid U).center i) ≀ abs (U.center i) + 1 := by + intro i + have h := abs_dyadicFloor_le p (U.center i) + have hm := dyadicMesh_le_one p + have hadd : abs (U.center i) + dyadicMesh p ≀ + abs (U.center i) + 1 := by linarith + change abs (dyadicFloor p (U.center i)) ≀ abs (U.center i) + 1 + exact h.le.trans hadd + rw [rationalCenterAbsBound, rationalCenterAbsBound] + calc + 1 + βˆ‘ i, abs ((adaptiveRoundedEllipsoid U).center i) ≀ + 1 + βˆ‘ i, (abs (U.center i) + 1) := by + gcongr with i + exact hentry i + _ = (1 + βˆ‘ i, abs (U.center i)) + d := by + rw [Finset.sum_add_distrib] + simp + ring + +theorem rationalStateAbsBound_adaptiveRounded_le {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalStateAbsBound (adaptiveRoundedEllipsoid U) ≀ + 7 * d ^ 2 * rationalStateAbsBound U := by + have hc := rationalCenterAbsBound_adaptiveRounded_le hd U + have hB := rationalMatrixAbsBound_adaptiveRounded_le hd U + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hT := rationalStateAbsBound_two_le U + have hc0 := rationalCenterAbsBound_one_le U.center + have hB0 := rationalMatrixAbsBound_one_le U.basis + rw [rationalStateAbsBound, rationalStateAbsBound] + calc + rationalCenterAbsBound (adaptiveRoundedEllipsoid U).center + + rationalMatrixAbsBound (adaptiveRoundedEllipsoid U).basis ≀ + (rationalCenterAbsBound U.center + d) + + 5 * d ^ 2 * rationalMatrixAbsBound U.basis := add_le_add hc hB + _ ≀ 7 * d ^ 2 * + (rationalCenterAbsBound U.center + rationalMatrixAbsBound U.basis) := by + have hBnonneg : 0 ≀ rationalMatrixAbsBound U.basis := by linarith + nlinarith [sq_nonneg ((d : β„š) - 1), + mul_nonneg (sq_nonneg (d : β„š)) hBnonneg] + +/-- A complete rounded cut grows the total basis magnitude by at most +`25 dΒ³`. -/ +theorem rationalMatrixAbsBound_adaptiveCentralUpdate_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidCentralUpdate E a).basis ≀ + 25 * d ^ 3 * rationalMatrixAbsBound E.basis := by + let U := rationalEllipsoidCentralUpdate E a + have hround := rationalMatrixAbsBound_adaptiveRounded_le hd U + have hexact := rationalMatrixAbsBound_centralUpdate_le hd E a hb + calc + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidCentralUpdate E a).basis = + rationalMatrixAbsBound (adaptiveRoundedEllipsoid U).basis := by rfl + _ ≀ 5 * d ^ 2 * rationalMatrixAbsBound U.basis := hround + _ ≀ 5 * d ^ 2 * (5 * d * rationalMatrixAbsBound E.basis) := + mul_le_mul_of_nonneg_left hexact (by positivity) + _ = 25 * d ^ 3 * rationalMatrixAbsBound E.basis := by ring + +theorem rationalStateAbsBound_adaptiveCentralUpdate_le {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalStateAbsBound (adaptiveRoundedEllipsoidCentralUpdate E a) ≀ + 42 * d ^ 3 * rationalStateAbsBound E := by + let U := rationalEllipsoidCentralUpdate E a + have hround := rationalStateAbsBound_adaptiveRounded_le hd U + have hexact := rationalStateAbsBound_centralUpdate_le hd E a hb + calc + rationalStateAbsBound (adaptiveRoundedEllipsoidCentralUpdate E a) = + rationalStateAbsBound (adaptiveRoundedEllipsoid U) := by rfl + _ ≀ 7 * d ^ 2 * rationalStateAbsBound U := hround + _ ≀ 7 * d ^ 2 * (6 * d * rationalStateAbsBound E) := + mul_le_mul_of_nonneg_left hexact (by positivity) + _ = 42 * d ^ 3 * rationalStateAbsBound E := by ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidIterationBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidIterationBounds.lean new file mode 100644 index 0000000000..96fe28be31 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidIterationBounds.lean @@ -0,0 +1,446 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidBitBounds +public import Mathlib.Tactic + +/-! # Rounded Ellipsoid Iteration Bounds -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Iterated size bounds + +This file turns the one-step determinant and magnitude estimates into a +uniform precision bound for every state in a regular rounded-cut sequence. +The bound is independent of feasibility: it uses only nonsingularity and +nonzero cuts. +-/ + +/-- Applies adaptive rounded central updates successively along a list of cut normals. -/ +def adaptiveRoundedEllipsoidIterate {d : β„•} : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ RationalEllipsoidState d + | E, [] => E + | E, a :: cuts => adaptiveRoundedEllipsoidIterate + (adaptiveRoundedEllipsoidCentralUpdate E a) cuts + +/-- Requires every cut normal to remain nonzero after pullback at its corresponding adaptively +updated ellipsoid state. -/ +def AdaptiveCutSequenceRegular {d : β„•} : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ Prop + | _, [] => True + | E, a :: cuts => + rationalPulledBackNormal E a β‰  0 ∧ + AdaptiveCutSequenceRegular + (adaptiveRoundedEllipsoidCentralUpdate E a) cuts + +theorem adaptiveRoundedEllipsoidIterate_append {d : β„•} + (E : RationalEllipsoidState d) + (xs ys : List (Fin d β†’ β„š)) : + adaptiveRoundedEllipsoidIterate E (xs ++ ys) = + adaptiveRoundedEllipsoidIterate + (adaptiveRoundedEllipsoidIterate E xs) ys := by + induction xs generalizing E with + | nil => simp [adaptiveRoundedEllipsoidIterate] + | cons a xs ih => + simp only [List.cons_append, adaptiveRoundedEllipsoidIterate] + exact ih _ + +theorem AdaptiveCutSequenceRegular.append_singleton {d : β„•} + (E : RationalEllipsoidState d) (xs : List (Fin d β†’ β„š)) + (a : Fin d β†’ β„š) + (hregular : AdaptiveCutSequenceRegular E xs) + (ha : rationalPulledBackNormal + (adaptiveRoundedEllipsoidIterate E xs) a β‰  0) : + AdaptiveCutSequenceRegular E (xs ++ [a]) := by + induction xs generalizing E with + | nil => exact ⟨ha, by simp [AdaptiveCutSequenceRegular]⟩ + | cons b xs ih => + exact ⟨hregular.1, ih _ hregular.2 ha⟩ + +theorem AdaptiveCutSequenceRegular.prefix_and_next {d : β„•} + (E : RationalEllipsoidState d) (pre suffix : List (Fin d β†’ β„š)) + (a : Fin d β†’ β„š) + (hregular : AdaptiveCutSequenceRegular E (pre ++ a :: suffix)) : + AdaptiveCutSequenceRegular E pre ∧ + rationalPulledBackNormal + (adaptiveRoundedEllipsoidIterate E pre) a β‰  0 := by + induction pre generalizing E with + | nil => + exact ⟨by simp [AdaptiveCutSequenceRegular], hregular.1⟩ + | cons b pre ih => + have htail := ih + (adaptiveRoundedEllipsoidCentralUpdate E b) hregular.2 + exact ⟨⟨hregular.1, htail.1⟩, htail.2⟩ + +theorem quarter_abs_det_le_adaptiveRoundedCentralUpdate_rat {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) : + (1 / 4 : β„š) * abs (Matrix.det E.basis) ≀ + abs (Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis) := by + have hreal := quarter_abs_det_le_adaptiveRoundedCentralUpdate + hd E a hdet hb + have hcast : + ((((1 / 4 : β„š) * abs (Matrix.det E.basis) : β„š) : β„š) : ℝ) ≀ + ((abs (Matrix.det + (adaptiveRoundedEllipsoidCentralUpdate E a).basis) : β„š) : ℝ) := by + norm_num only [Rat.cast_mul, Rat.cast_div, Rat.cast_one, + Rat.cast_ofNat] + exact_mod_cast hreal + exact Rat.cast_le.mp hcast + +theorem half_abs_det_le_rationalEllipsoidCentralUpdate {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + (1 / 2 : β„š) * abs (Matrix.det E.basis) ≀ + abs (Matrix.det (rationalEllipsoidCentralUpdate E a).basis) := by + let q : β„š := rationalEllipsoidPerpScale d ^ (d - 1) * + rationalEllipsoidParallelScale d + have hq : (1 / 2 : β„š) ≀ q := by + have hperp : (1 : β„š) ≀ rationalEllipsoidPerpScale d := by + rw [rationalEllipsoidPerpScale] + norm_num + positivity + have hpow : (1 : β„š) ≀ + rationalEllipsoidPerpScale d ^ (d - 1) := one_le_powβ‚€ hperp + have hparallel : (3 / 4 : β„š) ≀ + rationalEllipsoidParallelScale d := + rationalEllipsoidParallelScale_ge_three_quarters hd + dsimp only [q] + calc + (1 / 2 : β„š) ≀ 1 * (3 / 4 : β„š) := by norm_num + _ ≀ rationalEllipsoidPerpScale d ^ (d - 1) * + rationalEllipsoidParallelScale d := + mul_le_mul hpow hparallel (by norm_num) (by positivity) + have hq0 : 0 ≀ q := hq.trans' (by norm_num) + rw [det_rationalEllipsoidCentralUpdate hd E a hb, abs_mul, + abs_of_nonneg hq0] + simpa only [mul_comm] using + (mul_le_mul_of_nonneg_left hq (abs_nonneg (Matrix.det E.basis))) + +theorem dyadicMesh_succ_eq_half_mul (L : β„•) : + dyadicMesh (L + 1) = (1 / 2 : β„š) * dyadicMesh L := by + unfold dyadicMesh + rw [pow_add] + norm_num + +theorem rationalEllipsoidCentralUpdate_dyadic_det_lower {d L : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) : + dyadicMesh (L + 1) ≀ + abs (Matrix.det (rationalEllipsoidCentralUpdate E a).basis) := by + rw [dyadicMesh_succ_eq_half_mul] + exact (mul_le_mul_of_nonneg_left hdetLower (by norm_num)).trans + (half_abs_det_le_rationalEllipsoidCentralUpdate hd E a hb) + +theorem rationalEllipsoidExactGrowthFactor_le_two_pow (d : β„•) : + (6 * d : β„š) ≀ (2 : β„š) ^ (3 + d) := by + have hd := natCast_le_two_pow_self d + calc + (6 * d : β„š) ≀ 8 * (2 : β„š) ^ d := by nlinarith + _ = (2 : β„š) ^ (3 + d) := by + rw [show (8 : β„š) = 2 ^ 3 by norm_num, ← pow_add] + +theorem rationalEllipsoidCentralUpdate_two_pow_state_magnitude_upper + {d K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (a : Fin d β†’ β„š) (hb : rationalPulledBackNormal E a β‰  0) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) : + rationalStateAbsBound (rationalEllipsoidCentralUpdate E a) ≀ + (2 : β„š) ^ (K + 3 + d) := by + have hstep := rationalStateAbsBound_centralUpdate_le hd E a hb + have hfactor := rationalEllipsoidExactGrowthFactor_le_two_pow d + have hstate0 : 0 ≀ rationalStateAbsBound E := by + linarith [rationalStateAbsBound_two_le E] + calc + rationalStateAbsBound (rationalEllipsoidCentralUpdate E a) ≀ + 6 * d * rationalStateAbsBound E := hstep + _ ≀ (2 : β„š) ^ (3 + d) * (2 : β„š) ^ K := + mul_le_mul hfactor hM hstate0 (by positivity) + _ = (2 : β„š) ^ (K + 3 + d) := by + rw [← pow_add] + congr 1 + omega + +/-- Precision used inside the next rounded update. This is the missing +intermediate-state estimate: precision is computed after the exact central +cut and before the state is rounded. -/ +theorem rationalEllipsoidCentralUpdate_precision_upper + {d L K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (a : Fin d β†’ β„š) (hb : rationalPulledBackNormal E a β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) : + roundedEllipsoidPrecision (rationalEllipsoidCentralUpdate E a) ≀ + (L + 1) + roundedEllipsoidDenominatorExponent d (K + 3 + d) + 2 := by + apply roundedEllipsoidPrecision_le_of_magnitude_bounds hd + Β· exact rationalEllipsoidCentralUpdate_dyadic_det_lower + hd E a hb hdetLower + Β· exact (rationalMatrixAbsBound_le_rationalStateAbsBound + (rationalEllipsoidCentralUpdate E a)).trans + (rationalEllipsoidCentralUpdate_two_pow_state_magnitude_upper + hd E a hb hM) + +/-- Computes the next precision bound from the accumulated radius term and dimension-dependent +denominator exponent. -/ +def roundedEllipsoidNextPrecisionBound (d L K t : β„•) : β„• := + (L + 2 * t + 1) + + roundedEllipsoidDenominatorExponent d + (K + t * (6 + 3 * d) + 3 + d) + 2 + +theorem adaptiveRoundedEllipsoidIterate_det_lower {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + (1 / 4 : β„š) ^ cuts.length * abs (Matrix.det E.basis) ≀ + abs (Matrix.det (adaptiveRoundedEllipsoidIterate E cuts).basis) := by + induction cuts generalizing E with + | nil => simp [adaptiveRoundedEllipsoidIterate] + | cons a cuts ih => + have hb := hregular.1 + let E' := adaptiveRoundedEllipsoidCentralUpdate E a + have hdet' : Matrix.det E'.basis β‰  0 := + det_adaptiveRoundedEllipsoidCentralUpdate_ne_zero hd E a hdet hb + have hstep := quarter_abs_det_le_adaptiveRoundedCentralUpdate_rat + hd E a hdet hb + have htail := ih E' hdet' hregular.2 + rw [adaptiveRoundedEllipsoidIterate, List.length_cons, pow_succ] + calc + (1 / 4 : β„š) ^ cuts.length * (1 / 4) * + abs (Matrix.det E.basis) = + (1 / 4 : β„š) ^ cuts.length * + ((1 / 4) * abs (Matrix.det E.basis)) := by ring + _ ≀ (1 / 4 : β„š) ^ cuts.length * abs (Matrix.det E'.basis) := + mul_le_mul_of_nonneg_left hstep (by positivity) + _ ≀ abs (Matrix.det + (adaptiveRoundedEllipsoidIterate E' cuts).basis) := htail + +theorem adaptiveRoundedEllipsoidIterate_magnitude_upper {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidIterate E cuts).basis ≀ + (25 * d ^ 3 : β„š) ^ cuts.length * + rationalMatrixAbsBound E.basis := by + induction cuts generalizing E with + | nil => simp [adaptiveRoundedEllipsoidIterate] + | cons a cuts ih => + have hb := hregular.1 + let E' := adaptiveRoundedEllipsoidCentralUpdate E a + have hstep := rationalMatrixAbsBound_adaptiveCentralUpdate_le + hd E a hb + have htail := ih E' hregular.2 + rw [adaptiveRoundedEllipsoidIterate, List.length_cons, pow_succ] + calc + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidIterate E' cuts).basis ≀ + (25 * d ^ 3 : β„š) ^ cuts.length * + rationalMatrixAbsBound E'.basis := htail + _ ≀ (25 * d ^ 3 : β„š) ^ cuts.length * + (25 * d ^ 3 * rationalMatrixAbsBound E.basis) := + mul_le_mul_of_nonneg_left hstep (by positivity) + _ = (25 * d ^ 3 : β„š) ^ cuts.length * + (25 * d ^ 3) * rationalMatrixAbsBound E.basis := by ring + +/-- The same iteration estimate for the center and basis together. This is +the quantity needed to bound the encoding of every stored ellipsoid state. -/ +theorem adaptiveRoundedEllipsoidIterate_state_magnitude_upper {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + rationalStateAbsBound (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (42 * d ^ 3 : β„š) ^ cuts.length * rationalStateAbsBound E := by + induction cuts generalizing E with + | nil => simp [adaptiveRoundedEllipsoidIterate] + | cons a cuts ih => + have hb := hregular.1 + let E' := adaptiveRoundedEllipsoidCentralUpdate E a + have hstep := rationalStateAbsBound_adaptiveCentralUpdate_le + hd E a hb + have htail := ih E' hregular.2 + rw [adaptiveRoundedEllipsoidIterate, List.length_cons, pow_succ] + calc + rationalStateAbsBound (adaptiveRoundedEllipsoidIterate E' cuts) ≀ + (42 * d ^ 3 : β„š) ^ cuts.length * + rationalStateAbsBound E' := htail + _ ≀ (42 * d ^ 3 : β„š) ^ cuts.length * + (42 * d ^ 3 * rationalStateAbsBound E) := + mul_le_mul_of_nonneg_left hstep (by positivity) + _ = (42 * d ^ 3 : β„š) ^ cuts.length * + (42 * d ^ 3) * rationalStateAbsBound E := by ring + +theorem dyadicMesh_add_two_mul (L t : β„•) : + dyadicMesh (L + 2 * t) = + (1 / 4 : β„š) ^ t * dyadicMesh L := by + unfold dyadicMesh + rw [pow_add, pow_mul] + norm_num only [pow_two] + rw [show (1 / 4 : β„š) ^ t = 1 / (4 : β„š) ^ t by + simp only [one_div, inv_pow]] + ring + +theorem adaptiveRoundedEllipsoidIterate_dyadic_det_lower {d L : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + dyadicMesh (L + 2 * cuts.length) ≀ + abs (Matrix.det (adaptiveRoundedEllipsoidIterate E cuts).basis) := by + rw [dyadicMesh_add_two_mul] + calc + (1 / 4 : β„š) ^ cuts.length * dyadicMesh L ≀ + (1 / 4 : β„š) ^ cuts.length * abs (Matrix.det E.basis) := + mul_le_mul_of_nonneg_left hdetLower (by positivity) + _ ≀ abs (Matrix.det + (adaptiveRoundedEllipsoidIterate E cuts).basis) := + adaptiveRoundedEllipsoidIterate_det_lower hd E hdet cuts hregular + +theorem roundedEllipsoidGrowthFactor_le_two_pow (d : β„•) : + (25 * d ^ 3 : β„š) ≀ (2 : β„š) ^ (5 + 3 * d) := by + have hd := natCast_le_two_pow_self d + have hd3 : (d : β„š) ^ 3 ≀ ((2 : β„š) ^ d) ^ 3 := + pow_le_pow_leftβ‚€ (by positivity) hd 3 + calc + (25 * d ^ 3 : β„š) ≀ 32 * ((2 : β„š) ^ d) ^ 3 := by + nlinarith [show (0 : β„š) ≀ (d : β„š) ^ 3 by positivity] + _ = (2 : β„š) ^ (5 + 3 * d) := by + rw [show (32 : β„š) = 2 ^ 5 by norm_num, ← pow_mul, ← pow_add] + congr 1 + omega + +theorem roundedEllipsoidStateGrowthFactor_le_two_pow (d : β„•) : + (42 * d ^ 3 : β„š) ≀ (2 : β„š) ^ (6 + 3 * d) := by + have hd := natCast_le_two_pow_self d + have hd3 : (d : β„š) ^ 3 ≀ ((2 : β„š) ^ d) ^ 3 := + pow_le_pow_leftβ‚€ (by positivity) hd 3 + calc + (42 * d ^ 3 : β„š) ≀ 64 * ((2 : β„š) ^ d) ^ 3 := by + nlinarith [show (0 : β„š) ≀ (d : β„š) ^ 3 by positivity] + _ = (2 : β„š) ^ (6 + 3 * d) := by + rw [show (64 : β„š) = 2 ^ 6 by norm_num, ← pow_mul, ← pow_add] + congr 1 + omega + +/-- The affine magnitude exponent `K + t * (5 + 3 * d)` after `t` updates. -/ +def roundedEllipsoidMagnitudeExponent (d K t : β„•) : β„• := + K + t * (5 + 3 * d) + +/-- The affine state-magnitude exponent `K + t * (6 + 3 * d)` after `t` updates. -/ +def roundedEllipsoidStateMagnitudeExponent (d K t : β„•) : β„• := + K + t * (6 + 3 * d) + +theorem adaptiveRoundedEllipsoidIterate_two_pow_magnitude_upper + {d K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (hM : rationalMatrixAbsBound E.basis ≀ (2 : β„š) ^ K) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidIterate E cuts).basis ≀ + (2 : β„š) ^ roundedEllipsoidMagnitudeExponent d K cuts.length := by + have hiter := adaptiveRoundedEllipsoidIterate_magnitude_upper + hd E cuts hregular + have hfactor := roundedEllipsoidGrowthFactor_le_two_pow d + have hpow : (25 * d ^ 3 : β„š) ^ cuts.length ≀ + ((2 : β„š) ^ (5 + 3 * d)) ^ cuts.length := + pow_le_pow_leftβ‚€ (by positivity) hfactor cuts.length + calc + rationalMatrixAbsBound + (adaptiveRoundedEllipsoidIterate E cuts).basis ≀ + (25 * d ^ 3 : β„š) ^ cuts.length * + rationalMatrixAbsBound E.basis := hiter + _ ≀ ((2 : β„š) ^ (5 + 3 * d)) ^ cuts.length * + (2 : β„š) ^ K := + mul_le_mul hpow hM (rationalMatrixAbsBound_pos E.basis).le + (by positivity) + _ = (2 : β„š) ^ + roundedEllipsoidMagnitudeExponent d K cuts.length := by + rw [← pow_mul, ← pow_add] + rw [roundedEllipsoidMagnitudeExponent] + congr 1 + ring + +theorem adaptiveRoundedEllipsoidIterate_two_pow_state_magnitude_upper + {d K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + rationalStateAbsBound (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (2 : β„š) ^ + roundedEllipsoidStateMagnitudeExponent d K cuts.length := by + have hiter := adaptiveRoundedEllipsoidIterate_state_magnitude_upper + hd E cuts hregular + have hfactor := roundedEllipsoidStateGrowthFactor_le_two_pow d + have hpow : (42 * d ^ 3 : β„š) ^ cuts.length ≀ + ((2 : β„š) ^ (6 + 3 * d)) ^ cuts.length := + pow_le_pow_leftβ‚€ (by positivity) hfactor cuts.length + have hstate0 : 0 ≀ rationalStateAbsBound E := by + linarith [rationalStateAbsBound_two_le E] + calc + rationalStateAbsBound (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (42 * d ^ 3 : β„š) ^ cuts.length * + rationalStateAbsBound E := hiter + _ ≀ ((2 : β„š) ^ (6 + 3 * d)) ^ cuts.length * (2 : β„š) ^ K := + mul_le_mul hpow hM hstate0 (by positivity) + _ = (2 : β„š) ^ + roundedEllipsoidStateMagnitudeExponent d K cuts.length := by + rw [← pow_mul, ← pow_add] + rw [roundedEllipsoidStateMagnitudeExponent] + congr 1 + ring + +/-- Uniform bound for the proof-specification precision of the next exact +central cut after any regular prefix. A machine implementation may pass any +a-priori scheduled precision at least this large. -/ +theorem adaptiveRoundedEllipsoidIterate_next_precision_upper + {d L K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) + (pre : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E pre) + (a : Fin d β†’ β„š) + (ha : rationalPulledBackNormal + (adaptiveRoundedEllipsoidIterate E pre) a β‰  0) : + roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate + (adaptiveRoundedEllipsoidIterate E pre) a) ≀ + roundedEllipsoidNextPrecisionBound d L K pre.length := by + have hdetPrefix := adaptiveRoundedEllipsoidIterate_dyadic_det_lower + hd E hdet hdetLower pre hregular + have hMPrefix := + adaptiveRoundedEllipsoidIterate_two_pow_state_magnitude_upper + hd E hM pre hregular + have h := rationalEllipsoidCentralUpdate_precision_upper hd + (adaptiveRoundedEllipsoidIterate E pre) a ha hdetPrefix hMPrefix + simpa only [roundedEllipsoidNextPrecisionBound, + roundedEllipsoidStateMagnitudeExponent] using h + +/-- Explicit polynomial precision bound at every reachable state. -/ +theorem adaptiveRoundedEllipsoidIterate_precision_upper + {d L K : β„•} (hd : 0 < d) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalMatrixAbsBound E.basis ≀ (2 : β„š) ^ K) + (cuts : List (Fin d β†’ β„š)) + (hregular : AdaptiveCutSequenceRegular E cuts) : + roundedEllipsoidPrecision (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (L + 2 * cuts.length) + + roundedEllipsoidDenominatorExponent d + (roundedEllipsoidMagnitudeExponent d K cuts.length) + 2 := by + exact roundedEllipsoidPrecision_le_of_magnitude_bounds hd _ + (adaptiveRoundedEllipsoidIterate_dyadic_det_lower + hd E hdet hdetLower cuts hregular) + (adaptiveRoundedEllipsoidIterate_two_pow_magnitude_upper + hd E hM cuts hregular) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidScales.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidScales.lean new file mode 100644 index 0000000000..224f4ad7ff --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedEllipsoidScales.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.DyadicMagnitudePrecision +public import Mathlib.LinearAlgebra.Matrix.Integer +public import Mathlib.Tactic + +/-! # Rounded Ellipsoid Scales -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Quantitative bounded-bit ellipsoid scales + +The exact determinant defines the least precision needed in the semantic +rounding proof. We also prove a determinant-free lower bound by clearing +entry denominators. The final bit-model implementation must use an a-priori +schedule dominating the semantic precision: Mathlib's specification of +`Matrix.det` is not the algorithm used by the optimizer. +-/ + +/-- A positive rational bound for every absolute matrix entry. -/ +def rationalMatrixAbsBound {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : β„š := + 1 + βˆ‘ i, βˆ‘ j, abs (A i j) + +theorem rationalMatrixAbsBound_pos {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : 0 < rationalMatrixAbsBound A := by + rw [rationalMatrixAbsBound] + have hsum : 0 ≀ βˆ‘ i, βˆ‘ j, abs (A i j) := + Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ abs_nonneg _ + linarith + +theorem abs_entry_lt_rationalMatrixAbsBound {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (i j : Fin d) : + abs (A i j) < rationalMatrixAbsBound A := by + rw [rationalMatrixAbsBound] + have hrow : abs (A i j) ≀ βˆ‘ k, abs (A i k) := + Finset.single_le_sum (fun k _ ↦ abs_nonneg (A i k)) (Finset.mem_univ j) + have hall : (βˆ‘ k, abs (A i k)) ≀ βˆ‘ l, βˆ‘ k, abs (A l k) := + Finset.single_le_sum + (fun l _ ↦ Finset.sum_nonneg fun k _ ↦ abs_nonneg (A l k)) + (Finset.mem_univ i) + linarith + +/-- Inflation per rounded update. Its logarithmic size is polynomial in the +dimension, while its determinant cost is much smaller than the exact +central-cut contraction. -/ +def roundedEllipsoidInflation (d : β„•) : β„š := + 1 / (1024 * d ^ 4) + +theorem roundedEllipsoidInflation_pos {d : β„•} (hd : 0 < d) : + 0 < roundedEllipsoidInflation d := by + rw [roundedEllipsoidInflation] + positivity + +theorem roundedEllipsoidInflation_nonneg (d : β„•) : + 0 ≀ roundedEllipsoidInflation d := by + by_cases hd : d = 0 + Β· simp [roundedEllipsoidInflation, hd] + Β· exact (roundedEllipsoidInflation_pos (Nat.pos_of_ne_zero hd)).le + +/-- Coefficient multiplying the mesh in the determinant perturbation bound. -/ +def roundedDeterminantCoefficient (d : β„•) (M : β„š) : β„š := + d.factorial * d * (2 * M) ^ d + +/-- Coefficient multiplying the mesh in the adjugate correction bound. -/ +def roundedInverseCoefficient (d : β„•) (M : β„š) : β„š := + d * (d.factorial * (2 * M) ^ d) * (d + 1) + +theorem roundedDeterminantCoefficient_pos {d : β„•} (hd : 0 < d) + {M : β„š} (hM : 0 < M) : + 0 < roundedDeterminantCoefficient d M := by + rw [roundedDeterminantCoefficient] + positivity + +theorem roundedInverseCoefficient_pos {d : β„•} (hd : 0 < d) + {M : β„š} (hM : 0 < M) : + 0 < roundedInverseCoefficient d M := by + rw [roundedInverseCoefficient] + positivity + +/-- The allowed mesh for rounding an exact one-step state. -/ +def roundedEllipsoidMeshTarget {d : β„•} + (U : RationalEllipsoidState d) : β„š := + let M := rationalMatrixAbsBound U.basis + let Ξ” := abs (Matrix.det U.basis) + min + (Ξ” / (128 * d ^ 3 * roundedDeterminantCoefficient d M)) + (roundedEllipsoidInflation d * Ξ” / + (2 * d * roundedInverseCoefficient d M)) + +/-- A common denominator dominating both adaptive rounding constraints. -/ +def roundedEllipsoidCoarseDenominator (d : β„•) (M : β„š) : β„š := + 2048 * d ^ 6 * (d + 1) * d.factorial * (2 * M) ^ d + +theorem roundedEllipsoidCoarseDenominator_pos {d : β„•} (hd : 0 < d) + {M : β„š} (hM : 0 < M) : + 0 < roundedEllipsoidCoarseDenominator d M := by + rw [roundedEllipsoidCoarseDenominator] + positivity + +/-- A determinant lower bound computed without evaluating the determinant. +`Matrix.den` is the least common multiple of the entry denominators. -/ +def rationalMatrixDeterminantLower {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : β„š := + 1 / (A.den : β„š) ^ d + +theorem rationalMatrixDeterminantLower_pos {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) : + 0 < rationalMatrixDeterminantLower A := by + rw [rationalMatrixDeterminantLower] + have hdenNat : 0 < A.den := Nat.pos_of_ne_zero A.den_ne_zero + have hden : (0 : β„š) < A.den := by exact_mod_cast hdenNat + exact div_pos (by norm_num) (pow_pos hden d) + +/-- Clearing the common entry denominator turns the determinant into a +nonzero integer. Hence a nonzero rational determinant has magnitude at least +the reciprocal `d`-th power of that denominator. -/ +theorem rationalMatrixDeterminantLower_le_abs_det {d : β„•} + (A : Matrix (Fin d) (Fin d) β„š) (hdet : Matrix.det A β‰  0) : + rationalMatrixDeterminantLower A ≀ abs (Matrix.det A) := by + have hmatrix := A.inv_denom_smul_num + have hdetEq := congrArg Matrix.det hmatrix + rw [Matrix.det_smul, Fintype.card_fin, ← Int.cast_det] at hdetEq + let z : β„€ := Matrix.det A.num + have hnumdet : z β‰  0 := by + intro hz + apply hdet + rw [← hdetEq] + change (A.den : β„š)⁻¹ ^ d * (z : β„š) = 0 + rw [hz] + simp + have hint : (1 : β„€) ≀ abs z := Int.one_le_abs hnumdet + have hintQ : (1 : β„š) ≀ ((abs z : β„€) : β„š) := by + exact_mod_cast hint + rw [rationalMatrixDeterminantLower, ← hdetEq, abs_mul, abs_pow, + abs_inv, abs_of_nonneg (by positivity : (0 : β„š) ≀ (A.den : β„š)), + ← Int.cast_abs] + simpa only [one_div, inv_pow, mul_one, z] using + mul_le_mul_of_nonneg_left hintQ (by positivity : + 0 ≀ ((A.den : β„š)⁻¹) ^ d) + +/-- A positive mesh target computed only from entry arithmetic. -/ +def determinantFreeRoundedMeshTarget {d : β„•} + (U : RationalEllipsoidState d) : β„š := + rationalMatrixDeterminantLower U.basis / + roundedEllipsoidCoarseDenominator d + (rationalMatrixAbsBound U.basis) + +theorem determinantFreeRoundedMeshTarget_pos {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) : + 0 < determinantFreeRoundedMeshTarget U := by + rw [determinantFreeRoundedMeshTarget] + exact div_pos (rationalMatrixDeterminantLower_pos U.basis) + (roundedEllipsoidCoarseDenominator_pos hd + (rationalMatrixAbsBound_pos U.basis)) + +/-- Both determinant and inverse-error constraints are implied by one +coarse lower bound. -/ +theorem abs_det_div_coarseDenominator_le_meshTarget {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + abs (Matrix.det U.basis) / + roundedEllipsoidCoarseDenominator d + (rationalMatrixAbsBound U.basis) ≀ + roundedEllipsoidMeshTarget U := by + let M := rationalMatrixAbsBound U.basis + let Ξ” := abs (Matrix.det U.basis) + let Q := roundedEllipsoidCoarseDenominator d M + have hM : 0 < M := rationalMatrixAbsBound_pos U.basis + have hQ : 0 < Q := roundedEllipsoidCoarseDenominator_pos hd hM + have hΞ” : 0 ≀ Ξ” := abs_nonneg _ + rw [roundedEllipsoidMeshTarget] + apply le_min + Β· have hsmallDen : + 128 * (d : β„š) ^ 3 * roundedDeterminantCoefficient d M ≀ Q := by + have hfactor : (1 : β„š) ≀ 16 * d ^ 2 * (d + 1) := by + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hd2 : (1 : β„š) ≀ (d : β„š) ^ 2 := one_le_powβ‚€ hdq + nlinarith + have hbase : 0 ≀ + 128 * (d : β„š) ^ 3 * roundedDeterminantCoefficient d M := by + rw [roundedDeterminantCoefficient] + positivity + have heq : Q = + (128 * (d : β„š) ^ 3 * roundedDeterminantCoefficient d M) * + (16 * d ^ 2 * (d + 1)) := by + dsimp only [Q] + rw [roundedEllipsoidCoarseDenominator, + roundedDeterminantCoefficient] + push_cast + ring + rw [heq] + simpa only [mul_one] using mul_le_mul_of_nonneg_left hfactor hbase + exact div_le_div_of_nonneg_left hΞ” + (by + rw [roundedDeterminantCoefficient] + positivity) hsmallDen + Β· have heq : + roundedEllipsoidInflation d * Ξ” / + (2 * d * roundedInverseCoefficient d M) = Ξ” / Q := by + dsimp only [Q] + rw [roundedEllipsoidInflation, roundedInverseCoefficient, + roundedEllipsoidCoarseDenominator] + push_cast + field_simp [Nat.ne_of_gt hd, hM.ne'] + <;> ring + rw [heq] + +theorem determinantFreeRoundedMeshTarget_le {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) : + determinantFreeRoundedMeshTarget U ≀ roundedEllipsoidMeshTarget U := by + exact (div_le_div_of_nonneg_right + (rationalMatrixDeterminantLower_le_abs_det U.basis hdet) + (roundedEllipsoidCoarseDenominator_pos hd + (rationalMatrixAbsBound_pos U.basis)).le).trans + (abs_det_div_coarseDenominator_le_meshTarget hd U) + +/-- Mathematical lower bound on the number of fractional bits needed by one +rounded update. This quantity is used only as a proof specification: the +eventual machine uses an a priori schedule proved to dominate it and does not +evaluate a determinant. -/ +def roundedEllipsoidPrecision {d : β„•} + (U : RationalEllipsoidState d) : β„• := + positiveDyadicPrecision (roundedEllipsoidMeshTarget U) + +theorem dyadicMesh_eq_half_pow (p : β„•) : + dyadicMesh p = (1 / 2 : β„š) ^ p := by + simp [dyadicMesh, div_pow] + +theorem roundedEllipsoidMeshTarget_pos {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) : + 0 < roundedEllipsoidMeshTarget U := by + let M := rationalMatrixAbsBound U.basis + have hM : 0 < M := rationalMatrixAbsBound_pos U.basis + have hΞ” : 0 < abs (Matrix.det U.basis) := abs_pos.mpr hdet + rw [roundedEllipsoidMeshTarget] + apply lt_min + Β· exact div_pos hΞ” (by + have hc := roundedDeterminantCoefficient_pos hd hM + positivity) + Β· exact div_pos + (mul_pos (roundedEllipsoidInflation_pos hd) hΞ”) + (by + have hc := roundedInverseCoefficient_pos hd hM + positivity) + +theorem adaptive_dyadicMesh_lt_target {d : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) : + dyadicMesh (roundedEllipsoidPrecision U) < + roundedEllipsoidMeshTarget U := by + rw [roundedEllipsoidPrecision] + exact dyadicMesh_positiveDyadicPrecision_lt + (roundedEllipsoidMeshTarget_pos hd U hdet) + +theorem adaptive_dyadicMesh_lt_determinant_threshold {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) : + dyadicMesh (roundedEllipsoidPrecision U) < + abs (Matrix.det U.basis) / + (128 * d ^ 3 * roundedDeterminantCoefficient d + (rationalMatrixAbsBound U.basis)) := by + exact (adaptive_dyadicMesh_lt_target hd U hdet).trans_le + (min_le_left _ _) + +theorem adaptive_dyadicMesh_lt_inverse_threshold {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) : + dyadicMesh (roundedEllipsoidPrecision U) < + roundedEllipsoidInflation d * abs (Matrix.det U.basis) / + (2 * d * roundedInverseCoefficient d + (rationalMatrixAbsBound U.basis)) := by + exact (adaptive_dyadicMesh_lt_target hd U hdet).trans_le + (min_le_right _ _) + +theorem adaptive_determinant_rounding_loss_lt {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) : + roundedDeterminantCoefficient d (rationalMatrixAbsBound U.basis) * + dyadicMesh (roundedEllipsoidPrecision U) < + abs (Matrix.det U.basis) / (128 * d ^ 3) := by + let C := roundedDeterminantCoefficient d + (rationalMatrixAbsBound U.basis) + have hC : 0 < C := roundedDeterminantCoefficient_pos hd + (rationalMatrixAbsBound_pos U.basis) + have hmesh := adaptive_dyadicMesh_lt_determinant_threshold hd U hdet + have hmul := mul_lt_mul_of_pos_left hmesh hC + change C * dyadicMesh (roundedEllipsoidPrecision U) < _ + calc + C * dyadicMesh (roundedEllipsoidPrecision U) < + C * (abs (Matrix.det U.basis) / (128 * d ^ 3 * C)) := hmul + _ = abs (Matrix.det U.basis) / (128 * d ^ 3) := by + field_simp [hC.ne'] + +theorem adaptive_inverse_rounding_loss_lt {d : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) : + roundedInverseCoefficient d (rationalMatrixAbsBound U.basis) * + dyadicMesh (roundedEllipsoidPrecision U) < + roundedEllipsoidInflation d * abs (Matrix.det U.basis) / + (2 * d) := by + let C := roundedInverseCoefficient d + (rationalMatrixAbsBound U.basis) + have hC : 0 < C := roundedInverseCoefficient_pos hd + (rationalMatrixAbsBound_pos U.basis) + have hmesh := adaptive_dyadicMesh_lt_inverse_threshold hd U hdet + have hmul := mul_lt_mul_of_pos_left hmesh hC + change C * dyadicMesh (roundedEllipsoidPrecision U) < _ + calc + C * dyadicMesh (roundedEllipsoidPrecision U) < + C * (roundedEllipsoidInflation d * abs (Matrix.det U.basis) / + (2 * d * C)) := hmul + _ = roundedEllipsoidInflation d * abs (Matrix.det U.basis) / + (2 * d) := by + field_simp [hC.ne', Nat.ne_of_gt hd] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibility.lean new file mode 100644 index 0000000000..2a25340baa --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibility.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.AdaptiveRoundedEllipsoid +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import Mathlib.Tactic + +/-! # Rounded Feasibility -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Bounded-bit rational feasibility + +This is the executable feasibility loop used by the optimizer. It differs +from `runRationalFeasibility` only in replacing the exact central update by +the adaptive rounded update. The proofs below re-establish acceptance, +target preservation, nonsingularity, and finite termination with the weaker +rounded contraction constant. +-/ + +/-- Runs the central oracle until it accepts the current center or the budget is exhausted, +applying adaptive rounded updates after cuts. -/ +def runRoundedRationalFeasibility {d : β„•} + (oracle : RationalCentralOracle d) : + β„• β†’ RationalEllipsoidState d β†’ RationalFeasibilityResult d + | 0, E => .exhausted E + | budget + 1, E => + match oracle E with + | .accept => .accepted E.center + | .cut a => + runRoundedRationalFeasibility oracle budget + (adaptiveRoundedEllipsoidCentralUpdate E a) + +theorem runRoundedRationalFeasibility_acceptsOnly {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} {oracle : RationalCentralOracle d} + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {budget : β„•} {E : RationalEllipsoidState d} {x : Fin d β†’ β„š} + (hrun : runRoundedRationalFeasibility oracle budget E = .accepted x) : + Good x := by + induction budget generalizing E with + | zero => simp [runRoundedRationalFeasibility] at hrun + | succ budget ih => + rw [runRoundedRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· cases hrun + exact haccept E hresponse + Β· exact ih hrun + +/-- Physical form of adaptive rounded containment. -/ +theorem adaptiveRoundedEllipsoidCentralUpdate_contains_point {d : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + {x : Fin d β†’ ℝ} (hcontains : RationalEllipsoidContains E x) + (ha : a β‰  0) + (hcut : finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ x i - rationalCenterReal E i) ≀ 0) : + RationalEllipsoidContains + (adaptiveRoundedEllipsoidCentralUpdate E a) x := by + obtain ⟨y, hy, hpoint⟩ := hcontains + have hb := rationalPulledBackNormal_ne_zero_of_det_ne_zero E a hdet ha + have hpulled : finiteDot + (fun j ↦ (rationalPulledBackNormal E a j : ℝ)) y ≀ 0 := by + rw [← physicalDot_point_sub_center_eq_pulledDot E a y] + simpa only [hpoint] using hcut + obtain ⟨y', hy', hpoint'⟩ := + adaptiveRoundedEllipsoidCentralUpdate_contains hd E a hdet hb hy hpulled + exact ⟨y', hy', hpoint'.trans hpoint⟩ + +theorem runRoundedRationalFeasibility_preserves_target_of_exhausted {d : β„•} + (hd : 0 < d) {K : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runRoundedRationalFeasibility oracle budget E = .exhausted E') + {x : Fin d β†’ ℝ} (hK : K x) + (hcontains : RationalEllipsoidContains E x) : + RationalEllipsoidContains E' x := by + induction budget generalizing E E' with + | zero => + simp only [runRoundedRationalFeasibility] at hrun + cases hrun + exact hcontains + | succ budget ih => + rw [runRoundedRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· contradiction + Β· have hcut := hvalid E _ hresponse + have hnext := adaptiveRoundedEllipsoidCentralUpdate_contains_point + hd E _ hdet hcontains hcut.1 (hcut.2 x hK) + have hpulled := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E _ hdet hcut.1 + exact ih + (det_adaptiveRoundedEllipsoidCentralUpdate_ne_zero + hd E _ hdet hpulled) + hrun hnext + +theorem roundedContractionFactor_nonneg {d : β„•} (hd : 0 < d) : + 0 ≀ 1 - 1 / (32 * (d : ℝ) ^ 3) := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hden : (1 : ℝ) ≀ 32 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact sub_nonneg.mpr + ((div_le_one (by positivity : (0 : ℝ) < 32 * (d : ℝ) ^ 3)).2 hden) + +theorem runRoundedRationalFeasibility_det_upper_of_exhausted {d : β„•} + (hd : 0 < d) {K : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runRoundedRationalFeasibility oracle budget E = .exhausted E') : + abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + induction budget generalizing E E' with + | zero => + simp only [runRoundedRationalFeasibility] at hrun + cases hrun + simp + | succ budget ih => + rw [runRoundedRationalFeasibility] at hrun + split at hrun + Β· rename_i hresponse + contradiction + Β· rename_i a hresponse + have hcut := hvalid E a hresponse + have hpulled := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E a hdet hcut.1 + let Enext := adaptiveRoundedEllipsoidCentralUpdate E a + have hdetNext : Matrix.det Enext.basis β‰  0 := + det_adaptiveRoundedEllipsoidCentralUpdate_ne_zero + hd E a hdet hpulled + have htail := ih hdetNext hrun + have hstep := abs_det_adaptiveRoundedCentralUpdate_le + hd E a hdet hpulled + have hfactor0 := roundedContractionFactor_nonneg hd + calc + abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + abs ((Matrix.det Enext.basis : β„š) : ℝ) := htail + _ ≀ (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + ((1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ)) := + mul_le_mul_of_nonneg_left hstep (pow_nonneg hfactor0 _) + _ = (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ (budget + 1) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + rw [pow_succ] + ring + +theorem roundedContractionFactor_pow_budget_le_half_pow + {d M : β„•} (hd : 0 < d) : + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ (32 * d ^ 3 * M) ≀ + (1 / 2 : ℝ) ^ M := by + let x : ℝ := 1 / (32 * (d : ℝ) ^ 3) + have hx0 : 0 ≀ x := by dsimp only [x]; positivity + have hbase : 1 - x ≀ Real.exp (-x) := by + simpa [sub_eq_add_neg, add_comm] using Real.add_one_le_exp (-x) + have hfactor : 0 ≀ 1 - x := by + simpa only [x] using roundedContractionFactor_nonneg hd + have hpow := pow_le_pow_leftβ‚€ hfactor hbase (32 * d ^ 3 * M) + have hexp : (Real.exp (-x)) ^ (32 * d ^ 3 * M) = + Real.exp (-(M : ℝ)) := by + rw [← Real.exp_nat_mul] + congr 1 + dsimp only [x] + have hdR : (0 : ℝ) < d := by exact_mod_cast hd + push_cast + field_simp + calc + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ (32 * d ^ 3 * M) = + (1 - x) ^ (32 * d ^ 3 * M) := by rfl + _ ≀ (Real.exp (-x)) ^ (32 * d ^ 3 * M) := hpow + _ = Real.exp (-(M : ℝ)) := hexp + _ = Real.exp (-1) ^ M := by + rw [show -(M : ℝ) = (M : ℝ) * (-1 : ℝ) by ring, + Real.exp_nat_mul] + _ ≀ (1 / 2 : ℝ) ^ M := + pow_le_pow_leftβ‚€ (Real.exp_pos (-1)).le real_exp_neg_one_le_half M + +/-- A rounded run cannot exhaust the determinant budget while retaining the +coordinate endpoints of a radius-`r` ball. -/ +theorem runRoundedRationalFeasibility_not_exhausted_of_inner_cross + {d M : β„•} (hd : 0 < d) + {K : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hdyadic : Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M < r ^ d) + (hKplus : βˆ€ k, K (fun i ↦ z i + if i = k then r else 0)) + (hKminus : βˆ€ k, K (fun i ↦ z i - if i = k then r else 0)) + (hEplus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i + if i = k then r else 0)) + (hEminus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i - if i = k then r else 0)) + (E' : RationalEllipsoidState d) : + runRoundedRationalFeasibility oracle (32 * d ^ 3 * M) E β‰  + .exhausted E' := by + intro hrun + have hplus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i + if i = k then r else 0) := by + intro k + exact runRoundedRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hKplus k) (hEplus k) + have hminus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i - if i = k then r else 0) := by + intro k + exact runRoundedRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hKminus k) (hEminus k) + have hlower := rationalEllipsoid_storedDet_lower_of_ball_endpoints + E' hr (fun k ↦ hplus k) (fun k ↦ hminus k) + have hupper := runRoundedRationalFeasibility_det_upper_of_exhausted + hd hvalid hdet hrun + have hfactor := roundedContractionFactor_pow_budget_le_half_pow + (d := d) (M := M) hd + have hdetUpper : abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 / 2 : ℝ) ^ M * abs ((Matrix.det E.basis : β„š) : ℝ) := + hupper.trans (mul_le_mul_of_nonneg_right hfactor (abs_nonneg _)) + have hsandwich : r ^ d ≀ + Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M := by + calc + r ^ d ≀ Nat.factorial d * + abs ((Matrix.det E'.basis : β„š) : ℝ) := hlower + _ ≀ Nat.factorial d * + ((1 / 2 : ℝ) ^ M * + abs ((Matrix.det E.basis : β„š) : ℝ)) := + mul_le_mul_of_nonneg_left hdetUpper (Nat.cast_nonneg _) + _ = Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M := by ring + exact (not_lt_of_ge hsandwich) hdyadic + +/-- Ball specialization used by the concrete epigraph feasibility call. -/ +theorem runRoundedRationalFeasibility_ball_accepts + {d : β„•} (hd : 0 < d) + {K : (Fin d β†’ ℝ) β†’ Prop} {Good : (Fin d β†’ β„š) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + (c : Fin d β†’ β„š) {R r : β„š} (hR : 0 < R) (hr : 0 < r) + {z : Fin d β†’ ℝ} + (hKplus : βˆ€ k, K (fun i ↦ z i + if i = k then (r : ℝ) else 0)) + (hKminus : βˆ€ k, K (fun i ↦ z i - if i = k then (r : ℝ) else 0)) + (houterPlus : βˆ€ k, finiteNormSq + (fun i ↦ (z i + if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) + (houterMinus : βˆ€ k, finiteNormSq + (fun i ↦ (z i - if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) : + βˆƒ x : Fin d β†’ β„š, + runRoundedRationalFeasibility oracle + (32 * d ^ 3 * rationalBallDyadicExponent d R r) + (rationalBallEllipsoid d c R) = .accepted x ∧ Good x := by + let E := rationalBallEllipsoid d c R + let budget := 32 * d ^ 3 * rationalBallDyadicExponent d R r + let result := runRoundedRationalFeasibility oracle budget E + cases hresult : result with + | accepted x => + refine ⟨x, ?_, ?_⟩ + Β· simpa only [result, budget, E] using hresult + Β· exact runRoundedRationalFeasibility_acceptsOnly haccept + (by simpa only [result, budget, E] using hresult) + | exhausted E' => + exfalso + apply runRoundedRationalFeasibility_not_exhausted_of_inner_cross + hd hvalid E + (by + dsimp only [E] + rw [det_rationalBallEllipsoid] + exact pow_ne_zero _ hR.ne') + (hr := Rat.cast_nonneg.mpr hr.le) + (rationalBallEllipsoid_dyadic_budget hd c hR hr) + hKplus hKminus + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterPlus k) + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterMinus k) + Β· simpa only [result, budget, E] using hresult + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibilityBitBounds.lean b/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibilityBitBounds.lean new file mode 100644 index 0000000000..ec2eb55f6d --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RoundedFeasibilityBitBounds.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RationalEncodingBounds +public import Mathlib.Tactic + +/-! # Rounded Feasibility Bit Bounds -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Traces and size invariants for rounded feasibility + +The executable runner is recursive on a natural budget. This file exposes +the exact list of cuts it actually executes and connects that trace to the +iteration bounds. No feasibility assumption is needed for the size bounds; +oracle validity supplies only the nonzero-cut invariant. +-/ + +/-- Records the cuts encountered by the adaptive rounded feasibility run, stopping on acceptance +or budget exhaustion. -/ +def roundedRationalFeasibilityCuts {d : β„•} + (oracle : RationalCentralOracle d) : + β„• β†’ RationalEllipsoidState d β†’ List (Fin d β†’ β„š) + | 0, _ => [] + | budget + 1, E => + match oracle E with + | .accept => [] + | .cut a => a :: roundedRationalFeasibilityCuts oracle budget + (adaptiveRoundedEllipsoidCentralUpdate E a) + +theorem roundedRationalFeasibilityCuts_length_le {d : β„•} + (oracle : RationalCentralOracle d) (budget : β„•) + (E : RationalEllipsoidState d) : + (roundedRationalFeasibilityCuts oracle budget E).length ≀ budget := by + induction budget generalizing E with + | zero => simp [roundedRationalFeasibilityCuts] + | succ budget ih => + rw [roundedRationalFeasibilityCuts] + split + Β· simp + Β· simp only [List.length_cons] + exact Nat.succ_le_succ (ih _) + +theorem adaptiveRoundedEllipsoidIterate_feasibilityCuts_terminal {d : β„•} + (oracle : RationalCentralOracle d) (budget : β„•) + (E : RationalEllipsoidState d) : + match runRoundedRationalFeasibility oracle budget E with + | .accepted x => + (adaptiveRoundedEllipsoidIterate E + (roundedRationalFeasibilityCuts oracle budget E)).center = x + | .exhausted E' => + adaptiveRoundedEllipsoidIterate E + (roundedRationalFeasibilityCuts oracle budget E) = E' := by + induction budget generalizing E with + | zero => simp [runRoundedRationalFeasibility, + roundedRationalFeasibilityCuts, adaptiveRoundedEllipsoidIterate] + | succ budget ih => + cases hresponse : oracle E with + | accept => + simp [runRoundedRationalFeasibility, + roundedRationalFeasibilityCuts, hresponse, + adaptiveRoundedEllipsoidIterate] + | cut a => + let E' := adaptiveRoundedEllipsoidCentralUpdate E a + have htail := ih E' + cases hrun : runRoundedRationalFeasibility oracle budget E' with + | accepted x => + rw [hrun] at htail + simpa only [runRoundedRationalFeasibility, + roundedRationalFeasibilityCuts, hresponse, + adaptiveRoundedEllipsoidIterate, E', hrun] using htail + | exhausted U => + rw [hrun] at htail + simpa only [runRoundedRationalFeasibility, + roundedRationalFeasibilityCuts, hresponse, + adaptiveRoundedEllipsoidIterate, E', hrun] using htail + +theorem roundedRationalFeasibilityCuts_regular {d : β„•} + (hd : 0 < d) {K : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid K oracle) + (budget : β„•) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) : + AdaptiveCutSequenceRegular E + (roundedRationalFeasibilityCuts oracle budget E) := by + induction budget generalizing E with + | zero => simp [roundedRationalFeasibilityCuts, + AdaptiveCutSequenceRegular] + | succ budget ih => + rw [roundedRationalFeasibilityCuts] + split <;> rename_i hresponse + Β· simp [AdaptiveCutSequenceRegular] + Β· have ha := (hvalid E _ hresponse).1 + have hb := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E _ hdet ha + have hdet' := det_adaptiveRoundedEllipsoidCentralUpdate_ne_zero + hd E _ hdet hb + exact ⟨hb, ih _ hdet'⟩ + +/-- Every terminal state of a valid rounded run has a trace of at most the +budgeted length and satisfies the determinant, magnitude, and precision +invariants proved for abstract regular traces. -/ +theorem runRoundedRationalFeasibility_terminal_invariants {d L K : β„•} + (hd : 0 < d) {Target : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (budget : β„•) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) : + let cuts := roundedRationalFeasibilityCuts oracle budget E + cuts.length ≀ budget ∧ + AdaptiveCutSequenceRegular E cuts ∧ + dyadicMesh (L + 2 * cuts.length) ≀ + abs (Matrix.det (adaptiveRoundedEllipsoidIterate E cuts).basis) ∧ + rationalStateAbsBound (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (2 : β„š) ^ roundedEllipsoidStateMagnitudeExponent + d K cuts.length ∧ + roundedEllipsoidPrecision (adaptiveRoundedEllipsoidIterate E cuts) ≀ + (L + 2 * cuts.length) + + roundedEllipsoidDenominatorExponent d + (roundedEllipsoidMagnitudeExponent d K cuts.length) + 2 := by + let cuts := roundedRationalFeasibilityCuts oracle budget E + have hlen : cuts.length ≀ budget := + roundedRationalFeasibilityCuts_length_le oracle budget E + have hregular : AdaptiveCutSequenceRegular E cuts := + roundedRationalFeasibilityCuts_regular hd hvalid budget E hdet + have hMbasis : rationalMatrixAbsBound E.basis ≀ (2 : β„š) ^ K := + (rationalMatrixAbsBound_le_rationalStateAbsBound E).trans hM + exact ⟨hlen, hregular, + adaptiveRoundedEllipsoidIterate_dyadic_det_lower + hd E hdet hdetLower cuts hregular, + adaptiveRoundedEllipsoidIterate_two_pow_state_magnitude_upper + hd E hM cuts hregular, + adaptiveRoundedEllipsoidIterate_precision_upper + hd E hdet hdetLower hMbasis cuts hregular⟩ + +/-- Every exact central update that is actually requested by a valid run uses +at most the stated polynomial precision. The decomposition identifies the +cut and the trace prefix before it. -/ +theorem roundedRationalFeasibilityCuts_next_precision_upper + {d L K : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (budget : β„•) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) + (pre suffix : List (Fin d β†’ β„š)) (a : Fin d β†’ β„š) + (htrace : roundedRationalFeasibilityCuts oracle budget E = + pre ++ a :: suffix) : + roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate + (adaptiveRoundedEllipsoidIterate E pre) a) ≀ + roundedEllipsoidNextPrecisionBound d L K pre.length := by + have hregular := roundedRationalFeasibilityCuts_regular + hd hvalid budget E hdet + rw [htrace] at hregular + have hpre := AdaptiveCutSequenceRegular.prefix_and_next + E pre suffix a hregular + exact adaptiveRoundedEllipsoidIterate_next_precision_upper + hd E hdet hdetLower hM pre hpre.1 a hpre.2 + +/-- The stored state immediately after every executed cut has a fully +explicit encoding-length bound. -/ +theorem roundedRationalFeasibilityCuts_next_state_encodedBitLength_le + {d L K : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (budget : β„•) (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) + (pre suffix : List (Fin d β†’ β„š)) (a : Fin d β†’ β„š) + (htrace : roundedRationalFeasibilityCuts oracle budget E = + pre ++ a :: suffix) : + rationalEllipsoidStateEncodedBitLength + (adaptiveRoundedEllipsoidCentralUpdate + (adaptiveRoundedEllipsoidIterate E pre) a) ≀ + 6 + d * (20 + 4 * + roundedEllipsoidStateMagnitudeExponent d K (pre.length + 1) + + 8 * roundedEllipsoidNextPrecisionBound d L K pre.length) + + 2 * d + d ^ 2 * (100 + 4 * + roundedEllipsoidStateMagnitudeExponent d K (pre.length + 1) + + 8 * roundedEllipsoidNextPrecisionBound d L K pre.length + + 32 * d) := by + have hregular := roundedRationalFeasibilityCuts_regular + hd hvalid budget E hdet + rw [htrace] at hregular + have hpre := AdaptiveCutSequenceRegular.prefix_and_next + E pre suffix a hregular + have hprea := AdaptiveCutSequenceRegular.append_singleton + E pre a hpre.1 hpre.2 + have hstate := + adaptiveRoundedEllipsoidIterate_two_pow_state_magnitude_upper + hd E hM (pre ++ [a]) hprea + have hstate' : + rationalStateAbsBound + (adaptiveRoundedEllipsoidCentralUpdate + (adaptiveRoundedEllipsoidIterate E pre) a) ≀ + (2 : β„š) ^ + roundedEllipsoidStateMagnitudeExponent d K (pre.length + 1) := by + rw [adaptiveRoundedEllipsoidIterate_append] at hstate + simpa only [adaptiveRoundedEllipsoidIterate, List.length_append, + List.length_singleton, Nat.add_comm] using hstate + have hp := roundedRationalFeasibilityCuts_next_precision_upper + hd hvalid budget E hdet hdetLower hM pre suffix a htrace + exact adaptiveRoundedEllipsoid_state_encodedBitLength_le hd + (rationalEllipsoidCentralUpdate + (adaptiveRoundedEllipsoidIterate E pre) a) hstate' hp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/RowStability.lean b/LeanPool/BeyondBethe/BeyondBethe/RowStability.lean new file mode 100644 index 0000000000..7bc38410ff --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/RowStability.lean @@ -0,0 +1,1859 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import Mathlib.Analysis.Convex.Jensen +public import Mathlib.Analysis.SpecialFunctions.Artanh +public import Mathlib.Analysis.SpecialFunctions.Log.Deriv +public import Mathlib.Data.Fin.Rev +public import Mathlib.Tactic + +/-! # Row Stability -/ + +@[expose] public section + +namespace BeyondBethe + +/-- `b` occurs strictly between `a` and `c` in the ordering `Ο€`. -/ +def OrderBetween {n : β„•} (Ο€ : Equiv.Perm (Fin n)) + (a b c : Fin n) : Prop := + (Ο€.symm a < Ο€.symm b ∧ Ο€.symm b < Ο€.symm c) ∨ + (Ο€.symm c < Ο€.symm b ∧ Ο€.symm b < Ο€.symm a) + +instance instDecidableOrderBetween + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) (a b c : Fin n) : + Decidable (OrderBetween Ο€ a b c) := by + unfold OrderBetween + infer_instance + +theorem one_middle_indicator + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) + {i j k : Fin n} (hij : i β‰  j) (hik : i β‰  k) (hjk : j β‰  k) : + (if OrderBetween Ο€ j i k then (1 : ℝ) else 0) + + (if OrderBetween Ο€ i j k then 1 else 0) + + (if OrderBetween Ο€ i k j then 1 else 0) = 1 := by + classical + have hij' : Ο€.symm i β‰  Ο€.symm j := Ο€.symm.injective.ne hij + have hik' : Ο€.symm i β‰  Ο€.symm k := Ο€.symm.injective.ne hik + have hjk' : Ο€.symm j β‰  Ο€.symm k := Ο€.symm.injective.ne hjk + rcases lt_or_gt_of_ne hij' with hijlt | hjilt + Β· rcases lt_or_gt_of_ne hjk' with hjklt | hkjlt + Β· have hiklt := hijlt.trans hjklt + have hjinot : ¬π.symm j < Ο€.symm i := not_lt_of_ge hijlt.le + have hknotj : ¬π.symm k < Ο€.symm j := not_lt_of_ge hjklt.le + have hknoti : ¬π.symm k < Ο€.symm i := not_lt_of_ge hiklt.le + simp [OrderBetween, hijlt, hjklt, hiklt, hjinot, hknotj, hknoti] + Β· rcases lt_or_gt_of_ne hik' with hiklt | hkilt + Β· have hikj := hiklt.trans hkjlt + have hkinot : ¬π.symm k < Ο€.symm i := not_lt_of_ge hiklt.le + have hjnotk : ¬π.symm j < Ο€.symm k := not_lt_of_ge hkjlt.le + have hjnoti : ¬π.symm j < Ο€.symm i := not_lt_of_ge hikj.le + simp [OrderBetween, hiklt, hkjlt, hikj, hkinot, hjnotk, hjnoti] + Β· have hkij := hkilt.trans hijlt + have hinotk : ¬π.symm i < Ο€.symm k := not_lt_of_ge hkilt.le + have hjnoti : ¬π.symm j < Ο€.symm i := not_lt_of_ge hijlt.le + have hjnotk : ¬π.symm j < Ο€.symm k := not_lt_of_ge hkij.le + simp [OrderBetween, hkilt, hijlt, hkij, hinotk, hjnoti, hjnotk] + Β· rcases lt_or_gt_of_ne hik' with hiklt | hkilt + Β· have hjik := hjilt.trans hiklt + have hinotj : ¬π.symm i < Ο€.symm j := not_lt_of_ge hjilt.le + have hknoti : ¬π.symm k < Ο€.symm i := not_lt_of_ge hiklt.le + have hknotj : ¬π.symm k < Ο€.symm j := not_lt_of_ge hjik.le + simp [OrderBetween, hjilt, hiklt, hjik, hinotj, hknoti, hknotj] + Β· rcases lt_or_gt_of_ne hjk' with hjklt | hkjlt + Β· have hjki := hjklt.trans hkilt + have hknotj : ¬π.symm k < Ο€.symm j := not_lt_of_ge hjklt.le + have hinotk : ¬π.symm i < Ο€.symm k := not_lt_of_ge hkilt.le + have hinotj : ¬π.symm i < Ο€.symm j := not_lt_of_ge hjki.le + simp [OrderBetween, hjklt, hkilt, hjki, hknotj, hinotk, hinotj] + Β· have hkji := hkjlt.trans hjilt + have hjnotk : ¬π.symm j < Ο€.symm k := not_lt_of_ge hkjlt.le + have hinotj : ¬π.symm i < Ο€.symm j := not_lt_of_ge hjilt.le + have hinotk : ¬π.symm i < Ο€.symm k := not_lt_of_ge hkji.le + simp [OrderBetween, hkjlt, hjilt, hkji, hjnotk, hinotj, hinotk] + +theorem orderBetween_trans_swap + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) + {i j k : Fin n} (hik : i β‰  k) (hjk : j β‰  k) : + OrderBetween (Ο€.trans (Equiv.swap i j)) i j k ↔ + OrderBetween Ο€ j i k := by + simp [OrderBetween, Equiv.trans_apply, Equiv.swap_apply_def, hik, hjk, + Ne.symm hik, Ne.symm hjk] + +/-- Uniform probability that the middle argument lies between the two +endpoints in a random ordering. -/ +noncomputable def betweenProbability + {n : β„•} (a b c : Fin n) : ℝ := by + classical + exact uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if OrderBetween Ο€ a b c then 1 else 0) + +theorem betweenProbability_endpoint_symm + {n : β„•} (a b c : Fin n) : + betweenProbability a b c = betweenProbability c b a := by + classical + apply congrArg uniformAverage + funext Ο€ + apply if_congr + Β· simp only [OrderBetween] + tauto + Β· rfl + Β· rfl + +theorem betweenProbability_swap_middle + {n : β„•} {i j k : Fin n} (hik : i β‰  k) (hjk : j β‰  k) : + betweenProbability j i k = betweenProbability i j k := by + classical + let f : Equiv.Perm (Fin n) β†’ ℝ := fun Ο€ ↦ + if OrderBetween Ο€ i j k then 1 else 0 + calc + betweenProbability j i k = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + f (Ο€.trans (Equiv.swap i j))) := by + apply congrArg uniformAverage + funext Ο€ + simp only [f] + exact if_congr (orderBetween_trans_swap Ο€ hik hjk).symm rfl rfl + _ = uniformAverage f := uniformAverage_perm_trans f (Equiv.swap i j) + _ = betweenProbability i j k := rfl + +theorem betweenProbability_eq_one_third + {n : β„•} {i j k : Fin n} + (hij : i β‰  j) (hik : i β‰  k) (hjk : j β‰  k) : + betweenProbability j i k = 1 / 3 := by + classical + have hijSymm := betweenProbability_swap_middle (i := i) (j := j) + (k := k) hik hjk + have hjkSymm := betweenProbability_swap_middle (i := j) (j := k) + (k := i) (Ne.symm hij) (Ne.symm hik) + have hBC : betweenProbability i j k = betweenProbability i k j := by + calc + betweenProbability i j k = betweenProbability k j i := + betweenProbability_endpoint_symm i j k + _ = betweenProbability j k i := hjkSymm + _ = betweenProbability i k j := + betweenProbability_endpoint_symm j k i + have hsum : betweenProbability j i k + + betweenProbability i j k + betweenProbability i k j = 1 := by + unfold betweenProbability uniformAverage + rw [← add_div, ← add_div, + ← Finset.sum_add_distrib, ← Finset.sum_add_distrib] + simp_rw [one_middle_indicator _ hij hik hjk] + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + field_simp [Fintype.card_ne_zero] + rw [hijSymm, ← hBC] at hsum + linarith + +/-- The three named points occur in this strict order. -/ +def StrictTripleOrder {n : β„•} (Ο€ : Equiv.Perm (Fin n)) + (a b c : Fin n) : Prop := + Ο€.symm a < Ο€.symm b ∧ Ο€.symm b < Ο€.symm c + +instance instDecidableStrictTripleOrder + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) (a b c : Fin n) : + Decidable (StrictTripleOrder Ο€ a b c) := by + unfold StrictTripleOrder + infer_instance + +/-- The uniform probability that a permutation places the three specified indices in strict +order. -/ +noncomputable def tripleOrderProbability + {n : β„•} (a b c : Fin n) : ℝ := by + classical + exact uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ a b c then 1 else 0) + +theorem strictTripleOrder_trans_swap_endpoints + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) + {a b c : Fin n} (hab : a β‰  b) (hbc : b β‰  c) : + StrictTripleOrder (Ο€.trans (Equiv.swap a c)) a b c ↔ + StrictTripleOrder Ο€ c b a := by + simp [StrictTripleOrder, Equiv.trans_apply, Equiv.swap_apply_def, + hab, hbc, Ne.symm hab, Ne.symm hbc] + +theorem tripleOrderProbability_reverse + {n : β„•} {a b c : Fin n} (hab : a β‰  b) (hbc : b β‰  c) : + tripleOrderProbability a b c = tripleOrderProbability c b a := by + classical + let f : Equiv.Perm (Fin n) β†’ ℝ := fun Ο€ ↦ + if StrictTripleOrder Ο€ a b c then 1 else 0 + let g : Equiv.Perm (Fin n) β†’ ℝ := fun Ο€ ↦ + if StrictTripleOrder Ο€ c b a then 1 else 0 + calc + tripleOrderProbability a b c = uniformAverage f := rfl + _ = uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + g (Ο€.trans (Equiv.swap c a))) := by + apply congrArg uniformAverage + funext Ο€ + exact if_congr + (strictTripleOrder_trans_swap_endpoints Ο€ + (a := c) (b := b) (c := a) (Ne.symm hbc) (Ne.symm hab)).symm + rfl rfl + _ = uniformAverage g := uniformAverage_perm_trans g (Equiv.swap c a) + _ = tripleOrderProbability c b a := rfl + +theorem betweenProbability_eq_tripleOrder_add_reverse + {n : β„•} (a b c : Fin n) : + betweenProbability a b c = + tripleOrderProbability a b c + tripleOrderProbability c b a := by + classical + rw [betweenProbability, tripleOrderProbability, tripleOrderProbability, + ← uniformAverage_add] + apply congrArg uniformAverage + funext Ο€ + simp only [OrderBetween, StrictTripleOrder] + by_cases h₁ : Ο€.symm a < Ο€.symm b ∧ Ο€.symm b < Ο€.symm c + Β· have hnot : Β¬(Ο€.symm c < Ο€.symm b ∧ Ο€.symm b < Ο€.symm a) := by + intro h + exact lt_asymm h₁.1 h.2 + simp [h₁, hnot] + Β· by_cases hβ‚‚ : Ο€.symm c < Ο€.symm b ∧ Ο€.symm b < Ο€.symm a + Β· simp [h₁, hβ‚‚] + Β· simp [h₁, hβ‚‚] + +theorem tripleOrderProbability_eq_one_sixth + {n : β„•} {a b c : Fin n} + (hab : a β‰  b) (hac : a β‰  c) (hbc : b β‰  c) : + tripleOrderProbability a b c = 1 / 6 := by + have hbetween := betweenProbability_eq_one_third + (i := b) (j := a) (k := c) (Ne.symm hab) hbc hac + rw [betweenProbability_eq_tripleOrder_add_reverse] at hbetween + have hreverse := tripleOrderProbability_reverse hab hbc + rw [← hreverse] at hbetween + linarith + +/-- Mass strictly before coordinate `i` in an ordering. -/ +noncomputable def strictLeftMass + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : ℝ := + βˆ‘ j, if Ο€.symm j < Ο€.symm i then p j else 0 + +/-- Mass strictly after coordinate `i` in an ordering. -/ +noncomputable def strictRightMass + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : ℝ := + βˆ‘ j, if Ο€.symm i < Ο€.symm j then p j else 0 + +theorem strictLeftMass_add_strictRightMass + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : + strictLeftMass p Ο€ i + strictRightMass p Ο€ i = 1 - p i := by + classical + rw [strictLeftMass, strictRightMass, ← Finset.sum_add_distrib] + have hterm : βˆ€ j : Fin n, + (if Ο€.symm j < Ο€.symm i then p j else 0) + + (if Ο€.symm i < Ο€.symm j then p j else 0) = + if j = i then 0 else p j := by + intro j + by_cases hji : j = i + Β· subst j + simp + Β· have hpos : Ο€.symm j β‰  Ο€.symm i := Ο€.symm.injective.ne hji + rcases lt_or_gt_of_ne hpos with hlt | hgt + Β· simp [hji, hlt, not_lt_of_ge hlt.le] + Β· simp [hji, hgt, not_lt_of_ge hgt.le] + simp_rw [hterm] + calc + βˆ‘ j : Fin n, (if j = i then 0 else p j) = + βˆ‘ j, (p j - if j = i then p j else 0) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hji : j = i <;> simp [hji] + _ = (βˆ‘ j, p j) - βˆ‘ j, (if j = i then p j else 0) := by + rw [Finset.sum_sub_distrib] + _ = 1 - p i := by rw [hp.sum_eq_one]; simp + +theorem prefix_mul_suffix_eq_self_add_crossing + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : + (p i + strictLeftMass p Ο€ i) * + (p i + strictRightMass p Ο€ i) = + p i + strictLeftMass p Ο€ i * strictRightMass p Ο€ i := by + have hmass := strictLeftMass_add_strictRightMass hp Ο€ i + calc + (p i + strictLeftMass p Ο€ i) * + (p i + strictRightMass p Ο€ i) = + (p i) ^ 2 + p i * + (strictLeftMass p Ο€ i + strictRightMass p Ο€ i) + + strictLeftMass p Ο€ i * strictRightMass p Ο€ i := by ring + _ = p i + strictLeftMass p Ο€ i * strictRightMass p Ο€ i := by + rw [hmass] + ring + +/-- The product of the strict masses on the two sides of `i` is the total +weight of ordered pairs that straddle `i`. -/ +theorem strictLeftMass_mul_strictRightMass + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : + strictLeftMass p Ο€ i * strictRightMass p Ο€ i = + βˆ‘ j, βˆ‘ k, if StrictTripleOrder Ο€ j i k then p j * p k else 0 := by + classical + rw [strictLeftMass, strictRightMass, Finset.sum_mul] + apply Finset.sum_congr rfl + intro j _ + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro k _ + unfold StrictTripleOrder + by_cases hj : Ο€.symm j < Ο€.symm i + Β· by_cases hk : Ο€.symm i < Ο€.symm k <;> simp [hj, hk] + Β· simp [hj] + +theorem uniformAverage_indicator_mul + {Ξ± : Type*} [Fintype Ξ±] (P : Ξ± β†’ Prop) [DecidablePred P] (c : ℝ) : + uniformAverage (fun x ↦ if P x then c else 0) = + c * uniformAverage (fun x ↦ if P x then 1 else 0) := by + rw [← uniformAverage_const_mul] + apply congrArg uniformAverage + funext x + by_cases hx : P x <;> simp [hx] + +theorem tripleOrderProbability_eq_zero_of_left_eq_middle + {n : β„•} (a c : Fin n) : + tripleOrderProbability a a c = 0 := by + classical + rw [tripleOrderProbability] + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ a a c then 1 else 0) = + uniformAverage (fun _ : Equiv.Perm (Fin n) ↦ 0) := by + apply congrArg uniformAverage + funext Ο€ + simp [StrictTripleOrder] + _ = 0 := uniformAverage_const 0 + +theorem tripleOrderProbability_eq_zero_of_middle_eq_right + {n : β„•} (a c : Fin n) : + tripleOrderProbability a c c = 0 := by + classical + rw [tripleOrderProbability] + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ a c c then 1 else 0) = + uniformAverage (fun _ : Equiv.Perm (Fin n) ↦ 0) := by + apply congrArg uniformAverage + funext Ο€ + simp [StrictTripleOrder] + _ = 0 := uniformAverage_const 0 + +theorem tripleOrderProbability_eq_zero_of_left_eq_right + {n : β„•} (a b : Fin n) : + tripleOrderProbability a b a = 0 := by + classical + rw [tripleOrderProbability] + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ a b a then 1 else 0) = + uniformAverage (fun _ : Equiv.Perm (Fin n) ↦ 0) := by + apply congrArg uniformAverage + funext Ο€ + rw [ite_eq_right] + intro h + exact lt_asymm h.1 h.2 + _ = 0 := uniformAverage_const 0 + +theorem tripleOrderProbability_cases + {n : β„•} (a b c : Fin n) : + tripleOrderProbability a b c = + if a β‰  b ∧ a β‰  c ∧ b β‰  c then 1 / 6 else 0 := by + classical + by_cases hab : a = b + Β· subst b + simp [tripleOrderProbability_eq_zero_of_left_eq_middle] + Β· by_cases hac : a = c + Β· subst c + simp [hab, tripleOrderProbability_eq_zero_of_left_eq_right] + Β· by_cases hbc : b = c + Β· subst c + simp [hab, tripleOrderProbability_eq_zero_of_middle_eq_right] + Β· simp [hab, hac, hbc, tripleOrderProbability_eq_one_sixth hab hac hbc] + +/-- Uniformly averaging the strict-left/strict-right product turns every +ordered pair of distinct coordinates away from `i` into a `1/6` contribution. -/ +theorem average_strictLeftMass_mul_strictRightMass + {n : β„•} (p : Fin n β†’ ℝ) (i : Fin n) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + strictLeftMass p Ο€ i * strictRightMass p Ο€ i) = + (1 / 6) * βˆ‘ j, βˆ‘ k, + if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0 := by + classical + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + strictLeftMass p Ο€ i * strictRightMass p Ο€ i) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ j, βˆ‘ k, + if StrictTripleOrder Ο€ j i k then p j * p k else 0) := + congrArg uniformAverage (funext fun Ο€ ↦ + strictLeftMass_mul_strictRightMass p Ο€ i) + _ = βˆ‘ j, uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ k, if StrictTripleOrder Ο€ j i k then p j * p k else 0) := + uniformAverage_sum _ + _ = βˆ‘ j, βˆ‘ k, uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ j i k then p j * p k else 0) := by + apply Finset.sum_congr rfl + intro j _ + exact uniformAverage_sum _ + _ = βˆ‘ j, βˆ‘ k, (1 / 6) * + (if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) := by + apply Finset.sum_congr rfl + intro j _ + apply Finset.sum_congr rfl + intro k _ + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + if StrictTripleOrder Ο€ j i k then p j * p k else 0) = + p j * p k * tripleOrderProbability j i k := + uniformAverage_indicator_mul + (fun Ο€ : Equiv.Perm (Fin n) ↦ StrictTripleOrder Ο€ j i k) + (p j * p k) + _ = p j * p k * + (if j β‰  i ∧ j β‰  k ∧ i β‰  k then 1 / 6 else 0) := by + rw [tripleOrderProbability_cases] + _ = (1 / 6) * + (if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) := by + by_cases h : j β‰  i ∧ j β‰  k ∧ i β‰  k <;> simp [h] <;> ring + _ = (1 / 6) * βˆ‘ j, βˆ‘ k, + if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0 := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j _ + rw [Finset.mul_sum] + +theorem sum_ite_ne_eq_sum_sub + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (f : ΞΉ β†’ ℝ) (i : ΞΉ) : + (βˆ‘ j, if j β‰  i then f j else 0) = (βˆ‘ j, f j) - f i := by + calc + (βˆ‘ j, if j β‰  i then f j else 0) = + βˆ‘ j, (f j - if j = i then f j else 0) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hji : j = i <;> simp [hji] + _ = (βˆ‘ j, f j) - βˆ‘ j, (if j = i then f j else 0) := by + rw [Finset.sum_sub_distrib] + _ = (βˆ‘ j, f j) - f i := by simp + +theorem sum_away_from_two + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {i j : Fin n} (hij : i β‰  j) : + (βˆ‘ k, if i β‰  k ∧ j β‰  k then p k else 0) = 1 - p i - p j := by + classical + calc + (βˆ‘ k, if i β‰  k ∧ j β‰  k then p k else 0) = + βˆ‘ k, (p k - (if k = i then p k else 0) - + (if k = j then p k else 0)) := by + apply Finset.sum_congr rfl + intro k _ + by_cases hki : k = i + Β· subst k + simp [hij] + Β· by_cases hkj : k = j + Β· subst k + simp [hki] + Β· simp [hki, hkj, Ne.symm hki, Ne.symm hkj] + _ = (βˆ‘ k, p k) - βˆ‘ k, (if k = i then p k else 0) - + βˆ‘ k, (if k = j then p k else 0) := by + rw [Finset.sum_sub_distrib, Finset.sum_sub_distrib] + _ = 1 - p i - p j := by rw [hp.sum_eq_one]; simp + +theorem inner_ordered_distinct_products + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + (i j : Fin n) : + (βˆ‘ k, if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) = + if j β‰  i then p j * (1 - p i - p j) else 0 := by + classical + by_cases hji : j = i + Β· subst j + simp + Β· calc + (βˆ‘ k, if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) = + p j * βˆ‘ k, if i β‰  k ∧ j β‰  k then p k else 0 := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro k _ + by_cases hjk : j = k + Β· subst k + simp + Β· by_cases hik : i = k + Β· subst k + simp [hji] + Β· simp [hji, hjk, hik, Ne.symm hjk, Ne.symm hik] + _ = p j * (1 - p i - p j) := by + rw [sum_away_from_two hp (Ne.symm hji)] + _ = if j β‰  i then p j * (1 - p i - p j) else 0 := by simp [hji] + +/-- The exact finite-sum identity behind the expected prefix--suffix moment. -/ +theorem sum_ordered_distinct_products + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) (i : Fin n) : + (βˆ‘ j, βˆ‘ k, + if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) = + (1 - p i) ^ 2 - ((βˆ‘ j, (p j) ^ 2) - (p i) ^ 2) := by + classical + calc + (βˆ‘ j, βˆ‘ k, + if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0) = + βˆ‘ j, if j β‰  i then p j * (1 - p i - p j) else 0 := by + apply Finset.sum_congr rfl + intro j _ + exact inner_ordered_distinct_products hp i j + _ = βˆ‘ j, ((if j β‰  i then p j else 0) * (1 - p i) - + (if j β‰  i then (p j) ^ 2 else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hji : j = i <;> simp [hji] <;> ring + _ = (βˆ‘ j, if j β‰  i then p j else 0) * (1 - p i) - + βˆ‘ j, (if j β‰  i then (p j) ^ 2 else 0) := by + rw [Finset.sum_sub_distrib, Finset.sum_mul] + _ = ((βˆ‘ j, p j) - p i) * (1 - p i) - + ((βˆ‘ j, (p j) ^ 2) - (p i) ^ 2) := by + rw [sum_ite_ne_eq_sum_sub, sum_ite_ne_eq_sum_sub] + _ = (1 - p i) ^ 2 - ((βˆ‘ j, (p j) ^ 2) - (p i) ^ 2) := by + rw [hp.sum_eq_one] + ring + +/-- The expected product of the prefix and suffix masses at coordinate `i`. -/ +noncomputable def orderingMoment + {n : β„•} (p : Fin n β†’ ℝ) (i : Fin n) : ℝ := + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + (p i + strictLeftMass p Ο€ i) * (p i + strictRightMass p Ο€ i)) + +/-- Paper (31): the exact prefix--suffix moment identity. -/ +theorem orderingMoment_eq + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) (i : Fin n) : + orderingMoment p i = + (1 - βˆ‘ j, (p j) ^ 2) / 6 + 2 / 3 * p i + 1 / 3 * (p i) ^ 2 := by + classical + calc + orderingMoment p i = uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + p i + strictLeftMass p Ο€ i * strictRightMass p Ο€ i) := by + apply congrArg uniformAverage + funext Ο€ + exact prefix_mul_suffix_eq_self_add_crossing hp Ο€ i + _ = uniformAverage (fun _ : Equiv.Perm (Fin n) ↦ p i) + + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + strictLeftMass p Ο€ i * strictRightMass p Ο€ i) := + uniformAverage_add _ _ + _ = p i + (1 / 6) * βˆ‘ j, βˆ‘ k, + if j β‰  i ∧ j β‰  k ∧ i β‰  k then p j * p k else 0 := by + rw [uniformAverage_const, + average_strictLeftMass_mul_strictRightMass] + _ = p i + (1 / 6) * + ((1 - p i) ^ 2 - ((βˆ‘ j, (p j) ^ 2) - (p i) ^ 2)) := by + rw [sum_ordered_distinct_products hp] + _ = (1 - βˆ‘ j, (p j) ^ 2) / 6 + + 2 / 3 * p i + 1 / 3 * (p i) ^ 2 := by ring + +/-- Jensen's inequality for the uniform average of logarithms. -/ +theorem uniformAverage_log_le_log_uniformAverage + {Ξ± : Type*} [Fintype Ξ±] [Nonempty Ξ±] + (f : Ξ± β†’ ℝ) (hf : βˆ€ x, 0 < f x) : + uniformAverage (fun x ↦ Real.log (f x)) ≀ + Real.log (uniformAverage f) := by + let N : ℝ := Fintype.card Ξ± + have hN : 0 < N := by + simpa [N] using (Nat.cast_pos.mpr (Fintype.card_pos : 0 < Fintype.card Ξ±) : + (0 : ℝ) < Fintype.card Ξ±) + have hweights : βˆ‘ _x : Ξ±, (1 / N : ℝ) = 1 := by + dsimp [N] + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + field_simp + have h := strictConcaveOn_log_Ioi.concaveOn.le_map_sum + (t := Finset.univ) (w := fun _ : Ξ± ↦ (1 / N : ℝ)) (p := f) + (fun _ _ ↦ by positivity) hweights (fun x _ ↦ hf x) + calc + uniformAverage (fun x ↦ Real.log (f x)) = + βˆ‘ x, (1 / N) β€’ Real.log (f x) := by + rw [uniformAverage, div_eq_mul_inv, Finset.sum_mul] + apply Finset.sum_congr rfl + intro x _ + simp [N, smul_eq_mul] + ring + _ ≀ Real.log (βˆ‘ x, (1 / N) β€’ f x) := h + _ = Real.log (uniformAverage f) := by + congr 1 + calc + (βˆ‘ x, (1 / N) β€’ f x) = (1 / N) * βˆ‘ x, f x := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro x _ + simp [smul_eq_mul] + _ = uniformAverage f := by + simp [uniformAverage, N, div_eq_mul_inv] + ring + +theorem suffixMass_eq_self_add_strictRightMass + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : + suffixMass p Ο€ i = p i + strictRightMass p Ο€ i := by + classical + rw [suffixMass, strictRightMass] + calc + (βˆ‘ k, if Ο€.symm i ≀ Ο€.symm k then p k else 0) = + βˆ‘ k, ((if k = i then p k else 0) + + (if Ο€.symm i < Ο€.symm k then p k else 0)) := by + apply Finset.sum_congr rfl + intro k _ + by_cases hki : k = i + Β· subst k + simp + Β· have hpos : Ο€.symm i β‰  Ο€.symm k := + Ο€.symm.injective.ne (Ne.symm hki) + rcases lt_or_gt_of_ne hpos with hlt | hgt + Β· simp [hki, hlt, hlt.le] + Β· have hnot : ¬π.symm i < Ο€.symm k := not_lt_of_ge hgt.le + simp [hki, hgt, not_le_of_gt hgt, hnot] + _ = (βˆ‘ k, if k = i then p k else 0) + + βˆ‘ k, (if Ο€.symm i < Ο€.symm k then p k else 0) := by + rw [Finset.sum_add_distrib] + _ = p i + βˆ‘ k, (if Ο€.symm i < Ο€.symm k then p k else 0) := by simp + +/-- Reverse an ordering by reversing its positions. -/ +def reverseOrdering {n : β„•} (Ο€ : Equiv.Perm (Fin n)) : + Equiv.Perm (Fin n) := + Fin.revPerm.trans Ο€ + +/-- Left composition by a fixed permutation is a bijection on orderings. -/ +def permPreTransEquiv {n : β„•} (Ο„ : Equiv.Perm (Fin n)) : + Equiv.Perm (Fin n) ≃ Equiv.Perm (Fin n) where + toFun Ο€ := Ο„.trans Ο€ + invFun ΞΈ := Ο„.symm.trans ΞΈ + left_inv Ο€ := by + ext i + simp [Equiv.trans_apply] + right_inv ΞΈ := by + ext i + simp [Equiv.trans_apply] + +theorem uniformAverage_perm_preTrans + {n : β„•} (f : Equiv.Perm (Fin n) β†’ ℝ) + (Ο„ : Equiv.Perm (Fin n)) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ f (Ο„.trans Ο€)) = + uniformAverage f := by + rw [uniformAverage, uniformAverage] + congr 1 + exact (permPreTransEquiv Ο„).sum_comp f + +theorem suffixMass_reverseOrdering + {n : β„•} (p : Fin n β†’ ℝ) (Ο€ : Equiv.Perm (Fin n)) (i : Fin n) : + suffixMass p (reverseOrdering Ο€) i = p i + strictLeftMass p Ο€ i := by + classical + rw [suffixMass, strictLeftMass] + calc + (βˆ‘ k, if (reverseOrdering Ο€).symm i ≀ + (reverseOrdering Ο€).symm k then p k else 0) = + βˆ‘ k, ((if k = i then p k else 0) + + (if Ο€.symm k < Ο€.symm i then p k else 0)) := by + apply Finset.sum_congr rfl + intro k _ + have hrev : (reverseOrdering Ο€).symm i ≀ + (reverseOrdering Ο€).symm k ↔ Ο€.symm k ≀ Ο€.symm i := by + simp [reverseOrdering, Equiv.trans_apply, Fin.rev_le_rev] + simp only [hrev] + by_cases hki : k = i + Β· subst k + simp + Β· have hpos : Ο€.symm k β‰  Ο€.symm i := Ο€.symm.injective.ne hki + rcases lt_or_gt_of_ne hpos with hlt | hgt + Β· simp [hki, hlt, hlt.le] + Β· have hnot : ¬π.symm k < Ο€.symm i := not_lt_of_ge hgt.le + simp [hki, hgt, not_le_of_gt hgt, hnot] + _ = (βˆ‘ k, if k = i then p k else 0) + + βˆ‘ k, (if Ο€.symm k < Ο€.symm i then p k else 0) := by + rw [Finset.sum_add_distrib] + _ = p i + βˆ‘ k, (if Ο€.symm k < Ο€.symm i then p k else 0) := by simp + +theorem average_log_suffix_reverseOrdering + {n : β„•} (p : Fin n β†’ ℝ) (i : Fin n) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p (reverseOrdering Ο€) i)) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) := by + exact uniformAverage_perm_preTrans + (fun Ο€ : Equiv.Perm (Fin n) ↦ Real.log (suffixMass p Ο€ i)) + Fin.revPerm + +/-- Pairing an ordering with its reversal rewrites the suffix log as half the +logarithm of the prefix--suffix product. -/ +theorem average_log_suffix_symmetrized + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) (i : Fin n) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) = + (1 / 2) * uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log ((p i + strictLeftMass p Ο€ i) * + (p i + strictRightMass p Ο€ i))) := by + have hprefix : uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (p i + strictLeftMass p Ο€ i)) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) := by + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (p i + strictLeftMass p Ο€ i)) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p (reverseOrdering Ο€) i)) := by + apply congrArg uniformAverage + funext Ο€ + rw [suffixMass_reverseOrdering] + _ = uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) := + average_log_suffix_reverseOrdering p i + have hproduct : uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log ((p i + strictLeftMass p Ο€ i) * + (p i + strictRightMass p Ο€ i))) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (p i + strictLeftMass p Ο€ i)) + + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) := by + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log ((p i + strictLeftMass p Ο€ i) * + (p i + strictRightMass p Ο€ i))) = + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (p i + strictLeftMass p Ο€ i) + + Real.log (suffixMass p Ο€ i)) := by + apply congrArg uniformAverage + funext Ο€ + rw [suffixMass_eq_self_add_strictRightMass] + exact Real.log_mul + (by + rw [← suffixMass_reverseOrdering] + exact (suffixMass_pos hp.1 (hp.2 i) _).ne') + (by + rw [← suffixMass_eq_self_add_strictRightMass] + exact (suffixMass_pos hp.1 (hp.2 i) _).ne') + _ = _ := uniformAverage_add _ _ + rw [hproduct, hprefix] + ring + +theorem average_log_suffix_le_half_log_orderingMoment + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) (i : Fin n) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p Ο€ i)) ≀ + (1 / 2) * Real.log (orderingMoment p i) := by + rw [average_log_suffix_symmetrized hp i] + apply mul_le_mul_of_nonneg_left _ (by norm_num) + exact uniformAverage_log_le_log_uniformAverage _ (fun Ο€ ↦ by + exact mul_pos + (by + rw [← suffixMass_reverseOrdering] + exact suffixMass_pos hp.1 (hp.2 i) _) + (by + rw [← suffixMass_eq_self_add_strictRightMass] + exact suffixMass_pos hp.1 (hp.2 i) _)) + +theorem uniformAverage_pos + {Ξ± : Type*} [Fintype Ξ±] [Nonempty Ξ±] + (f : Ξ± β†’ ℝ) (hf : βˆ€ x, 0 < f x) : + 0 < uniformAverage f := by + rw [uniformAverage] + exact div_pos + (Finset.sum_pos (fun x _ ↦ hf x) Finset.univ_nonempty) + (by exact_mod_cast (Fintype.card_pos : 0 < Fintype.card Ξ±)) + +theorem orderingMoment_pos + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) (i : Fin n) : + 0 < orderingMoment p i := by + apply uniformAverage_pos + intro Ο€ + exact mul_pos + (by + rw [← suffixMass_reverseOrdering] + exact suffixMass_pos hp.1 (hp.2 i) _) + (by + rw [← suffixMass_eq_self_add_strictRightMass] + exact suffixMass_pos hp.1 (hp.2 i) _) + +/-- The tangent inequality for `log` at `1/2`. -/ +theorem log_le_tangent_at_half {x : ℝ} (hx : 0 < x) : + Real.log x ≀ -Real.log 2 + 2 * x - 1 := by + have h := Real.log_le_sub_one_of_pos (mul_pos (by norm_num : (0 : ℝ) < 2) hx) + rw [Real.log_mul (by norm_num : (2 : ℝ) β‰  0) hx.ne'] at h + linarith + +theorem rowT_le_moment_bound + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) : + rowT p ≀ -1 / 2 * Real.log 2 + + βˆ‘ i, p i * orderingMoment p i - 1 / 2 := by + calc + rowT p = βˆ‘ i, p i * uniformAverage + (fun Ο€ : Equiv.Perm (Fin n) ↦ Real.log (suffixMass p Ο€ i)) := + rowT_eq_sum_mul_average_suffix p + _ ≀ βˆ‘ i, p i * ((1 / 2) * Real.log (orderingMoment p i)) := by + apply Finset.sum_le_sum + intro i _ + exact mul_le_mul_of_nonneg_left + (average_log_suffix_le_half_log_orderingMoment hp i) + (hp.1.nonnegative i) + _ ≀ βˆ‘ i, p i * ((1 / 2) * + (-Real.log 2 + 2 * orderingMoment p i - 1)) := by + apply Finset.sum_le_sum + intro i _ + apply mul_le_mul_of_nonneg_left _ (hp.1.nonnegative i) + apply mul_le_mul_of_nonneg_left _ (by norm_num) + exact log_le_tangent_at_half (orderingMoment_pos hp i) + _ = βˆ‘ i, (-1 / 2 * Real.log 2 * p i + + p i * orderingMoment p i - 1 / 2 * p i) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = -1 / 2 * Real.log 2 + + βˆ‘ i, p i * orderingMoment p i - 1 / 2 := by + rw [Finset.sum_sub_distrib, Finset.sum_add_distrib, + ← Finset.mul_sum, ← Finset.mul_sum, hp.1.sum_eq_one] + ring + +theorem sum_mul_orderingMoment_eq + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) : + (βˆ‘ i, p i * orderingMoment p i) = + 1 / 6 + 1 / 2 * (βˆ‘ i, (p i) ^ 2) + + 1 / 3 * (βˆ‘ i, (p i) ^ 3) := by + simp_rw [orderingMoment_eq hp] + calc + (βˆ‘ i, p i * + ((1 - βˆ‘ j, p j ^ 2) / 6 + 2 / 3 * p i + 1 / 3 * p i ^ 2)) = + βˆ‘ i, ((1 - βˆ‘ j, p j ^ 2) / 6 * p i + + 2 / 3 * p i ^ 2 + 1 / 3 * p i ^ 3) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = (1 - βˆ‘ j, p j ^ 2) / 6 * (βˆ‘ i, p i) + + 2 / 3 * (βˆ‘ i, p i ^ 2) + 1 / 3 * (βˆ‘ i, p i ^ 3) := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib, + ← Finset.mul_sum, ← Finset.mul_sum, ← Finset.mul_sum] + _ = 1 / 6 + 1 / 2 * (βˆ‘ i, p i ^ 2) + + 1 / 3 * (βˆ‘ i, p i ^ 3) := by + rw [hp.sum_eq_one] + ring + +/-- The symmetrization, exact moment, Jensen, and tangent estimates combined. -/ +theorem rowT_le_cubic_bound + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) : + rowT p ≀ -1 / 2 * Real.log 2 - 1 / 3 + + 1 / 2 * (βˆ‘ i, (p i) ^ 2) + 1 / 3 * (βˆ‘ i, (p i) ^ 3) := by + calc + rowT p ≀ -1 / 2 * Real.log 2 + + βˆ‘ i, p i * orderingMoment p i - 1 / 2 := + rowT_le_moment_bound hp + _ = -1 / 2 * Real.log 2 - 1 / 3 + + 1 / 2 * (βˆ‘ i, (p i) ^ 2) + 1 / 3 * (βˆ‘ i, (p i) ^ 3) := by + rw [sum_mul_orderingMoment_eq hp.1] + ring + +/-- The separable function `F` in paper (35). -/ +noncomputable def rowStabilityF (x : ℝ) : ℝ := + -(1 - x) * Real.log (1 - x) + x ^ 2 / 2 + x ^ 3 / 3 + +/-- The sharp value of the separable sum at a half--half vector. -/ +noncomputable def rowStabilityC : ℝ := + Real.log 2 + 1 / 3 + +/-- The ratio `h(x)=F(x)/x` used to identify the equality case. Only positive +arguments are used below. -/ +noncomputable def rowStabilityH (x : ℝ) : ℝ := + rowStabilityF x / x + +/-- The row-stability derivative expression `log (1 - x) + 1 + x + x^2`. -/ +noncomputable def rowStabilityFPrime (x : ℝ) : ℝ := + Real.log (1 - x) + 1 + x + x ^ 2 + +/-- The row-stability derivative expression `(log (1 - x) + x + x^2 / 2 + 2 * x^3 / 3) / x^2`. -/ +noncomputable def rowStabilityHPrime (x : ℝ) : ℝ := + (Real.log (1 - x) + x + x ^ 2 / 2 + 2 * x ^ 3 / 3) / x ^ 2 + +theorem hasDerivAt_rowStabilityF + {x : ℝ} (hx : x < 1) : + HasDerivAt rowStabilityF (rowStabilityFPrime x) x := by + have hlinear : HasDerivAt (fun y : ℝ ↦ -(1 - y)) 1 x := by + convert! ((hasDerivAt_const x 1).sub (hasDerivAt_id x)).neg using 1 <;> ring + have hlog : HasDerivAt (fun y : ℝ ↦ Real.log (1 - y)) + (-1 / (1 - x)) x := by + simpa [Function.id_def] using + ((hasDerivAt_const x 1).sub (hasDerivAt_id x)).log + (by linarith : 1 - x β‰  0) + have hsq : HasDerivAt (fun y : ℝ ↦ y ^ 2 / 2) x x := by + convert! (hasDerivAt_pow 2 x).div_const 2 using 1 <;> ring + have hcub : HasDerivAt (fun y : ℝ ↦ y ^ 3 / 3) (x ^ 2) x := by + convert! (hasDerivAt_pow 3 x).div_const 3 using 1 <;> ring + have h := (hlinear.mul hlog).add hsq |>.add hcub + unfold rowStabilityF rowStabilityFPrime + convert! h using 1 <;> + field_simp [show 1 - x β‰  0 by linarith] <;> ring + +theorem hasDerivAt_rowStabilityH + {x : ℝ} (hx0 : 0 < x) (hx1 : x < 1) : + HasDerivAt rowStabilityH (rowStabilityHPrime x) x := by + have h := (hasDerivAt_rowStabilityF hx1).div (hasDerivAt_id x) hx0.ne' + simp only [Function.id_def] at h + unfold rowStabilityFPrime rowStabilityF at h + unfold rowStabilityH rowStabilityHPrime rowStabilityF + convert! h using 1 <;> field_simp [hx0.ne'] <;> ring + +/-- An explicit Taylor lower bound for `log(1-x)`. -/ +theorem log_one_sub_lower_eight + {x : ℝ} (hx0 : 0 ≀ x) (hx1 : x < 1) : + -(x + x ^ 2 / 2 + x ^ 3 / 3 + x ^ 4 / 4 + x ^ 5 / 5 + + x ^ 6 / 6 + x ^ 7 / 7 + x ^ 8 / 8) - x ^ 9 / (1 - x) ≀ + Real.log (1 - x) := by + have habs := Real.abs_log_sub_add_sum_range_le + (show |x| < 1 by simpa [abs_of_nonneg hx0]) 8 + have hneg := neg_le_of_abs_le habs + rw [abs_of_nonneg hx0] at hneg + norm_num [Finset.sum_range_succ] at hneg + nlinarith + +/-- On `[0,1/2]`, the numerator of `h'` has a uniform cubic lower bound. -/ +theorem rowStabilityHPrime_numerator_lower + {x : ℝ} (hx0 : 0 ≀ x) (hxHalf : x ≀ 1 / 2) : + x ^ 3 / 12 ≀ + Real.log (1 - x) + x + x ^ 2 / 2 + 2 * x ^ 3 / 3 := by + have hp (r : β„•) : x ^ (3 + r) ≀ x ^ 3 * (1 / 2 : ℝ) ^ r := by + rw [pow_add] + exact mul_le_mul_of_nonneg_left + (pow_le_pow_leftβ‚€ hx0 hxHalf r) (pow_nonneg hx0 3) + have h4 : x ^ 4 ≀ x ^ 3 / 2 := by + simpa [div_eq_mul_inv] using hp 1 + have h5 : x ^ 5 ≀ x ^ 3 / 4 := by + convert hp 2 using 1 <;> norm_num <;> ring + have h6 : x ^ 6 ≀ x ^ 3 / 8 := by + convert hp 3 using 1 <;> norm_num <;> ring + have h7 : x ^ 7 ≀ x ^ 3 / 16 := by + convert hp 4 using 1 <;> norm_num <;> ring + have h8 : x ^ 8 ≀ x ^ 3 / 32 := by + convert hp 5 using 1 <;> norm_num <;> ring + have h9 : x ^ 9 ≀ x ^ 3 / 64 := by + convert hp 6 using 1 <;> norm_num <;> ring + have hden : 0 < 1 - x := by linarith + have hrem : x ^ 9 / (1 - x) ≀ x ^ 3 / 32 := by + rw [div_le_iffβ‚€ hden] + have hs := mul_le_mul_of_nonneg_left + (show (1 / 2 : ℝ) ≀ 1 - x by linarith) (pow_nonneg hx0 3) + nlinarith + have hlog := log_one_sub_lower_eight hx0 (by linarith : x < 1) + have hneg : x ^ 4 / 4 + x ^ 5 / 5 + x ^ 6 / 6 + + x ^ 7 / 7 + x ^ 8 / 8 + x ^ 9 / (1 - x) ≀ x ^ 3 / 4 := by + nlinarith + nlinarith + +theorem rowStabilityHPrime_lower + {x : ℝ} (hx0 : 0 < x) (hxHalf : x ≀ 1 / 2) : + x / 12 ≀ rowStabilityHPrime x := by + have hnum := rowStabilityHPrime_numerator_lower hx0.le hxHalf + have hx2 : 0 < x ^ 2 := sq_pos_of_pos hx0 + calc + x / 12 = (x ^ 3 / 12) / x ^ 2 := by + field_simp [hx0.ne'] <;> ring + _ ≀ (Real.log (1 - x) + x + x ^ 2 / 2 + 2 * x ^ 3 / 3) / x ^ 2 := + (div_le_div_iff_of_pos_right hx2).2 hnum + _ = rowStabilityHPrime x := rfl + +theorem rowStabilityH_half : rowStabilityH (1 / 2) = rowStabilityC := by + rw [rowStabilityH, rowStabilityF, rowStabilityC] + have hhalf : (1 / 2 : ℝ) = (2 : ℝ)⁻¹ := by norm_num + rw [show (1 : ℝ) - 1 / 2 = 1 / 2 by norm_num, hhalf, Real.log_inv] + norm_num + ring + +theorem rowStabilityH_mono + {x y : ℝ} (hx0 : 0 < x) (hxy : x ≀ y) (hyHalf : y ≀ 1 / 2) : + rowStabilityH x ≀ rowStabilityH y := by + have hmono : MonotoneOn rowStabilityH (Set.Icc x y) := by + refine monotoneOn_of_hasDerivWithinAt_nonneg (convex_Icc x y) + (fun z hz ↦ (hasDerivAt_rowStabilityH + (by linarith [hz.1]) (by linarith [hz.2, hyHalf])).continuousAt.continuousWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo x y := by simpa only [interior_Icc] using hz + exact (hasDerivAt_rowStabilityH + (by linarith [hz'.1]) (by linarith [hz'.2, hyHalf])).hasDerivWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo x y := by simpa only [interior_Icc] using hz + have hprime := rowStabilityHPrime_lower (x := z) + (by linarith [hz'.1]) (by linarith [hz'.2, hyHalf]) + exact (show 0 ≀ z / 12 by linarith [hz'.1, hx0]).trans hprime) + exact hmono ⟨le_rfl, hxy⟩ ⟨hxy, le_rfl⟩ hxy + +/-- A concrete version of the paper's constant `c₁`. -/ +theorem rowStabilityH_gap_to_half + {x : ℝ} (hxQuarter : 1 / 4 ≀ x) (hxHalf : x ≀ 1 / 2) : + (1 / 48) * (1 / 2 - x) ≀ rowStabilityC - rowStabilityH x := by + let corrected : ℝ β†’ ℝ := fun z ↦ rowStabilityH z - z / 48 + have hmono : MonotoneOn corrected (Set.Icc x (1 / 2)) := by + refine monotoneOn_of_hasDerivWithinAt_nonneg (convex_Icc x (1 / 2)) + (fun z hz ↦ ((hasDerivAt_rowStabilityH + (by linarith [hz.1, hxQuarter]) (by linarith [hz.2])).sub + ((hasDerivAt_id z).div_const 48)).continuousAt.continuousWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo x (1 / 2) := by simpa only [interior_Icc] using hz + exact ((hasDerivAt_rowStabilityH + (by linarith [hz'.1, hxQuarter]) (by linarith [hz'.2])).sub + ((hasDerivAt_id z).div_const 48)).hasDerivWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo x (1 / 2) := by simpa only [interior_Icc] using hz + have hprime := rowStabilityHPrime_lower (x := z) + (by linarith [hz'.1, hxQuarter]) (by linarith [hz'.2]) + change 0 ≀ rowStabilityHPrime z - 1 / 48 + calc + 0 ≀ z / 12 - 1 / 48 := by + linarith [show (1 / 4 : ℝ) ≀ z by linarith [hz'.1, hxQuarter]] + _ ≀ rowStabilityHPrime z - 1 / 48 := sub_le_sub_right hprime _) + have h := hmono ⟨le_rfl, hxHalf⟩ ⟨hxHalf, le_rfl⟩ hxHalf + dsimp [corrected] at h + rw [rowStabilityH_half] at h + linarith + +/-- A concrete version of the paper's constant `cβ‚‚`. -/ +theorem rowStabilityH_half_argument_gap + {x : ℝ} (hxQuarter : 1 / 4 ≀ x) (hxHalf : x ≀ 1 / 2) : + (1 / 1536 : ℝ) ≀ rowStabilityH x - rowStabilityH (x / 2) := by + let corrected : ℝ β†’ ℝ := fun z ↦ rowStabilityH z - z / 96 + have hx2pos : 0 < x / 2 := by linarith + have hmono : MonotoneOn corrected (Set.Icc (x / 2) x) := by + refine monotoneOn_of_hasDerivWithinAt_nonneg (convex_Icc (x / 2) x) + (fun z hz ↦ ((hasDerivAt_rowStabilityH + (by linarith [hz.1, hxQuarter]) (by linarith [hz.2, hxHalf])).sub + ((hasDerivAt_id z).div_const 96)).continuousAt.continuousWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo (x / 2) x := by simpa only [interior_Icc] using hz + exact ((hasDerivAt_rowStabilityH + (by linarith [hz'.1, hxQuarter]) + (by linarith [hz'.2, hxHalf])).sub + ((hasDerivAt_id z).div_const 96)).hasDerivWithinAt) + (fun z hz ↦ by + have hz' : z ∈ Set.Ioo (x / 2) x := by simpa only [interior_Icc] using hz + have hprime := rowStabilityHPrime_lower (x := z) + (by linarith [hz'.1, hxQuarter]) (by linarith [hz'.2, hxHalf]) + change 0 ≀ rowStabilityHPrime z - 1 / 96 + calc + 0 ≀ z / 12 - 1 / 96 := by + linarith [show (1 / 8 : ℝ) ≀ z by linarith [hz'.1, hxQuarter]] + _ ≀ rowStabilityHPrime z - 1 / 96 := sub_le_sub_right hprime _) + have h := hmono ⟨le_rfl, by linarith [hx2pos]⟩ + ⟨by linarith [hx2pos], le_rfl⟩ (by linarith [hx2pos]) + dsimp [corrected] at h + linarith [hxQuarter] + +/-- Two indices attaining respectively the largest and second-largest +coordinates of a finite vector. -/ +theorem exists_two_largest_coordinates + {n : β„•} (hn : 2 ≀ n) (p : Fin n β†’ ℝ) : + βˆƒ a b : Fin n, a β‰  b ∧ + (βˆ€ j, p j ≀ p a) ∧ (βˆ€ j, j β‰  a β†’ p j ≀ p b) := by + classical + have huniv : (Finset.univ : Finset (Fin n)).Nonempty := by + exact ⟨⟨0, by omega⟩, Finset.mem_univ _⟩ + obtain ⟨a, _, ha⟩ := Finset.exists_max_image Finset.univ p huniv + have hcard : 1 < Fintype.card (Fin n) := by + simpa only [Fintype.card_fin] using (show 1 < n by omega) + obtain ⟨c, hca⟩ := Fintype.exists_ne_of_one_lt_card hcard a + have herase : (Finset.univ.erase a : Finset (Fin n)).Nonempty := + ⟨c, Finset.mem_erase.mpr ⟨hca, Finset.mem_univ c⟩⟩ + obtain ⟨b, hbmem, hb⟩ := + Finset.exists_max_image (Finset.univ.erase a) p herase + refine ⟨a, b, ?_, fun j ↦ ha j (Finset.mem_univ j), ?_⟩ + Β· exact (Finset.mem_erase.mp hbmem).1.symm + Β· intro j hja + exact hb j (Finset.mem_erase.mpr ⟨hja, Finset.mem_univ j⟩) + +/-- The half--half vector supported on two distinct coordinates. -/ +noncomputable def halfHalfVector + {n : β„•} (a b : Fin n) (j : Fin n) : ℝ := + if j = a ∨ j = b then 1 / 2 else 0 + +/-- The L1 distance from the row vector to the half-half vector supported on the selected +indices. -/ +noncomputable def halfHalfL1Distance + {n : β„•} (p : Fin n β†’ ℝ) (a b : Fin n) : ℝ := + βˆ‘ j, |p j - halfHalfVector a b j| + +/-- Exact decomposition of the distance into the two distinguished-coordinate +errors and the mass outside them. -/ +theorem halfHalfL1Distance_eq + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + halfHalfL1Distance p a b = + |p a - 1 / 2| + |p b - 1 / 2| + (1 - p a - p b) := by + classical + rw [halfHalfL1Distance] + calc + (βˆ‘ j, |p j - halfHalfVector a b j|) = + βˆ‘ j, ((if j = a then |p a - 1 / 2| else 0) + + (if j = b then |p b - 1 / 2| else 0) + + (if j β‰  a ∧ j β‰  b then p j else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp [halfHalfVector, hab] + Β· by_cases hjb : j = b + Β· subst j + simp [halfHalfVector, hja] + Β· simp [halfHalfVector, hja, hjb, + abs_of_nonneg (hp.nonnegative j)] + _ = |p a - 1 / 2| + |p b - 1 / 2| + + βˆ‘ j, (if j β‰  a ∧ j β‰  b then p j else 0) := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + simp + _ = |p a - 1 / 2| + |p b - 1 / 2| + (1 - p a - p b) := by + congr 1 + have htail : (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) = + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j; simp + Β· by_cases hjb : j = b + Β· subst j; simp + Β· simp [hja, hjb, Ne.symm hja, Ne.symm hjb] + rw [htail, sum_away_from_two hp hab] + +theorem halfHalfL1Distance_of_below_half + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) + (ha0 : 0 ≀ p a) (hb0 : 0 ≀ p b) + (haHalf : p a ≀ 1 / 2) (hbHalf : p b ≀ 1 / 2) : + halfHalfL1Distance p a b = 2 * (1 - p a - p b) := by + classical + rw [halfHalfL1Distance] + calc + (βˆ‘ j, |p j - halfHalfVector a b j|) = + βˆ‘ j, ((if j = a then 1 / 2 - p a else 0) + + (if j = b then 1 / 2 - p b else 0) + + (if j β‰  a ∧ j β‰  b then p j else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + have hsign : p a - (2 : ℝ)⁻¹ ≀ 0 := by + norm_num at haHalf ⊒ + exact haHalf + simp [halfHalfVector, hab, abs_of_nonpos hsign] + Β· by_cases hjb : j = b + Β· subst j + have hsign : p b - (2 : ℝ)⁻¹ ≀ 0 := by + norm_num at hbHalf ⊒ + exact hbHalf + simp [halfHalfVector, hja, abs_of_nonpos hsign] + Β· simp [halfHalfVector, hja, hjb, abs_of_nonneg (hp.nonnegative j)] + _ = (βˆ‘ j, if j = a then 1 / 2 - p a else 0) + + (βˆ‘ j, if j = b then 1 / 2 - p b else 0) + + βˆ‘ j, (if j β‰  a ∧ j β‰  b then p j else 0) := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + _ = 2 * (1 - p a - p b) := by + have htail : (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) = + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp + Β· by_cases hjb : j = b + Β· subst j + simp + Β· simp [hja, hjb, Ne.symm hja, Ne.symm hjb] + rw [htail, sum_away_from_two hp hab] + simp + ring + +theorem halfHalfL1Distance_of_above_half + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) + (haHalf : 1 / 2 ≀ p a) (hb0 : 0 ≀ p b) (hbHalf : p b ≀ 1 / 2) : + halfHalfL1Distance p a b = + 2 * (p a - 1 / 2) + 2 * (1 - p a - p b) := by + classical + rw [halfHalfL1Distance] + calc + (βˆ‘ j, |p j - halfHalfVector a b j|) = + βˆ‘ j, ((if j = a then p a - 1 / 2 else 0) + + (if j = b then 1 / 2 - p b else 0) + + (if j β‰  a ∧ j β‰  b then p j else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + have hsign : 0 ≀ p a - (2 : ℝ)⁻¹ := by + norm_num at haHalf ⊒ + exact haHalf + simp [halfHalfVector, hab, abs_of_nonneg hsign] + Β· by_cases hjb : j = b + Β· subst j + have hsign : p b - (2 : ℝ)⁻¹ ≀ 0 := by + norm_num at hbHalf ⊒ + exact hbHalf + simp [halfHalfVector, hja, abs_of_nonpos hsign] + Β· simp [halfHalfVector, hja, hjb, abs_of_nonneg (hp.nonnegative j)] + _ = (βˆ‘ j, if j = a then p a - 1 / 2 else 0) + + (βˆ‘ j, if j = b then 1 / 2 - p b else 0) + + βˆ‘ j, (if j β‰  a ∧ j β‰  b then p j else 0) := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + _ = 2 * (p a - 1 / 2) + 2 * (1 - p a - p b) := by + have htail : (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) = + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp + Β· by_cases hjb : j = b + Β· subst j + simp + Β· simp [hja, hjb, Ne.symm hja, Ne.symm hjb] + rw [htail, sum_away_from_two hp hab] + simp + ring + +/-- A fourth root expressed using square roots, convenient for ordered-real +reasoning. -/ +noncomputable def fourthRoot (x : ℝ) : ℝ := + Real.sqrt (Real.sqrt x) + +theorem fourthRoot_nonneg (x : ℝ) : 0 ≀ fourthRoot x := + Real.sqrt_nonneg _ + +theorem le_fourthRoot_of_pow_four_le + {x d : ℝ} (hx : 0 ≀ x) (hd : 0 ≀ d) (hpow : x ^ 4 ≀ d) : + x ≀ fourthRoot d := by + have hx2 : 0 ≀ x ^ 2 := sq_nonneg x + have hxsq : x ^ 2 ≀ Real.sqrt d := by + rw [Real.le_sqrt hx2 hd] + convert hpow using 1 <;> ring + rw [fourthRoot, Real.le_sqrt hx (Real.sqrt_nonneg d)] + exact hxsq + +theorem self_le_fourthRoot + {d : ℝ} (hd0 : 0 ≀ d) (hd1 : d ≀ 1) : + d ≀ fourthRoot d := by + apply le_fourthRoot_of_pow_four_le hd0 hd0 + have hd2 : d ^ 2 ≀ d := by nlinarith + nlinarith [sq_nonneg (d ^ 2 - d)] + +theorem sum_rowStabilityF_eq + {n : β„•} (p : Fin n β†’ ℝ) : + (βˆ‘ i, rowStabilityF (p i)) = + -(βˆ‘ i, (1 - p i) * Real.log (1 - p i)) + + 1 / 2 * (βˆ‘ i, (p i) ^ 2) + + 1 / 3 * (βˆ‘ i, (p i) ^ 3) := by + simp only [rowStabilityF] + calc + (βˆ‘ i, (-(1 - p i) * Real.log (1 - p i) + + p i ^ 2 / 2 + p i ^ 3 / 3)) = + βˆ‘ i, (-(1 - p i) * Real.log (1 - p i) + + 1 / 2 * p i ^ 2 + 1 / 3 * p i ^ 3) := by + apply Finset.sum_congr rfl + intro i _ + ring + _ = -(βˆ‘ i, (1 - p i) * Real.log (1 - p i)) + + 1 / 2 * (βˆ‘ i, p i ^ 2) + 1 / 3 * (βˆ‘ i, p i ^ 3) := by + simp_rw [neg_mul] + rw [Finset.sum_add_distrib, Finset.sum_add_distrib, + Finset.sum_neg_distrib, ← Finset.mul_sum, ← Finset.mul_sum] + +theorem rowStabilityF_eq_mul_H {x : ℝ} (hx : 0 < x) : + rowStabilityF x = x * rowStabilityH x := by + rw [rowStabilityH] + field_simp [hx.ne'] + +/-- The separable defect is the average, under `p`, of the coordinate gaps +`C-h(p_i)`. -/ +theorem separableDefect_eq_sum_gap + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) : + rowStabilityC - βˆ‘ i, rowStabilityF (p i) = + βˆ‘ i, p i * (rowStabilityC - rowStabilityH (p i)) := by + have hF : (βˆ‘ i, rowStabilityF (p i)) = + βˆ‘ i, p i * rowStabilityH (p i) := by + apply Finset.sum_congr rfl + intro i _ + exact rowStabilityF_eq_mul_H (hp.2 i) + calc + rowStabilityC - βˆ‘ i, rowStabilityF (p i) = + rowStabilityC * (βˆ‘ i, p i) - + βˆ‘ i, p i * rowStabilityH (p i) := by + rw [hF, hp.1.sum_eq_one] + ring + _ = βˆ‘ i, p i * (rowStabilityC - rowStabilityH (p i)) := by + rw [Finset.mul_sum, ← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro i _ + ring + +/-- The defect between applying the row-stability function to the total tail mass and summing it +over individual tail entries. -/ +noncomputable def tailSeparableDefect + {n : β„•} (p : Fin n β†’ ℝ) (a : Fin n) : ℝ := + rowStabilityF (1 - p a) - + βˆ‘ j, if j β‰  a then rowStabilityF (p j) else 0 + +theorem separableDefect_eq_head_add_tail + {n : β„•} (p : Fin n β†’ ℝ) (a : Fin n) : + rowStabilityC - βˆ‘ i, rowStabilityF (p i) = + (rowStabilityC - rowStabilityF (p a) - rowStabilityF (1 - p a)) + + tailSeparableDefect p a := by + rw [tailSeparableDefect, sum_ite_ne_eq_sum_sub] + ring + +theorem tailSeparableDefect_eq_sum_gap + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + tailSeparableDefect p a = + βˆ‘ j, if j β‰  a then + p j * (rowStabilityH (1 - p a) - rowStabilityH (p j)) else 0 := by + have hpa1 : p a < 1 := by + have hbpos := hp.2 b + have hbmem : b ∈ (Finset.univ.erase a : Finset (Fin n)) := + Finset.mem_erase.mpr ⟨Ne.symm hab, Finset.mem_univ b⟩ + have hb_le : p b ≀ βˆ‘ j ∈ Finset.univ.erase a, p j := + Finset.single_le_sum (fun j _ ↦ hp.1.nonnegative j) hbmem + have htotal := Finset.sum_erase_add (s := Finset.univ) (f := p) + (Finset.mem_univ a) + rw [hp.1.sum_eq_one] at htotal + linarith + have htailSum : (βˆ‘ j, if j β‰  a then p j else 0) = 1 - p a := by + rw [sum_ite_ne_eq_sum_sub, hp.1.sum_eq_one] + rw [tailSeparableDefect, rowStabilityF_eq_mul_H (sub_pos.mpr hpa1)] + have hFtail : (βˆ‘ j, if j β‰  a then rowStabilityF (p j) else 0) = + βˆ‘ j, if j β‰  a then p j * rowStabilityH (p j) else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· simp [hja] + Β· simpa [hja] using rowStabilityF_eq_mul_H (hp.2 j) + rw [hFtail, ← htailSum, Finset.sum_mul, ← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a <;> simp [hja] <;> ring + +/-- Paper (34): the row deficit dominates a separable defect. -/ +theorem rowDeficit_ge_separable + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) : + rowStabilityC - βˆ‘ i, rowStabilityF (p i) ≀ rowDeficit p := by + have hT := rowT_le_cubic_bound hp + rw [rowDeficit, rowCorrection] + rw [sum_rowStabilityF_eq] + unfold rowStabilityC + linarith + +/-- In the variable `u = 2a-1`, this is the separable row defect +`C-F(a)-F(1-a)` from the proof of paper Lemma 8. -/ +noncomputable def bernoulliExcess (u : ℝ) : ℝ := + (1 + u) / 2 * Real.log (1 + u) + + (1 - u) / 2 * Real.log (1 - u) - u ^ 2 / 2 + +theorem hasDerivAt_bernoulliExcess + {u : ℝ} (huLeft : -1 < u) (huRight : u < 1) : + HasDerivAt bernoulliExcess + (1 / 2 * Real.log ((1 + u) / (1 - u)) - u) u := by + have hp : HasDerivAt (fun x : ℝ ↦ (1 + x) / 2) (1 / 2) u := by + convert! ((hasDerivAt_const u 1).add (hasDerivAt_id u)).div_const 2 using 1 <;> + ring + have hm : HasDerivAt (fun x : ℝ ↦ (1 - x) / 2) (-1 / 2) u := by + convert! ((hasDerivAt_const u 1).sub (hasDerivAt_id u)).div_const 2 using 1 <;> + ring + have hlp : HasDerivAt (fun x : ℝ ↦ Real.log (1 + x)) + (1 / (1 + u)) u := by + convert! ((hasDerivAt_const u 1).add (hasDerivAt_id u)).log (by + simpa using (show (1 : ℝ) + u β‰  0 by linarith)) using 1 <;> + simp + have hlm : HasDerivAt (fun x : ℝ ↦ Real.log (1 - x)) + (-1 / (1 - u)) u := by + convert! ((hasDerivAt_const u 1).sub (hasDerivAt_id u)).log (by + simpa using (show (1 : ℝ) - u β‰  0 by linarith)) using 1 <;> + simp + have hsq : HasDerivAt (fun x : ℝ ↦ x ^ 2 / 2) u u := by + convert! (hasDerivAt_pow 2 u).div_const 2 using 1 <;> ring + have h := (hp.mul hlp).add (hm.mul hlm) |>.sub hsq + unfold bernoulliExcess + convert! h using 1 + rw [Real.log_div (by linarith : 1 + u β‰  0) (by linarith : 1 - u β‰  0)] + field_simp [(show 1 + u β‰  0 by linarith), + (show 1 - u β‰  0 by linarith)] <;> ring + +/-- The first two terms in the power series for `artanh`. -/ +theorem one_add_cube_third_le_artanh + {u : ℝ} (hu0 : 0 ≀ u) (hu1 : u < 1) : + u + u ^ 3 / 3 ≀ Real.artanh u := by + have hseries := Real.sum_range_le_log_div hu0 hu1 2 + rw [← Real.artanh_eq_half_log (by exact ⟨by linarith, hu1.le⟩)] at hseries + norm_num [Finset.sum_range_succ] at hseries ⊒ + simpa [pow_succ] using hseries + +/-- Subtracts the quartic correction `u^4 / 12` from the Bernoulli excess. -/ +noncomputable def correctedBernoulliExcess (u : ℝ) : ℝ := + bernoulliExcess u - u ^ 4 / 12 + +theorem hasDerivAt_correctedBernoulliExcess + {u : ℝ} (huLeft : -1 < u) (huRight : u < 1) : + HasDerivAt correctedBernoulliExcess + (Real.artanh u - u - u ^ 3 / 3) u := by + have hpow : HasDerivAt (fun x : ℝ ↦ x ^ 4 / 12) (u ^ 3 / 3) u := by + convert! (hasDerivAt_pow 4 u).div_const 12 using 1 <;> ring + have h := (hasDerivAt_bernoulliExcess huLeft huRight).sub hpow + unfold correctedBernoulliExcess + convert! h using 1 + rw [Real.artanh_eq_half_log (by exact ⟨huLeft.le, huRight.le⟩)] + +/-- Quartic separation from the half--half equality case, paper (37). -/ +theorem bernoulliExcess_quartic + {u : ℝ} (hu0 : 0 ≀ u) (hu1 : u < 1) : + u ^ 4 / 12 ≀ bernoulliExcess u := by + have hmono : MonotoneOn correctedBernoulliExcess (Set.Icc 0 u) := by + refine monotoneOn_of_hasDerivWithinAt_nonneg (convex_Icc 0 u) + (fun y hy ↦ (hasDerivAt_correctedBernoulliExcess + (by linarith [hy.1]) (by linarith [hy.2])).continuousAt.continuousWithinAt) + (fun y hy ↦ by + have hy' : y ∈ Set.Ioo 0 u := by + simpa only [interior_Icc] using hy + exact (hasDerivAt_correctedBernoulliExcess + (by linarith [hy'.1]) (by linarith [hy'.2, hu1])).hasDerivWithinAt) + (fun y hy ↦ by + have hy' : y ∈ Set.Ioo 0 u := by + simpa only [interior_Icc] using hy + have hy0 : 0 ≀ y := by + exact hy'.1.le + have hy1 : y < 1 := by + have := hy'.2 + linarith + linarith [one_add_cube_third_le_artanh hy0 hy1]) + have h := hmono (show 0 ∈ Set.Icc (0 : ℝ) u by exact ⟨le_rfl, hu0⟩) + (show u ∈ Set.Icc (0 : ℝ) u by exact ⟨hu0, le_rfl⟩) hu0 + simpa [correctedBernoulliExcess, bernoulliExcess] using h + +theorem row_defect_eq_bernoulliExcess + {a : ℝ} (ha0 : 0 < a) (ha1 : a < 1) : + rowStabilityC - rowStabilityF a - rowStabilityF (1 - a) = + bernoulliExcess (2 * a - 1) := by + have h1a : 0 < 1 - a := sub_pos.mpr ha1 + have hplus : 1 + (2 * a - 1) = 2 * a := by ring + have hminus : 1 - (2 * a - 1) = 2 * (1 - a) := by ring + rw [rowStabilityC, rowStabilityF, rowStabilityF, bernoulliExcess, + hplus, hminus, + Real.log_mul (by norm_num : (2 : ℝ) β‰  0) ha0.ne', + Real.log_mul (by norm_num : (2 : ℝ) β‰  0) h1a.ne'] + ring + +/-- Paper (37), in the original largest-coordinate variable. -/ +theorem row_defect_quartic + {a : ℝ} (haHalf : 1 / 2 ≀ a) (ha1 : a < 1) : + 4 / 3 * (a - 1 / 2) ^ 4 ≀ + rowStabilityC - rowStabilityF a - rowStabilityF (1 - a) := by + have ha0 : 0 < a := by linarith + have hu0 : 0 ≀ 2 * a - 1 := by linarith + have hu1 : 2 * a - 1 < 1 := by linarith + rw [row_defect_eq_bernoulliExcess ha0 ha1] + have h := bernoulliExcess_quartic hu0 hu1 + convert h using 1 <;> ring + +theorem halfHalfVector_nonnegative + {n : β„•} (a b j : Fin n) : 0 ≀ halfHalfVector a b j := by + rw [halfHalfVector] + split_ifs <;> norm_num + +theorem sum_halfHalfVector + {n : β„•} {a b : Fin n} (hab : a β‰  b) : + (βˆ‘ j, halfHalfVector a b j) = 1 := by + classical + simp only [halfHalfVector] + have hrewrite : + (βˆ‘ j : Fin n, if j = a ∨ j = b then (1 / 2 : ℝ) else 0) = + βˆ‘ j : Fin n, ((if j = a then (1 / 2 : ℝ) else 0) + + (if j = b then (1 / 2 : ℝ) else 0)) := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j + simp [hab] + Β· by_cases hjb : j = b <;> simp [hja, hjb, Ne.symm hab] + rw [hrewrite, Finset.sum_add_distrib] + norm_num + +/-- The total-variation diameter of the probability simplex, specialized to +the half--half comparison vector. -/ +theorem halfHalfL1Distance_le_two + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) : + halfHalfL1Distance p a b ≀ 2 := by + rw [halfHalfL1Distance] + calc + (βˆ‘ j, |p j - halfHalfVector a b j|) ≀ + βˆ‘ j, (p j + halfHalfVector a b j) := by + apply Finset.sum_le_sum + intro j _ + calc + |p j - halfHalfVector a b j| ≀ + |p j| + |halfHalfVector a b j| := + abs_sub (p j) (halfHalfVector a b j) + _ = p j + halfHalfVector a b j := by + rw [abs_of_nonneg (hp.nonnegative j), + abs_of_nonneg (halfHalfVector_nonnegative a b j)] + _ = 2 := by + rw [Finset.sum_add_distrib, hp.sum_eq_one, sum_halfHalfVector hab] + norm_num + +theorem rowStabilityH_gap_nonnegative + {x : ℝ} (hx0 : 0 < x) (hxHalf : x ≀ 1 / 2) : + 0 ≀ rowStabilityC - rowStabilityH x := by + rw [← rowStabilityH_half] + exact sub_nonneg.mpr (rowStabilityH_mono hx0 hxHalf le_rfl) + +/-- Coordinates below `1/4` pay a fixed per-unit-mass separable cost. -/ +theorem rowStabilityH_gap_of_lt_quarter + {x : ℝ} (hx0 : 0 < x) (hxQuarter : x < 1 / 4) : + (1 / 192 : ℝ) ≀ rowStabilityC - rowStabilityH x := by + have hmono := rowStabilityH_mono hx0 hxQuarter.le + (show (1 / 4 : ℝ) ≀ 1 / 2 by norm_num) + have hgap := rowStabilityH_gap_to_half + (x := (1 / 4 : ℝ)) le_rfl (by norm_num) + norm_num at hgap + linarith + +theorem separableDefect_nonnegative_of_le_half + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + (hhalf : βˆ€ i, p i ≀ 1 / 2) : + 0 ≀ rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + rw [separableDefect_eq_sum_gap hp] + exact Finset.sum_nonneg (fun i _ ↦ + mul_nonneg (hp.1.nonnegative i) + (rowStabilityH_gap_nonnegative (hp.2 i) (hhalf i))) + +theorem separableDefect_ge_of_max_lt_quarter + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a : Fin n} (hmax : βˆ€ j, p j ≀ p a) (haQuarter : p a < 1 / 4) : + (1 / 192 : ℝ) ≀ rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + rw [separableDefect_eq_sum_gap hp] + calc + (1 / 192 : ℝ) = βˆ‘ i, p i / 192 := by + rw [← Finset.sum_div, hp.1.sum_eq_one] + _ ≀ βˆ‘ i, p i * (rowStabilityC - rowStabilityH (p i)) := by + apply Finset.sum_le_sum + intro i _ + have hgap := rowStabilityH_gap_of_lt_quarter (hp.2 i) + (lt_of_le_of_lt (hmax i) haQuarter) + have hmul := mul_le_mul_of_nonneg_left hgap (hp.1.nonnegative i) + nlinarith + +theorem separableDefect_ge_tail_below_quarter + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hsecond : βˆ€ j, j β‰  a β†’ p j ≀ p b) + (haHalf : p a ≀ 1 / 2) (hbQuarter : p b < 1 / 4) : + (1 - p a) / 192 ≀ rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + rw [separableDefect_eq_sum_gap hp] + calc + (1 - p a) / 192 = βˆ‘ i, if i β‰  a then p i / 192 else 0 := by + have hsum : (βˆ‘ i, if i β‰  a then p i else 0) = 1 - p a := by + rw [sum_ite_ne_eq_sum_sub, hp.1.sum_eq_one] + calc + (1 - p a) / 192 = + (βˆ‘ i, if i β‰  a then p i else 0) / 192 := by rw [hsum] + _ = βˆ‘ i, (if i β‰  a then p i else 0) / 192 := by + simpa using (Finset.sum_div Finset.univ + (fun i : Fin n ↦ if i β‰  a then p i else 0) (192 : ℝ)) + _ = βˆ‘ i, if i β‰  a then p i / 192 else 0 := by + apply Finset.sum_congr rfl + intro i _ + by_cases hia : i = a <;> simp [hia] + _ ≀ βˆ‘ i, p i * (rowStabilityC - rowStabilityH (p i)) := by + apply Finset.sum_le_sum + intro i _ + by_cases hia : i = a + Β· simp only [hia, ne_eq, not_true_eq_false, ite_false] + exact mul_nonneg (hp.1.nonnegative a) + (rowStabilityH_gap_nonnegative (hp.2 a) haHalf) + Β· have hgap := rowStabilityH_gap_of_lt_quarter (hp.2 i) + (lt_of_le_of_lt (hsecond i hia) hbQuarter) + have hmul := mul_le_mul_of_nonneg_left hgap (hp.1.nonnegative i) + simpa [hia, div_eq_mul_inv] using hmul + +theorem separableDefect_ge_two_coordinates + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) (hhalf : βˆ€ i, p i ≀ 1 / 2) + (haQuarter : 1 / 4 ≀ p a) (hbQuarter : 1 / 4 ≀ p b) : + (1 / 192 : ℝ) * (1 - p a - p b) ≀ + rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + let f : Fin n β†’ ℝ := fun i ↦ + p i * (rowStabilityC - rowStabilityH (p i)) + have hfnon : βˆ€ i, 0 ≀ f i := fun i ↦ + mul_nonneg (hp.1.nonnegative i) + (rowStabilityH_gap_nonnegative (hp.2 i) (hhalf i)) + have hcoord : βˆ€ {i : Fin n}, 1 / 4 ≀ p i β†’ + (1 / 192 : ℝ) * (1 / 2 - p i) ≀ f i := by + intro i hiQuarter + have hgap := rowStabilityH_gap_to_half hiQuarter (hhalf i) + calc + (1 / 192 : ℝ) * (1 / 2 - p i) = + (1 / 4) * ((1 / 48) * (1 / 2 - p i)) := by ring + _ ≀ p i * ((1 / 48) * (1 / 2 - p i)) := + mul_le_mul_of_nonneg_right hiQuarter + (mul_nonneg (by norm_num) (sub_nonneg.mpr (hhalf i))) + _ ≀ p i * (rowStabilityC - rowStabilityH (p i)) := + mul_le_mul_of_nonneg_left hgap (hp.1.nonnegative i) + _ = f i := rfl + have hbmem : b ∈ (Finset.univ.erase a : Finset (Fin n)) := + Finset.mem_erase.mpr ⟨Ne.symm hab, Finset.mem_univ b⟩ + have hb_le : f b ≀ βˆ‘ i ∈ Finset.univ.erase a, f i := + Finset.single_le_sum (fun i _ ↦ hfnon i) hbmem + have hdecomp := Finset.sum_erase_add (s := Finset.univ) (f := f) + (Finset.mem_univ a) + rw [separableDefect_eq_sum_gap hp] + change (1 / 192 : ℝ) * (1 - p a - p b) ≀ βˆ‘ i, f i + have haLower := hcoord haQuarter + have hbLower := hcoord hbQuarter + nlinarith + +/-- Quantitative stability when the largest coordinate is at most `1/2`. +The small-deficit hypothesis forces the two largest coordinates into the +interval `[1/4,1/2]`, where the explicit linear gap estimate applies. -/ +theorem below_half_distance_le_rowDeficit + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) + (hmax : βˆ€ j, p j ≀ p a) (hsecond : βˆ€ j, j β‰  a β†’ p j ≀ p b) + (haHalf : p a ≀ 1 / 2) + (hsep : rowStabilityC - βˆ‘ i, rowStabilityF (p i) ≀ rowDeficit p) + (hdsmall : rowDeficit p < 1 / 768) : + halfHalfL1Distance p a b ≀ 384 * rowDeficit p := by + have hhalf : βˆ€ i, p i ≀ 1 / 2 := fun i ↦ (hmax i).trans haHalf + have haQuarter : 1 / 4 ≀ p a := by + by_contra h + have hcost := separableDefect_ge_of_max_lt_quarter hp hmax + (lt_of_not_ge h) + linarith + have hbQuarter : 1 / 4 ≀ p b := by + by_contra h + have hcost := separableDefect_ge_tail_below_quarter hp hsecond haHalf + (lt_of_not_ge h) + have htail : 1 / 2 ≀ 1 - p a := by linarith + linarith + have hcost := separableDefect_ge_two_coordinates hp hab hhalf + haQuarter hbQuarter + rw [halfHalfL1Distance_of_below_half hp.1 hab + (hp.1.nonnegative a) (hp.1.nonnegative b) haHalf (hhalf b)] + nlinarith + +theorem coordinate_le_complement + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a j : Fin n} (hja : j β‰  a) : p j ≀ 1 - p a := by + have hjmem : j ∈ (Finset.univ.erase a : Finset (Fin n)) := + Finset.mem_erase.mpr ⟨hja, Finset.mem_univ j⟩ + have hjle : p j ≀ βˆ‘ k ∈ Finset.univ.erase a, p k := + Finset.single_le_sum (fun k _ ↦ hp.nonnegative k) hjmem + have htotal := Finset.sum_erase_add (s := Finset.univ) (f := p) + (Finset.mem_univ a) + rw [hp.sum_eq_one] at htotal + linarith + +theorem tailSeparableDefect_nonnegative + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) (haHalf : 1 / 2 ≀ p a) : + 0 ≀ tailSeparableDefect p a := by + rw [tailSeparableDefect_eq_sum_gap hp hab] + apply Finset.sum_nonneg + intro j _ + by_cases hja : j = a + Β· simp [hja] + Β· have hmono := rowStabilityH_mono (hp.2 j) + (coordinate_le_complement hp.1 hja) + (show 1 - p a ≀ 1 / 2 by linarith) + simpa [hja] using + mul_nonneg (hp.1.nonnegative j) (sub_nonneg.mpr hmono) + +theorem coordinate_le_outside_two + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsProbabilityVector p) + {a b j : Fin n} (hab : a β‰  b) (hja : j β‰  a) (hjb : j β‰  b) : + p j ≀ 1 - p a - p b := by + have hterm : p j = if a β‰  j ∧ b β‰  j then p j else 0 := by + simp [Ne.symm hja, Ne.symm hjb] + rw [hterm, ← sum_away_from_two hp hab] + exact Finset.single_le_sum + (f := fun k ↦ if a β‰  k ∧ b β‰  k then p k else 0) + (fun k _ ↦ by + by_cases h : a β‰  k ∧ b β‰  k <;> simp [h, hp.nonnegative k]) + (Finset.mem_univ j) + +/-- If the largest coordinate exceeds `1/2`, the tail's separable defect +controls the mass outside the two largest coordinates. -/ +theorem tailSeparableDefect_ge_second_gap + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) + (hsecond : βˆ€ j, j β‰  a β†’ p j ≀ p b) + (haHalf : 1 / 2 ≀ p a) (hqQuarter : 1 / 4 ≀ 1 - p a) : + (1 - p a - p b) / 1536 ≀ tailSeparableDefect p a := by + have hqHalf : 1 - p a ≀ 1 / 2 := by linarith + have hgapHalf := rowStabilityH_half_argument_gap hqQuarter hqHalf + rw [tailSeparableDefect_eq_sum_gap hp hab] + by_cases hcase : 1 - p a - p b ≀ (1 - p a) / 2 + Β· calc + (1 - p a - p b) / 1536 = + βˆ‘ j, if j β‰  a ∧ j β‰  b then p j / 1536 else 0 := by + have hout : (βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0) = + 1 - p a - p b := sum_away_from_two hp.1 hab + have horient : (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) = + 1 - p a - p b := by + calc + (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) = + βˆ‘ j, if a β‰  j ∧ b β‰  j then p j else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a + Β· subst j; simp + Β· by_cases hjb : j = b + Β· subst j; simp + Β· simp [hja, hjb, Ne.symm hja, Ne.symm hjb] + _ = 1 - p a - p b := hout + calc + (1 - p a - p b) / 1536 = + (βˆ‘ j, if j β‰  a ∧ j β‰  b then p j else 0) / 1536 := by + rw [horient] + _ = βˆ‘ j, (if j β‰  a ∧ j β‰  b then p j else 0) / 1536 := by + simpa using (Finset.sum_div Finset.univ + (fun j : Fin n ↦ if j β‰  a ∧ j β‰  b then p j else 0) (1536 : ℝ)) + _ = βˆ‘ j, if j β‰  a ∧ j β‰  b then p j / 1536 else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases h : j β‰  a ∧ j β‰  b <;> simp [h] + _ ≀ βˆ‘ j, if j β‰  a then + p j * (rowStabilityH (1 - p a) - rowStabilityH (p j)) else 0 := by + apply Finset.sum_le_sum + intro j _ + by_cases hja : j = a + Β· simp [hja] + Β· by_cases hjb : j = b + Β· subst j + have hble := coordinate_le_complement hp.1 (Ne.symm hab) + have hmono := rowStabilityH_mono (hp.2 b) hble hqHalf + simpa [Ne.symm hab] using + mul_nonneg (hp.1.nonnegative b) (sub_nonneg.mpr hmono) + Β· have hpjHalf : p j ≀ (1 - p a) / 2 := + (coordinate_le_outside_two hp.1 hab hja hjb).trans hcase + have hmono := rowStabilityH_mono (hp.2 j) hpjHalf + (show (1 - p a) / 2 ≀ 1 / 2 by linarith) + have hgap : (1 / 1536 : ℝ) ≀ + rowStabilityH (1 - p a) - rowStabilityH (p j) := by + linarith + have hmul := mul_le_mul_of_nonneg_left hgap (hp.1.nonnegative j) + simpa [hja, hjb, div_eq_mul_inv] using hmul + Β· have htailMass : + (βˆ‘ j, if j β‰  a then p j else 0) = 1 - p a := by + rw [sum_ite_ne_eq_sum_sub, hp.1.sum_eq_one] + have hsumLower : (1 - p a) / 1536 ≀ + βˆ‘ j, if j β‰  a then + p j * (rowStabilityH (1 - p a) - rowStabilityH (p j)) else 0 := by + calc + (1 - p a) / 1536 = + βˆ‘ j, if j β‰  a then p j / 1536 else 0 := by + calc + (1 - p a) / 1536 = + (βˆ‘ j, if j β‰  a then p j else 0) / 1536 := by + rw [htailMass] + _ = βˆ‘ j, (if j β‰  a then p j else 0) / 1536 := by + simpa using (Finset.sum_div Finset.univ + (fun j : Fin n ↦ if j β‰  a then p j else 0) (1536 : ℝ)) + _ = βˆ‘ j, if j β‰  a then p j / 1536 else 0 := by + apply Finset.sum_congr rfl + intro j _ + by_cases hja : j = a <;> simp [hja] + _ ≀ βˆ‘ j, if j β‰  a then + p j * (rowStabilityH (1 - p a) - rowStabilityH (p j)) else 0 := by + apply Finset.sum_le_sum + intro j _ + by_cases hja : j = a + Β· simp [hja] + Β· have hpbHalf : p b ≀ (1 - p a) / 2 := by + have hpb0 := hp.1.nonnegative b + have := lt_of_not_ge hcase + linarith + have hpjHalf := (hsecond j hja).trans hpbHalf + have hmono := rowStabilityH_mono (hp.2 j) hpjHalf + (show (1 - p a) / 2 ≀ 1 / 2 by linarith) + have hgap : (1 / 1536 : ℝ) ≀ + rowStabilityH (1 - p a) - rowStabilityH (p j) := by + linarith + have hmul := mul_le_mul_of_nonneg_left hgap (hp.1.nonnegative j) + simpa [hja, div_eq_mul_inv] using hmul + have htail_ge : 1 - p a - p b ≀ 1 - p a := by + linarith [hp.1.nonnegative b] + linarith + +/-- Quantitative stability when the largest coordinate is at least `1/2`. +The quartic head gap controls its displacement from `1/2`, while the linear +tail gap controls the mass outside the two largest coordinates. -/ +theorem above_half_distance_le_rowDeficit + {n : β„•} {p : Fin n β†’ ℝ} (hp : IsStrictProbabilityVector p) + {a b : Fin n} (hab : a β‰  b) + (hsecond : βˆ€ j, j β‰  a β†’ p j ≀ p b) + (haHalf : 1 / 2 ≀ p a) + (hsep : rowStabilityC - βˆ‘ i, rowStabilityF (p i) ≀ rowDeficit p) + (hdsmall : rowDeficit p < 1 / 768) : + halfHalfL1Distance p a b ≀ + 2 * fourthRoot (rowDeficit p) + 3072 * rowDeficit p := by + have hpbq := coordinate_le_complement hp.1 (Ne.symm hab) + have hpa1 : p a < 1 := by linarith [hp.2 b] + have htailNonneg := tailSeparableDefect_nonnegative hp hab haHalf + have hdecomp := separableDefect_eq_head_add_tail p a + have hquart := row_defect_quartic haHalf hpa1 + have hhead_le : 4 / 3 * (p a - 1 / 2) ^ 4 ≀ + rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + linarith + have hqQuarter : 1 / 4 ≀ 1 - p a := by + by_contra h + have hx : (1 / 4 : ℝ) ≀ p a - 1 / 2 := by + linarith [lt_of_not_ge h] + have hpow : (1 / 4 : ℝ) ^ 4 ≀ (p a - 1 / 2) ^ 4 := + pow_le_pow_leftβ‚€ (by norm_num) hx 4 + norm_num at hpow + linarith + have htailGap := tailSeparableDefect_ge_second_gap hp hab hsecond + haHalf hqQuarter + have htail_le : tailSeparableDefect p a ≀ + rowStabilityC - βˆ‘ i, rowStabilityF (p i) := by + have hhead0 : 0 ≀ 4 / 3 * (p a - 1 / 2) ^ 4 := + mul_nonneg (by norm_num) (pow_nonneg (by linarith) 4) + linarith + have houtside : 1 - p a - p b ≀ 1536 * rowDeficit p := by + linarith + have hpowD : (p a - 1 / 2) ^ 4 ≀ rowDeficit p := by + have hxnon : 0 ≀ (p a - 1 / 2) ^ 4 := pow_nonneg (by linarith) 4 + nlinarith + have hd0 : 0 ≀ rowDeficit p := + (pow_nonneg (by linarith : 0 ≀ p a - 1 / 2) 4).trans hpowD + have hroot : p a - 1 / 2 ≀ fourthRoot (rowDeficit p) := + le_fourthRoot_of_pow_four_le (by linarith) hd0 hpowD + have hbHalf : p b ≀ 1 / 2 := hpbq.trans (by linarith) + rw [halfHalfL1Distance_of_above_half hp.1 hab haHalf + (hp.1.nonnegative b) hbHalf] + linarith + +/-- A fully explicit, strict-support version of paper Lemma 8. The sharp +one-row inequality is kept as an explicit argument for modularity and is +proved in `SourceAnariRezaeiList`; all stability and compactness arguments are +discharged here with the concrete constant `3074`. Strict support is exactly +the case used for rows of the Gibbs marginal matrix associated with a positive +input matrix. -/ +theorem row_stability_explicit + (hrow : AnariRezaeiRowInequality) + {n : β„•} (hn : 2 ≀ n) (p : Fin n β†’ ℝ) + (hp : IsStrictProbabilityVector p) : + βˆƒ a b : Fin n, a β‰  b ∧ + halfHalfL1Distance p a b ≀ 3074 * fourthRoot (rowDeficit p) := by + obtain ⟨a, b, hab, hmax, hsecond⟩ := exists_two_largest_coordinates hn p + refine ⟨a, b, hab, ?_⟩ + have hd0 : 0 ≀ rowDeficit p := hrow hn p hp.1 + have hsep := rowDeficit_ge_separable hp + by_cases hdsmall : rowDeficit p < 1 / 768 + Β· have hd1 : rowDeficit p ≀ 1 := by linarith + have hdroot := self_le_fourthRoot hd0 hd1 + by_cases haHalf : p a ≀ 1 / 2 + Β· have hdist := below_half_distance_le_rowDeficit hp hab hmax hsecond + haHalf hsep hdsmall + nlinarith [fourthRoot_nonneg (rowDeficit p)] + Β· have hdist := above_half_distance_le_rowDeficit hp hab hsecond + (le_of_not_ge haHalf) hsep hdsmall + nlinarith [fourthRoot_nonneg (rowDeficit p)] + Β· have hdist := halfHalfL1Distance_le_two hp.1 hab + have hdlarge : 1 / 768 ≀ rowDeficit p := le_of_not_gt hdsmall + by_cases hd1 : rowDeficit p ≀ 1 + Β· have hdroot := self_le_fourthRoot hd0 hd1 + nlinarith + Β· have hone : (1 : ℝ) ≀ fourthRoot (rowDeficit p) := by + apply le_fourthRoot_of_pow_four_le (by norm_num) hd0 + norm_num + exact le_of_not_ge hd1 + nlinarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheBisection.lean b/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheBisection.lean new file mode 100644 index 0000000000..4ab11e2744 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheBisection.lean @@ -0,0 +1,377 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ScannedBetheThresholdFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.BetheBisection +public import Mathlib.Tactic + +/-! +# Rational bisection for the row-major Bethe oracle + +The earlier semantic bisection permits a different choice among violated +floor constraints. This file follows the implemented row-major oracle +exactly. Its proof uses only validity and acceptance of that oracle, so the +optimization guarantee is unchanged even though the returned rational point +need not be byte-for-byte equal to the earlier runner's point. +-/ + +@[expose] public section + +namespace BeyondBethe + +/-- Tests the midpoint with scanned threshold feasibility, lowering the upper endpoint and +recording a witness on acceptance or raising the lower endpoint otherwise. -/ +def scannedBetheBisectionStep {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + (s : BetheBisectionState (m * m + 1)) : + BetheBisectionState (m * m + 1) := + let mid := (s.low + s.high) / 2 + match runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat mid) r with + | .accepted q => ⟨s.low, mid, some q⟩ + | .exhausted _ => ⟨mid, s.high, s.witness⟩ + +/-- Iterates scanned Bethe bisection for the requested number of steps. -/ +def runScannedBetheBisection {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) : + β„• β†’ BetheBisectionState (m * m + 1) β†’ + BetheBisectionState (m * m + 1) + | 0, s => s + | N + 1, s => runScannedBetheBisection tau A p delta r N + (scannedBetheBisectionStep tau A p delta r s) + +/-- Initializes the scanned bisection interval and records a witness exactly when feasibility +accepts the initial high threshold. -/ +def initialScannedBetheBisectionState {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (mix r : β„š) : + BetheBisectionState (m * m + 1) := + let high := betheBisectionInitialHigh A mix r + match runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat high) r with + | .accepted q => ⟨betheNegativeObjectiveLower m, high, some q⟩ + | .exhausted _ => ⟨betheNegativeObjectiveLower m, high, none⟩ + +@[simp] theorem initialScannedBetheBisectionState_low {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (mix r : β„š) : + (initialScannedBetheBisectionState tau A p delta mix r).low = + betheNegativeObjectiveLower m := by + rw [initialScannedBetheBisectionState] + split <;> rfl + +@[simp] theorem initialScannedBetheBisectionState_high {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (mix r : β„š) : + (initialScannedBetheBisectionState tau A p delta mix r).high = + betheBisectionInitialHigh A mix r := by + rw [initialScannedBetheBisectionState] + split <;> rfl + +/-- Requires any stored witness to be the scanned feasibility result at the current high +threshold and to satisfy the accepted epigraph-oracle predicate. -/ +def ScannedBetheBisectionWitnessValid {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + (s : BetheBisectionState (m * m + 1)) : Prop := + βˆ€ q, s.witness = some q β†’ + runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat s.high) r = .accepted q ∧ + BetheEpigraphOracleAccepted tau A p delta.value s.high q + +theorem initialScannedBetheBisectionState_witnessValid {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (mix r : β„š) : + ScannedBetheBisectionWitnessValid tau A p delta r + (initialScannedBetheBisectionState tau A p delta mix r) := by + intro q hq + rw [initialScannedBetheBisectionState] at hq ⊒ + split at hq <;> rename_i hrun + Β· cases hq + refine ⟨hrun, ?_⟩ + simpa only [rawRatOfRat_value] using + runExplicitScannedBetheThresholdFeasibility_acceptsOnly + tau A p delta _ r hrun + Β· contradiction + +theorem scannedBetheBisectionStep_witnessValid {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + {s : BetheBisectionState (m * m + 1)} + (hs : ScannedBetheBisectionWitnessValid tau A p delta r s) : + ScannedBetheBisectionWitnessValid tau A p delta r + (scannedBetheBisectionStep tau A p delta r s) := by + intro q hq + rw [scannedBetheBisectionStep] at hq ⊒ + split at hq <;> rename_i hrun + Β· cases hq + refine ⟨hrun, ?_⟩ + simpa only [rawRatOfRat_value] using + runExplicitScannedBetheThresholdFeasibility_acceptsOnly + tau A p delta _ r hrun + Β· exact hs q hq + +theorem runScannedBetheBisection_witnessValid {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + {s : BetheBisectionState (m * m + 1)} + (hs : ScannedBetheBisectionWitnessValid tau A p delta r s) (N : β„•) : + ScannedBetheBisectionWitnessValid tau A p delta r + (runScannedBetheBisection tau A p delta r N s) := by + induction N generalizing s with + | zero => simpa [runScannedBetheBisection] using hs + | succ N ih => + rw [runScannedBetheBisection] + exact ih (scannedBetheBisectionStep_witnessValid tau A p delta r hs) + +theorem scannedBetheBisectionStep_width {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + (s : BetheBisectionState (m * m + 1)) : + (scannedBetheBisectionStep tau A p delta r s).high - + (scannedBetheBisectionStep tau A p delta r s).low = + (s.high - s.low) / 2 := by + rw [scannedBetheBisectionStep] + split <;> ring + +theorem runScannedBetheBisection_width {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) (N : β„•) + (s : BetheBisectionState (m * m + 1)) : + (runScannedBetheBisection tau A p delta r N s).high - + (runScannedBetheBisection tau A p delta r N s).low = + (s.high - s.low) / 2 ^ N := by + induction N generalizing s with + | zero => simp [runScannedBetheBisection] + | succ N ih => + rw [runScannedBetheBisection, ih, scannedBetheBisectionStep_width] + rw [pow_succ] + ring + +theorem scannedBetheBisectionStep_low_le_cutoff {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) {cutoff : ℝ} + (hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat u) r = .exhausted E β†’ + (u : ℝ) < cutoff) + {s : BetheBisectionState (m * m + 1)} + (hlow : (s.low : ℝ) ≀ cutoff) : + ((scannedBetheBisectionStep tau A p delta r s).low : β„š) ≀ + cutoff := by + rw [scannedBetheBisectionStep] + split <;> rename_i hrun + Β· exact hlow + Β· exact (hbelow _ _ hrun).le + +theorem runScannedBetheBisection_low_le_cutoff {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) {cutoff : ℝ} + (hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat u) r = .exhausted E β†’ + (u : ℝ) < cutoff) + {s : BetheBisectionState (m * m + 1)} + (hlow : (s.low : ℝ) ≀ cutoff) (N : β„•) : + (((runScannedBetheBisection tau A p delta r N s).low : β„š) : ℝ) ≀ + cutoff := by + induction N generalizing s with + | zero => simpa [runScannedBetheBisection] using hlow + | succ N ih => + rw [runScannedBetheBisection] + exact ih (scannedBetheBisectionStep_low_le_cutoff + tau A p delta r hbelow hlow) + +theorem runScannedBetheBisection_preserves_some {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta : RawRat) (r : β„š) + {s : BetheBisectionState (m * m + 1)} + (hsome : βˆƒ q, s.witness = some q) (N : β„•) : + βˆƒ q, (runScannedBetheBisection tau A p delta r N s).witness = some q := by + induction N generalizing s with + | zero => simpa [runScannedBetheBisection] using hsome + | succ N ih => + rw [runScannedBetheBisection] + apply ih + rw [scannedBetheBisectionStep] + split + Β· rename_i q hrun + exact ⟨q, rfl⟩ + Β· exact hsome + +theorem initialScannedBetheBisectionState_has_witness_of_optimizer + {m : β„•} (hm : 0 < m) {tau : β„š} (htau0 : 0 < tau) + (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix r : β„š} {delta : RawRat} + (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hdelta : 0 < delta.value) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : delta.value ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) tau) + (p : β„•) : + βˆƒ q, (initialScannedBetheBisectionState + tau A p delta mix r).witness = some q := by + have hupper := (negativeObjective_mem_initial_interval htau0.le htau1 + hApos hAupper hX).2 + have hthreshold : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (betheBisectionInitialHigh A mix r : ℝ) := by + rw [betheBisectionInitialHigh, betheSmoothingSlack] + push_cast + linarith + have hthreshold' : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ + ((rawRatOfRat (betheBisectionInitialHigh A mix r)).value : ℝ) := by + simpa only [rawRatOfRat_value] using hthreshold + obtain ⟨q, hrun, _⟩ := + runExplicitScannedBetheThresholdFeasibility_accepts_of_slack + (upper := rawRatOfRat (betheBisectionInitialHigh A mix r)) + hm htau0 htau1 hApos hAupper hX hmax hmix0 hmix1 hdelta hr + hspike hfloor hthreshold' p + refine ⟨q, ?_⟩ + rw [initialScannedBetheBisectionState, hrun] + +theorem runScannedBetheBisection_objective_gap + {m : β„•} (hm : 0 < m) {tau : β„š} (htau0 : 0 < tau) + (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix r : β„š} {delta : RawRat} + (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hdelta : 0 < delta.value) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : delta.value ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) tau) + (p N : β„•) : + let s0 := initialScannedBetheBisectionState tau A p delta mix r + let sN := runScannedBetheBisection tau A p delta r N s0 + βˆƒ q : Fin (m * m + 1) β†’ β„š, + sN.witness = some q ∧ + BetheEpigraphOracleAccepted tau A p delta.value sN.high q ∧ + IsDoublyStochastic (acceptedBetheMatrix q) ∧ + (βˆ€ i j, (delta.value : ℝ) ≀ acceptedBetheMatrix q i j) ∧ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X - + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + (betheSmoothingSlack A mix r : ℝ) + + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) + + (betheObjectiveEvaluationError m p : ℝ) := by + dsimp only + let s0 := initialScannedBetheBisectionState tau A p delta mix r + let sN := runScannedBetheBisection tau A p delta r N s0 + have hsome0 : βˆƒ q, s0.witness = some q := by + simpa only [s0] using + initialScannedBetheBisectionState_has_witness_of_optimizer + hm htau0 htau1 hApos hAupper hX hmax hmix0 hmix1 hdelta hr + hspike hfloor p + obtain ⟨q, hq⟩ := runScannedBetheBisection_preserves_some + tau A p delta r hsome0 N + have hqN : sN.witness = some q := by simpa only [sN] using hq + have hvalid0 := initialScannedBetheBisectionState_witnessValid + tau A p delta mix r + have hvalidN := runScannedBetheBisection_witnessValid + tau A p delta r hvalid0 N + have hcertificate : + BetheEpigraphOracleAccepted tau A p delta.value sN.high q := + (hvalidN q (by simpa only [sN] using hqN)).2 + have hbounds := negativeObjective_mem_initial_interval htau0.le htau1 + hApos hAupper hX + let cutoff : ℝ := + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (betheSmoothingSlack A mix r : ℝ) + have hslack0 : 0 ≀ betheSmoothingSlack A mix r := by + rw [betheSmoothingSlack] + exact add_nonneg + (mul_nonneg hmix0.le (rationalRegularizedObjectiveRange_nonneg A)) + (mul_nonneg (by norm_num) hr.le) + have hlow0 : (s0.low : ℝ) ≀ cutoff := by + rw [show s0.low = betheNegativeObjectiveLower m by + simp only [s0, initialScannedBetheBisectionState_low]] + dsimp only [cutoff] + have hslack0R : 0 ≀ (betheSmoothingSlack A mix r : ℝ) := + Rat.cast_nonneg.mpr hslack0 + linarith [hbounds.1] + have hbelow : βˆ€ (u : β„š) (E : RationalEllipsoidState (m * m + 1)), + runExplicitScannedBetheThresholdFeasibility + tau A p delta (rawRatOfRat u) r = .exhausted E β†’ + (u : ℝ) < cutoff := by + intro u E hrun + have h := + runExplicitScannedBetheThresholdFeasibility_exhausted_lt_optimum_add_slack + hm htau0 htau1 hApos hAupper hX hmax hmix0 hmix1 hdelta hr + hspike hfloor p hrun + dsimp only [cutoff] + rw [betheSmoothingSlack] + push_cast + simpa [add_assoc] using h + have hlowN : (sN.low : ℝ) ≀ cutoff := by + simpa only [sN] using runScannedBetheBisection_low_le_cutoff + tau A p delta r hbelow hlow0 N + have hwidthQ := runScannedBetheBisection_width tau A p delta r N s0 + have hwidth : (sN.high : ℝ) - (sN.low : ℝ) = + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) := by + have hwidthQ' : sN.high - sN.low = + (betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N := by + simpa only [sN, s0, initialScannedBetheBisectionState_high, + initialScannedBetheBisectionState_low] using hwidthQ + exact_mod_cast hwidthQ' + have hhigh : (sN.high : ℝ) ≀ cutoff + + (((betheBisectionInitialHigh A mix r - + betheNegativeObjectiveLower m) / 2 ^ N : β„š) : ℝ) := by + linarith + have hobjective := + BetheEpigraphOracleAccepted_exact_objective_upper_compact + hm htau0.le htau1 hApos hdelta hcertificate + have hheight : ((epigraphHeight q : β„š) : ℝ) ≀ (sN.high : ℝ) := by + exact_mod_cast hcertificate.2.1 + have hreturned : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + (sN.high : ℝ) + (betheObjectiveEvaluationError m p : ℝ) := by + have hobjective' : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) (acceptedBetheMatrix q) ≀ + ((epigraphHeight q : β„š) : ℝ) + + (betheObjectiveEvaluationError m p : ℝ) := by + simpa only [affineNegativeObjective, acceptedBetheMatrix] using hobjective + linarith + refine ⟨q, hqN, hcertificate, + BetheEpigraphOracleAccepted_doublyStochastic hdelta.le hcertificate, + BetheEpigraphOracleAccepted_entry_floor hcertificate, ?_⟩ + dsimp only [cutoff] at hhigh + linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheThresholdFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheThresholdFeasibility.lean new file mode 100644 index 0000000000..946f89db58 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ScannedBetheThresholdFeasibility.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.MachineBetheEpigraphOracle +public import LeanPool.BeyondBethe.BeyondBethe.ExplicitScheduledFeasibility +public import Mathlib.Tactic + +/-! # Scanned Bethe Threshold Feasibility -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Threshold feasibility for the implemented Bethe oracle + +The finite-word oracle scans the floor constraints in row-major order. This +file gives that exact oracle its semantic feasibility runner. The older +`betheBoundedEpigraphOracle` may choose a different violated floor constraint; +no equality between the two tie-breaking rules is needed. +-/ + +/-- Runs ball-based rational feasibility with the scanned bounded epigraph oracle, explicit +threshold budget, and epigraph outer radius. -/ +def runExplicitScannedBetheThresholdFeasibility {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) (r : β„š) : + RationalFeasibilityResult (m * m + 1) := + let R := betheEpigraphOuterRadius m upper.value r + runExplicitBallRationalFeasibility + (scannedBetheBoundedEpigraphOracle tau A p delta upper) + (betheThresholdFeasibilityBudget m upper.value r) R + +theorem runExplicitScannedBetheThresholdFeasibility_acceptsOnly {m : β„•} + (tau : β„š) (A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š) + (p : β„•) (delta upper : RawRat) (r : β„š) + {q : Fin (m * m + 1) β†’ β„š} + (hrun : runExplicitScannedBetheThresholdFeasibility + tau A p delta upper r = .accepted q) : + BetheEpigraphOracleAccepted tau A p delta.value upper.value q := by + exact runExplicitBallRationalFeasibility_acceptsOnly + (scannedBetheBoundedEpigraphOracle_acceptsOnly tau A p delta upper) + (by simpa only [runExplicitScannedBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun) + +theorem runExplicitScannedBetheThresholdFeasibility_accepts_of_slack + {m : β„•} (hm : 0 < m) {tau : β„š} (htau0 : 0 < tau) + (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix r : β„š} {delta upper : RawRat} + (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hdelta : 0 < delta.value) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : delta.value ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) tau) + (hslack : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper.value : ℝ)) + (p : β„•) : + βˆƒ q : Fin (m * m + 1) β†’ β„š, + runExplicitScannedBetheThresholdFeasibility + tau A p delta upper r = .accepted q ∧ + BetheEpigraphOracleAccepted + tau A p delta.value upper.value q := by + let delta0 : β„š := numericalInteriorFloor (m + 1) + (rationalMatrixEntryBitBound A) tau + have hoptimizerFloor : βˆ€ i j, (delta0 : ℝ) ≀ X i j := by + intro i j + exact (regularizedOptimizer_meets_executable_floor + (n := m + 1) (by omega) htau0 hApos hAupper hX hmax i j).1 + have hcross := BetheEpigraphTarget_smoothed_inner_cross hm htau0.le htau1 + hApos hAupper hX hoptimizerFloor + (Rat.cast_pos.mpr hmix0) (by exact_mod_cast hmix1) + (Rat.cast_nonneg.mpr hr.le) (by + have hs := (Rat.cast_le (K := ℝ)).mpr hspike + norm_num only [Rat.cast_div, Rat.cast_one, Rat.cast_natCast] at hs + simpa using hs) + (Ξ΄ := (delta.value : ℝ)) (upper := (upper.value : ℝ)) (by + exact_mod_cast hfloor) hslack + let ycenter := squareMatrixToVector (smoothedUniformAffineBase X (mix : ℝ)) + let zcenter := epigraphPoint ycenter ((upper.value : ℝ) - (r : ℝ)) + have hcross' : + (βˆ€ k, BetheEpigraphTarget (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + (delta.value : ℝ) (upper.value : ℝ) + (fun i ↦ zcenter i + if i = k then (r : ℝ) else 0)) ∧ + (βˆ€ k, BetheEpigraphTarget (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + (delta.value : ℝ) (upper.value : ℝ) + (fun i ↦ zcenter i - if i = k then (r : ℝ) else 0)) := by + simpa only [ycenter, zcenter] using hcross + have houter := BetheEpigraphTarget_inner_cross_outer_zero hm + (Rat.cast_nonneg.mpr hdelta.le) (Rat.cast_nonneg.mpr hr.le) ycenter + hcross'.1 hcross'.2 + have hR : 0 < betheEpigraphOuterRadius m upper.value r := + betheEpigraphOuterRadius_pos m hr.le + obtain ⟨q, hrun, hgood⟩ := + runExplicitBallRationalFeasibility_ball_accepts + (d := m * m + 1) (by omega) + (Target := BetheEpigraphTarget (tau : ℝ) (fun i j ↦ (A i j : ℝ)) + (delta.value : ℝ) (upper.value : ℝ)) + (Good := BetheEpigraphOracleAccepted + tau A p delta.value upper.value) + (oracle := scannedBetheBoundedEpigraphOracle tau A p delta upper) + (scannedBetheBoundedEpigraphOracle_valid hm htau0.le htau1 + hApos hdelta p upper) + (scannedBetheBoundedEpigraphOracle_acceptsOnly tau A p delta upper) + hR hr hcross'.1 hcross'.2 + (by + intro k + have hk := houter.1 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + (by + intro k + have hk := houter.2 k + rw [cast_betheEpigraphOuterRadius] + simpa [zcenter, ycenter] using hk) + refine ⟨q, ?_, hgood⟩ + simpa only [runExplicitScannedBetheThresholdFeasibility, + betheThresholdFeasibilityBudget] using hrun + +theorem runExplicitScannedBetheThresholdFeasibility_exhausted_lt_optimum_add_slack + {m : β„•} (hm : 0 < m) {tau : β„š} (htau0 : 0 < tau) + (htau1 : tau ≀ 1) + {A : Matrix (Fin (m + 1)) (Fin (m + 1)) β„š} + (hApos : βˆ€ i j, 0 < A i j) (hAupper : βˆ€ i j, A i j ≀ 1) + {X : Matrix (Fin (m + 1)) (Fin (m + 1)) ℝ} + (hX : IsDoublyStochastic X) + (hmax : βˆ€ Y, IsDoublyStochastic Y β†’ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) Y ≀ + regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X) + {mix r : β„š} {delta upper : RawRat} + (hmix0 : 0 < mix) (hmix1 : mix ≀ 1) + (hdelta : 0 < delta.value) (hr : 0 < r) + (hspike : r / mix ≀ 1 / (m + 1 : β„š)) + (hfloor : delta.value ≀ (1 - mix) * + numericalInteriorFloor (m + 1) (rationalMatrixEntryBitBound A) tau) + (p : β„•) {E : RationalEllipsoidState (m * m + 1)} + (hrun : runExplicitScannedBetheThresholdFeasibility + tau A p delta upper r = .exhausted E) : + (upper.value : ℝ) < + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) := by + by_contra hnot + have hslack : + -regularizedBetheObjective (tau : ℝ) + (fun i j ↦ (A i j : ℝ)) X + + (mix : ℝ) * (rationalRegularizedObjectiveRange A : ℝ) + + 2 * (r : ℝ) ≀ (upper.value : ℝ) := not_lt.mp hnot + obtain ⟨q, haccepted, _⟩ := + runExplicitScannedBetheThresholdFeasibility_accepts_of_slack + hm htau0 htau1 hApos hAupper hX hmax hmix0 hmix1 hdelta hr + hspike hfloor hslack p + rw [hrun] at haccepted + contradiction + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ScheduledFeasibility.lean b/LeanPool/BeyondBethe/BeyondBethe/ScheduledFeasibility.lean new file mode 100644 index 0000000000..ca7932527f --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ScheduledFeasibility.lean @@ -0,0 +1,384 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoidIteration +public import LeanPool.BeyondBethe.BeyondBethe.RationalFeasibility +public import LeanPool.BeyondBethe.BeyondBethe.RoundedFeasibility +public import Mathlib.Tactic + +/-! # Scheduled Feasibility -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Fixed-precision rational feasibility + +The public runner computes two determinant-free exponents from its initial +state and one precision from the total iteration budget. That precision is +then held fixed throughout the recursive loop. +-/ + +/-- Determinant-free initial exponent. -/ +def scheduledInitialDetExponent {d : β„•} + (E : RationalEllipsoidState d) : β„• := + positiveDyadicPrecision (rationalMatrixDeterminantLower E.basis) + +/-- Initial exponent dominating the total rational state magnitude. -/ +def scheduledInitialMagnitudeExponent {d : β„•} + (E : RationalEllipsoidState d) : β„• := + encodedBitLength β„š (rationalStateAbsBound E) + +theorem scheduledInitialDetExponent_lower {d : β„•} + (E : RationalEllipsoidState d) (hdet : Matrix.det E.basis β‰  0) : + dyadicMesh (scheduledInitialDetExponent E) ≀ + abs (Matrix.det E.basis) := by + exact (dyadicMesh_positiveDyadicPrecision_lt + (rationalMatrixDeterminantLower_pos E.basis)).le.trans + (rationalMatrixDeterminantLower_le_abs_det E.basis hdet) + +theorem scheduledInitialMagnitudeExponent_upper {d : β„•} + (E : RationalEllipsoidState d) : + rationalStateAbsBound E ≀ + (2 : β„š) ^ scheduledInitialMagnitudeExponent E := by + have hpos : 0 < rationalStateAbsBound E := + (show (0 : β„š) < 2 by norm_num).trans_le + (rationalStateAbsBound_two_le E) + exact (positive_rational_lt_two_pow_encodedBitLength hpos).le + +/-- The determinant-independent precision computed once for a feasibility +run. -/ +def scheduledFeasibilityPrecision {d : β„•} + (budget : β„•) (E : RationalEllipsoidState d) : β„• := + roundedEllipsoidPrecisionSchedule d + (scheduledInitialDetExponent E) + (scheduledInitialMagnitudeExponent E) budget + +/-- Recursive loop at a fixed precision. -/ +def runFixedPrecisionRationalFeasibility {d : β„•} (p : β„•) + (oracle : RationalCentralOracle d) : + β„• β†’ RationalEllipsoidState d β†’ RationalFeasibilityResult d + | 0, E => .exhausted E + | budget + 1, E => + match oracle E with + | .accept => .accepted E.center + | .cut a => runFixedPrecisionRationalFeasibility p oracle budget + (scheduledRoundedEllipsoidCentralUpdate p E a) + +/-- Public scheduled runner. Its precision contains no determinant +evaluation and is unchanged inside the loop. -/ +def runScheduledRationalFeasibility {d : β„•} + (oracle : RationalCentralOracle d) + (budget : β„•) (E : RationalEllipsoidState d) : + RationalFeasibilityResult d := + runFixedPrecisionRationalFeasibility + (scheduledFeasibilityPrecision budget E) oracle budget E + +theorem runFixedPrecisionRationalFeasibility_acceptsOnly {d p : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} {oracle : RationalCentralOracle d} + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {budget : β„•} {E : RationalEllipsoidState d} {x : Fin d β†’ β„š} + (hrun : runFixedPrecisionRationalFeasibility p oracle budget E = + .accepted x) : Good x := by + induction budget generalizing E with + | zero => simp [runFixedPrecisionRationalFeasibility] at hrun + | succ budget ih => + rw [runFixedPrecisionRationalFeasibility] at hrun + split at hrun <;> rename_i hresponse + Β· cases hrun + exact haccept E hresponse + Β· exact ih hrun + +theorem runScheduledRationalFeasibility_acceptsOnly {d : β„•} + {Good : (Fin d β†’ β„š) β†’ Prop} {oracle : RationalCentralOracle d} + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + {budget : β„•} {E : RationalEllipsoidState d} {x : Fin d β†’ β„š} + (hrun : runScheduledRationalFeasibility oracle budget E = .accepted x) : + Good x := by + exact runFixedPrecisionRationalFeasibility_acceptsOnly haccept + (by simpa only [runScheduledRationalFeasibility] using hrun) + +theorem scheduledRoundedEllipsoidCentralUpdate_contains_point {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) + {x : Fin d β†’ ℝ} (hcontains : RationalEllipsoidContains E x) + (ha : a β‰  0) + (hcut : finiteDot (fun i ↦ (a i : ℝ)) + (fun i ↦ x i - rationalCenterReal E i) ≀ 0) : + RationalEllipsoidContains + (scheduledRoundedEllipsoidCentralUpdate p E a) x := by + obtain ⟨y, hy, hpoint⟩ := hcontains + have hb := rationalPulledBackNormal_ne_zero_of_det_ne_zero E a hdet ha + have hpulled : finiteDot + (fun j ↦ (rationalPulledBackNormal E a j : ℝ)) y ≀ 0 := by + rw [← physicalDot_point_sub_center_eq_pulledDot E a y] + simpa only [hpoint] using hcut + obtain ⟨y', hy', hpoint'⟩ := + scheduledRoundedEllipsoidCentralUpdate_contains + hd E a hdet hb hp hy hpulled + exact ⟨y', hy', hpoint'.trans hpoint⟩ + +theorem scheduledContractionFactor_nonneg {d : β„•} (hd : 0 < d) : + 0 ≀ 1 - 1 / (32 * (d : ℝ) ^ 3) := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hden : (1 : ℝ) ≀ 32 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact sub_nonneg.mpr + ((div_le_one (by positivity : (0 : ℝ) < 32 * (d : ℝ) ^ 3)).2 hden) + +/-- Target preservation for a fixed-precision run. The global invariant +discharges the rounding precision at each recursive call. -/ +theorem runFixedPrecisionRationalFeasibility_preserves_target_of_exhausted + {d L K T t : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hInv : ScheduledEllipsoidInvariant d L K t E) + (hbudget : t + budget ≀ T) + (hrun : runFixedPrecisionRationalFeasibility + (roundedEllipsoidPrecisionSchedule d L K T) oracle budget E = + .exhausted E') + {x : Fin d β†’ ℝ} (hTarget : Target x) + (hcontains : RationalEllipsoidContains E x) : + RationalEllipsoidContains E' x := by + induction budget generalizing E E' t with + | zero => + simp only [runFixedPrecisionRationalFeasibility] at hrun + cases hrun + exact hcontains + | succ budget ih => + rw [runFixedPrecisionRationalFeasibility] at hrun + split at hrun + Β· contradiction + Β· rename_i a hresponse + have hcut := hvalid E a hresponse + have hb := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E a hInv.det_ne_zero hcut.1 + have htT : t ≀ T := by omega + have hadvance := hInv.advance hd a hb htT + let E₁ := scheduledRoundedEllipsoidCentralUpdate + (roundedEllipsoidPrecisionSchedule d L K T) E a + have hInv₁ : ScheduledEllipsoidInvariant d L K (t + 1) E₁ := by + simpa only [E₁] using hadvance.2 + have hnext := scheduledRoundedEllipsoidCentralUpdate_contains_point + hd E a hInv.det_ne_zero hadvance.1 hcontains hcut.1 + (hcut.2 x hTarget) + apply ih hInv₁ + Β· omega + Β· exact hrun + Β· exact hnext + +theorem runFixedPrecisionRationalFeasibility_det_upper_of_exhausted + {d L K T t : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hInv : ScheduledEllipsoidInvariant d L K t E) + (hbudget : t + budget ≀ T) + (hrun : runFixedPrecisionRationalFeasibility + (roundedEllipsoidPrecisionSchedule d L K T) oracle budget E = + .exhausted E') : + abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + induction budget generalizing E E' t with + | zero => + simp only [runFixedPrecisionRationalFeasibility] at hrun + cases hrun + simp + | succ budget ih => + rw [runFixedPrecisionRationalFeasibility] at hrun + split at hrun + Β· contradiction + Β· rename_i a hresponse + have hcut := hvalid E a hresponse + have hb := rationalPulledBackNormal_ne_zero_of_det_ne_zero + E a hInv.det_ne_zero hcut.1 + have htT : t ≀ T := by omega + have hadvance := hInv.advance hd a hb htT + let E₁ := scheduledRoundedEllipsoidCentralUpdate + (roundedEllipsoidPrecisionSchedule d L K T) E a + have hInv₁ : ScheduledEllipsoidInvariant d L K (t + 1) E₁ := by + simpa only [E₁] using hadvance.2 + have htail := ih hInv₁ (by omega) hrun + have hstep := abs_det_scheduledRoundedCentralUpdate_le + hd E a hInv.det_ne_zero hb hadvance.1 + have hfactor0 := scheduledContractionFactor_nonneg hd + calc + abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + abs ((Matrix.det E₁.basis : β„š) : ℝ) := htail + _ ≀ (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + ((1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ)) := + mul_le_mul_of_nonneg_left hstep (pow_nonneg hfactor0 _) + _ = (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ (budget + 1) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + rw [pow_succ] + ring + +theorem scheduledInitialInvariant {d : β„•} + (E : RationalEllipsoidState d) (hdet : Matrix.det E.basis β‰  0) : + ScheduledEllipsoidInvariant d (scheduledInitialDetExponent E) + (scheduledInitialMagnitudeExponent E) 0 E := by + refine ⟨hdet, ?_, ?_⟩ + Β· simpa using scheduledInitialDetExponent_lower E hdet + Β· simpa using scheduledInitialMagnitudeExponent_upper E + +theorem runScheduledRationalFeasibility_preserves_target_of_exhausted + {d : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runScheduledRationalFeasibility oracle budget E = .exhausted E') + {x : Fin d β†’ ℝ} (hTarget : Target x) + (hcontains : RationalEllipsoidContains E x) : + RationalEllipsoidContains E' x := by + let L := scheduledInitialDetExponent E + let K := scheduledInitialMagnitudeExponent E + have hInv : ScheduledEllipsoidInvariant d L K 0 E := by + simpa only [L, K] using scheduledInitialInvariant E hdet + apply runFixedPrecisionRationalFeasibility_preserves_target_of_exhausted + (L := L) (K := K) (T := budget) (t := 0) (budget := budget) + (E := E) (E' := E') hd hvalid hInv (by omega) + Β· simpa only [runScheduledRationalFeasibility, + scheduledFeasibilityPrecision, L, K] using hrun + Β· exact hTarget + Β· exact hcontains + +theorem runScheduledRationalFeasibility_det_upper_of_exhausted + {d : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + {budget : β„•} {E E' : RationalEllipsoidState d} + (hdet : Matrix.det E.basis β‰  0) + (hrun : runScheduledRationalFeasibility oracle budget E = .exhausted E') : + abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) ^ budget * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + let L := scheduledInitialDetExponent E + let K := scheduledInitialMagnitudeExponent E + have hInv : ScheduledEllipsoidInvariant d L K 0 E := by + simpa only [L, K] using scheduledInitialInvariant E hdet + apply runFixedPrecisionRationalFeasibility_det_upper_of_exhausted + (L := L) (K := K) (T := budget) (t := 0) (budget := budget) + (E := E) (E' := E') hd hvalid hInv (by omega) + simpa only [runScheduledRationalFeasibility, + scheduledFeasibilityPrecision, L, K] using hrun + +theorem runScheduledRationalFeasibility_not_exhausted_of_inner_cross + {d M : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + {z : Fin d β†’ ℝ} {r : ℝ} (hr : 0 ≀ r) + (hdyadic : Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M < r ^ d) + (hTargetPlus : βˆ€ k, Target + (fun i ↦ z i + if i = k then r else 0)) + (hTargetMinus : βˆ€ k, Target + (fun i ↦ z i - if i = k then r else 0)) + (hEplus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i + if i = k then r else 0)) + (hEminus : βˆ€ k, RationalEllipsoidContains E + (fun i ↦ z i - if i = k then r else 0)) + (E' : RationalEllipsoidState d) : + runScheduledRationalFeasibility oracle (32 * d ^ 3 * M) E β‰  + .exhausted E' := by + intro hrun + have hplus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i + if i = k then r else 0) := by + intro k + exact runScheduledRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hTargetPlus k) (hEplus k) + have hminus : βˆ€ k, RationalEllipsoidContains E' + (fun i ↦ z i - if i = k then r else 0) := by + intro k + exact runScheduledRationalFeasibility_preserves_target_of_exhausted + hd hvalid hdet hrun (hTargetMinus k) (hEminus k) + have hlower := rationalEllipsoid_storedDet_lower_of_ball_endpoints + E' hr (fun k ↦ hplus k) (fun k ↦ hminus k) + have hupper := runScheduledRationalFeasibility_det_upper_of_exhausted + hd hvalid hdet hrun + have hfactor := roundedContractionFactor_pow_budget_le_half_pow + (d := d) (M := M) hd + have hdetUpper : abs ((Matrix.det E'.basis : β„š) : ℝ) ≀ + (1 / 2 : ℝ) ^ M * abs ((Matrix.det E.basis : β„š) : ℝ) := + hupper.trans (mul_le_mul_of_nonneg_right hfactor (abs_nonneg _)) + have hsandwich : r ^ d ≀ + Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M := by + calc + r ^ d ≀ Nat.factorial d * + abs ((Matrix.det E'.basis : β„š) : ℝ) := hlower + _ ≀ Nat.factorial d * + ((1 / 2 : ℝ) ^ M * + abs ((Matrix.det E.basis : β„š) : ℝ)) := + mul_le_mul_of_nonneg_left hdetUpper (Nat.cast_nonneg _) + _ = Nat.factorial d * abs ((Matrix.det E.basis : β„š) : ℝ) * + (1 / 2 : ℝ) ^ M := by ring + exact (not_lt_of_ge hsandwich) hdyadic + +/-- Ball specialization used by the determinant-independent epigraph +feasibility call. -/ +theorem runScheduledRationalFeasibility_ball_accepts + {d : β„•} (hd : 0 < d) + {Target : (Fin d β†’ ℝ) β†’ Prop} {Good : (Fin d β†’ β„š) β†’ Prop} + {oracle : RationalCentralOracle d} + (hvalid : RationalCentralOracleValid Target oracle) + (haccept : RationalCentralOracleAcceptsOnly Good oracle) + (c : Fin d β†’ β„š) {R r : β„š} (hR : 0 < R) (hr : 0 < r) + {z : Fin d β†’ ℝ} + (hTargetPlus : βˆ€ k, Target + (fun i ↦ z i + if i = k then (r : ℝ) else 0)) + (hTargetMinus : βˆ€ k, Target + (fun i ↦ z i - if i = k then (r : ℝ) else 0)) + (houterPlus : βˆ€ k, finiteNormSq + (fun i ↦ (z i + if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) + (houterMinus : βˆ€ k, finiteNormSq + (fun i ↦ (z i - if i = k then (r : ℝ) else 0) - (c i : ℝ)) ≀ + (R : ℝ) ^ 2) : + βˆƒ x : Fin d β†’ β„š, + runScheduledRationalFeasibility oracle + (32 * d ^ 3 * rationalBallDyadicExponent d R r) + (rationalBallEllipsoid d c R) = .accepted x ∧ Good x := by + let E := rationalBallEllipsoid d c R + let budget := 32 * d ^ 3 * rationalBallDyadicExponent d R r + let result := runScheduledRationalFeasibility oracle budget E + cases hresult : result with + | accepted x => + refine ⟨x, ?_, ?_⟩ + Β· simpa only [result, budget, E] using hresult + Β· exact runScheduledRationalFeasibility_acceptsOnly haccept + (by simpa only [result, budget, E] using hresult) + | exhausted E' => + exfalso + apply runScheduledRationalFeasibility_not_exhausted_of_inner_cross + hd hvalid E + (by + dsimp only [E] + rw [det_rationalBallEllipsoid] + exact pow_ne_zero _ hR.ne') + (hr := Rat.cast_nonneg.mpr hr.le) + (rationalBallEllipsoid_dyadic_budget hd c hR hr) + hTargetPlus hTargetMinus + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterPlus k) + Β· intro k + exact rationalBallEllipsoid_contains c hR (houterMinus k) + Β· simpa only [result, budget, E] using hresult + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoid.lean b/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoid.lean new file mode 100644 index 0000000000..46c15d0691 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoid.lean @@ -0,0 +1,713 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RoundedEllipsoidIterationBounds +public import Mathlib.Tactic + +/-! # Scheduled Rounded Ellipsoid -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Determinant-independent scheduled rounding + +`roundedEllipsoidPrecision` is a semantic proof specification: it mentions the +exact determinant of the state to be rounded. The definitions in this file +take an externally scheduled number of fractional bits. Correctness needs +only the displayed inequality saying that the schedule dominates the semantic +requirement. Later iteration lemmas discharge that inequality from the +initial determinant and magnitude bounds, without evaluating a determinant. +-/ + +/-- A uniform precision schedule for a run of at most `T` central cuts. -/ +def roundedEllipsoidPrecisionSchedule (d L K T : β„•) : β„• := + roundedEllipsoidNextPrecisionBound d L K T + +theorem roundedEllipsoidNextPrecisionBound_mono_last + {d L K t T : β„•} (ht : t ≀ T) : + roundedEllipsoidNextPrecisionBound d L K t ≀ + roundedEllipsoidNextPrecisionBound d L K T := by + rw [roundedEllipsoidNextPrecisionBound, + roundedEllipsoidNextPrecisionBound, + roundedEllipsoidDenominatorExponent, + roundedEllipsoidDenominatorExponent] + gcongr + +theorem roundedEllipsoidNextPrecisionBound_le_schedule + {d L K t T : β„•} (ht : t ≀ T) : + roundedEllipsoidNextPrecisionBound d L K t ≀ + roundedEllipsoidPrecisionSchedule d L K T := by + exact roundedEllipsoidNextPrecisionBound_mono_last ht + +/-- Round a state at a determinant-independent scheduled precision. -/ +def scheduledRoundedEllipsoid {d : β„•} (p : β„•) + (U : RationalEllipsoidState d) : RationalEllipsoidState d := + inflatedDyadicRound p (roundedEllipsoidInflation d) U + +/-- Exact central update followed by scheduled dyadic rounding. -/ +def scheduledRoundedEllipsoidCentralUpdate {d : β„•} (p : β„•) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) : + RationalEllipsoidState d := + scheduledRoundedEllipsoid p (rationalEllipsoidCentralUpdate E a) + +theorem scheduled_dyadicMesh_le_adaptive {d p : β„•} + (U : RationalEllipsoidState d) + (hp : roundedEllipsoidPrecision U ≀ p) : + dyadicMesh p ≀ dyadicMesh (roundedEllipsoidPrecision U) := + dyadicMesh_antitone hp + +theorem scheduled_dyadicMesh_lt_target {d p : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) : + dyadicMesh p < roundedEllipsoidMeshTarget U := + (scheduled_dyadicMesh_le_adaptive U hp).trans_lt + (adaptive_dyadicMesh_lt_target hd U hdet) + +theorem scheduled_determinant_rounding_loss_lt {d p : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) : + roundedDeterminantCoefficient d (rationalMatrixAbsBound U.basis) * + dyadicMesh p < + abs (Matrix.det U.basis) / (128 * d ^ 3) := by + have hmesh := scheduled_dyadicMesh_le_adaptive U hp + have hC : 0 ≀ roundedDeterminantCoefficient d + (rationalMatrixAbsBound U.basis) := + (roundedDeterminantCoefficient_pos hd + (rationalMatrixAbsBound_pos U.basis)).le + exact (mul_le_mul_of_nonneg_left hmesh hC).trans_lt + (adaptive_determinant_rounding_loss_lt hd U hdet) + +theorem scheduled_inverse_rounding_loss_lt {d p : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) + (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) : + roundedInverseCoefficient d (rationalMatrixAbsBound U.basis) * + dyadicMesh p < + roundedEllipsoidInflation d * abs (Matrix.det U.basis) / + (2 * d) := by + have hmesh := scheduled_dyadicMesh_le_adaptive U hp + have hC : 0 ≀ roundedInverseCoefficient d + (rationalMatrixAbsBound U.basis) := + (roundedInverseCoefficient_pos hd + (rationalMatrixAbsBound_pos U.basis)).le + exact (mul_le_mul_of_nonneg_left hmesh hC).trans_lt + (adaptive_inverse_rounding_loss_lt hd U hdet) + +theorem scheduledRounded_entry_bound {d p : β„•} + (U : RationalEllipsoidState d) (i j : Fin d) : + abs (((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) ≀ + (2 * rationalMatrixAbsBound U.basis : β„š) := by + let M := rationalMatrixAbsBound U.basis + have hM1 : (1 : β„š) ≀ M := rationalMatrixAbsBound_one_le U.basis + have hentry : abs (U.basis i j) < M := + abs_entry_lt_rationalMatrixAbsBound U.basis i j + have hround := abs_dyadicFloor_le p (U.basis i j) + have hmesh := dyadicMesh_le_one p + have hq : abs (dyadicFloor p (U.basis i j)) ≀ 2 * M := by + dsimp only [M] at hM1 hentry ⊒ + linarith + exact_mod_cast hq + +theorem scheduledRounded_det_lower {d p : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) : + ((abs (Matrix.det U.basis) / 2 : β„š) : ℝ) ≀ + abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ))) := by + let Mq := rationalMatrixAbsBound U.basis + let Ξ”q := abs (Matrix.det U.basis) + let A : Matrix (Fin d) (Fin d) ℝ := + fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ) + let B : Matrix (Fin d) (Fin d) ℝ := + fun i j ↦ ((U.basis i j : β„š) : ℝ) + have hMq1 : (1 : β„š) ≀ Mq := rationalMatrixAbsBound_one_le U.basis + have hMreal : (1 : ℝ) ≀ (Mq : ℝ) := by exact_mod_cast hMq1 + have hBentry : βˆ€ i j, abs (B i j) ≀ (Mq : ℝ) := by + intro i j + change abs (((U.basis i j : β„š) : ℝ)) ≀ (Mq : ℝ) + exact_mod_cast (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hpert := abs_det_dyadicFloorMatrix_sub_det_le p U.basis hMreal + (by simpa only [B] using hBentry) + have hlossQ := scheduled_determinant_rounding_loss_lt hd U hdet hp + have hloss : + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) < + (Ξ”q : ℝ) / (128 * (d : ℝ) ^ 3) := by + have hc : + ((roundedDeterminantCoefficient d Mq * dyadicMesh p : β„š) : ℝ) < + ((Ξ”q / (128 * d ^ 3) : β„š) : ℝ) := by + exact_mod_cast hlossQ + norm_num only [roundedDeterminantCoefficient, Rat.cast_mul, + Rat.cast_pow, Rat.cast_natCast, Rat.cast_div] at hc + convert hc using 1 <;> ring + have hsmallLoss : + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) < + (Ξ”q : ℝ) / 2 := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hΞ” : 0 < (Ξ”q : ℝ) := by + exact_mod_cast (abs_pos.mpr hdet) + have hden : (2 : ℝ) ≀ 128 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + have hfrac : (Ξ”q : ℝ) / (128 * (d : ℝ) ^ 3) ≀ (Ξ”q : ℝ) / 2 := + div_le_div_of_nonneg_left hΞ”.le (by norm_num) hden + exact hloss.trans_le hfrac + have htriangle : abs (Matrix.det B) ≀ + abs (Matrix.det A - Matrix.det B) + abs (Matrix.det A) := by + calc + abs (Matrix.det B) = + abs ((Matrix.det B - Matrix.det A) + Matrix.det A) := by ring_nf + _ ≀ abs (Matrix.det B - Matrix.det A) + abs (Matrix.det A) := + abs_add_le _ _ + _ = abs (Matrix.det A - Matrix.det B) + abs (Matrix.det A) := by + rw [show Matrix.det B - Matrix.det A = + -(Matrix.det A - Matrix.det B) by ring, abs_neg] + have hcastB : Matrix.det B = ((Matrix.det U.basis : β„š) : ℝ) := by + rw [show B = U.basis.map (fun q : β„š ↦ (q : ℝ)) by rfl, Rat.cast_det] + have hpert' : abs (Matrix.det A - Matrix.det B) ≀ + d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) := by + simpa only [A, B] using hpert + rw [hcastB] at htriangle hpert' + have hΞ”cast : abs (((Matrix.det U.basis : β„š) : ℝ)) = (Ξ”q : ℝ) := by + exact_mod_cast (show abs (Matrix.det U.basis) = Ξ”q by rfl) + rw [hΞ”cast] at htriangle + have hresult : (Ξ”q : ℝ) / 2 ≀ abs (Matrix.det A) := by linarith + simpa only [A, Ξ”q, Rat.cast_div, Rat.cast_ofNat] using hresult + +theorem scheduledRounded_contains {d p : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint (scheduledRoundedEllipsoid p U) y' = + rationalEllipsoidPoint U y := by + let Mq := rationalMatrixAbsBound U.basis + let Mr : ℝ := 2 * (Mq : ℝ) + let Ξ”q := abs (Matrix.det U.basis) + let D : ℝ := ((Ξ”q / 2 : β„š) : ℝ) + let Ξ· := roundedEllipsoidInflation d + have hMq : 0 < Mq := rationalMatrixAbsBound_pos U.basis + have hMr : (1 : ℝ) ≀ Mr := by + dsimp only [Mr] + have hMq1 := rationalMatrixAbsBound_one_le U.basis + exact_mod_cast (show (1 : β„š) ≀ 2 * Mq by linarith) + have hD : 0 < D := by + dsimp only [D, Ξ”q] + exact_mod_cast (div_pos (abs_pos.mpr hdet) (by norm_num : (0 : β„š) < 2)) + have hΞ· : 0 ≀ Ξ· := roundedEllipsoidInflation_nonneg d + have hentries : βˆ€ i j, + abs (((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) ≀ Mr := by + intro i j + simpa only [Mr, Rat.cast_mul, Rat.cast_ofNat] using + scheduledRounded_entry_bound (p := p) U i j + have hdetLower : D ≀ abs (Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ))) := by + simpa only [D, Ξ”q] using scheduledRounded_det_lower hd U hdet hp + have hinverseQ := scheduled_inverse_rounding_loss_lt hd U hdet hp + have hinverse : + (roundedInverseCoefficient d Mq : ℝ) * (dyadicMesh p : ℝ) < + (Ξ· : ℝ) * (Ξ”q : ℝ) / (2 * (d : ℝ)) := by + exact_mod_cast hinverseQ + let V : ℝ := + (d * (d.factorial * Mr ^ d) * + (((d + 1 : β„•) : ℝ) * (dyadicMesh p : ℝ))) / D + have hVform : V = + ((roundedInverseCoefficient d Mq : β„š) : ℝ) * + (dyadicMesh p : ℝ) / D := by + have hCcast : ((roundedInverseCoefficient d Mq : β„š) : ℝ) = + (d : ℝ) * (d.factorial * (2 * (Mq : ℝ)) ^ d) * (d + 1) := by + simp [roundedInverseCoefficient] + rw [hCcast] + dsimp only [V, Mr] + norm_num only [Nat.cast_add, Nat.cast_one] + ring + have hV0 : 0 ≀ V := by + have hMr0 : 0 ≀ Mr := by linarith [hMr] + have hMrpow : 0 ≀ Mr ^ d := pow_nonneg hMr0 _ + have hmesh0 : 0 ≀ (dyadicMesh p : ℝ) := by + exact_mod_cast dyadicMesh_nonneg p + dsimp only [V] + exact div_nonneg + (mul_nonneg + (mul_nonneg (by positivity) + (mul_nonneg (by positivity) hMrpow)) + (mul_nonneg (by positivity) hmesh0)) hD.le + have hV : V ≀ (Ξ· : ℝ) / d := by + rw [hVform] + have hΞ” : 0 < (Ξ”q : ℝ) := by + exact_mod_cast (abs_pos.mpr hdet) + have hdR : (0 : ℝ) < d := by exact_mod_cast hd + have hDform : D = (Ξ”q : ℝ) / 2 := by + dsimp only [D] + norm_num + rw [hDform] + have hposDen : 0 < (Ξ”q : ℝ) / 2 := div_pos hΞ” (by norm_num) + rw [div_le_iffβ‚€ hposDen] + have hΞ·R : 0 ≀ (Ξ· : ℝ) := by exact_mod_cast hΞ· + calc + ((roundedInverseCoefficient d Mq : β„š) : ℝ) * + (dyadicMesh p : ℝ) ≀ + (Ξ· : ℝ) * (Ξ”q : ℝ) / (2 * (d : ℝ)) := hinverse.le + _ = ((Ξ· : ℝ) / d) * ((Ξ”q : ℝ) / 2) := by ring + have hsmall : d * V ^ 2 ≀ (Ξ· : ℝ) ^ 2 := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hΞ·R : 0 ≀ (Ξ· : ℝ) := by exact_mod_cast hΞ· + have hdiv0 : 0 ≀ (Ξ· : ℝ) / d := div_nonneg hΞ·R (by positivity) + have hsq : V ^ 2 ≀ ((Ξ· : ℝ) / d) ^ 2 := + (sq_le_sqβ‚€ hV0 hdiv0).2 hV + have hdpos : (0 : ℝ) < d := by positivity + calc + (d : ℝ) * V ^ 2 ≀ d * ((Ξ· : ℝ) / d) ^ 2 := + mul_le_mul_of_nonneg_left hsq hdpos.le + _ = (Ξ· : ℝ) ^ 2 / d := by field_simp + _ ≀ (Ξ· : ℝ) ^ 2 := div_le_self (sq_nonneg (Ξ· : ℝ)) hdR + have hsmall' : + d * + ((d * (d.factorial * Mr ^ d) * + ((d + 1 : β„•) * (dyadicMesh p : ℝ))) / D) ^ 2 ≀ + (Ξ· : ℝ) ^ 2 := by simpa only [V] using hsmall + simpa only [scheduledRoundedEllipsoid, Ξ·] using + inflatedDyadicRound_contains hd p Ξ· U hΞ· hD hMr hentries + hdetLower hsmall' hy + +theorem det_scheduledRoundedEllipsoid_ne_zero {d p : β„•} (hd : 0 < d) + (U : RationalEllipsoidState d) (hdet : Matrix.det U.basis β‰  0) + (hp : roundedEllipsoidPrecision U ≀ p) : + Matrix.det (scheduledRoundedEllipsoid p U).basis β‰  0 := by + have hround : Matrix.det (dyadicFloorMatrix p U.basis) β‰  0 := by + intro hz + have hlower := scheduledRounded_det_lower hd U hdet hp + have hzeroReal : Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = 0 := by + rw [show (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + (dyadicFloorMatrix p U.basis).map (fun q : β„š ↦ (q : ℝ)) by rfl, + ← Rat.cast_det, hz] + simp + rw [hzeroReal] at hlower + have hpos : (0 : ℝ) < ((abs (Matrix.det U.basis) / 2 : β„š) : ℝ) := by + exact_mod_cast div_pos (abs_pos.mpr hdet) (by norm_num : (0 : β„š) < 2) + linarith + rw [scheduledRoundedEllipsoid, det_inflatedDyadicRound_basis] + exact mul_ne_zero + (pow_ne_zero _ (by + have hΞ· := roundedEllipsoidInflation_pos hd + linarith)) hround + +theorem det_scheduledRoundedEllipsoidCentralUpdate_ne_zero {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) : + Matrix.det (scheduledRoundedEllipsoidCentralUpdate p E a).basis β‰  0 := by + let U := rationalEllipsoidCentralUpdate E a + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + exact det_scheduledRoundedEllipsoid_ne_zero hd U hdetU hp + +theorem scheduledRoundedEllipsoidCentralUpdate_contains {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) + {y : Fin d β†’ ℝ} (hy : finiteNormSq y ≀ 1) + (hcut : finiteDot + (fun i ↦ (rationalPulledBackNormal E a i : ℝ)) y ≀ 0) : + βˆƒ y' : Fin d β†’ ℝ, finiteNormSq y' ≀ 1 ∧ + rationalEllipsoidPoint + (scheduledRoundedEllipsoidCentralUpdate p E a) y' = + rationalEllipsoidPoint E y := by + let U := rationalEllipsoidCentralUpdate E a + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + obtain ⟨z, hz, hpoint⟩ := + rationalEllipsoidCentralUpdate_contains hd E a hb hy hcut + obtain ⟨z', hz', hround⟩ := scheduledRounded_contains hd U hdetU hp hz + refine ⟨z', hz', ?_⟩ + rw [scheduledRoundedEllipsoidCentralUpdate, hround, hpoint] + +/-- A sufficiently fine scheduled rounded cut has the same uniform +determinant contraction as the proof-specification update. -/ +theorem abs_det_scheduledRoundedCentralUpdate_le {d p : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) : + abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) ≀ + (1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + let U := rationalEllipsoidCentralUpdate E a + let Mq := rationalMatrixAbsBound U.basis + let Ξ· := roundedEllipsoidInflation d + let L : ℝ := d.factorial * + (d * (dyadicMesh p : ℝ) * (2 * (Mq : ℝ)) ^ d) + let Ξ”E : ℝ := abs ((Matrix.det E.basis : β„š) : ℝ) + let Ξ”U : ℝ := abs ((Matrix.det U.basis : β„š) : ℝ) + let q : ℝ := + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + have hΞ”E0 : 0 ≀ Ξ”E := abs_nonneg _ + have hq0 : 0 ≀ q := by + dsimp only [q] + exact mul_nonneg + (pow_nonneg (Rat.cast_nonneg.mpr + (rationalEllipsoidPerpScale_pos d).le) _) + (Rat.cast_nonneg.mpr (rationalEllipsoidParallelScale_pos hd).le) + have hq1 : q ≀ 1 := (rationalEllipsoid_volumeFactor_lt_one hd).le + have hqContract : q ≀ 1 - 1 / (16 * (d : ℝ) ^ 3) := + rationalEllipsoid_volumeFactor_le_one_sub hd + have hΞ”eq : Ξ”U = Ξ”E * q := by + have hdetEq := det_rationalEllipsoidCentralUpdate hd E a hb + dsimp only [U, Ξ”U, Ξ”E, q] + rw [hdetEq, Rat.cast_mul, abs_mul] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_sub, + Rat.cast_div, Rat.cast_one, Rat.cast_natCast] + rw [abs_of_nonneg hq0] + have hΞ”Ule : Ξ”U ≀ Ξ”E := by + rw [hΞ”eq] + simpa only [mul_one] using mul_le_mul_of_nonneg_left hq1 hΞ”E0 + have hMq1 : (1 : ℝ) ≀ (Mq : ℝ) := by + exact_mod_cast rationalMatrixAbsBound_one_le U.basis + have hUentry : βˆ€ i j, abs ((U.basis i j : β„š) : ℝ) ≀ (Mq : ℝ) := by + intro i j + exact_mod_cast (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hupper0 := abs_det_inflatedDyadicRound_le p Ξ· U + (roundedEllipsoidInflation_nonneg d) hMq1 hUentry + have hupper : + abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) ≀ + (1 + (Ξ· : ℝ)) ^ d * (Ξ”U + L) := by + simpa only [scheduledRoundedEllipsoidCentralUpdate, + scheduledRoundedEllipsoid, U, Ξ·, Ξ”U, L] using hupper0 + have hlossQ := scheduled_determinant_rounding_loss_lt hd U hdetU hp + have hloss : L < Ξ”U / (128 * (d : ℝ) ^ 3) := by + have hc : + ((roundedDeterminantCoefficient d Mq * dyadicMesh p : β„š) : ℝ) < + ((abs (Matrix.det U.basis) / (128 * d ^ 3) : β„š) : ℝ) := by + exact_mod_cast hlossQ + norm_num only [roundedDeterminantCoefficient, Rat.cast_mul, + Rat.cast_pow, Rat.cast_natCast, Rat.cast_div] at hc + have hc' : L < + ((abs (Matrix.det U.basis) : β„š) : ℝ) / + (128 * (d : ℝ) ^ 3) := by + dsimp only [L] + simpa [mul_assoc, mul_left_comm, mul_comm] using hc + have habsCast : ((abs (Matrix.det U.basis) : β„š) : ℝ) = Ξ”U := by + dsimp only [Ξ”U] + exact_mod_cast (show abs (Matrix.det U.basis) = + abs (Matrix.det U.basis) by rfl) + rw [habsCast] at hc' + exact hc' + have hlossE : L ≀ Ξ”E / (128 * (d : ℝ) ^ 3) := by + have hden : 0 < (128 : ℝ) * (d : ℝ) ^ 3 := by positivity + exact hloss.le.trans (div_le_div_of_nonneg_right hΞ”Ule hden.le) + have hbracket : Ξ”U + L ≀ + Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3)) := by + rw [hΞ”eq] + have hq' : q ≀ 1 - 8 / (128 * (d : ℝ) ^ 3) := by + convert hqContract using 1 <;> ring + have hqmul := mul_le_mul_of_nonneg_left hq' hΞ”E0 + calc + Ξ”E * q + L ≀ + Ξ”E * (1 - 8 / (128 * (d : ℝ) ^ 3)) + + Ξ”E / (128 * (d : ℝ) ^ 3) := add_le_add hqmul hlossE + _ = Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3)) := by ring + have hfactor0 : 0 ≀ 1 - 7 / (128 * (d : ℝ) ^ 3) := by + have hdR : (1 : ℝ) ≀ d := by exact_mod_cast hd + have hden : (7 : ℝ) ≀ 128 * (d : ℝ) ^ 3 := by + nlinarith [one_le_powβ‚€ (n := 3) hdR] + exact sub_nonneg.mpr + ((div_le_one (by positivity : (0 : ℝ) < 128 * (d : ℝ) ^ 3)).2 hden) + have hscale := roundedEllipsoidInflation_pow_bound hd + have hscale0 : 0 ≀ (1 + (Ξ· : ℝ)) ^ d := by + exact pow_nonneg (by + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith) _ + calc + abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) ≀ + (1 + (Ξ· : ℝ)) ^ d * (Ξ”U + L) := hupper + _ ≀ (1 + (Ξ· : ℝ)) ^ d * + (Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3))) := + mul_le_mul_of_nonneg_left hbracket hscale0 + _ ≀ (1 + 1 / (512 * (d : ℝ) ^ 3)) * + (Ξ”E * (1 - 7 / (128 * (d : ℝ) ^ 3))) := by + exact mul_le_mul_of_nonneg_right hscale + (mul_nonneg hΞ”E0 hfactor0) + _ = Ξ”E * ((1 + 1 / (512 * (d : ℝ) ^ 3)) * + (1 - 7 / (128 * (d : ℝ) ^ 3))) := by ring + _ ≀ Ξ”E * (1 - 1 / (32 * (d : ℝ) ^ 3)) := + mul_le_mul_of_nonneg_left (roundedContraction_arithmetic hd) hΞ”E0 + _ = (1 - 1 / (32 * (d : ℝ) ^ 3)) * + abs ((Matrix.det E.basis : β„š) : ℝ) := by + simp only [Ξ”E] + ring + +/-- A sufficiently fine scheduled rounded cut loses at most two binary bits +of determinant magnitude. -/ +theorem quarter_abs_det_le_scheduledRoundedCentralUpdate {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) : + (1 / 4 : ℝ) * abs ((Matrix.det E.basis : β„š) : ℝ) ≀ + abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) := by + let U := rationalEllipsoidCentralUpdate E a + let Ξ· := roundedEllipsoidInflation d + let Ξ”E : ℝ := abs ((Matrix.det E.basis : β„š) : ℝ) + let Ξ”U : ℝ := abs ((Matrix.det U.basis : β„š) : ℝ) + let q : ℝ := + (rationalEllipsoidPerpScale d : ℝ) ^ (d - 1) * + (rationalEllipsoidParallelScale d : ℝ) + have hdetU : Matrix.det U.basis β‰  0 := by + dsimp only [U] + rw [det_rationalEllipsoidCentralUpdate hd E a hb] + exact mul_ne_zero hdet (mul_ne_zero + (pow_ne_zero _ (rationalEllipsoidPerpScale_pos d).ne') + (rationalEllipsoidParallelScale_pos hd).ne') + have hq0 : 0 ≀ q := by + dsimp only [q] + exact mul_nonneg + (pow_nonneg (Rat.cast_nonneg.mpr + (rationalEllipsoidPerpScale_pos d).le) _) + (Rat.cast_nonneg.mpr (rationalEllipsoidParallelScale_pos hd).le) + have hΞ”eq : Ξ”U = Ξ”E * q := by + have hdetEq := det_rationalEllipsoidCentralUpdate hd E a hb + dsimp only [U, Ξ”U, Ξ”E, q] + rw [hdetEq, Rat.cast_mul, abs_mul] + norm_num only [Rat.cast_mul, Rat.cast_pow, Rat.cast_sub, + Rat.cast_div, Rat.cast_one, Rat.cast_natCast] + rw [abs_of_nonneg hq0] + have hqLower : (1 / 2 : ℝ) ≀ q := by + simpa only [q] using rationalEllipsoid_volumeFactor_ge_half hd + have hΞ”lower : (1 / 2 : ℝ) * Ξ”E ≀ Ξ”U := by + rw [hΞ”eq] + have hh : (1 / 2 : ℝ) * Ξ”E ≀ q * Ξ”E := + mul_le_mul_of_nonneg_right hqLower (by + dsimp only [Ξ”E] + exact abs_nonneg _) + simpa only [mul_comm] using hh + have hround0 := scheduledRounded_det_lower hd U hdetU hp + have hround : Ξ”U / 2 ≀ + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) := by + have hcastDet : Matrix.det + (fun i j ↦ ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + ((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ) := by + rw [show (fun i j ↦ + ((dyadicFloorMatrix p U.basis i j : β„š) : ℝ)) = + (dyadicFloorMatrix p U.basis).map (fun q : β„š ↦ (q : ℝ)) by rfl, + Rat.cast_det] + have habsCast : + (((abs (Matrix.det U.basis) : β„š) : β„š) : ℝ) = + abs (((Matrix.det U.basis : β„š) : ℝ)) := by + exact_mod_cast (show abs (Matrix.det U.basis) = + abs (Matrix.det U.basis) by rfl) + norm_num only [Rat.cast_div, Rat.cast_ofNat] at hround0 + rw [hcastDet] at hround0 + simpa only [Ξ”U, habsCast] using hround0 + have hscale : (1 : ℝ) ≀ (1 + (Ξ· : ℝ)) ^ d := by + apply one_le_powβ‚€ + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + dsimp only [Ξ·] + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith + have hstored : + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) ≀ + abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) := by + rw [scheduledRoundedEllipsoidCentralUpdate, scheduledRoundedEllipsoid, + det_inflatedDyadicRound_basis, Rat.cast_mul, abs_mul] + change abs (((1 + Ξ·) ^ d : β„š) : ℝ) * + abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) β‰₯ _ + have hscaleAbs : (1 : ℝ) ≀ abs (((1 + Ξ·) ^ d : β„š) : ℝ) := by + rw [Rat.cast_pow, Rat.cast_add, Rat.cast_one, + abs_of_nonneg (pow_nonneg (by + have hΞ·0 : (0 : ℝ) ≀ (Ξ· : ℝ) := by + dsimp only [Ξ·] + exact_mod_cast roundedEllipsoidInflation_nonneg d + linarith) d)] + exact hscale + simpa only [one_mul] using mul_le_mul_of_nonneg_right hscaleAbs + (abs_nonneg (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ))) + calc + (1 / 4 : ℝ) * Ξ”E = ((1 / 2 : ℝ) * Ξ”E) / 2 := by ring + _ ≀ Ξ”U / 2 := div_le_div_of_nonneg_right hΞ”lower (by norm_num) + _ ≀ abs (((Matrix.det (dyadicFloorMatrix p U.basis) : β„š) : ℝ)) := hround + _ ≀ abs ((Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis : β„š) : ℝ) := + hstored + +theorem quarter_abs_det_le_scheduledRoundedCentralUpdate_rat {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hdet : Matrix.det E.basis β‰  0) + (hb : rationalPulledBackNormal E a β‰  0) + (hp : roundedEllipsoidPrecision + (rationalEllipsoidCentralUpdate E a) ≀ p) : + (1 / 4 : β„š) * abs (Matrix.det E.basis) ≀ + abs (Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis) := by + have hreal := quarter_abs_det_le_scheduledRoundedCentralUpdate + hd E a hdet hb hp + have hcast : + ((((1 / 4 : β„š) * abs (Matrix.det E.basis) : β„š) : β„š) : ℝ) ≀ + ((abs (Matrix.det + (scheduledRoundedEllipsoidCentralUpdate p E a).basis) : β„š) : ℝ) := by + norm_num only [Rat.cast_mul, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] + exact_mod_cast hreal + exact Rat.cast_le.mp hcast + +theorem rationalMatrixAbsBound_scheduledRounded_le {d p : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalMatrixAbsBound (scheduledRoundedEllipsoid p U).basis ≀ + 5 * d ^ 2 * rationalMatrixAbsBound U.basis := by + let M := rationalMatrixAbsBound U.basis + let Ξ· := roundedEllipsoidInflation d + have hM1 : (1 : β„š) ≀ M := rationalMatrixAbsBound_one_le U.basis + have hΞ·0 : 0 ≀ Ξ· := roundedEllipsoidInflation_nonneg d + have hΞ·1 : Ξ· ≀ 1 := roundedEllipsoidInflation_le_one hd + have hentry : βˆ€ i j, + abs ((scheduledRoundedEllipsoid p U).basis i j) ≀ 4 * M := by + intro i j + have hround := abs_dyadicFloor_le p (U.basis i j) + have hmesh := dyadicMesh_le_one p + have hU := (abs_entry_lt_rationalMatrixAbsBound U.basis i j).le + have hfloor : abs (dyadicFloor p (U.basis i j)) ≀ 2 * M := by + linarith + rw [scheduledRoundedEllipsoid, inflatedDyadicRound_basis_apply, abs_mul, + abs_of_nonneg (by linarith : 0 ≀ 1 + Ξ·)] + calc + (1 + Ξ·) * abs (dyadicFloor p (U.basis i j)) ≀ 2 * (2 * M) := + mul_le_mul (by linarith) hfloor (abs_nonneg _) (by linarith) + _ = 4 * M := by ring + rw [rationalMatrixAbsBound] + calc + 1 + βˆ‘ i, βˆ‘ j, abs ((scheduledRoundedEllipsoid p U).basis i j) ≀ + 1 + βˆ‘ _i : Fin d, βˆ‘ _j : Fin d, 4 * M := by + have hs0 : (βˆ‘ i : Fin d, βˆ‘ j : Fin d, + abs ((scheduledRoundedEllipsoid p U).basis i j)) ≀ + βˆ‘ _i : Fin d, βˆ‘ _j : Fin d, 4 * M := by + apply Finset.sum_le_sum + intro i _ + apply Finset.sum_le_sum + intro j _ + exact hentry i j + have hs := add_le_add_left hs0 1 + simpa only [add_comm] using hs + _ = 1 + d ^ 2 * (4 * M) := by simp; ring + _ ≀ 5 * d ^ 2 * M := by + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + nlinarith [sq_nonneg ((d : β„š) - 1)] + +theorem rationalCenterAbsBound_scheduledRounded_le {d p : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalCenterAbsBound (scheduledRoundedEllipsoid p U).center ≀ + rationalCenterAbsBound U.center + d := by + have hentry : βˆ€ i, + abs ((scheduledRoundedEllipsoid p U).center i) ≀ abs (U.center i) + 1 := by + intro i + have h := abs_dyadicFloor_le p (U.center i) + have hm := dyadicMesh_le_one p + have hadd : abs (U.center i) + dyadicMesh p ≀ + abs (U.center i) + 1 := by linarith + change abs (dyadicFloor p (U.center i)) ≀ abs (U.center i) + 1 + exact h.le.trans hadd + rw [rationalCenterAbsBound, rationalCenterAbsBound] + calc + 1 + βˆ‘ i, abs ((scheduledRoundedEllipsoid p U).center i) ≀ + 1 + βˆ‘ i, (abs (U.center i) + 1) := by + gcongr with i + exact hentry i + _ = (1 + βˆ‘ i, abs (U.center i)) + d := by + rw [Finset.sum_add_distrib] + simp + ring + +theorem rationalStateAbsBound_scheduledRounded_le {d p : β„•} + (hd : 0 < d) (U : RationalEllipsoidState d) : + rationalStateAbsBound (scheduledRoundedEllipsoid p U) ≀ + 7 * d ^ 2 * rationalStateAbsBound U := by + have hc := rationalCenterAbsBound_scheduledRounded_le (p := p) hd U + have hB := rationalMatrixAbsBound_scheduledRounded_le (p := p) hd U + have hdq : (1 : β„š) ≀ d := by exact_mod_cast hd + have hT := rationalStateAbsBound_two_le U + have hc0 := rationalCenterAbsBound_one_le U.center + have hB0 := rationalMatrixAbsBound_one_le U.basis + rw [rationalStateAbsBound, rationalStateAbsBound] + calc + rationalCenterAbsBound (scheduledRoundedEllipsoid p U).center + + rationalMatrixAbsBound (scheduledRoundedEllipsoid p U).basis ≀ + (rationalCenterAbsBound U.center + d) + + 5 * d ^ 2 * rationalMatrixAbsBound U.basis := add_le_add hc hB + _ ≀ 7 * d ^ 2 * + (rationalCenterAbsBound U.center + rationalMatrixAbsBound U.basis) := by + have hBnonneg : 0 ≀ rationalMatrixAbsBound U.basis := + (rationalMatrixAbsBound_pos U.basis).le + nlinarith [sq_nonneg ((d : β„š) - 1), + mul_nonneg (sq_nonneg (d : β„š)) hBnonneg] + +theorem rationalMatrixAbsBound_scheduledCentralUpdate_le {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalMatrixAbsBound + (scheduledRoundedEllipsoidCentralUpdate p E a).basis ≀ + 25 * d ^ 3 * rationalMatrixAbsBound E.basis := by + let U := rationalEllipsoidCentralUpdate E a + have hround := rationalMatrixAbsBound_scheduledRounded_le (p := p) hd U + have hexact := rationalMatrixAbsBound_centralUpdate_le hd E a hb + calc + rationalMatrixAbsBound + (scheduledRoundedEllipsoidCentralUpdate p E a).basis = + rationalMatrixAbsBound (scheduledRoundedEllipsoid p U).basis := by rfl + _ ≀ 5 * d ^ 2 * rationalMatrixAbsBound U.basis := hround + _ ≀ 5 * d ^ 2 * (5 * d * rationalMatrixAbsBound E.basis) := + mul_le_mul_of_nonneg_left hexact (by positivity) + _ = 25 * d ^ 3 * rationalMatrixAbsBound E.basis := by ring + +theorem rationalStateAbsBound_scheduledCentralUpdate_le {d p : β„•} + (hd : 0 < d) (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) + (hb : rationalPulledBackNormal E a β‰  0) : + rationalStateAbsBound (scheduledRoundedEllipsoidCentralUpdate p E a) ≀ + 42 * d ^ 3 * rationalStateAbsBound E := by + let U := rationalEllipsoidCentralUpdate E a + have hround := rationalStateAbsBound_scheduledRounded_le (p := p) hd U + have hexact := rationalStateAbsBound_centralUpdate_le hd E a hb + calc + rationalStateAbsBound (scheduledRoundedEllipsoidCentralUpdate p E a) = + rationalStateAbsBound (scheduledRoundedEllipsoid p U) := by rfl + _ ≀ 7 * d ^ 2 * rationalStateAbsBound U := hround + _ ≀ 7 * d ^ 2 * (6 * d * rationalStateAbsBound E) := + mul_le_mul_of_nonneg_left hexact (by positivity) + _ = 42 * d ^ 3 * rationalStateAbsBound E := by ring + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoidIteration.lean b/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoidIteration.lean new file mode 100644 index 0000000000..37ebe7370b --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/ScheduledRoundedEllipsoidIteration.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ScheduledRoundedEllipsoid +public import Mathlib.Tactic + +/-! # Scheduled Rounded Ellipsoid Iteration -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Iteration of the determinant-independent schedule + +The theorem in this file is the bridge from the semantic one-step precision +requirement to a genuine implementation. One precision is computed from the +initial determinant exponent, initial magnitude exponent, and total cut +budget. Induction proves that it is sufficient at every reachable regular +state. No determinant is evaluated by the scheduled iteration. +-/ + +/-- Applies central ellipsoid updates at the fixed rounding precision `p` along a list of cut +normals. -/ +def scheduledRoundedEllipsoidIterate {d : β„•} (p : β„•) : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ RationalEllipsoidState d + | E, [] => E + | E, a :: cuts => scheduledRoundedEllipsoidIterate p + (scheduledRoundedEllipsoidCentralUpdate p E a) cuts + +/-- Requires each cut to have nonzero pullback at its corresponding ellipsoid state under the +fixed-precision update schedule. -/ +def ScheduledCutSequenceRegular {d : β„•} (p : β„•) : + RationalEllipsoidState d β†’ List (Fin d β†’ β„š) β†’ Prop + | _, [] => True + | E, a :: cuts => + rationalPulledBackNormal E a β‰  0 ∧ + ScheduledCutSequenceRegular p + (scheduledRoundedEllipsoidCentralUpdate p E a) cuts + +theorem dyadicMesh_add_two_step (L t : β„•) : + dyadicMesh (L + 2 * (t + 1)) = + (1 / 4 : β„š) * dyadicMesh (L + 2 * t) := by + rw [dyadicMesh_add_two_mul, dyadicMesh_add_two_mul, pow_succ] + ring + +private theorem scheduled_state_step_two_pow {d K t : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) (a : Fin d β†’ β„š) (p : β„•) + (hb : rationalPulledBackNormal E a β‰  0) + (hM : rationalStateAbsBound E ≀ + (2 : β„š) ^ (K + t * (6 + 3 * d))) : + rationalStateAbsBound (scheduledRoundedEllipsoidCentralUpdate p E a) ≀ + (2 : β„š) ^ (K + (t + 1) * (6 + 3 * d)) := by + have hstep := rationalStateAbsBound_scheduledCentralUpdate_le + (p := p) hd E a hb + have hfactor := roundedEllipsoidStateGrowthFactor_le_two_pow d + have hstate0 : 0 ≀ rationalStateAbsBound E := by + linarith [rationalStateAbsBound_two_le E] + calc + rationalStateAbsBound (scheduledRoundedEllipsoidCentralUpdate p E a) ≀ + (42 * d ^ 3 : β„š) * rationalStateAbsBound E := hstep + _ ≀ (2 : β„š) ^ (6 + 3 * d) * + (2 : β„š) ^ (K + t * (6 + 3 * d)) := + mul_le_mul hfactor hM hstate0 (by positivity) + _ = (2 : β„š) ^ (K + (t + 1) * (6 + 3 * d)) := by + rw [← pow_add] + congr 1 + ring + +/-- The three quantitative facts carried by a scheduled run after `t` cuts. -/ +structure ScheduledEllipsoidInvariant (d L K t : β„•) + (E : RationalEllipsoidState d) : Prop where + det_ne_zero : Matrix.det E.basis β‰  0 + det_lower : dyadicMesh (L + 2 * t) ≀ abs (Matrix.det E.basis) + magnitude : rationalStateAbsBound E ≀ + (2 : β„š) ^ (K + t * (6 + 3 * d)) + +/-- The schedule is sufficient for the next cut, and the next state satisfies +the invariant at time `t+1`. -/ +theorem ScheduledEllipsoidInvariant.advance + {d L K T t : β„•} (hd : 0 < d) + {E : RationalEllipsoidState d} + (hE : ScheduledEllipsoidInvariant d L K t E) + (a : Fin d β†’ β„š) (hb : rationalPulledBackNormal E a β‰  0) + (htT : t ≀ T) : + let P := roundedEllipsoidPrecisionSchedule d L K T + let U := rationalEllipsoidCentralUpdate E a + let E₁ := scheduledRoundedEllipsoidCentralUpdate P E a + roundedEllipsoidPrecision U ≀ P ∧ + ScheduledEllipsoidInvariant d L K (t + 1) E₁ := by + let P := roundedEllipsoidPrecisionSchedule d L K T + let U := rationalEllipsoidCentralUpdate E a + let E₁ := scheduledRoundedEllipsoidCentralUpdate P E a + have hsemantic0 := rationalEllipsoidCentralUpdate_precision_upper + hd E a hb hE.det_lower hE.magnitude + have hsemantic : roundedEllipsoidPrecision U ≀ + roundedEllipsoidNextPrecisionBound d L K t := by + simpa only [U, roundedEllipsoidNextPrecisionBound] using hsemantic0 + have hp : roundedEllipsoidPrecision U ≀ P := + hsemantic.trans (roundedEllipsoidNextPrecisionBound_le_schedule htT) + have hdet₁ : Matrix.det E₁.basis β‰  0 := by + dsimp only [E₁, P, U] at hp ⊒ + exact det_scheduledRoundedEllipsoidCentralUpdate_ne_zero + hd E a hE.det_ne_zero hb hp + have hquarter := quarter_abs_det_le_scheduledRoundedCentralUpdate_rat + hd E a hE.det_ne_zero hb hp + have hdetLower₁ : dyadicMesh (L + 2 * (t + 1)) ≀ + abs (Matrix.det E₁.basis) := by + rw [dyadicMesh_add_two_step] + exact (mul_le_mul_of_nonneg_left hE.det_lower (by norm_num)).trans + (by simpa only [E₁, P] using hquarter) + have hM₁ : rationalStateAbsBound E₁ ≀ + (2 : β„š) ^ (K + (t + 1) * (6 + 3 * d)) := by + dsimp only [E₁, P] + exact scheduled_state_step_two_pow hd E a _ hb hE.magnitude + exact ⟨hp, hdet₁, hdetLower₁, hMβ‚βŸ© + +/-- One fixed precision, computed before the run, dominates every semantic +precision requirement and preserves the determinant and magnitude invariants +through an arbitrary regular cut sequence of the budgeted length. -/ +theorem scheduledRoundedEllipsoidIterate_invariants + {d L K T t : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh (L + 2 * t) ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ + (2 : β„š) ^ (K + t * (6 + 3 * d))) + (cuts : List (Fin d β†’ β„š)) + (hregular : ScheduledCutSequenceRegular + (roundedEllipsoidPrecisionSchedule d L K T) E cuts) + (hbudget : t + cuts.length ≀ T) : + let E' := scheduledRoundedEllipsoidIterate + (roundedEllipsoidPrecisionSchedule d L K T) E cuts + Matrix.det E'.basis β‰  0 ∧ + dyadicMesh (L + 2 * (t + cuts.length)) ≀ + abs (Matrix.det E'.basis) ∧ + rationalStateAbsBound E' ≀ + (2 : β„š) ^ (K + (t + cuts.length) * (6 + 3 * d)) := by + induction cuts generalizing E t with + | nil => + simpa [scheduledRoundedEllipsoidIterate] using + And.intro hdet (And.intro hdetLower hM) + | cons a cuts ih => + let P := roundedEllipsoidPrecisionSchedule d L K T + let E₁ := scheduledRoundedEllipsoidCentralUpdate P E a + have hb : rationalPulledBackNormal E a β‰  0 := hregular.1 + have htT : t ≀ T := by omega + let hInv : ScheduledEllipsoidInvariant d L K t E := + ⟨hdet, hdetLower, hM⟩ + have hadvance := hInv.advance hd a hb htT + have hInv₁ : ScheduledEllipsoidInvariant d L K (t + 1) E₁ := by + simpa only [E₁, P] using hadvance.2 + have hbudgetTail : (t + 1) + cuts.length ≀ T := by + simpa only [List.length_cons, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hbudget + have htail := ih (E := E₁) (t := t + 1) hInv₁.det_ne_zero + hInv₁.det_lower hInv₁.magnitude + hregular.2 hbudgetTail + have hindex : t + 1 + cuts.length = t + (cuts.length + 1) := by + omega + simpa only [scheduledRoundedEllipsoidIterate, E₁, P, + List.length_cons, hindex] using htail + +/-- Initial-state specialization of the scheduled invariants. -/ +theorem scheduledRoundedEllipsoidIterate_from_initial + {d L K T : β„•} (hd : 0 < d) + (E : RationalEllipsoidState d) + (hdet : Matrix.det E.basis β‰  0) + (hdetLower : dyadicMesh L ≀ abs (Matrix.det E.basis)) + (hM : rationalStateAbsBound E ≀ (2 : β„š) ^ K) + (cuts : List (Fin d β†’ β„š)) + (hregular : ScheduledCutSequenceRegular + (roundedEllipsoidPrecisionSchedule d L K T) E cuts) + (hbudget : cuts.length ≀ T) : + let E' := scheduledRoundedEllipsoidIterate + (roundedEllipsoidPrecisionSchedule d L K T) E cuts + Matrix.det E'.basis β‰  0 ∧ + dyadicMesh (L + 2 * cuts.length) ≀ abs (Matrix.det E'.basis) ∧ + rationalStateAbsBound E' ≀ + (2 : β„š) ^ (K + cuts.length * (6 + 3 * d)) := by + simpa using scheduledRoundedEllipsoidIterate_invariants + (L := L) (K := K) (T := T) (t := 0) hd E hdet + (by simpa using hdetLower) (by simpa using hM) cuts hregular + (by omega) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Sequential.lean b/LeanPool/BeyondBethe/BeyondBethe/Sequential.lean new file mode 100644 index 0000000000..98e1e26bf9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Sequential.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Gibbs +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import LeanPool.BeyondBethe.BeyondBethe.SequentialNormalization +public import Mathlib.Tactic + +/-! # Sequential -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- A distribution on Mathlib permutations has row-column marginals `P` in +the orientation `Οƒ column = row`. -/ +def HasAssignmentMarginals + {n : β„•} (ΞΌ : Equiv.Perm (Fin n) β†’ ℝ) + (P : Matrix (Fin n) (Fin n) ℝ) : Prop := + βˆ€ i j, P i j = βˆ‘ Οƒ, if Οƒ j = i then ΞΌ Οƒ else 0 + +theorem gibbs_hasAssignmentMarginals + {n : β„•} (A : Matrix (Fin n) (Fin n) ℝ) : + HasAssignmentMarginals (gibbsProbability A) (assignmentMarginal A) := by + intro i j + exact assignmentMarginal_eq_gibbs_sum A i j + +/-- The column ordering induced by a row ordering `Ο€` and a matching `Οƒ`. +Mathlib represents `Οƒ` from columns to rows, hence the inverse here. -/ +def inducedColumnOrder + {n : β„•} (Ο€ Οƒ : Equiv.Perm (Fin n)) : Equiv.Perm (Fin n) := + Ο€.trans Οƒ.symm + +/-- For a fixed row order, sending a matching to its induced column order is +a bijection. -/ +def inducedColumnOrderEquiv + {n : β„•} (Ο€ : Equiv.Perm (Fin n)) : + Equiv.Perm (Fin n) ≃ Equiv.Perm (Fin n) where + toFun Οƒ := inducedColumnOrder Ο€ Οƒ + invFun ΞΈ := ΞΈ.symm.trans Ο€ + left_inv Οƒ := by + ext i + simp [inducedColumnOrder, Equiv.trans_apply] + right_inv ΞΈ := by + ext i + simp [inducedColumnOrder, Equiv.trans_apply] + +theorem orderedSuffixWeight_eq_suffixMass + {n : β„•} (W : Fin n β†’ Fin n β†’ ℝ) + (ΞΈ : Equiv.Perm (Fin n)) (t : Fin n) : + orderedSuffixWeight W ΞΈ t = suffixMass (W t) ΞΈ (ΞΈ t) := by + rw [suffixMass, ← Equiv.sum_comp ΞΈ] + simp [orderedSuffixWeight] + +/-- Likelihood of a matching under the sequential experiment for a fixed row +ordering. -/ +noncomputable def sequentialLikelihood + {n : β„•} (P : Matrix (Fin n) (Fin n) ℝ) + (Ο€ Οƒ : Equiv.Perm (Fin n)) : ℝ := + ∏ i, P i (Οƒ.symm i) / + suffixMass (P i) (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i) + +/-- The paper's row-indexed formula is exactly the canonical sequential +likelihood after reindexing the rows by `Ο€`. -/ +theorem sequentialLikelihood_eq_ordered + {n : β„•} (P : Matrix (Fin n) (Fin n) ℝ) + (Ο€ Οƒ : Equiv.Perm (Fin n)) : + sequentialLikelihood P Ο€ Οƒ = + orderedSequentialLikelihood + (fun t j ↦ P (Ο€ t) j) (inducedColumnOrder Ο€ Οƒ) := by + rw [sequentialLikelihood, orderedSequentialLikelihood, + ← Equiv.prod_comp Ο€] + apply Finset.prod_congr rfl + intro t _ + change P (Ο€ t) (Οƒ.symm (Ο€ t)) / + suffixMass (P (Ο€ t)) (inducedColumnOrder Ο€ Οƒ) + (Οƒ.symm (Ο€ t)) = + P (Ο€ t) ((inducedColumnOrder Ο€ Οƒ) t) / + orderedSuffixWeight (fun s j ↦ P (Ο€ s) j) + (inducedColumnOrder Ο€ Οƒ) t + rw [orderedSuffixWeight_eq_suffixMass] + rfl + +theorem sequentialLikelihood_pos + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (Ο€ Οƒ : Equiv.Perm (Fin n)) : + 0 < sequentialLikelihood P Ο€ Οƒ := by + rw [sequentialLikelihood] + apply Finset.prod_pos + intro i _ + exact div_pos ((hP i).2 (Οƒ.symm i)) + (suffixMass_pos (hP i).1 ((hP i).2 (Οƒ.symm i)) _) + +/-- For every fixed row order, the sequential likelihood is a probability +vector. This closes the normalization that is implicit in the paper's +description of the sequential experiment. -/ +theorem sequentialLikelihood_isProbabilityVector + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (Ο€ : Equiv.Perm (Fin n)) : + IsProbabilityVector (sequentialLikelihood P Ο€) := by + constructor + Β· intro Οƒ + exact (sequentialLikelihood_pos hP Ο€ Οƒ).le + Β· simp_rw [sequentialLikelihood_eq_ordered] + calc + βˆ‘ Οƒ : Equiv.Perm (Fin n), + orderedSequentialLikelihood (fun t j ↦ P (Ο€ t) j) + (inducedColumnOrder Ο€ Οƒ) = + βˆ‘ ΞΈ : Equiv.Perm (Fin n), + orderedSequentialLikelihood (fun t j ↦ P (Ο€ t) j) ΞΈ := + Equiv.sum_comp (inducedColumnOrderEquiv Ο€) + (orderedSequentialLikelihood (fun t j ↦ P (Ο€ t) j)) + _ = 1 := orderedSequentialLikelihood_sum_eq_one n + (fun t j ↦ P (Ο€ t) j) (fun t j ↦ (hP (Ο€ t)).2 j) + +theorem finiteKL_sequential_nonneg + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + {p : Equiv.Perm (Fin n) β†’ ℝ} + (hp : IsProbabilityVector p) (hppos : βˆ€ Οƒ, 0 < p Οƒ) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (Ο€ : Equiv.Perm (Fin n)) : + 0 ≀ finiteKL p (sequentialLikelihood P Ο€) := + finiteKL_nonneg hp (sequentialLikelihood_isProbabilityVector hP Ο€) + hppos (sequentialLikelihood_pos hP Ο€) + +theorem log_sequentialLikelihood + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (Ο€ Οƒ : Equiv.Perm (Fin n)) : + Real.log (sequentialLikelihood P Ο€ Οƒ) = + βˆ‘ i, (Real.log (P i (Οƒ.symm i)) - + Real.log (suffixMass (P i) (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i))) := by + rw [sequentialLikelihood, Real.log_prod] + Β· apply Finset.sum_congr rfl + intro i _ + rw [Real.log_div ((hP i).2 (Οƒ.symm i)).ne' + (suffixMass_pos (hP i).1 ((hP i).2 (Οƒ.symm i)) _).ne'] + Β· intro i _ + exact (div_pos ((hP i).2 (Οƒ.symm i)) + (suffixMass_pos (hP i).1 ((hP i).2 (Οƒ.symm i)) _)).ne' + +/-- Right composition by a fixed permutation is a bijection on orderings. -/ +def permTransEquiv {n : β„•} (Ο„ : Equiv.Perm (Fin n)) : + Equiv.Perm (Fin n) ≃ Equiv.Perm (Fin n) where + toFun (Ο€ : Equiv.Perm (Fin n)) := Ο€.trans Ο„ + invFun (ΞΈ : Equiv.Perm (Fin n)) := ΞΈ.trans Ο„.symm + left_inv Ο€ := by + ext i + simp [Equiv.trans_apply] + right_inv ΞΈ := by + ext i + simp [Equiv.trans_apply] + +theorem uniformAverage_perm_trans + {n : β„•} (f : Equiv.Perm (Fin n) β†’ ℝ) + (Ο„ : Equiv.Perm (Fin n)) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ f (Ο€.trans Ο„)) = uniformAverage f := by + rw [uniformAverage, uniformAverage] + congr 1 + exact (permTransEquiv Ο„).sum_comp f + +/-- Averaging an induced column ordering over uniform row orderings gives the +uniform average over column orderings. -/ +theorem average_induced_suffix + {n : β„•} (p : Fin n β†’ ℝ) (Οƒ : Equiv.Perm (Fin n)) (j : Fin n) : + uniformAverage (fun Ο€ ↦ + Real.log (suffixMass p (inducedColumnOrder Ο€ Οƒ) j)) = + uniformAverage (fun ΞΈ ↦ Real.log (suffixMass p ΞΈ j)) := by + exact uniformAverage_perm_trans + (fun ΞΈ ↦ Real.log (suffixMass p ΞΈ j)) Οƒ.symm + +theorem uniformAverage_const {Ξ± : Type*} [Fintype Ξ±] [Nonempty Ξ±] + (c : ℝ) : uniformAverage (fun _ : Ξ± ↦ c) = c := by + rw [uniformAverage, Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + field_simp [Fintype.card_ne_zero] + +theorem uniformAverage_sub + {Ξ± : Type*} [Fintype Ξ±] (f g : Ξ± β†’ ℝ) : + uniformAverage (fun x ↦ f x - g x) = + uniformAverage f - uniformAverage g := by + simp [uniformAverage, Finset.sum_sub_distrib, sub_div] + +theorem uniformAverage_add + {Ξ± : Type*} [Fintype Ξ±] (f g : Ξ± β†’ ℝ) : + uniformAverage (fun x ↦ f x + g x) = + uniformAverage f + uniformAverage g := by + simp [uniformAverage, Finset.sum_add_distrib, add_div] + +theorem uniformAverage_sum + {Ξ± ΞΉ : Type*} [Fintype Ξ±] [Fintype ΞΉ] + (f : Ξ± β†’ ΞΉ β†’ ℝ) : + uniformAverage (fun x ↦ βˆ‘ i, f x i) = + βˆ‘ i, uniformAverage (fun x ↦ f x i) := by + rw [uniformAverage] + simp_rw [uniformAverage, ← Finset.sum_div] + rw [Finset.sum_comm] + +theorem uniformAverage_const_mul + {Ξ± : Type*} [Fintype Ξ±] (c : ℝ) (f : Ξ± β†’ ℝ) : + uniformAverage (fun x ↦ c * f x) = c * uniformAverage f := by + simp [uniformAverage, ← Finset.mul_sum, mul_div_assoc] + +theorem uniformAverage_nonneg + {Ξ± : Type*} [Fintype Ξ±] (f : Ξ± β†’ ℝ) + (hf : βˆ€ x, 0 ≀ f x) : + 0 ≀ uniformAverage f := by + exact div_nonneg (Finset.sum_nonneg fun x _ ↦ hf x) (Nat.cast_nonneg _) + +/-- Marginal expectation for the column assigned to a fixed row. -/ +theorem marginal_expectation_row + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) + (i : Fin n) (f : Fin n β†’ ℝ) : + βˆ‘ Οƒ, ΞΌ Οƒ * f (Οƒ.symm i) = βˆ‘ j, P i j * f j := by + classical + simp_rw [hmarg i, Finset.sum_mul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro Οƒ _ + rw [Finset.sum_eq_single (Οƒ.symm i)] + Β· simp + Β· intro j _ hj + have hne : Οƒ j β‰  i := by + intro h + apply hj + simpa using congrArg Οƒ.symm h + simp [hne] + Β· simp + +/-- Rewriting `T(p)` by first fixing the sampled coordinate and then +averaging the ordering. -/ +theorem rowT_eq_sum_mul_average_suffix + {n : β„•} (p : Fin n β†’ ℝ) : + rowT p = βˆ‘ j, p j * uniformAverage (fun ΞΈ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass p ΞΈ j)) := by + unfold rowT uniformAverage + rw [Finset.sum_comm] + rw [Finset.sum_div] + apply Finset.sum_congr rfl + intro j _ + rw [← Finset.mul_sum] + ring + +/-- The expected log numerator of the sequential likelihood is determined by +the assignment marginals. -/ +theorem expected_log_sequential_numerator + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) : + βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, Real.log (P i (Οƒ.symm i))) = + βˆ‘ i, βˆ‘ j, P i j * Real.log (P i j) := by + simp_rw [Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i _ + exact marginal_expectation_row hmarg i (fun j ↦ Real.log (P i j)) + +/-- Averaging the log denominators in the sequential likelihood gives the +sum of the row suffix scores. -/ +theorem averaged_log_sequential_denominator + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hmarg : HasAssignmentMarginals ΞΌ P) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, + Real.log (suffixMass (P i) (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i)))) = + βˆ‘ i, rowT (P i) := by + rw [uniformAverage_sum] + simp_rw [uniformAverage_const_mul, uniformAverage_sum] + simp_rw [Finset.mul_sum] + rw [Finset.sum_comm] + have havg : βˆ€ (Οƒ : Equiv.Perm (Fin n)) (i : Fin n), + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass (P i) (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i))) = + uniformAverage (fun ΞΈ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass (P i) ΞΈ (Οƒ.symm i))) := + fun Οƒ i ↦ average_induced_suffix (P i) Οƒ (Οƒ.symm i) + simp_rw [havg] + apply Finset.sum_congr rfl + intro i _ + let f : Fin n β†’ ℝ := fun j ↦ + uniformAverage (fun ΞΈ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass (P i) ΞΈ j)) + calc + βˆ‘ Οƒ, ΞΌ Οƒ * uniformAverage (fun ΞΈ : Equiv.Perm (Fin n) ↦ + Real.log (suffixMass (P i) ΞΈ (Οƒ.symm i))) = + βˆ‘ j, P i j * f j := marginal_expectation_row hmarg i f + _ = rowT (P i) := (rowT_eq_sum_mul_average_suffix (P i)).symm + +/-- Exact entropy expansion of the averaged sequential KL divergence. -/ +theorem averagedSequentialKL_identity + {n : β„•} {ΞΌ : Equiv.Perm (Fin n) β†’ ℝ} + {P : Matrix (Fin n) (Fin n) ℝ} + (hΞΌpos : βˆ€ Οƒ, 0 < ΞΌ Οƒ) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) + (hmarg : HasAssignmentMarginals ΞΌ P) : + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + finiteKL ΞΌ (sequentialLikelihood P Ο€)) = + -shannonEntropy ΞΌ - (βˆ‘ i, βˆ‘ j, P i j * Real.log (P i j)) + + βˆ‘ i, rowT (P i) := by + have hKL : βˆ€ Ο€ : Equiv.Perm (Fin n), + finiteKL ΞΌ (sequentialLikelihood P Ο€) = + -shannonEntropy ΞΌ - + βˆ‘ Οƒ, ΞΌ Οƒ * Real.log (sequentialLikelihood P Ο€ Οƒ) := by + intro Ο€ + exact finiteKL_eq_neg_entropy_sub hΞΌpos + (sequentialLikelihood_pos hP Ο€) + have hlog : uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + βˆ‘ Οƒ, ΞΌ Οƒ * Real.log (sequentialLikelihood P Ο€ Οƒ)) = + (βˆ‘ i, βˆ‘ j, P i j * Real.log (P i j)) - βˆ‘ i, rowT (P i) := by + have hpoint : βˆ€ Ο€ : Equiv.Perm (Fin n), + (βˆ‘ Οƒ, ΞΌ Οƒ * Real.log (sequentialLikelihood P Ο€ Οƒ)) = + (βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, Real.log (P i (Οƒ.symm i)))) - + βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, + Real.log (suffixMass (P i) + (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i))) := by + intro Ο€ + calc + βˆ‘ Οƒ, ΞΌ Οƒ * Real.log (sequentialLikelihood P Ο€ Οƒ) = + βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, + (Real.log (P i (Οƒ.symm i)) - + Real.log (suffixMass (P i) + (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i)))) := by + apply Finset.sum_congr rfl + intro Οƒ _ + rw [log_sequentialLikelihood hP] + _ = (βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, Real.log (P i (Οƒ.symm i)))) - + βˆ‘ Οƒ, ΞΌ Οƒ * (βˆ‘ i, + Real.log (suffixMass (P i) + (inducedColumnOrder Ο€ Οƒ) (Οƒ.symm i))) := by + simp_rw [Finset.sum_sub_distrib, mul_sub, + Finset.sum_sub_distrib] + simp_rw [hpoint] + rw [uniformAverage_sub, + uniformAverage_const, + averaged_log_sequential_denominator hmarg, + expected_log_sequential_numerator hmarg] + simp_rw [hKL] + rw [uniformAverage_sub, uniformAverage_const, hlog] + ring + +/-- Average divergence between a target law and the sequential laws over all +row orderings. -/ +noncomputable def averagedSequentialDivergence + {n : β„•} (ΞΌ : Equiv.Perm (Fin n) β†’ ℝ) + (P : Matrix (Fin n) (Fin n) ℝ) : ℝ := + uniformAverage (fun Ο€ : Equiv.Perm (Fin n) ↦ + finiteKL ΞΌ (sequentialLikelihood P Ο€)) + +theorem averagedSequentialDivergence_nonneg + {n : β„•} {P : Matrix (Fin n) (Fin n) ℝ} + {p : Equiv.Perm (Fin n) β†’ ℝ} + (hp : IsProbabilityVector p) (hppos : βˆ€ Οƒ, 0 < p Οƒ) + (hP : βˆ€ i, IsStrictProbabilityVector (P i)) : + 0 ≀ averagedSequentialDivergence p P := by + apply uniformAverage_nonneg + intro Ο€ + exact finiteKL_sequential_nonneg hp hppos hP Ο€ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SequentialNormalization.lean b/LeanPool/BeyondBethe/BeyondBethe/SequentialNormalization.lean new file mode 100644 index 0000000000..3d0a24f6cb --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SequentialNormalization.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.GroupTheory.Perm.Fin +public import Mathlib.Tactic + +/-! # Sequential Normalization -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Total weight still available to position `t` when the columns are exposed +in the order `ΞΈ`. This is the position-indexed version of `suffixMass`. -/ +noncomputable def orderedSuffixWeight + {n : β„•} (W : Fin n β†’ Fin n β†’ ℝ) + (ΞΈ : Equiv.Perm (Fin n)) (t : Fin n) : ℝ := + βˆ‘ s, if t ≀ s then W t (ΞΈ s) else 0 + +/-- The probability of one complete outcome of sequential sampling without +replacement, with rows processed in their natural order. -/ +noncomputable def orderedSequentialLikelihood + {n : β„•} (W : Fin n β†’ Fin n β†’ ℝ) + (ΞΈ : Equiv.Perm (Fin n)) : ℝ := + ∏ t, W t (ΞΈ t) / orderedSuffixWeight W ΞΈ t + +/-- After the first column `p` is chosen, `tailWeight W p` is the smaller +instance obtained by deleting the first row and that column. The swap is the +one used by Mathlib's canonical decomposition of a permutation of `Fin (n+1)`. +-/ +def tailWeight {n : β„•} + (W : Fin (n + 1) β†’ Fin (n + 1) β†’ ℝ) (p : Fin (n + 1)) : + Fin n β†’ Fin n β†’ ℝ := + fun i j ↦ W i.succ ((Equiv.swap 0 p) j.succ) + +theorem orderedSuffixWeight_zero + {n : β„•} (W : Fin (n + 1) β†’ Fin (n + 1) β†’ ℝ) + (ΞΈ : Equiv.Perm (Fin (n + 1))) : + orderedSuffixWeight W ΞΈ 0 = βˆ‘ j, W 0 j := by + unfold orderedSuffixWeight + simp only [Fin.zero_le, ↓reduceIte] + exact Equiv.sum_comp ΞΈ (W 0) + +theorem orderedSuffixWeight_decompose_succ + {n : β„•} (W : Fin (n + 1) β†’ Fin (n + 1) β†’ ℝ) + (p : Fin (n + 1)) (e : Equiv.Perm (Fin n)) (i : Fin n) : + orderedSuffixWeight W (Equiv.Perm.decomposeFin.symm (p, e)) i.succ = + orderedSuffixWeight (tailWeight W p) e i := by + unfold orderedSuffixWeight tailWeight + rw [Fin.sum_univ_succ] + simp + +theorem orderedSequentialLikelihood_decompose + {n : β„•} (W : Fin (n + 1) β†’ Fin (n + 1) β†’ ℝ) + (p : Fin (n + 1)) (e : Equiv.Perm (Fin n)) : + orderedSequentialLikelihood W (Equiv.Perm.decomposeFin.symm (p, e)) = + (W 0 p / βˆ‘ j, W 0 j) * orderedSequentialLikelihood (tailWeight W p) e := by + rw [orderedSequentialLikelihood, Fin.prod_univ_succ, + Equiv.Perm.decomposeFin_symm_apply_zero, + orderedSuffixWeight_zero, orderedSequentialLikelihood] + congr 1 + apply Finset.prod_congr rfl + intro i _ + rw [Equiv.Perm.decomposeFin_symm_apply_succ, + orderedSuffixWeight_decompose_succ] + rfl + +/-- Sequential choice probabilities sum to one. The proof is the chain rule: +split a permutation according to its first chosen column and apply induction to +the remaining rows and columns. -/ +theorem orderedSequentialLikelihood_sum_eq_one : + βˆ€ (n : β„•) (W : Fin n β†’ Fin n β†’ ℝ), + (βˆ€ i j, 0 < W i j) β†’ + βˆ‘ ΞΈ : Equiv.Perm (Fin n), orderedSequentialLikelihood W ΞΈ = 1 := by + intro n + induction n with + | zero => + intro W _ + simp [orderedSequentialLikelihood] + | succ n ih => + intro W hW + have htail : βˆ€ p i j, 0 < tailWeight W p i j := by + intro p i j + exact hW i.succ ((Equiv.swap 0 p) j.succ) + have hrow : 0 < βˆ‘ j, W 0 j := + Finset.sum_pos (fun j _ ↦ hW 0 j) ⟨0, Finset.mem_univ 0⟩ + calc + βˆ‘ ΞΈ : Equiv.Perm (Fin (n + 1)), orderedSequentialLikelihood W ΞΈ = + βˆ‘ pe : Fin (n + 1) Γ— Equiv.Perm (Fin n), + orderedSequentialLikelihood W + (Equiv.Perm.decomposeFin.symm pe) := + (Equiv.sum_comp Equiv.Perm.decomposeFin.symm + (orderedSequentialLikelihood W)).symm + _ = βˆ‘ p, βˆ‘ e, + orderedSequentialLikelihood W + (Equiv.Perm.decomposeFin.symm (p, e)) := + Fintype.sum_prod_type _ + _ = βˆ‘ p, βˆ‘ e, + (W 0 p / βˆ‘ j, W 0 j) * + orderedSequentialLikelihood (tailWeight W p) e := by + simp_rw [orderedSequentialLikelihood_decompose] + _ = βˆ‘ p, (W 0 p / βˆ‘ j, W 0 j) * + (βˆ‘ e, orderedSequentialLikelihood (tailWeight W p) e) := by + apply Finset.sum_congr rfl + intro p _ + rw [Finset.mul_sum] + _ = βˆ‘ p, W 0 p / βˆ‘ j, W 0 j := by + apply Finset.sum_congr rfl + intro p _ + rw [ih (tailWeight W p) (htail p), mul_one] + _ = 1 := by + rw [← Finset.sum_div, div_self hrow.ne'] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Slack.lean b/LeanPool/BeyondBethe/BeyondBethe/Slack.lean new file mode 100644 index 0000000000..af9f0c3915 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Slack.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import LeanPool.BeyondBethe.BeyondBethe.Sequential +public import Mathlib.Tactic + +/-! # Slack -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Row score `s(p)=H(p)+T(p)` from paper (24). -/ +noncomputable def rowScore + {m : β„•} (p : Fin m β†’ ℝ) : ℝ := + shannonEntropy p + rowT p + +/-- Direct cancellation between the Bethe objective and the row corrections. +This is the algebraic core of paper Lemma 10. -/ +theorem bethe_add_rowCorrection_eq_logWeight_add_rowScore + {m : β„•} (A P : Matrix (Fin m) (Fin m) ℝ) : + betheObjective A P + βˆ‘ i, rowCorrection (P i) = + (βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j)) + + βˆ‘ i, rowScore (P i) := by + rw [betheObjective] + simp_rw [betheRowObjective, rowCorrection, rowScore, shannonEntropy] + simp only [Finset.sum_add_distrib, Finset.sum_sub_distrib] + ring + +/-- The averaged KL term `D` in the paper, specialized to the Gibbs law and +its assignment marginals. -/ +noncomputable def gibbsSequentialDivergence + {m : β„•} (A : Matrix (Fin m) (Fin m) ℝ) : ℝ := + averagedSequentialDivergence + (gibbsProbability A) (assignmentMarginal A) + +theorem neg_logMarginals_add_rowT_eq_rowScore + {m : β„•} (P : Matrix (Fin m) (Fin m) ℝ) : + -(βˆ‘ i, βˆ‘ j, P i j * Real.log (P i j)) + βˆ‘ i, rowT (P i) = + βˆ‘ i, rowScore (P i) := by + have hneg : -(βˆ‘ i, βˆ‘ j, P i j * Real.log (P i j)) = + βˆ‘ i, βˆ‘ j, -(P i j * Real.log (P i j)) := by + simp + simp_rw [rowScore, shannonEntropy, Real.negMulLog_def, + Finset.sum_add_distrib] + rw [hneg] + ring_nf + +/-- Entropy form of the averaged sequential divergence, now proved directly +for the Gibbs law rather than taken as a premise. -/ +theorem gibbsSequentialDivergence_eq_entropy + {m : β„•} (A : Matrix (Fin m) (Fin m) ℝ) + (hA : βˆ€ i j, 0 < A i j) : + gibbsSequentialDivergence A = + -shannonEntropy (gibbsProbability A) + + βˆ‘ i, rowScore (assignmentMarginal A i) := by + unfold gibbsSequentialDivergence averagedSequentialDivergence + calc + uniformAverage (fun Ο€ : Equiv.Perm (Fin m) ↦ + finiteKL (gibbsProbability A) + (sequentialLikelihood (assignmentMarginal A) Ο€)) = + -shannonEntropy (gibbsProbability A) - + (βˆ‘ i, βˆ‘ j, assignmentMarginal A i j * + Real.log (assignmentMarginal A i j)) + + βˆ‘ i, rowT (assignmentMarginal A i) := + averagedSequentialKL_identity + (gibbsProbability_pos A hA) + (assignmentMarginal_strictProbabilityVector A hA) + (gibbs_hasAssignmentMarginals A) + _ = -shannonEntropy (gibbsProbability A) + + βˆ‘ i, rowScore (assignmentMarginal A i) := by + rw [← neg_logMarginals_add_rowT_eq_rowScore (assignmentMarginal A)] + ring + +theorem gibbsSequentialDivergence_nonneg + {m : β„•} (A : Matrix (Fin m) (Fin m) ℝ) + (hA : βˆ€ i j, 0 < A i j) : + 0 ≀ gibbsSequentialDivergence A := by + exact averagedSequentialDivergence_nonneg + (gibbsProbability_isProbabilityVector A hA) + (gibbsProbability_pos A hA) + (assignmentMarginal_strictProbabilityVector A hA) + +/-- Paper Lemma 6 (exact sequential identity), with every probability and +normalization assertion discharged. -/ +theorem gibbs_exact_sequential_identity + {m : β„•} (A : Matrix (Fin m) (Fin m) ℝ) + (hA : βˆ€ i j, 0 < A i j) : + Real.log (Matrix.permanent A) = + betheObjective A (assignmentMarginal A) + + (βˆ‘ i, rowCorrection (assignmentMarginal A i)) - + gibbsSequentialDivergence A := by + have hGibbs := gibbsEntropy_identity A hA + have hD := gibbsSequentialDivergence_eq_entropy A hA + have hBethe := bethe_add_rowCorrection_eq_logWeight_add_rowScore + A (assignmentMarginal A) + linarith + +/-- Entropy form of the sequential divergence, paper Lemma 10, derived from +the Gibbs entropy identity and the exact sequential identity. -/ +theorem entropy_form_of_sequential_identity + {m : β„•} (A P : Matrix (Fin m) (Fin m) ℝ) + {logPermanent divergence gibbsEntropy : ℝ} + (hGibbs : gibbsEntropy = logPermanent - + βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j)) + (hseq : logPermanent = + betheObjective A P + (βˆ‘ i, rowCorrection (P i)) - divergence) : + divergence = -gibbsEntropy + βˆ‘ i, rowScore (P i) := by + rw [bethe_add_rowCorrection_eq_logWeight_add_rowScore A P] at hseq + linarith + +/-- Slack in the upper half of the Bethe sandwich, in logarithmic +coordinates. -/ +noncomputable def betheSlack (n : β„•) (logBethe logPermanent : ℝ) : ℝ := + n * (Real.log 2 / 2) + logBethe - logPermanent + +/-- Loss from evaluating the Bethe objective away from its maximizer. -/ +def betheSuboptimality (logBethe objectiveValue : ℝ) : ℝ := + logBethe - objectiveValue + +/-- Paper Lemma 7 is an exact algebraic consequence of Lemma 6. This version +separates that closed algebra from the probabilistic proof of the sequential +identity. -/ +theorem slack_decomposition_of_sequential_identity + {m : β„•} (g : Fin m β†’ ℝ) + {logBethe logPermanent objectiveValue divergence : ℝ} + (hseq : logPermanent = + objectiveValue + (βˆ‘ i, g i) - divergence) : + betheSlack m logBethe logPermanent = + betheSuboptimality logBethe objectiveValue + + (βˆ‘ i, (Real.log 2 / 2 - g i)) + divergence := by + rw [betheSlack, betheSuboptimality, hseq] + simp_rw [Finset.sum_sub_distrib, Finset.sum_const, nsmul_eq_mul] + rw [Finset.card_univ, Fintype.card_fin] + ring + +/-- The same identity in the paper's `rowDeficit` notation. -/ +theorem slack_decomposition_rowDeficit + {m : β„•} (p : Fin m β†’ Fin m β†’ ℝ) + {logBethe logPermanent objectiveValue divergence : ℝ} + (hseq : logPermanent = + objectiveValue + (βˆ‘ i, rowCorrection (p i)) - divergence) : + betheSlack m logBethe logPermanent = + betheSuboptimality logBethe objectiveValue + + (βˆ‘ i, rowDeficit (p i)) + divergence := by + simpa only [rowDeficit] using + slack_decomposition_of_sequential_identity + (fun i ↦ rowCorrection (p i)) hseq + +theorem terms_le_slack_of_decomposition + {slack sub row divergence : ℝ} + (hsub : 0 ≀ sub) (hrow : 0 ≀ row) (hdiv : 0 ≀ divergence) + (h : slack = sub + row + divergence) : + sub ≀ slack ∧ row ≀ slack ∧ divergence ≀ slack := by + subst slack + constructor + Β· linarith + constructor <;> linarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Smoothing.lean b/LeanPool/BeyondBethe/BeyondBethe/Smoothing.lean new file mode 100644 index 0000000000..ba02472512 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Smoothing.lean @@ -0,0 +1,243 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Permanent +public import Mathlib.Algebra.Order.Ring.Pow +public import Mathlib.Analysis.Complex.Exponential +public import Mathlib.Data.Fintype.Perm +public import Mathlib.Tactic + +/-! # Smoothing -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The smoothing level from paper (48), written for an abstract matrix order +`n`. -/ +noncomputable def smoothingDelta (n : β„•) (m Ο‡ : ℝ) : ℝ := + min (1 / (2 * n)) (Ο‡ * m ^ n / (4 * Nat.factorial n)) + +theorem smoothingDelta_pos {n : β„•} {m Ο‡ : ℝ} + (hn : 0 < n) (hm : 0 < m) (hΟ‡ : 0 < Ο‡) : + 0 < smoothingDelta n m Ο‡ := by + rw [smoothingDelta, lt_min_iff] + constructor <;> positivity + +theorem smoothingDelta_scale {n : β„•} {m Ο‡ : ℝ} : + smoothingDelta n m Ο‡ ≀ Ο‡ * m ^ n / (4 * Nat.factorial n) := by + exact min_le_right _ _ + +theorem smoothingDelta_half {n : β„•} {m Ο‡ : ℝ} + (hn : 0 < n) : + (n : ℝ) * smoothingDelta n m Ο‡ ≀ 1 / 2 := by + have hle : smoothingDelta n m Ο‡ ≀ 1 / (2 * (n : ℝ)) := by + rw [smoothingDelta] + exact min_le_left _ _ + have hn0 : (n : ℝ) β‰  0 := by exact_mod_cast hn.ne' + calc + (n : ℝ) * smoothingDelta n m Ο‡ + ≀ (n : ℝ) * (1 / (2 * (n : ℝ))) := + mul_le_mul_of_nonneg_left hle (by positivity) + _ = 1 / 2 := by field_simp + +/-- The elementary geometric-series estimate used after choosing +`n * Ξ΄ ≀ 1/2` in the smoothing argument. -/ +theorem one_add_pow_sub_one_le_two_mul + {n : β„•} {Ξ΄ : ℝ} (hΞ΄ : 0 ≀ Ξ΄) + (hhalf : (n : ℝ) * Ξ΄ ≀ 1 / 2) : + (1 + Ξ΄) ^ n - 1 ≀ 2 * n * Ξ΄ := by + let x : ℝ := n * Ξ΄ + have hx0 : 0 ≀ x := by dsimp [x]; positivity + have hxhalf : x ≀ 1 / 2 := by simpa [x] using hhalf + have hxlt : x < 1 := hxhalf.trans_lt (by norm_num) + have hpowexp : (1 + Ξ΄) ^ n ≀ Real.exp x := by + have h := Real.prod_one_add_le_exp_sum + (Finset.univ : Finset (Fin n)) (f := fun _ ↦ Ξ΄) (fun _ ↦ hΞ΄) + simpa [Finset.prod_const, Finset.sum_const, nsmul_eq_mul, x, + mul_comm] using h + have hexp : Real.exp x ≀ 1 / (1 - x) := + Real.exp_bound_div_one_sub_of_interval hx0 hxlt + have hden : 0 < 1 - x := by linarith + have hfrac : 1 / (1 - x) ≀ 1 + 2 * x := by + rw [div_le_iffβ‚€ hden] + nlinarith + calc + (1 + Ξ΄) ^ n - 1 ≀ Real.exp x - 1 := sub_le_sub_right hpowexp 1 + _ ≀ 1 / (1 - x) - 1 := sub_le_sub_right hexp 1 + _ ≀ 2 * x := by linarith + _ = 2 * n * Ξ΄ := by dsimp [x]; ring + +/-- Increasing every factor in a product by `Ξ΄` changes the product by at +most the change at the all-ones vector. This is the termwise estimate used in +the smoothing lemma. -/ +theorem prod_add_const_sub_prod_le + {ΞΉ : Type*} [DecidableEq ΞΉ] (s : Finset ΞΉ) (a : ΞΉ β†’ ℝ) {Ξ΄ : ℝ} + (hΞ΄ : 0 ≀ Ξ΄) + (ha0 : βˆ€ i ∈ s, 0 ≀ a i) + (ha1 : βˆ€ i ∈ s, a i ≀ 1) : + (∏ i ∈ s, (a i + Ξ΄)) - (∏ i ∈ s, a i) + ≀ (1 + Ξ΄) ^ s.card - 1 := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert x s hx ih => + have hx0 : 0 ≀ a x := ha0 x (Finset.mem_insert_self x s) + have hx1 : a x ≀ 1 := ha1 x (Finset.mem_insert_self x s) + have hs0 : βˆ€ i ∈ s, 0 ≀ a i := fun i hi ↦ ha0 i (Finset.mem_insert_of_mem hi) + have hs1 : βˆ€ i ∈ s, a i ≀ 1 := fun i hi ↦ ha1 i (Finset.mem_insert_of_mem hi) + have hprod : (∏ i ∈ s, (a i + Ξ΄)) ≀ (1 + Ξ΄) ^ s.card := by + rw [← Finset.prod_const] + exact Finset.prod_le_prodβ‚€ + (fun i hi ↦ add_nonneg (hs0 i hi) hΞ΄) + (fun i hi ↦ by simpa [add_comm] using add_le_add_right (hs1 i hi) Ξ΄) + have hpow : 0 ≀ (1 + Ξ΄) ^ s.card - 1 := by + apply sub_nonneg.mpr + exact one_le_powβ‚€ (by linarith) + calc + (∏ i ∈ insert x s, (a i + Ξ΄)) - (∏ i ∈ insert x s, a i) + = Ξ΄ * (∏ i ∈ s, (a i + Ξ΄)) + + a x * ((∏ i ∈ s, (a i + Ξ΄)) - (∏ i ∈ s, a i)) := by + rw [Finset.prod_insert hx, Finset.prod_insert hx] + ring + _ ≀ Ξ΄ * (1 + Ξ΄) ^ s.card + + a x * ((1 + Ξ΄) ^ s.card - 1) := by + exact add_le_add + (mul_le_mul_of_nonneg_left hprod hΞ΄) + (mul_le_mul_of_nonneg_left (ih hs0 hs1) hx0) + _ ≀ Ξ΄ * (1 + Ξ΄) ^ s.card + + ((1 + Ξ΄) ^ s.card - 1) := by + have hmul := mul_le_mul_of_nonneg_right hx1 hpow + nlinarith + _ = (1 + Ξ΄) ^ (insert x s).card - 1 := by + rw [Finset.card_insert_of_notMem hx, pow_succ] + ring + +/-- Matrix-level smoothing bound before choosing the smoothing scale. -/ +theorem permanent_add_uniform_sub_le + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) {Ξ΄ : ℝ} + (hΞ΄ : 0 ≀ Ξ΄) (hA0 : Matrix.Nonnegative A) + (hA1 : βˆ€ i j, A i j ≀ 1) : + Matrix.permanent (fun i j ↦ A i j + Ξ΄) - Matrix.permanent A + ≀ Nat.factorial (Fintype.card n) * ((1 + Ξ΄) ^ Fintype.card n - 1) := by + classical + unfold Matrix.permanent + rw [← Finset.sum_sub_distrib] + calc + βˆ‘ Οƒ : Equiv.Perm n, + ((∏ i, (A (Οƒ i) i + Ξ΄)) - ∏ i, A (Οƒ i) i) + ≀ βˆ‘ _Οƒ : Equiv.Perm n, ((1 + Ξ΄) ^ Fintype.card n - 1) := by + apply Finset.sum_le_sum + intro Οƒ _ + simpa using prod_add_const_sub_prod_le Finset.univ + (fun i ↦ A (Οƒ i) i) hΞ΄ + (fun i _ ↦ hA0 (Οƒ i) i) + (fun i _ ↦ hA1 (Οƒ i) i) + _ = Nat.factorial (Fintype.card n) * ((1 + Ξ΄) ^ Fintype.card n - 1) := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_perm, nsmul_eq_mul] + +/-- The quantitative form used in paper Lemma 21 once `Ξ΄ ≀ 1/(2n)` has +been imposed. -/ +theorem permanent_add_uniform_sub_le_two_mul + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) {Ξ΄ : ℝ} + (hΞ΄ : 0 ≀ Ξ΄) (hhalf : (Fintype.card n : ℝ) * Ξ΄ ≀ 1 / 2) + (hA0 : Matrix.Nonnegative A) (hA1 : βˆ€ i j, A i j ≀ 1) : + Matrix.permanent (fun i j ↦ A i j + Ξ΄) - Matrix.permanent A + ≀ Nat.factorial (Fintype.card n) * + (2 * Fintype.card n * Ξ΄) := by + refine (permanent_add_uniform_sub_le A hΞ΄ hA0 hA1).trans ?_ + exact mul_le_mul_of_nonneg_left + (one_add_pow_sub_one_le_two_mul hΞ΄ hhalf) + (Nat.cast_nonneg _) + +/-- The mathematical comparison in paper Lemma 21. The statement isolates +the two inequalities imposed on the chosen smoothing scale `Ξ΄`; the paper's +explicit minimum satisfies both. -/ +theorem smoothing_comparison + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) {m Ο‡ Ξ΄ : ℝ} + (hn : 0 < Fintype.card n) (hm : 0 < m) (hΟ‡ : 0 ≀ Ο‡) + (hΞ΄ : 0 ≀ Ξ΄) + (hhalf : (Fintype.card n : ℝ) * Ξ΄ ≀ 1 / 2) + (hscale : Ξ΄ ≀ + Ο‡ * m ^ Fintype.card n / + (4 * Nat.factorial (Fintype.card n))) + (hA0 : Matrix.Nonnegative A) (hA1 : βˆ€ i j, A i j ≀ 1) + (hmin : βˆ€ i j, A i j β‰  0 β†’ m ≀ A i j) + (hmatch : Matrix.HasPerfectMatching A) : + Matrix.permanent A ≀ Matrix.permanent (fun i j ↦ A i j + Ξ΄) ∧ + Matrix.permanent (fun i j ↦ A i j + Ξ΄) ≀ + (1 + Ο‡ * Fintype.card n / 2) * Matrix.permanent A := by + let N : ℝ := Fintype.card n + let F : ℝ := Nat.factorial (Fintype.card n) + have hN : 0 ≀ N := by dsimp [N]; positivity + have hF : 0 < F := by dsimp [F]; positivity + have hper0 : 0 ≀ Matrix.permanent A := Matrix.permanent_nonneg_real A hA0 + have hmatched : m ^ Fintype.card n ≀ Matrix.permanent A := + Matrix.pow_card_le_permanent_of_hasPerfectMatching A hm.le hA0 hmin hmatch + have hlower : Matrix.permanent A ≀ Matrix.permanent (fun i j ↦ A i j + Ξ΄) := by + exact Matrix.permanent_mono_real hA0 fun i j ↦ by linarith + have hdiff := permanent_add_uniform_sub_le_two_mul A hΞ΄ hhalf hA0 hA1 + have hscale' : + F * (2 * N * Ξ΄) ≀ Ο‡ * N / 2 * m ^ Fintype.card n := by + have hmultiplier : 0 ≀ F * (2 * N) := + mul_nonneg hF.le (mul_nonneg (by norm_num) hN) + have hmul : (F * (2 * N)) * Ξ΄ ≀ + (F * (2 * N)) * + (Ο‡ * m ^ Fintype.card n / + (4 * Nat.factorial (Fintype.card n))) := + mul_le_mul_of_nonneg_left hscale hmultiplier + dsimp [F, N] at hmul ⊒ + calc + (Nat.factorial (Fintype.card n) : ℝ) * + (2 * (Fintype.card n : ℝ) * Ξ΄) + = ((Nat.factorial (Fintype.card n) : ℝ) * + (2 * (Fintype.card n : ℝ))) * Ξ΄ := by ring + _ ≀ ((Nat.factorial (Fintype.card n) : ℝ) * + (2 * (Fintype.card n : ℝ))) * + (Ο‡ * m ^ Fintype.card n / + (4 * Nat.factorial (Fintype.card n))) := hmul + _ = Ο‡ * (Fintype.card n : ℝ) / 2 * + m ^ Fintype.card n := by + field_simp + ring + refine ⟨hlower, ?_⟩ + have hdiff' : + Matrix.permanent (fun i j ↦ A i j + Ξ΄) - Matrix.permanent A + ≀ Ο‡ * N / 2 * m ^ Fintype.card n := by + exact hdiff.trans (by simpa [F, N] using hscale') + have hcoef : 0 ≀ Ο‡ * N / 2 := by positivity + have hmatched' := mul_le_mul_of_nonneg_left hmatched hcoef + dsimp [N] at hdiff' hmatched' ⊒ + linarith + +/-- Paper Lemma 21 with its explicit smoothing level. This is the exact +real-inequality content; rational bit length and construction time belong to +the algorithmic layer. -/ +theorem smoothing_comparison_explicit + {n : Type*} [Fintype n] [DecidableEq n] + (A : Matrix n n ℝ) {m Ο‡ : ℝ} + (hn : 0 < Fintype.card n) (hm : 0 < m) (hΟ‡ : 0 < Ο‡) + (hA0 : Matrix.Nonnegative A) (hA1 : βˆ€ i j, A i j ≀ 1) + (hmin : βˆ€ i j, A i j β‰  0 β†’ m ≀ A i j) + (hmatch : Matrix.HasPerfectMatching A) : + let Ξ΄ := smoothingDelta (Fintype.card n) m Ο‡ + Matrix.permanent A ≀ Matrix.permanent (fun i j ↦ A i j + Ξ΄) ∧ + Matrix.permanent (fun i j ↦ A i j + Ξ΄) ≀ + (1 + Ο‡ * Fintype.card n / 2) * Matrix.permanent A := by + dsimp only + exact smoothing_comparison A hn hm hΟ‡.le + (smoothingDelta_pos hn hm hΟ‡).le + (smoothingDelta_half hn) + smoothingDelta_scale hA0 hA1 hmin hmatch + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaei.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaei.lean new file mode 100644 index 0000000000..4187631b6e --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaei.lean @@ -0,0 +1,840 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.RowStability +public import Mathlib.Analysis.Calculus.Deriv.MeanValue + +/-! # Source Anari Rezaei -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Anari--Rezaei's sharp one-row inequality + +This file formalizes the source proof of the one-row inequality used in the +upper Bethe bound. The first step pairs every ordering with its reversal and +reduces the averaged row score to the deterministic prefix--suffix functional +called `phi` in the source. +-/ + +/-- The sum of the two row scores for an ordering and its reversal, minus +twice the complement-entropy term. After reindexing the coordinates into the +given order, this is Anari--Rezaei's function `phi`. -/ +noncomputable def pairedRowScore {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) : ℝ := + (βˆ‘ j, p j * Real.log (suffixMass p Ο€ j)) + + (βˆ‘ j, p j * Real.log (suffixMass p (reverseOrdering Ο€) j)) - + 2 * βˆ‘ j, (1 - p j) * Real.log (1 - p j) + +/-- Averaging the paired score gives exactly twice the one-row correction. -/ +theorem uniformAverage_pairedRowScore {m : β„•} (p : Fin m β†’ ℝ) : + uniformAverage (pairedRowScore p) = 2 * rowCorrection p := by + let f : Equiv.Perm (Fin m) β†’ ℝ := fun Ο€ ↦ + βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) + let C : ℝ := βˆ‘ j, (1 - p j) * Real.log (1 - p j) + have hrev : uniformAverage (fun Ο€ : Equiv.Perm (Fin m) ↦ + f (reverseOrdering Ο€)) = uniformAverage f := by + exact uniformAverage_perm_preTrans f Fin.revPerm + have hconst : uniformAverage + (fun _Ο€ : Equiv.Perm (Fin m) ↦ 2 * C) = 2 * C := + uniformAverage_const (2 * C) + rw [show pairedRowScore p = fun Ο€ ↦ + f Ο€ + f (reverseOrdering Ο€) - 2 * C by + funext Ο€ + rfl] + rw [uniformAverage_sub, uniformAverage_add, hrev, hconst] + have hf : uniformAverage f = rowT p := rfl + rw [hf] + change rowT p + rowT p - 2 * C = 2 * rowCorrection p + rw [rowCorrection] + ring + +/-- Pointwise control of the reversal-paired functional implies the sharp +one-row deficit inequality. -/ +theorem rowDeficit_nonneg_of_pairedRowScore_le + {m : β„•} (p : Fin m β†’ ℝ) + (hphi : βˆ€ Ο€ : Equiv.Perm (Fin m), pairedRowScore p Ο€ ≀ Real.log 2) : + 0 ≀ rowDeficit p := by + have havg : uniformAverage (pairedRowScore p) ≀ + uniformAverage (fun _Ο€ : Equiv.Perm (Fin m) ↦ Real.log 2) := by + unfold uniformAverage + exact div_le_div_of_nonneg_right + (Finset.sum_le_sum fun Ο€ _ ↦ hphi Ο€) (Nat.cast_nonneg _) + rw [uniformAverage_pairedRowScore, + uniformAverage_const (Ξ± := Equiv.Perm (Fin m))] at havg + rw [rowDeficit] + linarith + +/-- The canonical `phi`, with the coordinates already arranged in their +natural order. -/ +noncomputable def anariRezaeiPhi {m : β„•} (p : Fin m β†’ ℝ) : ℝ := + pairedRowScore p (Equiv.refl (Fin m)) + +/-- Reindex a probability vector by an ordering. -/ +def orderCoordinates {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) : Fin m β†’ ℝ := + fun i ↦ p (Ο€ i) + +theorem orderCoordinates_probability {m : β„•} + {p : Fin m β†’ ℝ} (hp : IsProbabilityVector p) + (Ο€ : Equiv.Perm (Fin m)) : + IsProbabilityVector (orderCoordinates p Ο€) := by + refine ⟨fun i ↦ hp.nonnegative (Ο€ i), ?_⟩ + exact (Equiv.sum_comp Ο€ p).trans hp.sum_eq_one + +theorem suffixMass_orderCoordinates {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) (i : Fin m) : + suffixMass (orderCoordinates p Ο€) (Equiv.refl (Fin m)) i = + suffixMass p Ο€ (Ο€ i) := by + classical + rw [suffixMass, suffixMass] + change (βˆ‘ k, if i ≀ k then p (Ο€ k) else 0) = + βˆ‘ k, if Ο€.symm (Ο€ i) ≀ Ο€.symm k then p k else 0 + let f : Fin m β†’ ℝ := fun k ↦ + if Ο€.symm (Ο€ i) ≀ Ο€.symm k then p k else 0 + calc + (βˆ‘ k, if i ≀ k then p (Ο€ k) else 0) = + βˆ‘ k, f (Ο€ k) := by simp [f] + _ = βˆ‘ k, f k := Equiv.sum_comp Ο€ f + _ = βˆ‘ k, if Ο€.symm (Ο€ i) ≀ Ο€.symm k then p k else 0 := rfl + +theorem suffixMass_reverse_orderCoordinates {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) (i : Fin m) : + suffixMass (orderCoordinates p Ο€) + (reverseOrdering (Equiv.refl (Fin m))) i = + suffixMass p (reverseOrdering Ο€) (Ο€ i) := by + classical + rw [suffixMass, suffixMass] + change (βˆ‘ k, if + (reverseOrdering (Equiv.refl (Fin m))).symm i ≀ + (reverseOrdering (Equiv.refl (Fin m))).symm k + then p (Ο€ k) else 0) = + βˆ‘ k, if (reverseOrdering Ο€).symm (Ο€ i) ≀ + (reverseOrdering Ο€).symm k then p k else 0 + let f : Fin m β†’ ℝ := fun k ↦ + if (reverseOrdering Ο€).symm (Ο€ i) ≀ + (reverseOrdering Ο€).symm k then p k else 0 + calc + (βˆ‘ k, if + (reverseOrdering (Equiv.refl (Fin m))).symm i ≀ + (reverseOrdering (Equiv.refl (Fin m))).symm k + then p (Ο€ k) else 0) = + βˆ‘ k, f (Ο€ k) := by + apply Finset.sum_congr rfl + intro k _ + simp [f, reverseOrdering, Equiv.trans_apply] + _ = βˆ‘ k, f k := Equiv.sum_comp Ο€ f + _ = βˆ‘ k, if (reverseOrdering Ο€).symm (Ο€ i) ≀ + (reverseOrdering Ο€).symm k then p k else 0 := rfl + +/-- Every paired row score is the canonical `phi` of the reordered vector. -/ +theorem anariRezaeiPhi_orderCoordinates {m : β„•} + (p : Fin m β†’ ℝ) (Ο€ : Equiv.Perm (Fin m)) : + anariRezaeiPhi (orderCoordinates p Ο€) = pairedRowScore p Ο€ := by + classical + rw [anariRezaeiPhi, pairedRowScore, pairedRowScore] + have hsuffix : + (βˆ‘ j, orderCoordinates p Ο€ j * + Real.log (suffixMass (orderCoordinates p Ο€) + (Equiv.refl (Fin m)) j)) = + βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) := by + let f : Fin m β†’ ℝ := fun j ↦ + p j * Real.log (suffixMass p Ο€ j) + calc + (βˆ‘ j, orderCoordinates p Ο€ j * + Real.log (suffixMass (orderCoordinates p Ο€) + (Equiv.refl (Fin m)) j)) = + βˆ‘ i, f (Ο€ i) := by + apply Finset.sum_congr rfl + intro i _ + rw [suffixMass_orderCoordinates] + rfl + _ = βˆ‘ j, f j := Equiv.sum_comp Ο€ f + _ = βˆ‘ j, p j * Real.log (suffixMass p Ο€ j) := rfl + have hreverse : + (βˆ‘ j, orderCoordinates p Ο€ j * + Real.log (suffixMass (orderCoordinates p Ο€) + (reverseOrdering (Equiv.refl (Fin m))) j)) = + βˆ‘ j, p j * Real.log (suffixMass p (reverseOrdering Ο€) j) := by + let f : Fin m β†’ ℝ := fun j ↦ + p j * Real.log (suffixMass p (reverseOrdering Ο€) j) + calc + (βˆ‘ j, orderCoordinates p Ο€ j * + Real.log (suffixMass (orderCoordinates p Ο€) + (reverseOrdering (Equiv.refl (Fin m))) j)) = + βˆ‘ i, f (Ο€ i) := by + apply Finset.sum_congr rfl + intro i _ + rw [suffixMass_reverse_orderCoordinates] + rfl + _ = βˆ‘ j, f j := Equiv.sum_comp Ο€ f + _ = βˆ‘ j, p j * + Real.log (suffixMass p (reverseOrdering Ο€) j) := rfl + have hcomplement : + (βˆ‘ j, (1 - orderCoordinates p Ο€ j) * + Real.log (1 - orderCoordinates p Ο€ j)) = + βˆ‘ j, (1 - p j) * Real.log (1 - p j) := by + exact Equiv.sum_comp Ο€ + (fun j ↦ (1 - p j) * Real.log (1 - p j)) + rw [hsuffix, hreverse, hcomplement] + +/-- The canonical `phi` inequality implies the full Anari--Rezaei one-row +interface. -/ +theorem anariRezaeiRowInequality_of_phi + (hphi : βˆ€ {m : β„•}, 2 ≀ m β†’ βˆ€ p : Fin m β†’ ℝ, + IsProbabilityVector p β†’ anariRezaeiPhi p ≀ Real.log 2) : + AnariRezaeiRowInequality := by + intro m hm p hp + apply rowDeficit_nonneg_of_pairedRowScore_le + intro Ο€ + rw [← anariRezaeiPhi_orderCoordinates] + exact hphi hm (orderCoordinates p Ο€) + (orderCoordinates_probability hp Ο€) + +/-! ## An analytic replacement for the source's three-variable grid check -/ + +/-- A hyperbolic upper bound for the logarithm. -/ +theorem two_mul_log_le_sub_inv {z : ℝ} (hz : 1 ≀ z) : + 2 * Real.log z ≀ z - 1 / z := by + let h : ℝ β†’ ℝ := fun x ↦ x - 1 / x - 2 * Real.log x + have hcont : ContinuousOn h (Set.Ici (1 : ℝ)) := by + intro x hx + have hx0 : x β‰  0 := ne_of_gt (lt_of_lt_of_le zero_lt_one hx) + dsimp [h] + fun_prop + have hdiff : DifferentiableOn ℝ h (interior (Set.Ici (1 : ℝ))) := by + intro x hx + have hx' : 1 < x := by simpa using hx + have hx0 : x β‰  0 := ne_of_gt (zero_lt_one.trans hx') + have hd : HasDerivAt h (1 + 1 / x ^ 2 - 2 / x) x := by + dsimp [h] + convert! ((hasDerivAt_id x).sub + ((hasDerivAt_const x 1).div (hasDerivAt_id x) hx0)).sub + ((Real.hasDerivAt_log hx0).const_mul 2) using 1 <;> + simp only [id_eq] <;> ring + exact hd.differentiableAt.differentiableWithinAt + have hderiv : βˆ€ x ∈ interior (Set.Ici (1 : ℝ)), + deriv h x = (x - 1) ^ 2 / x ^ 2 := by + intro x hx + have hx' : 1 < x := by simpa using hx + have hx0 : x β‰  0 := ne_of_gt (zero_lt_one.trans hx') + have hd : HasDerivAt h (1 + 1 / x ^ 2 - 2 / x) x := by + dsimp [h] + convert! ((hasDerivAt_id x).sub + ((hasDerivAt_const x 1).div (hasDerivAt_id x) hx0)).sub + ((Real.hasDerivAt_log hx0).const_mul 2) using 1 <;> + simp only [id_eq] <;> ring + rw [hd.deriv] + field_simp + ring + have hmono : MonotoneOn h (Set.Ici (1 : ℝ)) := + monotoneOn_of_deriv_nonneg (convex_Ici (1 : ℝ)) hcont hdiff fun x hx ↦ by + rw [hderiv x hx] + positivity + have hle := hmono (by simp : (1 : ℝ) ∈ Set.Ici 1) hz hz + dsimp [h] at hle + norm_num at hle ⊒ + linarith + +/-- Positive Bernstein coefficients for the rational polynomial certificate +used below. The two indices are the Bernstein degrees in `u` and `v`. -/ +private noncomputable def anariRezaeiDirectionCoeff + (k : Fin 7) (l : Fin 5) : ℝ := + match k.1, l.1 with + | 0, 0 => 1 | 0, 1 => 78/25 | 0, 2 => 84/25 | 0, 3 => 34/25 | 0, 4 => 3/25 + | 1, 0 => 6 | 1, 1 => 468/25 | 1, 2 => 12358/625 | 1, 3 => 118062/15625 | 1, 4 => 7862/15625 + | 2, 0 => 15 | 2, 1 => 234/5 | 2, 2 => 30048/625 | 2, 3 => 267446/15625 | 2, 4 => 313384/390625 + | 3, 0 => 20 | 3, 1 => 312/5 | 3, 2 => 7674/125 | 3, 3 => 312712/15625 | 3, 4 => 281922/390625 + | 4, 0 => 15 | 4, 1 => 234/5 | 4, 2 => 26781/625 | 4, 3 => 197266/15625 | 4, 4 => 264016/390625 + | 5, 0 => 6 | 5, 1 => 468/25 | 5, 2 => 9454/625 | 5, 3 => 66032/15625 | 5, 4 => 242288/390625 + | 6, 0 => 1 | 6, 1 => 78/25 | 6, 2 => 1253/625 | 6, 3 => 10844/15625 | 6, 4 => 81844/390625 + | _, _ => 0 + +private noncomputable def anariRezaeiDirectionCertificate + (u v : ℝ) : ℝ := + βˆ‘ k : Fin 7, βˆ‘ l : Fin 5, + anariRezaeiDirectionCoeff k l * + u ^ k.1 * (1 - u) ^ (6 - k.1) * + v ^ l.1 * (1 - v) ^ (4 - l.1) + +private theorem anariRezaeiDirectionCoeff_nonneg + (k : Fin 7) (l : Fin 5) : + 0 ≀ anariRezaeiDirectionCoeff k l := by + fin_cases k <;> fin_cases l <;> + norm_num [anariRezaeiDirectionCoeff] + +private theorem anariRezaeiDirectionCertificate_nonneg + {u v : ℝ} (hu0 : 0 ≀ u) (hu1 : u ≀ 1) + (hv0 : 0 ≀ v) (hv1 : v ≀ 1) : + 0 ≀ anariRezaeiDirectionCertificate u v := by + apply Finset.sum_nonneg + intro k _ + apply Finset.sum_nonneg + intro l _ + exact mul_nonneg (mul_nonneg (mul_nonneg (mul_nonneg + (anariRezaeiDirectionCoeff_nonneg k l) (pow_nonneg hu0 _)) + (pow_nonneg (sub_nonneg.mpr hu1) _)) + (pow_nonneg hv0 _)) (pow_nonneg (sub_nonneg.mpr hv1) _) + +private theorem anariRezaeiDirectionCertificate_eq (u v : ℝ) : + anariRezaeiDirectionCertificate u v = + 1 - (22/25)*v + - (242/625)*u*v^2 + (2662/15625)*u*v^3 + - (242/625)*u^2*v^2 + (7986/15625)*u^2*v^3 - (14641/390625)*u^2*v^4 + - (242/625)*u^3*v^2 + (10648/15625)*u^3*v^3 - (58564/390625)*u^3*v^4 + - (121/625)*u^4*v^2 + (7986/15625)*u^4*v^3 - (87846/390625)*u^4*v^4 + + (2662/15625)*u^5*v^3 - (58564/390625)*u^5*v^4 + - (14641/390625)*u^6*v^4 := by + norm_num [anariRezaeiDirectionCertificate, + anariRezaeiDirectionCoeff, Fin.sum_univ_succ] + ring + +/-- Polynomial obtained after removing denominators from the directional +derivative estimate for the three-variable `phi`. -/ +noncomputable def anariRezaeiLargeCoordinatePolynomial + (q s : ℝ) : ℝ := + 2*q*(1-q)*s*(q+s)^2 + s^2*(1-s)^2 - (1-q)^2*(q+s)^4 + +/-- The polynomial is nonnegative on the triangle +`0 ≀ q ≀ s ≀ 11/25`. This is the 35-term exact rational certificate that +replaces the source's `881^2` grid computation. -/ +theorem anariRezaeiLargeCoordinatePolynomial_nonneg + {q s : ℝ} (hq0 : 0 ≀ q) (hqs : q ≀ s) + (hs : s ≀ 11/25) : + 0 ≀ anariRezaeiLargeCoordinatePolynomial q s := by + have hs0 : 0 ≀ s := hq0.trans hqs + by_cases hs_zero : s = 0 + Β· have hq_zero : q = 0 := le_antisymm (hqs.trans_eq hs_zero) hq0 + simp [anariRezaeiLargeCoordinatePolynomial, hs_zero, hq_zero] + Β· have hspos : 0 < s := lt_of_le_of_ne hs0 (Ne.symm hs_zero) + let u := q / s + let v := s / (11/25 : ℝ) + have hu0 : 0 ≀ u := div_nonneg hq0 hs0 + have hu1 : u ≀ 1 := (div_le_one hspos).mpr hqs + have hv0 : 0 ≀ v := div_nonneg hs0 (by norm_num) + have hv1 : v ≀ 1 := + (div_le_one (by norm_num : (0 : ℝ) < 11/25)).mpr hs + have hc := anariRezaeiDirectionCertificate_nonneg hu0 hu1 hv0 hv1 + have hid : anariRezaeiLargeCoordinatePolynomial q s = + s^2 * anariRezaeiDirectionCertificate u v := by + rw [anariRezaeiDirectionCertificate_eq] + dsimp [anariRezaeiLargeCoordinatePolynomial, u, v] + field_simp [hs_zero] + ring + rw [hid] + exact mul_nonneg (sq_nonneg s) hc + +/-- The derivative of the three-variable `phi` in its larger endpoint +coordinate, after eliminating the middle coordinate by `r = 1-q-s`. -/ +noncomputable def anariRezaeiLargeCoordinateDerivative + (q s : ℝ) : ℝ := + Real.log (s*(1-s)/((1-q)*(q+s)^2)) + q/(1-s) + +/-- On `0 ≀ q ≀ s ≀ 11/25`, increasing the larger endpoint coordinate does +not decrease the three-variable `phi`. -/ +theorem anariRezaeiLargeCoordinateDerivative_nonneg + {q s : ℝ} (hq0 : 0 ≀ q) (hqs : q ≀ s) + (hs : s ≀ 11/25) (hspos : 0 < s) : + 0 ≀ anariRezaeiLargeCoordinateDerivative q s := by + have hs1 : s < 1 := hs.trans_lt (by norm_num) + have hq1 : q < 1 := hqs.trans_lt hs1 + have honeq : 0 < 1-q := sub_pos.mpr hq1 + have hones : 0 < 1-s := sub_pos.mpr hs1 + have hsum : 0 < q+s := add_pos_of_nonneg_of_pos hq0 hspos + let z : ℝ := (1-q)*(q+s)^2/(s*(1-s)) + have hzpos : 0 < z := div_pos (mul_pos honeq (sq_pos_of_pos hsum)) + (mul_pos hspos hones) + have hrewrite : anariRezaeiLargeCoordinateDerivative q s = + -Real.log z + q/(1-s) := by + rw [anariRezaeiLargeCoordinateDerivative] + have hinv : s * (1-s) / ((1-q)*(q+s)^2) = z⁻¹ := by + dsimp [z] + field_simp + rw [hinv, Real.log_inv] + rw [hrewrite] + by_cases hz : z ≀ 1 + Β· have hlog : Real.log z ≀ 0 := Real.log_nonpos hzpos.le hz + exact add_nonneg (neg_nonneg.mpr hlog) (div_nonneg hq0 hones.le) + Β· have hz1 : 1 ≀ z := le_of_not_ge hz + have hlog := two_mul_log_le_sub_inv hz1 + have hpoly := anariRezaeiLargeCoordinatePolynomial_nonneg hq0 hqs hs + have hrat : z - 1/z ≀ 2*q/(1-s) := by + dsimp [z] + have hden1 : s * (1-s) β‰  0 := (mul_pos hspos hones).ne' + have hden2 : (1-q)*(q+s)^2 β‰  0 := + (mul_pos honeq (sq_pos_of_pos hsum)).ne' + field_simp [hden1, hden2, hones.ne'] + rw [anariRezaeiLargeCoordinatePolynomial] at hpoly + nlinarith + have htwo : 2*q/(1-s) = 2*(q/(1-s)) := by ring + rw [htwo] at hrat + have hlog' : Real.log z ≀ q/(1-s) := by linarith + linarith + +/-- The source's three-variable `phi(q,1-q-s,s)`, written with the continuous +`negMulLog` convention at `q=0` or `s=0`. -/ +noncomputable def anariRezaeiPhiThree (q s : ℝ) : ℝ := + -Real.negMulLog q - Real.negMulLog s + - (1-q+s)*Real.log (1-q) + - (1+q-s)*Real.log (1-s) + + 2*Real.negMulLog (q+s) + +theorem hasDerivAt_anariRezaeiPhiThree_right + {q s : ℝ} (hq1 : q < 1) (hs0 : 0 < s) (hs1 : s < 1) + (hq0 : 0 ≀ q) : + HasDerivAt (anariRezaeiPhiThree q) + (anariRezaeiLargeCoordinateDerivative q s) s := by + have hqsum : 0 < q+s := add_pos_of_nonneg_of_pos hq0 hs0 + have h1q : 1-q β‰  0 := (sub_pos.mpr hq1).ne' + have h1s : 1-s β‰  0 := (sub_pos.mpr hs1).ne' + have hsum : q+s β‰  0 := hqsum.ne' + have hnegS := (Real.hasDerivAt_negMulLog hs0.ne').neg + have hlin1 : HasDerivAt (fun x : ℝ => 1-q+x) 1 s := by + convert! (hasDerivAt_const s (1-q)).add (hasDerivAt_id s) using 1 <;> ring + have hterm1 := (hlin1.mul_const (Real.log (1-q))).neg + have hlin2 : HasDerivAt (fun x : ℝ => 1+q-x) (-1) s := by + convert! (hasDerivAt_const s (1+q)).sub (hasDerivAt_id s) using 1 <;> ring + have hcomp2 : HasDerivAt (fun x : ℝ => Real.log (1-x)) + (-1/(1-s)) s := by + convert! (Real.hasDerivAt_log h1s).comp s + ((hasDerivAt_const s 1).sub (hasDerivAt_id s)) using 1 <;> ring + have hterm2 := (hlin2.mul hcomp2).neg + have hsumlin : HasDerivAt (fun x : ℝ => q+x) 1 s := by + convert! (hasDerivAt_const s q).add (hasDerivAt_id s) using 1 <;> ring + have hterm3 := ((Real.hasDerivAt_negMulLog hsum).comp s hsumlin).const_mul 2 + have hd := ((((hasDerivAt_const s (-Real.negMulLog q)).add hnegS).add + hterm1).add hterm2).add hterm3 + convert! hd using 1 + rw [anariRezaeiLargeCoordinateDerivative] + rw [Real.log_div (mul_ne_zero hs0.ne' h1s) + (mul_ne_zero h1q (pow_ne_zero 2 hsum)), + Real.log_mul hs0.ne' h1s, + Real.log_mul h1q (pow_ne_zero 2 hsum), Real.log_pow] + field_simp [h1s] + ring + +/-- On the central triangle, `phi(q,1-q-s,s)` is no larger than its value +after increasing the larger endpoint coordinate to `11/25`. -/ +theorem anariRezaeiPhiThree_le_boundary + {q s : ℝ} (hq0 : 0 ≀ q) (hqs : q ≀ s) + (hs : s ≀ 11/25) : + anariRezaeiPhiThree q s ≀ anariRezaeiPhiThree q (11/25) := by + have hq1 : q < 1 := (hqs.trans hs).trans_lt (by norm_num) + have hcont : ContinuousOn (anariRezaeiPhiThree q) + (Set.Icc s (11/25)) := by + intro x hx + have hx1 : x < 1 := hx.2.trans_lt (by norm_num) + have h1q : 1-q β‰  0 := (sub_pos.mpr hq1).ne' + have h1x : 1-x β‰  0 := (sub_pos.mpr hx1).ne' + have hnml : ContinuousAt (fun y : ℝ ↦ Real.negMulLog y) x := + Real.continuous_negMulLog.continuousAt + have hlinearQ : ContinuousAt (fun y : ℝ ↦ 1 - q + y) x := + (continuousAt_const.sub continuousAt_const).add continuousAt_id + have hlinearX : ContinuousAt (fun y : ℝ ↦ 1 + q - y) x := + (continuousAt_const.add continuousAt_const).sub continuousAt_id + have hlogQ : ContinuousAt (fun _y : ℝ ↦ Real.log (1 - q)) x := + continuousAt_const + have hlogX : ContinuousAt (fun y : ℝ ↦ Real.log (1 - y)) x := + (continuousAt_const.sub continuousAt_id).log h1x + have hnmlSum : ContinuousAt (fun y : ℝ ↦ Real.negMulLog (q + y)) x := + Real.continuous_negMulLog.continuousAt.comp' + (continuousAt_const.add continuousAt_id) + have hzero : ContinuousAt (fun _y : ℝ ↦ -Real.negMulLog q) x := + continuousAt_const + have htwo : ContinuousAt (fun _y : ℝ ↦ (2 : ℝ)) x := + continuousAt_const + have htotal := + ((((hzero.sub hnml).sub (hlinearQ.mul hlogQ)).sub + (hlinearX.mul hlogX)).add (htwo.mul hnmlSum)) + change ContinuousWithinAt (fun y : ℝ ↦ + -Real.negMulLog q - Real.negMulLog y + - (1-q+y)*Real.log (1-q) + - (1+q-y)*Real.log (1-y) + + 2*Real.negMulLog (q+y)) (Set.Icc s (11/25)) x + exact htotal.continuousWithinAt + have hdiff : DifferentiableOn ℝ (anariRezaeiPhiThree q) + (interior (Set.Icc s (11/25))) := by + intro x hx + have hx' : s < x ∧ x < 11/25 := by simpa using hx + have hx0 : 0 < x := lt_of_le_of_lt (hq0.trans hqs) hx'.1 + have hx1 : x < 1 := hx'.2.trans (by norm_num) + exact (hasDerivAt_anariRezaeiPhiThree_right hq1 hx0 hx1 + hq0).differentiableAt.differentiableWithinAt + have hmono : MonotoneOn (anariRezaeiPhiThree q) + (Set.Icc s (11/25)) := + monotoneOn_of_deriv_nonneg (convex_Icc s (11/25)) hcont hdiff fun x hx => by + have hx' : s < x ∧ x < 11/25 := by simpa using hx + have hx0 : 0 < x := lt_of_le_of_lt (hq0.trans hqs) hx'.1 + have hx1 : x < 1 := hx'.2.trans (by norm_num) + rw [(hasDerivAt_anariRezaeiPhiThree_right hq1 hx0 hx1 hq0).deriv] + exact anariRezaeiLargeCoordinateDerivative_nonneg hq0 + (hqs.trans hx'.1.le) hx'.2.le hx0 + exact hmono ⟨le_rfl, hs⟩ ⟨hs, le_rfl⟩ hs + +theorem anariRezaeiPhiThree_comm (q s : ℝ) : + anariRezaeiPhiThree q s = anariRezaeiPhiThree s q := by + rw [anariRezaeiPhiThree, anariRezaeiPhiThree] + ring + +/-! On the boundary `s = 11/25`, the derivative is nonnegative after +`q = 1/5`. The following five positive Bernstein coefficients certify the +only polynomial inequality needed for that assertion. -/ + +private noncomputable def anariRezaeiEdgeCoeff (k : Fin 5) : ℝ := + match k.1 with + | 0 => 3260944 / 244140625 + | 1 => 24245392 / 244140625 + | 2 => 53151396 / 244140625 + | 3 => 41514088 / 244140625 + | 4 => 9903124 / 244140625 + | _ => 0 + +private noncomputable def anariRezaeiEdgeCertificate (v : ℝ) : ℝ := + βˆ‘ k : Fin 5, anariRezaeiEdgeCoeff k * + v ^ k.1 * (1 - v) ^ (4 - k.1) + +private theorem anariRezaeiEdgeCoeff_nonneg (k : Fin 5) : + 0 ≀ anariRezaeiEdgeCoeff k := by + fin_cases k <;> norm_num [anariRezaeiEdgeCoeff] + +private theorem anariRezaeiEdgeCertificate_nonneg + {v : ℝ} (hv0 : 0 ≀ v) (hv1 : v ≀ 1) : + 0 ≀ anariRezaeiEdgeCertificate v := by + apply Finset.sum_nonneg + intro k _ + exact mul_nonneg (mul_nonneg (anariRezaeiEdgeCoeff_nonneg k) + (pow_nonneg hv0 _)) (pow_nonneg (sub_nonneg.mpr hv1) _) + +private theorem anariRezaeiEdgeCertificate_eq (v : ℝ) : + anariRezaeiEdgeCertificate v = + (3260944 + 11201616*v - 19116*v^2 - 5096304*v^3 + + 555984*v^4) / 244140625 := by + norm_num [anariRezaeiEdgeCertificate, anariRezaeiEdgeCoeff, + Fin.sum_univ_succ] + ring + +/-- The explicit quartic edge polynomial with constants `11/25` and `14/25` used in the +Anari-Rezaei edge estimate. -/ +noncomputable def anariRezaeiEdgePolynomial (q : ℝ) : ℝ := + 2*(11/25)*(14/25)*q*(q+11/25)^2 + q^2*(1-q)^2 - + (14/25)^2*(q+11/25)^4 + +theorem anariRezaeiEdgePolynomial_nonneg + {q : ℝ} (hq0 : 1/5 ≀ q) (hq1 : q ≀ 11/25) : + 0 ≀ anariRezaeiEdgePolynomial q := by + let v : ℝ := (q - 1/5) / (6/25) + have hv0 : 0 ≀ v := div_nonneg (sub_nonneg.mpr hq0) (by norm_num) + have hv1 : v ≀ 1 := by + dsimp [v] + apply (div_le_one (by norm_num : (0 : ℝ) < 6/25)).mpr + linarith + have hc := anariRezaeiEdgeCertificate_nonneg hv0 hv1 + have hid : anariRezaeiEdgePolynomial q = + anariRezaeiEdgeCertificate v := by + rw [anariRezaeiEdgeCertificate_eq] + dsimp [anariRezaeiEdgePolynomial, v] + ring + rw [hid] + exact hc + +/-- The boundary-edge derivative is nonnegative on `[1/5, 11/25]`. -/ +theorem anariRezaeiEdgeDerivative_nonneg + {q : ℝ} (hq0 : 1/5 ≀ q) (hq1 : q ≀ 11/25) : + 0 ≀ anariRezaeiLargeCoordinateDerivative (11/25) q := by + have hqpos : 0 < q := (by norm_num : (0 : ℝ) < 1/5).trans_le hq0 + have hq_lt_one : q < 1 := hq1.trans_lt (by norm_num) + have h1q : 0 < 1-q := sub_pos.mpr hq_lt_one + have ha0 : 0 < (11/25 : ℝ) := by norm_num + have ha1 : 0 < (14/25 : ℝ) := by norm_num + have hsum : 0 < q+11/25 := add_pos hqpos ha0 + let z : ℝ := (14/25)*(q+11/25)^2/(q*(1-q)) + have hzpos : 0 < z := div_pos (mul_pos ha1 (sq_pos_of_pos hsum)) + (mul_pos hqpos h1q) + have hrewrite : anariRezaeiLargeCoordinateDerivative (11/25) q = + -Real.log z + (11/25)/(1-q) := by + rw [anariRezaeiLargeCoordinateDerivative] + have hinv : q*(1-q)/((1-11/25)*(11/25+q)^2) = z⁻¹ := by + dsimp [z] + norm_num + field_simp + ring + rw [hinv, Real.log_inv] + rw [hrewrite] + by_cases hz : z ≀ 1 + Β· have hlog : Real.log z ≀ 0 := Real.log_nonpos hzpos.le hz + exact add_nonneg (neg_nonneg.mpr hlog) (div_nonneg (by norm_num) h1q.le) + Β· have hz1 : 1 ≀ z := le_of_not_ge hz + have hlog := two_mul_log_le_sub_inv hz1 + have hpoly := anariRezaeiEdgePolynomial_nonneg hq0 hq1 + have hrat : z - 1/z ≀ 2*(11/25)/(1-q) := by + dsimp [z] + have hden1 : q*(1-q) β‰  0 := (mul_pos hqpos h1q).ne' + have hden2 : (14/25)*(q+11/25)^2 β‰  0 := + (mul_pos ha1 (sq_pos_of_pos hsum)).ne' + field_simp [hden1, hden2, h1q.ne'] + rw [anariRezaeiEdgePolynomial] at hpoly + nlinarith + have htwo : 2*(11/25)/(1-q) = 2*((11/25)/(1-q)) := by ring + rw [htwo] at hrat + linarith + +theorem hasDerivAt_anariRezaeiPhiThree_edge + {q : ℝ} (hq0 : 0 < q) (hq1 : q < 1) : + HasDerivAt (fun x ↦ anariRezaeiPhiThree x (11/25)) + (anariRezaeiLargeCoordinateDerivative (11/25) q) q := by + have hd := hasDerivAt_anariRezaeiPhiThree_right + (q := (11/25 : ℝ)) (s := q) (by norm_num) hq0 hq1 (by norm_num) + have heq : (fun x ↦ anariRezaeiPhiThree x (11/25)) =αΆ [nhds q] + anariRezaeiPhiThree (11/25) := + Filter.Eventually.of_forall fun x ↦ + (anariRezaeiPhiThree_comm (11/25) x).symm + exact hd.congr_of_eventuallyEq heq + +/-- The edge second-derivative expression `1/q - 2/(q + 11/25) - (1 - q - 11/25)/(1 - q)^2`. -/ +noncomputable def anariRezaeiEdgeSecondDerivative (q : ℝ) : ℝ := + 1/q - 2/(q+11/25) - (1-q-11/25)/(1-q)^2 + +theorem hasDerivAt_anariRezaeiEdgeDerivative + {q : ℝ} (hq0 : 0 < q) (hq1 : q < 1) : + HasDerivAt (anariRezaeiLargeCoordinateDerivative (11/25)) + (anariRezaeiEdgeSecondDerivative q) q := by + have h1q : 1-q β‰  0 := (sub_pos.mpr hq1).ne' + have hsum : q+11/25 β‰  0 := (add_pos hq0 (by norm_num)).ne' + have hnum : q*(1-q) β‰  0 := mul_ne_zero hq0.ne' h1q + have hden : (1-11/25)*(11/25+q)^2 β‰  0 := by + norm_num + simpa [add_comm] using hsum + have hnum' := (hasDerivAt_id q).mul + ((hasDerivAt_const q 1).sub (hasDerivAt_id q)) + have hsum' : HasDerivAt (fun x : ℝ ↦ 11/25+x) 1 q := by + convert! (hasDerivAt_const q (11/25)).add (hasDerivAt_id q) using 1 <;> ring + have hden' : HasDerivAt + (fun x : ℝ ↦ (1-11/25)*(11/25+x)^2) + (2*(1-11/25)*(11/25+q)) q := by + convert! (hsum'.pow 2).const_mul (1-11/25) using 1 <;> ring + have hquot := hnum'.div hden' hden + have hlog := (Real.hasDerivAt_log (div_ne_zero hnum hden)).comp q hquot + have hlin : HasDerivAt (fun x : ℝ ↦ 1-x) (-1) q := by + convert! (hasDerivAt_const q 1).sub (hasDerivAt_id q) using 1 <;> ring + have hfrac := (hasDerivAt_const q (11/25 : ℝ)).div hlin h1q + have hd := hlog.add hfrac + convert! hd using 1 <;> + dsimp [anariRezaeiLargeCoordinateDerivative, + anariRezaeiEdgeSecondDerivative] <;> + field_simp [hq0.ne', h1q, hsum] <;> ring + +private theorem anariRezaeiEdgeSecondNumerator_nonneg + {q : ℝ} (hq0 : 0 ≀ q) (hq1 : q ≀ 1/5) : + 0 ≀ 11/25 - (1329/625)*q + (58/25)*q^2 := by + have hfactor1 : 0 ≀ 1/5-q := sub_nonneg.mpr hq1 + have hfactor2 : 0 ≀ 1329/625-(58/25)*(q+1/5) := by + linarith + have hprod := mul_nonneg hfactor1 hfactor2 + nlinarith + +theorem anariRezaeiEdgeSecondDerivative_nonneg + {q : ℝ} (hq0 : 0 < q) (hq1 : q ≀ 1/5) : + 0 ≀ anariRezaeiEdgeSecondDerivative q := by + have hq_lt_one : q < 1 := hq1.trans_lt (by norm_num) + have h1q : 0 < 1-q := sub_pos.mpr hq_lt_one + have hsum : 0 < q+11/25 := add_pos hq0 (by norm_num) + have hnum := anariRezaeiEdgeSecondNumerator_nonneg hq0.le hq1 + have hden : 0 < q*(q+11/25)*(1-q)^2 := + mul_pos (mul_pos hq0 hsum) (sq_pos_of_pos h1q) + have hid : anariRezaeiEdgeSecondDerivative q = + (11/25 - (1329/625)*q + (58/25)*q^2) / + (q*(q+11/25)*(1-q)^2) := by + rw [anariRezaeiEdgeSecondDerivative] + field_simp [hq0.ne', hsum.ne', h1q.ne'] + ring + rw [hid] + exact div_nonneg hnum hden.le + +private theorem continuousWithinAt_anariRezaeiPhiThree_edge + {D : Set ℝ} {q : ℝ} (hq1 : q < 1) : + ContinuousWithinAt (fun x ↦ anariRezaeiPhiThree x (11/25)) D q := by + have h1q : 1-q β‰  0 := (sub_pos.mpr hq1).ne' + have hid : ContinuousWithinAt (fun x : ℝ ↦ x) D q := + continuousAt_id.continuousWithinAt + have hc : ContinuousWithinAt (fun _x : ℝ ↦ (11/25 : ℝ)) D q := + continuousWithinAt_const + have hnq : ContinuousWithinAt (fun x : ℝ ↦ Real.negMulLog x) D q := + Real.continuous_negMulLog.continuousAt.continuousWithinAt + have hna : ContinuousWithinAt (fun _x : ℝ ↦ Real.negMulLog (11/25)) D q := + continuousWithinAt_const + have hlogq : ContinuousWithinAt (fun x : ℝ ↦ Real.log (1-x)) D q := + (continuousWithinAt_const.sub hid).log h1q + have hloga : ContinuousWithinAt + (fun _x : ℝ ↦ Real.log (1-11/25)) D q := continuousWithinAt_const + have hnsum : ContinuousWithinAt + (fun x : ℝ ↦ Real.negMulLog (x+11/25)) D q := by + simpa [Function.comp_def] using + (Real.continuous_negMulLog.continuousAt.comp + (continuousAt_id.add continuousAt_const)).continuousWithinAt + unfold anariRezaeiPhiThree + exact (((hnq.neg.sub hna).sub + (((continuousWithinAt_const.sub hid).add hc).mul hlogq)).sub + (((continuousWithinAt_const.add hid).sub hc).mul hloga)).add + (hnsum.const_mul 2) + +/-- The boundary-edge function is convex between `0` and `1/5`. -/ +theorem anariRezaeiPhiThree_edge_convex : + ConvexOn ℝ (Set.Icc (0 : ℝ) (1/5)) + (fun q ↦ anariRezaeiPhiThree q (11/25)) := by + apply convexOn_of_hasDerivWithinAt2_nonneg (convex_Icc 0 (1/5)) + Β· intro q hq + have hq1 : q < 1 := hq.2.trans_lt (by norm_num) + exact continuousWithinAt_anariRezaeiPhiThree_edge hq1 + Β· intro q hq + have hq' : 0 < q ∧ q < 1/5 := by simpa using hq + exact (hasDerivAt_anariRezaeiPhiThree_edge hq'.1 + (hq'.2.trans (by norm_num))).hasDerivWithinAt + Β· intro q hq + have hq' : 0 < q ∧ q < 1/5 := by simpa using hq + exact (hasDerivAt_anariRezaeiEdgeDerivative hq'.1 + (hq'.2.trans (by norm_num))).hasDerivWithinAt + Β· intro q hq + have hq' : 0 < q ∧ q < 1/5 := by simpa using hq + exact anariRezaeiEdgeSecondDerivative_nonneg hq'.1 hq'.2.le + +theorem binaryEntropy_le_log_two + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) : + binaryEntropy t ≀ Real.log 2 := by + let p : Fin 2 β†’ ℝ := fun i ↦ if i = 0 then t else 1-t + have hp : IsProbabilityVector p := by + constructor + Β· intro i + fin_cases i <;> simp [p, ht0, sub_nonneg.mpr ht1] + Β· norm_num [p, Fin.sum_univ_succ] + have h := shannonEntropy_le_log_card hp + simpa [shannonEntropy, binaryEntropy, p, Fin.sum_univ_succ] using h + +theorem anariRezaeiPhiThree_zero_edge : + anariRezaeiPhiThree 0 (11/25) = binaryEntropy (11/25) := by + rw [anariRezaeiPhiThree, binaryEntropy] + simp only [Real.negMulLog_zero, neg_zero, zero_add, + Real.log_one, mul_zero, sub_zero] + rw [Real.negMulLog_def] + ring + +theorem anariRezaeiPhiThree_zero_edge_le : + anariRezaeiPhiThree 0 (11/25) ≀ Real.log 2 := by + rw [anariRezaeiPhiThree_zero_edge] + exact binaryEntropy_le_log_two (by norm_num) (by norm_num) + +/-- At the other endpoint of the boundary edge, the desired estimate reduces +to a single exact integer inequality. -/ +theorem anariRezaeiPhiThree_diagonal_le_binaryEntropy : + anariRezaeiPhiThree (11/25) (11/25) ≀ binaryEntropy (11/25) := by + have h11 : (11/25 : ℝ) β‰  0 := by norm_num + have h14 : (14/25 : ℝ) β‰  0 := by norm_num + have h2 : (2 : ℝ) β‰  0 := by norm_num + have hA : (11/25 : ℝ)^11 β‰  0 := pow_ne_zero 11 h11 + have hB : (2 : ℝ)^44 β‰  0 := pow_ne_zero 44 h2 + have hC : (14/25 : ℝ)^36 β‰  0 := pow_ne_zero 36 h14 + have hprod : (1 : ℝ) ≀ + (11/25 : ℝ)^11 * 2^44 * (14/25)^36 := by + norm_num + have hlogprod := Real.log_nonneg hprod + rw [Real.log_mul (mul_ne_zero hA hB) hC, + Real.log_mul hA hB, Real.log_pow, Real.log_pow, Real.log_pow] at hlogprod + have h22 : (22/25 : ℝ) = 2*(11/25) := by norm_num + rw [anariRezaeiPhiThree, binaryEntropy, Real.negMulLog_def] + norm_num only [sub_self, add_zero, Real.log_one, + mul_zero, sub_zero] + rw [h22, Real.log_mul h2 h11] + nlinarith + +theorem anariRezaeiPhiThree_diagonal_le : + anariRezaeiPhiThree (11/25) (11/25) ≀ Real.log 2 := + anariRezaeiPhiThree_diagonal_le_binaryEntropy.trans + (binaryEntropy_le_log_two (by norm_num) (by norm_num)) + +theorem anariRezaeiPhiThree_edge_le_diagonal + {q : ℝ} (hq0 : 1/5 ≀ q) (hq1 : q ≀ 11/25) : + anariRezaeiPhiThree q (11/25) ≀ + anariRezaeiPhiThree (11/25) (11/25) := by + have hcont : ContinuousOn (fun x ↦ anariRezaeiPhiThree x (11/25)) + (Set.Icc q (11/25)) := by + intro x hx + exact continuousWithinAt_anariRezaeiPhiThree_edge + (hx.2.trans_lt (by norm_num)) + have hdiff : DifferentiableOn ℝ + (fun x ↦ anariRezaeiPhiThree x (11/25)) + (interior (Set.Icc q (11/25))) := by + intro x hx + have hx' : q < x ∧ x < 11/25 := by simpa using hx + exact (hasDerivAt_anariRezaeiPhiThree_edge + ((by norm_num : (0 : ℝ) < 1/5).trans_le (hq0.trans hx'.1.le)) + (hx'.2.trans (by norm_num))).differentiableAt.differentiableWithinAt + have hmono : MonotoneOn (fun x ↦ anariRezaeiPhiThree x (11/25)) + (Set.Icc q (11/25)) := + monotoneOn_of_deriv_nonneg (convex_Icc q (11/25)) hcont hdiff + fun x hx ↦ by + have hx' : q < x ∧ x < 11/25 := by simpa using hx + rw [(hasDerivAt_anariRezaeiPhiThree_edge + ((by norm_num : (0 : ℝ) < 1/5).trans_le (hq0.trans hx'.1.le)) + (hx'.2.trans (by norm_num))).deriv] + exact anariRezaeiEdgeDerivative_nonneg (hq0.trans hx'.1.le) hx'.2.le + exact hmono ⟨le_rfl, hq1⟩ ⟨hq1, le_rfl⟩ hq1 + +/-- Every point of the boundary edge satisfies the sharp `log 2` bound. -/ +theorem anariRezaeiPhiThree_edge_le + {q : ℝ} (hq0 : 0 ≀ q) (hq1 : q ≀ 11/25) : + anariRezaeiPhiThree q (11/25) ≀ Real.log 2 := by + by_cases hq : q ≀ 1/5 + Β· have hmax := anariRezaeiPhiThree_edge_convex.le_max_of_mem_Icc + (x := (0 : ℝ)) (y := (1/5 : ℝ)) (z := q) + (by norm_num) (by norm_num) ⟨hq0, hq⟩ + have hright : anariRezaeiPhiThree (1/5) (11/25) ≀ Real.log 2 := + (anariRezaeiPhiThree_edge_le_diagonal (by norm_num) (by norm_num)).trans + anariRezaeiPhiThree_diagonal_le + exact hmax.trans (max_le anariRezaeiPhiThree_zero_edge_le hright) + Β· exact (anariRezaeiPhiThree_edge_le_diagonal (le_of_not_ge hq) hq1).trans + anariRezaeiPhiThree_diagonal_le + +/-- Exact replacement for the source's computer-assisted three-variable +base case. -/ +theorem anariRezaeiPhiThree_le_log_two + {q s : ℝ} (hq0 : 0 ≀ q) (hs0 : 0 ≀ s) + (hq : q ≀ 11/25) (hs : s ≀ 11/25) : + anariRezaeiPhiThree q s ≀ Real.log 2 := by + rcases le_total q s with hqs | hsq + Β· exact (anariRezaeiPhiThree_le_boundary hq0 hqs hs).trans + (anariRezaeiPhiThree_edge_le hq0 hq) + Β· rw [anariRezaeiPhiThree_comm] + exact (anariRezaeiPhiThree_le_boundary hs0 hsq hq).trans + (anariRezaeiPhiThree_edge_le hs0 hs) + +/-- The three-coordinate vector with entries `q`, `1 - q - s`, and `s`. -/ +def anariRezaeiThreeVector (q s : ℝ) : Fin 3 β†’ ℝ := + ![q, 1-q-s, s] + +theorem anariRezaeiThreeVector_probability + {q s : ℝ} (hq : 0 ≀ q) (hs : 0 ≀ s) (hqs : q+s ≀ 1) : + IsProbabilityVector (anariRezaeiThreeVector q s) := by + constructor + Β· intro i + fin_cases i <;> simp [anariRezaeiThreeVector] <;> linarith + Β· norm_num [anariRezaeiThreeVector, Fin.sum_univ_succ] + +theorem anariRezaeiPhi_threeVector (q s : ℝ) : + anariRezaeiPhi (anariRezaeiThreeVector q s) = + anariRezaeiPhiThree q s := by + classical + rw [anariRezaeiPhi, pairedRowScore] + simp [suffixMass, reverseOrdering, anariRezaeiThreeVector, + Fin.sum_univ_succ, anariRezaeiPhiThree] + simp only [Real.negMulLog_def] + ring_nf + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiList.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiList.lean new file mode 100644 index 0000000000..35c050e8e4 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiList.lean @@ -0,0 +1,398 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiMerge + +/-! # Source Anari Rezaei List -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Dimension reduction for the Anari--Rezaei functional + +Lists expose the adjacent-merge induction without finite-index casts. The +last part of the file identifies this list functional with the canonical +`Fin n` functional used by the rest of the development. +-/ + +/-- Sums each list entry times the logarithm of the suffix sum starting at that entry. -/ +noncomputable def anariRezaeiRightScore : List ℝ β†’ ℝ + | [] => 0 + | x :: xs => x * Real.log ((x :: xs).sum) + anariRezaeiRightScore xs + +/-- Sums the complement terms `(1 - x) * log (1 - x)` over a list. -/ +noncomputable def anariRezaeiComplementScore (p : List ℝ) : ℝ := + (p.map fun x ↦ (1-x)*Real.log (1-x)).sum + +/-- Adds forward and reverse suffix-log scores and subtracts twice the complement score. -/ +noncomputable def anariRezaeiListPhi (p : List ℝ) : ℝ := + anariRezaeiRightScore p + anariRezaeiRightScore p.reverse - + 2*anariRezaeiComplementScore p + +theorem anariRezaeiRightScore_merge + (L R : List ℝ) (r s : ℝ) : + anariRezaeiRightScore (L ++ r :: s :: R) - + anariRezaeiRightScore (L ++ (r+s) :: R) = + s*(Real.log (s+R.sum)-Real.log (r+s+R.sum)) := by + induction L with + | nil => + simp [anariRezaeiRightScore] + ring + | cons x L ih => + simp only [List.cons_append, anariRezaeiRightScore] + have hsum : (x :: (L ++ r :: s :: R)).sum = + (x :: (L ++ (r+s) :: R)).sum := by simp; ring + rw [hsum] + linarith [ih] + +theorem anariRezaeiComplementScore_merge + (L R : List ℝ) (r s : ℝ) : + anariRezaeiComplementScore (L ++ r :: s :: R) - + anariRezaeiComplementScore (L ++ (r+s) :: R) = + (1-r)*Real.log (1-r) + (1-s)*Real.log (1-s) - + (1-r-s)*Real.log (1-r-s) := by + simp [anariRezaeiComplementScore] + ring + +/-- The expanded logarithmic gap for merging adjacent masses `r` and `s` with surrounding masses +`q` and `t`. -/ +noncomputable def anariRezaeiMergeExpandedGap (q r s t : ℝ) : ℝ := + r*(Real.log (q+r)-Real.log (q+r+s)) + + s*(Real.log (s+t)-Real.log (r+s+t)) - + 2*(1-r)*Real.log (1-r) - + 2*(1-s)*Real.log (1-s) + + 2*(1-r-s)*Real.log (1-r-s) + +theorem anariRezaeiListPhi_merge (L R : List ℝ) (r s : ℝ) : + anariRezaeiListPhi (L ++ r :: s :: R) - + anariRezaeiListPhi (L ++ (r+s) :: R) = + anariRezaeiMergeExpandedGap L.sum r s R.sum := by + have hrevOld : (L ++ r :: s :: R).reverse = + R.reverse ++ s :: r :: L.reverse := by simp + have hrevNew : (L ++ (r+s) :: R).reverse = + R.reverse ++ (s+r) :: L.reverse := by simp [add_comm] + have hf := anariRezaeiRightScore_merge L R r s + have hb := anariRezaeiRightScore_merge R.reverse L.reverse s r + have hc := anariRezaeiComplementScore_merge L R r s + have hb' : + anariRezaeiRightScore (R.reverse ++ s :: r :: L.reverse) - + anariRezaeiRightScore (R.reverse ++ (s+r) :: L.reverse) = + r*(Real.log (L.sum+r)-Real.log (L.sum+r+s)) := by + simpa [add_comm, add_left_comm, add_assoc] using hb + rw [anariRezaeiListPhi, anariRezaeiListPhi, hrevOld, hrevNew, + anariRezaeiMergeExpandedGap] + linear_combination hf + hb' - 2*hc + +theorem anariRezaeiMergeExpandedGap_nonpos + {q r s t : ℝ} (hq0 : 0 ≀ q) (hr0 : 0 ≀ r) + (hs0 : 0 ≀ s) (ht0 : 0 ≀ t) + (hsum : q+r+s+t = 1) (hC : r+s ≀ 14/25) : + anariRezaeiMergeExpandedGap q r s t ≀ 0 := by + by_cases hrz : r = 0 + Β· subst r + rw [anariRezaeiMergeExpandedGap] + norm_num + Β· by_cases hsz : s = 0 + Β· subst s + rw [anariRezaeiMergeExpandedGap] + norm_num + Β· have hr : 0 < r := lt_of_le_of_ne hr0 (Ne.symm hrz) + have hs : 0 < s := lt_of_le_of_ne hs0 (Ne.symm hsz) + have hqr : 0 < q+r := add_pos_of_nonneg_of_pos hq0 hr + have hqrs : 0 < q+r+s := add_pos hqr hs + have hst : 0 < s+t := add_pos_of_pos_of_nonneg hs ht0 + have hrst : 0 < r+s+t := add_pos_of_pos_of_nonneg (add_pos hr hs) ht0 + have heq : anariRezaeiMergeExpandedGap q r s t = + anariRezaeiMergeGap q r s t := by + rw [anariRezaeiMergeExpandedGap, anariRezaeiMergeGap, + Real.log_div hqr.ne' hqrs.ne', Real.log_div hst.ne' hrst.ne'] + rw [heq] + exact anariRezaeiMergeGap_nonpos hq0 hr0 hs0 ht0 hsum hC + +theorem anariRezaeiListPhi_le_of_merge + {L R : List ℝ} {r s : ℝ} + (hL : βˆ€ x ∈ L, 0 ≀ x) (hR : βˆ€ x ∈ R, 0 ≀ x) + (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) + (hsum : (L ++ r :: s :: R).sum = 1) + (hC : r+s ≀ 14/25) : + anariRezaeiListPhi (L ++ r :: s :: R) ≀ + anariRezaeiListPhi (L ++ (r+s) :: R) := by + have hLsum : 0 ≀ L.sum := List.sum_nonneg hL + have hRsum : 0 ≀ R.sum := List.sum_nonneg hR + have hquad : L.sum+r+s+R.sum = 1 := by + simp only [List.sum_append, List.sum_cons, List.sum_nil] at hsum + linarith + have hgap := anariRezaeiMergeExpandedGap_nonpos + hLsum hr0 hs0 hRsum hquad hC + rw [← anariRezaeiListPhi_merge] at hgap + linarith + +theorem anariRezaeiListPhi_two + {q s : ℝ} (hsum : q+s = 1) : + anariRezaeiListPhi [q,s] = binaryEntropy q := by + have hs : s = 1-q := by linarith + subst s + simp [anariRezaeiListPhi, anariRezaeiRightScore, + anariRezaeiComplementScore, binaryEntropy, Real.negMulLog_def] + ring + +theorem anariRezaeiListPhi_two_le + {q s : ℝ} (hq0 : 0 ≀ q) (hs0 : 0 ≀ s) + (hsum : q+s = 1) : + anariRezaeiListPhi [q,s] ≀ Real.log 2 := by + rw [anariRezaeiListPhi_two hsum] + apply binaryEntropy_le_log_two hq0 + linarith + +theorem anariRezaeiListPhi_three + {q r s : ℝ} (hsum : q+r+s = 1) : + anariRezaeiListPhi [q,r,s] = anariRezaeiPhiThree q s := by + have hr : r = 1-q-s := by linarith + subst r + simp [anariRezaeiListPhi, anariRezaeiRightScore, + anariRezaeiComplementScore, anariRezaeiPhiThree, + Real.negMulLog_def] + ring_nf + rw [Real.log_one] + ring + +theorem anariRezaeiListPhi_three_le + {q r s : ℝ} (hq0 : 0 ≀ q) (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) + (hsum : q+r+s = 1) : + anariRezaeiListPhi [q,r,s] ≀ Real.log 2 := by + by_cases hqr : q+r ≀ 14/25 + Β· calc + anariRezaeiListPhi [q,r,s] ≀ anariRezaeiListPhi [q+r,s] := by + simpa using anariRezaeiListPhi_le_of_merge + (L := []) (R := [s]) (r := q) (s := r) + (by simp) (by simpa) hq0 hr0 (by norm_num; linarith) hqr + _ ≀ Real.log 2 := anariRezaeiListPhi_two_le + (add_nonneg hq0 hr0) hs0 (by linarith) + Β· by_cases hrs : r+s ≀ 14/25 + Β· calc + anariRezaeiListPhi [q,r,s] ≀ anariRezaeiListPhi [q,r+s] := by + simpa using anariRezaeiListPhi_le_of_merge + (L := [q]) (R := []) (r := r) (s := s) + (by simpa) (by simp) hr0 hs0 (by norm_num; linarith) hrs + _ ≀ Real.log 2 := anariRezaeiListPhi_two_le + hq0 (add_nonneg hr0 hs0) (by linarith) + Β· rw [anariRezaeiListPhi_three hsum] + apply anariRezaeiPhiThree_le_log_two hq0 hs0 + Β· linarith + Β· linarith + +private theorem anariRezaeiListPhi_le_log_two_fuel + (fuel : β„•) (p : List ℝ) (hlen : p.length ≀ fuel) + (hp : βˆ€ x ∈ p, 0 ≀ x) (hsum : p.sum = 1) : + anariRezaeiListPhi p ≀ Real.log 2 := by + induction fuel generalizing p with + | zero => + have hpempty : p = [] := List.length_eq_zero_iff.mp + (Nat.eq_zero_of_le_zero hlen) + subst p + simp at hsum + | succ fuel ih => + rcases p with _ | ⟨a, p⟩ + Β· simp at hsum + rcases p with _ | ⟨b, p⟩ + Β· have ha : a = 1 := by simpa using hsum + subst a + simp [anariRezaeiListPhi, anariRezaeiRightScore, + anariRezaeiComplementScore] + exact Real.log_nonneg (by norm_num) + rcases p with _ | ⟨c, p⟩ + Β· apply anariRezaeiListPhi_two_le + Β· exact hp a (by simp) + Β· exact hp b (by simp) + Β· norm_num at hsum ⊒ + linarith + rcases p with _ | ⟨d, R⟩ + Β· apply anariRezaeiListPhi_three_le + Β· exact hp a (by simp) + Β· exact hp b (by simp) + Β· exact hp c (by simp) + Β· norm_num at hsum ⊒ + linarith + have ha : 0 ≀ a := hp a (by simp) + have hb : 0 ≀ b := hp b (by simp) + have hc : 0 ≀ c := hp c (by simp) + have hd : 0 ≀ d := hp d (by simp) + have hR : βˆ€ x ∈ R, 0 ≀ x := by + intro x hx + exact hp x (by simp [hx]) + have hRsum : 0 ≀ R.sum := List.sum_nonneg hR + have hsum' : a+b+c+d+R.sum = 1 := by + norm_num at hsum + linarith + by_cases hab : a+b ≀ 1/2 + Β· let p' := (a+b) :: c :: d :: R + have hp' : βˆ€ x ∈ p', 0 ≀ x := by + intro x hx + simp only [p', List.mem_cons] at hx + rcases hx with rfl | rfl | rfl | hx + Β· exact add_nonneg ha hb + Β· exact hc + Β· exact hd + Β· exact hR x hx + have hp'sum : p'.sum = 1 := by + dsimp [p'] + norm_num + linarith + have hp'len : p'.length ≀ fuel := by + dsimp [p'] + simp at hlen ⊒ + omega + have hmerge : anariRezaeiListPhi (a :: b :: c :: d :: R) ≀ + anariRezaeiListPhi p' := by + simpa [p'] using anariRezaeiListPhi_le_of_merge + (L := []) (R := c :: d :: R) (r := a) (s := b) + (by simp) (by + intro x hx + simp only [List.mem_cons] at hx + rcases hx with rfl | rfl | hx + Β· exact hc + Β· exact hd + Β· exact hR x hx) + ha hb (by norm_num; linarith) (hab.trans (by norm_num)) + exact hmerge.trans (ih p' hp'len hp' hp'sum) + Β· have hcd : c+d ≀ 1/2 := by + have hab' : 1/2 < a+b := lt_of_not_ge hab + linarith + let p' := a :: b :: (c+d) :: R + have hp' : βˆ€ x ∈ p', 0 ≀ x := by + intro x hx + simp only [p', List.mem_cons] at hx + rcases hx with rfl | rfl | rfl | hx + Β· exact ha + Β· exact hb + Β· exact add_nonneg hc hd + Β· exact hR x hx + have hp'sum : p'.sum = 1 := by + dsimp [p'] + norm_num + linarith + have hp'len : p'.length ≀ fuel := by + dsimp [p'] + simp at hlen ⊒ + omega + have hmerge : anariRezaeiListPhi (a :: b :: c :: d :: R) ≀ + anariRezaeiListPhi p' := by + simpa [p'] using anariRezaeiListPhi_le_of_merge + (L := [a,b]) (R := R) (r := c) (s := d) + (by simp [ha, hb]) hR hc hd + (by norm_num; linarith) (hcd.trans (by norm_num)) + exact hmerge.trans (ih p' hp'len hp' hp'sum) + +/-- The sharp `log 2` bound for probability lists of arbitrary length. -/ +theorem anariRezaeiListPhi_le_log_two_of_probability + (p : List ℝ) (hp : βˆ€ x ∈ p, 0 ≀ x) (hsum : p.sum = 1) : + anariRezaeiListPhi p ≀ Real.log 2 := + anariRezaeiListPhi_le_log_two_fuel p.length p le_rfl hp hsum + +/-! ## Identification with the finite-coordinate functional -/ + +theorem list_sum_ofFn_eq_fin_sum {m : β„•} (p : Fin m β†’ ℝ) : + (List.ofFn p).sum = βˆ‘ i, p i := by + induction m with + | zero => simp [List.ofFn_zero] + | succ m ih => + rw [List.ofFn_succ, Fin.sum_univ_succ] + simp only [List.sum_cons] + rw [ih] + +theorem anariRezaeiRightScore_ofFn {m : β„•} (p : Fin m β†’ ℝ) : + anariRezaeiRightScore (List.ofFn p) = + βˆ‘ j, p j * Real.log (suffixMass p (Equiv.refl (Fin m)) j) := by + induction m with + | zero => simp [List.ofFn_zero, anariRezaeiRightScore, suffixMass] + | succ m ih => + rw [List.ofFn_succ, anariRezaeiRightScore, Fin.sum_univ_succ] + rw [ih (fun i ↦ p i.succ)] + have hsum : (p 0 :: List.ofFn fun i ↦ p i.succ).sum = βˆ‘ i, p i := by + rw [List.sum_cons, list_sum_ofFn_eq_fin_sum, Fin.sum_univ_succ] + have hzero : suffixMass p (Equiv.refl (Fin (m+1))) 0 = βˆ‘ i, p i := by + simp [suffixMass] + rw [hsum, hzero] + congr 1 + apply Finset.sum_congr rfl + intro j _ + congr 2 + rw [suffixMass, suffixMass, Fin.sum_univ_succ] + simp + rfl + +theorem anariRezaeiComplementScore_ofFn {m : β„•} (p : Fin m β†’ ℝ) : + anariRezaeiComplementScore (List.ofFn p) = + βˆ‘ j, (1-p j)*Real.log (1-p j) := by + rw [anariRezaeiComplementScore] + rw [List.map_ofFn] + simpa [Function.comp_def] using + list_sum_ofFn_eq_fin_sum (fun j ↦ (1-p j)*Real.log (1-p j)) + +theorem ofFn_orderCoordinates_revPerm {m : β„•} (p : Fin m β†’ ℝ) : + List.ofFn (orderCoordinates p Fin.revPerm) = (List.ofFn p).reverse := by + apply List.ext_getElem + Β· simp + Β· intro i hi hri + rw [List.getElem_ofFn, List.getElem_reverse, List.getElem_ofFn] + apply congrArg p + apply Fin.ext + simp [orderCoordinates, Fin.revPerm_apply, Fin.val_rev] + omega + +theorem anariRezaeiReverseScore_ofFn {m : β„•} (p : Fin m β†’ ℝ) : + anariRezaeiRightScore (List.ofFn p).reverse = + βˆ‘ j, p j * Real.log + (suffixMass p (reverseOrdering (Equiv.refl (Fin m))) j) := by + let f : Fin m β†’ ℝ := fun j ↦ p j * Real.log + (suffixMass p (reverseOrdering (Equiv.refl (Fin m))) j) + calc + anariRezaeiRightScore (List.ofFn p).reverse = + anariRezaeiRightScore + (List.ofFn (orderCoordinates p Fin.revPerm)) := by + rw [ofFn_orderCoordinates_revPerm] + _ = βˆ‘ i, orderCoordinates p Fin.revPerm i * + Real.log (suffixMass (orderCoordinates p Fin.revPerm) + (Equiv.refl (Fin m)) i) := + anariRezaeiRightScore_ofFn _ + _ = βˆ‘ i, f (Fin.revPerm i) := by + apply Finset.sum_congr rfl + intro i _ + rw [suffixMass_orderCoordinates] + rfl + _ = βˆ‘ j, f j := Equiv.sum_comp Fin.revPerm f + _ = βˆ‘ j, p j * Real.log + (suffixMass p (reverseOrdering (Equiv.refl (Fin m))) j) := rfl + +theorem anariRezaeiListPhi_ofFn {m : β„•} (p : Fin m β†’ ℝ) : + anariRezaeiListPhi (List.ofFn p) = anariRezaeiPhi p := by + rw [anariRezaeiListPhi, anariRezaeiPhi, pairedRowScore, + anariRezaeiRightScore_ofFn, anariRezaeiReverseScore_ofFn, + anariRezaeiComplementScore_ofFn] + +/-- The source's sharp one-row inequality, now without an interface +hypothesis. -/ +theorem anariRezaeiPhi_le_log_two + {m : β„•} (p : Fin m β†’ ℝ) (hp : IsProbabilityVector p) : + anariRezaeiPhi p ≀ Real.log 2 := by + rw [← anariRezaeiListPhi_ofFn] + apply anariRezaeiListPhi_le_log_two_of_probability + Β· intro x hx + rw [List.mem_ofFn] at hx + rcases hx with ⟨i, rfl⟩ + exact hp.nonnegative i + Β· rw [list_sum_ofFn_eq_fin_sum, hp.sum_eq_one] + +theorem anariRezaeiRowInequality : AnariRezaeiRowInequality := by + apply anariRezaeiRowInequality_of_phi + intro m _hm p hp + exact anariRezaeiPhi_le_log_two p hp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiMerge.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiMerge.lean new file mode 100644 index 0000000000..a34217dad2 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceAnariRezaeiMerge.lean @@ -0,0 +1,496 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaei + +/-! # Source Anari Rezaei Merge -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The Anari--Rezaei merge argument + +This file formalizes the dimension-reduction lemma in the source proof. We +use the rational cutoff `14/25`; it is smaller than the source cutoff and its +complement is exactly the `11/25` used by the analytic three-variable proof. +-/ + +/-- Loss in `phi` before two adjacent masses `r,s` are merged. -/ +noncomputable def anariRezaeiMergeGap (q r s t : ℝ) : ℝ := + r * Real.log ((q+r)/(q+r+s)) + + s * Real.log ((s+t)/(r+s+t)) - + 2*(1-r)*Real.log (1-r) - + 2*(1-s)*Real.log (1-s) + + 2*(1-r-s)*Real.log (1-r-s) + +/-- The value of the merge gap at its stationary choice of the exterior +masses. -/ +noncomputable def anariRezaeiMergePsi (r s : ℝ) : ℝ := + -(r+s)*Real.log (1+r+s) + + (s-r)*Real.log ((1+s)/(1+r)) - + 2*(1-r)*Real.log (1-r) - + 2*(1-s)*Real.log (1-s) + + 2*(1-r-s)*Real.log (1-r-s) + +/-- Restricts the merge comparison function to the line where its two arguments sum to `C`. -/ +noncomputable def anariRezaeiMergePsiAlong (C x : ℝ) : ℝ := + anariRezaeiMergePsi x (C-x) + +/-- The explicit logarithmic and reciprocal derivative expression used for the two-mass merge +comparison. -/ +noncomputable def anariRezaeiMergePsiDerivative (r s : ℝ) : ℝ := + -2*Real.log ((1+s)/(1+r)) - + (s-r)*(1/(1+r)+1/(1+s)) + + 2*Real.log ((1-r)/(1-s)) + +theorem anariRezaeiMergePsi_zero (C : ℝ) : + anariRezaeiMergePsi 0 C = 0 := by + rw [anariRezaeiMergePsi] + norm_num + +theorem hasDerivAt_anariRezaeiMergePsiAlong + {C x : ℝ} (hx0 : 0 ≀ x) (hxC : x ≀ C) + (hC : C < 1) : + HasDerivAt (anariRezaeiMergePsiAlong C) + (anariRezaeiMergePsiDerivative x (C-x)) x := by + have h1px : 1+x β‰  0 := by linarith + have h1ps : 1+(C-x) β‰  0 := by linarith + have h1mx : 1-x β‰  0 := by linarith + have h1ms : 1-(C-x) β‰  0 := by linarith + have hconst : HasDerivAt (fun _y : ℝ ↦ C) 0 x := hasDerivAt_const x C + have hid := hasDerivAt_id x + have hs := hconst.sub hid + have h1px' := (hasDerivAt_const x 1).add hid + have h1ps' := (hasDerivAt_const x 1).add hs + have hratioPlus := h1ps'.div h1px' h1px + have hlogPlus := (Real.hasDerivAt_log (div_ne_zero h1ps h1px)).comp x hratioPlus + have hdiff := hs.sub hid + have hmiddle := hdiff.mul hlogPlus + have h1mx' := (hasDerivAt_const x 1).sub hid + have h1ms' := (hasDerivAt_const x 1).sub hs + have hlogmx := (Real.hasDerivAt_log h1mx).comp x h1mx' + have hlogms := (Real.hasDerivAt_log h1ms).comp x h1ms' + have hxm := (h1mx'.mul hlogmx).const_mul (-2) + have hsm := (h1ms'.mul hlogms).const_mul (-2) + have hlast : HasDerivAt + (fun _y : ℝ ↦ 2*(1-C)*Real.log (1-C)) 0 x := + hasDerivAt_const x _ + have hfirst : HasDerivAt + (fun _y : ℝ ↦ -C*Real.log (1+C)) 0 x := + hasDerivAt_const x _ + have hd := (((hfirst.add hmiddle).add hxm).add hsm).add hlast + convert! hd using 1 + Β· funext y + simp only [anariRezaeiMergePsiAlong, anariRezaeiMergePsi, + Function.comp_apply, Pi.add_apply, Pi.sub_apply, Pi.mul_apply, + Pi.div_apply, id_eq] + ring + Β· dsimp [anariRezaeiMergePsiDerivative] + rw [Real.log_div h1mx h1ms] + try simp only [Function.comp_apply, Pi.add_apply, Pi.sub_apply, + Pi.mul_apply, Pi.div_apply, id_eq] + field_simp [h1px, h1ps, h1mx, h1ms] + ring + +/-- The derivative of `psi(x,C-x)` is nonpositive on its first half. The +proof uses the elementary hyperbolic logarithm bound and exact polynomial +arithmetic; it replaces the integral estimate in the source. -/ +theorem anariRezaeiMergePsiDerivative_nonpos + {r s : ℝ} (hr0 : 0 ≀ r) (hrs : r ≀ s) + (hC : r+s ≀ 14/25) : + anariRezaeiMergePsiDerivative r s ≀ 0 := by + have hs0 : 0 ≀ s := hr0.trans hrs + have hs1 : s < 1 := (le_add_of_nonneg_left hr0).trans hC |>.trans_lt (by norm_num) + have hr1 : r < 1 := hrs.trans_lt hs1 + have h1mr : 0 < 1-r := sub_pos.mpr hr1 + have h1ms : 0 < 1-s := sub_pos.mpr hs1 + have h1pr : 0 < 1+r := by linarith + have h1ps : 0 < 1+s := by linarith + let z : ℝ := (1-r^2)/(1-s^2) + have hden : 0 < 1-s^2 := by nlinarith + have hnum : 0 < 1-r^2 := by nlinarith + have hzpos : 0 < z := div_pos hnum hden + have hz1 : 1 ≀ z := by + apply (one_le_div hden).mpr + nlinarith [mul_self_le_mul_self (by linarith : 0 ≀ r) hrs] + have hlog := two_mul_log_le_sub_inv hz1 + have hcut : 0 ≀ 2-3*(r+s)-(r+s)^2 := by + have hfac : 0 ≀ (14/25-(r+s))*(3+14/25+(r+s)) := + mul_nonneg (sub_nonneg.mpr hC) (by positivity) + nlinarith + have hrat : z-1/z ≀ + (s-r)*(1/(1+r)+1/(1+s)) := by + dsimp [z] + have hA : 1-r^2 β‰  0 := hnum.ne' + have hB : 1-s^2 β‰  0 := hden.ne' + field_simp [hA, hB, h1pr.ne', h1ps.ne'] + have hrs0 : 0 ≀ r*s := mul_nonneg hr0 hs0 + have h2C : 0 ≀ 2-(r+s) := by linarith + have hextra : 0 ≀ (r+s)^3 + (2-(r+s))*(r*s) := + add_nonneg (pow_nonneg (add_nonneg hr0 hs0) 3) + (mul_nonneg h2C hrs0) + have hD : 0 ≀ 2-3*(r+s)-(r+s)^2 + + ((r+s)^3 + (2-(r+s))*(r*s)) := add_nonneg hcut hextra + have hfactor : 0 ≀ (s-r)*(1+r)*(1+s)* + (2-3*(r+s)-(r+s)^2 + + ((r+s)^3 + (2-(r+s))*(r*s))) := by positivity + nlinarith + have hlogRewrite : Real.log z = + Real.log ((1-r)/(1-s)) - Real.log ((1+s)/(1+r)) := by + have hzEq : z = ((1-r)/(1-s))/((1+s)/(1+r)) := by + dsimp [z] + field_simp [h1mr.ne', h1ms.ne', h1pr.ne', h1ps.ne'] + ring + rw [hzEq, Real.log_div (div_ne_zero h1mr.ne' h1ms.ne') + (div_ne_zero h1ps.ne' h1pr.ne')] + rw [hlogRewrite] at hlog + rw [anariRezaeiMergePsiDerivative] + linarith + +theorem anariRezaeiMergePsi_nonpos_ordered + {r s : ℝ} (hr0 : 0 ≀ r) (hrs : r ≀ s) + (hC : r+s ≀ 14/25) : + anariRezaeiMergePsi r s ≀ 0 := by + let C := r+s + have hC0 : 0 ≀ C := add_nonneg hr0 (hr0.trans hrs) + have hrC : r ≀ C := le_add_of_nonneg_right (hr0.trans hrs) + have hClt : C < 1 := hC.trans_lt (by norm_num) + have hcont : ContinuousOn (anariRezaeiMergePsiAlong C) (Set.Icc 0 r) := by + intro x hx + exact (hasDerivAt_anariRezaeiMergePsiAlong hx.1 (hx.2.trans hrC) + hClt).continuousAt.continuousWithinAt + have hdiff : DifferentiableOn ℝ (anariRezaeiMergePsiAlong C) + (interior (Set.Icc 0 r)) := by + intro x hx + have hx' : 0 < x ∧ x < r := by simpa using hx + exact (hasDerivAt_anariRezaeiMergePsiAlong hx'.1.le + (hx'.2.le.trans hrC) hClt).differentiableAt.differentiableWithinAt + have hanti : AntitoneOn (anariRezaeiMergePsiAlong C) (Set.Icc 0 r) := + antitoneOn_of_deriv_nonpos (convex_Icc 0 r) hcont hdiff fun x hx ↦ by + have hx' : 0 < x ∧ x < r := by simpa using hx + rw [(hasDerivAt_anariRezaeiMergePsiAlong hx'.1.le + (hx'.2.le.trans hrC) hClt).deriv] + apply anariRezaeiMergePsiDerivative_nonpos hx'.1.le + Β· dsimp [C] + linarith + Β· dsimp [C] + ring_nf + exact hC + have hle := hanti ⟨le_rfl, hr0⟩ ⟨hr0, le_rfl⟩ hr0 + dsimp [anariRezaeiMergePsiAlong, C] at hle + rw [show r+s-r=s by ring, anariRezaeiMergePsi_zero] at hle + exact hle + +theorem anariRezaeiMergePsi_comm + {r s : ℝ} (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) : + anariRezaeiMergePsi r s = anariRezaeiMergePsi s r := by + have h1pr : 1+r β‰  0 := by linarith + have h1ps : 1+s β‰  0 := by linarith + rw [anariRezaeiMergePsi, anariRezaeiMergePsi] + rw [Real.log_div h1ps h1pr, Real.log_div h1pr h1ps] + ring + +theorem anariRezaeiMergePsi_nonpos + {r s : ℝ} (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) + (hC : r+s ≀ 14/25) : + anariRezaeiMergePsi r s ≀ 0 := by + rcases le_total r s with hrs | hsr + Β· exact anariRezaeiMergePsi_nonpos_ordered hr0 hrs hC + Β· rw [anariRezaeiMergePsi_comm hr0 hs0] + exact anariRezaeiMergePsi_nonpos_ordered hs0 hsr (by linarith) + +/-- The candidate outer mass `(1 - r * (1 + r + s)) / (2 + r + s)` in the merge-gap +optimization. -/ +noncomputable def anariRezaeiMergeQStar (r s : ℝ) : ℝ := + (1-r*(1+r+s))/(2+r+s) + +/-- The symmetric candidate outer mass `(1 - s * (1 + r + s)) / (2 + r + s)` in the merge-gap +optimization. -/ +noncomputable def anariRezaeiMergeTStar (r s : ℝ) : ℝ := + (1-s*(1+r+s))/(2+r+s) + +private theorem anariRezaeiCutoff_product + {C : ℝ} (hC0 : 0 ≀ C) (hC : C ≀ 14/25) : + C*(1+C) < 1 := by + have hfac : 0 ≀ (14/25-C)*(1+14/25+C) := + mul_nonneg (sub_nonneg.mpr hC) (by positivity) + nlinarith + +theorem anariRezaeiMergeStars_nonnegative + {r s : ℝ} (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) + (hC : r+s ≀ 14/25) : + 0 ≀ anariRezaeiMergeQStar r s ∧ + 0 ≀ anariRezaeiMergeTStar r s := by + have hC0 : 0 ≀ r+s := add_nonneg hr0 hs0 + have hprod := anariRezaeiCutoff_product hC0 hC + have hrC : r ≀ r+s := le_add_of_nonneg_right hs0 + have hsC : s ≀ r+s := le_add_of_nonneg_left hr0 + have hden : 0 < 2+r+s := by linarith + constructor + Β· rw [anariRezaeiMergeQStar] + exact div_nonneg (by nlinarith) hden.le + Β· rw [anariRezaeiMergeTStar] + exact div_nonneg (by nlinarith) hden.le + +theorem anariRezaeiMergeStars_sum (r s : ℝ) (hden : 2+r+s β‰  0) : + anariRezaeiMergeQStar r s + anariRezaeiMergeTStar r s = + 1-r-s := by + rw [anariRezaeiMergeQStar, anariRezaeiMergeTStar] + field_simp [hden] + ring + +/-- Restricts the merge gap to outer masses `x` and `1 - r - s - x`, keeping total mass one. -/ +noncomputable def anariRezaeiMergeGapAlong (r s x : ℝ) : ℝ := + anariRezaeiMergeGap x r s (1-r-s-x) + +/-- The explicit derivative expression for the merge gap along the fixed-total-mass line. -/ +noncomputable def anariRezaeiMergeGapDerivative (r s x : ℝ) : ℝ := + r*s*(1/((x+r)*(x+r+s)) - + 1/((1-r-x)*(1-x))) + +theorem hasDerivAt_anariRezaeiMergeGapAlong + {r s x : ℝ} (hr : 0 < r) (hs : 0 < s) + (hx0 : 0 ≀ x) (ht0 : 0 ≀ 1-r-s-x) : + HasDerivAt (anariRezaeiMergeGapAlong r s) + (anariRezaeiMergeGapDerivative r s x) x := by + have hxr : 0 < x+r := add_pos_of_nonneg_of_pos hx0 hr + have hxC : 0 < x+r+s := add_pos hxr hs + have hst : 0 < s+(1-r-s-x) := add_pos_of_pos_of_nonneg hs ht0 + have hCt : 0 < r+s+(1-r-s-x) := add_pos_of_pos_of_nonneg (add_pos hr hs) ht0 + have hid := hasDerivAt_id x + have hxR := hid.add_const r + have hxC' := (hid.add_const r).add_const s + have hratio1 := hxR.div hxC' hxC.ne' + have hlog1 := (Real.hasDerivAt_log (div_ne_zero hxr.ne' hxC.ne')).comp x hratio1 + have hst2 : 0 < 1-r-x := by linarith + have hCt2 : 0 < 1-x := by linarith + have hsT' := (hasDerivAt_const x (1-r)).sub hid + have hCT' := (hasDerivAt_const x 1).sub hid + have hratio2 := hsT'.div hCT' hCt2.ne' + have hlog2 := (Real.hasDerivAt_log + (div_ne_zero hst2.ne' hCt2.ne')).comp x hratio2 + have hvar := (hlog1.const_mul r).add (hlog2.const_mul s) + have hconst : HasDerivAt (fun _y : ℝ ↦ + -2*(1-r)*Real.log (1-r) - + 2*(1-s)*Real.log (1-s) + + 2*(1-r-s)*Real.log (1-r-s)) 0 x := hasDerivAt_const x _ + have hd := hvar.add hconst + convert! hd using 1 + Β· funext y + simp only [anariRezaeiMergeGapAlong, anariRezaeiMergeGap, + Function.comp_apply, Pi.add_apply, Pi.sub_apply, Pi.div_apply, id_eq] + ring + Β· dsimp [anariRezaeiMergeGapDerivative] + try simp only [Function.comp_apply, Pi.add_apply, Pi.sub_apply, + Pi.div_apply, id_eq] + field_simp [hxr.ne', hxC.ne', hst2.ne', hCt2.ne'] + ring + +theorem anariRezaeiMergeGapDerivative_sign + {r s x : ℝ} (hr : 0 < r) (hs : 0 < s) + (hx0 : 0 ≀ x) (ht0 : 0 ≀ 1-r-s-x) : + (0 ≀ anariRezaeiMergeGapDerivative r s x ↔ + x ≀ anariRezaeiMergeQStar r s) ∧ + (anariRezaeiMergeGapDerivative r s x ≀ 0 ↔ + anariRezaeiMergeQStar r s ≀ x) := by + have hxr : 0 < x+r := add_pos_of_nonneg_of_pos hx0 hr + have hxC : 0 < x+r+s := add_pos hxr hs + have hst : 0 < 1-r-x := by linarith + have hCt : 0 < 1-x := by linarith + have hden : 0 < (x+r)*(x+r+s)*(1-r-x)*(1-x) := by positivity + have hstar : 0 < 2+r+s := by positivity + have hid : anariRezaeiMergeGapDerivative r s x = + r*s*(1-r*(1+r+s)-(2+r+s)*x) / + ((x+r)*(x+r+s)*(1-r-x)*(1-x)) := by + rw [anariRezaeiMergeGapDerivative] + field_simp [hxr.ne', hxC.ne', hst.ne', hCt.ne'] + ring + rw [hid] + have hrs : 0 < r*s := mul_pos hr hs + constructor + Β· constructor + Β· intro h + have hmul := mul_nonneg h hden.le + rw [div_mul_cancelβ‚€ _ hden.ne'] at hmul + have hlin : 0 ≀ 1-r*(1+r+s)-(2+r+s)*x := + nonneg_of_mul_nonneg_right hmul hrs + rw [anariRezaeiMergeQStar, (le_div_iffβ‚€ hstar)] + linarith + Β· intro h + rw [anariRezaeiMergeQStar, (le_div_iffβ‚€ hstar)] at h + exact div_nonneg (mul_nonneg hrs.le (by linarith)) hden.le + Β· constructor + Β· intro h + have hmul := mul_nonpos_of_nonpos_of_nonneg h hden.le + rw [div_mul_cancelβ‚€ _ hden.ne'] at hmul + have hlin : 1-r*(1+r+s)-(2+r+s)*x ≀ 0 := + nonpos_of_mul_nonpos_right hmul hrs + rw [anariRezaeiMergeQStar, (div_le_iffβ‚€ hstar)] + linarith + Β· intro h + rw [anariRezaeiMergeQStar, (div_le_iffβ‚€ hstar)] at h + exact div_nonpos_of_nonpos_of_nonneg + (mul_nonpos_of_nonneg_of_nonpos hrs.le (by linarith)) hden.le + +theorem anariRezaeiMergeGap_le_stationary + {q r s t : ℝ} (hq0 : 0 ≀ q) (hr : 0 < r) (hs : 0 < s) + (ht0 : 0 ≀ t) (hsum : q+r+s+t = 1) + (hC : r+s ≀ 14/25) : + anariRezaeiMergeGap q r s t ≀ + anariRezaeiMergeGap (anariRezaeiMergeQStar r s) r s + (anariRezaeiMergeTStar r s) := by + have hstars := anariRezaeiMergeStars_nonnegative hr.le hs.le hC + have hqstar0 := hstars.1 + have htstar0 := hstars.2 + have htEq : t = 1-r-s-q := by linarith + have hden : 2+r+s β‰  0 := by positivity + have hstarEq : anariRezaeiMergeTStar r s = + 1-r-s-anariRezaeiMergeQStar r s := by + linarith [anariRezaeiMergeStars_sum r s hden] + have hcapStar : 0 ≀ 1-r-s-anariRezaeiMergeQStar r s := by + rw [← hstarEq] + exact htstar0 + subst t + rw [hstarEq] + change anariRezaeiMergeGapAlong r s q ≀ + anariRezaeiMergeGapAlong r s (anariRezaeiMergeQStar r s) + rcases le_total q (anariRezaeiMergeQStar r s) with hq | hq + Β· have hcont : ContinuousOn (anariRezaeiMergeGapAlong r s) + (Set.Icc q (anariRezaeiMergeQStar r s)) := by + intro x hx + exact (hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hq0.trans hx.1) (by linarith [hcapStar, hx.2])).continuousAt.continuousWithinAt + have hdiff : DifferentiableOn ℝ (anariRezaeiMergeGapAlong r s) + (interior (Set.Icc q (anariRezaeiMergeQStar r s))) := by + intro x hx + have hx' : q < x ∧ x < anariRezaeiMergeQStar r s := by simpa using hx + exact (hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hq0.trans hx'.1.le) + (by linarith [hcapStar, hx'.2.le])).differentiableAt.differentiableWithinAt + have hmono := monotoneOn_of_deriv_nonneg + (convex_Icc q (anariRezaeiMergeQStar r s)) hcont hdiff fun x hx ↦ by + have hx' : q < x ∧ x < anariRezaeiMergeQStar r s := by simpa using hx + rw [(hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hq0.trans hx'.1.le) (by linarith [hcapStar, hx'.2.le])).deriv] + exact (anariRezaeiMergeGapDerivative_sign hr hs + (hq0.trans hx'.1.le) (by linarith [hcapStar, hx'.2.le])).1.mpr hx'.2.le + exact hmono ⟨le_rfl, hq⟩ ⟨hq, le_rfl⟩ hq + Β· have hcont : ContinuousOn (anariRezaeiMergeGapAlong r s) + (Set.Icc (anariRezaeiMergeQStar r s) q) := by + intro x hx + exact (hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hqstar0.trans hx.1) (by linarith [ht0, hx.2])).continuousAt.continuousWithinAt + have hdiff : DifferentiableOn ℝ (anariRezaeiMergeGapAlong r s) + (interior (Set.Icc (anariRezaeiMergeQStar r s) q)) := by + intro x hx + have hx' : anariRezaeiMergeQStar r s < x ∧ x < q := by simpa using hx + exact (hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hqstar0.trans hx'.1.le) + (by linarith [ht0, hx'.2.le])).differentiableAt.differentiableWithinAt + have hanti := antitoneOn_of_deriv_nonpos + (convex_Icc (anariRezaeiMergeQStar r s) q) hcont hdiff fun x hx ↦ by + have hx' : anariRezaeiMergeQStar r s < x ∧ x < q := by simpa using hx + rw [(hasDerivAt_anariRezaeiMergeGapAlong hr hs + (hqstar0.trans hx'.1.le) (by linarith [ht0, hx'.2.le])).deriv] + exact (anariRezaeiMergeGapDerivative_sign hr hs + (hqstar0.trans hx'.1.le) (by linarith [ht0, hx'.2.le])).2.mpr hx'.1.le + exact hanti ⟨le_rfl, hq⟩ ⟨hq, le_rfl⟩ hq + +theorem anariRezaeiMergeGap_stationary_eq + {r s : ℝ} (hr0 : 0 ≀ r) (hs0 : 0 ≀ s) + (hC : r+s ≀ 14/25) : + anariRezaeiMergeGap (anariRezaeiMergeQStar r s) r s + (anariRezaeiMergeTStar r s) = anariRezaeiMergePsi r s := by + have h1pr : 1+r β‰  0 := by linarith + have h1ps : 1+s β‰  0 := by linarith + have h1pC : 1+r+s β‰  0 := by linarith + have hden : 2+r+s β‰  0 := by linarith + have hqNum : anariRezaeiMergeQStar r s+r = + (1+r)/(2+r+s) := by + rw [anariRezaeiMergeQStar] + field_simp [hden] + ring + have hqDen : anariRezaeiMergeQStar r s+r+s = + ((1+r+s)*(1+s))/(2+r+s) := by + rw [anariRezaeiMergeQStar] + field_simp [hden] + ring + have hqratio : + (anariRezaeiMergeQStar r s+r)/ + (anariRezaeiMergeQStar r s+r+s) = + (1+r)/((1+r+s)*(1+s)) := by + rw [hqDen, hqNum] + field_simp [hden, h1pr, h1ps, h1pC] + have htNum : s+anariRezaeiMergeTStar r s = + (1+s)/(2+r+s) := by + rw [anariRezaeiMergeTStar] + field_simp [hden] + ring + have htDen : r+s+anariRezaeiMergeTStar r s = + ((1+r+s)*(1+r))/(2+r+s) := by + rw [anariRezaeiMergeTStar] + field_simp [hden] + ring + have htratio : + (s+anariRezaeiMergeTStar r s)/ + (r+s+anariRezaeiMergeTStar r s) = + (1+s)/((1+r+s)*(1+r)) := by + rw [htDen, htNum] + field_simp [hden, h1pr, h1ps, h1pC] + rw [anariRezaeiMergeGap, anariRezaeiMergePsi, hqratio, htratio] + rw [Real.log_div h1pr (mul_ne_zero h1pC h1ps), + Real.log_div h1ps (mul_ne_zero h1pC h1pr), + Real.log_div h1ps h1pr, + Real.log_mul h1pC h1ps, Real.log_mul h1pC h1pr] + ring + +/-- Four-mass merge lemma with the rational cutoff used by the formal proof. -/ +theorem anariRezaeiMergeGap_nonpos + {q r s t : ℝ} (hq0 : 0 ≀ q) (hr0 : 0 ≀ r) + (hs0 : 0 ≀ s) (ht0 : 0 ≀ t) + (hsum : q+r+s+t = 1) (hC : r+s ≀ 14/25) : + anariRezaeiMergeGap q r s t ≀ 0 := by + by_cases hrz : r = 0 + Β· subst r + rw [anariRezaeiMergeGap] + by_cases hst : s+t = 0 + Β· have hs : s = 0 := by linarith + subst s + norm_num + Β· have hratio : (s+t)/(s+t) = (1 : ℝ) := div_self hst + have hratio' : (s+t)/(0+s+t) = (1 : ℝ) := by + convert hratio using 1 <;> ring + rw [hratio'] + norm_num + Β· by_cases hsz : s = 0 + Β· subst s + rw [anariRezaeiMergeGap] + by_cases hqr : q+r = 0 + Β· have hrzero : r = 0 := by linarith + exact (hrz hrzero).elim + Β· have hratio : (q+r)/(q+r) = (1 : ℝ) := div_self hqr + have hratio' : (q+r)/(q+r+0) = (1 : ℝ) := by + convert hratio using 1 <;> ring + rw [hratio'] + norm_num + Β· calc + anariRezaeiMergeGap q r s t ≀ + anariRezaeiMergeGap (anariRezaeiMergeQStar r s) r s + (anariRezaeiMergeTStar r s) := + anariRezaeiMergeGap_le_stationary hq0 + (lt_of_le_of_ne hr0 (Ne.symm hrz)) + (lt_of_le_of_ne hs0 (Ne.symm hsz)) ht0 hsum hC + _ = anariRezaeiMergePsi r s := + anariRezaeiMergeGap_stationary_eq hr0 hs0 hC + _ ≀ 0 := anariRezaeiMergePsi_nonpos hr0 hs0 hC + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceBetheLower.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceBetheLower.lean new file mode 100644 index 0000000000..f5073141c1 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceBetheLower.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.ClusterCertificate +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer + +/-! # Source Bethe Lower -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The lower half of the Bethe sandwich + +The stable-coefficient theorem contains Gurvits's Bethe lower bound as the +special case in which every row is a singleton cluster. This file makes that +reduction explicit. Once the stable-coefficient theorem is closed, there is +no separate Schrijver/Gurvits interface left in the development. +-/ + +/-- The clustering with one named singleton cluster for each row. -/ +noncomputable def singletonRowClustering (n : β„•) : RowClustering n where + Cluster := Fin n + clusterFintype := inferInstance + clusterDecidableEq := inferInstance + size := fun _ ↦ 1 + rows := Equiv.sigmaUnique (Fin n) (fun _ ↦ Fin 1) + +@[simp] theorem singletonRowClustering_size (n : β„•) + (i : (singletonRowClustering n).Cluster) : + (singletonRowClustering n).size i = 1 := rfl + +@[simp] theorem singletonRowClustering_rows (n : β„•) + (s : Ξ£ c : (singletonRowClustering n).Cluster, + Fin ((singletonRowClustering n).size c)) : + (singletonRowClustering n).rows s = s.1 := by + rfl + +theorem singletonRowClustering_singletonPairs (n : β„•) : + IsSingletonPairClustering (singletonRowClustering n) := by + intro i + exact Or.inl rfl + +@[simp] theorem singletonClusterRow_singletonRowClustering + {n : β„•} (i : Fin n) : + singletonClusterRow (singletonRowClustering n) i rfl = i := by + rfl + +theorem paperClusterFactor_singletonRowClustering + {n : β„•} (hn : 2 ≀ n) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) (hX : IsDoublyStochastic X) + (hXpos : βˆ€ i j, 0 < X i j) (i : Fin n) : + paperClusterFactor A X (singletonRowClustering n) + (singletonRowClustering_singletonPairs n) i = + singletonFactor A X i := by + unfold paperClusterFactor + rw [dif_pos (show (singletonRowClustering n).size i = 1 from rfl)] + rfl + +/-- Gurvits's pointwise Bethe lower certificate, obtained from the +stable-coefficient theorem with singleton clusters. -/ +theorem exp_betheObjective_le_permanent_of_stableCoefficient + {n : β„•} (hn : 2 ≀ n) + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + {A X : Matrix (Fin n) (Fin n) ℝ} + (hA : Matrix.Positive A) (hX : IsDoublyStochastic X) + (hXpos : βˆ€ i j, 0 < X i j) : + Real.exp (betheObjective A X) ≀ Matrix.permanent A := by + have hcert := pairedLowerCertificate_for_clustering stableCoefficient + (singletonRowClustering n) hn hA hX hXpos + (singletonRowClustering_singletonPairs n) + rw [← prod_singletonFactor_eq_exp_betheObjective] + calc + (∏ i, singletonFactor A X i) = + ∏ i, paperClusterFactor A X (singletonRowClustering n) + (singletonRowClustering_singletonPairs n) i := by + apply Finset.prod_congr rfl + intro i _ + exact (paperClusterFactor_singletonRowClustering hn hA hX hXpos i).symm + _ ≀ Matrix.permanent A := hcert + +/-- The lower half of the Bethe sandwich for positive matrices. -/ +theorem bethePermanent_le_permanent_of_positive + {n : β„•} (hn : 2 ≀ n) + (stableCoefficient : AnariOveisGharanStableCoefficient.{0}) + (A : Matrix (Fin n) (Fin n) ℝ) (hA : Matrix.Positive A) : + bethePermanent A ≀ Matrix.permanent A := by + have hper : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hlog : betheLogValue A ≀ Real.log (Matrix.permanent A) := by + apply le_of_forall_pos_le_add + intro Ξ΅ hΞ΅ + let C : ℝ := n * Real.log n + have hn1 : (1 : ℝ) ≀ n := by exact_mod_cast (show 1 ≀ n by omega) + have hC : 0 ≀ C := mul_nonneg (Nat.cast_nonneg n) + (Real.log_nonneg hn1) + let Ο„ : ℝ := Ξ΅ / (C + 1) + have hΟ„ : 0 < Ο„ := div_pos hΞ΅ (by linarith) + obtain ⟨X, hX, hmax⟩ := exists_regularizedBetheMaximizer Ο„ A + have hXpos := regularizedBetheMaximizer_positive + (show 1 < n by omega) hΟ„ hA hX hmax + have hvalue := betheLogValue_le_regularizedMaximizer + (show 1 < n by omega) hΟ„.le hA hX hmax + have hcert := exp_betheObjective_le_permanent_of_stableCoefficient + hn stableCoefficient hA hX hXpos + have hobjective : betheObjective A X ≀ + Real.log (Matrix.permanent A) := + (Real.le_log_iff_exp_le hper).mpr hcert + have hbudget : Ο„ * C ≀ Ξ΅ := by + dsimp only [Ο„] + rw [div_mul_eq_mul_div, div_le_iffβ‚€ (by linarith : 0 < C + 1)] + nlinarith + dsimp only [C] at hvalue hbudget + linarith + have hmatch : Matrix.HasPerfectMatching A := positiveMatrix_hasPerfectMatching hA + rw [bethePermanent, ite_eq_left hmatch] + have hexp := Real.exp_le_exp.mpr hlog + rwa [Real.exp_log hper] at hexp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceBetheUpper.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceBetheUpper.lean new file mode 100644 index 0000000000..79e39251b8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceBetheUpper.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Optimizer +public import LeanPool.BeyondBethe.BeyondBethe.SourceAnariRezaeiList + +/-! # Source Bethe Upper -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# The upper half of the Bethe sandwich + +For a positive matrix, the Gibbs distribution on perfect matchings has a +doubly stochastic marginal matrix `P`. The exact sequential identity writes +`log(per A)` as the Bethe objective at `P`, plus one correction per row, minus +a nonnegative averaged relative entropy. The sharp Anari--Rezaei row theorem +bounds every correction by `log 2 / 2`. This is the whole upper-bound proof. +-/ + +theorem sum_rowCorrection_le_log_two_half + {n : β„•} (hn : 2 ≀ n) {P : Matrix (Fin n) (Fin n) ℝ} + (hP : IsDoublyStochastic P) : + (βˆ‘ i, rowCorrection (P i)) ≀ n * (Real.log 2 / 2) := by + have hrow : βˆ€ i : Fin n, rowCorrection (P i) ≀ Real.log 2 / 2 := by + intro i + have hPi : IsProbabilityVector (P i) := + ⟨fun j ↦ hP.1 i j, hP.2.1 i⟩ + have hdeficit := anariRezaeiRowInequality hn (P i) hPi + rw [rowDeficit] at hdeficit + linarith + calc + (βˆ‘ i, rowCorrection (P i)) ≀ βˆ‘ _i : Fin n, Real.log 2 / 2 := + Finset.sum_le_sum fun i _ ↦ hrow i + _ = n * (Real.log 2 / 2) := by simp + +/-- Logarithmic upper Bethe bound for positive matrices of order at least two. -/ +theorem log_permanent_le_betheLogValue_add_log_two_half + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) ℝ) + (hA : Matrix.Positive A) : + Real.log (Matrix.permanent A) ≀ + betheLogValue A + n * (Real.log 2 / 2) := by + let P := assignmentMarginal A + have hper : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hP : IsDoublyStochastic P := + assignmentMarginal_doublyStochastic A (fun i j ↦ (hA i j).le) hper.ne' + have hobjective : betheObjective A P ≀ betheLogValue A := + betheObjective_le_betheLogValue_of_positive hA hP + have hrows : (βˆ‘ i, rowCorrection (P i)) ≀ + n * (Real.log 2 / 2) := sum_rowCorrection_le_log_two_half hn hP + have hdiv : 0 ≀ gibbsSequentialDivergence A := + gibbsSequentialDivergence_nonneg A hA + have hexact := gibbs_exact_sequential_identity A hA + dsimp only [P] at hP hobjective hrows hexact + linarith + +/-- The upper half of the Bethe sandwich for positive matrices. -/ +theorem permanent_le_sqrtTwo_pow_mul_bethePermanent_of_positive + {n : β„•} (hn : 2 ≀ n) (A : Matrix (Fin n) (Fin n) ℝ) + (hA : Matrix.Positive A) : + Matrix.permanent A ≀ + (Real.sqrt 2) ^ n * bethePermanent A := by + have hmatch : Matrix.HasPerfectMatching A := positiveMatrix_hasPerfectMatching hA + have hper : 0 < Matrix.permanent A := permanent_pos_of_positive A hA + have hlog := log_permanent_le_betheLogValue_add_log_two_half hn A hA + have hexp := Real.exp_le_exp.mpr hlog + rw [Real.exp_log hper, Real.exp_add] at hexp + have hsqrt : 0 < Real.sqrt 2 := Real.sqrt_pos.2 (by norm_num) + have hfactor : Real.exp (n * (Real.log 2 / 2)) = + (Real.sqrt 2) ^ n := by + rw [Real.exp_nat_mul] + congr 1 + rw [← Real.exp_log hsqrt, Real.log_sqrt (by norm_num : (0 : ℝ) ≀ 2)] + have hbethe : bethePermanent A = Real.exp (betheLogValue A) := by + rw [bethePermanent, ite_eq_left hmatch] + rw [hfactor, ← hbethe] at hexp + simpa [mul_comm] using hexp + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableBivariate.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableBivariate.lean new file mode 100644 index 0000000000..8f9240e5c8 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableBivariate.lean @@ -0,0 +1,385 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import Mathlib.Analysis.Complex.Basic +public import Mathlib.Analysis.MeanInequalities +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Tactic + +/-! # Source Stable Bivariate -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The bivariate core of the stable-coefficient inequality + +After all other variables have been specialized to positive real numbers, a +multiaffine bistable polynomial has the form + +`a*y*z + b*y + c*z + d`. + +Stability of the sign-reversed polynomial forces `b*c ≀ a*d`. The short +argument below is the elementary two-variable content behind the Rayleigh +inequality used in Anari--Oveis Gharan. +-/ + +/-- A nonnegative bivariate multiaffine polynomial is bistable when its +sign-reversal in the second variable has no zero with both variables in the +open upper half-plane. -/ +def BivariateBistable (a b c d : ℝ) : Prop := + βˆ€ y z : β„‚, 0 < y.im β†’ 0 < z.im β†’ + -(a : β„‚) * y * z + (b : β„‚) * y - (c : β„‚) * z + (d : β„‚) β‰  0 + +/-- The bivariate Rayleigh determinant inequality, proved directly by +exhibiting an upper-half-plane zero if `a*d < b*c`. -/ +theorem bivariate_rayleigh_of_bistable + {a b c d : ℝ} + (ha : 0 ≀ a) (hb : 0 ≀ b) (hc : 0 ≀ c) (hd : 0 ≀ d) + (hstable : BivariateBistable a b c d) : + b * c ≀ a * d := by + by_contra hnot + have hgap : a * d < b * c := lt_of_not_ge hnot + have hbpos : 0 < b := by + by_contra hbnot + have hbzero : b = 0 := le_antisymm (le_of_not_gt hbnot) hb + rw [hbzero, zero_mul] at hgap + exact (not_lt_of_ge (mul_nonneg ha hd)) hgap + have hcpos : 0 < c := by + by_contra hcnot + have hczero : c = 0 := le_antisymm (le_of_not_gt hcnot) hc + rw [hczero, mul_zero] at hgap + exact (not_lt_of_ge (mul_nonneg ha hd)) hgap + let y : β„‚ := Complex.I + let z : β„‚ := ((d : β„‚) + (b : β„‚) * Complex.I) / + ((c : β„‚) + (a : β„‚) * Complex.I) + have hden : (c : β„‚) + (a : β„‚) * Complex.I β‰  0 := by + intro hzero + have hre := congrArg Complex.re hzero + simp at hre + exact hcpos.ne' hre + have hyim : 0 < y.im := by simp [y] + have hzim_formula : z.im = (b * c - a * d) / (c ^ 2 + a ^ 2) := by + dsimp only [z] + rw [Complex.div_im] + simp only [Complex.add_re, Complex.ofReal_re, Complex.mul_re, + Complex.I_re, Complex.I_im, mul_zero, Complex.add_im, + Complex.ofReal_im, zero_add, Complex.mul_im, zero_mul, mul_one, + add_zero, Complex.normSq_apply] + congr 1 <;> ring + have hdenpos : 0 < c ^ 2 + a ^ 2 := by positivity + have hzim : 0 < z.im := by + rw [hzim_formula] + exact div_pos (sub_pos.mpr hgap) hdenpos + have hzero : + -(a : β„‚) * y * z + (b : β„‚) * y - (c : β„‚) * z + (d : β„‚) = 0 := by + dsimp only [y, z] + field_simp [hden] + ring + exact (hstable y z hyim hzim) hzero + +/-! ## The scalar capacity inequality -/ + +/-- The boundary factor `Ξ±^Ξ± * (1 - Ξ±)^(1 - Ξ±)` with real exponents. -/ +noncomputable def stableBoundaryScalar (Ξ± : ℝ) : ℝ := + (Ξ± : ℝ) ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±) + +/-- The weighted AM--GM inequality in the normalization used by the source +proof. -/ +theorem normalized_weighted_geometric_mean_le_add + {Ξ± u v : ℝ} (hΞ±0 : 0 < Ξ±) (hΞ±1 : Ξ± < 1) + (hu : 0 ≀ u) (hv : 0 ≀ v) : + u ^ Ξ± * v ^ (1 - Ξ±) ≀ stableBoundaryScalar Ξ± * (u + v) := by + have hΞ± : 0 ≀ Ξ± := hΞ±0.le + have h1Ξ± : 0 ≀ 1 - Ξ± := sub_nonneg.mpr hΞ±1.le + have hamgm := Real.geom_mean_le_arith_mean2_weighted + hΞ± h1Ξ± (div_nonneg hu hΞ±) (div_nonneg hv h1Ξ±) (by ring) + rw [stableBoundaryScalar] + have hboundary : 0 < Ξ± ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±) := + mul_pos (Real.rpow_pos_of_pos hΞ±0 Ξ±) + (Real.rpow_pos_of_pos (sub_pos.mpr hΞ±1) (1 - Ξ±)) + have hscaled := mul_le_mul_of_nonneg_left hamgm hboundary.le + calc + u ^ Ξ± * v ^ (1 - Ξ±) = + (Ξ± ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±)) * + ((u / Ξ±) ^ Ξ± * (v / (1 - Ξ±)) ^ (1 - Ξ±)) := by + rw [Real.div_rpow hu hΞ±, Real.div_rpow hv h1Ξ±] + field_simp [hΞ±0.ne', (sub_pos.mpr hΞ±1).ne'] + _ ≀ (Ξ± ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±)) * + (Ξ± * (u / Ξ±) + (1 - Ξ±) * (v / (1 - Ξ±))) := hscaled + _ = (Ξ± ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±)) * (u + v) := by + field_simp [hΞ±0.ne', (sub_pos.mpr hΞ±1).ne'] + +/-- The candidate minimizing point `Ξ± * v / ((1 - Ξ±) * u)` for the linear capacity calculation. -/ +noncomputable def linearCapacityCandidate (Ξ± u v : ℝ) : ℝ := + Ξ± * v / ((1 - Ξ±) * u) + +theorem linearCapacityCandidate_pos + {Ξ± u v : ℝ} (hΞ±0 : 0 < Ξ±) (hΞ±1 : Ξ± < 1) + (hu : 0 < u) (hv : 0 < v) : + 0 < linearCapacityCandidate Ξ± u v := by + exact div_pos (mul_pos hΞ±0 hv) (mul_pos (sub_pos.mpr hΞ±1) hu) + +/-- Evaluation of a positive affine linear form at its weighted-AM--GM +minimizer. -/ +theorem linearCapacityCandidate_ratio + {Ξ± u v : ℝ} (hΞ±0 : 0 < Ξ±) (hΞ±1 : Ξ± < 1) + (hu : 0 < u) (hv : 0 < v) : + (u * linearCapacityCandidate Ξ± u v + v) / + (linearCapacityCandidate Ξ± u v) ^ Ξ± = + u ^ Ξ± * v ^ (1 - Ξ±) / stableBoundaryScalar Ξ± := by + have h1Ξ± : 0 < 1 - Ξ± := sub_pos.mpr hΞ±1 + have ht : 0 < linearCapacityCandidate Ξ± u v := + linearCapacityCandidate_pos hΞ±0 hΞ±1 hu hv + have hnum : u * linearCapacityCandidate Ξ± u v + v = v / (1 - Ξ±) := by + rw [linearCapacityCandidate] + field_simp [hu.ne', h1Ξ±.ne'] + ring + rw [hnum, linearCapacityCandidate, stableBoundaryScalar] + rw [Real.div_rpow (mul_nonneg hΞ±0.le hv.le) + (mul_nonneg h1Ξ±.le hu.le), + Real.mul_rpow hΞ±0.le hv.le, + Real.mul_rpow h1Ξ±.le hu.le] + field_simp [hΞ±0.ne', h1Ξ±.ne', hu.ne', hv.ne', + (Real.rpow_pos_of_pos hΞ±0 Ξ±).ne', + (Real.rpow_pos_of_pos h1Ξ± (1 - Ξ±)).ne', + (Real.rpow_pos_of_pos hu Ξ±).ne', + (Real.rpow_pos_of_pos hv Ξ±).ne'] + have hsum : Ξ± + (1 - Ξ±) = 1 := by ring + calc + v * (1 - Ξ±) ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±) = + v * ((1 - Ξ±) ^ Ξ± * (1 - Ξ±) ^ (1 - Ξ±)) := by ring + _ = v * (1 - Ξ±) := by + rw [← Real.rpow_add h1Ξ±, hsum, Real.rpow_one] + _ = (1 - Ξ±) * v := by ring + _ = (1 - Ξ±) * (v ^ Ξ± * v ^ (1 - Ξ±)) := by + rw [← Real.rpow_add hv, hsum, Real.rpow_one] + _ = (1 - Ξ±) * v ^ Ξ± * v ^ (1 - Ξ±) := by ring + +/-- The exact bivariate capacity step used by the inductive +stable-coefficient proof, in the strictly positive interior case. -/ +theorem exists_bivariate_capacity_witness + {Ξ± a b c d : ℝ} (hΞ±0 : 0 < Ξ±) (hΞ±1 : Ξ± < 1) + (ha : 0 < a) (hb : 0 ≀ b) (hc : 0 < c) (hd : 0 < d) + (hrayleigh : b * c ≀ a * d) : + βˆƒ y z : ℝ, 0 < y ∧ 0 < z ∧ + stableBoundaryScalar Ξ± * + ((a * y * z + b * y + c * z + d) / (y * z) ^ Ξ±) ≀ + a + d := by + let y := linearCapacityCandidate Ξ± a c + let z := linearCapacityCandidate Ξ± 1 (d / c) + have hdc : 0 < d / c := div_pos hd hc + have hy : 0 < y := linearCapacityCandidate_pos hΞ±0 hΞ±1 ha hc + have hz : 0 < z := linearCapacityCandidate_pos hΞ±0 hΞ±1 (by norm_num) hdc + have hb' : b ≀ a * d / c := by + rw [le_div_iffβ‚€ hc] + nlinarith + have hpoly : a * y * z + b * y + c * z + d ≀ + (a * y + c) * (z + d / c) := by + have := mul_le_mul_of_nonneg_right hb' hy.le + field_simp [hc.ne'] at this ⊒ + nlinarith + have hden : 0 < (y * z) ^ Ξ± := + Real.rpow_pos_of_pos (mul_pos hy hz) Ξ± + have hboundary : 0 < stableBoundaryScalar Ξ± := by + rw [stableBoundaryScalar] + exact mul_pos (Real.rpow_pos_of_pos hΞ±0 Ξ±) + (Real.rpow_pos_of_pos (sub_pos.mpr hΞ±1) (1 - Ξ±)) + have hratio := div_le_div_of_nonneg_right hpoly hden.le + have hscaled := mul_le_mul_of_nonneg_left hratio hboundary.le + have hfactor : + ((a * y + c) * (z + d / c)) / (y * z) ^ Ξ± = + ((a * y + c) / y ^ Ξ±) * ((z + d / c) / z ^ Ξ±) := by + rw [Real.mul_rpow hy.le hz.le] + field_simp [(Real.rpow_pos_of_pos hy Ξ±).ne', + (Real.rpow_pos_of_pos hz Ξ±).ne'] + have hyvalue : (a * y + c) / y ^ Ξ± = + a ^ Ξ± * c ^ (1 - Ξ±) / stableBoundaryScalar Ξ± := by + exact linearCapacityCandidate_ratio hΞ±0 hΞ±1 ha hc + have hzvalue : (z + d / c) / z ^ Ξ± = + (d / c) ^ (1 - Ξ±) / stableBoundaryScalar Ξ± := by + simpa using linearCapacityCandidate_ratio hΞ±0 hΞ±1 + (by norm_num : (0 : ℝ) < 1) hdc + have hcollapse : + stableBoundaryScalar Ξ± * + ((a ^ Ξ± * c ^ (1 - Ξ±) / stableBoundaryScalar Ξ±) * + ((d / c) ^ (1 - Ξ±) / stableBoundaryScalar Ξ±)) = + a ^ Ξ± * d ^ (1 - Ξ±) / stableBoundaryScalar Ξ± := by + rw [Real.div_rpow hd.le hc.le] + have hcPow : 0 < c ^ (1 - Ξ±) := Real.rpow_pos_of_pos hc _ + field_simp [hboundary.ne', hcPow.ne'] + have hamgm := normalized_weighted_geometric_mean_le_add + hΞ±0 hΞ±1 ha.le hd.le + have hfinal : + a ^ Ξ± * d ^ (1 - Ξ±) / stableBoundaryScalar Ξ± ≀ a + d := by + exact (div_le_iffβ‚€ hboundary).mpr (by simpa [mul_comm] using hamgm) + refine ⟨y, z, hy, hz, ?_⟩ + calc + stableBoundaryScalar Ξ± * + ((a * y * z + b * y + c * z + d) / (y * z) ^ Ξ±) ≀ + stableBoundaryScalar Ξ± * + (((a * y + c) * (z + d / c)) / (y * z) ^ Ξ±) := hscaled + _ = stableBoundaryScalar Ξ± * + (((a * y + c) / y ^ Ξ±) * ((z + d / c) / z ^ Ξ±)) := by + rw [hfactor] + _ = stableBoundaryScalar Ξ± * + ((a ^ Ξ± * c ^ (1 - Ξ±) / stableBoundaryScalar Ξ±) * + ((d / c) ^ (1 - Ξ±) / stableBoundaryScalar Ξ±)) := by + rw [hyvalue, hzvalue] + _ = a ^ Ξ± * d ^ (1 - Ξ±) / stableBoundaryScalar Ξ± := hcollapse + _ ≀ a + d := hfinal + +/-- The strictly positive scalar lemma is sufficient after an arbitrarily +small coefficient regularization. This is the version needed by the source +induction: no coefficient is assumed positive, and the conclusion loses only +an arbitrary additive `Ξ΅`. -/ +theorem exists_bivariate_capacity_witness_nonnegative_interior + {Ξ± a b c d Ξ΅ : ℝ} (hΞ±0 : 0 < Ξ±) (hΞ±1 : Ξ± < 1) + (ha : 0 ≀ a) (hb : 0 ≀ b) (hc : 0 ≀ c) (hd : 0 ≀ d) + (hrayleigh : b * c ≀ a * d) (hΞ΅ : 0 < Ξ΅) : + βˆƒ y z : ℝ, 0 < y ∧ 0 < z ∧ + stableBoundaryScalar Ξ± * + ((a * y * z + b * y + c * z + d) / (y * z) ^ Ξ±) ≀ + a + d + Ξ΅ := by + let Ξ΄ : ℝ := Ξ΅ / 4 + let c' : ℝ := c + Ξ΄ ^ 2 / (b + 1) + have hΞ΄ : 0 < Ξ΄ := by dsimp [Ξ΄]; positivity + have hb1 : 0 < b + 1 := by linarith + have hc' : 0 < c' := by + dsimp [c'] + exact add_pos_of_nonneg_of_pos hc (div_pos (sq_pos_of_pos hΞ΄) hb1) + have hrayleigh' : b * c' ≀ (a + Ξ΄) * (d + Ξ΄) := by + have hfrac : b * (Ξ΄ ^ 2 / (b + 1)) ≀ Ξ΄ ^ 2 := by + rw [← mul_div_assoc] + apply (div_le_iffβ‚€ hb1).2 + nlinarith + dsimp only [c'] + nlinarith [mul_nonneg ha hΞ΄.le, mul_nonneg hd hΞ΄.le] + obtain ⟨y, z, hy, hz, hwitness⟩ := + exists_bivariate_capacity_witness hΞ±0 hΞ±1 + (add_pos_of_nonneg_of_pos ha hΞ΄) + hb hc' (add_pos_of_nonneg_of_pos hd hΞ΄) hrayleigh' + have hden : 0 < (y * z) ^ Ξ± := + Real.rpow_pos_of_pos (mul_pos hy hz) Ξ± + have hpoly : + a * y * z + b * y + c * z + d ≀ + (a + Ξ΄) * y * z + b * y + c' * z + (d + Ξ΄) := by + have hcc' : c ≀ c' := by + dsimp [c'] + exact le_add_of_nonneg_right (div_nonneg (sq_nonneg Ξ΄) hb1.le) + nlinarith [mul_nonneg hy.le hz.le, + mul_le_mul_of_nonneg_right hcc' hz.le] + have hboundary : 0 ≀ stableBoundaryScalar Ξ± := by + rw [stableBoundaryScalar] + positivity + refine ⟨y, z, hy, hz, ?_⟩ + calc + stableBoundaryScalar Ξ± * + ((a * y * z + b * y + c * z + d) / (y * z) ^ Ξ±) ≀ + stableBoundaryScalar Ξ± * + (((a + Ξ΄) * y * z + b * y + c' * z + (d + Ξ΄)) / + (y * z) ^ Ξ±) := by + exact mul_le_mul_of_nonneg_left + (div_le_div_of_nonneg_right hpoly hden.le) hboundary + _ ≀ (a + Ξ΄) + (d + Ξ΄) := hwitness + _ ≀ a + d + Ξ΅ := by dsimp [Ξ΄]; linarith + +/-- The endpoint `Ξ± = 0`: send both variables to zero. -/ +theorem exists_bivariate_capacity_witness_zero + {a b c d Ξ΅ : ℝ} + (ha : 0 ≀ a) (hb : 0 ≀ b) (hc : 0 ≀ c) (hd : 0 ≀ d) + (hΞ΅ : 0 < Ξ΅) : + βˆƒ y z : ℝ, 0 < y ∧ 0 < z ∧ + stableBoundaryScalar 0 * + ((a * y * z + b * y + c * z + d) / (y * z) ^ (0 : ℝ)) ≀ + a + d + Ξ΅ := by + let s : ℝ := a + b + c + 1 + let t : ℝ := Ξ΅ / ((Ξ΅ + 1) * s) + have hs : 0 < s := by dsimp [s]; linarith + have hΞ΅1 : 0 < Ξ΅ + 1 := by linarith + have ht : 0 < t := by dsimp [t]; positivity + have ht1 : t ≀ 1 := by + dsimp [t] + rw [div_le_one (mul_pos hΞ΅1 hs)] + have hs1 : 1 ≀ s := by dsimp [s]; linarith + nlinarith [mul_nonneg hΞ΅.le hs.le] + have hsmall : (a + b + c) * t < Ξ΅ := by + dsimp [t] + rw [← mul_div_assoc] + apply (div_lt_iffβ‚€ (mul_pos hΞ΅1 hs)).2 + have hsum : a + b + c < s := by dsimp [s]; linarith + have hs_scaled : s ≀ (Ξ΅ + 1) * s := by + nlinarith [mul_nonneg hΞ΅.le hs.le] + simpa [mul_comm] using + (mul_lt_mul_of_pos_left (hsum.trans_le hs_scaled) hΞ΅) + refine ⟨t, t, ht, ht, ?_⟩ + rw [stableBoundaryScalar] + norm_num + have hatt : a * t * t ≀ a * t := by + nlinarith [mul_nonneg ha ht.le] + nlinarith + +/-- The endpoint `Ξ± = 1`: send both variables to infinity. -/ +theorem exists_bivariate_capacity_witness_one + {a b c d Ξ΅ : ℝ} + (ha : 0 ≀ a) (hb : 0 ≀ b) (hc : 0 ≀ c) (hd : 0 ≀ d) + (hΞ΅ : 0 < Ξ΅) : + βˆƒ y z : ℝ, 0 < y ∧ 0 < z ∧ + stableBoundaryScalar 1 * + ((a * y * z + b * y + c * z + d) / (y * z) ^ (1 : ℝ)) ≀ + a + d + Ξ΅ := by + let s : ℝ := b + c + d + 1 + let t : ℝ := (Ξ΅ + 1) * s / Ξ΅ + have hs : 0 < s := by dsimp [s]; linarith + have hΞ΅1 : 0 < Ξ΅ + 1 := by linarith + have ht : 0 < t := by dsimp [t]; positivity + have ht1 : 1 ≀ t := by + dsimp [t] + rw [le_div_iffβ‚€ hΞ΅] + have hs1 : 1 ≀ s := by dsimp [s]; linarith + nlinarith [mul_nonneg hΞ΅.le hs.le] + have hsmall : (b + c + d) / t < Ξ΅ := by + rw [div_lt_iffβ‚€ ht] + dsimp [t] + have hsum : b + c + d < s := by dsimp [s]; linarith + have hs_scaled : s ≀ (Ξ΅ + 1) * s := by + nlinarith [mul_nonneg hΞ΅.le hs.le] + have hcancel : Ξ΅ * ((Ξ΅ + 1) * s / Ξ΅) = (Ξ΅ + 1) * s := by + field_simp [hΞ΅.ne'] + rw [hcancel] + exact hsum.trans_le hs_scaled + refine ⟨t, t, ht, ht, ?_⟩ + rw [stableBoundaryScalar] + norm_num [Real.rpow_one] + field_simp [ht.ne'] + have hdt : d ≀ d * t := by nlinarith [mul_nonneg hd (sub_nonneg.mpr ht1)] + have hsmall' : (b + c + d) * t < Ξ΅ * t ^ 2 := by + rw [div_lt_iffβ‚€ ht] at hsmall + nlinarith + nlinarith + +/-- Complete bivariate scalar step, including both boundary exponents. -/ +theorem exists_bivariate_capacity_witness_nonnegative + {Ξ± a b c d Ξ΅ : ℝ} + (hΞ± : 0 ≀ Ξ± ∧ Ξ± ≀ 1) + (ha : 0 ≀ a) (hb : 0 ≀ b) (hc : 0 ≀ c) (hd : 0 ≀ d) + (hrayleigh : b * c ≀ a * d) (hΞ΅ : 0 < Ξ΅) : + βˆƒ y z : ℝ, 0 < y ∧ 0 < z ∧ + stableBoundaryScalar Ξ± * + ((a * y * z + b * y + c * z + d) / (y * z) ^ Ξ±) ≀ + a + d + Ξ΅ := by + rcases hΞ± with ⟨hΞ±0, hΞ±1⟩ + rcases eq_or_lt_of_le hΞ±0 with rfl | hΞ±pos + Β· exact exists_bivariate_capacity_witness_zero ha hb hc hd hΞ΅ + rcases eq_or_lt_of_le hΞ±1 with rfl | hΞ±lt + Β· exact exists_bivariate_capacity_witness_one ha hb hc hd hΞ΅ + exact exists_bivariate_capacity_witness_nonnegative_interior + hΞ±pos hΞ±lt ha hb hc hd hrayleigh hΞ΅ + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableClosure.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableClosure.lean new file mode 100644 index 0000000000..788cc51eb9 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableClosure.lean @@ -0,0 +1,733 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Stable +public import Mathlib.Analysis.Complex.JensenFormula +public import Mathlib.Analysis.Analytic.Polynomial +public import Mathlib.Algebra.Polynomial.Roots +public import Mathlib.Algebra.MvPolynomial.Funext +public import Mathlib.Algebra.Polynomial.Degree.SmallDegree +public import Mathlib.Tactic + +/-! # Source Stable Closure -/ + +@[expose] public section + +open Filter MeasureTheory Metric Real Set + +namespace BeyondBethe + +/-! +# Closure of the stable cone + +The source proof uses two limiting operations on stable polynomials: taking a +coefficient in a multiaffine variable and specializing a variable to the real +boundary. In the source literature these facts are usually folded into the +statement that stability preservers may output the zero polynomial. + +This file starts from the one-variable analytic fact needed to justify those +limits. We prove it from the isolated-zero theorem, compactness of a circle, +and the mean-value identity for the logarithm of a nonvanishing analytic +function. Thus no version of Hurwitz's theorem is introduced as an axiom. +-/ + +/-- A linear perturbation of a nonzero polynomial cannot be zero-free on a +fixed disk for every positive perturbation size if the limiting polynomial +vanishes at the center. This is the precise one-variable Hurwitz principle +needed below. -/ +theorem polynomial_linear_perturbation_has_nearby_zero + (A B : Polynomial β„‚) (R : ℝ) + (hA : A β‰  0) (hR : 0 < R) (hA0 : A.eval 0 = 0) : + βˆƒ t : ℝ, 0 < t ∧ βˆƒ z ∈ closedBall (0 : β„‚) R, + (A + Polynomial.C (t : β„‚) * B).eval z = 0 := by + have hAanalytic : AnalyticOnNhd β„‚ (fun z : β„‚ ↦ A.eval z) Set.univ := by + exact AnalyticOnNhd.eval_polynomial A + have hpunctured : + βˆ€αΆ  z in nhdsWithin (0 : β„‚) ({0} : Set β„‚)ᢜ, A.eval z β‰  0 := by + rcases (hAanalytic 0 (Set.mem_univ 0)).eventually_eq_zero_or_eventually_ne_zero with + hlocal | hlocal + Β· have hzero : Set.EqOn (fun z : β„‚ ↦ A.eval z) 0 Set.univ := + hAanalytic.eqOn_zero_of_preconnected_of_eventuallyEq_zero + isPreconnected_univ (Set.mem_univ 0) (by + filter_upwards [hlocal] with z hz + simpa using hz) + exfalso + apply hA + apply Polynomial.zero_of_eval_zero + intro z + simpa using hzero (Set.mem_univ z) + Β· exact hlocal + obtain ⟨δ, hΞ΄, hΞ΄sub⟩ := Metric.mem_nhdsWithin_iff.mp hpunctured + let r : ℝ := min (Ξ΄ / 2) (R / 2) + have hr : 0 < r := by + dsimp [r] + positivity + have hrΞ΄ : r < Ξ΄ := by + dsimp [r] + exact lt_of_le_of_lt (min_le_left _ _) (half_lt_self hΞ΄) + have hrR : r < R := by + dsimp [r] + exact lt_of_le_of_lt (min_le_right _ _) (half_lt_self hR) + have hsphereA : βˆ€ z ∈ sphere (0 : β„‚) r, A.eval z β‰  0 := by + intro z hz + apply hΞ΄sub + constructor + Β· rw [mem_sphere, dist_zero_right] at hz + rw [mem_ball, dist_zero_right, hz] + exact hrΞ΄ + Β· rw [Set.mem_compl_iff, Set.mem_singleton_iff] + intro hz0 + subst z + have : (0 : ℝ) = r := by simpa [mem_sphere] using hz + exact hr.ne' this.symm + have hsphere_nonempty : (sphere (0 : β„‚) r).Nonempty := + NormedSpace.sphere_nonempty.mpr hr.le + obtain ⟨u, hu, humin⟩ := + (isCompact_sphere (0 : β„‚) r).exists_isMinOn hsphere_nonempty + (A.continuous.norm.continuousOn) + let m : ℝ := β€–A.eval uβ€– + have hm : 0 < m := by + dsimp [m] + exact norm_pos_iff.mpr (hsphereA u hu) + have hm_lower : βˆ€ z ∈ sphere (0 : β„‚) r, m ≀ β€–A.eval zβ€– := by + intro z hz + exact humin hz + obtain ⟨v, hv, hvmax⟩ := + (isCompact_sphere (0 : β„‚) r).exists_isMaxOn hsphere_nonempty + (B.continuous.norm.continuousOn) + let M : ℝ := max β€–B.eval vβ€– β€–B.eval 0β€– + have hM0 : 0 ≀ M := by + dsimp [M] + positivity + have hM_sphere : βˆ€ z ∈ sphere (0 : β„‚) r, β€–B.eval zβ€– ≀ M := by + intro z hz + exact (hvmax hz).trans (le_max_left _ _) + have hM_center : β€–B.eval 0β€– ≀ M := by + exact le_max_right _ _ + let t : ℝ := m / (4 * (M + 1)) + have ht : 0 < t := by + dsimp [t] + positivity + let F : Polynomial β„‚ := A + Polynomial.C (t : β„‚) * B + by_contra hno + push_neg at hno + have hFzeroFree : βˆ€ z ∈ closedBall (0 : β„‚) r, F.eval z β‰  0 := by + intro z hz + exact hno t ht z (closedBall_subset_closedBall hrR.le hz) + have hFanalytic : AnalyticOnNhd β„‚ (fun z : β„‚ ↦ F.eval z) + (closedBall (0 : β„‚) r) := by + exact (AnalyticOnNhd.eval_polynomial F).mono (Set.subset_univ _) + have hmean : + circleAverage (fun z : β„‚ ↦ Real.log β€–F.eval zβ€–) 0 r = + Real.log β€–F.eval 0β€– := by + apply AnalyticOnNhd.circleAverage_log_norm_of_ne_zero + (R := r) (c := (0 : β„‚)) (g := fun z : β„‚ ↦ F.eval z) + Β· simpa [abs_of_pos hr] using hFanalytic + Β· simpa [abs_of_pos hr] using hFzeroFree + have hperturb_sphere : βˆ€ z ∈ sphere (0 : β„‚) r, + β€–((t : β„‚) * B.eval z)β€– < m / 2 := by + intro z hz + calc + β€–((t : β„‚) * B.eval z)β€– = t * β€–B.eval zβ€– := by + simp [norm_mul, Real.norm_eq_abs, abs_of_pos ht] + _ ≀ t * M := mul_le_mul_of_nonneg_left (hM_sphere z hz) ht.le + _ < m / 2 := by + dsimp [t] + have hden : 0 < 4 * (M + 1) := by positivity + rw [div_mul_eq_mul_div, div_lt_iffβ‚€ hden, div_mul_eq_mul_div] + nlinarith + have hF_lower : βˆ€ z ∈ sphere (0 : β„‚) r, m / 2 < β€–F.eval zβ€– := by + intro z hz + have htriangle : β€–A.eval zβ€– ≀ + β€–F.eval zβ€– + β€–((t : β„‚) * B.eval z)β€– := by + have heval : F.eval z = A.eval z + (t : β„‚) * B.eval z := by + simp [F] + rw [heval] + simpa [add_assoc] using norm_sub_le (A.eval z + (t : β„‚) * B.eval z) + ((t : β„‚) * B.eval z) + linarith [hm_lower z hz, hperturb_sphere z hz] + have hlog_lower : βˆ€ z ∈ sphere (0 : β„‚) r, + Real.log (m / 2) ≀ Real.log β€–F.eval zβ€– := by + intro z hz + exact Real.strictMonoOn_log.monotoneOn + (half_pos hm) (norm_pos_iff.mpr (hFzeroFree z (sphere_subset_closedBall hz))) + (hF_lower z hz).le + have havg_lower : Real.log (m / 2) ≀ + circleAverage (fun z : β„‚ ↦ Real.log β€–F.eval zβ€–) 0 r := by + rw [← circleAverage_const (Real.log (m / 2)) (0 : β„‚) r] + apply circleAverage_mono + Β· exact circleIntegrable_const _ _ _ + Β· have hmer : MeromorphicOn (fun z : β„‚ ↦ F.eval z) + (sphere (0 : β„‚) |r|) := by + simpa [abs_of_pos hr] using + (hFanalytic.mono sphere_subset_closedBall).meromorphicOn + exact hmer.circleIntegrable_log_norm + Β· simpa [abs_of_pos hr] using hlog_lower + have hF0 : F.eval 0 = (t : β„‚) * B.eval 0 := by + simp [F, hA0] + have hcenter_norm : β€–F.eval 0β€– < m / 2 := by + rw [hF0] + simp only [norm_mul] + rw [show β€–(t : β„‚)β€– = t by simp [Real.norm_eq_abs, abs_of_pos ht]] + calc + t * β€–B.eval 0β€– ≀ t * M := mul_le_mul_of_nonneg_left hM_center ht.le + _ < m / 2 := by + dsimp [t] + have hden : 0 < 4 * (M + 1) := by positivity + rw [div_mul_eq_mul_div, div_lt_iffβ‚€ hden, div_mul_eq_mul_div] + nlinarith + have hlog_center : Real.log β€–F.eval 0β€– < Real.log (m / 2) := by + exact Real.strictMonoOn_log + (norm_pos_iff.mpr (hFzeroFree 0 (by simp [hr.le]))) (half_pos hm) hcenter_norm + rw [hmean] at havg_lower + exact (not_lt_of_ge havg_lower) hlog_center + +/-! ## The multivariate closure lemma -/ + +/-- Complex-coefficient stability in the product of open upper half-planes. -/ +def IsUpperHalfPlaneStable + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) : Prop := + βˆ€ z : Οƒ β†’ β„‚, (βˆ€ i, 0 < (z i).im) β†’ p.eval z β‰  0 + +/-- Restrict a multivariate polynomial to the affine complex line `z + s v`. -/ +noncomputable def affineLinePolynomial + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) (z v : Οƒ β†’ β„‚) : Polynomial β„‚ := + p.evalβ‚‚ Polynomial.C (fun i ↦ Polynomial.C (z i) + Polynomial.C (v i) * Polynomial.X) + +@[simp] +theorem affineLinePolynomial_eval + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) (z v : Οƒ β†’ β„‚) (s : β„‚) : + (affineLinePolynomial p z v).eval s = p.eval (fun i ↦ z i + s * v i) := by + rw [affineLinePolynomial, MvPolynomial.polynomial_eval_evalβ‚‚] + simp only [Polynomial.eval_add, Polynomial.eval_C, Polynomial.eval_mul, + Polynomial.eval_X] + have hring : (Polynomial.evalRingHom s).comp Polynomial.C = RingHom.id β„‚ := by + ext x + simp + rw [hring, MvPolynomial.evalβ‚‚_id] + apply MvPolynomial.evalβ‚‚_congr + intro i c hi hc + ring + +theorem exists_eval_ne_zero_of_mvPolynomial_ne_zero + {Οƒ : Type*} {p : MvPolynomial Οƒ β„‚} (hp : p β‰  0) : + βˆƒ z : Οƒ β†’ β„‚, p.eval z β‰  0 := by + by_contra h + push Not at h + apply hp + apply MvPolynomial.funext + intro z + simpa using h z + +/-- The limit, along a positive real ray, of stable multivariate polynomials +is stable or identically zero. This is the finite-dimensional form of +Hurwitz closure used in the preservation argument. -/ +theorem upperHalfPlaneStableOrZero_of_positive_ray + {Οƒ : Type*} [Fintype Οƒ] + (p q : MvPolynomial Οƒ β„‚) + (hstable : βˆ€ t : ℝ, 0 < t β†’ + IsUpperHalfPlaneStable (p + MvPolynomial.C (t : β„‚) * q)) : + p = 0 ∨ IsUpperHalfPlaneStable p := by + by_cases hp : p = 0 + Β· exact Or.inl hp + right + intro z hz + intro hpz + obtain ⟨w, hw⟩ := exists_eval_ne_zero_of_mvPolynomial_ne_zero hp + let v : Οƒ β†’ β„‚ := fun i ↦ w i - z i + let A : Polynomial β„‚ := affineLinePolynomial p z v + let B : Polynomial β„‚ := affineLinePolynomial q z v + have hA0 : A.eval 0 = 0 := by + simp [A, v, hpz] + have hA1 : A.eval 1 = p.eval w := by + simp [A, v] + have hA : A β‰  0 := by + intro hzero + have := congrArg (fun P : Polynomial β„‚ ↦ P.eval 1) hzero + simp [hA1, hw] at this + have hnear : + {s : β„‚ | βˆ€ i, 0 < (z i + s * v i).im} ∈ nhds (0 : β„‚) := by + change βˆ€αΆ  s in nhds (0 : β„‚), βˆ€ i, 0 < (z i + s * v i).im + rw [Filter.eventually_all] + intro i + have hcont : ContinuousAt (fun s : β„‚ ↦ (z i + s * v i).im) 0 := by + fun_prop + exact hcont.eventually (isOpen_Ioi.mem_nhds (by simpa using hz i)) + obtain ⟨R, hR, hRsub⟩ := Metric.mem_nhds_iff.mp hnear + obtain ⟨t, ht, s, hsball, hsroot⟩ := + polynomial_linear_perturbation_has_nearby_zero A B (R / 2) + hA (half_pos hR) hA0 + have hsR : s ∈ ball (0 : β„‚) R := by + rw [mem_closedBall, dist_zero_right] at hsball + rw [mem_ball, dist_zero_right] + exact hsball.trans_lt (half_lt_self hR) + have hlineUpper : βˆ€ i, 0 < (z i + s * v i).im := hRsub hsR + have hne := hstable t ht (fun i ↦ z i + s * v i) hlineUpper + apply hne + rw [MvPolynomial.eval_add, MvPolynomial.eval_mul, MvPolynomial.eval_C] + simpa [A, B, affineLinePolynomial_eval] using hsroot + +/-! ## Coefficients, boundary values, and the Lieb--Sokal contraction -/ + +/-- Adjoin one multiaffine variable, with constant coefficient `g` and +linear coefficient `f`. -/ +noncomputable def linearExtension + {Οƒ : Type*} (g f : MvPolynomial Οƒ β„‚) : MvPolynomial (Option Οƒ) β„‚ := + MvPolynomial.rename some g + + MvPolynomial.X none * MvPolynomial.rename some f + +@[simp] +theorem linearExtension_eval + {Οƒ : Type*} (g f : MvPolynomial Οƒ β„‚) (z : Option Οƒ β†’ β„‚) : + (linearExtension g f).eval z = + g.eval (z ∘ some) + z none * f.eval (z ∘ some) := by + simp [linearExtension, MvPolynomial.eval_rename] + +/-- The coefficient of a stable polynomial in a multiaffine variable is +stable or zero. It is obtained as a large-imaginary-value limit. -/ +theorem linearExtension_linearCoefficient_stableOrZero + {Οƒ : Type*} [Fintype Οƒ] + {g f : MvPolynomial Οƒ β„‚} + (hstable : IsUpperHalfPlaneStable (linearExtension g f)) : + f = 0 ∨ IsUpperHalfPlaneStable f := by + let q : MvPolynomial Οƒ β„‚ := MvPolynomial.C (-Complex.I) * g + apply upperHalfPlaneStableOrZero_of_positive_ray f q + intro t ht z hz + let w : Option Οƒ β†’ β„‚ + | none => Complex.I / (t : β„‚) + | some i => z i + have hw : βˆ€ i, 0 < (w i).im := by + intro i + cases i with + | none => + simp [w, Complex.div_im, ht] + | some i => simpa [w] using hz i + have hne := hstable w hw + intro hzero + have hzero' : f.eval z - (t : β„‚) * Complex.I * g.eval z = 0 := by + simpa [q, sub_eq_add_neg, mul_assoc] using hzero + apply hne + have hwcomp : w ∘ some = z := by rfl + rw [linearExtension_eval, hwcomp] + calc + g.eval z + w none * f.eval z = + (Complex.I / (t : β„‚)) * + (f.eval z - (t : β„‚) * Complex.I * g.eval z) := by + dsimp [w] + field_simp [ht.ne'] + have hII (x : β„‚) : Complex.I * (Complex.I * x) = -x := by + rw [← mul_assoc, Complex.I_mul_I, neg_one_mul] + calc + g.eval z * (t : β„‚) + Complex.I * f.eval z = + Complex.I * f.eval z + g.eval z * (t : β„‚) := by ring + _ = Complex.I * f.eval z - + Complex.I * (Complex.I * (g.eval z * (t : β„‚))) := by + rw [hII] + ring + _ = Complex.I * + (f.eval z - g.eval z * Complex.I * (t : β„‚)) := by ring + _ = 0 := by rw [hzero']; ring + +/-- Substitution of a real-boundary value preserves stability, with the zero +polynomial allowed. Here the boundary value is zero; translations give the +usual general statement. -/ +theorem linearExtension_constantCoefficient_stableOrZero + {Οƒ : Type*} [Fintype Οƒ] + {g f : MvPolynomial Οƒ β„‚} + (hstable : IsUpperHalfPlaneStable (linearExtension g f)) : + g = 0 ∨ IsUpperHalfPlaneStable g := by + let q : MvPolynomial Οƒ β„‚ := MvPolynomial.C Complex.I * f + apply upperHalfPlaneStableOrZero_of_positive_ray g q + intro t ht z hz + let w : Option Οƒ β†’ β„‚ + | none => Complex.I * (t : β„‚) + | some i => z i + have hw : βˆ€ i, 0 < (w i).im := by + intro i + cases i with + | none => simpa [w] using ht + | some i => simpa [w] using hz i + have hne := hstable w hw + have hwcomp : w ∘ some = z := by rfl + intro hzero + apply hne + rw [linearExtension_eval, hwcomp] + have hzero' : g.eval z + (t : β„‚) * Complex.I * f.eval z = 0 := by + simpa [q, mul_assoc] using hzero + linear_combination hzero' + +/-- Ratio characterization for a polynomial affine in one new variable. -/ +theorem linearExtension_stable_iff_ratio + {Οƒ : Type*} {g f : MvPolynomial Οƒ β„‚} + (hf : IsUpperHalfPlaneStable f) : + IsUpperHalfPlaneStable (linearExtension g f) ↔ + βˆ€ z : Οƒ β†’ β„‚, (βˆ€ i, 0 < (z i).im) β†’ + 0 ≀ (g.eval z / f.eval z).im := by + constructor + Β· intro h z hz + have hfz := hf z hz + by_contra hneg + have him : 0 < (-g.eval z / f.eval z).im := by + rw [neg_div] + simpa using (lt_of_not_ge hneg) + let w : Option Οƒ β†’ β„‚ + | none => -g.eval z / f.eval z + | some i => z i + have hw : βˆ€ i, 0 < (w i).im := by + intro i + cases i with + | none => exact him + | some i => simpa [w] using hz i + have hne := h w hw + apply hne + have hwcomp : w ∘ some = z := by rfl + rw [linearExtension_eval, hwcomp] + dsimp [w] + field_simp [hfz] + ring + Β· intro h z hz + have hbase : βˆ€ i, 0 < ((z ∘ some) i).im := fun i ↦ hz (some i) + have hfz := hf (z ∘ some) hbase + intro hzero + have hy : z none = -g.eval (z ∘ some) / f.eval (z ∘ some) := by + apply (eq_div_iff hfz).2 + have := hzero + simp only [linearExtension_eval] at this + rw [eq_neg_iff_add_eq_zero] + simpa [add_comm] using this + have him := h (z ∘ some) hbase + have hyim : (z none).im ≀ 0 := by + rw [hy, neg_div] + simpa using neg_nonpos.mpr him + exact (not_lt_of_ge hyim) (hz none) + +/-- The elementary inverse-shift identity in the Lieb--Sokal proof. -/ +theorem inverseShiftExtension_stable + {Οƒ : Type*} [Fintype Οƒ] + {fβ‚€ f₁ : MvPolynomial Οƒ β„‚} + (hf : IsUpperHalfPlaneStable (linearExtension fβ‚€ f₁)) : + IsUpperHalfPlaneStable + (linearExtension (-MvPolynomial.rename some f₁) + (linearExtension fβ‚€ f₁)) := by + intro z hz + let y : β„‚ := z none + let u : Option Οƒ β†’ β„‚ := z ∘ some + let shifted : Option Οƒ β†’ β„‚ + | none => u none - 1 / y + | some i => u (some i) + have hy : 0 < y.im := by simpa [y] using hz none + have hyne : y β‰  0 := by + intro h + rw [h] at hy + simp at hy + have him_inv : (1 / y).im < 0 := by + rw [one_div, Complex.inv_im] + exact div_neg_of_neg_of_pos (neg_neg_of_pos hy) (Complex.normSq_pos.mpr hyne) + have hshifted : βˆ€ i, 0 < (shifted i).im := by + intro i + cases i with + | none => + dsimp [shifted, u] + have hu := hz (some none) + linarith + | some i => simpa [shifted, u] using hz (some (some i)) + have hne := hf shifted hshifted + intro hzero + apply hne + have hzero' : + -f₁.eval (u ∘ some) + + y * (fβ‚€.eval (u ∘ some) + u none * f₁.eval (u ∘ some)) = 0 := by + simpa [linearExtension_eval, MvPolynomial.eval_rename, y, u] using hzero + rw [linearExtension_eval] + have hshiftcomp : shifted ∘ some = u ∘ some := by rfl + rw [hshiftcomp] + change fβ‚€.eval (u ∘ some) + + (u none - 1 / y) * f₁.eval (u ∘ some) = 0 + calc + fβ‚€.eval (u ∘ some) + + (u none - 1 / y) * f₁.eval (u ∘ some) = + (1 / y) * + (-f₁.eval (u ∘ some) + + y * (fβ‚€.eval (u ∘ some) + u none * f₁.eval (u ∘ some))) := by + field_simp [hyne] + ring + _ = 0 := by rw [hzero']; ring + +/-- Coordinate form of the Lieb--Sokal lemma. The proof uses only the ratio +characterization above, the inverse shift, and boundary closure. -/ +theorem liebSokal_linear_contraction + {Οƒ : Type*} [Fintype Οƒ] + (g : MvPolynomial (Option Οƒ) β„‚) (fβ‚€ f₁ : MvPolynomial Οƒ β„‚) + (hstable : IsUpperHalfPlaneStable + (linearExtension g (linearExtension fβ‚€ f₁))) : + g - MvPolynomial.rename some f₁ = 0 ∨ + IsUpperHalfPlaneStable (g - MvPolynomial.rename some f₁) := by + have hfOr := linearExtension_linearCoefficient_stableOrZero hstable + rcases hfOr with hfzero | hf + Β· have hf₁zero : f₁ = 0 := by + apply MvPolynomial.funext + intro z + let wβ‚€ : Option Οƒ β†’ β„‚ + | none => 0 + | some i => z i + let w₁ : Option Οƒ β†’ β„‚ + | none => 1 + | some i => z i + have hβ‚€ := congrArg (fun P : MvPolynomial (Option Οƒ) β„‚ ↦ P.eval wβ‚€) hfzero + have h₁ := congrArg (fun P : MvPolynomial (Option Οƒ) β„‚ ↦ P.eval w₁) hfzero + have hwβ‚€ : wβ‚€ ∘ some = z := by rfl + have hw₁ : w₁ ∘ some = z := by rfl + simp [linearExtension_eval, wβ‚€, w₁, hwβ‚€, hw₁] at hβ‚€ h₁ + change f₁.eval z = 0 + linear_combination h₁ - hβ‚€ + subst f₁ + simpa using linearExtension_constantCoefficient_stableOrZero hstable + Β· have hinverse := inverseShiftExtension_stable hf + have hratio₁ := (linearExtension_stable_iff_ratio hf).1 hstable + have hratioβ‚‚ := (linearExtension_stable_iff_ratio hf).1 hinverse + have hcombined : IsUpperHalfPlaneStable + (linearExtension (g - MvPolynomial.rename some f₁) + (linearExtension fβ‚€ f₁)) := by + apply (linearExtension_stable_iff_ratio hf).2 + intro z hz + have h₁ := hratio₁ z hz + have hβ‚‚ := hratioβ‚‚ z hz + simp only [MvPolynomial.eval_neg, neg_div] at hβ‚‚ + rw [MvPolynomial.eval_sub, sub_eq_add_neg, add_div, neg_div] + simpa only [Complex.add_im, Complex.neg_im] using add_nonneg h₁ hβ‚‚ + exact linearExtension_constantCoefficient_stableOrZero hcombined + +/-! ## Specializing an arbitrary multiaffine coordinate -/ + +/-- Requires the complex multivariate polynomial to have degree at most one in each variable. -/ +def IsComplexMultiaffine + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) : Prop := + βˆ€ i, p.degreeOf i ≀ 1 + +theorem IsUpperHalfPlaneStable.rename + {Οƒ Ο„ : Type*} {p : MvPolynomial Οƒ β„‚} + (hp : IsUpperHalfPlaneStable p) (f : Οƒ β†’ Ο„) : + IsUpperHalfPlaneStable (MvPolynomial.rename f p) := by + intro z hz + rw [MvPolynomial.eval_rename] + exact hp (z ∘ f) (fun i ↦ hz (f i)) + +/-- Extracts the coefficient of degree zero in the distinguished optional variable. -/ +noncomputable def optionConstantCoefficient + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) : MvPolynomial Οƒ β„‚ := + (MvPolynomial.optionEquivLeft β„‚ Οƒ p).coeff 0 + +/-- Extracts the coefficient of degree one in the distinguished optional variable. -/ +noncomputable def optionLinearCoefficient + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) : MvPolynomial Οƒ β„‚ := + (MvPolynomial.optionEquivLeft β„‚ Οƒ p).coeff 1 + +theorem optionEquivLeft_rename_some + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) : + MvPolynomial.optionEquivLeft β„‚ Οƒ (MvPolynomial.rename some p) = + Polynomial.C p := by + induction p using MvPolynomial.induction_on with + | C r => simp + | add p q hp hq => simp [hp, hq] + | mul_X p n hp => simp [hp] + +theorem option_eq_linearExtension + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) + (hdegree : p.degreeOf none ≀ 1) : + p = linearExtension (optionConstantCoefficient p) + (optionLinearCoefficient p) := by + apply (MvPolynomial.optionEquivLeft β„‚ Οƒ).injective + have hnat : (MvPolynomial.optionEquivLeft β„‚ Οƒ p).natDegree ≀ 1 := by + simpa [MvPolynomial.natDegree_optionEquivLeft] using hdegree + rw [Polynomial.eq_X_add_C_of_natDegree_le_one hnat] + simp only [linearExtension, map_add, map_mul, + MvPolynomial.optionEquivLeft_X_none, optionEquivLeft_rename_some] + dsimp [optionConstantCoefficient, optionLinearCoefficient] + ring + +theorem linearExtension_eq_zero_iff + {Οƒ : Type*} {g f : MvPolynomial Οƒ β„‚} : + linearExtension g f = 0 ↔ g = 0 ∧ f = 0 := by + constructor + Β· intro h + have h' := congrArg (MvPolynomial.optionEquivLeft β„‚ Οƒ) h + simp only [linearExtension, map_add, map_mul, + MvPolynomial.optionEquivLeft_X_none, optionEquivLeft_rename_some, map_zero] at h' + constructor + Β· have := congrArg (fun P : Polynomial (MvPolynomial Οƒ β„‚) ↦ P.coeff 0) h' + simpa using this + Β· have := congrArg (fun P : Polynomial (MvPolynomial Οƒ β„‚) ↦ P.coeff 1) h' + simpa using this + Β· rintro ⟨rfl, rfl⟩ + simp [linearExtension] +theorem linearExtension_multiaffine + {Οƒ : Type*} {g f : MvPolynomial Οƒ β„‚} + (hg : IsComplexMultiaffine g) (hf : IsComplexMultiaffine f) : + IsComplexMultiaffine (linearExtension g f) := by + classical + intro j + cases j with + | none => + rw [← MvPolynomial.natDegree_optionEquivLeft] + simp only [linearExtension, map_add, map_mul, + MvPolynomial.optionEquivLeft_X_none, optionEquivLeft_rename_some] + rw [show Polynomial.C g + Polynomial.X * Polynomial.C f = + Polynomial.C f * Polynomial.X + Polynomial.C g by ring] + exact Polynomial.natDegree_linear_le (a := f) (b := g) + | some i => + apply le_trans (MvPolynomial.degreeOf_add_le (some i) _ _) + apply max_le + Β· simpa using + (MvPolynomial.degreeOf_rename_of_injective (Option.some_injective Οƒ) i).trans_le (hg i) + Β· apply le_trans (MvPolynomial.degreeOf_mul_le (some i) _ _) + have hx : (MvPolynomial.X none : MvPolynomial (Option Οƒ) β„‚).degreeOf (some i) = 0 := + MvPolynomial.degreeOf_X_of_ne (by simp) + rw [hx, zero_add] + simpa using + (MvPolynomial.degreeOf_rename_of_injective (Option.some_injective Οƒ) i).trans_le (hf i) + +/-- Specializing the adjoined variable to a real number preserves stability, +again allowing the zero polynomial. -/ +theorem linearExtension_specialize_real_stableOrZero + {Οƒ : Type*} [Fintype Οƒ] + {g f : MvPolynomial Οƒ β„‚} (c : ℝ) + (hstable : IsUpperHalfPlaneStable (linearExtension g f)) : + g + MvPolynomial.C (c : β„‚) * f = 0 ∨ + IsUpperHalfPlaneStable (g + MvPolynomial.C (c : β„‚) * f) := by + have hshift : IsUpperHalfPlaneStable + (linearExtension (g + MvPolynomial.C (c : β„‚) * f) f) := by + intro z hz + let w : Option Οƒ β†’ β„‚ + | none => z none + (c : β„‚) + | some i => z (some i) + have hw : βˆ€ i, 0 < (w i).im := by + intro i + cases i with + | none => simpa [w] using hz none + | some i => simpa [w] using hz (some i) + have hne := hstable w hw + have hwcomp : w ∘ some = z ∘ some := by rfl + intro hzero + apply hne + rw [linearExtension_eval, hwcomp] + have hzero' := hzero + rw [linearExtension_eval] at hzero' + simp only [MvPolynomial.eval_add, MvPolynomial.eval_mul, + MvPolynomial.eval_C] at hzero' + dsimp [w] + linear_combination hzero' + exact linearExtension_constantCoefficient_stableOrZero hshift + +/-- Coordinate specialization in a polynomial whose selected variable has +degree at most one. -/ +theorem option_specialize_real_stableOrZero + {Οƒ : Type*} [Fintype Οƒ] + (p : MvPolynomial (Option Οƒ) β„‚) (c : ℝ) + (hdegree : p.degreeOf none ≀ 1) + (hstable : IsUpperHalfPlaneStable p) : + optionConstantCoefficient p + + MvPolynomial.C (c : β„‚) * optionLinearCoefficient p = 0 ∨ + IsUpperHalfPlaneStable + (optionConstantCoefficient p + + MvPolynomial.C (c : β„‚) * optionLinearCoefficient p) := by + rw [option_eq_linearExtension p hdegree] at hstable + exact linearExtension_specialize_real_stableOrZero c hstable + +theorem degreeOf_optionConstantCoefficient_le + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) (i : Οƒ) : + (optionConstantCoefficient p).degreeOf i ≀ p.degreeOf (some i) := by + rw [MvPolynomial.degreeOf_le_iff] + intro m hm + have hm' : m.optionElim 0 ∈ p.support := by + exact (MvPolynomial.mem_support_coeff_optionEquivLeft (R := β„‚)).mp hm + simpa using MvPolynomial.monomial_le_degreeOf (some i) hm' + +theorem degreeOf_optionLinearCoefficient_le + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) (i : Οƒ) : + (optionLinearCoefficient p).degreeOf i ≀ p.degreeOf (some i) := by + rw [MvPolynomial.degreeOf_le_iff] + intro m hm + have hm' : m.optionElim 1 ∈ p.support := by + exact (MvPolynomial.mem_support_coeff_optionEquivLeft (R := β„‚)).mp hm + simpa using MvPolynomial.monomial_le_degreeOf (some i) hm' + +theorem option_specialization_multiaffine + {Οƒ : Type*} (p : MvPolynomial (Option Οƒ) β„‚) (c : ℝ) + (hp : IsComplexMultiaffine p) : + IsComplexMultiaffine + (optionConstantCoefficient p + + MvPolynomial.C (c : β„‚) * optionLinearCoefficient p) := by + intro i + apply le_trans (MvPolynomial.degreeOf_add_le i _ _) + apply max_le + Β· exact (degreeOf_optionConstantCoefficient_le p i).trans (hp (some i)) + Β· exact (MvPolynomial.degreeOf_C_mul_le _ i _).trans + ((degreeOf_optionLinearCoefficient_le p i).trans (hp (some i))) + +/-- Renames coordinate `i` as the distinguished optional variable and all other coordinates by +their unequal-index subtype. -/ +noncomputable def coordinateReindex + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) (i : Οƒ) : + MvPolynomial (Option {j : Οƒ // j β‰  i}) β„‚ := by + classical + exact MvPolynomial.rename (Equiv.optionSubtypeNe i).symm p + +/-- Adds the distinguished constant coefficient to `c` times its linear coefficient after +reindexing coordinate `i`. -/ +noncomputable def coordinateSpecialization + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) (i : Οƒ) (c : ℝ) : + MvPolynomial {j : Οƒ // j β‰  i} β„‚ := by + classical + exact optionConstantCoefficient (coordinateReindex p i) + + MvPolynomial.C (c : β„‚) * optionLinearCoefficient (coordinateReindex p i) + +theorem coordinateReindex_stable + {Οƒ : Type*} {p : MvPolynomial Οƒ β„‚} (i : Οƒ) + (hp : IsUpperHalfPlaneStable p) : + IsUpperHalfPlaneStable (coordinateReindex p i) := by + classical + simpa [coordinateReindex] using hp.rename (Equiv.optionSubtypeNe i).symm + +theorem coordinateReindex_multiaffine + {Οƒ : Type*} {p : MvPolynomial Οƒ β„‚} (i : Οƒ) + (hp : IsComplexMultiaffine p) : + IsComplexMultiaffine (coordinateReindex p i) := by + classical + intro j + let e := Equiv.optionSubtypeNe i + have hdegree := MvPolynomial.degreeOf_rename_of_injective e.symm.injective (e j) + (p := p) + have hp' := hp (e j) + change MvPolynomial.degreeOf j (MvPolynomial.rename e.symm p) ≀ 1 + convert hdegree.trans_le hp' using 1 + simp + +theorem coordinateSpecialization_stableOrZero + {Οƒ : Type*} [Fintype Οƒ] + (p : MvPolynomial Οƒ β„‚) (i : Οƒ) (c : ℝ) + (hmulti : IsComplexMultiaffine p) + (hstable : IsUpperHalfPlaneStable p) : + coordinateSpecialization p i c = 0 ∨ + IsUpperHalfPlaneStable (coordinateSpecialization p i c) := by + classical + let p' := coordinateReindex p i + have hdegree : p'.degreeOf none ≀ 1 := + coordinateReindex_multiaffine i hmulti none + simpa [coordinateSpecialization, p'] using + option_specialize_real_stableOrZero p' c hdegree + (coordinateReindex_stable i hstable) + +theorem coordinateSpecialization_multiaffine + {Οƒ : Type*} (p : MvPolynomial Οƒ β„‚) (i : Οƒ) (c : ℝ) + (hp : IsComplexMultiaffine p) : + IsComplexMultiaffine (coordinateSpecialization p i c) := by + classical + exact option_specialization_multiaffine (coordinateReindex p i) c + (coordinateReindex_multiaffine i hp) + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableEncoding.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableEncoding.lean new file mode 100644 index 0000000000..24158e38e0 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableEncoding.lean @@ -0,0 +1,683 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableInduction +public import LeanPool.BeyondBethe.BeyondBethe.CapacityOrder +public import Mathlib.Tactic + +/-! # Source Stable Encoding -/ + +@[expose] public section + +open scoped BigOperators +open scoped ComplexConjugate + +namespace BeyondBethe + +/-! +# Encoding multiaffine polynomials by Boolean coefficient tables +-/ + +/-- Converts a Boolean coordinate selector to its finitely supported zero-or-one exponent +vector. -/ +noncomputable def boolExponent {n : β„•} (S : Fin n β†’ Bool) : Fin n β†’β‚€ β„• := + Finsupp.equivFunOnFinite.symm (fun i ↦ bif S i then 1 else 0) + +@[simp] +theorem boolExponent_apply {n : β„•} (S : Fin n β†’ Bool) (i : Fin n) : + boolExponent S i = bif S i then 1 else 0 := by + simp [boolExponent] + +theorem boolExponent_injective {n : β„•} : + Function.Injective (@boolExponent n) := by + intro S T h + funext i + have hi := DFunLike.congr_fun h i + simp only [boolExponent_apply] at hi + cases hS : S i <;> cases hT : T i <;> simp [hS, hT] at hi ⊒ + +/-- Marks exactly the coordinates where a finitely supported exponent vector equals one. -/ +noncomputable def exponentBool {n : β„•} (d : Fin n β†’β‚€ β„•) : Fin n β†’ Bool := + fun i ↦ decide (d i = 1) + +theorem boolExponent_exponentBool {n : β„•} (d : Fin n β†’β‚€ β„•) + (hd : βˆ€ i, d i ≀ 1) : boolExponent (exponentBool d) = d := by + ext i + simp only [boolExponent_apply, exponentBool] + by_cases h : d i = 1 + Β· simp [h] + Β· have hz : d i = 0 := by + rcases Nat.le_one_iff_eq_zero_or_eq_one.mp (hd i) with hz | ho + Β· exact hz + Β· exact (h ho).elim + simp [h, hz] + +theorem coeff_eq_zero_of_not_squarefree + {n : β„•} {p : MvPolynomial (Fin n) ℝ} + (hp : IsMultiaffine p) {d : Fin n β†’β‚€ β„•} + (hd : Β¬ βˆ€ i, d i ≀ 1) : p.coeff d = 0 := by + by_contra hcoeff + push Not at hd + obtain ⟨i, hi⟩ := hd + have hmem : d ∈ p.support := MvPolynomial.mem_support_iff.mpr hcoeff + have hdegree := MvPolynomial.monomial_le_degreeOf i hmem + have := hp i + omega + +theorem multiaffine_eq_boolExpansion + {n : β„•} (p : MvPolynomial (Fin n) ℝ) (hp : IsMultiaffine p) : + p = βˆ‘ S : Fin n β†’ Bool, + MvPolynomial.monomial (boolExponent S) (p.coeff (boolExponent S)) := by + classical + ext d + by_cases hd : βˆ€ i, d i ≀ 1 + Β· let S := exponentBool d + have hSd : boolExponent S = d := boolExponent_exponentBool d hd + rw [MvPolynomial.coeff_sum] + rw [Finset.sum_eq_single S] + Β· simp [hSd] + Β· intro T hT hTS + simp only [MvPolynomial.coeff_monomial] + rw [ite_eq_right] + intro h + apply hTS + exact boolExponent_injective (h.trans hSd.symm) + Β· intro hS + exact (hS (Finset.mem_univ S)).elim + Β· rw [coeff_eq_zero_of_not_squarefree hp hd, MvPolynomial.coeff_sum] + symm + apply Finset.sum_eq_zero + intro S hS + simp only [MvPolynomial.coeff_monomial] + rw [ite_eq_right] + intro h + apply hd + intro i + rw [← h, boolExponent_apply] + cases S i <;> simp + +/-- The real squarefree monomial selected by the true coordinates of a Boolean vector. -/ +noncomputable def boolMonomial {n : β„•} + (x : Fin n β†’ ℝ) (S : Fin n β†’ Bool) : ℝ := + ∏ i, (x i) ^ (bif S i then (1 : β„•) else 0) + +theorem multiaffine_eval_eq_boolSum + {n : β„•} (p : MvPolynomial (Fin n) ℝ) (hp : IsMultiaffine p) + (x : Fin n β†’ ℝ) : + p.eval x = βˆ‘ S : Fin n β†’ Bool, + p.coeff (boolExponent S) * boolMonomial x S := by + calc + p.eval x = + (βˆ‘ S : Fin n β†’ Bool, + MvPolynomial.monomial (boolExponent S) (p.coeff (boolExponent S))).eval x := by + rw [← multiaffine_eq_boolExpansion p hp] + _ = βˆ‘ S : Fin n β†’ Bool, + p.coeff (boolExponent S) * boolMonomial x S := by + rw [map_sum] + apply Finset.sum_congr rfl + intro S hS + simp only [MvPolynomial.eval_monomial] + congr 1 + rw [Finsupp.prod_fintype] + Β· simp [boolMonomial, boolExponent_apply] + Β· intro i + simp + +theorem sum_bool_fin_succ {n : β„•} {R : Type*} [AddCommMonoid R] + (f : (Fin (n + 1) β†’ Bool) β†’ R) : + (βˆ‘ S : Fin (n + 1) β†’ Bool, f S) = + βˆ‘ b : Bool, βˆ‘ T : Fin n β†’ Bool, f (prependBool b T) := by + let e : Bool Γ— (Fin n β†’ Bool) ≃ (Fin (n + 1) β†’ Bool) := + Fin.consEquiv (fun _ ↦ Bool) + calc + (βˆ‘ S : Fin (n + 1) β†’ Bool, f S) = + βˆ‘ p : Bool Γ— (Fin n β†’ Bool), f (e p) := by + symm + exact e.sum_comp f + _ = βˆ‘ b : Bool, βˆ‘ T : Fin n β†’ Bool, f (prependBool b T) := by + rw [Fintype.sum_prod_type] + rfl + +theorem boolMonomial_prepend {n : β„•} (x : Fin (n + 1) β†’ ℝ) + (b : Bool) (S : Fin n β†’ Bool) : + boolMonomial x (prependBool b S) = + (bif b then x 0 else 1) * boolMonomial (fun i ↦ x i.succ) S := by + rw [boolMonomial, Fin.prod_univ_succ, boolMonomial] + simp only [prependBool, Fin.cases_zero, Fin.cases_succ] + cases b <;> simp + +theorem sum_sum_mul_factors {ΞΉ ΞΊ R : Type*} [Fintype ΞΉ] [Fintype ΞΊ] + [CommRing R] + (c : ΞΉ β†’ ΞΊ β†’ R) (u : ΞΉ β†’ R) (v : ΞΊ β†’ R) (A B : R) : + (βˆ‘ i, βˆ‘ j, c i j * (A * u i) * (B * v j)) = + A * B * (βˆ‘ i, βˆ‘ j, c i j * u i * v j) := by + calc + (βˆ‘ i, βˆ‘ j, c i j * (A * u i) * (B * v j)) = + βˆ‘ i, βˆ‘ j, (A * B) * (c i j * u i * v j) := by + apply Finset.sum_congr rfl + intro i hi + apply Finset.sum_congr rfl + intro j hj + ring + _ = βˆ‘ i, (A * B) * (βˆ‘ j, c i j * u i * v j) := by + apply Finset.sum_congr rfl + intro i hi + rw [Finset.mul_sum] + _ = A * B * (βˆ‘ i, βˆ‘ j, c i j * u i * v j) := by + rw [Finset.mul_sum] + +theorem pairTableEval_eq_boolDoubleSum : + βˆ€ {n : β„•} (c : PairTable n) (y z : Fin n β†’ ℝ), + pairTableEval n c y z = + βˆ‘ S : Fin n β†’ Bool, βˆ‘ T : Fin n β†’ Bool, + c S T * boolMonomial y S * boolMonomial z T := by + intro n + induction n with + | zero => + intro c y z + have hy (S : Fin 0 β†’ Bool) : boolMonomial y S = 1 := by + rw [boolMonomial] + apply Finset.prod_eq_one + intro i hi + exact Fin.elim0 i + have hz (T : Fin 0 β†’ Bool) : boolMonomial z T = 1 := by + rw [boolMonomial] + apply Finset.prod_eq_one + intro i hi + exact Fin.elim0 i + simp only [pairTableEval, Fintype.sum_unique, hy, hz, mul_one] + apply congrArgβ‚‚ c <;> apply Subsingleton.elim + | succ n ih => + intro c y z + rw [sum_bool_fin_succ] + simp_rw [sum_bool_fin_succ] + simp only [Fintype.sum_bool, boolMonomial_prepend, + Finset.sum_add_distrib] + rw [sum_sum_mul_factors, sum_sum_mul_factors, + sum_sum_mul_factors, sum_sum_mul_factors] + simp only [Bool.false_eq, Bool.true_eq, Bool.cond_false, Bool.cond_true, + one_mul, mul_one] + change pairTableEval (n + 1) c y z = + y 0 * z 0 * + (βˆ‘ S, βˆ‘ T, pairTableSection c true true S T * + boolMonomial (fun i ↦ y i.succ) S * boolMonomial (fun i ↦ z i.succ) T) + + z 0 * + (βˆ‘ S, βˆ‘ T, pairTableSection c false true S T * + boolMonomial (fun i ↦ y i.succ) S * boolMonomial (fun i ↦ z i.succ) T) + + (y 0 * + (βˆ‘ S, βˆ‘ T, pairTableSection c true false S T * + boolMonomial (fun i ↦ y i.succ) S * boolMonomial (fun i ↦ z i.succ) T) + + (βˆ‘ S, βˆ‘ T, pairTableSection c false false S T * + boolMonomial (fun i ↦ y i.succ) S * boolMonomial (fun i ↦ z i.succ) T)) + rw [← ih (pairTableSection c true true) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c false true) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c true false) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c false false) (fun i ↦ y i.succ) (fun i ↦ z i.succ)] + simp only [pairTableEval] + ring + +/-- The table of products of the two polynomials' coefficients at Boolean exponent vectors. -/ +noncomputable def coefficientPairTable {n : β„•} + (p q : MvPolynomial (Fin n) ℝ) : PairTable n := + fun S T ↦ p.coeff (boolExponent S) * q.coeff (boolExponent T) + +theorem coefficientPairTable_eval + {n : β„•} (p q : MvPolynomial (Fin n) ℝ) + (hp : IsMultiaffine p) (hq : IsMultiaffine q) + (y z : Fin n β†’ ℝ) : + pairTableEval n (coefficientPairTable p q) y z = p.eval y * q.eval z := by + rw [pairTableEval_eq_boolDoubleSum, + multiaffine_eval_eq_boolSum p hp, + multiaffine_eval_eq_boolSum q hq] + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro S hS + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro T hT + simp [coefficientPairTable] + ring + +/-- The complex squarefree monomial selected by the true coordinates of a Boolean vector. -/ +noncomputable def complexBoolMonomial {n : β„•} + (x : Fin n β†’ β„‚) (S : Fin n β†’ Bool) : β„‚ := + ∏ i, (x i) ^ (bif S i then (1 : β„•) else 0) + +theorem multiaffine_evalβ‚‚_eq_boolSum + {n : β„•} (p : MvPolynomial (Fin n) ℝ) (hp : IsMultiaffine p) + (x : Fin n β†’ β„‚) : + p.evalβ‚‚ (algebraMap ℝ β„‚) x = βˆ‘ S : Fin n β†’ Bool, + ((p.coeff (boolExponent S) : ℝ) : β„‚) * complexBoolMonomial x S := by + calc + p.evalβ‚‚ (algebraMap ℝ β„‚) x = + ((βˆ‘ S : Fin n β†’ Bool, + MvPolynomial.monomial (boolExponent S) (p.coeff (boolExponent S) : ℝ)) : + MvPolynomial (Fin n) ℝ).evalβ‚‚ + (algebraMap ℝ β„‚) x := by + rw [← multiaffine_eq_boolExpansion p hp] + _ = βˆ‘ S : Fin n β†’ Bool, + ((p.coeff (boolExponent S) : ℝ) : β„‚) * complexBoolMonomial x S := by + rw [MvPolynomial.evalβ‚‚_sum] + apply Finset.sum_congr rfl + intro S hS + simp only [MvPolynomial.evalβ‚‚_monomial, map_natCast] + congr 1 + rw [Finsupp.prod_fintype] + Β· simp [complexBoolMonomial, boolExponent_apply] + Β· intro i + simp + +/-- Recursively evaluates a pair table on complex vectors by its four head-coordinate sections. -/ +noncomputable def pairTableComplexEval : + βˆ€ n : β„•, PairTable n β†’ (Fin n β†’ β„‚) β†’ (Fin n β†’ β„‚) β†’ β„‚ + | 0, c, _, _ => (c (fun i ↦ Fin.elim0 i) (fun i ↦ Fin.elim0 i) : β„‚) + | n + 1, c, y, z => + let yt : Fin n β†’ β„‚ := fun i ↦ y i.succ + let zt : Fin n β†’ β„‚ := fun i ↦ z i.succ + let a := pairTableComplexEval n (pairTableSection c true true) yt zt + let b := pairTableComplexEval n (pairTableSection c true false) yt zt + let cc := pairTableComplexEval n (pairTableSection c false true) yt zt + let d := pairTableComplexEval n (pairTableSection c false false) yt zt + a * y 0 * z 0 + b * y 0 + cc * z 0 + d + +theorem complexBoolMonomial_prepend {n : β„•} (x : Fin (n + 1) β†’ β„‚) + (b : Bool) (S : Fin n β†’ Bool) : + complexBoolMonomial x (prependBool b S) = + (bif b then x 0 else 1) * complexBoolMonomial (fun i ↦ x i.succ) S := by + rw [complexBoolMonomial, Fin.prod_univ_succ, complexBoolMonomial] + simp only [prependBool, Fin.cases_zero, Fin.cases_succ] + cases b <;> simp + +theorem pairTableComplexEval_eq_boolDoubleSum : + βˆ€ {n : β„•} (c : PairTable n) (y z : Fin n β†’ β„‚), + pairTableComplexEval n c y z = + βˆ‘ S : Fin n β†’ Bool, βˆ‘ T : Fin n β†’ Bool, + (c S T : β„‚) * complexBoolMonomial y S * complexBoolMonomial z T := by + intro n + induction n with + | zero => + intro c y z + have hy (S : Fin 0 β†’ Bool) : complexBoolMonomial y S = 1 := by + rw [complexBoolMonomial] + apply Finset.prod_eq_one + intro i hi + exact Fin.elim0 i + have hz (T : Fin 0 β†’ Bool) : complexBoolMonomial z T = 1 := by + rw [complexBoolMonomial] + apply Finset.prod_eq_one + intro i hi + exact Fin.elim0 i + simp only [pairTableComplexEval, Fintype.sum_unique, hy, hz, mul_one] + norm_cast + | succ n ih => + intro c y z + rw [sum_bool_fin_succ] + simp_rw [sum_bool_fin_succ] + simp only [Fintype.sum_bool, complexBoolMonomial_prepend, + Finset.sum_add_distrib] + rw [sum_sum_mul_factors, sum_sum_mul_factors, + sum_sum_mul_factors, sum_sum_mul_factors] + simp only [Bool.cond_false, Bool.cond_true, one_mul, mul_one] + change pairTableComplexEval (n + 1) c y z = + y 0 * z 0 * + (βˆ‘ S, βˆ‘ T, (pairTableSection c true true S T : β„‚) * + complexBoolMonomial (fun i ↦ y i.succ) S * + complexBoolMonomial (fun i ↦ z i.succ) T) + + z 0 * + (βˆ‘ S, βˆ‘ T, (pairTableSection c false true S T : β„‚) * + complexBoolMonomial (fun i ↦ y i.succ) S * + complexBoolMonomial (fun i ↦ z i.succ) T) + + (y 0 * + (βˆ‘ S, βˆ‘ T, (pairTableSection c true false S T : β„‚) * + complexBoolMonomial (fun i ↦ y i.succ) S * + complexBoolMonomial (fun i ↦ z i.succ) T) + + (βˆ‘ S, βˆ‘ T, (pairTableSection c false false S T : β„‚) * + complexBoolMonomial (fun i ↦ y i.succ) S * complexBoolMonomial (fun i ↦ z i.succ) T)) + rw [← ih (pairTableSection c true true) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c false true) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c true false) (fun i ↦ y i.succ) (fun i ↦ z i.succ), + ← ih (pairTableSection c false false) (fun i ↦ y i.succ) (fun i ↦ z i.succ)] + simp only [pairTableComplexEval] + ring + +theorem coefficientPairTable_complexEval + {n : β„•} (p q : MvPolynomial (Fin n) ℝ) + (hp : IsMultiaffine p) (hq : IsMultiaffine q) + (y z : Fin n β†’ β„‚) : + pairTableComplexEval n (coefficientPairTable p q) y z = + p.evalβ‚‚ (algebraMap ℝ β„‚) y * q.evalβ‚‚ (algebraMap ℝ β„‚) z := by + rw [pairTableComplexEval_eq_boolDoubleSum, + multiaffine_evalβ‚‚_eq_boolSum p hp, + multiaffine_evalβ‚‚_eq_boolSum q hq] + rw [Finset.sum_mul] + apply Finset.sum_congr rfl + intro S hS + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro T hT + simp [coefficientPairTable] + push_cast + ring + +/-- Reads the left member of each recursively encoded variable pair into a finite complex +vector. -/ +def pairVariablesLeft : + βˆ€ n : β„•, (PairVariables n β†’ β„‚) β†’ Fin n β†’ β„‚ + | 0, _, i => Fin.elim0 i + | n + 1, w, i => Fin.cases (w none) (pairVariablesLeft n ((w ∘ some) ∘ some)) i + +/-- Reads the right member of each recursively encoded variable pair into a finite complex +vector. -/ +def pairVariablesRight : + βˆ€ n : β„•, (PairVariables n β†’ β„‚) β†’ Fin n β†’ β„‚ + | 0, _, i => Fin.elim0 i + | n + 1, w, i => Fin.cases (w (some none)) (pairVariablesRight n ((w ∘ some) ∘ some)) i + +theorem pairTableStablePolynomial_eval_coordinates : + βˆ€ {n : β„•} (c : PairTable n) (w : PairVariables n β†’ β„‚), + (pairTableStablePolynomial n c).eval w = + pairTableComplexEval n c (pairVariablesLeft n w) + (fun i ↦ -pairVariablesRight n w i) := by + intro n + induction n with + | zero => intro c w; simp [pairTableStablePolynomial, pairTableComplexEval] + | succ n ih => + intro c w + change Option (Option (PairVariables n)) β†’ β„‚ at w + simp only [pairTableStablePolynomial] + change + (linearExtension + (linearExtension (pairTableStablePolynomial n (pairTableSection c false false)) + (-pairTableStablePolynomial n (pairTableSection c false true))) + (linearExtension (pairTableStablePolynomial n (pairTableSection c true false)) + (-pairTableStablePolynomial n (pairTableSection c true true)))).eval w = + pairTableComplexEval (n + 1) c + (Fin.cases (w none) (pairVariablesLeft n ((w ∘ some) ∘ some))) + (fun i ↦ -Fin.cases (w (some none)) + (pairVariablesRight n ((w ∘ some) ∘ some)) i) + rw [linearExtension_eval, linearExtension_eval, linearExtension_eval] + simp only [MvPolynomial.eval_neg] + rw [ih, ih, ih, ih] + simp only [pairTableComplexEval, pairVariablesLeft, pairVariablesRight, + Fin.cases_zero, Fin.cases_succ, Function.comp_apply] + ring + +theorem coefficientPairTable_nonnegative + {n : β„•} {p q : MvPolynomial (Fin n) ℝ} + (hp : HasNonnegativeCoefficients p) (hq : HasNonnegativeCoefficients q) : + PairTableNonnegative (coefficientPairTable p q) := by + intro S T + exact mul_nonneg (hp _) (hq _) + +theorem evalβ‚‚_conj_of_real + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) (z : Οƒ β†’ β„‚) : + p.evalβ‚‚ (algebraMap ℝ β„‚) (fun i ↦ conj (z i)) = + conj (p.evalβ‚‚ (algebraMap ℝ β„‚) z) := by + induction p using MvPolynomial.induction_on with + | C r => simp + | add p q hp hq => simp [hp, hq] + | mul_X p i hp => simp [hp, map_mul] + +theorem IsRealStable.lowerHalfPlane + {Οƒ : Type*} {p : MvPolynomial Οƒ ℝ} (hp : IsRealStable p) + (z : Οƒ β†’ β„‚) (hz : βˆ€ i, (z i).im < 0) : + p.evalβ‚‚ (algebraMap ℝ β„‚) z β‰  0 := by + have hupper : βˆ€ i, 0 < (conj (z i)).im := by + intro i + simpa using neg_pos.mpr (hz i) + have hne := hp (fun i ↦ conj (z i)) hupper + rw [evalβ‚‚_conj_of_real] at hne + intro hzero + apply hne + rw [hzero] + simp + +theorem pairVariablesLeft_upper : + βˆ€ {n : β„•} (w : PairVariables n β†’ β„‚), + (βˆ€ i, 0 < (w i).im) β†’ βˆ€ j, 0 < (pairVariablesLeft n w j).im := by + intro n + induction n with + | zero => intro w hw j; exact Fin.elim0 j + | succ n ih => + intro w hw j + change Option (Option (PairVariables n)) β†’ β„‚ at w + refine Fin.cases (hw none) (fun i ↦ ?_) j + exact ih ((w ∘ some) ∘ some) (fun k ↦ hw (some (some k))) i + +theorem pairVariablesRight_upper : + βˆ€ {n : β„•} (w : PairVariables n β†’ β„‚), + (βˆ€ i, 0 < (w i).im) β†’ βˆ€ j, 0 < (pairVariablesRight n w j).im := by + intro n + induction n with + | zero => intro w hw j; exact Fin.elim0 j + | succ n ih => + intro w hw j + change Option (Option (PairVariables n)) β†’ β„‚ at w + refine Fin.cases (hw (some none)) (fun i ↦ ?_) j + exact ih ((w ∘ some) ∘ some) (fun k ↦ hw (some (some k))) i + +theorem coefficientPairTable_stable + {n : β„•} {p q : MvPolynomial (Fin n) ℝ} + (hpMulti : IsMultiaffine p) (hqMulti : IsMultiaffine q) + (hpStable : IsRealStable p) (hqStable : IsRealStable q) : + IsUpperHalfPlaneStable + (pairTableStablePolynomial n (coefficientPairTable p q)) := by + intro w hw + rw [pairTableStablePolynomial_eval_coordinates, + coefficientPairTable_complexEval p q hpMulti hqMulti] + apply mul_ne_zero + Β· apply hpStable + exact pairVariablesLeft_upper w hw + Β· apply hqStable.lowerHalfPlane + intro i + simp only [Complex.neg_im] + exact neg_lt_zero.mpr (pairVariablesRight_upper w hw i) + +theorem pairTableDiagonalSum_eq_boolSum : + βˆ€ {n : β„•} (c : PairTable n), + pairTableDiagonalSum n c = βˆ‘ S : Fin n β†’ Bool, c S S := by + intro n + induction n with + | zero => + intro c + simp only [pairTableDiagonalSum, Fintype.sum_unique] + apply congrArgβ‚‚ c <;> apply Subsingleton.elim + | succ n ih => + intro c + rw [sum_bool_fin_succ] + simp only [Fintype.sum_bool] + change pairTableDiagonalSum (n + 1) c = + (βˆ‘ S, pairTableSection c true true S S) + + βˆ‘ S, pairTableSection c false false S S + rw [← ih (pairTableSection c true true), + ← ih (pairTableSection c false false)] + simp only [pairTableDiagonalSum] + ring + +theorem exponentBool_boolExponent {n : β„•} (S : Fin n β†’ Bool) : + exponentBool (boolExponent S) = S := by + apply boolExponent_injective + rw [boolExponent_exponentBool] + intro i + rw [boolExponent_apply] + cases S i <;> simp +theorem coefficientInnerProduct_eq_boolSum + {n : β„•} (p q : MvPolynomial (Fin n) ℝ) + (hp : IsMultiaffine p) : + coefficientInnerProduct p q = + βˆ‘ S : Fin n β†’ Bool, + p.coeff (boolExponent S) * q.coeff (boolExponent S) := by + classical + let target := (Finset.univ : Finset (Fin n β†’ Bool)).filter + (fun S ↦ boolExponent S ∈ p.support ∧ boolExponent S ∈ q.support) + have hsquarefree {d : Fin n β†’β‚€ β„•} + (hd : d ∈ p.support.filter (Β· ∈ q.support)) : βˆ€ i, d i ≀ 1 := by + intro i + have hdp : d ∈ p.support := (Finset.mem_filter.mp hd).1 + exact (MvPolynomial.monomial_le_degreeOf i hdp).trans (hp i) + have hreindex : + (βˆ‘ d ∈ p.support.filter (Β· ∈ q.support), p.coeff d * q.coeff d) = + βˆ‘ S ∈ target, p.coeff (boolExponent S) * q.coeff (boolExponent S) := by + apply Finset.sum_nbij' exponentBool boolExponent + Β· intro d hd + have heq := boolExponent_exponentBool d (hsquarefree hd) + have hdpair := Finset.mem_filter.mp hd + change exponentBool d ∈ target + rw [Finset.mem_filter] + exact ⟨Finset.mem_univ _, by simpa [heq] using hdpair⟩ + Β· intro S hS + have hpair := (Finset.mem_filter.mp hS).2 + exact Finset.mem_filter.mpr hpair + Β· intro d hd + exact boolExponent_exponentBool d (hsquarefree hd) + Β· intro S hS + exact exponentBool_boolExponent S + Β· intro d hd + rw [boolExponent_exponentBool d (hsquarefree hd)] + have htarget : + (βˆ‘ S ∈ target, p.coeff (boolExponent S) * q.coeff (boolExponent S)) = + βˆ‘ S, p.coeff (boolExponent S) * q.coeff (boolExponent S) := by + dsimp only [target] + rw [Finset.sum_filter] + apply Finset.sum_congr rfl + intro S hS + by_cases hpS : boolExponent S ∈ p.support + Β· by_cases hqS : boolExponent S ∈ q.support + Β· simp [hpS, hqS] + Β· have hqzero : q.coeff (boolExponent S) = 0 := + MvPolynomial.notMem_support_iff.mp hqS + simp [hpS, hqS, hqzero] + Β· have hpzero : p.coeff (boolExponent S) = 0 := + MvPolynomial.notMem_support_iff.mp hpS + simp [hpS, hpzero] + unfold coefficientInnerProduct + convert hreindex.trans htarget using 1 + apply Finset.sum_congr + Β· ext d + simp + Β· intro d hd + rfl + +theorem coefficientPairTable_diagonalSum + {n : β„•} (p q : MvPolynomial (Fin n) ℝ) (hp : IsMultiaffine p) : + pairTableDiagonalSum n (coefficientPairTable p q) = + coefficientInnerProduct p q := by + rw [pairTableDiagonalSum_eq_boolSum, + coefficientInnerProduct_eq_boolSum p q hp] + rfl + +theorem pairTableBoundary_eq_stableBoundaryFactor : + βˆ€ {n : β„•} (Ξ± : Fin n β†’ ℝ), + pairTableBoundary n Ξ± = stableBoundaryFactor Ξ± := by + intro n + induction n with + | zero => + intro Ξ± + simp [pairTableBoundary, stableBoundaryFactor] + | succ n ih => + intro Ξ± + simp only [pairTableBoundary] + have hdef : stableBoundaryFactor Ξ± = + ∏ i, Ξ± i ^ Ξ± i * (1 - Ξ± i) ^ (1 - Ξ± i) := rfl + rw [hdef, Fin.prod_univ_succ, ih] + have htaildef : stableBoundaryFactor (fun i : Fin n ↦ Ξ± i.succ) = + ∏ i : Fin n, Ξ± i.succ ^ Ξ± i.succ * + (1 - Ξ± i.succ) ^ (1 - Ξ± i.succ) := rfl + rw [htaildef] + rfl + +theorem pairTableMonomial_eq_realMonomial : + βˆ€ {n : β„•} (x Ξ± : Fin n β†’ ℝ), + pairTableMonomial n x Ξ± = realMonomial x Ξ± := by + intro n + induction n with + | zero => + intro x Ξ± + simp [pairTableMonomial, realMonomial] + | succ n ih => + intro x Ξ± + simp only [pairTableMonomial] + have hdef : realMonomial x Ξ± = ∏ i, x i ^ Ξ± i := rfl + rw [hdef, Fin.prod_univ_succ, ih] + have htaildef : realMonomial (fun i : Fin n ↦ x i.succ) + (fun i : Fin n ↦ Ξ± i.succ) = ∏ i : Fin n, x i.succ ^ Ξ± i.succ := rfl + rw [htaildef] + +/-- The stable-coefficient inequality on the canonical finite coordinate type. +The source theorem assumes homogeneity and a prescribed total degree, but the +coefficient-table proof only needs nonnegative coefficients, multiaffinity, +stability, and `Ξ± ∈ [0,1]^n`; we record the stronger statement exposed by the +formal proof. -/ +theorem stableCoefficient_fin + {n : β„•} (p q : MvPolynomial (Fin n) ℝ) (Ξ± : Fin n β†’ ℝ) + (hpNonneg : HasNonnegativeCoefficients p) + (hqNonneg : HasNonnegativeCoefficients q) + (hpMulti : IsMultiaffine p) (hqMulti : IsMultiaffine q) + (hpStable : IsRealStable p) (hqStable : IsRealStable q) + (hΞ± : βˆ€ i, 0 ≀ Ξ± i ∧ Ξ± i ≀ 1) : + stableBoundaryFactor Ξ± * + polynomialCapacity Ξ± p * polynomialCapacity Ξ± q ≀ + coefficientInnerProduct p q := by + have hboundary : 0 ≀ stableBoundaryFactor Ξ± := by + rw [← pairTableBoundary_eq_stableBoundaryFactor Ξ±] + exact pairTableBoundary_nonnegative hΞ± + have hcapP : 0 ≀ polynomialCapacity Ξ± p := + polynomialCapacity_nonneg hpNonneg Ξ± + have hcapQ : 0 ≀ polynomialCapacity Ξ± q := + polynomialCapacity_nonneg hqNonneg Ξ± + refine le_of_forall_pos_le_add fun Ξ΅ hΞ΅ ↦ ?_ + obtain ⟨y, z, hy, hz, hwitness⟩ := + pairTable_stableCoefficient_witness + (coefficientPairTable p q) Ξ± + (coefficientPairTable_nonnegative hpNonneg hqNonneg) + (Or.inr (coefficientPairTable_stable hpMulti hqMulti hpStable hqStable)) + hΞ± Ξ΅ hΞ΅ + have hmy : 0 < realMonomial y Ξ± := realMonomial_pos hy Ξ± + have hmz : 0 < realMonomial z Ξ± := realMonomial_pos hz Ξ± + let rp := p.eval y / realMonomial y Ξ± + let rq := q.eval z / realMonomial z Ξ± + have hrp : 0 ≀ rp := by + dsimp [rp] + exact div_nonneg + (eval_nonneg_of_nonnegativeCoefficients hpNonneg (fun i ↦ (hy i).le)) + hmy.le + have hrq : 0 ≀ rq := by + dsimp [rq] + exact div_nonneg + (eval_nonneg_of_nonnegativeCoefficients hqNonneg (fun i ↦ (hz i).le)) + hmz.le + have hcaps : + polynomialCapacity Ξ± p * polynomialCapacity Ξ± q ≀ rp * rq := by + exact mul_le_mul + (polynomialCapacity_le_ratio hpNonneg Ξ± y hy) + (polynomialCapacity_le_ratio hqNonneg Ξ± z hz) + hcapQ hrp + have hscaled := mul_le_mul_of_nonneg_left hcaps hboundary + calc + stableBoundaryFactor Ξ± * polynomialCapacity Ξ± p * + polynomialCapacity Ξ± q = + stableBoundaryFactor Ξ± * + (polynomialCapacity Ξ± p * polynomialCapacity Ξ± q) := by ring + _ ≀ stableBoundaryFactor Ξ± * (rp * rq) := hscaled + _ = stableBoundaryFactor Ξ± * + ((p.eval y * q.eval z) / + (realMonomial y Ξ± * realMonomial z Ξ±)) := by + dsimp [rp, rq] + field_simp [hmy.ne', hmz.ne'] + _ = pairTableBoundary n Ξ± * + (pairTableEval n (coefficientPairTable p q) y z / + (pairTableMonomial n y Ξ± * pairTableMonomial n z Ξ±)) := by + rw [pairTableBoundary_eq_stableBoundaryFactor, + coefficientPairTable_eval p q hpMulti hqMulti, + pairTableMonomial_eq_realMonomial, + pairTableMonomial_eq_realMonomial] + _ ≀ pairTableDiagonalSum n (coefficientPairTable p q) + Ξ΅ := hwitness + _ = coefficientInnerProduct p q + Ξ΅ := by + rw [coefficientPairTable_diagonalSum p q hpMulti] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableInduction.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableInduction.lean new file mode 100644 index 0000000000..db4c8637c3 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableInduction.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSlice +public import Mathlib.Tactic + +/-! # Source Stable Induction -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The multilinear stable-coefficient induction + +This is the source proof after its analytic content has been isolated. At +each step we contract the equal left--right coefficient, use stability of the +contraction for the induction hypothesis, and use the bivariate Rayleigh +inequality for the next pair of positive evaluation points. +-/ + +theorem pairTableBoundary_nonnegative : + βˆ€ {n : β„•} {Ξ± : Fin n β†’ ℝ}, + (βˆ€ i, 0 ≀ Ξ± i ∧ Ξ± i ≀ 1) β†’ 0 ≀ pairTableBoundary n Ξ± := by + intro n + induction n with + | zero => intro Ξ± hΞ±; norm_num [pairTableBoundary] + | succ n ih => + intro Ξ± hΞ± + simp only [pairTableBoundary] + apply mul_nonneg + Β· rw [stableBoundaryScalar] + exact mul_nonneg (Real.rpow_nonneg (hΞ± 0).1 _) + (Real.rpow_nonneg (sub_nonneg.mpr (hΞ± 0).2) _) + Β· exact ih (fun i ↦ hΞ± i.succ) + +theorem pairTableMonomial_pos : + βˆ€ {n : β„•} {x Ξ± : Fin n β†’ ℝ}, + (βˆ€ i, 0 < x i) β†’ 0 < pairTableMonomial n x Ξ± := by + intro n + induction n with + | zero => intro x Ξ± hx; norm_num [pairTableMonomial] + | succ n ih => + intro x Ξ± hx + simp only [pairTableMonomial] + exact mul_pos (Real.rpow_pos_of_pos (hx 0) _) (ih (fun i ↦ hx i.succ)) + +theorem pairTableEval_eq_zero_of_stablePolynomial_eq_zero + {n : β„•} {c : PairTable n} + (hzero : pairTableStablePolynomial n c = 0) + (y z : Fin n β†’ ℝ) : pairTableEval n c y z = 0 := by + have heval := pairTableStablePolynomial_eval_signed n c y z + rw [hzero] at heval + simp only [map_zero] at heval + exact_mod_cast heval.symm + +theorem pairTableDiagonalSum_nonnegative + {n : β„•} {c : PairTable n} (hc : PairTableNonnegative c) : + 0 ≀ pairTableDiagonalSum n c := by + induction n with + | zero => exact hc _ _ + | succ n ih => + simp only [pairTableDiagonalSum] + exact add_nonneg + (ih (pairTableSection_nonnegative hc false false)) + (ih (pairTableSection_nonnegative hc true true)) + +theorem pairTableEval_contract + {n : β„•} (c : PairTable (n + 1)) (y z : Fin n β†’ ℝ) : + pairTableEval n (pairTableContract c) y z = + pairTableEval n (pairTableSection c false false) y z + + pairTableEval n (pairTableSection c true true) y z := by + rw [pairTableContract, pairTableEval_add] + +theorem pairTableDiagonalSum_contract + {n : β„•} (c : PairTable (n + 1)) : + pairTableDiagonalSum n (pairTableContract c) = + pairTableDiagonalSum (n + 1) c := by + rw [pairTableContract, pairTableDiagonalSum_add] + rfl + +/-- Approximate-attainment form of the stable-coefficient inequality. This +is stronger than the capacity statement needed later and avoids assuming that +an infimum is attained. -/ +theorem pairTable_stableCoefficient_witness : + βˆ€ {n : β„•} (c : PairTable n) (Ξ± : Fin n β†’ ℝ), + PairTableNonnegative c β†’ PairTableStableOrZero c β†’ + (βˆ€ i, 0 ≀ Ξ± i ∧ Ξ± i ≀ 1) β†’ + βˆ€ Ξ΅ : ℝ, 0 < Ξ΅ β†’ + βˆƒ y z : Fin n β†’ ℝ, + (βˆ€ i, 0 < y i) ∧ (βˆ€ i, 0 < z i) ∧ + pairTableBoundary n Ξ± * + (pairTableEval n c y z / + (pairTableMonomial n y Ξ± * pairTableMonomial n z Ξ±)) ≀ + pairTableDiagonalSum n c + Ξ΅ := by + intro n + induction n with + | zero => + intro c Ξ± hc hstable hΞ± Ξ΅ hΞ΅ + let y : Fin 0 β†’ ℝ := fun i ↦ Fin.elim0 i + let z : Fin 0 β†’ ℝ := fun i ↦ Fin.elim0 i + refine ⟨y, z, ?_, ?_, ?_⟩ + Β· intro i; exact Fin.elim0 i + Β· intro i; exact Fin.elim0 i + Β· simp only [pairTableBoundary, pairTableMonomial, pairTableEval, + pairTableDiagonalSum, one_mul, div_one] + linarith + | succ n ih => + intro c Ξ± hc hstable hΞ± Ξ΅ hΞ΅ + rcases hstable with hzero | hstable + Β· let y : Fin (n + 1) β†’ ℝ := fun _ ↦ 1 + let z : Fin (n + 1) β†’ ℝ := fun _ ↦ 1 + refine ⟨y, z, (fun _ ↦ by norm_num [y]), (fun _ ↦ by norm_num [z]), ?_⟩ + have heval : pairTableEval (n + 1) c y z = 0 := + pairTableEval_eq_zero_of_stablePolynomial_eq_zero hzero y z + rw [heval, zero_div, mul_zero] + exact le_add_of_nonneg_right hΞ΅.le |>.trans' + (pairTableDiagonalSum_nonnegative hc) + Β· let Ξ±t : Fin n β†’ ℝ := fun i ↦ Ξ± i.succ + have hΞ±t : βˆ€ i, 0 ≀ Ξ±t i ∧ Ξ±t i ≀ 1 := fun i ↦ hΞ± i.succ + have hcContract : PairTableNonnegative (pairTableContract c) := + pairTableContract_nonnegative hc + have hsContract : PairTableStableOrZero (pairTableContract c) := + pairTableContract_stableOrZero c (Or.inr hstable) + obtain ⟨yt, zt, hyt, hzt, htail⟩ := + ih (pairTableContract c) Ξ±t hcContract hsContract hΞ±t (Ξ΅ / 2) (half_pos hΞ΅) + let tailBoundary := pairTableBoundary n Ξ±t + let my := pairTableMonomial n yt Ξ±t + let mz := pairTableMonomial n zt Ξ±t + have hmy : 0 < my := pairTableMonomial_pos hyt + have hmz : 0 < mz := pairTableMonomial_pos hzt + have htailBoundary : 0 ≀ tailBoundary := pairTableBoundary_nonnegative hΞ±t + let K := tailBoundary / (my * mz) + have hK : 0 ≀ K := div_nonneg htailBoundary (mul_pos hmy hmz).le + let Ξ΄ := Ξ΅ / (2 * (K + 1)) + have hΞ΄ : 0 < Ξ΄ := by + dsimp [Ξ΄] + positivity + let a := pairTableEval n (pairTableSection c true true) yt zt + let b := pairTableEval n (pairTableSection c true false) yt zt + let cc := pairTableEval n (pairTableSection c false true) yt zt + let d := pairTableEval n (pairTableSection c false false) yt zt + have ha : 0 ≀ a := pairTableEval_nonnegative + (pairTableSection_nonnegative hc true true) + (fun i ↦ (hyt i).le) (fun i ↦ (hzt i).le) + have hb : 0 ≀ b := pairTableEval_nonnegative + (pairTableSection_nonnegative hc true false) + (fun i ↦ (hyt i).le) (fun i ↦ (hzt i).le) + have hcc : 0 ≀ cc := pairTableEval_nonnegative + (pairTableSection_nonnegative hc false true) + (fun i ↦ (hyt i).le) (fun i ↦ (hzt i).le) + have hd : 0 ≀ d := pairTableEval_nonnegative + (pairTableSection_nonnegative hc false false) + (fun i ↦ (hyt i).le) (fun i ↦ (hzt i).le) + have hrayleigh : b * cc ≀ a * d := by + exact pairTable_slice_rayleigh hc hstable yt zt hyt hzt + obtain ⟨Y, Z, hY, hZ, hlocal⟩ := + exists_bivariate_capacity_witness_nonnegative + (hΞ± 0) ha hb hcc hd hrayleigh hΞ΄ + let y : Fin (n + 1) β†’ ℝ := Fin.cases Y yt + let z : Fin (n + 1) β†’ ℝ := Fin.cases Z zt + refine ⟨y, z, ?_, ?_, ?_⟩ + Β· intro i + refine Fin.cases hY (fun j ↦ ?_) i + simpa [y] using hyt j + Β· intro i + refine Fin.cases hZ (fun j ↦ ?_) i + simpa [z] using hzt j + Β· have hKΞ΄ : K * Ξ΄ ≀ Ξ΅ / 2 := by + dsimp [Ξ΄] + rw [← mul_div_assoc] + apply (div_le_iffβ‚€ (by positivity : 0 < 2 * (K + 1))).2 + nlinarith + have hlocalScaled := mul_le_mul_of_nonneg_left hlocal hK + have htail' : K * (a + d) ≀ pairTableDiagonalSum (n + 1) c + Ξ΅ / 2 := by + dsimp [K, a, d] + rw [add_comm, ← pairTableEval_contract, + ← pairTableDiagonalSum_contract] + change tailBoundary / (my * mz) * + pairTableEval n (pairTableContract c) yt zt ≀ + pairTableDiagonalSum n (pairTableContract c) + Ξ΅ / 2 + calc + tailBoundary / (my * mz) * + pairTableEval n (pairTableContract c) yt zt = + tailBoundary * + (pairTableEval n (pairTableContract c) yt zt / (my * mz)) := by + field_simp [(mul_pos hmy hmz).ne'] + _ ≀ pairTableDiagonalSum n (pairTableContract c) + Ξ΅ / 2 := by + simpa [tailBoundary, my, mz] using htail + have hcombined : + K * (stableBoundaryScalar (Ξ± 0) * + ((a * Y * Z + b * Y + cc * Z + d) / (Y * Z) ^ (Ξ± 0))) ≀ + pairTableDiagonalSum (n + 1) c + Ξ΅ := by + calc + _ ≀ K * (a + d + Ξ΄) := hlocalScaled + _ = K * (a + d) + K * Ξ΄ := by ring + _ ≀ (pairTableDiagonalSum (n + 1) c + Ξ΅ / 2) + Ξ΅ / 2 := + add_le_add htail' hKΞ΄ + _ = pairTableDiagonalSum (n + 1) c + Ξ΅ := by ring + have hdenfactor : + pairTableMonomial (n + 1) y Ξ± * pairTableMonomial (n + 1) z Ξ± = + (Y * Z) ^ (Ξ± 0) * (my * mz) := by + simp only [pairTableMonomial] + change (Y ^ (Ξ± 0) * my) * (Z ^ (Ξ± 0) * mz) = _ + rw [Real.mul_rpow hY.le hZ.le] + ring + have heval : pairTableEval (n + 1) c y z = + a * Y * Z + b * Y + cc * Z + d := by + simp only [pairTableEval] + rfl + rw [pairTableBoundary, heval, hdenfactor] + dsimp [K, tailBoundary, my, mz] at hcombined + have hdenTail : 0 < my * mz := mul_pos hmy hmz + have hdenHead : 0 < (Y * Z) ^ (Ξ± 0) := + Real.rpow_pos_of_pos (mul_pos hY hZ) _ + calc + stableBoundaryScalar (Ξ± 0) * pairTableBoundary n Ξ±t * + ((a * Y * Z + b * Y + cc * Z + d) / + ((Y * Z) ^ (Ξ± 0) * (my * mz))) = + (pairTableBoundary n Ξ±t / (my * mz)) * + (stableBoundaryScalar (Ξ± 0) * + ((a * Y * Z + b * Y + cc * Z + d) / (Y * Z) ^ (Ξ± 0))) := by + field_simp [hdenTail.ne', hdenHead.ne'] + _ ≀ pairTableDiagonalSum (n + 1) c + Ξ΅ := hcombined + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableReindex.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableReindex.lean new file mode 100644 index 0000000000..b37837fbfd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableReindex.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableEncoding +public import Mathlib.Tactic + +/-! # Source Stable Reindex -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Transporting the stable-coefficient theorem across finite coordinate types + +The coefficient-table induction is most naturally indexed by `Fin n`. This +file proves that all quantities in the theorem are invariant under a bijective +renaming of variables, and hence transports the result to an arbitrary finite +type. No mathematical theorem is hidden in this bookkeeping layer. +-/ + +open MvPolynomial + +theorem renameEquiv_nonnegativeCoefficients + {Οƒ Ο„ : Type*} (e : Οƒ ≃ Ο„) {p : MvPolynomial Οƒ ℝ} + (hp : HasNonnegativeCoefficients p) : + HasNonnegativeCoefficients (MvPolynomial.rename e p) := by + intro d + have hcoeff : + (MvPolynomial.rename e p).coeff d = + p.coeff (d.mapDomain e.symm) := by + have h := MvPolynomial.coeff_rename_mapDomain + e.symm e.symm.injective (MvPolynomial.rename e p) d + have hrename : + MvPolynomial.rename e.symm (MvPolynomial.rename e p) = p := + MvPolynomial.rename_leftInverse e.left_inv p + rw [hrename] at h + exact h.symm + rw [hcoeff] + exact hp _ + +theorem renameEquiv_multiaffine + {Οƒ Ο„ : Type*} (e : Οƒ ≃ Ο„) {p : MvPolynomial Οƒ ℝ} + (hp : IsMultiaffine p) : + IsMultiaffine (MvPolynomial.rename e p) := by + intro j + have hdegree := + MvPolynomial.degreeOf_rename_of_injective (R := ℝ) (p := p) + e.injective (e.symm j) + rw [e.apply_symm_apply] at hdegree + rw [hdegree] + exact hp (e.symm j) + +theorem stableBoundaryFactor_equiv + {Οƒ Ο„ : Type*} [Fintype Οƒ] [Fintype Ο„] + (e : Οƒ ≃ Ο„) (Ξ± : Οƒ β†’ ℝ) : + stableBoundaryFactor (fun j ↦ Ξ± (e.symm j)) = + stableBoundaryFactor Ξ± := by + unfold stableBoundaryFactor + exact e.symm.prod_comp + (fun i ↦ Ξ± i ^ Ξ± i * (1 - Ξ± i) ^ (1 - Ξ± i)) + +theorem realMonomial_equiv + {Οƒ Ο„ : Type*} [Fintype Οƒ] [Fintype Ο„] + (e : Οƒ ≃ Ο„) (z Ξ± : Οƒ β†’ ℝ) : + realMonomial (fun j ↦ z (e.symm j)) (fun j ↦ Ξ± (e.symm j)) = + realMonomial z Ξ± := by + unfold realMonomial + exact e.symm.prod_comp (fun i ↦ z i ^ Ξ± i) + +theorem renameEquiv_eval + {Οƒ Ο„ : Type*} (e : Οƒ ≃ Ο„) (p : MvPolynomial Οƒ ℝ) + (z : Οƒ β†’ ℝ) : + (MvPolynomial.rename e p).eval (fun j ↦ z (e.symm j)) = p.eval z := by + rw [MvPolynomial.eval_rename] + apply congrArg (fun w : Οƒ β†’ ℝ ↦ p.eval w) + funext i + simpa only [Function.comp_apply] using congrArg z (e.symm_apply_apply i) + +theorem polynomialCapacity_renameEquiv + {Οƒ Ο„ : Type*} [Fintype Οƒ] [Fintype Ο„] + (e : Οƒ ≃ Ο„) {p : MvPolynomial Οƒ ℝ} + (hp : HasNonnegativeCoefficients p) (Ξ± : Οƒ β†’ ℝ) : + polynomialCapacity (fun j ↦ Ξ± (e.symm j)) + (MvPolynomial.rename e p) = + polynomialCapacity Ξ± p := by + let p' := MvPolynomial.rename e p + let Ξ±' : Ο„ β†’ ℝ := fun j ↦ Ξ± (e.symm j) + have hp' : HasNonnegativeCoefficients p' := + renameEquiv_nonnegativeCoefficients e hp + apply le_antisymm + Β· apply le_polynomialCapacity_of_le_ratio + intro z hz + let z' : Ο„ β†’ ℝ := fun j ↦ z (e.symm j) + have hz' : βˆ€ j, 0 < z' j := fun j ↦ hz (e.symm j) + have h := polynomialCapacity_le_ratio hp' Ξ±' z' hz' + simpa only [p', Ξ±', z', renameEquiv_eval, + realMonomial_equiv] using h + Β· apply le_polynomialCapacity_of_le_ratio + intro z hz + let z' : Οƒ β†’ ℝ := fun i ↦ z (e i) + have hz' : βˆ€ i, 0 < z' i := fun i ↦ hz (e i) + have h := polynomialCapacity_le_ratio hp Ξ± z' hz' + have heval : p.eval z' = p'.eval z := by + dsimp only [p', z'] + rw [MvPolynomial.eval_rename] + rfl + have hmonomial : realMonomial z' Ξ± = realMonomial z Ξ±' := by + rw [show z' = fun i ↦ z (e i) by rfl] + rw [show Ξ± = fun i ↦ Ξ±' (e i) by + funext i + simp [Ξ±']] + unfold realMonomial + exact e.prod_comp (fun j ↦ z j ^ Ξ±' j) + simpa only [heval, hmonomial] using h + +theorem coefficientInnerProduct_renameEquiv + {Οƒ Ο„ : Type*} (e : Οƒ ≃ Ο„) (p q : MvPolynomial Οƒ ℝ) : + coefficientInnerProduct (MvPolynomial.rename e p) + (MvPolynomial.rename e q) = + coefficientInnerProduct p q := by + classical + let E : (Οƒ β†’β‚€ β„•) ≃ (Ο„ β†’β‚€ β„•) := (Finsupp.domCongr e).toEquiv + have hE (d : Οƒ β†’β‚€ β„•) : E d = d.mapDomain e := by + change Finsupp.equivMapDomain e d = d.mapDomain e + exact Finsupp.equivMapDomain_eq_mapDomain e d + have hmem (d : Οƒ β†’β‚€ β„•) : + d ∈ p.support.filter (Β· ∈ q.support) ↔ + E d ∈ (MvPolynomial.rename e p).support.filter + (Β· ∈ (MvPolynomial.rename e q).support) := by + simp only [Finset.mem_filter] + have hpSupport := MvPolynomial.support_rename_of_injective + (p := p) e.injective + have hqSupport := MvPolynomial.support_rename_of_injective + (p := q) e.injective + rw [hpSupport, hqSupport, hE] + simp only [Finset.mem_image] + constructor + Β· rintro ⟨hdp, hdq⟩ + exact ⟨⟨d, hdp, rfl⟩, d, hdq, rfl⟩ + Β· rintro ⟨⟨a, hap, ha⟩, b, hbq, hb⟩ + have had : a = d := Finsupp.mapDomain_injective e.injective ha + have hbd : b = d := Finsupp.mapDomain_injective e.injective hb + simpa only [had, hbd] using And.intro hap hbq + have hsum : + (βˆ‘ d ∈ p.support.filter (Β· ∈ q.support), + p.coeff d * q.coeff d) = + βˆ‘ d ∈ (MvPolynomial.rename e p).support.filter + (Β· ∈ (MvPolynomial.rename e q).support), + (MvPolynomial.rename e p).coeff d * + (MvPolynomial.rename e q).coeff d := by + apply Finset.sum_equiv E hmem + intro d hd + rw [hE] + simp only [MvPolynomial.coeff_rename_mapDomain e e.injective] + unfold coefficientInnerProduct + symm + convert hsum using 1 + +/-- The Anari--Oveis Gharan stable-coefficient inequality, reconstructed from +its bivariate analytic lemma and multilinear induction and transported from +`Fin n` to every finite coordinate type. -/ +theorem anariOveisGharanStableCoefficient : + AnariOveisGharanStableCoefficient := by + intro Οƒ inst p q d Ξ± hpNonneg hqNonneg hpMulti hqMulti + hpStable hqStable hpHomogeneous hqHomogeneous hΞ± hΞ±sum + let e : Οƒ ≃ Fin (Fintype.card Οƒ) := Fintype.equivFin Οƒ + let p' := MvPolynomial.rename e p + let q' := MvPolynomial.rename e q + let Ξ±' : Fin (Fintype.card Οƒ) β†’ ℝ := fun j ↦ Ξ± (e.symm j) + have hfin := stableCoefficient_fin p' q' Ξ±' + (renameEquiv_nonnegativeCoefficients e hpNonneg) + (renameEquiv_nonnegativeCoefficients e hqNonneg) + (renameEquiv_multiaffine e hpMulti) + (renameEquiv_multiaffine e hqMulti) + (hpStable.rename e) (hqStable.rename e) + (fun j ↦ hΞ± (e.symm j)) + have hboundary : stableBoundaryFactor Ξ±' = stableBoundaryFactor Ξ± := + stableBoundaryFactor_equiv e Ξ± + have hcapP : polynomialCapacity Ξ±' p' = polynomialCapacity Ξ± p := + polynomialCapacity_renameEquiv e hpNonneg Ξ± + have hcapQ : polynomialCapacity Ξ±' q' = polynomialCapacity Ξ± q := + polynomialCapacity_renameEquiv e hqNonneg Ξ± + have hinner : coefficientInnerProduct p' q' = coefficientInnerProduct p q := + coefficientInnerProduct_renameEquiv e p q + rw [hboundary, hcapP, hcapQ, hinner] at hfin + exact hfin + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableSlice.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableSlice.lean new file mode 100644 index 0000000000..1254cc1c8a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableSlice.lean @@ -0,0 +1,257 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableSpecialization +public import Mathlib.Tactic + +/-! # Source Stable Slice -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# The stable bivariate slice of a coefficient table + +We now justify the bivariate polynomial used at one induction step. All tail +variables are placed on the real boundary, with the right variables sign +reversed. The finite closure theorem says that the resulting polynomial in +the next left--right pair is stable or zero. +-/ + +/-- Assigns `y` to left variables and `-z` to right variables in the recursive paired-variable +encoding. -/ +def pairVariablesSignedRealPoint : + βˆ€ n : β„•, (Fin n β†’ ℝ) β†’ (Fin n β†’ ℝ) β†’ PairVariables n β†’ ℝ + | 0, _, _, i => PEmpty.elim i + | n + 1, y, z, none => y 0 + | n + 1, y, z, some none => -z 0 + | n + 1, y, z, some (some i) => + pairVariablesSignedRealPoint n (fun j ↦ y j.succ) (fun j ↦ z j.succ) i + +theorem pairTableStablePolynomial_eval_signed : + βˆ€ (n : β„•) (c : PairTable n) (y z : Fin n β†’ ℝ), + (pairTableStablePolynomial n c).eval + (fun i ↦ (pairVariablesSignedRealPoint n y z i : β„‚)) = + (pairTableEval n c y z : β„‚) := by + intro n + induction n with + | zero => + intro c y z + simp [pairTableStablePolynomial, pairTableEval] + | succ n ih => + intro c y z + let yt : Fin n β†’ ℝ := fun i ↦ y i.succ + let zt : Fin n β†’ ℝ := fun i ↦ z i.succ + let w : Option (Option (PairVariables n)) β†’ β„‚ + | none => (y 0 : β„‚) + | some none => -(z 0 : β„‚) + | some (some i) => (pairVariablesSignedRealPoint n yt zt i : β„‚) + simp only [pairTableStablePolynomial, pairTableEval] + change PairVariables (n + 1) β†’ β„‚ at w + have hpoint : + (fun i ↦ (pairVariablesSignedRealPoint (n + 1) y z i : β„‚)) = w := by + funext i + change Option (Option (PairVariables n)) at i + cases i with + | none => rfl + | some i => + cases i with + | none => simp [w, pairVariablesSignedRealPoint] + | some i => rfl + rw [hpoint] + change Option (Option (PairVariables n)) β†’ β„‚ at w + change + (linearExtension + (linearExtension (pairTableStablePolynomial n (pairTableSection c false false)) + (-pairTableStablePolynomial n (pairTableSection c false true))) + (linearExtension (pairTableStablePolynomial n (pairTableSection c true false)) + (-pairTableStablePolynomial n (pairTableSection c true true)))).eval + w = _ + rw [linearExtension_eval, linearExtension_eval, linearExtension_eval] + have hcomp : + (w ∘ some) ∘ some = + fun i ↦ (pairVariablesSignedRealPoint n yt zt i : β„‚) := by + funext i + rfl + have hnone : w none = y 0 := rfl + have hsomeNone : (w ∘ some) none = -(z 0 : β„‚) := by rfl + rw [hcomp, hnone, hsomeNone] + simp only [MvPolynomial.eval_neg] + rw [ + ih (pairTableSection c false false) yt zt, + ih (pairTableSection c false true) yt zt, + ih (pairTableSection c true false) yt zt, + ih (pairTableSection c true true) yt zt] + push_cast + ring + +/-- Separate the tail variables from the next left--right pair. `false` is +the new left variable and `true` the new (sign-reversed) right variable. -/ +def pairHeadTailEquiv (n : β„•) : + PairVariables (n + 1) ≃ PairVariables n βŠ• Bool where + toFun + | none => Sum.inr false + | some none => Sum.inr true + | some (some i) => Sum.inl i + invFun + | Sum.inr false => none + | Sum.inr true => some none + | Sum.inl i => some (some i) + left_inv x := by + change Option (Option (PairVariables n)) at x + cases x with + | none => rfl + | some x => cases x <;> rfl + right_inv x := by + cases x with + | inl x => rfl + | inr x => cases x <;> rfl + +/-- Renames the signed pair-table polynomial into tail variables and a Boolean-indexed head +pair. -/ +noncomputable def pairTableHeadPolynomial + {n : β„•} (c : PairTable (n + 1)) : + MvPolynomial (PairVariables n βŠ• Bool) β„‚ := + MvPolynomial.rename (pairHeadTailEquiv n) (pairTableStablePolynomial (n + 1) c) + +theorem pairTableHeadPolynomial_multiaffine + {n : β„•} (c : PairTable (n + 1)) : + IsComplexMultiaffine (pairTableHeadPolynomial c) := by + intro i + change MvPolynomial.degreeOf i + (MvPolynomial.rename (pairHeadTailEquiv n) + (pairTableStablePolynomial (n + 1) c)) ≀ 1 + have hdegree := MvPolynomial.degreeOf_rename_of_injective + (pairHeadTailEquiv n).injective ((pairHeadTailEquiv n).symm i) + (p := pairTableStablePolynomial (n + 1) c) + convert hdegree.trans_le + (pairTableStablePolynomial_multiaffine c ((pairHeadTailEquiv n).symm i)) using 1 + simp + +theorem pairTableHeadPolynomial_stable + {n : β„•} {c : PairTable (n + 1)} + (hstable : IsUpperHalfPlaneStable (pairTableStablePolynomial (n + 1) c)) : + IsUpperHalfPlaneStable (pairTableHeadPolynomial c) := by + exact hstable.rename (pairHeadTailEquiv n) + +/-- Specializes all tail variables at the signed real point, retaining the two head variables as +a complex bivariate polynomial. -/ +noncomputable def pairTableBivariateSlice + {n : β„•} (c : PairTable (n + 1)) + (y z : Fin n β†’ ℝ) : MvPolynomial Bool β„‚ := + partialSpecialization (pairTableHeadPolynomial c) + (pairVariablesSignedRealPoint n y z) + +theorem pairTableBivariateSlice_eval + {n : β„•} (c : PairTable (n + 1)) (y z : Fin n β†’ ℝ) + (Y Z : β„‚) : + (pairTableBivariateSlice c y z).eval (fun b ↦ bif b then Z else Y) = + -(pairTableEval n (pairTableSection c true true) y z : β„‚) * Y * Z + + (pairTableEval n (pairTableSection c true false) y z : β„‚) * Y - + (pairTableEval n (pairTableSection c false true) y z : β„‚) * Z + + (pairTableEval n (pairTableSection c false false) y z : β„‚) := by + rw [pairTableBivariateSlice, partialSpecialization_eval, + pairTableHeadPolynomial, MvPolynomial.eval_rename] + let w : PairVariables (n + 1) β†’ β„‚ := + fun i ↦ Sum.elim + (fun j ↦ (pairVariablesSignedRealPoint n y z j : β„‚)) + (fun b ↦ bif b then Z else Y) (pairHeadTailEquiv n i) + change Option (Option (PairVariables n)) β†’ β„‚ at w + change (pairTableStablePolynomial (n + 1) c).eval w = _ + simp only [pairTableStablePolynomial] + change + (linearExtension + (linearExtension (pairTableStablePolynomial n (pairTableSection c false false)) + (-pairTableStablePolynomial n (pairTableSection c false true))) + (linearExtension (pairTableStablePolynomial n (pairTableSection c true false)) + (-pairTableStablePolynomial n (pairTableSection c true true)))).eval w = _ + rw [linearExtension_eval, linearExtension_eval, linearExtension_eval] + have htail : (w ∘ some) ∘ some = + fun i ↦ (pairVariablesSignedRealPoint n y z i : β„‚) := by + funext i + rfl + have hy : w none = Y := by rfl + have hz : (w ∘ some) none = Z := by rfl + rw [htail, hy, hz] + simp only [MvPolynomial.eval_neg] + rw [ + pairTableStablePolynomial_eval_signed, + pairTableStablePolynomial_eval_signed, + pairTableStablePolynomial_eval_signed, + pairTableStablePolynomial_eval_signed] + ring + +theorem pairTableBivariateSlice_stableOrZero + {n : β„•} {c : PairTable (n + 1)} + (y z : Fin n β†’ ℝ) + (hstable : IsUpperHalfPlaneStable (pairTableStablePolynomial (n + 1) c)) : + pairTableBivariateSlice c y z = 0 ∨ + IsUpperHalfPlaneStable (pairTableBivariateSlice c y z) := by + exact pairVariables_partialSpecialization_stableOrZero n + (pairTableHeadPolynomial c) (pairVariablesSignedRealPoint n y z) + (pairTableHeadPolynomial_multiaffine c) + (pairTableHeadPolynomial_stable hstable) + +/-- The coefficient determinant inequality for every real tail specialization. +This is the exact local consequence of stability consumed by the scalar +capacity lemma. -/ +theorem pairTable_slice_rayleigh + {n : β„•} {c : PairTable (n + 1)} + (hc : PairTableNonnegative c) + (hstable : IsUpperHalfPlaneStable (pairTableStablePolynomial (n + 1) c)) + (y z : Fin n β†’ ℝ) (hy : βˆ€ i, 0 < y i) (hz : βˆ€ i, 0 < z i) : + pairTableEval n (pairTableSection c true false) y z * + pairTableEval n (pairTableSection c false true) y z ≀ + pairTableEval n (pairTableSection c true true) y z * + pairTableEval n (pairTableSection c false false) y z := by + let a := pairTableEval n (pairTableSection c true true) y z + let b := pairTableEval n (pairTableSection c true false) y z + let cc := pairTableEval n (pairTableSection c false true) y z + let d := pairTableEval n (pairTableSection c false false) y z + have hy' : βˆ€ i, 0 ≀ y i := fun i ↦ (hy i).le + have hz' : βˆ€ i, 0 ≀ z i := fun i ↦ (hz i).le + have ha : 0 ≀ a := pairTableEval_nonnegative + (pairTableSection_nonnegative hc true true) hy' hz' + have hb : 0 ≀ b := pairTableEval_nonnegative + (pairTableSection_nonnegative hc true false) hy' hz' + have hcc : 0 ≀ cc := pairTableEval_nonnegative + (pairTableSection_nonnegative hc false true) hy' hz' + have hd : 0 ≀ d := pairTableEval_nonnegative + (pairTableSection_nonnegative hc false false) hy' hz' + rcases pairTableBivariateSlice_stableOrZero y z hstable with hzero | hs + Β· have heval : + (pairTableBivariateSlice c y z).eval + (fun q ↦ bif q then (0 : β„‚) else 1) = + (0 : MvPolynomial Bool β„‚).eval + (fun q ↦ bif q then (0 : β„‚) else 1) := by + exact congrArg + (fun p : MvPolynomial Bool β„‚ ↦ + p.eval (fun q ↦ bif q then (0 : β„‚) else 1)) hzero + rw [pairTableBivariateSlice_eval] at heval + have hbzero : b = 0 := by + have hsum : (b : β„‚) + (d : β„‚) = 0 := by + simpa [a, b, cc, d] using heval + have hre := congrArg Complex.re hsum + simp only [Complex.add_re, Complex.ofReal_re, Complex.zero_re] at hre + linarith + change b * cc ≀ a * d + rw [hbzero, zero_mul] + exact mul_nonneg ha hd + Β· have hbistable : BivariateBistable a b cc d := by + intro Y Z hY hZ + have hne := hs (fun q ↦ bif q then Z else Y) (by + intro q + cases q with + | false => simpa using hY + | true => simpa using hZ) + rw [pairTableBivariateSlice_eval] at hne + simpa only [a, b, cc, d] using hne + exact bivariate_rayleigh_of_bistable ha hb hcc hd hbistable + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableSpecialization.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableSpecialization.lean new file mode 100644 index 0000000000..d6175659fd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableSpecialization.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableClosure +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableTable +public import Mathlib.Tactic + +/-! # Source Stable Specialization -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# Finite real-boundary specialization + +The source induction freezes every variable except the next left--right pair. +This file proves that operation from the one-coordinate closure theorem. The +proof keeps the two classes of variables separated by a sum type and performs +an explicit induction on the recursively finite type `PairVariables`. +-/ + +/-- Evaluates the left summand variables at real constants while retaining the right summand as +polynomial variables. -/ +noncomputable def partialSpecialization + {ΞΊ Ο„ : Type*} (p : MvPolynomial (ΞΊ βŠ• Ο„) β„‚) (x : ΞΊ β†’ ℝ) : + MvPolynomial Ο„ β„‚ := + p.evalβ‚‚ MvPolynomial.C (Sum.elim (fun i ↦ MvPolynomial.C (x i : β„‚)) MvPolynomial.X) + +@[simp] +theorem partialSpecialization_eval + {ΞΊ Ο„ : Type*} (p : MvPolynomial (ΞΊ βŠ• Ο„) β„‚) (x : ΞΊ β†’ ℝ) + (z : Ο„ β†’ β„‚) : + (partialSpecialization p x).eval z = + p.eval (Sum.elim (fun i ↦ (x i : β„‚)) z) := by + change MvPolynomial.evalβ‚‚ (RingHom.id β„‚) z + (p.evalβ‚‚ MvPolynomial.C + (Sum.elim (fun i ↦ MvPolynomial.C (x i : β„‚)) MvPolynomial.X)) = _ + rw [← MvPolynomial.evalβ‚‚_assoc] + apply MvPolynomial.evalβ‚‚_congr + intro i d hi hd + cases i with + | inl i => simp + | inr i => simp + +theorem partialSpecialization_zero + {ΞΊ Ο„ : Type*} (x : ΞΊ β†’ ℝ) : + partialSpecialization (0 : MvPolynomial (ΞΊ βŠ• Ο„) β„‚) x = 0 := by + simp [partialSpecialization] + +/-- Move the distinguished `none` coordinate of `Option ΞΊ` in front of all +remaining variables. -/ +def optionSumEquiv (ΞΊ Ο„ : Type*) : (Option ΞΊ βŠ• Ο„) ≃ Option (ΞΊ βŠ• Ο„) where + toFun + | Sum.inl none => none + | Sum.inl (some i) => some (Sum.inl i) + | Sum.inr j => some (Sum.inr j) + invFun + | none => Sum.inl none + | some (Sum.inl i) => Sum.inl (some i) + | some (Sum.inr j) => Sum.inr j + left_inv x := by cases x with + | inl x => cases x <;> rfl + | inr x => rfl + right_inv x := by cases x with + | none => rfl + | some x => cases x <;> rfl + +/-- Renames the distinguished variable in the left summand into an optional variable over the +combined remaining indices. -/ +noncomputable def sumOptionReindex + {ΞΊ Ο„ : Type*} (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) : + MvPolynomial (Option (ΞΊ βŠ• Ο„)) β„‚ := + MvPolynomial.rename (optionSumEquiv ΞΊ Ο„) p + +/-- Forms the distinguished constant coefficient plus `c` times its linear coefficient after +sum-option reindexing. -/ +noncomputable def sumOptionSpecialization + {ΞΊ Ο„ : Type*} (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) (c : ℝ) : + MvPolynomial (ΞΊ βŠ• Ο„) β„‚ := + optionConstantCoefficient (sumOptionReindex p) + + MvPolynomial.C (c : β„‚) * optionLinearCoefficient (sumOptionReindex p) + +theorem sumOptionReindex_multiaffine + {ΞΊ Ο„ : Type*} {p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚} + (hp : IsComplexMultiaffine p) : + IsComplexMultiaffine (sumOptionReindex p) := by + intro i + change MvPolynomial.degreeOf i + (MvPolynomial.rename (optionSumEquiv ΞΊ Ο„) p) ≀ 1 + have hdegree := MvPolynomial.degreeOf_rename_of_injective + (optionSumEquiv ΞΊ Ο„).injective ((optionSumEquiv ΞΊ Ο„).symm i) (p := p) + convert hdegree.trans_le (hp ((optionSumEquiv ΞΊ Ο„).symm i)) using 1 + simp + +theorem sumOptionReindex_stable + {ΞΊ Ο„ : Type*} {p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚} + (hp : IsUpperHalfPlaneStable p) : + IsUpperHalfPlaneStable (sumOptionReindex p) := by + exact hp.rename (optionSumEquiv ΞΊ Ο„) + +theorem sumOptionSpecialization_multiaffine + {ΞΊ Ο„ : Type*} (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) (c : ℝ) + (hp : IsComplexMultiaffine p) : + IsComplexMultiaffine (sumOptionSpecialization p c) := by + exact option_specialization_multiaffine (sumOptionReindex p) c + (sumOptionReindex_multiaffine hp) + +theorem sumOptionSpecialization_stableOrZero + {ΞΊ Ο„ : Type*} [Fintype ΞΊ] [Fintype Ο„] + (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) (c : ℝ) + (hmulti : IsComplexMultiaffine p) + (hstable : IsUpperHalfPlaneStable p) : + sumOptionSpecialization p c = 0 ∨ + IsUpperHalfPlaneStable (sumOptionSpecialization p c) := by + exact option_specialize_real_stableOrZero (sumOptionReindex p) c + (sumOptionReindex_multiaffine hmulti none) + (sumOptionReindex_stable hstable) + +@[simp] +theorem optionSumEquiv_apply_inl_none {ΞΊ Ο„ : Type*} : + optionSumEquiv ΞΊ Ο„ (Sum.inl none) = none := rfl + +@[simp] +theorem optionSumEquiv_apply_inl_some {ΞΊ Ο„ : Type*} (i : ΞΊ) : + optionSumEquiv ΞΊ Ο„ (Sum.inl (some i)) = some (Sum.inl i) := rfl + +@[simp] +theorem optionSumEquiv_apply_inr {ΞΊ Ο„ : Type*} (j : Ο„) : + optionSumEquiv ΞΊ Ο„ (Sum.inr j) = some (Sum.inr j) := rfl + +theorem sumOptionSpecialization_eval + {ΞΊ Ο„ : Type*} (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) (c : ℝ) + (hmulti : IsComplexMultiaffine p) (z : ΞΊ βŠ• Ο„ β†’ β„‚) : + (sumOptionSpecialization p c).eval z = + p.eval (Sum.elim (fun + | none => (c : β„‚) + | some i => z (Sum.inl i)) (fun j => z (Sum.inr j))) := by + let w : Option (ΞΊ βŠ• Ο„) β†’ β„‚ + | none => (c : β„‚) + | some i => z i + have hlinear := option_eq_linearExtension (sumOptionReindex p) + (sumOptionReindex_multiaffine hmulti none) + have heval : (sumOptionReindex p).eval w = + (linearExtension + (optionConstantCoefficient (sumOptionReindex p)) + (optionLinearCoefficient (sumOptionReindex p))).eval w := by + exact congrArg + (fun q : MvPolynomial (Option (ΞΊ βŠ• Ο„)) β„‚ ↦ q.eval w) hlinear + rw [linearExtension_eval] at heval + have hwcomp : w ∘ some = z := by rfl + rw [hwcomp] at heval + calc + (sumOptionSpecialization p c).eval z = + (optionConstantCoefficient (sumOptionReindex p)).eval z + + (c : β„‚) * (optionLinearCoefficient (sumOptionReindex p)).eval z := by + simp [sumOptionSpecialization] + _ = (sumOptionReindex p).eval w := by + exact heval.symm + _ = p.eval (Sum.elim (fun + | none => (c : β„‚) + | some i => z (Sum.inl i)) (fun j => z (Sum.inr j))) := by + rw [sumOptionReindex, MvPolynomial.eval_rename] + apply congrArg (fun u ↦ p.eval u) + funext i + cases i with + | inl i => cases i <;> rfl + | inr i => rfl + +theorem partialSpecialization_option + {ΞΊ Ο„ : Type*} (p : MvPolynomial (Option ΞΊ βŠ• Ο„) β„‚) + (x : Option ΞΊ β†’ ℝ) (hmulti : IsComplexMultiaffine p) : + partialSpecialization p x = + partialSpecialization (sumOptionSpecialization p (x none)) + (fun i ↦ x (some i)) := by + apply MvPolynomial.funext + intro z + rw [partialSpecialization_eval, partialSpecialization_eval, + sumOptionSpecialization_eval _ _ hmulti] + apply congrArg (fun u ↦ p.eval u) + funext i + cases i with + | inl i => cases i <;> rfl + | inr i => rfl + +/-- Specializing the recursively finite set of `PairVariables` to real values +preserves upper-half-plane stability in the variables that remain. -/ +theorem pairVariables_partialSpecialization_stableOrZero : + βˆ€ (n : β„•) {Ο„ : Type*} [Fintype Ο„] + (p : MvPolynomial (PairVariables n βŠ• Ο„) β„‚) + (x : PairVariables n β†’ ℝ), + IsComplexMultiaffine p β†’ IsUpperHalfPlaneStable p β†’ + partialSpecialization p x = 0 ∨ + IsUpperHalfPlaneStable (partialSpecialization p x) := by + intro n + induction n with + | zero => + intro Ο„ _ p x hmulti hstable + right + intro z hz + rw [partialSpecialization_eval] + apply hstable + intro i + cases i with + | inl i => exact PEmpty.elim i + | inr i => exact hz i + | succ n ih => + intro Ο„ _ p x hmulti hstable + change MvPolynomial (Option (Option (PairVariables n)) βŠ• Ο„) β„‚ at p + change Option (Option (PairVariables n)) β†’ ℝ at x + change partialSpecialization p x = 0 ∨ + IsUpperHalfPlaneStable (partialSpecialization p x) + have hfirst := sumOptionSpecialization_stableOrZero p (x none) hmulti hstable + rcases hfirst with hzero | hfirst + Β· left + rw [partialSpecialization_option p x hmulti, hzero, + partialSpecialization_zero] + Β· let p₁ := sumOptionSpecialization p (x none) + let x₁ : Option (PairVariables n) β†’ ℝ := fun i ↦ x (some i) + have hm₁ : IsComplexMultiaffine p₁ := + sumOptionSpecialization_multiaffine p (x none) hmulti + have hsecond := sumOptionSpecialization_stableOrZero p₁ (x₁ none) hm₁ hfirst + rcases hsecond with hzero | hsecond + Β· left + rw [partialSpecialization_option p x hmulti] + change partialSpecialization p₁ x₁ = 0 + rw [partialSpecialization_option p₁ x₁ hm₁, hzero, + partialSpecialization_zero] + Β· let pβ‚‚ := sumOptionSpecialization p₁ (x₁ none) + let xβ‚‚ : PairVariables n β†’ ℝ := fun i ↦ x₁ (some i) + have hmβ‚‚ : IsComplexMultiaffine pβ‚‚ := + sumOptionSpecialization_multiaffine p₁ (x₁ none) hm₁ + have htail := ih pβ‚‚ xβ‚‚ hmβ‚‚ hsecond + rw [partialSpecialization_option p x hmulti] + change partialSpecialization p₁ x₁ = 0 ∨ + IsUpperHalfPlaneStable (partialSpecialization p₁ x₁) + rw [partialSpecialization_option p₁ x₁ hm₁] + exact htail + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceStableTable.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceStableTable.lean new file mode 100644 index 0000000000..bb3bbc654c --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceStableTable.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableClosure +public import LeanPool.BeyondBethe.BeyondBethe.SourceStableBivariate +public import Mathlib.Tactic + +/-! # Source Stable Table -/ + +@[expose] public section + +namespace BeyondBethe + +/-! +# A coefficient-table model for the multilinear source induction + +A table records the coefficient of every pair of squarefree monomials. The +recursive variable type places the next left variable first and the next +right variable second. With this ordering, sign reversal on the right turns +one recursion step into two nested `linearExtension`s, exactly the form used +by the formal Lieb--Sokal contraction. +-/ + +/-- A real coefficient table indexed by two Boolean selectors on `n` coordinates. -/ +abbrev PairTable (n : β„•) := + (Fin n β†’ Bool) β†’ (Fin n β†’ Bool) β†’ ℝ + +/-- Prepends one Boolean head coordinate to a finite Boolean selector. -/ +def prependBool {n : β„•} (b : Bool) (S : Fin n β†’ Bool) : Fin (n + 1) β†’ Bool := + Fin.cases b S + +/-- Fixes the two head selector bits and retains a table on the remaining coordinates. -/ +def pairTableSection {n : β„•} (c : PairTable (n + 1)) + (left right : Bool) : PairTable n := + fun S T ↦ c (prependBool left S) (prependBool right T) + +/-- A recursively encoded type containing two fresh optional variables for each coordinate. -/ +def PairVariables : β„• β†’ Type + | 0 => PEmpty + | n + 1 => Option (Option (PairVariables n)) + +noncomputable instance pairVariablesFintype (n : β„•) : Fintype (PairVariables n) := by + induction n with + | zero => + change Fintype PEmpty + exact inferInstance + | succ n ih => + letI : Fintype (PairVariables n) := ih + change Fintype (Option (Option (PairVariables n))) + exact inferInstance + +/-- Builds the signed polynomial associated with a pair table using two linear extensions per +coordinate and negative right-variable coefficients. -/ +noncomputable def pairTableStablePolynomial : + βˆ€ n : β„•, PairTable n β†’ MvPolynomial (PairVariables n) β„‚ + | 0, c => MvPolynomial.C (c (fun i ↦ Fin.elim0 i) (fun i ↦ Fin.elim0 i) : β„‚) + | n + 1, c => + let A := pairTableStablePolynomial n (pairTableSection c true true) + let B := pairTableStablePolynomial n (pairTableSection c true false) + let C := pairTableStablePolynomial n (pairTableSection c false true) + let D := pairTableStablePolynomial n (pairTableSection c false false) + linearExtension (linearExtension D (-C)) (linearExtension B (-A)) + +/-- Requires every coefficient-table entry to be nonnegative. -/ +def PairTableNonnegative {n : β„•} (c : PairTable n) : Prop := + βˆ€ S T, 0 ≀ c S T + +/-- Requires the associated signed polynomial to be zero or upper-half-plane stable. -/ +def PairTableStableOrZero {n : β„•} (c : PairTable n) : Prop := + pairTableStablePolynomial n c = 0 ∨ + IsUpperHalfPlaneStable (pairTableStablePolynomial n c) + +/-- Recursively evaluates a pair table on real vectors by its four head-coordinate sections. -/ +noncomputable def pairTableEval : + βˆ€ n : β„•, PairTable n β†’ (Fin n β†’ ℝ) β†’ (Fin n β†’ ℝ) β†’ ℝ + | 0, c, _, _ => c (fun i ↦ Fin.elim0 i) (fun i ↦ Fin.elim0 i) + | n + 1, c, y, z => + let yt : Fin n β†’ ℝ := fun i ↦ y i.succ + let zt : Fin n β†’ ℝ := fun i ↦ z i.succ + let a := pairTableEval n (pairTableSection c true true) yt zt + let b := pairTableEval n (pairTableSection c true false) yt zt + let cc := pairTableEval n (pairTableSection c false true) yt zt + let d := pairTableEval n (pairTableSection c false false) yt zt + a * y 0 * z 0 + b * y 0 + cc * z 0 + d + +/-- Sums diagonal table coefficients by recursively retaining only equal head-selector pairs. -/ +noncomputable def pairTableDiagonalSum : βˆ€ n : β„•, PairTable n β†’ ℝ + | 0, c => c (fun i ↦ Fin.elim0 i) (fun i ↦ Fin.elim0 i) + | n + 1, c => + pairTableDiagonalSum n (pairTableSection c false false) + + pairTableDiagonalSum n (pairTableSection c true true) + +/-- Multiplies the scalar stability-boundary factors over all coordinates. -/ +noncomputable def pairTableBoundary : βˆ€ n : β„•, (Fin n β†’ ℝ) β†’ ℝ + | 0, _ => 1 + | n + 1, Ξ± => + stableBoundaryScalar (Ξ± 0) * pairTableBoundary n (fun i ↦ Ξ± i.succ) + +/-- Multiplies the coordinate powers `x i ^ Ξ± i` with real exponents. -/ +noncomputable def pairTableMonomial : + βˆ€ n : β„•, (Fin n β†’ ℝ) β†’ (Fin n β†’ ℝ) β†’ ℝ + | 0, _, _ => 1 + | n + 1, x, Ξ± => + (x 0) ^ (Ξ± 0) * pairTableMonomial n (fun i ↦ x i.succ) (fun i ↦ Ξ± i.succ) + +theorem pairTableStablePolynomial_multiaffine : + βˆ€ {n : β„•} (c : PairTable n), + IsComplexMultiaffine (pairTableStablePolynomial n c) := by + intro n + induction n with + | zero => + intro c i + exact PEmpty.elim i + | succ n ih => + intro c + dsimp only [pairTableStablePolynomial] + apply linearExtension_multiaffine + Β· apply linearExtension_multiaffine + Β· exact ih _ + Β· intro i + simpa using ih (pairTableSection c false true) i + Β· apply linearExtension_multiaffine + Β· exact ih _ + Β· intro i + simpa using ih (pairTableSection c true true) i + +theorem pairTableSection_nonnegative + {n : β„•} {c : PairTable (n + 1)} (hc : PairTableNonnegative c) + (left right : Bool) : + PairTableNonnegative (pairTableSection c left right) := by + intro S T + exact hc _ _ + +/-- Adds pair tables entrywise. -/ +def pairTableAdd {n : β„•} (c d : PairTable n) : PairTable n := + fun S T ↦ c S T + d S T + +/-- Contracts a head coordinate by adding its false-false and true-true coefficient sections. -/ +def pairTableContract {n : β„•} (c : PairTable (n + 1)) : PairTable n := + pairTableAdd (pairTableSection c false false) + (pairTableSection c true true) + +theorem linearExtension_add {ΞΉ : Type*} + (g₁ f₁ gβ‚‚ fβ‚‚ : MvPolynomial ΞΉ β„‚) : + linearExtension (g₁ + gβ‚‚) (f₁ + fβ‚‚) = + linearExtension g₁ f₁ + linearExtension gβ‚‚ fβ‚‚ := by + simp only [linearExtension, map_add, mul_add] + abel + +theorem pairTableStablePolynomial_add : + βˆ€ {n : β„•} (c d : PairTable n), + pairTableStablePolynomial n (pairTableAdd c d) = + pairTableStablePolynomial n c + pairTableStablePolynomial n d := by + intro n + induction n with + | zero => + intro c d + simp [pairTableStablePolynomial, pairTableAdd] + | succ n ih => + intro c d + simp only [pairTableStablePolynomial] + have hsection (l r : Bool) : + pairTableSection (pairTableAdd c d) l r = + pairTableAdd (pairTableSection c l r) (pairTableSection d l r) := by + rfl + simp_rw [hsection, ih] + simp only [neg_add_rev, add_comm, linearExtension_add] + rfl + +theorem pairTableEval_add : + βˆ€ {n : β„•} (c d : PairTable n) (y z : Fin n β†’ ℝ), + pairTableEval n (pairTableAdd c d) y z = + pairTableEval n c y z + pairTableEval n d y z := by + intro n + induction n with + | zero => + intro c d y z + simp [pairTableEval, pairTableAdd] + | succ n ih => + intro c d y z + simp only [pairTableEval] + have hsection (l r : Bool) : + pairTableSection (pairTableAdd c d) l r = + pairTableAdd (pairTableSection c l r) (pairTableSection d l r) := by + rfl + simp_rw [hsection, ih] + ring + +theorem pairTableEval_nonnegative : + βˆ€ {n : β„•} {c : PairTable n} {y z : Fin n β†’ ℝ}, + PairTableNonnegative c β†’ + (βˆ€ i, 0 ≀ y i) β†’ (βˆ€ i, 0 ≀ z i) β†’ + 0 ≀ pairTableEval n c y z := by + intro n + induction n with + | zero => + intro c y z hc hy hz + exact hc _ _ + | succ n ih => + intro c y z hc hy hz + simp only [pairTableEval] + have hyt : βˆ€ i : Fin n, 0 ≀ y i.succ := fun i ↦ hy i.succ + have hzt : βˆ€ i : Fin n, 0 ≀ z i.succ := fun i ↦ hz i.succ + have ha := ih (pairTableSection_nonnegative hc true true) hyt hzt + have hb := ih (pairTableSection_nonnegative hc true false) hyt hzt + have hcc := ih (pairTableSection_nonnegative hc false true) hyt hzt + have hd := ih (pairTableSection_nonnegative hc false false) hyt hzt + exact add_nonneg + (add_nonneg + (add_nonneg (mul_nonneg (mul_nonneg ha (hy 0)) (hz 0)) + (mul_nonneg hb (hy 0))) + (mul_nonneg hcc (hz 0))) hd + +theorem pairTableDiagonalSum_add : + βˆ€ {n : β„•} (c d : PairTable n), + pairTableDiagonalSum n (pairTableAdd c d) = + pairTableDiagonalSum n c + pairTableDiagonalSum n d := by + intro n + induction n with + | zero => + intro c d + simp [pairTableDiagonalSum, pairTableAdd] + | succ n ih => + intro c d + simp only [pairTableDiagonalSum] + have hsection (l r : Bool) : + pairTableSection (pairTableAdd c d) l r = + pairTableAdd (pairTableSection c l r) (pairTableSection d l r) := by + rfl + simp_rw [hsection, ih] + ring + +theorem pairTableContract_nonnegative + {n : β„•} {c : PairTable (n + 1)} + (hc : PairTableNonnegative c) : + PairTableNonnegative (pairTableContract c) := by + intro S T + exact add_nonneg (hc _ _) (hc _ _) + +/-- The diagonal contraction is stable or zero. This is the exact operator +step in the Anari--Oveis Gharan induction. -/ +theorem pairTableContract_stableOrZero + {n : β„•} (c : PairTable (n + 1)) + (hstable : PairTableStableOrZero c) : + PairTableStableOrZero (pairTableContract c) := by + let A := pairTableStablePolynomial n (pairTableSection c true true) + let B := pairTableStablePolynomial n (pairTableSection c true false) + let C := pairTableStablePolynomial n (pairTableSection c false true) + let D := pairTableStablePolynomial n (pairTableSection c false false) + have hcontract : + pairTableStablePolynomial n (pairTableContract c) = D + A := by + rw [pairTableContract, pairTableStablePolynomial_add] + rcases hstable with hzero | hstable + Β· change + linearExtension (linearExtension D (-C)) (linearExtension B (-A)) = 0 at hzero + have hout : linearExtension D (-C) = 0 := + (linearExtension_eq_zero_iff.mp (by + exact hzero)).1 + have hD : D = 0 := (linearExtension_eq_zero_iff.mp hout).1 + have hin : linearExtension B (-A) = 0 := + (linearExtension_eq_zero_iff.mp (by + exact hzero)).2 + have hA : A = 0 := by + have := (linearExtension_eq_zero_iff.mp hin).2 + simpa using this + left + rw [hcontract, hD, hA, add_zero] + Β· change + IsUpperHalfPlaneStable + (linearExtension (linearExtension D (-C)) (linearExtension B (-A))) at hstable + have hLS := liebSokal_linear_contraction + (linearExtension D (-C)) B (-A) (by + exact hstable) + have hrewrite : + linearExtension D (-C) - MvPolynomial.rename some (-A) = + linearExtension (D + A) (-C) := by + simp [linearExtension] + ring + rw [hrewrite] at hLS + rcases hLS with hzero | hLS + Β· have hDA := (linearExtension_eq_zero_iff.mp hzero).1 + left + rwa [hcontract] + Β· have hboundary := linearExtension_constantCoefficient_stableOrZero hLS + change pairTableStablePolynomial n (pairTableContract c) = 0 ∨ + IsUpperHalfPlaneStable (pairTableStablePolynomial n (pairTableContract c)) + rw [hcontract] + exact hboundary + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/SourceVontobel.lean b/LeanPool/BeyondBethe/BeyondBethe/SourceVontobel.lean new file mode 100644 index 0000000000..605fcc107a --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/SourceVontobel.lean @@ -0,0 +1,510 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Bethe +public import Mathlib.Algebra.Order.BigOperators.Ring.Finset +public import Mathlib.Analysis.Convex.Deriv + +/-! # Source Vontobel -/ + +@[expose] public section + +open scoped BigOperators Topology + +namespace BeyondBethe + +/-! +# Vontobel's simplex-concavity theorem + +This file formalizes the source theorem used to prove concavity of the Bethe +objective. The algebraic core is the Hessian inequality + +`sum v_i^2 / (1 - p_i) <= sum v_i^2 / p_i` + +for a strictly positive probability vector `p` and a tangent vector `v` whose +coordinates sum to zero. This is the finite-dimensional form of the argument +in Vontobel's Theorem 20. The proof below uses weighted Cauchy--Schwarz and +also supplies the boundary control that is only sketched in the source. +-/ + +/-- Weighted Cauchy--Schwarz on the complement of one coordinate. -/ +private theorem tangent_coordinate_sq_div_complement_le + {ΞΉ : Type*} [DecidableEq ΞΉ] (s : Finset ΞΉ) + (p v : ΞΉ β†’ ℝ) (hp : βˆ€ i ∈ s, 0 < p i) + (hpsum : βˆ‘ i ∈ s, p i = 1) (hvsum : βˆ‘ i ∈ s, v i = 0) + (i : ΞΉ) (hi : i ∈ s) (hpi : p i < 1) : + v i ^ 2 / (1 - p i) ≀ + βˆ‘ j ∈ s.erase i, v j ^ 2 / p j := by + have hpsumErase : βˆ‘ j ∈ s.erase i, p j = 1 - p i := by + have h := Finset.sum_erase_add s p hi + rw [hpsum] at h + linarith + have hpc : 0 < βˆ‘ j ∈ s.erase i, p j := by + rw [hpsumErase] + exact sub_pos.mpr hpi + have hvsumErase : βˆ‘ j ∈ s.erase i, v j = -v i := by + have h := Finset.sum_erase_add s v hi + rw [hvsum] at h + linarith + have hcs := Finset.sq_sum_div_le_sum_sq_div + (R := ℝ) (s.erase i) v + (fun j hj ↦ hp j (Finset.mem_of_mem_erase hj)) + rw [hpsumErase, hvsumErase, neg_sq] at hcs + exact hcs + +/-- The Hessian inequality behind concavity of Vontobel's simplex entropy. -/ +theorem vontobel_tangent_hessian_nonpos + {ΞΉ : Type*} [DecidableEq ΞΉ] (s : Finset ΞΉ) + (p v : ΞΉ β†’ ℝ) (hp : βˆ€ i ∈ s, 0 < p i) + (hplt : βˆ€ i ∈ s, p i < 1) + (hpsum : βˆ‘ i ∈ s, p i = 1) (hvsum : βˆ‘ i ∈ s, v i = 0) : + (βˆ‘ i ∈ s, v i ^ 2 / (1 - p i)) - + βˆ‘ i ∈ s, v i ^ 2 / p i ≀ 0 := by + have hcoord : βˆ€ i ∈ s, + p i * (v i ^ 2 / (1 - p i)) ≀ + p i * βˆ‘ j ∈ s.erase i, v j ^ 2 / p j := by + intro i hi + exact mul_le_mul_of_nonneg_left + (tangent_coordinate_sq_div_complement_le s p v hp hpsum hvsum i hi (hplt i hi)) + (hp i hi).le + have hsum := Finset.sum_le_sum fun i hi ↦ hcoord i hi + have hdouble : + βˆ‘ i ∈ s, p i * βˆ‘ j ∈ s.erase i, v j ^ 2 / p j = + βˆ‘ j ∈ s, (1 - p j) * (v j ^ 2 / p j) := by + classical + let a : ΞΉ β†’ ℝ := fun j ↦ v j ^ 2 / p j + have herase : βˆ€ i ∈ s, βˆ‘ j ∈ s.erase i, a j = (βˆ‘ j ∈ s, a j) - a i := by + intro i hi + have h := Finset.sum_erase_add s a hi + linarith + change (βˆ‘ i ∈ s, p i * βˆ‘ j ∈ s.erase i, a j) = + βˆ‘ j ∈ s, (1 - p j) * a j + calc + βˆ‘ i ∈ s, p i * βˆ‘ j ∈ s.erase i, a j + = βˆ‘ i ∈ s, p i * ((βˆ‘ j ∈ s, a j) - a i) := by + apply Finset.sum_congr rfl + intro i hi + rw [herase i hi] + _ + = (βˆ‘ i ∈ s, p i) * (βˆ‘ j ∈ s, a j) - βˆ‘ i ∈ s, p i * a i := by + simp_rw [mul_sub, Finset.sum_sub_distrib, Finset.sum_mul] + _ = (βˆ‘ j ∈ s, a j) - βˆ‘ i ∈ s, p i * a i := by rw [hpsum, one_mul] + _ = βˆ‘ j ∈ s, (1 - p j) * a j := by + simp_rw [sub_mul, one_mul, Finset.sum_sub_distrib] + rw [hdouble] at hsum + have hleft : + βˆ‘ i ∈ s, v i ^ 2 / (1 - p i) = + βˆ‘ i ∈ s, (v i ^ 2 + p i * (v i ^ 2 / (1 - p i))) := by + apply Finset.sum_congr rfl + intro i hi + have hne : 1 - p i β‰  0 := (sub_pos.mpr (hplt i hi)).ne' + field_simp + ring + have hright : + βˆ‘ i ∈ s, v i ^ 2 / p i = + βˆ‘ i ∈ s, (v i ^ 2 + (1 - p i) * (v i ^ 2 / p i)) := by + apply Finset.sum_congr rfl + intro i hi + have hne : p i β‰  0 := (hp i hi).ne' + field_simp + ring + rw [hleft, hright, Finset.sum_add_distrib, Finset.sum_add_distrib] + linarith + +/-- Vontobel's scalar entropy contribution +`-x log x + (1-x) log (1-x)`, written in a boundary-continuous form. -/ +noncomputable def vontobelEntropyTerm (x : ℝ) : ℝ := + Real.negMulLog x - Real.negMulLog (1 - x) + +/-- The entropy `S` in Vontobel's Theorem 20. -/ +noncomputable def vontobelSimplexEntropy + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i, vontobelEntropyTerm (p i) + +/-- Affine segment between two finite vectors. -/ +def probabilitySegment + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) (t : ℝ) (i : ΞΉ) : ℝ := + (1 - t) * p i + t * q i + +theorem probabilitySegment_sum + {ΞΉ : Type*} [Fintype ΞΉ] {p q : ΞΉ β†’ ℝ} + (hp : βˆ‘ i, p i = 1) (hq : βˆ‘ i, q i = 1) (t : ℝ) : + βˆ‘ i, probabilitySegment p q t i = 1 := by + simp_rw [probabilitySegment, Finset.sum_add_distrib, ← Finset.mul_sum, + hp, hq] + ring + +theorem IsStrictProbabilityVector.lt_one_of_one_lt_card + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsStrictProbabilityVector p) + (hcard : 1 < Fintype.card ΞΉ) (i : ΞΉ) : + p i < 1 := by + obtain ⟨j, hji⟩ := Fintype.exists_ne_of_one_lt_card hcard i + rw [← hp.1.sum_eq_one] + calc + p i < p i + p j := lt_add_of_pos_right _ (hp.2 j) + _ = βˆ‘ k ∈ ({i, j} : Finset ΞΉ), p k := by + rw [Finset.sum_pair hji.symm] + _ ≀ βˆ‘ k, p k := Finset.sum_le_sum_of_subset_of_nonneg + (Finset.subset_univ _) (fun k _ _ ↦ hp.1.nonnegative k) + +theorem probabilitySegment_strictProbability + {ΞΉ : Type*} [Fintype ΞΉ] + {p q : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) + (hq : IsStrictProbabilityVector q) {t : ℝ} + (ht0 : 0 < t) (ht1 : t < 1) : + IsStrictProbabilityVector (probabilitySegment p q t) := by + refine ⟨⟨?_, probabilitySegment_sum hp.sum_eq_one hq.1.sum_eq_one t⟩, ?_⟩ + Β· intro i + exact add_nonneg + (mul_nonneg (sub_nonneg.mpr ht1.le) (hp.nonnegative i)) + (mul_nonneg ht0.le (hq.1.nonnegative i)) + Β· intro i + exact add_pos_of_nonneg_of_pos + (mul_nonneg (sub_nonneg.mpr ht1.le) (hp.nonnegative i)) + (mul_pos ht0 (hq.2 i)) + +theorem hasDerivAt_probabilitySegment + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) (i : ΞΉ) (t : ℝ) : + HasDerivAt (fun u ↦ probabilitySegment p q u i) (q i - p i) t := by + convert! ((hasDerivAt_const t 1).sub (hasDerivAt_id t)).mul_const (p i) |>.add + ((hasDerivAt_id t).mul_const (q i)) using 1 <;> + simp [probabilitySegment] <;> ring + +private theorem hasDerivAt_vontobelEntropyTerm_segment + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) (i : ΞΉ) {t : ℝ} + (hpos : 0 < probabilitySegment p q t i) + (hlt : probabilitySegment p q t i < 1) : + HasDerivAt + (fun u ↦ vontobelEntropyTerm (probabilitySegment p q u i)) + ((q i - p i) * + (-Real.log (probabilitySegment p q t i) - + Real.log (1 - probabilitySegment p q t i) - 2)) t := by + let r := probabilitySegment p q t i + let v := q i - p i + have hr := hasDerivAt_probabilitySegment p q i t + have hneg : HasDerivAt + (fun u ↦ Real.negMulLog (probabilitySegment p q u i)) + ((-Real.log r - 1) * v) t := by + exact (Real.hasDerivAt_negMulLog hpos.ne').comp t hr + have hinner : HasDerivAt + (fun u ↦ 1 - probabilitySegment p q u i) (-v) t := by + convert! (hasDerivAt_const t 1).sub hr using 1 <;> simp [v] + have hcomp : HasDerivAt + (fun u ↦ Real.negMulLog (1 - probabilitySegment p q u i)) + ((-Real.log (1 - r) - 1) * (-v)) t := by + exact (Real.hasDerivAt_negMulLog (sub_pos.mpr hlt).ne').comp t hinner + change HasDerivAt + (fun u ↦ Real.negMulLog (probabilitySegment p q u i) - + Real.negMulLog (1 - probabilitySegment p q u i)) _ t + convert! hneg.sub hcomp using 1 <;> dsimp [r, v] <;> ring + +private theorem hasDerivAt_vontobelEntropyTerm_segment_deriv + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) (i : ΞΉ) {t : ℝ} + (hpos : 0 < probabilitySegment p q t i) + (hlt : probabilitySegment p q t i < 1) : + HasDerivAt + (fun u ↦ (q i - p i) * + (-Real.log (probabilitySegment p q u i) - + Real.log (1 - probabilitySegment p q u i) - 2)) + ((q i - p i) ^ 2 / (1 - probabilitySegment p q t i) - + (q i - p i) ^ 2 / probabilitySegment p q t i) t := by + let r := probabilitySegment p q t i + let v := q i - p i + have hr := hasDerivAt_probabilitySegment p q i t + have hlogr : HasDerivAt + (fun u ↦ Real.log (probabilitySegment p q u i)) (v / r) t := by + exact hr.log hpos.ne' + have hinner : HasDerivAt + (fun u ↦ 1 - probabilitySegment p q u i) (-v) t := by + convert! (hasDerivAt_const t 1).sub hr using 1 <;> simp [v] + have hlogc : HasDerivAt + (fun u ↦ Real.log (1 - probabilitySegment p q u i)) + ((-v) / (1 - r)) t := by + exact hinner.log (sub_pos.mpr hlt).ne' + have hsum := ((hlogr.neg.sub hlogc).sub_const 2).const_mul v + convert! hsum using 1 <;> dsimp [r, v] <;> field_simp <;> ring + +/-- Concavity along a segment whose second endpoint has full support. This +is the exact form first needed in the regularized-optimizer argument. -/ +theorem vontobelSimplexEntropy_segment_concave + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p q : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) + (hq : IsStrictProbabilityVector q) + (hcard : 1 < Fintype.card ΞΉ) : + ConcaveOn ℝ (Set.Icc (0 : ℝ) 1) + (fun t ↦ vontobelSimplexEntropy (probabilitySegment p q t)) := by + let f : ℝ β†’ ℝ := fun t ↦ + vontobelSimplexEntropy (probabilitySegment p q t) + let f' : ℝ β†’ ℝ := fun t ↦ βˆ‘ i, + (q i - p i) * + (-Real.log (probabilitySegment p q t i) - + Real.log (1 - probabilitySegment p q t i) - 2) + let f'' : ℝ β†’ ℝ := fun t ↦ βˆ‘ i, + ((q i - p i) ^ 2 / (1 - probabilitySegment p q t i) - + (q i - p i) ^ 2 / probabilitySegment p q t i) + apply concaveOn_of_hasDerivWithinAt2_nonpos (convex_Icc 0 1) + Β· dsimp only [f, vontobelSimplexEntropy, vontobelEntropyTerm, + probabilitySegment] + fun_prop + Β· intro t ht + have ht' : t ∈ Set.Ioo (0 : ℝ) 1 := by simpa using ht + have hr := probabilitySegment_strictProbability hp hq ht'.1 ht'.2 + have hlt := hr.lt_one_of_one_lt_card hcard + apply (HasDerivAt.fun_sum fun i _ ↦ + hasDerivAt_vontobelEntropyTerm_segment p q i (hr.2 i) (hlt i)).hasDerivWithinAt + Β· intro t ht + have ht' : t ∈ Set.Ioo (0 : ℝ) 1 := by simpa using ht + have hr := probabilitySegment_strictProbability hp hq ht'.1 ht'.2 + have hlt := hr.lt_one_of_one_lt_card hcard + apply (HasDerivAt.fun_sum fun i _ ↦ + hasDerivAt_vontobelEntropyTerm_segment_deriv p q i (hr.2 i) (hlt i)).hasDerivWithinAt + Β· intro t ht + have ht' : t ∈ Set.Ioo (0 : ℝ) 1 := by simpa using ht + have hr := probabilitySegment_strictProbability hp hq ht'.1 ht'.2 + have hlt := hr.lt_one_of_one_lt_card hcard + have hsumv : βˆ‘ i, (q i - p i) = 0 := by + rw [Finset.sum_sub_distrib, hq.1.sum_eq_one, hp.sum_eq_one] + ring + simpa [f'', Finset.sum_sub_distrib] using + vontobel_tangent_hessian_nonpos Finset.univ + (probabilitySegment p q t) (fun i ↦ q i - p i) + (fun i _ ↦ hr.2 i) (fun i _ ↦ hlt i) + (by simpa using hr.1.sum_eq_one) (by simpa using hsumv) + +@[simp] theorem probabilitySegment_zero + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) : + probabilitySegment p q 0 = p := by + funext i + simp [probabilitySegment] + +@[simp] theorem probabilitySegment_one + {ΞΉ : Type*} (p q : ΞΉ β†’ ℝ) : + probabilitySegment p q 1 = q := by + funext i + simp [probabilitySegment] + +/-- Jensen form of Vontobel's entropy concavity when one endpoint has full +support. -/ +theorem vontobelSimplexEntropy_segment_lower_of_right_strict + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p q : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) + (hq : IsStrictProbabilityVector q) + (hcard : 1 < Fintype.card ΞΉ) + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) : + (1 - t) * vontobelSimplexEntropy p + + t * vontobelSimplexEntropy q ≀ + vontobelSimplexEntropy (probabilitySegment p q t) := by + have hc := (vontobelSimplexEntropy_segment_concave hp hq hcard).2 + (show (0 : ℝ) ∈ Set.Icc (0 : ℝ) 1 by simp) + (show (1 : ℝ) ∈ Set.Icc (0 : ℝ) 1 by simp) + (sub_nonneg.mpr ht1) ht0 (by ring : (1 - t) + t = 1) + simpa [probabilitySegment, smul_eq_mul] using hc + +/-- The simplex entropy is continuous on the whole ambient finite-dimensional +space. In particular, its boundary convention agrees with limits from the +relative interior of the simplex. -/ +theorem continuous_vontobelSimplexEntropy + {ΞΉ : Type*} [Fintype ΞΉ] : + Continuous (vontobelSimplexEntropy : (ΞΉ β†’ ℝ) β†’ ℝ) := by + unfold vontobelSimplexEntropy vontobelEntropyTerm + apply continuous_finsetSum + intro i _ + fun_prop + +/-- Uniform probability vector on a nonempty finite type. -/ +noncomputable def uniformProbabilityVector + (ΞΉ : Type*) [Fintype ΞΉ] : ΞΉ β†’ ℝ := + fun _ ↦ 1 / Fintype.card ΞΉ + +theorem uniformProbabilityVector_strict + {ΞΉ : Type*} [Fintype ΞΉ] [Nonempty ΞΉ] : + IsStrictProbabilityVector (uniformProbabilityVector ΞΉ) := by + have hcard : 0 < Fintype.card ΞΉ := Fintype.card_pos + refine ⟨⟨?_, ?_⟩, ?_⟩ + Β· intro i + exact div_nonneg zero_le_one (Nat.cast_nonneg _) + Β· simp [uniformProbabilityVector, hcard.ne'] + Β· intro i + exact div_pos zero_lt_one (by exact_mod_cast hcard) + +/-- Full Jensen form of Vontobel's simplex-concavity theorem. The proof +approximates the second endpoint by a full-support probability vector and +passes to the boundary using continuity. -/ +theorem vontobelSimplexEntropy_segment_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p q : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) + (hq : IsProbabilityVector q) + (hcard : 1 < Fintype.card ΞΉ) + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) : + (1 - t) * vontobelSimplexEntropy p + + t * vontobelSimplexEntropy q ≀ + vontobelSimplexEntropy (probabilitySegment p q t) := by + letI : Nonempty ΞΉ := Fintype.card_pos_iff.mp (by omega) + let u : ΞΉ β†’ ℝ := uniformProbabilityVector ΞΉ + let qs : ℝ β†’ ΞΉ β†’ ℝ := fun Ξ΄ ↦ probabilitySegment q u Ξ΄ + let lhs : ℝ β†’ ℝ := fun Ξ΄ ↦ + (1 - t) * vontobelSimplexEntropy p + + t * vontobelSimplexEntropy (qs Ξ΄) + let rhs : ℝ β†’ ℝ := fun Ξ΄ ↦ + vontobelSimplexEntropy (probabilitySegment p (qs Ξ΄) t) + have hu : IsStrictProbabilityVector u := by + simpa [u] using (uniformProbabilityVector_strict (ΞΉ := ΞΉ)) + have hlhs : Continuous lhs := by + have hqs : Continuous qs := by + apply continuous_pi + intro i + dsimp [qs, probabilitySegment] + fun_prop + exact continuous_const.add + (continuous_const.mul (continuous_vontobelSimplexEntropy.comp hqs)) + have hrhs : Continuous rhs := by + have hsegment : Continuous + (fun Ξ΄ ↦ probabilitySegment p (qs Ξ΄) t) := by + apply continuous_pi + intro i + dsimp [qs, probabilitySegment] + fun_prop + exact continuous_vontobelSimplexEntropy.comp hsegment + have hlhs0 : lhs 0 = + (1 - t) * vontobelSimplexEntropy p + + t * vontobelSimplexEntropy q := by + simp [lhs, qs] + have hrhs0 : rhs 0 = + vontobelSimplexEntropy (probabilitySegment p q t) := by + simp [rhs, qs] + rw [← hlhs0, ← hrhs0] + letI : Filter.NeBot (nhdsWithin (0 : ℝ) (Set.Ioi 0)) := + nhdsGT_neBot (0 : ℝ) + refine le_of_tendsto_of_tendsto (b := nhdsWithin (0 : ℝ) (Set.Ioi 0)) + (hlhs.tendsto 0 |>.mono_left nhdsWithin_le_nhds) + (hrhs.tendsto 0 |>.mono_left nhdsWithin_le_nhds) ?_ + filter_upwards [self_mem_nhdsWithin, + (eventually_lt_nhds (show (0 : ℝ) < 1 by norm_num)).filter_mono + nhdsWithin_le_nhds] with Ξ΄ hΞ΄pos hΞ΄one + have hqs : IsStrictProbabilityVector (qs Ξ΄) := by + exact probabilitySegment_strictProbability hq hu hΞ΄pos hΞ΄one + exact vontobelSimplexEntropy_segment_lower_of_right_strict + hp hqs hcard ht0 ht1 + +theorem betheRowObjective_eq_linear_add_vontobelEntropy + {ΞΉ : Type*} [Fintype ΞΉ] + (A X : Matrix ΞΉ ΞΉ ℝ) (i : ΞΉ) : + betheRowObjective A X i = + (βˆ‘ j, X i j * Real.log (A i j)) + + vontobelSimplexEntropy (X i) := by + classical + simp only [betheRowObjective, vontobelSimplexEntropy, + vontobelEntropyTerm, Finset.sum_add_distrib, + Finset.sum_sub_distrib, Real.negMulLog] + have hneg : + (βˆ‘ j, -(1 - X i j) * Real.log (1 - X i j)) = + -(βˆ‘ j, (1 - X i j) * Real.log (1 - X i j)) := by + rw [← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro j _ + ring + rw [hneg] + ring + +/-- Matrix segment written rowwise. -/ +def betheMatrixSegment + {ΞΉ : Type*} (t : ℝ) (X Y : Matrix ΞΉ ΞΉ ℝ) : Matrix ΞΉ ΞΉ ℝ := + fun i ↦ probabilitySegment (X i) (Y i) t + +/-- Jensen inequality for the Bethe objective on the Birkhoff polytope. -/ +theorem betheObjective_segment_lower + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + (A X Y : Matrix ΞΉ ΞΉ ℝ) + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) : + (1 - t) * betheObjective A X + t * betheObjective A Y ≀ + betheObjective A (betheMatrixSegment t X Y) := by + classical + simp_rw [betheObjective, betheRowObjective_eq_linear_add_vontobelEntropy, + Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro i _ + have hentropy := vontobelSimplexEntropy_segment_lower + (hX.row_probability i) + (hY.row_probability i) hcard ht0 ht1 + have hentropy' : + (1 - t) * vontobelSimplexEntropy (X i) + + t * vontobelSimplexEntropy (Y i) ≀ + vontobelSimplexEntropy (betheMatrixSegment t X Y i) := by + simpa only [betheMatrixSegment] using hentropy + have hlinear : + (1 - t) * (βˆ‘ j, X i j * Real.log (A i j)) + + t * (βˆ‘ j, Y i j * Real.log (A i j)) = + βˆ‘ j, betheMatrixSegment t X Y i j * Real.log (A i j) := by + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro j _ + simp only [betheMatrixSegment, probabilitySegment] + ring + rw [← hlinear] + linarith + +/-- The Birkhoff polytope is convex. -/ +theorem convex_doublyStochastic + {ΞΉ : Type*} [Fintype ΞΉ] : + Convex ℝ {X : Matrix ΞΉ ΞΉ ℝ | IsDoublyStochastic X} := by + rw [convex_iff_add_mem] + intro X hX Y hY a b ha hb hab + change IsDoublyStochastic + (fun i j ↦ a * X i j + b * Y i j) + refine ⟨?_, ?_, ?_⟩ + Β· intro i j + exact add_nonneg + (mul_nonneg ha (hX.nonnegative i j)) + (mul_nonneg hb (hY.nonnegative i j)) + Β· intro i + simp_rw [Finset.sum_add_distrib, ← Finset.mul_sum, + hX.row_sum, hY.row_sum] + simpa using hab + Β· intro j + simp_rw [Finset.sum_add_distrib, ← Finset.mul_sum, + hX.col_sum, hY.col_sum] + simpa using hab + +/-- Vontobel's full Bethe-concavity theorem, including boundary points of the +Birkhoff polytope. -/ +theorem vontobelBetheConcavity : VontobelBetheConcavity := by + intro ΞΉ _ A _hA + classical + refine ⟨convex_doublyStochastic, ?_⟩ + intro X hX Y hY a b ha hb hab + by_cases hcard : 1 < Fintype.card ΞΉ + Β· have hble : b ≀ 1 := by linarith + have hjensen := betheObjective_segment_lower hcard A X Y hX hY hb hble + have haeq : a = 1 - b := by linarith + rw [haeq] + have hmatrix : + (1 - b) β€’ X + b β€’ Y = betheMatrixSegment b X Y := by + funext i j + change (1 - b) * X i j + b * Y i j = + (1 - b) * X i j + b * Y i j + rfl + simpa [smul_eq_mul, hmatrix] using hjensen + Β· have hsmall : Fintype.card ΞΉ ≀ 1 := Nat.le_of_not_gt hcard + letI : Subsingleton ΞΉ := Fintype.card_le_one_iff_subsingleton.mp hsmall + have hXY : X = Y := by + ext i j + have hx := hX.row_sum i + have hy := hY.row_sum i + have huniv : (Finset.univ : Finset ΞΉ) = {j} := by + ext k + simp only [Finset.mem_univ, Finset.mem_singleton, true_iff] + exact Subsingleton.elim k j + rw [huniv] at hx hy + simpa using hx.trans hy.symm + subst Y + rw [Convex.combo_self hab, Convex.combo_self hab] + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Stable.lean b/LeanPool/BeyondBethe/BeyondBethe/Stable.lean new file mode 100644 index 0000000000..e4ff2c9fbc --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Stable.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.Algebra.MvPolynomial.Degrees +public import Mathlib.RingTheory.MvPolynomial.Homogeneous +public import Mathlib.Analysis.Complex.Basic +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Tactic + +/-! # Stable -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +open MvPolynomial + +/-- Real stability: the polynomial has no zero when every variable lies in +the open upper half-plane. -/ +def IsRealStable + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) : Prop := + βˆ€ z : Οƒ β†’ β„‚, (βˆ€ i, 0 < (z i).im) β†’ + p.evalβ‚‚ (algebraMap ℝ β„‚) z β‰  0 + +/-- The source literature includes the zero polynomial among the stable +polynomials. Keeping the nonzero notion above is convenient for evaluation +arguments, while this wrapper records the source convention whenever a +stability-preserving operator can annihilate its input. -/ +def IsRealStableOrZero + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) : Prop := + p = 0 ∨ IsRealStable p + +/-- Requires every real coefficient of the multivariate polynomial to be nonnegative. -/ +def HasNonnegativeCoefficients + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) : Prop := + βˆ€ d, 0 ≀ p.coeff d + +/-- Requires the real multivariate polynomial to have degree at most one in each variable. -/ +def IsMultiaffine + {Οƒ : Type*} (p : MvPolynomial Οƒ ℝ) : Prop := + βˆ€ i, p.degreeOf i ≀ 1 + +theorem IsRealStable.rename + {Οƒ Ο„ : Type*} {p : MvPolynomial Οƒ ℝ} + (hp : IsRealStable p) (f : Οƒ β†’ Ο„) : + IsRealStable (MvPolynomial.rename f p) := by + intro z hz + rw [MvPolynomial.evalβ‚‚_rename] + exact hp (z ∘ f) (fun i ↦ hz (f i)) + +theorem IsRealStable.mul + {Οƒ : Type*} {p q : MvPolynomial Οƒ ℝ} + (hp : IsRealStable p) (hq : IsRealStable q) : + IsRealStable (p * q) := by + intro z hz + simp only [evalβ‚‚_mul] + exact mul_ne_zero (hp z hz) (hq z hz) + +theorem IsRealStable.isRealStableOrZero + {Οƒ : Type*} {p : MvPolynomial Οƒ ℝ} (hp : IsRealStable p) : + IsRealStableOrZero p := + Or.inr hp + +theorem IsRealStableOrZero.zero + {Οƒ : Type*} : IsRealStableOrZero (0 : MvPolynomial Οƒ ℝ) := + Or.inl rfl + +theorem IsRealStableOrZero.mul + {Οƒ : Type*} {p q : MvPolynomial Οƒ ℝ} + (hp : IsRealStableOrZero p) (hq : IsRealStableOrZero q) : + IsRealStableOrZero (p * q) := by + rcases hp with rfl | hp + Β· simp [IsRealStableOrZero] + rcases hq with rfl | hq + Β· simp [IsRealStableOrZero] + exact (hp.mul hq).isRealStableOrZero + +/-- `z^Ξ±` for a real exponent vector. -/ +noncomputable def realMonomial + {Οƒ : Type*} [Fintype Οƒ] (z Ξ± : Οƒ β†’ ℝ) : ℝ := + ∏ i, (z i) ^ (Ξ± i) + +/-- Capacity from paper (4). -/ +noncomputable def polynomialCapacity + {Οƒ : Type*} [Fintype Οƒ] + (Ξ± : Οƒ β†’ ℝ) (p : MvPolynomial Οƒ ℝ) : ℝ := + sInf {v : ℝ | βˆƒ z : Οƒ β†’ ℝ, + (βˆ€ i, 0 < z i) ∧ + v = p.eval z / realMonomial z Ξ±} + +/-- Same-squarefree-monomial coefficient pairing used in paper Theorem 3. -/ +noncomputable def coefficientInnerProduct + {Οƒ : Type*} (p q : MvPolynomial Οƒ ℝ) : ℝ := by + classical + exact βˆ‘ d ∈ p.support.filter (Β· ∈ q.support), p.coeff d * q.coeff d + +/-- Boundary product in the multiaffine coefficient inequality. -/ +noncomputable def stableBoundaryFactor + {Οƒ : Type*} [Fintype Οƒ] (Ξ± : Οƒ β†’ ℝ) : ℝ := + ∏ i, (Ξ± i) ^ (Ξ± i) * (1 - Ξ± i) ^ (1 - Ξ± i) + +/-- Exact interface to the multiaffine coefficient theorem of +Anari--Oveis Gharan. Every hypothesis used in the paper is visible here. -/ +def AnariOveisGharanStableCoefficient : Prop := + βˆ€ {Οƒ : Type*} [Fintype Οƒ] + (p q : MvPolynomial Οƒ ℝ) (d : β„•) (Ξ± : Οƒ β†’ ℝ), + HasNonnegativeCoefficients p β†’ + HasNonnegativeCoefficients q β†’ + IsMultiaffine p β†’ IsMultiaffine q β†’ + IsRealStable p β†’ IsRealStable q β†’ + p.IsHomogeneous d β†’ q.IsHomogeneous d β†’ + (βˆ€ i, 0 ≀ Ξ± i ∧ Ξ± i ≀ 1) β†’ + (βˆ‘ i, Ξ± i) = d β†’ + stableBoundaryFactor Ξ± * + polynomialCapacity Ξ± p * polynomialCapacity Ξ± q + ≀ coefficientInnerProduct p q + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/StrongEntropy.lean b/LeanPool/BeyondBethe/BeyondBethe/StrongEntropy.lean new file mode 100644 index 0000000000..8c139f0f27 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/StrongEntropy.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import Mathlib.Analysis.Convex.Strong +public import Mathlib.Analysis.Convex.Deriv +public import Mathlib.Tactic + +/-! # Strong Entropy -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Quantitative concavity from row entropy + +The extra row-entropy regularizer is not merely strictly concave. On the +probability cube it supplies a uniform quadratic Jensen gap. This is the +bridge from objective accuracy to coordinate accuracy in the executable +optimizer. +-/ + +/-- On `[0,1]`, `x log x` is one-strongly convex. -/ +theorem strongConvexOn_mul_log_Icc : + StrongConvexOn (Set.Icc (0 : ℝ) 1) 1 + (fun x : ℝ ↦ x * Real.log x) := by + rw [strongConvexOn_iff_convex] + have hconv : ConvexOn ℝ (Set.Icc (0 : ℝ) 1) + (fun x : ℝ ↦ x * Real.log x - x ^ 2 / 2) := by + apply convexOn_of_hasDerivWithinAt2_nonneg (convex_Icc 0 1) + Β· exact (Real.continuous_mul_log.sub + (continuous_id.pow 2 |>.div_const 2)).continuousOn + Β· intro x hx + rw [interior_Icc] at hx + have hx0 : x β‰  0 := ne_of_gt hx.1 + convert (Real.hasDerivAt_mul_log hx0).sub + ((hasDerivAt_pow 2 x).div_const 2) |>.hasDerivWithinAt using 1 <;> + ring + Β· intro x hx + rw [interior_Icc] at hx + have hx0 : x β‰  0 := ne_of_gt hx.1 + convert (((hasDerivAt_const x 1).add + (Real.hasDerivAt_log hx0)).sub (hasDerivAt_id x)).hasDerivWithinAt + using 1 + Β· funext u + norm_num + ring + Β· intro x hx + rw [interior_Icc] at hx + have hxpos : 0 < x := hx.1 + have hxle : x ≀ 1 := hx.2.le + have hinv : 1 ≀ x⁻¹ := by + have hdiv : 1 ≀ 1 / x := (le_div_iffβ‚€ hxpos).2 (by simpa using hxle) + simpa only [one_div] using hdiv + linarith + convert hconv using 1 + funext x + rw [Real.norm_eq_abs, sq_abs] + ring + +/-- Scalar quadratic Jensen bonus for `negMulLog`. -/ +theorem negMulLog_segment_gap_quadratic + {t x y : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + (hx0 : 0 ≀ x) (hx1 : x ≀ 1) + (hy0 : 0 ≀ y) (hy1 : y ≀ 1) : + (1 - t) * Real.negMulLog x + t * Real.negMulLog y + + ((1 - t) * t / 2) * (x - y) ^ 2 ≀ + Real.negMulLog ((1 - t) * x + t * y) := by + have hstrong := strongConvexOn_mul_log_Icc.2 + (Set.mem_Icc.mpr ⟨hx0, hx1⟩) + (Set.mem_Icc.mpr ⟨hy0, hy1⟩) + (sub_nonneg.mpr ht1) ht0 (by ring : (1 - t) + t = 1) + simp only [smul_eq_mul, one_div] at hstrong + change (1 - t) * (-x * Real.log x) + t * (-y * Real.log y) + + (1 - t) * t / 2 * (x - y) ^ 2 ≀ + -((1 - t) * x + t * y) * Real.log ((1 - t) * x + t * y) + rw [Real.norm_eq_abs, sq_abs] at hstrong + linarith + +/-- Summing the scalar bonus gives a Frobenius-square Jensen gap for total +row entropy. -/ +theorem totalRowEntropy_segment_quadratic + {ΞΉ : Type*} [Fintype ΞΉ] + {t : ℝ} (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + {X Y : Matrix ΞΉ ΞΉ ℝ} + (hX0 : Matrix.Nonnegative X) (hX1 : βˆ€ i j, X i j ≀ 1) + (hY0 : Matrix.Nonnegative Y) (hY1 : βˆ€ i j, Y i j ≀ 1) : + (1 - t) * totalRowEntropy X + t * totalRowEntropy Y + + ((1 - t) * t / 2) * (βˆ‘ i, βˆ‘ j, (X i j - Y i j) ^ 2) ≀ + totalRowEntropy (matrixSegment t X Y) := by + simp only [totalRowEntropy, shannonEntropy] + rw [Finset.mul_sum, Finset.mul_sum, Finset.mul_sum] + rw [← Finset.sum_add_distrib, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro i _ + rw [Finset.mul_sum, Finset.mul_sum, Finset.mul_sum] + rw [← Finset.sum_add_distrib, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro j _ + simpa only [matrixSegment, mul_assoc] using + negMulLog_segment_gap_quadratic ht0 ht1 + (hX0 i j) (hX1 i j) (hY0 i j) (hY1 i j) + +/-- Strong-concavity form of the regularized Bethe segment inequality. -/ +theorem regularizedBetheObjective_segment_quadratic + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ t : ℝ} (hΟ„ : 0 ≀ Ο„) (ht0 : 0 ≀ t) (ht1 : t ≀ 1) + (A : Matrix ΞΉ ΞΉ ℝ) {X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) : + (1 - t) * regularizedBetheObjective Ο„ A X + + t * regularizedBetheObjective Ο„ A Y + + Ο„ * (((1 - t) * t / 2) * + (βˆ‘ i, βˆ‘ j, (X i j - Y i j) ^ 2)) ≀ + regularizedBetheObjective Ο„ A (matrixSegment t X Y) := by + have hbethe := betheObjective_segment_lower hcard A X Y hX hY ht0 ht1 + have hsegment : betheMatrixSegment t X Y = matrixSegment t X Y := by + ext i j + rfl + rw [hsegment] at hbethe + have hentropy := totalRowEntropy_segment_quadratic ht0 ht1 + hX.nonnegative (fun i j ↦ hX.entry_le_one i j) + hY.nonnegative (fun i j ↦ hY.entry_le_one i j) + have hscaled := mul_le_mul_of_nonneg_left hentropy hΟ„ + rw [regularizedBetheObjective, regularizedBetheObjective, + regularizedBetheObjective] + nlinarith + +/-- Objective suboptimality controls squared distance from any exact +regularized maximizer. The constant `Ο„/4` comes from the midpoint case. -/ +theorem regularizedBetheMaximizer_distance_sq_le_gap + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (hcard : 1 < Fintype.card ΞΉ) + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {A X Y : Matrix ΞΉ ΞΉ ℝ} + (hX : IsDoublyStochastic X) (hY : IsDoublyStochastic Y) + (hmax : βˆ€ Z, IsDoublyStochastic Z β†’ + regularizedBetheObjective Ο„ A Z ≀ + regularizedBetheObjective Ο„ A X) : + (Ο„ / 4) * (βˆ‘ i, βˆ‘ j, (X i j - Y i j) ^ 2) ≀ + regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A Y := by + have hmidDS := matrixSegment_doublyStochastic + (show (0 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 1 by norm_num) hX hY + have hupper := hmax _ hmidDS + have hlower := regularizedBetheObjective_segment_quadratic + hcard hΟ„ (show (0 : ℝ) ≀ 1 / 2 by norm_num) + (show (1 / 2 : ℝ) ≀ 1 by norm_num) A hX hY + norm_num at hlower + nlinarith + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/Transfer.lean b/LeanPool/BeyondBethe/BeyondBethe/Transfer.lean new file mode 100644 index 0000000000..557a0cdb52 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/Transfer.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Entropy +public import Mathlib.Analysis.SpecialFunctions.Log.Deriv +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Tactic + +/-! # Transfer -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- Interior probability vector. Both strict inequalities are recorded to +avoid repeatedly deriving the upper one from dimension assumptions. -/ +def IsInteriorProbabilityVector + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : Prop := + IsProbabilityVector p ∧ βˆ€ i, 0 < p i ∧ p i < 1 + +theorem IsInteriorProbabilityVector.strict + {ΞΉ : Type*} [Fintype ΞΉ] {p : ΞΉ β†’ ℝ} + (hp : IsInteriorProbabilityVector p) : + IsStrictProbabilityVector p := + ⟨hp.1, fun i ↦ (hp.2 i).1⟩ + +/-- Second moment of a finite probability vector. -/ +noncomputable def secondMoment + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : ℝ := + βˆ‘ i, (p i) ^ 2 + +theorem secondMoment_nonneg + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : + 0 ≀ secondMoment p := by + exact Finset.sum_nonneg fun _ _ ↦ sq_nonneg _ + +theorem secondMoment_lt_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) : + secondMoment p < 1 := by + have huniv : (Finset.univ : Finset ΞΉ).Nonempty := by + by_contra hempty + have hsum0 : βˆ‘ i, p i = 0 := by + rw [Finset.not_nonempty_iff_eq_empty.mp hempty] + simp + linarith [hp.1.sum_eq_one] + rw [← hp.1.sum_eq_one] + apply Finset.sum_lt_sum + Β· intro i _ + nlinarith [mul_nonneg (hp.1.nonnegative i) + (sub_nonneg.mpr (hp.1.le_one i))] + Β· obtain ⟨i, hi⟩ := huniv + refine ⟨i, hi, ?_⟩ + nlinarith [hp.2 i |>.1, hp.2 i |>.2] + +theorem coordinate_le_sqrt_secondMoment + {ΞΉ : Type*} [Fintype ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : βˆ€ i, 0 ≀ p i) (i : ΞΉ) : + p i ≀ Real.sqrt (secondMoment p) := by + have hs2 : (p i) ^ 2 ≀ secondMoment p := by + rw [secondMoment] + exact Finset.single_le_sum (fun j _ ↦ sq_nonneg (p j)) (Finset.mem_univ i) + exact (Real.le_sqrt (hp i) (secondMoment_nonneg p)).2 hs2 + +/-- Finite-dimensional monotonicity of `ell_p` norms in the exact form used +in the proof of paper Lemma 15. -/ +theorem sum_pow_le_sqrt_secondMoment_pow + {ΞΉ : Type*} [Fintype ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : βˆ€ i, 0 ≀ p i) {k : β„•} (hk : 2 ≀ k) : + βˆ‘ i, (p i) ^ k ≀ (Real.sqrt (secondMoment p)) ^ k := by + obtain ⟨t, rfl⟩ := Nat.exists_eq_add_of_le hk + have hcoord : βˆ€ i, p i ≀ Real.sqrt (secondMoment p) := + coordinate_le_sqrt_secondMoment hp + calc + βˆ‘ i, (p i) ^ (2 + t) + = βˆ‘ i, (p i) ^ 2 * (p i) ^ t := by + apply Finset.sum_congr rfl + intro i _ + rw [pow_add] + _ ≀ βˆ‘ i, (p i) ^ 2 * (Real.sqrt (secondMoment p)) ^ t := by + apply Finset.sum_le_sum + intro i _ + exact mul_le_mul_of_nonneg_left + (pow_le_pow_leftβ‚€ (hp i) (hcoord i) t) (sq_nonneg (p i)) + _ = secondMoment p * (Real.sqrt (secondMoment p)) ^ t := by + rw [← Finset.sum_mul, secondMoment] + _ = (Real.sqrt (secondMoment p)) ^ (2 + t) := by + rw [pow_add, Real.sq_sqrt (secondMoment_nonneg p)] + +/-- Product of the complementary coordinates of a row. -/ +noncomputable def complementProduct + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : ℝ := + ∏ i, (1 - p i) + +theorem complementProduct_pos + {ΞΉ : Type*} [Fintype ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) : + 0 < complementProduct p := by + rw [complementProduct] + exact Finset.prod_pos fun i _ ↦ sub_pos.mpr (hp.2 i).2 + +/-- The logarithmic estimate at the heart of the row-sum bound in paper +Lemma 15. -/ +theorem neg_log_complementProduct_le + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) : + -Real.log (complementProduct p) ≀ + 1 - Real.log (1 - secondMoment p) := by + let a : ℝ := Real.sqrt (secondMoment p) + have ha0 : 0 ≀ a := Real.sqrt_nonneg _ + have ha_sq : a ^ 2 = secondMoment p := Real.sq_sqrt (secondMoment_nonneg p) + have ha1 : a < 1 := by + nlinarith [secondMoment_lt_one hp] + have hpabs : βˆ€ i, |p i| < 1 := by + intro i + rw [abs_of_pos (hp.2 i).1] + exact (hp.2 i).2 + have hleft : HasSum + (fun n : β„• => βˆ‘ i, (p i) ^ (n + 1) / ((n : ℝ) + 1)) + (βˆ‘ i, -Real.log (1 - p i)) := by + classical + have hfinite : βˆ€ s : Finset ΞΉ, HasSum + (fun n : β„• => βˆ‘ i ∈ s, (p i) ^ (n + 1) / ((n : ℝ) + 1)) + (βˆ‘ i ∈ s, -Real.log (1 - p i)) := by + intro s + induction s using Finset.induction_on with + | empty => simp + | @insert i s hi ih => + have hsingle := Real.hasSum_pow_div_log_of_abs_lt_one (hpabs i) + simpa [Finset.sum_insert hi] using hsingle.add ih + simpa using hfinite Finset.univ + have haabs : |a| < 1 := by simpa [abs_of_nonneg ha0] + have haSeries := Real.hasSum_pow_div_log_of_abs_lt_one haabs + have hpoint := hasSum_ite_eq (0 : β„•) (1 - a) + have hright : HasSum + (fun n : β„• => + a ^ (n + 1) / ((n : ℝ) + 1) + if n = 0 then 1 - a else 0) + (-Real.log (1 - a) + (1 - a)) := by + exact haSeries.add hpoint + have hterm : βˆ€ n : β„•, + (βˆ‘ i, (p i) ^ (n + 1) / ((n : ℝ) + 1)) ≀ + a ^ (n + 1) / ((n : ℝ) + 1) + if n = 0 then 1 - a else 0 := by + intro n + cases n with + | zero => simp [hp.1.sum_eq_one] + | succ n => + have hk : 2 ≀ n.succ + 1 := by omega + have hpow := sum_pow_le_sqrt_secondMoment_pow hp.1.nonnegative hk + change (βˆ‘ i, (p i) ^ (n.succ + 1) / ((n.succ : ℝ) + 1)) ≀ _ + rw [← Finset.sum_div] + simp only [Nat.succ_ne_zero, ↓reduceIte, add_zero] + exact div_le_div_of_nonneg_right (by simpa [a] using hpow) + (by positivity) + have hseriesBound := hleft.summable.tsum_le_tsum hterm hright.summable + rw [hleft.tsum_eq, hright.tsum_eq] at hseriesBound + have halog : Real.log (1 + a) ≀ a := by + have := Real.log_le_sub_one_of_pos (by linarith : 0 < 1 + a) + linarith + have honeSub : 0 < 1 - a := sub_pos.mpr ha1 + have honeAdd : 0 < 1 + a := by linarith + have hlogFactor : + Real.log (1 - secondMoment p) = + Real.log (1 - a) + Real.log (1 + a) := by + rw [← Real.log_mul honeSub.ne' honeAdd.ne'] + congr 1 + nlinarith [ha_sq] + have hlogBound : + -Real.log (1 - a) + (1 - a) ≀ + 1 - Real.log (1 - secondMoment p) := by + rw [hlogFactor] + linarith + have hsumLog : + -Real.log (complementProduct p) = + βˆ‘ i, -Real.log (1 - p i) := by + rw [complementProduct, Real.log_prod] + Β· rw [Finset.sum_neg_distrib] + Β· intro i _ + exact (sub_pos.mpr (hp.2 i).2).ne' + rw [hsumLog] + exact hseriesBound.trans hlogBound + +/-- Exponentiating the preceding logarithmic estimate yields the product +bound used in paper Lemma 15. -/ +theorem exp_neg_one_mul_one_sub_secondMoment_le_complementProduct + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) : + Real.exp (-1) * (1 - secondMoment p) ≀ complementProduct p := by + have hd : 0 < 1 - secondMoment p := sub_pos.mpr (secondMoment_lt_one hp) + have hq : 0 < complementProduct p := complementProduct_pos hp + have hlog := neg_log_complementProduct_le hp + have hlog' : -1 + Real.log (1 - secondMoment p) ≀ + Real.log (complementProduct p) := by + linarith + have hexp := Real.exp_le_exp.mpr hlog' + rw [Real.exp_add, Real.exp_log hd, Real.exp_log hq] at hexp + exact hexp + +/-- Elementary product inequality +`1 - βˆ‘ x_i ≀ ∏ (1 - x_i)` for nonnegative numbers with sum at most one. -/ +theorem one_sub_sum_le_prod_one_sub + {ΞΉ : Type*} [DecidableEq ΞΉ] (s : Finset ΞΉ) (x : ΞΉ β†’ ℝ) + (hx : βˆ€ i ∈ s, 0 ≀ x i) (hsum : βˆ‘ i ∈ s, x i ≀ 1) : + 1 - βˆ‘ i ∈ s, x i ≀ ∏ i ∈ s, (1 - x i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => + have ha0 : 0 ≀ x a := hx a (Finset.mem_insert_self a s) + have hxs : βˆ€ i ∈ s, 0 ≀ x i := + fun i hi ↦ hx i (Finset.mem_insert_of_mem hi) + have hs0 : 0 ≀ βˆ‘ i ∈ s, x i := Finset.sum_nonneg hxs + have hsle : βˆ‘ i ∈ s, x i ≀ 1 := by + rw [Finset.sum_insert ha] at hsum + linarith + have hale : x a ≀ 1 := by + rw [Finset.sum_insert ha] at hsum + linarith + have hih := ih hxs hsle + rw [Finset.sum_insert ha, Finset.prod_insert ha] + have hmul := mul_le_mul_of_nonneg_left hih (sub_nonneg.mpr hale) + nlinarith [mul_nonneg ha0 hs0] + +/-- Product of all complementary coordinates except `j`. -/ +noncomputable def productExcept + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) (j : ΞΉ) : ℝ := + ∏ k ∈ Finset.univ.erase j, (1 - p k) + +theorem self_le_productExcept + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsProbabilityVector p) (j : ΞΉ) : + p j ≀ productExcept p j := by + have hsum : βˆ‘ k ∈ Finset.univ.erase j, p k = 1 - p j := by + have htotal := hp.sum_eq_one + rw [← Finset.sum_erase_add _ _ (Finset.mem_univ j)] at htotal + linarith + have hprod := one_sub_sum_le_prod_one_sub + (Finset.univ.erase j) p + (fun k _ ↦ hp.nonnegative k) + (by rw [hsum]; linarith [hp.nonnegative j]) + change 1 - βˆ‘ k ∈ Finset.univ.erase j, p k ≀ productExcept p j at hprod + rw [hsum] at hprod + linarith + +theorem productExcept_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + 0 < productExcept p j := by + rw [productExcept] + exact Finset.prod_pos fun k _ ↦ sub_pos.mpr (hp.2 k).2 + +theorem complementProduct_eq_mul_productExcept + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (p : ΞΉ β†’ ℝ) (j : ΞΉ) : + complementProduct p = (1 - p j) * productExcept p j := by + rw [complementProduct, productExcept] + exact (Finset.mul_prod_erase Finset.univ (fun k ↦ 1 - p k) + (Finset.mem_univ j)).symm + +/-- Transfer coordinate `U_j` from paper (37). -/ +noncomputable def transferU + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + (Ο„ : ℝ) (p : ΞΉ β†’ ℝ) (j : ΞΉ) : ℝ := + (p j) ^ (1 + Ο„) / productExcept p j + +theorem transferU_pos + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + 0 < transferU Ο„ p j := by + exact div_pos (Real.rpow_pos_of_pos (hp.2 j).1 _) (productExcept_pos hp j) + +theorem transferU_le_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {p : ΞΉ β†’ ℝ} + (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + transferU Ο„ p j ≀ 1 := by + have hpow : (p j) ^ (1 + Ο„) ≀ p j := by + have h := Real.rpow_le_rpow_of_exponent_ge' + (hp.1.nonnegative j) (hp.2 j).2.le (by norm_num : (0 : ℝ) ≀ 1) + (by linarith : (1 : ℝ) ≀ 1 + Ο„) + simpa using h + have hnum : (p j) ^ (1 + Ο„) ≀ productExcept p j := + hpow.trans (self_le_productExcept hp.1 j) + rw [transferU, div_le_one (productExcept_pos hp j)] + exact hnum + +theorem transferU_eq_div_complementProduct + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + transferU Ο„ p j = + (p j) ^ (1 + Ο„) * (1 - p j) / complementProduct p := by + rw [transferU, complementProduct_eq_mul_productExcept p j] + field_simp [(sub_pos.mpr (hp.2 j).2).ne', (productExcept_pos hp j).ne'] + +/-- The full row-sum conclusion of paper Lemma 15. -/ +theorem sum_transferU_le_exp_one + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) {p : ΞΉ β†’ ℝ} + (hp : IsInteriorProbabilityVector p) : + βˆ‘ j, transferU Ο„ p j ≀ Real.exp 1 := by + have hq : 0 < complementProduct p := complementProduct_pos hp + have hpoint : βˆ€ j, + transferU Ο„ p j ≀ p j * (1 - p j) / complementProduct p := by + intro j + rw [transferU_eq_div_complementProduct hp j] + have hpow : (p j) ^ (1 + Ο„) ≀ p j := by + have h := Real.rpow_le_rpow_of_exponent_ge' + (hp.1.nonnegative j) (hp.2 j).2.le (by norm_num : (0 : ℝ) ≀ 1) + (by linarith : (1 : ℝ) ≀ 1 + Ο„) + simpa using h + exact div_le_div_of_nonneg_right + (mul_le_mul_of_nonneg_right hpow (sub_nonneg.mpr (hp.1.le_one j))) hq.le + calc + βˆ‘ j, transferU Ο„ p j + ≀ βˆ‘ j, p j * (1 - p j) / complementProduct p := + Finset.sum_le_sum fun j _ ↦ hpoint j + _ = (1 - secondMoment p) / complementProduct p := by + rw [← Finset.sum_div] + simp_rw [mul_sub, mul_one] + rw [Finset.sum_sub_distrib, hp.1.sum_eq_one, secondMoment] + simp only [pow_two] + _ ≀ Real.exp 1 := by + rw [div_le_iffβ‚€ hq] + have hbase := + exp_neg_one_mul_one_sub_secondMoment_le_complementProduct hp + have hexppos : 0 < Real.exp 1 := Real.exp_pos 1 + have hscaled := mul_le_mul_of_nonneg_left hbase hexppos.le + have hexpinv : Real.exp 1 * Real.exp (-1) = 1 := by + rw [← Real.exp_add] + norm_num + calc + 1 - secondMoment p = + Real.exp 1 * (Real.exp (-1) * (1 - secondMoment p)) := by + rw [← mul_assoc, hexpinv, one_mul] + _ ≀ Real.exp 1 * complementProduct p := hscaled + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/TransferIdentity.lean b/LeanPool/BeyondBethe/BeyondBethe/TransferIdentity.lean new file mode 100644 index 0000000000..d8c3c008dd --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/TransferIdentity.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Transfer +public import LeanPool.BeyondBethe.BeyondBethe.Slack +public import Mathlib.Tactic + +/-! # Transfer Identity -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-- The row contribution `h_B` used in the transfer identity. -/ +noncomputable def betheEntropyContribution + {ΞΉ : Type*} [Fintype ΞΉ] (p : ΞΉ β†’ ℝ) : ℝ := + shannonEntropy p + βˆ‘ j, (1 - p j) * Real.log (1 - p j) + +/-- Logarithmic form of the KKT factorization. It is the exact form needed +for the transfer identity; exponentiating the row and column potentials gives +the positive scalings in the paper. -/ +def HasLogKKT + {ΞΉ : Type*} [Fintype ΞΉ] + (Ο„ : ℝ) (A X : Matrix ΞΉ ΞΉ ℝ) (r c : ΞΉ β†’ ℝ) : Prop := + βˆ€ i j, Real.log (A i j) = r i + c j + + (1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j) + +/-- The regularized Bethe coordinate `x * log a - (1 + Ο„) * x * log x + (1 - x) * log (1 - x)`. -/ +noncomputable def regularizedBetheCoordinate + (Ο„ a x : ℝ) : ℝ := + x * Real.log a + Real.negMulLog x + + (1 - x) * Real.log (1 - x) + Ο„ * Real.negMulLog x + +theorem regularizedBetheObjective_eq_sum_coordinates + {ΞΉ : Type*} [Fintype ΞΉ] (Ο„ : ℝ) (A X : Matrix ΞΉ ΞΉ ℝ) : + regularizedBetheObjective Ο„ A X = + βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate Ο„ (A i j) (X i j) := by + rw [regularizedBetheObjective, betheObjective, totalRowEntropy] + simp_rw [betheRowObjective, shannonEntropy, regularizedBetheCoordinate] + simp only [Finset.mul_sum, ← Finset.sum_add_distrib] + +theorem betheEntropyContribution_add_regularizer_eq_sum + {ΞΉ : Type*} [Fintype ΞΉ] (Ο„ : ℝ) (P : Matrix ΞΉ ΞΉ ℝ) : + βˆ‘ i, (betheEntropyContribution (P i) + Ο„ * shannonEntropy (P i)) = + βˆ‘ i, βˆ‘ j, (Real.negMulLog (P i j) + + (1 - P i j) * Real.log (1 - P i j) + + Ο„ * Real.negMulLog (P i j)) := by + simp_rw [betheEntropyContribution, shannonEntropy, Finset.mul_sum, + ← Finset.sum_add_distrib] + +theorem rowScore_eq_rowCorrection_add_betheEntropyContribution + {m : β„•} (p : Fin m β†’ ℝ) : + rowScore p = rowCorrection p + betheEntropyContribution p := by + rw [rowScore, rowCorrection, betheEntropyContribution] + ring + +/-- The upper-bound algebra in paper Lemma 16. The hypotheses name exactly +the three analytic/optimization inputs used in the paper: regularized +suboptimality, the size of the entropy regularizer, and the exact slack +decomposition. -/ +theorem global_transfer_upper_of_slack + {n : β„•} {Ο„ ΞΎ E EΟ„ gibbsEntropy divergence slack : ℝ} + (P : Matrix (Fin n) (Fin n) ℝ) + (hEΟ„ : EΟ„ ≀ E + ΞΎ * n) + (hregularizer : Ο„ * totalRowEntropy P ≀ ΞΎ * n) + (hdivergence : divergence = + -gibbsEntropy + βˆ‘ i, rowScore (P i)) + (hslack : slack = E + (βˆ‘ i, rowDeficit (P i)) + divergence) : + EΟ„ + βˆ‘ i, (betheEntropyContribution (P i) + + Ο„ * shannonEntropy (P i)) ≀ + slack + 2 * ΞΎ * n + gibbsEntropy - n * (Real.log 2 / 2) := by + have hscore : (βˆ‘ i, rowScore (P i)) = + (βˆ‘ i, rowCorrection (P i)) + + βˆ‘ i, betheEntropyContribution (P i) := by + simp_rw [rowScore_eq_rowCorrection_add_betheEntropyContribution] + exact Finset.sum_add_distrib + have hentropy : (βˆ‘ i, betheEntropyContribution (P i)) = + gibbsEntropy + divergence - βˆ‘ i, rowCorrection (P i) := by + linarith + have hregularizerSum : + (βˆ‘ i, Ο„ * shannonEntropy (P i)) = + Ο„ * totalRowEntropy P := by + rw [totalRowEntropy, Finset.mul_sum] + have hdeficit : (βˆ‘ i, rowDeficit (P i)) = + n * (Real.log 2 / 2) - βˆ‘ i, rowCorrection (P i) := by + simp_rw [rowDeficit, Finset.sum_sub_distrib, Finset.sum_const, + nsmul_eq_mul] + rw [Finset.card_univ, Fintype.card_fin] + rw [Finset.sum_add_distrib, hentropy, hregularizerSum] + linarith + +theorem neg_regularizedCoordinate_add_entropy + (Ο„ a x : ℝ) : + -regularizedBetheCoordinate Ο„ a x + + (Real.negMulLog x + (1 - x) * Real.log (1 - x) + + Ο„ * Real.negMulLog x) = + -x * Real.log a := by + rw [regularizedBetheCoordinate] + ring + +theorem regularizedCoordinate_of_logKKT + (Ο„ x R C : ℝ) : + x * (R + C + (1 + Ο„) * Real.log x + Real.log (1 - x)) + + Real.negMulLog x + (1 - x) * Real.log (1 - x) + + Ο„ * Real.negMulLog x = + x * (R + C) + Real.log (1 - x) := by + rw [Real.negMulLog_def] + ring + +theorem rowColumnPotential_sum_eq + {ΞΉ : Type*} [Fintype ΞΉ] + {X P : Matrix ΞΉ ΞΉ ℝ} (hX : IsDoublyStochastic X) + (hP : IsDoublyStochastic P) (r c : ΞΉ β†’ ℝ) : + (βˆ‘ i, βˆ‘ j, X i j * (r i + c j)) = + βˆ‘ i, βˆ‘ j, P i j * (r i + c j) := by + have hrowX : (βˆ‘ i, βˆ‘ j, X i j * r i) = βˆ‘ i, r i := by + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_mul, hX.row_sum i, one_mul] + have hrowP : (βˆ‘ i, βˆ‘ j, P i j * r i) = βˆ‘ i, r i := by + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_mul, hP.row_sum i, one_mul] + have hcolX : (βˆ‘ i, βˆ‘ j, X i j * c j) = βˆ‘ j, c j := by + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + rw [← Finset.sum_mul, hX.col_sum j, one_mul] + have hcolP : (βˆ‘ i, βˆ‘ j, P i j * c j) = βˆ‘ j, c j := by + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + rw [← Finset.sum_mul, hP.col_sum j, one_mul] + simp_rw [mul_add, Finset.sum_add_distrib] + linarith + +theorem log_one_div_transferU + {ΞΉ : Type*} [Fintype ΞΉ] [DecidableEq ΞΉ] + {Ο„ : ℝ} {p : ΞΉ β†’ ℝ} (hp : IsInteriorProbabilityVector p) (j : ΞΉ) : + Real.log (1 / transferU Ο„ p j) = + -(1 + Ο„) * Real.log (p j) - Real.log (1 - p j) + + Real.log (complementProduct p) := by + rw [transferU_eq_div_complementProduct hp j, one_div_div] + have hpPow : 0 < (p j) ^ (1 + Ο„) := + Real.rpow_pos_of_pos (hp.2 j).1 _ + have hcomp : 0 < 1 - p j := sub_pos.mpr (hp.2 j).2 + have hq : 0 < complementProduct p := complementProduct_pos hp + rw [Real.log_div hq.ne' (mul_ne_zero hpPow.ne' hcomp.ne'), + Real.log_mul hpPow.ne' hcomp.ne', Real.log_rpow (hp.2 j).1] + ring + +/-- Paper Lemma 16, the exact global transfer identity, assuming the KKT +equations. No optimization theorem or analytic approximation is used in +this algebraic step. -/ +theorem global_transfer_identity_of_logKKT + {n : β„•} {Ο„ : ℝ} {A X P : Matrix (Fin n) (Fin n) ℝ} + {r c : Fin n β†’ ℝ} + (hX : IsDoublyStochastic X) (hP : IsDoublyStochastic P) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hKKT : HasLogKKT Ο„ A X r c) : + (regularizedBetheObjective Ο„ A X - regularizedBetheObjective Ο„ A P) + + βˆ‘ i, (betheEntropyContribution (P i) + Ο„ * shannonEntropy (P i)) = + βˆ‘ i, βˆ‘ j, P i j * Real.log (1 / transferU Ο„ (X i) j) := by + unfold HasLogKKT at hKKT + have hPcancel : + -(βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate Ο„ (A i j) (P i j)) + + βˆ‘ i, βˆ‘ j, (Real.negMulLog (P i j) + + (1 - P i j) * Real.log (1 - P i j) + + Ο„ * Real.negMulLog (P i j)) = + -(βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j)) := by + calc + -(βˆ‘ i, βˆ‘ j, regularizedBetheCoordinate Ο„ (A i j) (P i j)) + + βˆ‘ i, βˆ‘ j, (Real.negMulLog (P i j) + + (1 - P i j) * Real.log (1 - P i j) + + Ο„ * Real.negMulLog (P i j)) = + βˆ‘ i, βˆ‘ j, (-regularizedBetheCoordinate Ο„ (A i j) (P i j) + + (Real.negMulLog (P i j) + + (1 - P i j) * Real.log (1 - P i j) + + Ο„ * Real.negMulLog (P i j))) := by + simp only [Finset.sum_add_distrib, Finset.sum_neg_distrib] + _ = βˆ‘ i, βˆ‘ j, -(P i j * Real.log (A i j)) := by + apply Finset.sum_congr rfl + intro i _ + apply Finset.sum_congr rfl + intro j _ + rw [neg_regularizedCoordinate_add_entropy] + ring + _ = -(βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j)) := by + simp only [Finset.sum_neg_distrib] + have hcancel : + (regularizedBetheObjective Ο„ A X - regularizedBetheObjective Ο„ A P) + + βˆ‘ i, (betheEntropyContribution (P i) + Ο„ * shannonEntropy (P i)) = + regularizedBetheObjective Ο„ A X - + βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j) := by + rw [regularizedBetheObjective_eq_sum_coordinates, + regularizedBetheObjective_eq_sum_coordinates, + betheEntropyContribution_add_regularizer_eq_sum] + linarith + have hphiX : + regularizedBetheObjective Ο„ A X = + (βˆ‘ i, βˆ‘ j, X i j * (r i + c j)) + + βˆ‘ i, βˆ‘ j, Real.log (1 - X i j) := by + rw [regularizedBetheObjective_eq_sum_coordinates] + simp_rw [regularizedBetheCoordinate, hKKT, + regularizedCoordinate_of_logKKT] + simp only [Finset.sum_add_distrib] + have hlogAP : + (βˆ‘ i, βˆ‘ j, P i j * Real.log (A i j)) = + (βˆ‘ i, βˆ‘ j, P i j * (r i + c j)) + + βˆ‘ i, βˆ‘ j, P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j)) := by + simp_rw [hKKT] + simp only [mul_add, Finset.sum_add_distrib] + ring + have hpot := rowColumnPotential_sum_eq hX hP r c + have hq : βˆ€ i, + Real.log (complementProduct (X i)) = + βˆ‘ j, Real.log (1 - X i j) := by + intro i + rw [complementProduct, Real.log_prod] + intro j _ + exact (sub_pos.mpr ((hXint i).2 j).2).ne' + have hweightedQ : + (βˆ‘ i, βˆ‘ j, P i j * (βˆ‘ k, Real.log (1 - X i k))) = + βˆ‘ i, βˆ‘ k, Real.log (1 - X i k) := by + apply Finset.sum_congr rfl + intro i _ + rw [← Finset.sum_mul, hP.row_sum i, one_mul] + have hcostNeg : + (βˆ‘ i, βˆ‘ j, P i j * + (-(1 + Ο„) * Real.log (X i j) - Real.log (1 - X i j))) = + -(βˆ‘ i, βˆ‘ j, P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j))) := by + calc + (βˆ‘ i, βˆ‘ j, P i j * + (-(1 + Ο„) * Real.log (X i j) - Real.log (1 - X i j))) = + βˆ‘ i, βˆ‘ j, -(P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j))) := by + apply Finset.sum_congr rfl + intro i _ + apply Finset.sum_congr rfl + intro j _ + ring + _ = -(βˆ‘ i, βˆ‘ j, P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j))) := by + simp only [Finset.sum_neg_distrib] + have htransferCost : + (βˆ‘ i, βˆ‘ j, P i j * Real.log (1 / transferU Ο„ (X i) j)) = + -(βˆ‘ i, βˆ‘ j, P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j))) + + βˆ‘ i, βˆ‘ k, Real.log (1 - X i k) := by + calc + (βˆ‘ i, βˆ‘ j, P i j * Real.log (1 / transferU Ο„ (X i) j)) = + βˆ‘ i, βˆ‘ j, P i j * + (-(1 + Ο„) * Real.log (X i j) - Real.log (1 - X i j) + + Real.log (complementProduct (X i))) := by + simp_rw [log_one_div_transferU (hXint _)] + _ = (βˆ‘ i, βˆ‘ j, P i j * + (-(1 + Ο„) * Real.log (X i j) - Real.log (1 - X i j))) + + βˆ‘ i, βˆ‘ j, P i j * Real.log (complementProduct (X i)) := by + simp only [mul_add, Finset.sum_add_distrib] + _ = -(βˆ‘ i, βˆ‘ j, P i j * + ((1 + Ο„) * Real.log (X i j) + Real.log (1 - X i j))) + + βˆ‘ i, βˆ‘ k, Real.log (1 - X i k) := by + rw [hcostNeg] + simp_rw [hq] + rw [hweightedQ] + rw [hcancel, hphiX, hlogAP, htransferCost] + linarith + +/-- Paper Lemma 16 in its upper-bound form, with the KKT and slack inputs +kept explicit. -/ +theorem global_transfer_upper_of_logKKT_and_slack + {n : β„•} {Ο„ ΞΎ E gibbsEntropy divergence slack : ℝ} + {A X P : Matrix (Fin n) (Fin n) ℝ} {r c : Fin n β†’ ℝ} + (hX : IsDoublyStochastic X) (hP : IsDoublyStochastic P) + (hXint : βˆ€ i, IsInteriorProbabilityVector (X i)) + (hKKT : HasLogKKT Ο„ A X r c) + (hEΟ„ : regularizedBetheObjective Ο„ A X - + regularizedBetheObjective Ο„ A P ≀ E + ΞΎ * n) + (hregularizer : Ο„ * totalRowEntropy P ≀ ΞΎ * n) + (hdivergence : divergence = + -gibbsEntropy + βˆ‘ i, rowScore (P i)) + (hslack : slack = E + (βˆ‘ i, rowDeficit (P i)) + divergence) : + βˆ‘ i, βˆ‘ j, P i j * Real.log (1 / transferU Ο„ (X i) j) ≀ + slack + 2 * ΞΎ * n + gibbsEntropy - n * (Real.log 2 / 2) := by + rw [← global_transfer_identity_of_logKKT hX hP hXint hKKT] + exact global_transfer_upper_of_slack P hEΟ„ hregularizer + hdivergence hslack + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/BeyondBethe/WeakSeparation.lean b/LeanPool/BeyondBethe/BeyondBethe/WeakSeparation.lean new file mode 100644 index 0000000000..220db26410 --- /dev/null +++ b/LeanPool/BeyondBethe/BeyondBethe/WeakSeparation.lean @@ -0,0 +1,273 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.DirectedOptimizerOracle +public import LeanPool.BeyondBethe.BeyondBethe.NumericalNearby +public import LeanPool.BeyondBethe.BeyondBethe.NumericalPotentials +public import Mathlib.Tactic + +/-! # Weak Separation -/ + +@[expose] public section + +open scoped BigOperators + +namespace BeyondBethe + +/-! +# Supporting cuts in rational affine coordinates + +The affine pullback of a full matrix gradient has a four-corner formula. +Making this formula explicit avoids any appeal to an abstract adjoint and is +the algebraic core of the separation oracle. +-/ + +/-- Pull a full matrix covector back through the upper-left affine +parametrization of the Birkhoff affine hull. -/ +def affinePullbackGradient {n : β„•} {R : Type*} [AddCommGroup R] + (G : Matrix (Fin (n + 1)) (Fin (n + 1)) R) : + Matrix (Fin n) (Fin n) R := + fun i j ↦ G i.castSucc j.castSucc - G i.castSucc (Fin.last n) - + G (Fin.last n) j.castSucc + G (Fin.last n) (Fin.last n) + +/-- Matrix pairing written as an explicit finite sum. -/ +def matrixPairing {m n : Type*} [Fintype m] [Fintype n] + {R : Type*} [Semiring R] (G D : Matrix m n R) : R := + βˆ‘ i, βˆ‘ j, G i j * D i j + +/-- Exact adjoint identity for the affine recovery map. -/ +theorem matrixPairing_affineMap_sub {n : β„•} {R : Type*} [CommRing R] + (G : Matrix (Fin (n + 1)) (Fin (n + 1)) R) + (Y Z : Matrix (Fin n) (Fin n) R) : + matrixPairing G + (fun i j ↦ birkhoffAffineMap Z i j - birkhoffAffineMap Y i j) = + matrixPairing (affinePullbackGradient G) + (fun i j ↦ Z i j - Y i j) := by + simp only [matrixPairing] + have hpull : βˆ€ i j, + affinePullbackGradient G i j * (Z i j - Y i j) = + G i.castSucc j.castSucc * Z i j - + G i.castSucc j.castSucc * Y i j - + G i.castSucc (Fin.last n) * Z i j + + G i.castSucc (Fin.last n) * Y i j - + G (Fin.last n) j.castSucc * Z i j + + G (Fin.last n) j.castSucc * Y i j + + G (Fin.last n) (Fin.last n) * Z i j - + G (Fin.last n) (Fin.last n) * Y i j := by + intro i j + rw [affinePullbackGradient] + ring + simp_rw [hpull] + simp only [Finset.sum_add_distrib, Finset.sum_sub_distrib] + rw [Fin.sum_univ_castSucc] + simp_rw [Fin.sum_univ_castSucc] + simp only [birkhoffAffineMap_castSucc_castSucc, + birkhoffAffineMap_castSucc_last, birkhoffAffineMap_last_castSucc, + birkhoffAffineMap_last_last] + ring_nf + simp_rw [Finset.mul_sum] + simp_rw [Finset.sum_add_distrib, Finset.sum_neg_distrib] + have hcolZ : + (βˆ‘ j, βˆ‘ i, G (Fin.last n) j.castSucc * Z i j) = + βˆ‘ i, βˆ‘ j, G (Fin.last n) j.castSucc * Z i j := by + exact Finset.sum_comm + have hcolY : + (βˆ‘ j, βˆ‘ i, G (Fin.last n) j.castSucc * Y i j) = + βˆ‘ i, βˆ‘ j, G (Fin.last n) j.castSucc * Y i j := by + exact Finset.sum_comm + rw [hcolZ, hcolY] + repeat' first + | rw [Finset.sum_add_distrib] + | rw [Finset.sum_sub_distrib] + | rw [Finset.sum_neg_distrib] + have hupperBlock : + (βˆ‘ i, βˆ‘ j, + (G i.castSucc j.castSucc * Z i j - + G i.castSucc j.castSucc * Y i j)) = + (βˆ‘ i, βˆ‘ j, G i.castSucc j.castSucc * Z i j) - + βˆ‘ i, βˆ‘ j, G i.castSucc j.castSucc * Y i j := by + simp only [Finset.sum_sub_distrib] + rw [hupperBlock] + module + +/-- The negative regularized objective in upper-left affine coordinates. -/ +noncomputable def affineNegativeObjective {n : β„•} + (Ο„ : ℝ) (A : Matrix (Fin (n + 1)) (Fin (n + 1)) ℝ) + (Y : Matrix (Fin n) (Fin n) ℝ) : ℝ := + -regularizedBetheObjective Ο„ A (birkhoffAffineMap Y) + +/-- The exact full negative gradient at a rational or real interior point. -/ +noncomputable def negativeGradientMatrix {n : β„•} + (Ο„ : ℝ) (A X : Matrix (Fin n) (Fin n) ℝ) : Matrix (Fin n) (Fin n) ℝ := + fun i j ↦ negativeRegularizedBetheGradientCoordinate Ο„ (A i j) (X i j) + +theorem negativeGradientMatrix_eq_neg_gradient {n : β„•} + (Ο„ : ℝ) (A X : Matrix (Fin n) (Fin n) ℝ) (i j : Fin n) : + negativeGradientMatrix Ο„ A X i j = + -regularizedBetheGradient Ο„ A X i j := by + rw [negativeGradientMatrix, regularizedBetheGradient, + negativeRegularizedBetheGradientCoordinate_eq_neg] + +/-- Convexity gives the exact supporting-hyperplane inequality in the +explicit affine coordinates. -/ +theorem affineNegativeObjective_support + {n : β„•} (hn : 0 < n) {Ο„ : ℝ} (hΟ„ : 0 ≀ Ο„) + {A : Matrix (Fin (n + 1)) (Fin (n + 1)) ℝ} + {Y Z : Matrix (Fin n) (Fin n) ℝ} + (hY : IsDoublyStochastic (birkhoffAffineMap Y)) + (hZ : IsDoublyStochastic (birkhoffAffineMap Z)) + (hYint : βˆ€ i, IsInteriorProbabilityVector (birkhoffAffineMap Y i)) : + affineNegativeObjective Ο„ A Y + + matrixPairing + (affinePullbackGradient + (negativeGradientMatrix Ο„ A (birkhoffAffineMap Y))) + (fun i j ↦ Z i j - Y i j) ≀ + affineNegativeObjective Ο„ A Z := by + have hsupp := regularizedBetheObjective_sub_le_gradient + (show 1 < Fintype.card (Fin (n + 1)) by simp; omega) + (A := A) (X := birkhoffAffineMap Y) (Y := birkhoffAffineMap Z) + hΟ„ hY hZ hYint + have hpair := matrixPairing_affineMap_sub + (negativeGradientMatrix Ο„ A (birkhoffAffineMap Y)) Y Z + have hG : negativeGradientMatrix Ο„ A (birkhoffAffineMap Y) = + fun i j ↦ -regularizedBetheGradient Ο„ A (birkhoffAffineMap Y) i j := by + ext i j + exact negativeGradientMatrix_eq_neg_gradient Ο„ A (birkhoffAffineMap Y) i j + rw [hG] at hpair ⊒ + simp only [matrixPairing, neg_mul] at hpair ⊒ + rw [← hpair] + simp_rw [Finset.sum_neg_distrib] + simp only [affineNegativeObjective] + linarith + +/-- Executable rational full-gradient lower endpoint. -/ +def directedNegativeGradientLowerMatrix {n : β„•} + (Ο„ : β„š) (A X : Matrix (Fin n) (Fin n) β„š) (p : β„•) : + Matrix (Fin n) (Fin n) β„š := + fun i j ↦ directedNegativeGradientLower Ο„ (A i j) (X i j) p + +/-- Every pullback coordinate combines four full-gradient coordinates. Thus +an entrywise full-gradient error `e` becomes at most `4e`. -/ +theorem affinePullbackGradient_error_le_four + {n : β„•} {G H : Matrix (Fin (n + 1)) (Fin (n + 1)) ℝ} {e : ℝ} + (h : βˆ€ i j, abs (G i j - H i j) ≀ e) (i j : Fin n) : + abs (affinePullbackGradient G i j - + affinePullbackGradient H i j) ≀ 4 * e := by + rw [affinePullbackGradient, affinePullbackGradient] + have hid : + (G i.castSucc j.castSucc - G i.castSucc (Fin.last n) - + G (Fin.last n) j.castSucc + G (Fin.last n) (Fin.last n)) - + (H i.castSucc j.castSucc - H i.castSucc (Fin.last n) - + H (Fin.last n) j.castSucc + H (Fin.last n) (Fin.last n)) = + (G i.castSucc j.castSucc - H i.castSucc j.castSucc) - + (G i.castSucc (Fin.last n) - H i.castSucc (Fin.last n)) - + (G (Fin.last n) j.castSucc - H (Fin.last n) j.castSucc) + + (G (Fin.last n) (Fin.last n) - H (Fin.last n) (Fin.last n)) := by ring + rw [hid] + exact abs_sub_sub_add_le_four + (h i.castSucc j.castSucc) (h i.castSucc (Fin.last n)) + (h (Fin.last n) j.castSucc) (h (Fin.last n) (Fin.last n)) + +/-- At precision `p`, the executable pullback gradient is within +`16Β·2⁻ᡖ` in every coordinate. -/ +theorem directedAffineGradient_error + {n : β„•} {Ο„ : β„š} {A X : Matrix (Fin (n + 1)) (Fin (n + 1)) β„š} + (hΟ„0 : 0 ≀ Ο„) (hΟ„1 : Ο„ ≀ 1) + (hA : βˆ€ i j, 0 < A i j) + (hX0 : βˆ€ i j, 0 < X i j) (hX1 : βˆ€ i j, X i j < 1) + (p : β„•) (i j : Fin n) : + abs (affinePullbackGradient + (negativeGradientMatrix (Ο„ : ℝ) + (fun i j ↦ (A i j : ℝ)) (fun i j ↦ (X i j : ℝ))) i j - + (affinePullbackGradient + (fun i j ↦ ((directedNegativeGradientLowerMatrix Ο„ A X p i j : β„š) : ℝ))) i j) ≀ + 16 * (((1 / 2 : β„š) ^ p : β„š) : ℝ) := by + apply (affinePullbackGradient_error_le_four + (e := 4 * (((1 / 2 : β„š) ^ p : β„š) : ℝ)) ?_ i j).trans_eq + Β· ring + intro a b + have hb := directedNegativeGradient_bounds hΟ„0 hΟ„1 + (hA a b) (hX0 a b) (hX1 a b) p + have hlo := hb.1 + have hwidth := hb.2.2 + change abs (negativeRegularizedBetheGradientCoordinate + (Ο„ : ℝ) (A a b : ℝ) (X a b : ℝ) - + (directedNegativeGradientLower Ο„ (A a b) (X a b) p : ℝ)) ≀ _ + rw [abs_of_nonneg (sub_nonneg.mpr hlo)] + linarith [hb.2.1] + +/-- Entrywise `β„“1` size of a matrix displacement. -/ +def matrixL1 {m n : Type*} [Fintype m] [Fintype n] + (D : Matrix m n ℝ) : ℝ := + βˆ‘ i, βˆ‘ j, abs (D i j) + +theorem matrixL1_nonneg {m n : Type*} [Fintype m] [Fintype n] + (D : Matrix m n ℝ) : 0 ≀ matrixL1 D := by + exact Finset.sum_nonneg fun i _ ↦ Finset.sum_nonneg fun j _ ↦ abs_nonneg _ + +/-- Coordinatewise covector error controls pairing error by the `β„“1` size +of the displacement. -/ +theorem matrixPairing_sub_le_error_mul_l1 + {m n : Type*} [Fintype m] [Fintype n] + {G H D : Matrix m n ℝ} {e : ℝ} + (herr : βˆ€ i j, abs (G i j - H i j) ≀ e) : + matrixPairing G D - matrixPairing H D ≀ e * matrixL1 D := by + rw [matrixPairing, matrixPairing, matrixL1, ← Finset.sum_sub_distrib, + Finset.mul_sum] + apply Finset.sum_le_sum + intro i _ + rw [← Finset.sum_sub_distrib, Finset.mul_sum] + apply Finset.sum_le_sum + intro j _ + have hpoint : + (G i j - H i j) * D i j ≀ e * abs (D i j) := by + calc + (G i j - H i j) * D i j ≀ + abs ((G i j - H i j) * D i j) := le_abs_self _ + _ = abs (G i j - H i j) * abs (D i j) := abs_mul _ _ + _ ≀ e * abs (D i j) := + mul_le_mul_of_nonneg_right (herr i j) (abs_nonneg _) + convert hpoint using 1 <;> ring + +/-- Generic tolerant epigraph-cut lemma. It records all three losses used by +the executable oracle: a one-sided value approximation, a coordinatewise +gradient approximation, and a known `β„“1` radius for candidate displacements. -/ +theorem approximateEpigraphCut_valid + {m n : Type*} [Fintype m] [Fintype n] + {fY fZ lower t s e Dmax : ℝ} + {G H D : Matrix m n ℝ} + (hsupport : fY + matrixPairing G D ≀ fZ) + (hlower : lower ≀ fY) + (hgradient : βˆ€ i j, abs (H i j - G i j) ≀ e) + (hD : matrixL1 D ≀ Dmax) + (he : 0 ≀ e) (hepigraph : fZ ≀ s) : + matrixPairing H D - (s - t) ≀ + t - lower + e * Dmax := by + have hpair := matrixPairing_sub_le_error_mul_l1 + (G := H) (H := G) (D := D) hgradient + have hscale := mul_le_mul_of_nonneg_left hD he + linarith + +/-- If the certified lower value exceeds the query height by more than the +gradient-error budget, the approximate supporting hyperplane strictly +separates the query from every epigraph point in the prescribed radius. -/ +theorem approximateEpigraphCut_strict + {m n : Type*} [Fintype m] [Fintype n] + {fY fZ lower t s e Dmax margin : ℝ} + {G H D : Matrix m n ℝ} + (hsupport : fY + matrixPairing G D ≀ fZ) + (hlower : lower ≀ fY) + (hgradient : βˆ€ i j, abs (H i j - G i j) ≀ e) + (hD : matrixL1 D ≀ Dmax) + (he : 0 ≀ e) (hepigraph : fZ ≀ s) + (hviolation : t - lower + e * Dmax ≀ -margin) : + matrixPairing H D - (s - t) ≀ -margin := + (approximateEpigraphCut_valid hsupport hlower hgradient hD he hepigraph).trans + hviolation + +end BeyondBethe diff --git a/LeanPool/BeyondBethe/Complexitylib.lean b/LeanPool/BeyondBethe/Complexitylib.lean new file mode 100644 index 0000000000..f83126ac43 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Circuits +public import LeanPool.BeyondBethe.Complexitylib.Classes +public import LeanPool.BeyondBethe.Complexitylib.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Languages +public import LeanPool.BeyondBethe.Complexitylib.Mathlib +public import LeanPool.BeyondBethe.Complexitylib.Models +public import LeanPool.BeyondBethe.Complexitylib.SAT + +/-! +# Complexitylib dependency provenance + +The imported dependency comes from +[SamuelSchlesinger/complexitylib at `b6738219a3a3c50967d6bd16cba9487887ca6b66`](https://github.com/SamuelSchlesinger/complexitylib/tree/b6738219a3a3c50967d6bd16cba9487887ca6b66). +This is the revision pinned by the upstream Beyond Bethe +[`lake-manifest.json`](https://github.com/nimaanari/formalization-beyond-bethe/blob/325cda6d2118870f7f121a9a986b7ea9ffdd7a26/lake-manifest.json). +The dependency is licensed under Apache-2.0. Its imported file headers credit +Samuel Schlesinger, Bolton Bailey, Christian Reitwiessner, and Nima Anari; +individual copyright and author notices are retained in those files. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Asymptotics.lean b/LeanPool/BeyondBethe/Complexitylib/Asymptotics.lean new file mode 100644 index 0000000000..c605345070 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Asymptotics.lean @@ -0,0 +1,449 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Analysis.Asymptotics.SpecificAsymptotics +public import Mathlib.Data.Nat.Size +public import Mathlib.Algebra.Polynomial.Eval.Degree + +/-! +# Asymptotic notation for natural number functions + +This module defines `Complexity.BigO` and `Complexity.LittleO`, thin adapters +that lift Mathlib's `Asymptotics.IsBigO` and `Asymptotics.IsLittleO` to +`β„• β†’ β„•` functions (casting through `ℝ`). + +The scoped notations `f =O g` and `f =o g` are available when `Complexity` is +opened and read like standard complexity-theoretic asymptotic notation. + +## Main definitions + +- `BigO` β€” `f =O g` means `f(n) = O(g(n))` as `n β†’ ∞` +- `LittleO` β€” `f =o g` means `f(n) = o(g(n))` as `n β†’ ∞` + +## Main results + +### BigO +- `BigO.refl` β€” reflexivity +- `BigO.trans` β€” transitivity +- `BigO.of_le` β€” pointwise `≀` implies big-O +- `BigO.add` β€” sum of big-O is big-O +- `BigO.pow` β€” fixed powers preserve big-O +- `BigO.const_mul_left` β€” constant multiple preserves big-O +- `BigO.natSize_of_pow` β€” binary widths of power-bounded values are logarithmic +- `BigO.le_add_left` / `BigO.le_add_right` β€” projections from a sum +- `BigO.const_mul_add` β€” `c * f₁ + fβ‚‚ = O(T₁ + Tβ‚‚)` +- `polynomial_eval_mono_nat` β€” natural polynomial evaluation is monotone + +### LittleO +- `LittleO.isBigO` β€” little-o implies big-O +- `LittleO.trans` β€” transitivity +- `LittleO.trans_bigO` β€” mixed: `o` then `O` gives `o` +- `BigO.trans_littleO` β€” mixed: `O` then `o` gives `o` +- `LittleO.add` β€” sum of little-o is little-o +- `LittleO.const_mul_left` β€” constant multiple preserves little-o +-/ + + +@[expose] public section + +open Asymptotics Filter + +namespace Complexity + +-- ════════════════════════════════════════════════════════════════════════ +-- Definitions +-- ════════════════════════════════════════════════════════════════════════ + +/-- `f` grows at most as fast as `g` asymptotically: `f(n) = O(g(n))` as `n β†’ ∞`. + Lifts Mathlib's `Asymptotics.IsBigO` to `β„• β†’ β„•` functions, avoiding + repeated `Nat.cast` coercions in complexity class definitions. + + Unfolding: `f =O g ↔ βˆƒ C, βˆ€αΆ  n in atTop, ↑(f n) ≀ C * ↑(g n)`. -/ +def BigO (f g : β„• β†’ β„•) : Prop := + (fun n => (f n : ℝ)) =O[atTop] (fun n => (g n : ℝ)) + +@[inherit_doc BigO] +scoped infixl:50 " =O " => BigO + +/-- `f` grows strictly slower than `g` asymptotically: `f(n) = o(g(n))` as `n β†’ ∞`. + Lifts Mathlib's `Asymptotics.IsLittleO` to `β„• β†’ β„•` functions. + + Unfolding: `f =o g ↔ βˆ€ Ξ΅ > 0, βˆ€αΆ  n in atTop, ↑(f n) ≀ Ξ΅ * ↑(g n)`. -/ +def LittleO (f g : β„• β†’ β„•) : Prop := + (fun n => (f n : ℝ)) =o[atTop] (fun n => (g n : ℝ)) + +@[inherit_doc LittleO] +scoped infixl:50 " =o " => LittleO + +-- ════════════════════════════════════════════════════════════════════════ +-- BigO core lemmas +-- ════════════════════════════════════════════════════════════════════════ + +/-- Big-O is reflexive: `f = O(f)`. -/ +theorem BigO.refl (f : β„• β†’ β„•) : f =O f := + isBigO_refl _ _ + +/-- Big-O is transitive: `f = O(g) β†’ g = O(h) β†’ f = O(h)`. -/ +theorem BigO.trans {f g h : β„• β†’ β„•} (h₁ : f =O g) (hβ‚‚ : g =O h) : f =O h := + IsBigO.trans h₁ hβ‚‚ + +/-- Pointwise `≀` implies big-O. -/ +theorem BigO.of_le {f g : β„• β†’ β„•} (h : βˆ€ n, f n ≀ g n) : f =O g := by + apply IsBigO.of_bound 1 + filter_upwards with n + simp only [one_mul, Real.norm_natCast] + exact_mod_cast h n + +/-- Sum of two big-O functions: `f₁ = O(g) β†’ fβ‚‚ = O(g) β†’ (f₁ + fβ‚‚) = O(g)`. -/ +theorem BigO.add {f₁ fβ‚‚ g : β„• β†’ β„•} (h₁ : f₁ =O g) (hβ‚‚ : fβ‚‚ =O g) : + (fun n => f₁ n + fβ‚‚ n) =O g := by + show (fun n => ((f₁ n + fβ‚‚ n : β„•) : ℝ)) =O[atTop] _ + have key := IsBigO.add h₁ hβ‚‚ + convert key using 1 + ext n; push_cast; ring + +/-- Product of two big-O bounds: `f₁ = O(g₁) β†’ fβ‚‚ = O(gβ‚‚) β†’ (f₁·fβ‚‚) = O(g₁·gβ‚‚)`. -/ +theorem BigO.mul {f₁ fβ‚‚ g₁ gβ‚‚ : β„• β†’ β„•} (h₁ : f₁ =O g₁) (hβ‚‚ : fβ‚‚ =O gβ‚‚) : + (fun n => f₁ n * fβ‚‚ n) =O (fun n => g₁ n * gβ‚‚ n) := by + show (fun n => ((f₁ n * fβ‚‚ n : β„•) : ℝ)) =O[atTop] (fun n => ((g₁ n * gβ‚‚ n : β„•) : ℝ)) + have key := IsBigO.mul h₁ hβ‚‚ + convert key using 1 + Β· ext n; push_cast; ring + Β· ext n; push_cast; ring + +/-- Raising both sides of a big-O bound to a fixed natural power preserves +big-O. -/ +theorem BigO.pow {f g : β„• β†’ β„•} (h : f =O g) (k : β„•) : + (fun n => (f n) ^ k) =O (fun n => (g n) ^ k) := by + induction k with + | zero => exact BigO.refl fun _ => 1 + | succ k ih => + simpa only [pow_succ] using BigO.mul ih h + +/-- Constant multiple preserves big-O. -/ +theorem BigO.const_mul_left (c : β„•) {f g : β„• β†’ β„•} (h : f =O g) : + (fun n => c * f n) =O g := by + show (fun n => ((c * f n : β„•) : ℝ)) =O[atTop] _ + have hcf : (fun n => (c : ℝ) * (f n : ℝ)) =O[atTop] (fun n => (f n : ℝ)) := + IsBigO.const_mul_left (isBigO_refl _ _) (c : ℝ) + have key := IsBigO.trans hcf h + convert key using 1 + ext n; push_cast; ring + +-- ════════════════════════════════════════════════════════════════════════ +-- LittleO core lemmas +-- ════════════════════════════════════════════════════════════════════════ + +/-- Little-o implies big-O: if `f = o(g)` then `f = O(g)`. -/ +theorem LittleO.isBigO {f g : β„• β†’ β„•} (h : f =o g) : f =O g := + IsLittleO.isBigO h + +/-- Little-o is transitive: `f = o(g) β†’ g = o(h) β†’ f = o(h)`. -/ +theorem LittleO.trans {f g h : β„• β†’ β„•} (h₁ : f =o g) (hβ‚‚ : g =o h) : f =o h := + IsLittleO.trans_isBigO h₁ (IsLittleO.isBigO hβ‚‚) + +/-- Mixed transitivity: `f = o(g) β†’ g = O(h) β†’ f = o(h)`. -/ +theorem LittleO.trans_bigO {f g h : β„• β†’ β„•} (h₁ : f =o g) (hβ‚‚ : g =O h) : f =o h := + IsLittleO.trans_isBigO h₁ hβ‚‚ + +/-- Mixed transitivity: `f = O(g) β†’ g = o(h) β†’ f = o(h)`. -/ +theorem BigO.trans_littleO {f g h : β„• β†’ β„•} (h₁ : f =O g) (hβ‚‚ : g =o h) : f =o h := + IsBigO.trans_isLittleO h₁ hβ‚‚ + +/-- Sum of two little-o functions: `f₁ = o(g) β†’ fβ‚‚ = o(g) β†’ (f₁ + fβ‚‚) = o(g)`. -/ +theorem LittleO.add {f₁ fβ‚‚ g : β„• β†’ β„•} (h₁ : f₁ =o g) (hβ‚‚ : fβ‚‚ =o g) : + (fun n => f₁ n + fβ‚‚ n) =o g := by + show (fun n => ((f₁ n + fβ‚‚ n : β„•) : ℝ)) =o[atTop] _ + have key := IsLittleO.add h₁ hβ‚‚ + convert key using 1 + ext n; push_cast; ring + +/-- Constant multiple preserves little-o. -/ +theorem LittleO.const_mul_left (c : β„•) {f g : β„• β†’ β„•} (h : f =o g) : + (fun n => c * f n) =o g := by + show (fun n => ((c * f n : β„•) : ℝ)) =o[atTop] _ + have hcf : (fun n => (c : ℝ) * (f n : ℝ)) =O[atTop] (fun n => (f n : ℝ)) := + IsBigO.const_mul_left (isBigO_refl _ _) (c : ℝ) + have key := IsBigO.trans_isLittleO hcf h + convert key using 1 + ext n; push_cast; ring + +-- ════════════════════════════════════════════════════════════════════════ +-- BigO arithmetic lemmas (addition bounds) +-- ════════════════════════════════════════════════════════════════════════ + +/-- `T₁` is big-O of `T₁ + Tβ‚‚`. -/ +theorem BigO.le_add_left (T₁ Tβ‚‚ : β„• β†’ β„•) : + T₁ =O (fun n => T₁ n + Tβ‚‚ n) := by + show (fun n => ((T₁ n : β„•) : ℝ)) =O[atTop] (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) + apply IsBigO.of_bound 1 + filter_upwards with n + simp only [Nat.cast_add, one_mul, Real.norm_natCast] + exact le_of_le_of_eq (le_add_of_nonneg_right (Nat.cast_nonneg (Ξ± := ℝ) (Tβ‚‚ n))) + (abs_of_nonneg (add_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _))).symm + +/-- `Tβ‚‚` is big-O of `T₁ + Tβ‚‚`. -/ +theorem BigO.le_add_right (T₁ Tβ‚‚ : β„• β†’ β„•) : + Tβ‚‚ =O (fun n => T₁ n + Tβ‚‚ n) := by + show (fun n => ((Tβ‚‚ n : β„•) : ℝ)) =O[atTop] (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) + apply IsBigO.of_bound 1 + filter_upwards with n + simp only [Nat.cast_add, one_mul, Real.norm_natCast] + exact le_of_le_of_eq (le_add_of_nonneg_left (Nat.cast_nonneg (Ξ± := ℝ) (T₁ n))) + (abs_of_nonneg (add_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _))).symm + +/-- If `f₁ =O T₁` and `fβ‚‚ =O Tβ‚‚`, then `c * f₁ + fβ‚‚ =O (T₁ + Tβ‚‚)`. -/ +theorem BigO.const_mul_add (c : β„•) {f₁ fβ‚‚ T₁ Tβ‚‚ : β„• β†’ β„•} + (ho₁ : f₁ =O T₁) (hoβ‚‚ : fβ‚‚ =O Tβ‚‚) : + (fun n => c * f₁ n + fβ‚‚ n) =O (fun n => T₁ n + Tβ‚‚ n) := by + show (fun n => ((c * f₁ n + fβ‚‚ n : β„•) : ℝ)) =O[atTop] + (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) + have hf₁ : (fun n => ((f₁ n : β„•) : ℝ)) =O[atTop] + (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) := IsBigO.trans ho₁ (le_add_left T₁ Tβ‚‚) + have hcf₁ : (fun n => ((c * f₁ n : β„•) : ℝ)) =O[atTop] + (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) := by + have : (fun n => (c : ℝ) * ((f₁ n : β„•) : ℝ)) =O[atTop] + (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) := + IsBigO.const_mul_left hf₁ c + convert this using 1 + ext n; push_cast; ring + have hfβ‚‚ : (fun n => ((fβ‚‚ n : β„•) : ℝ)) =O[atTop] + (fun n => ((T₁ n + Tβ‚‚ n : β„•) : ℝ)) := IsBigO.trans hoβ‚‚ (le_add_right T₁ Tβ‚‚) + have := IsBigO.add hcf₁ hfβ‚‚ + convert this using 1 + ext n; push_cast; ring + +-- ════════════════════════════════════════════════════════════════════════ +-- BigO max and power bounds +-- ════════════════════════════════════════════════════════════════════════ + +/-- `T₁` is big-O of `max T₁ Tβ‚‚`. -/ +theorem BigO.le_max_left (T₁ Tβ‚‚ : β„• β†’ β„•) : + T₁ =O (fun n => max (T₁ n) (Tβ‚‚ n)) := + BigO.of_le fun _ => Nat.le_max_left _ _ + +/-- `Tβ‚‚` is big-O of `max T₁ Tβ‚‚`. -/ +theorem BigO.le_max_right (T₁ Tβ‚‚ : β„• β†’ β„•) : + Tβ‚‚ =O (fun n => max (T₁ n) (Tβ‚‚ n)) := + BigO.of_le fun _ => Nat.le_max_right _ _ + +/-- `max T₁ Tβ‚‚ =O (T₁ + Tβ‚‚)`. -/ +theorem BigO.max_le_add (T₁ Tβ‚‚ : β„• β†’ β„•) : + (fun n => max (T₁ n) (Tβ‚‚ n)) =O (fun n => T₁ n + Tβ‚‚ n) := + BigO.of_le fun _ => Nat.max_le.mpr ⟨Nat.le_add_right _ _, Nat.le_add_left _ _⟩ + +/-- A pointwise maximum of two functions with the same asymptotic bound has +that bound as well. -/ +theorem BigO.max_same {f₁ fβ‚‚ g : β„• β†’ β„•} (h₁ : f₁ =O g) (hβ‚‚ : fβ‚‚ =O g) : + (fun n => max (f₁ n) (fβ‚‚ n)) =O g := + (BigO.max_le_add f₁ fβ‚‚).trans (BigO.add h₁ hβ‚‚) + +/-- Any function is big-O of itself-plus-constant: `f =O (fun n => f n + c)`. -/ +theorem BigO.self_le_add_const (f : β„• β†’ β„•) (c : β„•) : + f =O (fun n => f n + c) := + BigO.of_le fun _ => Nat.le_add_right _ _ + +/-- `n^k` is big-O of `n^(k+1)` on sequences with `n β‰₯ 1`. -/ +theorem BigO.pow_le_pow_succ (k : β„•) : + (Β· ^ k) =O ((Β· ^ (k + 1)) : β„• β†’ β„•) := by + apply IsBigO.of_bound 1 + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + simp only [one_mul, Real.norm_natCast] + exact_mod_cast Nat.pow_le_pow_right hn (Nat.le_succ k) + +/-- `n^j =O n^k` when `j ≀ k` (on sequences with `n β‰₯ 1`). -/ +theorem BigO.pow_le_pow_right {j k : β„•} (hjk : j ≀ k) : + (Β· ^ j) =O ((Β· ^ k) : β„• β†’ β„•) := by + apply IsBigO.of_bound 1 + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + simp only [one_mul, Real.norm_natCast] + exact_mod_cast Nat.pow_le_pow_right hn hjk + +/-- A constant function is big-O of `n^k` (eventually `n^k β‰₯ 1`). -/ +theorem BigO.const_le_pow (c k : β„•) : + (fun _ : β„• => c) =O ((Β· ^ k) : β„• β†’ β„•) := by + apply IsBigO.of_bound c + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + simp only [Real.norm_natCast] + have : 1 ≀ n ^ k := Nat.one_le_pow _ _ hn + exact_mod_cast le_mul_of_one_le_right (Nat.zero_le _) this + +/-- Every fixed natural constant is eventually bounded by a constant multiple +of the unshifted base-two logarithm. The threshold `n β‰₯ 2` is necessary because +`Nat.log 2 0 = Nat.log 2 1 = 0`. -/ +theorem BigO.const_le_logTwo (c : β„•) : + (fun _ : β„• => c) =O (fun n => Nat.log 2 n) := by + apply IsBigO.of_bound c + filter_upwards [Filter.eventually_ge_atTop 2] with n hn + simp only [Real.norm_natCast] + have hlog : 1 ≀ Nat.log 2 n := Nat.log_pos (by omega) hn + exact_mod_cast le_mul_of_one_le_right (Nat.zero_le c) hlog + +/-- `n^j + n^k =O n^(max j k)` on sequences with `n β‰₯ 1`. -/ +theorem BigO.pow_add_pow (j k : β„•) : + (fun n => n ^ j + n ^ k) =O ((Β· ^ max j k) : β„• β†’ β„•) := by + apply IsBigO.of_bound 2 + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + simp only [Real.norm_natCast] + have h1 : n ^ j ≀ n ^ max j k := Nat.pow_le_pow_right hn (Nat.le_max_left j k) + have h2 : n ^ k ≀ n ^ max j k := Nat.pow_le_pow_right hn (Nat.le_max_right j k) + have : n ^ j + n ^ k ≀ 2 * n ^ max j k := by omega + exact_mod_cast this + +/-! ### Natural polynomial evaluation -/ + +/-- Evaluation of a polynomial with natural coefficients is monotone in its + natural-number argument. -/ +theorem polynomial_eval_mono_nat (p : Polynomial β„•) : Monotone p.eval := by + intro m n hmn + change p.eval m ≀ p.eval n + rw [Polynomial.eval_eq_sum_range, Polynomial.eval_eq_sum_range] + exact Finset.sum_le_sum fun i _ => + Nat.mul_le_mul_left (p.coeff i) (Nat.pow_le_pow_left hmn i) + +-- ════════════════════════════════════════════════════════════════════════ +-- BigO β‡’ polynomial bound +-- ════════════════════════════════════════════════════════════════════════ + +/-- **From `f =O (Β·^k)` to an explicit polynomial bound.** If `f : β„• β†’ β„•` + is big-O of `n^k`, then there exists a polynomial `p` in `Polynomial β„•` + with `f n ≀ p.eval n` *for every* `n` (not just eventually). + + The standard big-O definition gives only an asymptotic bound; this lemma + turns that into an everywhere-bound by (i) extracting a real constant + `C` and threshold `N` such that `f n ≀ C Β· n^k` for `n β‰₯ N`, (ii) + rounding `C` up to a natural number, and (iii) adding a constant term + that dominates `f` on the initial segment `[0, N)`. + + This is the bridge from big-O hypotheses to the explicit + `Polynomial β„•` shape expected by definitions like `PolyBalanced` and + by time-bound packaging in the `WitnessNTMConstruction` + construction. -/ +theorem BigO.pow_polynomial_bound {f : β„• β†’ β„•} {k : β„•} (h : f =O (Β· ^ k)) : + βˆƒ p : Polynomial β„•, βˆ€ n, f n ≀ p.eval n := by + rw [BigO, Asymptotics.isBigO_iff] at h + obtain ⟨C, hC⟩ := h + rw [Filter.eventually_atTop] at hC + obtain ⟨N, hN⟩ := hC + refine ⟨Polynomial.C ⌈CβŒ‰β‚Š * Polynomial.X ^ k + + Polynomial.C ((Finset.range N).sup f), ?_⟩ + intro n + simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_X] + by_cases hn : n < N + Β· have : f n ≀ (Finset.range N).sup f := + Finset.le_sup (f := f) (Finset.mem_range.mpr hn) + omega + Β· push Not at hn + have hb := hN n hn + simp only [Real.norm_natCast] at hb + have hC_le : C ≀ (⌈CβŒ‰β‚Š : ℝ) := Nat.le_ceil C + have h_nk_nonneg : (0 : ℝ) ≀ ((n ^ k : β„•) : ℝ) := by positivity + have h_real : (f n : ℝ) ≀ (⌈CβŒ‰β‚Š : ℝ) * ((n ^ k : β„•) : ℝ) := + le_trans hb (mul_le_mul_of_nonneg_right hC_le h_nk_nonneg) + have h_nat : f n ≀ ⌈CβŒ‰β‚Š * n ^ k := by exact_mod_cast h_real + omega + +/-- **From a polynomial bound to `=O (Β·^deg)`.** If `f : β„• β†’ β„•` is + pointwise bounded by a polynomial `p`, then `f =O (Β·^p.natDegree)`. + + Companion to `BigO.pow_polynomial_bound`; the pair lets you convert + freely between the big-O form used by complexity classes and the + explicit `Polynomial β„•` shape used in `PolyBalanced` and in + running-time packaging for composite machines. -/ +theorem BigO.of_polynomial_bound {f : β„• β†’ β„•} (p : Polynomial β„•) + (h : βˆ€ n, f n ≀ p.eval n) : f =O (Β· ^ p.natDegree) := by + set S : β„• := βˆ‘ i ∈ Finset.range (p.natDegree + 1), p.coeff i with hS + apply IsBigO.of_bound S + filter_upwards [Filter.eventually_ge_atTop 1] with n hn + simp only [Real.norm_natCast] + have hp : p.eval n ≀ S * n ^ p.natDegree := by + rw [Polynomial.eval_eq_sum_range, hS, Finset.sum_mul] + refine Finset.sum_le_sum (fun i hi => ?_) + have hi' : i ≀ p.natDegree := by + rw [Finset.mem_range] at hi; omega + have : n ^ i ≀ n ^ p.natDegree := Nat.pow_le_pow_right hn hi' + exact Nat.mul_le_mul_left _ this + exact_mod_cast le_trans (h n) hp + +/-- Extract a natural-number constant and threshold from a big-O bound: + `f =O g` yields `c` and `N` with `f n ≀ c * g n` for all `n β‰₯ N`. -/ +theorem BigO.exists_nat_bound {f g : β„• β†’ β„•} (h : f =O g) : + βˆƒ (c N : β„•), βˆ€ n, N ≀ n β†’ f n ≀ c * g n := by + rw [BigO, Asymptotics.isBigO_iff] at h + obtain ⟨C, hC⟩ := h + rw [Filter.eventually_atTop] at hC + obtain ⟨N, hN⟩ := hC + refine ⟨⌈CβŒ‰β‚Š, N, fun n hn => ?_⟩ + have hb := hN n hn + simp only [Real.norm_natCast] at hb + have hr : (f n : ℝ) ≀ (⌈CβŒ‰β‚Š : ℝ) * (g n : ℝ) := + le_trans hb (mul_le_mul_of_nonneg_right (Nat.le_ceil C) (Nat.cast_nonneg _)) + exact_mod_cast hr + +/-- Binary widths of power-bounded natural values are logarithmic. The proof +raises the eventual power bound by one, which uniformly handles exponent zero +and constant functions. -/ +theorem BigO.natSize_of_pow {f : β„• β†’ β„•} {d : β„•} + (hf : f =O ((Β· ^ d) : β„• β†’ β„•)) : + (fun n => (f n).size) =O (fun n => Nat.log 2 n) := by + obtain ⟨c, N, hbound⟩ := BigO.exists_nat_bound hf + rw [BigO] + apply Asymptotics.IsBigO.of_bound (2 * (d + 1)) + filter_upwards [Filter.eventually_ge_atTop (max 2 (max c N))] with n hn + simp only [Real.norm_natCast] + have hn2 : 2 ≀ n := le_trans (Nat.le_max_left 2 (max c N)) hn + have hcn : c ≀ n := le_trans (le_trans (Nat.le_max_left c N) + (Nat.le_max_right 2 (max c N))) hn + have hNn : N ≀ n := le_trans (le_trans (Nat.le_max_right c N) + (Nat.le_max_right 2 (max c N))) hn + have hvalue : f n ≀ n ^ (d + 1) := by + calc + f n ≀ c * n ^ d := hbound n hNn + _ ≀ n * n ^ d := Nat.mul_le_mul_right _ hcn + _ = n ^ (d + 1) := by rw [pow_succ'] + have hlog : 1 ≀ Nat.log 2 n := Nat.log_pos (by omega) hn2 + have hpow : n ^ (d + 1) < 2 ^ ((d + 1) * (Nat.log 2 n + 1)) := by + calc + n ^ (d + 1) < (2 ^ (Nat.log 2 n + 1)) ^ (d + 1) := + Nat.pow_lt_pow_left (Nat.lt_pow_succ_log_self (by omega) n) (by omega) + _ = 2 ^ ((d + 1) * (Nat.log 2 n + 1)) := by + rw [← pow_mul'] + have hsize : (f n).size ≀ (d + 1) * (Nat.log 2 n + 1) := + Nat.size_le.mpr (lt_of_le_of_lt hvalue hpow) + have hlog' : Nat.log 2 n + 1 ≀ 2 * Nat.log 2 n := by omega + have hfinal : (f n).size ≀ (2 * (d + 1)) * Nat.log 2 n := + hsize.trans (by + calc + (d + 1) * (Nat.log 2 n + 1) ≀ + (d + 1) * (2 * Nat.log 2 n) := Nat.mul_le_mul_left _ hlog' + _ = (2 * (d + 1)) * Nat.log 2 n := by ring) + exact_mod_cast hfinal + +/-- Binary widths of pointwise polynomial-bounded natural values are logarithmic. -/ +theorem BigO.natSize_of_polynomial_bound {f : β„• β†’ β„•} + (p : Polynomial β„•) (hf : βˆ€ n, f n ≀ p.eval n) : + (fun n => (f n).size) =O (fun n => Nat.log 2 n) := + BigO.natSize_of_pow (BigO.of_polynomial_bound p hf) + +/-- The binary width of a fixed natural polynomial evaluation is logarithmic. -/ +theorem BigO.natSize_polynomial_eval (p : Polynomial β„•) : + (fun n => (p.eval n).size) =O (fun n => Nat.log 2 n) := + BigO.natSize_of_polynomial_bound p fun _ => le_rfl + +/-- Strict power gap, shifted to the everywhere-positive base `n + 1`: + `(n + 1)^p = o((n + 1)^q)` when `p < q`. -/ +theorem LittleO.pow_lt_pow {p q : β„•} (hpq : p < q) : + LittleO (fun n => (n + 1) ^ p) (fun n => (n + 1) ^ q) := by + have hbase : Filter.Tendsto (fun n : β„• => ((n : ℝ) + 1)) atTop atTop := + Filter.tendsto_atTop_add_const_right atTop 1 tendsto_natCast_atTop_atTop + have key := + (Asymptotics.isLittleO_pow_pow_atTop_of_lt (π•œ := ℝ) hpq).comp_tendsto hbase + exact key.congr (fun n => by simp only [Function.comp_apply]; push_cast; ring) + (fun n => by simp only [Function.comp_apply]; push_cast; ring) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolyBound.lean b/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolyBound.lean new file mode 100644 index 0000000000..ff3ce9fb34 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolyBound.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics + +/-! +# Polynomial bounds on natural-number functions + +`PolyBound f` says `f` is dominated pointwise (at every argument, not merely +eventually) by the evaluation of a natural polynomial. Resource bookkeeping +assembles time and space bounds by addition, multiplication, and monotonicity, +so an everywhere-bound closed under those operations is easier to carry through +a construction than a big-O statement; `PolyBound.bigO` converts to the big-O +form the complexity classes are stated in. + +## Main results + +- `PolyBound` β€” pointwise domination by a natural polynomial +- `PolyBound.const`, `.id`, `.add`, `.mul`, `.pow`, `.mono`, `.max`, `.eval` β€” + the closure API +- `PolyBound.bigO` β€” a polynomial bound is a big-O power bound +-/ + + +@[expose] public section + +namespace Complexity + +/-- Pointwise domination by the evaluation of a natural polynomial. -/ +def PolyBound (f : β„• β†’ β„•) : Prop := + βˆƒ p : Polynomial β„•, βˆ€ inputLength, f inputLength ≀ p.eval inputLength + +namespace PolyBound + +theorem const (value : β„•) : PolyBound (fun _ => value) := + ⟨Polynomial.C value, fun _ => by simp⟩ + +theorem id : PolyBound (fun inputLength => inputLength) := + ⟨Polynomial.X, fun _ => by simp⟩ + +theorem add {f g : β„• β†’ β„•} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => f inputLength + g inputLength) := by + obtain ⟨p, hp⟩ := hf + obtain ⟨q, hq⟩ := hg + exact ⟨p + q, fun inputLength => by + rw [Polynomial.eval_add] + exact Nat.add_le_add (hp inputLength) (hq inputLength)⟩ + +theorem mul {f g : β„• β†’ β„•} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => f inputLength * g inputLength) := by + obtain ⟨p, hp⟩ := hf + obtain ⟨q, hq⟩ := hg + exact ⟨p * q, fun inputLength => by + rw [Polynomial.eval_mul] + exact Nat.mul_le_mul (hp inputLength) (hq inputLength)⟩ + +theorem mono {f g : β„• β†’ β„•} (hg : PolyBound g) + (hle : βˆ€ inputLength, f inputLength ≀ g inputLength) : PolyBound f := by + obtain ⟨p, hp⟩ := hg + exact ⟨p, fun inputLength => le_trans (hle inputLength) (hp inputLength)⟩ + +theorem max {f g : β„• β†’ β„•} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => max (f inputLength) (g inputLength)) := + (hf.add hg).mono fun _ => Nat.max_le.mpr + ⟨Nat.le_add_right _ _, Nat.le_add_left _ _⟩ + +theorem eval (p : Polynomial β„•) : + PolyBound (fun inputLength => p.eval inputLength) := + ⟨p, fun _ => le_rfl⟩ + +theorem pow {f : β„• β†’ β„•} (hf : PolyBound f) (exponent : β„•) : + PolyBound (fun inputLength => f inputLength ^ exponent) := by + induction exponent with + | zero => simpa using const 1 + | succ exponent ih => simpa [pow_succ] using ih.mul hf + +/-- A polynomial bound is a big-O bound by the polynomial's degree. -/ +theorem bigO {f : β„• β†’ β„•} (hf : PolyBound f) : βˆƒ d, f =O (Β· ^ d) := by + obtain ⟨p, hp⟩ := hf + exact ⟨p.natDegree, BigO.of_polynomial_bound p hp⟩ + +end PolyBound + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolynomialComposition.lean b/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolynomialComposition.lean new file mode 100644 index 0000000000..6c59cada6b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Asymptotics/PolynomialComposition.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics + +/-! +# Polynomial composition bounds + +This module packages natural-polynomial composition as power-form big-O +bounds. The second theorem records the coarse time expression used when two +deterministic function computations are connected sequentially. + +## Main results + +- `BigO.polynomial_eval_comp` β€” nested polynomial evaluation is polynomially bounded +- `BigO.polynomial_composition_time` β€” the coarse sequential runtime is polynomially bounded +-/ + + +@[expose] public section + +namespace Complexity + +/-- Composing evaluations of natural-coefficient polynomials gives a function +bounded by a power whose exponent is the degree of the composed polynomial. -/ +theorem BigO.polynomial_eval_comp (p q : Polynomial β„•) : + (fun n => q.eval (p.eval n)) =O (Β· ^ (q.comp p).natDegree) := by + apply BigO.of_polynomial_bound (q.comp p) + intro n + simp [Polynomial.eval_comp] + +/-- The coarse runtime for sequentially composing computations with polynomial +bounds `p` and `q` is itself bounded by a power. -/ +theorem BigO.polynomial_composition_time (p q : Polynomial β„•) : + (fun n => 4 * p.eval n + 11 + q.eval (p.eval n)) =O + (Β· ^ (Polynomial.C 4 * p + Polynomial.C 11 + q.comp p).natDegree) := by + apply BigO.of_polynomial_bound + (Polynomial.C 4 * p + Polynomial.C 11 + q.comp p) + intro n + simp [Polynomial.eval_comp] + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits.lean new file mode 100644 index 0000000000..3727a665ab --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Basic +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot.lean new file mode 100644 index 0000000000..f1baf51d8e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot.Defs + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot/Defs.lean new file mode 100644 index 0000000000..8c9e8eefa6 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/AndOrNot/Defs.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Basic + +/-! # AND/OR/NOT Basis β€” Definitions + +This module defines the AND/OR operations and various basis configurations +used throughout the circuit complexity library. + +## Main definitions + +* `AndOrOp` β€” AND/OR operations (negation is free via per-input gate flags) +* `AndOrOp.eval` β€” fold-based evaluation of AND/OR on `n` input bits +* `AndOrOp.dual`, `AndOrOp.dualIf` β€” De Morgan duality +* `Basis.unboundedAndOr` β€” unbounded fan-in AND/OR basis +* `Basis.boundedAndOr` β€” fan-in bounded by `k` AND/OR basis +* `Basis.andOr2` β€” fan-in exactly 2 AND/OR basis (used in Shannon/Schnorr bounds) +-/ + + +@[expose] public section + +namespace Complexity + +/-- Operations in an AND/OR basis. Negation is handled by per-input flags + on gates, so only AND and OR need explicit representation. -/ +inductive AndOrOp where + /-- The AND operation: outputs `true` iff all inputs are `true`. -/ + | and + /-- The OR operation: outputs `true` iff at least one input is `true`. -/ + | or + deriving Repr, DecidableEq + +/-- Evaluate an AND or OR operation on `n` input bits by folding. + AND folds with `&&` starting from `true`; OR folds with `||` from `false`. -/ +def AndOrOp.eval : (op : AndOrOp) β†’ (n : Nat) β†’ BitString n β†’ Bool + | .and, n, inputs => Fin.foldl n (fun acc i => acc && inputs i) true + | .or, n, inputs => Fin.foldl n (fun acc i => acc || inputs i) false + +/-- De Morgan duality swaps AND and OR. -/ +def AndOrOp.dual : AndOrOp β†’ AndOrOp + | .and => .or + | .or => .and + +/-- Select the De Morgan dual exactly when `negated` is true. -/ +def AndOrOp.dualIf (negated : Bool) (op : AndOrOp) : AndOrOp := + if negated then op.dual else op + +/-- AND/OR basis with unbounded fan-in. Negation is free (per-input flags on gates). -/ +def Basis.unboundedAndOr : Basis where + Op := AndOrOp + arity + | .and => .unbounded + | .or => .unbounded + eval op n _ inputs := op.eval n inputs + +/-- AND/OR basis with fan-in bounded by `k`. Negation is free (per-input flags on gates). -/ +def Basis.boundedAndOr (k : Nat) : Basis where + Op := AndOrOp + arity + | .and => .upto k + | .or => .upto k + eval op n _ inputs := op.eval n inputs + +/-- Fan-in-2 AND/OR basis. Every gate has exactly 2 inputs. + Negation is free (per-input flags on gates). + This is the basis used in the Shannon and Schnorr lower bound theorems. -/ +def Basis.andOr2 : Basis where + Op := AndOrOp + arity _ := .exactly 2 + eval op n _ inputs := op.eval n inputs + +/-- Every gate over `Basis.andOr2` has fan-in exactly 2. -/ +theorem fanIn_andOr2 {W : Nat} (g : Gate Basis.andOr2 W) : g.fanIn = 2 := g.arityOk + +/-- A fan-in-2 AND gate computes the conjunction of its two inputs. -/ +theorem AndOrOp.eval_two_and (inputs : BitString 2) : + AndOrOp.eval .and 2 inputs = (inputs 0 && inputs 1) := by + simp [AndOrOp.eval, Fin.foldl_succ_last, Fin.foldl_zero] + +/-- A fan-in-2 OR gate computes the disjunction of its two inputs. -/ +theorem AndOrOp.eval_two_or (inputs : BitString 2) : + AndOrOp.eval .or 2 inputs = (inputs 0 || inputs 1) := by + simp [AndOrOp.eval, Fin.foldl_succ_last, Fin.foldl_zero] + +@[simp] theorem AndOrOp.dual_dual (op : AndOrOp) : + op.dual.dual = op := by + cases op <;> rfl + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/Basic.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/Basic.lean new file mode 100644 index 0000000000..bdb6a38277 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/Basic.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Nat.Lattice +public import Mathlib.Order.Lattice.Nat +public import Mathlib.Order.CompleteLattice.Basic + +/-! # Boolean Circuit Complexity + +This file defines Boolean circuits parameterized by a basis of operations and +establishes the circuit size complexity measure for Boolean functions. + +## Main definitions + +* `BitString` β€” a string of bits of a specific length +* `BoolFunFamily` β€” a family of Boolean functions indexed by input length +* `Basis` β€” a basis of Boolean operations with arity constraints +* `Circuit` β€” an acyclic Boolean circuit (well-formedness by construction) +* `CompleteBasis` β€” typeclass for functionally complete bases +* `Circuit.wireDepth` β€” depth of a wire in the circuit DAG +* `Circuit.outputDepth` β€” depth of a single output gate +* `Circuit.depth` β€” depth of a (possibly multi-output) circuit +* `Circuit.Realizable` β€” whether a function is computed by some circuit over a basis +* `Circuit.sizeComplexityWithTop` β€” generic minimum size, with `⊀` for unrealizable functions +* `Circuit.sizeComplexity` β€” natural-valued minimum size over a complete basis + +## Main results + +* `Circuit.sizeComplexity_pos` β€” for complete bases, size complexity is positive +-/ + + +@[expose] public section + +namespace Complexity + +/-- A BitString of length `n`. -/ +abbrev BitString n := Fin n β†’ Bool + +/-- A family of Boolean functions indexed by input length `N`. + +Each member maps `N`-bit strings to a single output bit. -/ +abbrev BoolFunFamily := (N : Nat) β†’ BitString N β†’ Bool + +/-- Arity constraint for operations in a basis. -/ +inductive Arity where + /-- Any number of inputs is allowed. -/ + | unbounded + /-- Exactly `k` inputs are required. -/ + | exactly (k : Nat) + /-- At most `k` inputs are allowed. -/ + | upto (k : Nat) + deriving Repr, DecidableEq + +/-- Whether `n` satisfies an arity constraint. -/ +def Arity.satisfiedBy : Arity β†’ Nat β†’ Prop + | .unbounded, _ => True + | .exactly k, n => n = k + | .upto k, n => n ≀ k + +instance (a : Arity) (n : Nat) : Decidable (a.satisfiedBy n) := by + cases a <;> simp only [Arity.satisfiedBy] <;> exact inferInstance + +/-- +A basis of Boolean operations. + +Each operation has an arity constraint and an evaluation function that computes +the output bit from any valid number of input bits. +-/ +structure Basis where + /-- The type of operations (e.g., AND, OR, NOT). -/ + Op : Type + /-- The arity constraint for each operation. -/ + arity : Op β†’ Arity + /-- Evaluate an operation on `n` input bits, given that `n` satisfies the arity. -/ + eval : (op : Op) β†’ (n : Nat) β†’ (arity op).satisfiedBy n β†’ BitString n β†’ Bool + +/-- +A gate in a circuit over basis `B` with `W` wires available as inputs. +The gate's fan-in must satisfy the arity constraint of its operation, and each +input is wired to one of the `W` available wires. +-/ +structure Gate (B : Basis) (W : Nat) where + /-- The basis operation this gate computes. -/ + op : B.Op + /-- The number of inputs this gate reads. -/ + fanIn : Nat + /-- Proof that `fanIn` satisfies the arity constraint of `op`. -/ + arityOk : (B.arity op).satisfiedBy fanIn + /-- The wire each of the gate's `fanIn` inputs is connected to. -/ + inputs : Fin fanIn β†’ Fin W + /-- Per-input negation flag. Negations are free under this library's size + convention. -/ + negated : Fin fanIn β†’ Bool + +/-- Evaluate a gate given a wire-value assignment. -/ +def Gate.eval (g : Gate B W) (wireVal : BitString W) : Bool := + B.eval g.op g.fanIn g.arityOk (fun i => (g.negated i).xor (wireVal (g.inputs i))) + +/-- +A Boolean circuit over basis `B` with `N` inputs, `M` outputs, and `G` +internal gates. + +All gates reference wires from `Fin (N + G)`. The `acyclic` field ensures +that internal gate `i` only reads wires `0, …, N + i βˆ’ 1`, preventing cycles. +-/ +structure Circuit (B : Basis) (N M G : Nat) [NeZero N] [NeZero M] where + /-- The internal gates; gate `i` drives wire `N + i`. -/ + gates : Fin G β†’ Gate B (N + G) + /-- The output gates; output bit `j` is the value of gate `outputs j`. -/ + outputs : Fin M β†’ Gate B (N + G) + /-- Acyclicity: internal gate `i` only reads wires `0, …, N + i βˆ’ 1`. -/ + acyclic : βˆ€ (i : Fin G) (k : Fin (gates i).fanIn), + ((gates i).inputs k).val < N + i.val + +namespace Circuit +variable {B : Basis} {N M G : Nat} [NeZero N] [NeZero M] + +/-- Value of wire `w` when the circuit is fed `input`. + +The first `N` wires carry the primary inputs. Wire `N + i` carries the +output of internal gate `i`. -/ +def wireValue (c : Circuit B N M G) (input : BitString N) + (w : Fin (N + G)) : Bool := + if h : w.val < N then + input ⟨w.val, h⟩ + else + have hG : w.val - N < G := by omega + let gate := c.gates ⟨w.val - N, hG⟩ + B.eval gate.op gate.fanIn gate.arityOk + fun k => (gate.negated k).xor (c.wireValue input (gate.inputs k)) +termination_by w.val +decreasing_by + have hacyc := c.acyclic ⟨w.val - N, hG⟩ k + have : (⟨w.val - N, hG⟩ : Fin G).val = w.val - N := rfl + omega + +/-- On primary input wires (index < `N`), `wireValue` is the corresponding input bit. -/ +theorem wireValue_of_lt (c : Circuit B N M G) (input : BitString N) + (w : Fin (N + G)) (h : w.val < N) : + c.wireValue input w = input ⟨w.val, h⟩ := by + unfold wireValue + simp [h] + +/-- On internal gate wires (index β‰₯ `N`), `wireValue` is the evaluation of gate +`w βˆ’ N` on the values of its input wires. -/ +theorem wireValue_of_not_lt (c : Circuit B N M G) (input : BitString N) + (w : Fin (N + G)) (h : Β¬ (w.val < N)) : + c.wireValue input w = + (c.gates ⟨w.val - N, by omega⟩).eval (c.wireValue input) := by + unfold wireValue + simp only [h, dite_false] + rfl + +/-- Depth of wire `w` in the circuit DAG. + +Primary inputs have depth 0. Wire `N + i` (internal gate `i`) has depth +`1 + max over input wires`. -/ +def wireDepth (c : Circuit B N M G) (w : Fin (N + G)) : Nat := + if h : w.val < N then + 0 + else + have hG : w.val - N < G := by omega + let gate := c.gates ⟨w.val - N, hG⟩ + 1 + Fin.foldl gate.fanIn (fun acc k => max acc (c.wireDepth (gate.inputs k))) 0 +termination_by w.val +decreasing_by + have hacyc := c.acyclic ⟨w.val - N, hG⟩ k + have : (⟨w.val - N, hG⟩ : Fin G).val = w.val - N := rfl + omega + +/-- Primary input wires (index < N) have depth 0. -/ +@[simp] theorem wireDepth_of_lt (c : Circuit B N M G) + (w : Fin (N + G)) (h : w.val < N) : + c.wireDepth w = 0 := by + unfold wireDepth; simp [h] + +/-- Internal gate wires (index β‰₯ N) have depth 1 + max over their input wires. +Unfolds one step of `wireDepth` for the gate case. -/ +theorem wireDepth_of_not_lt (c : Circuit B N M G) + (w : Fin (N + G)) (h : Β¬ (w.val < N)) : + c.wireDepth w = + 1 + Fin.foldl (c.gates ⟨w.val - N, by omega⟩).fanIn + (fun acc k => max acc (c.wireDepth ((c.gates ⟨w.val - N, by omega⟩).inputs k))) 0 := by + conv_lhs => unfold wireDepth + simp only [h, dite_false] + +/-- Depth contributed by a single output gate: one layer for the gate itself +plus the maximum `wireDepth` of its inputs. Always β‰₯ 1. -/ +def outputDepth (c : Circuit B N M G) (j : Fin M) : Nat := + let outGate := c.outputs j + 1 + Fin.foldl outGate.fanIn (fun acc k => max acc (c.wireDepth (outGate.inputs k))) 0 + +/-- Depth of a circuit: the maximum `outputDepth` over all output gates. -/ +def depth (c : Circuit B N M G) : Nat := + Fin.foldl M (fun acc j => max acc (c.outputDepth j)) 0 + +/-- Evaluate a circuit: map an `N`-bit input to an `M`-bit output. -/ +def eval (c : Circuit B N M G) (input : BitString N) : BitString M := + fun j => (c.outputs j).eval (c.wireValue input) + +/-- The library's circuit size: internal gates plus output gates. + +Primary input vertices are not counted, and the negation flags on gate inputs +have zero cost. Some texts instead count input vertices and explicit NOT gates; +those conventions agree only up to additive/linear overhead, not on exact size +bounds. -/ +-- The circuit argument is unused by design: `size` is determined by the +-- indices, and the argument exists purely to enable `c.size` dot notation. +def size (_ : Circuit B N M G) : Nat := G + M + +end Circuit + +/-- A basis is complete if every Boolean function can be computed by some circuit over it. -/ +class CompleteBasis (B : Basis) : Prop where + /-- Every function `BitString N β†’ BitString M` is the evaluation of some circuit over `B`. -/ + complete : βˆ€ {N M} [NeZero N] [NeZero M] (f : BitString N β†’ BitString M), + βˆƒ G, βˆƒ c : Circuit B N M G, c.eval = f + +/-- If every circuit over `B₁` can be simulated by a circuit over `Bβ‚‚` + (possibly with a different number of internal gates), then completeness + of `B₁` implies completeness of `Bβ‚‚`. + + This is the generic tool for proving new bases complete: show you can + compile each gate of a known-complete basis into a subcircuit of the + new basis. -/ +theorem CompleteBasis.of_simulation (B₁ Bβ‚‚ : Basis) [CompleteBasis B₁] + (sim : βˆ€ {N M G} [NeZero N] [NeZero M] (c : Circuit B₁ N M G), + βˆƒ G', βˆƒ c' : Circuit Bβ‚‚ N M G', c'.eval = c.eval) + : CompleteBasis Bβ‚‚ where + complete f := by + obtain ⟨G, c, hc⟩ := CompleteBasis.complete (B := B₁) f + obtain ⟨G', c', hc'⟩ := sim c + exact ⟨G', c', hc'.trans hc⟩ + +namespace Circuit +variable {B : Basis} {N : Nat} [NeZero N] + +/-- A Boolean function is realizable over `B` when some single-output circuit +over `B` computes it. -/ +def Realizable (B : Basis) (f : BitString N β†’ Bool) : Prop := + βˆƒ G, βˆƒ c : Circuit B N 1 G, (fun x => (c.eval x) 0) = f + +/-- Sizes of all single-output circuits over `B` that realize `f`. -/ +def realizationSizes (B : Basis) (f : BitString N β†’ Bool) : Set Nat := + {s | βˆƒ G, βˆƒ c : Circuit B N 1 G, + c.size = s ∧ (fun x => (c.eval x) 0) = f} + +/-- The minimum circuit size over an arbitrary basis, as an extended natural. + +A single-output circuit `Circuit B N 1 G` has size `G + 1`. The value is `⊀` +exactly when no circuit over `B` computes `f`; thus an unrealizable function +cannot be confused with a zero-size function. -/ +noncomputable def sizeComplexityWithTop + (B : Basis) (f : BitString N β†’ Bool) : WithTop Nat := + sInf ((fun s : Nat => (s : WithTop Nat)) '' realizationSizes B f) + +/-- The minimum circuit size over a complete basis `B` computing `f`. + +This natural-valued interface requires completeness so that the set of +realizing circuits is nonempty. Use `sizeComplexityWithTop` when the basis may +be incomplete. -/ +-- Completeness is an intentional API precondition. The infimum expression +-- itself does not inspect the selected witness. +noncomputable def sizeComplexity + (B : Basis) [CompleteBasis B] (f : BitString N β†’ Bool) : Nat := + sInf (realizationSizes B f) + +private theorem realizationSizes_nonempty [CompleteBasis B] + (f : BitString N β†’ Bool) : + (realizationSizes B f).Nonempty := by + obtain ⟨G, c, hc⟩ := CompleteBasis.complete (B := B) (fun x => (fun _ : Fin 1 => f x)) + refine ⟨c.size, G, c, rfl, ?_⟩ + funext x + exact congrFun (congrFun hc x) 0 + +/-- Any circuit computing `f` gives an upper bound on the generic extended +size complexity. -/ +theorem sizeComplexityWithTop_le {G : Nat} + (c : Circuit B N 1 G) (f : BitString N β†’ Bool) + (hf : (fun x => (c.eval x) 0) = f) : + sizeComplexityWithTop B f ≀ c.size := by + apply sInf_le + exact ⟨c.size, ⟨G, c, rfl, hf⟩, rfl⟩ + +/-- Generic size complexity is infinite exactly for functions that cannot be +realized over the chosen basis. -/ +theorem sizeComplexityWithTop_eq_top_iff + (f : BitString N β†’ Bool) : + sizeComplexityWithTop B f = ⊀ ↔ Β¬ Realizable B f := by + rw [sizeComplexityWithTop, sInf_eq_top] + constructor + Β· intro h hrealizable + obtain ⟨G, c, hc⟩ := hrealizable + have htop := h (c.size : WithTop Nat) + ⟨c.size, ⟨G, c, rfl, hc⟩, rfl⟩ + exact (WithTop.coe_ne_top : (c.size : WithTop Nat) β‰  ⊀) htop + Β· intro h a ha + obtain ⟨s, ⟨G, c, _, hc⟩, rfl⟩ := ha + exact (h ⟨G, c, hc⟩).elim + +/-- Generic size complexity is finite exactly for realizable functions. -/ +theorem sizeComplexityWithTop_ne_top_iff + (f : BitString N β†’ Bool) : + sizeComplexityWithTop B f β‰  ⊀ ↔ Realizable B f := by + rw [ne_eq, sizeComplexityWithTop_eq_top_iff] + simp only [not_not] + +/-- Whenever the generic size complexity is finite, a circuit realizes its +minimum value. -/ +theorem sizeComplexityWithTop_witness + (f : BitString N β†’ Bool) + (hfinite : sizeComplexityWithTop B f β‰  ⊀) : + βˆƒ G, βˆƒ c : Circuit B N 1 G, + (c.size : WithTop Nat) = sizeComplexityWithTop B f ∧ + (fun x => (c.eval x) 0) = f := by + have hrealizable := (sizeComplexityWithTop_ne_top_iff (B := B) f).mp hfinite + obtain ⟨Gβ‚€, cβ‚€, hcβ‚€βŸ© := hrealizable + have hset : ((fun s : Nat => (s : WithTop Nat)) '' + realizationSizes B f).Nonempty := + ⟨cβ‚€.size, cβ‚€.size, ⟨Gβ‚€, cβ‚€, rfl, hcβ‚€βŸ©, rfl⟩ + have hmem := csInf_mem hset + obtain ⟨s, ⟨G, c, hs, hc⟩, hcoe⟩ := hmem + exact ⟨G, c, hs β–Έ hcoe, hc⟩ + +/-- Over a complete basis, the generic extended measure agrees with the +natural-valued minimum. -/ +theorem sizeComplexityWithTop_eq_coe [CompleteBasis B] + (f : BitString N β†’ Bool) : + sizeComplexityWithTop B f = (sizeComplexity B f : WithTop Nat) := by + apply le_antisymm + Β· apply sInf_le + exact ⟨sizeComplexity B f, + Nat.sInf_mem (realizationSizes_nonempty (B := B) f), rfl⟩ + Β· apply le_sInf + rintro _ ⟨s, hs, rfl⟩ + exact WithTop.coe_le_coe.mpr (Nat.sInf_le hs) + +/-- For a complete basis, circuit size complexity is always positive. -/ +theorem sizeComplexity_pos [CompleteBasis B] + (f : BitString N β†’ Bool) : + 0 < sizeComplexity B f := by + obtain ⟨_, _, hs, _⟩ := Nat.sInf_mem (realizationSizes_nonempty (B := B) f) + simp only [sizeComplexity] + rw [← hs, size] + omega + +/-- Any circuit computing `f` has size at least `sizeComplexity B f`. -/ +theorem sizeComplexity_le [CompleteBasis B] {G : Nat} + (c : Circuit B N 1 G) (f : BitString N β†’ Bool) + (hf : (fun x => (c.eval x) 0) = f) : + sizeComplexity B f ≀ c.size := + Nat.sInf_le ⟨G, c, rfl, hf⟩ + +/-- For a complete basis, `sizeComplexity` is realized by some circuit. -/ +theorem sizeComplexity_witness [CompleteBasis B] + (f : BitString N β†’ Bool) : + βˆƒ G, βˆƒ c : Circuit B N 1 G, + c.size = sizeComplexity B f ∧ (fun x => (c.eval x) 0) = f := + Nat.sInf_mem (realizationSizes_nonempty (B := B) f) + +end Circuit + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding.lean new file mode 100644 index 0000000000..9d06fdb304 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Defs.lean new file mode 100644 index 0000000000..436502481f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Defs.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Circuits.AndOrNot.Defs + +/-! +# Machine-facing encoding of fan-in-two AND/OR circuits + +This file defines a proof-free, on-tape representation of the library's +`Basis.andOr2` circuits. A raw circuit is an ordered list of gates. For an +input arity `N`, wires `0, ..., N - 1` are primary inputs and gate `i` produces +wire `N + i`. Thus topological well-formedness says that both references of +gate `i` are strictly less than `N + i`. The last gate is the sole output. + +The evaluator is intentionally iterative. It stores each wire value in an +array exactly once, so sharing in the circuit DAG does not cause the recursive +recomputation performed by the proof-oriented `Circuit.wireValue` definition. + +The bit format is deterministic and self-delimiting. Naturals use terminated +unary (`n` one-bits followed by a zero-bit), a gate stores three fixed bits and +two unary references, and a circuit starts with its unary gate count. Exact +decoding rejects truncation and trailing garbage. Unary references make the +format polynomially long in the input arity and number of gates; a binary +format can be added later without changing the raw circuit semantics. +-/ + + +@[expose] public section + +namespace Complexity + +namespace CircuitCode + +/-- A proof-free fan-in-two AND/OR gate. + +`inputβ‚€` and `input₁` are absolute wire indices. Negation flags are applied +before the AND/OR operation, matching `Gate.negated` in the typed circuit +model. -/ +structure RawGate where + /-- Whether the gate computes AND or OR of its (possibly negated) inputs. -/ + op : AndOrOp + /-- Absolute wire index of the first input. -/ + inputβ‚€ : β„• + /-- Absolute wire index of the second input. -/ + input₁ : β„• + /-- Whether the first input value is negated before applying `op`. -/ + negatedβ‚€ : Bool + /-- Whether the second input value is negated before applying `op`. -/ + negated₁ : Bool + deriving DecidableEq + +/-- A raw single-output circuit. The output is the value of the last gate. -/ +abbrev RawCircuit := List RawGate + +namespace RawGate + +/-- Both inputs of a gate must refer to already available wires. -/ +def WellFormedAt (g : RawGate) (available : β„•) : Prop := + g.inputβ‚€ < available ∧ g.input₁ < available + +instance (g : RawGate) (available : β„•) : Decidable (g.WellFormedAt available) := + by + unfold WellFormedAt + exact inferInstance + +/-- Boolean checker corresponding to `WellFormedAt`. -/ +def isWellFormedAt (g : RawGate) (available : β„•) : Bool := + decide (g.WellFormedAt available) + +/-- Evaluate a gate once its two (unnegated) input values are known. -/ +def eval (g : RawGate) (valueβ‚€ value₁ : Bool) : Bool := + let valueβ‚€ := g.negatedβ‚€.xor valueβ‚€ + let value₁ := g.negated₁.xor value₁ + match g.op with + | .and => valueβ‚€ && value₁ + | .or => valueβ‚€ || value₁ + +end RawGate + +namespace RawCircuit + +/-- Every gate reference points to a primary input or an earlier gate. -/ +def TopologicallyWellFormed (N : β„•) (c : RawCircuit) : Prop := + βˆ€ i : Fin c.length, (c.get i).WellFormedAt (N + i.val) + +instance (N : β„•) (c : RawCircuit) : Decidable (TopologicallyWellFormed N c) := + by + unfold TopologicallyWellFormed + exact Fintype.decidableForallFintype + +/-- A valid single-output raw circuit is nonempty and topologically ordered. -/ +def WellFormed (N : β„•) (c : RawCircuit) : Prop := + c β‰  [] ∧ c.TopologicallyWellFormed N + +instance (N : β„•) (c : RawCircuit) : Decidable (WellFormed N c) := + by + unfold WellFormed + exact inferInstance + +/-- Boolean checker for the explicit well-formedness predicate. -/ +def isWellFormed (N : β„•) (c : RawCircuit) : Bool := + decide (c.WellFormed N) + +/-- Evaluate gates in order, appending each result to the memo array. + +Failure means that a gate contains a forward or out-of-range reference. -/ +def evalAux? : RawCircuit β†’ Array Bool β†’ Option (Array Bool) + | [], wires => some wires + | gate :: gates, wires => do + let valueβ‚€ ← wires[gate.inputβ‚€]? + let value₁ ← wires[gate.input₁]? + evalAux? gates (wires.push (gate.eval valueβ‚€ value₁)) + +/-- Evaluate a raw circuit on a list of primary-input values. + +The empty gate list has no designated output and is rejected. -/ +def eval? (c : RawCircuit) (input : List Bool) : Option Bool := do + if c.isEmpty then + none + else + let wires ← evalAux? c input.toArray + wires[input.length + c.length - 1]? + +end RawCircuit + +/-! ## Terminated unary fields -/ + +namespace NatCode + +/-- Self-delimiting unary: `n` one-bits followed by a zero terminator. -/ +def encode (n : β„•) : List Bool := + List.replicate n true ++ [false] + +/-- Parse one terminated-unary prefix, returning the unconsumed suffix. -/ +def decodeAux? : List Bool β†’ β„• β†’ Option (β„• Γ— List Bool) + | [], _ => none + | false :: rest, acc => some (acc, rest) + | true :: rest, acc => decodeAux? rest (acc + 1) + +/-- Parse one terminated-unary prefix. -/ +def decodePrefix? (bits : List Bool) : Option (β„• Γ— List Bool) := + decodeAux? bits 0 + +end NatCode + +/-! ## Gate serialization -/ + +namespace RawGate + +/-- Operation bit: one is AND and zero is OR. -/ +def opBit (g : RawGate) : Bool := + match g.op with + | .and => true + | .or => false + +/-- Decode the operation bit used by `opBit`. -/ +def opOfBit : Bool β†’ AndOrOp + | true => .and + | false => .or + +/-- Encode a gate as operation, negation flags, then two unary references. -/ +def encode (g : RawGate) : List Bool := + [g.opBit, g.negatedβ‚€, g.negated₁] ++ + NatCode.encode g.inputβ‚€ ++ NatCode.encode g.input₁ + +/-- Parse one gate prefix, returning the unconsumed suffix. -/ +def decodePrefix? : List Bool β†’ Option (RawGate Γ— List Bool) + | op :: negatedβ‚€ :: negated₁ :: rest => + match NatCode.decodePrefix? rest with + | none => none + | some (inputβ‚€, rest) => + match NatCode.decodePrefix? rest with + | none => none + | some (input₁, rest) => + some ({ op := opOfBit op, inputβ‚€, input₁, negatedβ‚€, negated₁ }, rest) + | _ => none + +end RawGate + +/-! ## Circuit serialization -/ + +namespace RawCircuit + +/-- Parse exactly `count` gate prefixes and return the remaining suffix. -/ +def decodeGates? : β„• β†’ List Bool β†’ Option (RawCircuit Γ— List Bool) + | 0, bits => some ([], bits) + | count + 1, bits => + match RawGate.decodePrefix? bits with + | none => none + | some (gate, rest) => + match decodeGates? count rest with + | none => none + | some (gates, rest) => some (gate :: gates, rest) + +/-- Serialize a circuit as its unary gate count followed by its gates. -/ +def encode (c : RawCircuit) : List Bool := + NatCode.encode c.length ++ c.flatMap RawGate.encode + +/-- Decode one circuit prefix and return the unconsumed suffix. -/ +def decodePrefix? (bits : List Bool) : Option (RawCircuit Γ— List Bool) := + match NatCode.decodePrefix? bits with + | none => none + | some (count, rest) => decodeGates? count rest + +/-- Decode exactly one circuit. Any trailing bits are rejected. -/ +def decode? (bits : List Bool) : Option RawCircuit := + match decodePrefix? bits with + | some (c, []) => some c + | _ => none + +end RawCircuit + +/-- Translate a typed fan-in-two gate to the proof-free wire format. -/ +def RawGate.ofGate {W : β„•} (g : Gate Basis.andOr2 W) : RawGate := by + have hfan : g.fanIn = 2 := fanIn_andOr2 g + exact + { op := g.op + inputβ‚€ := (g.inputs ⟨0, by omega⟩).val + input₁ := (g.inputs ⟨1, by omega⟩).val + negatedβ‚€ := g.negated ⟨0, by omega⟩ + negated₁ := g.negated ⟨1, by omega⟩ } + +/-- Translate a typed single-output circuit to an ordered raw circuit. + +Internal gates retain their order and the typed output gate is appended as the +last raw gate. -/ +def RawCircuit.ofCircuit {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : RawCircuit := + List.ofFn (fun i : Fin G => RawGate.ofGate (c.gates i)) ++ + [RawGate.ofGate (c.outputs 0)] + +/-- Serialize a typed fan-in-two circuit as machine-facing bits. -/ +def encodeCircuit {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : List Bool := + (RawCircuit.ofCircuit c).encode + +/-- Decode and evaluate a circuit code against an input of exactly `N` bits. -/ +def evalCode (N : β„•) (code input : List Bool) : Option Bool := do + if input.length = N then + let circuit ← RawCircuit.decode? code + circuit.eval? input + else + none + +end CircuitCode + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal.lean new file mode 100644 index 0000000000..d6dace739b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal.Codec + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal/Codec.lean b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal/Codec.lean new file mode 100644 index 0000000000..0c38988a4b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Circuits/Encoding/Internal/Codec.lean @@ -0,0 +1,552 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# Correctness of the machine-facing circuit codec + +This internal module proves that the proof-free encoding and iterative +evaluator in `Encoding.Defs` faithfully enforce their advertised syntactic +invariants. Semantic agreement with typed circuit evaluation is deliberately +kept in a separate proof layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace CircuitCode + +namespace NatCode + +/-- The unary encoding of `n` uses exactly `n + 1` bits (`n` trues and a false). -/ +@[simp] theorem length_encode (n : β„•) : (encode n).length = n + 1 := by + simp [encode] + +private theorem decodeAux?_replicate_true (n acc : β„•) (suffix : List Bool) : + decodeAux? (List.replicate n true ++ false :: suffix) acc = + some (acc + n, suffix) := by + induction n generalizing acc with + | zero => simp [decodeAux?] + | succ n ih => + rw [List.replicate_succ, List.cons_append] + simp only [decodeAux?] + rw [ih] + congr 2 + omega + +/-- A unary field can be decoded in front of an arbitrary suffix. -/ +@[simp] theorem decodePrefix?_encode_append (n : β„•) (suffix : List Bool) : + decodePrefix? (encode n ++ suffix) = some (n, suffix) := by + rw [decodePrefix?, encode, List.append_assoc] + change decodeAux? (List.replicate n true ++ false :: suffix) 0 = _ + simpa using decodeAux?_replicate_true n 0 suffix + +private theorem decodeAux?_sound {bits : List Bool} {acc n : β„•} + {suffix : List Bool} (h : decodeAux? bits acc = some (n, suffix)) : + βˆƒ consumed : β„•, + n = acc + consumed ∧ + bits = List.replicate consumed true ++ false :: suffix := by + induction bits generalizing acc with + | nil => simp [decodeAux?] at h + | cons bit bits ih => + cases bit with + | false => + simp only [decodeAux?] at h + cases h + exact ⟨0, by simp⟩ + | true => + simp only [decodeAux?] at h + obtain ⟨consumed, hn, hbits⟩ := ih h + refine ⟨consumed + 1, by omega, ?_⟩ + rw [List.replicate_succ] + simp [hbits] + +private theorem decodeAux?_eq_none_iff (bits : List Bool) (acc : β„•) : + decodeAux? bits acc = none ↔ + bits = List.replicate bits.length true := by + induction bits generalizing acc with + | nil => simp [decodeAux?] + | cons bit bits ih => + cases bit <;> simp [decodeAux?, ih, List.replicate_succ] + +/-- Unary prefix decoding fails exactly when every available bit is a one, +so no zero terminator occurs. -/ +theorem decodePrefix?_eq_none_iff (bits : List Bool) : + decodePrefix? bits = none ↔ + bits = List.replicate bits.length true := by + simpa [decodePrefix?] using decodeAux?_eq_none_iff bits 0 + +/-- Successful unary prefix decoding reconstructs the consumed input exactly. -/ +theorem decodePrefix?_eq_some_iff (bits : List Bool) (n : β„•) (suffix : List Bool) : + decodePrefix? bits = some (n, suffix) ↔ bits = encode n ++ suffix := by + constructor + Β· intro h + obtain ⟨consumed, hn, hbits⟩ := decodeAux?_sound h + simp only [decodePrefix?] at h + have : consumed = n := by omega + subst consumed + simpa [encode, List.append_assoc] using hbits + Β· rintro rfl + exact decodePrefix?_encode_append n suffix + +end NatCode + +namespace RawGate + +/-- The Boolean well-formedness check agrees with the `WellFormedAt` predicate. -/ +@[simp] theorem isWellFormedAt_eq_true (gate : RawGate) (available : β„•) : + gate.isWellFormedAt available = true ↔ gate.WellFormedAt available := by + simp [isWellFormedAt] + +/-- Decoding a gate's operation bit recovers its operation. -/ +@[simp] theorem opOfBit_opBit (g : RawGate) : opOfBit g.opBit = g.op := by + cases g with + | mk op inputβ‚€ input₁ negatedβ‚€ negated₁ => cases op <;> rfl + +/-- A gate encoding uses five header/delimiter bits plus one bit per unary + input reference. -/ +@[simp] theorem length_encode (g : RawGate) : + g.encode.length = 5 + g.inputβ‚€ + g.input₁ := by + simp [encode, NatCode.length_encode] + omega + +/-- A gate can be decoded in front of an arbitrary suffix. -/ +@[simp] theorem decodePrefix?_encode_append (g : RawGate) (suffix : List Bool) : + decodePrefix? (g.encode ++ suffix) = some (g, suffix) := by + cases g with + | mk op inputβ‚€ input₁ negatedβ‚€ negated₁ => + cases op <;> + simp [encode, decodePrefix?, opBit, opOfBit, List.append_assoc] + +/-- Successful gate-prefix decoding reconstructs the consumed input exactly. -/ +theorem decodePrefix?_eq_some_iff (bits : List Bool) (gate : RawGate) + (suffix : List Bool) : + decodePrefix? bits = some (gate, suffix) ↔ bits = gate.encode ++ suffix := by + constructor + Β· intro h + cases bits with + | nil => simp [decodePrefix?] at h + | cons op bits => + cases bits with + | nil => simp [decodePrefix?] at h + | cons negatedβ‚€ bits => + cases bits with + | nil => simp [decodePrefix?] at h + | cons negated₁ rest => + cases hβ‚€ : NatCode.decodePrefix? rest with + | none => simp [decodePrefix?, hβ‚€] at h + | some parsedβ‚€ => + obtain ⟨inputβ‚€, restβ‚€βŸ© := parsedβ‚€ + cases h₁ : NatCode.decodePrefix? restβ‚€ with + | none => simp [decodePrefix?, hβ‚€, h₁] at h + | some parsed₁ => + obtain ⟨input₁, restβ‚βŸ© := parsed₁ + simp only [decodePrefix?, hβ‚€, h₁] at h + cases h + have hrestβ‚€ := + (NatCode.decodePrefix?_eq_some_iff rest inputβ‚€ restβ‚€).mp hβ‚€ + have hrest₁ := + (NatCode.decodePrefix?_eq_some_iff restβ‚€ input₁ suffix).mp h₁ + cases op <;> + simp [encode, opBit, opOfBit, hrestβ‚€, hrest₁, + List.append_assoc] + Β· rintro rfl + exact decodePrefix?_encode_append gate suffix + +end RawGate + +namespace RawCircuit + +/-- The Boolean well-formedness check agrees with the `WellFormed` predicate. -/ +@[simp] theorem isWellFormed_eq_true (circuit : RawCircuit) (N : β„•) : + circuit.isWellFormed N = true ↔ circuit.WellFormed N := by + simp [isWellFormed] + +/-- Parsing an encoded gate list consumes exactly that list and leaves the + caller-supplied suffix untouched. -/ +@[simp] theorem decodeGates?_flatMap_encode_append + (c : RawCircuit) (suffix : List Bool) : + decodeGates? c.length (c.flatMap RawGate.encode ++ suffix) = some (c, suffix) := by + induction c with + | nil => simp [decodeGates?] + | cons gate gates ih => + simp [decodeGates?, ih, List.append_assoc] + +/-- A circuit prefix can be decoded in front of an arbitrary suffix. -/ +@[simp] theorem decodePrefix?_encode_append (c : RawCircuit) (suffix : List Bool) : + decodePrefix? (c.encode ++ suffix) = some (c, suffix) := by + simp [decodePrefix?, encode, List.append_assoc] + +/-- Exact decoding is a left inverse of circuit serialization. -/ +@[simp] theorem decode?_encode (c : RawCircuit) : decode? c.encode = some c := by + rw [show c.encode = c.encode ++ [] by simp] + unfold decode? + rw [decodePrefix?_encode_append] + +/-- Exact decoding rejects any nonempty suffix after a canonical encoding. -/ +theorem decode?_encode_append_eq_none (c : RawCircuit) {suffix : List Bool} + (h : suffix β‰  []) : decode? (c.encode ++ suffix) = none := by + simp [decode?, h] + +/-- A circuit encoding consists of the unary gate count followed by the + concatenated gate encodings. -/ +@[simp] theorem length_encode (c : RawCircuit) : + c.encode.length = c.length + 1 + (c.map fun gate => gate.encode.length).sum := by + simp [encode, NatCode.length_encode, List.length_flatMap] + +/-- Topological well-formedness of a nonempty gate list splits at its head. -/ +theorem topologicallyWellFormed_cons (N : β„•) (gate : RawGate) (gates : RawCircuit) : + TopologicallyWellFormed N (gate :: gates) ↔ + gate.WellFormedAt N ∧ TopologicallyWellFormed (N + 1) gates := by + constructor + Β· intro h + constructor + Β· simpa [TopologicallyWellFormed] using h (0 : Fin (gate :: gates).length) + Β· intro i + have hi := h i.succ + change (gates.get i).WellFormedAt (N + (i.val + 1)) at hi + unfold RawGate.WellFormedAt at hi ⊒ + omega + Β· rintro ⟨hgate, hgates⟩ i + refine Fin.cases ?_ (fun j => ?_) i + Β· simpa using hgate + Β· have hj := hgates j + change (gates.get j).WellFormedAt (N + (j.val + 1)) + unfold RawGate.WellFormedAt at hj ⊒ + omega + +/-- Successful fixed-count gate decoding reconstructs the consumed input. -/ +theorem decodeGates?_eq_some_iff (count : β„•) (bits : List Bool) + (circuit : RawCircuit) (suffix : List Bool) : + decodeGates? count bits = some (circuit, suffix) ↔ + circuit.length = count ∧ bits = circuit.flatMap RawGate.encode ++ suffix := by + constructor + Β· intro h + induction count generalizing bits circuit with + | zero => + simp only [decodeGates?] at h + cases h + simp + | succ count ih => + cases hgate : RawGate.decodePrefix? bits with + | none => simp [decodeGates?, hgate] at h + | some parsedGate => + obtain ⟨gate, rest⟩ := parsedGate + cases hgates : decodeGates? count rest with + | none => simp [decodeGates?, hgate, hgates] at h + | some parsedGates => + obtain ⟨gates, final⟩ := parsedGates + simp only [decodeGates?, hgate, hgates] at h + cases h + obtain ⟨hlen, hrest⟩ := ih rest gates hgates + have hbits := + (RawGate.decodePrefix?_eq_some_iff bits gate rest).mp hgate + constructor + Β· simp [hlen] + Β· rw [hbits, hrest] + simp [List.append_assoc] + Β· rintro ⟨hlen, rfl⟩ + subst count + exact decodeGates?_flatMap_encode_append circuit suffix + +/-- Successful circuit-prefix decoding reconstructs its canonical encoding. -/ +theorem decodePrefix?_eq_some_iff (bits : List Bool) (circuit : RawCircuit) + (suffix : List Bool) : + decodePrefix? bits = some (circuit, suffix) ↔ + bits = circuit.encode ++ suffix := by + constructor + Β· intro h + cases hcount : NatCode.decodePrefix? bits with + | none => simp [decodePrefix?, hcount] at h + | some parsedCount => + obtain ⟨count, rest⟩ := parsedCount + simp only [decodePrefix?, hcount] at h + have hbits := + (NatCode.decodePrefix?_eq_some_iff bits count rest).mp hcount + obtain ⟨hlen, hrest⟩ := + (decodeGates?_eq_some_iff count rest circuit suffix).mp h + rw [hbits, hrest] + simp [encode, hlen, List.append_assoc] + Β· rintro rfl + exact decodePrefix?_encode_append circuit suffix + +/-- Exact decoding succeeds precisely on canonical encodings. -/ +theorem decode?_eq_some_iff_internal (bits : List Bool) (circuit : RawCircuit) : + decode? bits = some circuit ↔ bits = circuit.encode := by + constructor + Β· intro h + cases hprefix : decodePrefix? bits with + | none => simp [decode?, hprefix] at h + | some parsed => + obtain ⟨decoded, suffix⟩ := parsed + cases suffix with + | nil => + simp only [decode?, hprefix] at h + cases h + simpa using (decodePrefix?_eq_some_iff bits circuit []).mp hprefix + | cons bit suffix => simp [decode?, hprefix] at h + Β· rintro rfl + exact decode?_encode circuit + +/-- Running the iterative evaluator succeeds exactly for topological gate lists. -/ +theorem evalAux?_isSome_iff (circuit : RawCircuit) (wires : Array Bool) : + (evalAux? circuit wires).isSome ↔ + circuit.TopologicallyWellFormed wires.size := by + induction circuit generalizing wires with + | nil => simp [evalAux?, TopologicallyWellFormed] + | cons gate gates ih => + rw [topologicallyWellFormed_cons] + simp only [evalAux?] + by_cases hβ‚€ : gate.inputβ‚€ < wires.size + Β· rw [Array.getElem?_eq_getElem hβ‚€] + by_cases h₁ : gate.input₁ < wires.size + Β· rw [Array.getElem?_eq_getElem h₁] + simp [ih, RawGate.WellFormedAt, hβ‚€, h₁, Array.size_push] + Β· rw [Array.getElem?_eq_none (by omega)] + simp [RawGate.WellFormedAt, h₁] + Β· rw [Array.getElem?_eq_none (by omega)] + simp [RawGate.WellFormedAt, hβ‚€] + +/-- Successful iterative evaluation appends exactly one wire per gate. -/ +theorem evalAux?_size {circuit : RawCircuit} {wires result : Array Bool} + (h : evalAux? circuit wires = some result) : + result.size = wires.size + circuit.length := by + induction circuit generalizing wires result with + | nil => + simp only [evalAux?] at h + cases h + simp + | cons gate gates ih => + cases hβ‚€ : wires[gate.inputβ‚€]? with + | none => simp [evalAux?, hβ‚€] at h + | some valueβ‚€ => + cases h₁ : wires[gate.input₁]? with + | none => simp [evalAux?, hβ‚€, h₁] at h + | some value₁ => + simp only [evalAux?, hβ‚€, h₁] at h + have hsize := ih h + rw [Array.size_push] at hsize + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hsize + +/-- Raw evaluation succeeds precisely for nonempty topologically ordered circuits. -/ +theorem eval?_isSome_iff_internal (circuit : RawCircuit) (input : List Bool) : + (circuit.eval? input).isSome ↔ circuit.WellFormed input.length := by + cases circuit with + | nil => simp [eval?, WellFormed] + | cons gate gates => + constructor + Β· intro h + cases haux : evalAux? (gate :: gates) input.toArray with + | none => simp [eval?, haux] at h + | some result => + have htop : + TopologicallyWellFormed input.toArray.size (gate :: gates) := + (evalAux?_isSome_iff (gate :: gates) input.toArray).mp (by simp [haux]) + constructor + Β· simp + Β· simpa using htop + Β· rintro ⟨_, htop⟩ + have htop' : + TopologicallyWellFormed input.toArray.size (gate :: gates) := by + simpa using htop + have hsome := + (evalAux?_isSome_iff (gate :: gates) input.toArray).mpr htop' + obtain ⟨result, haux⟩ := Option.isSome_iff_exists.mp hsome + have hsize := evalAux?_size haux + have hlt : + input.length + (gate :: gates).length - 1 < result.size := by + rw [hsize, List.size_toArray] + simp + rw [eval?] + simp only [List.isEmpty_cons, Bool.false_eq_true, ite_false, haux] + change (result[input.length + (gate :: gates).length - 1]?).isSome + rw [Array.getElem?_eq_getElem hlt] + simp + +end RawCircuit + +/-- Code evaluation succeeds exactly when the input length is the declared arity, +the code is canonical, and the decoded raw circuit is well formed. -/ +theorem evalCode_isSome_iff (N : β„•) (code input : List Bool) : + (evalCode N code input).isSome ↔ + input.length = N ∧ + βˆƒ circuit : RawCircuit, + code = circuit.encode ∧ circuit.WellFormed N := by + constructor + Β· intro h + by_cases hlen : input.length = N + Β· cases hdecode : RawCircuit.decode? code with + | none => simp [evalCode, hlen, hdecode] at h + | some circuit => + have heval : (circuit.eval? input).isSome := by + simpa [evalCode, hlen, hdecode] using h + have hwellInput := + (RawCircuit.eval?_isSome_iff_internal circuit input).mp heval + have hcode := + (RawCircuit.decode?_eq_some_iff_internal code circuit).mp hdecode + exact ⟨hlen, circuit, hcode, by simpa [hlen] using hwellInput⟩ + Β· simp [evalCode, hlen] at h + Β· rintro ⟨hlen, circuit, hcode, hwell⟩ + subst code + have heval : (circuit.eval? input).isSome := + (RawCircuit.eval?_isSome_iff_internal circuit input).mpr + (by simpa [hlen] using hwell) + simpa [evalCode, hlen] using heval + +namespace RawGate + +/-- The first raw reference is the first typed input wire. -/ +@[simp] theorem ofGate_inputβ‚€ {W : β„•} (gate : Gate Basis.andOr2 W) : + (RawGate.ofGate gate).inputβ‚€ = (gate.inputs ⟨0, by rw [fanIn_andOr2 gate]; omega⟩).val := by + simp [RawGate.ofGate] + +/-- The second raw reference is the second typed input wire. -/ +@[simp] theorem ofGate_input₁ {W : β„•} (gate : Gate Basis.andOr2 W) : + (RawGate.ofGate gate).input₁ = (gate.inputs ⟨1, by rw [fanIn_andOr2 gate]; omega⟩).val := by + simp [RawGate.ofGate] + +/-- Erasing a typed gate's proofs never introduces an out-of-range reference. -/ +theorem ofGate_wellFormedAt {W : β„•} (gate : Gate Basis.andOr2 W) : + (RawGate.ofGate gate).WellFormedAt W := by + constructor <;> simp + +end RawGate + +namespace RawCircuit + +/-- Translating a typed single-output circuit produces one raw gate per +internal gate, followed by its output gate. -/ +@[simp] theorem length_ofCircuit {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : + (ofCircuit c).length = G + 1 := by + simp [ofCircuit] + +/-- Translation preserves the typed circuit's topological ordering. -/ +theorem ofCircuit_topologicallyWellFormed {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : + (ofCircuit c).TopologicallyWellFormed N := by + intro i + rw [List.get_eq_getElem] + change + (List.ofFn (fun j : Fin G => RawGate.ofGate (c.gates j)) ++ + [RawGate.ofGate (c.outputs 0)])[i.val].WellFormedAt (N + i.val) + by_cases hi : i.val < G + Β· rw [List.getElem_append_left (by simp [hi])] + rw [List.getElem_ofFn] + constructor + Β· rw [RawGate.ofGate_inputβ‚€] + exact c.acyclic ⟨i.val, hi⟩ + ⟨0, by rw [fanIn_andOr2 (c.gates ⟨i.val, hi⟩)]; omega⟩ + Β· rw [RawGate.ofGate_input₁] + exact c.acyclic ⟨i.val, hi⟩ + ⟨1, by rw [fanIn_andOr2 (c.gates ⟨i.val, hi⟩)]; omega⟩ + Β· have hieq : i.val = G := by + have := i.isLt + simp only [length_ofCircuit] at this + omega + rw [List.getElem_append_right (by simp; omega)] + simpa [hieq] using RawGate.ofGate_wellFormedAt (c.outputs 0) + +/-- Translation of a typed circuit is a valid raw single-output circuit. -/ +theorem ofCircuit_wellFormed {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : + (ofCircuit c).WellFormed N := by + constructor + Β· intro hempty + have hlen := length_ofCircuit c + rw [hempty] at hlen + simp at hlen + Β· exact ofCircuit_topologicallyWellFormed c + +private theorem sum_encode_length_le (N : β„•) (circuit : RawCircuit) + (hwell : circuit.TopologicallyWellFormed N) : + (circuit.map fun gate => gate.encode.length).sum ≀ + circuit.length * (2 * (N + circuit.length) + 5) := by + induction circuit generalizing N with + | nil => simp + | cons gate gates ih => + obtain ⟨hgate, hgates⟩ := + (topologicallyWellFormed_cons N gate gates).mp hwell + have hgateLength : gate.encode.length ≀ 2 * N + 5 := by + rw [RawGate.length_encode] + unfold RawGate.WellFormedAt at hgate + omega + have htail := ih (N + 1) hgates + let K := 2 * (N + (gate :: gates).length) + 5 + have htail' : + (gates.map fun next => next.encode.length).sum ≀ gates.length * K := by + simpa [K, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using htail + have hgateLength' : gate.encode.length ≀ K := by + dsimp only [K] + simp only [List.length_cons] + omega + simp only [List.map_cons, List.sum_cons, List.length_cons] + calc + gate.encode.length + (gates.map fun next => next.encode.length).sum ≀ + K + gates.length * K := Nat.add_le_add hgateLength' htail' + _ = (gates.length + 1) * K := by + rw [Nat.add_mul] + simp [Nat.add_comm] + +/-- A generic topological raw circuit with `G` gates and input arity `N` has +quadratic-size unary encoding. -/ +theorem encode_length_le (N G : β„•) (circuit : RawCircuit) + (hlen : circuit.length = G) + (hwell : circuit.TopologicallyWellFormed N) : + circuit.encode.length ≀ G + 1 + G * (2 * (N + G) + 5) := by + subst G + rw [RawCircuit.length_encode] + exact Nat.add_le_add_left (sum_encode_length_le N circuit hwell) _ + +end RawCircuit + +/-- A code produced from a typed circuit is evaluable exactly on inputs of +the circuit's declared arity. -/ +theorem evalCode_encodeCircuit_isSome_iff {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) (input : List Bool) : + (evalCode N (encodeCircuit c) input).isSome ↔ input.length = N := by + rw [evalCode_isSome_iff] + constructor + Β· exact And.left + Β· intro hlen + exact ⟨hlen, RawCircuit.ofCircuit c, rfl, RawCircuit.ofCircuit_wellFormed c⟩ + +/-- The unary encoding of a typed `G`-internal-gate circuit has a concrete +quadratic length bound. -/ +theorem encodeCircuit_length_le {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : + (encodeCircuit c).length ≀ + (G + 1) + 1 + (G + 1) * (2 * (N + (G + 1)) + 5) := by + exact RawCircuit.encode_length_le N (G + 1) (RawCircuit.ofCircuit c) + (RawCircuit.length_ofCircuit c) (RawCircuit.ofCircuit_topologicallyWellFormed c) + +/-- In the library's size convention, which counts internal and output gates +but not primary inputs or free negations, unary circuit codes have quadratic +length in the input arity and circuit size. -/ +theorem encodeCircuit_length_le_size_internal {N G : β„•} [NeZero N] + (c : Circuit Basis.andOr2 N 1 G) : + (encodeCircuit c).length ≀ + 1 + c.size * (2 * (N + c.size) + 6) := by + calc + (encodeCircuit c).length ≀ + (G + 1) + 1 + (G + 1) * (2 * (N + (G + 1)) + 5) := + encodeCircuit_length_le c + _ = 1 + c.size * (2 * (N + c.size) + 6) := by + simp only [Circuit.size] + conv_rhs => + rw [show 2 * (N + (G + 1)) + 6 = + (2 * (N + (G + 1)) + 5) + 1 by omega] + rw [Nat.mul_add] + omega + +end CircuitCode + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes.lean b/LeanPool/BeyondBethe/Complexitylib/Classes.lean new file mode 100644 index 0000000000..cfd87eb402 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Classes.Containments +public import LeanPool.BeyondBethe.Complexitylib.Classes.Exponential +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP +public import LeanPool.BeyondBethe.Complexitylib.Classes.L +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP +public import LeanPool.BeyondBethe.Complexitylib.Classes.P +public import LeanPool.BeyondBethe.Complexitylib.Classes.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Classes.Randomized +public import LeanPool.BeyondBethe.Complexitylib.Classes.Space +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Containments.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Containments.lean new file mode 100644 index 0000000000..be95c0f943 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Containments.lean @@ -0,0 +1,312 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP +public import LeanPool.BeyondBethe.Complexitylib.Classes.Randomized +public import LeanPool.BeyondBethe.Complexitylib.Classes.L +public import LeanPool.BeyondBethe.Complexitylib.Classes.Exponential + +/-! +# Containment relations between complexity classes + +This file collects the standard containment results between complexity classes. + +## Theorems + +- `DTIME_subset_NTIME` β€” `DTIME(T) βŠ† NTIME(T)` +- `P_subset_NP` β€” `P βŠ† NP` +- `DTIME_mono` β€” `T₁ =O Tβ‚‚ β†’ DTIME(T₁) βŠ† DTIME(Tβ‚‚)` +- `NTIME_mono` β€” `T₁ =O Tβ‚‚ β†’ NTIME(T₁) βŠ† NTIME(Tβ‚‚)` +- `DSPACE_mono` β€” `S₁ =O Sβ‚‚ β†’ DSPACE(S₁) βŠ† DSPACE(Sβ‚‚)` +- `P_subset_EXP` β€” `P βŠ† EXP` +- `DTIME_subset_DSPACE` β€” `DTIME(T) βŠ† DSPACE(T)` (time bounds space) +- `P_subset_PSPACE` β€” `P βŠ† PSPACE` +- `RTIME_subset_NTIME` β€” `RTIME(T) βŠ† NTIME(T)` (one-sided error β†’ nondeterministic) +- `RP_subset_NP` β€” `RP βŠ† NP` +- `DTIME_subset_BPTIME` β€” `DTIME(T) βŠ† BPTIME(T)` (deterministic β†’ zero-error probabilistic) +- `P_subset_BPP` β€” `P βŠ† BPP` +- `NP_subset_NEXP` β€” `NP βŠ† NEXP` +- `EXP_subset_NEXP` β€” `EXP βŠ† NEXP` +- `BPTIME_subset_PPTIME` β€” `BPTIME(T) βŠ† PPTIME(T)` (bounded error β†’ unbounded error) +- `BPP_subset_PP` β€” `BPP βŠ† PP` +- `P_compl` β€” `L ∈ P β†’ Lᢜ ∈ P` (P closed under complement) +- `DSPACE_subset_NSPACE` β€” `DSPACE(S) βŠ† NSPACE(S)` +- `NSPACE_mono` β€” `S₁ =O Sβ‚‚ β†’ NSPACE(S₁) βŠ† NSPACE(Sβ‚‚)` +- `L_subset_NL` β€” `L βŠ† NL` +- `ZPP_subset_RP` β€” `ZPP βŠ† RP` +- `ZPP_subset_coRP` β€” `ZPP βŠ† coRP` +- `DTIME_subset_NSPACE` β€” `DTIME(T) βŠ† NSPACE(T)` +- `P_subset_NPSPACE` β€” `P βŠ† NPSPACE` +- `P_subset_NEXP` β€” `P βŠ† NEXP` +- `P_subset_PP` β€” `P βŠ† PP` +- `P_union` β€” `L₁ ∈ P β†’ Lβ‚‚ ∈ P β†’ L₁ βˆͺ Lβ‚‚ ∈ P` (P closed under union) +- `P_inter` β€” `L₁ ∈ P β†’ Lβ‚‚ ∈ P β†’ L₁ ∩ Lβ‚‚ ∈ P` (P closed under intersection) +-/ + + +@[expose] public section + +namespace Complexity + + +/-- **DTIME βŠ† NTIME**: every language decidable by a DTM in time `O(T)` is also + decidable by an NTM in time `O(T)`, via the `TM.toNTM` embedding. -/ +theorem DTIME_subset_NTIME (T : β„• β†’ β„•) : DTIME T βŠ† NTIME T := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm.toNTM, f, tm.toNTM_decidesInTime hdec, hbig⟩ + +/-- **P βŠ† NP** -/ +theorem P_subset_NP : P βŠ† NP := + Set.iUnion_mono fun _ => DTIME_subset_NTIME _ + +/-- DTIME is monotone with respect to `=O`: if `T₁ =O Tβ‚‚`, then `DTIME T₁ βŠ† DTIME Tβ‚‚`. -/ +theorem DTIME_mono {T₁ Tβ‚‚ : β„• β†’ β„•} (h : T₁ =O Tβ‚‚) : DTIME T₁ βŠ† DTIME Tβ‚‚ := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm, f, hdec, hbig.trans h⟩ + +/-- **P βŠ† EXP**: every polynomial-time language is also exponential-time. -/ +theorem P_subset_EXP : P βŠ† EXP := + Set.iUnion_mono fun _ => DTIME_mono (BigO.of_le (fun _ => Nat.lt_two_pow_self.le)) + +/-- **DTIME βŠ† DSPACE**: a DTM running in time `T` uses at most + `O(T)` auxiliary space, since every two-way tape head can move at most one + cell per step. -/ +theorem DTIME_subset_DSPACE (T : β„• β†’ β„•) : DTIME T βŠ† DSPACE T := by + intro L ⟨k, tm, f, hdec, hbig⟩ + refine ⟨k, tm, f, ⟨?_, ?_⟩, hbig⟩ + Β· -- Space bound: all reachable configurations obey the honest tape bounds + intro x c' hreach + obtain ⟨c_halt, t_halt, hle, hreachIn_halt, hhalt, _, _⟩ := hdec x + obtain ⟨t, hreachIn⟩ := TM.reaches_to_reachesIn tm hreach + have ht_le := TM.reachesIn_le_halt tm hreachIn hreachIn_halt hhalt + refine ⟨⟨?_, ?_⟩, ?_⟩ + Β· intro i + have hbound := TM.work_head_reachesIn_bound tm hreachIn i + have hzero := TM.initCfg_work_head_zero tm x i + omega + Β· have hbound := TM.input_head_reachesIn_bound tm hreachIn + have hzero := TM.initCfg_input_head_zero tm x + omega + Β· have hbound := TM.output_head_reachesIn_bound tm hreachIn + have hzero := TM.initCfg_output_head_zero tm x + omega + Β· -- Decision: reachesIn implies reaches, same output + intro x + obtain ⟨c', t, hle, hreachIn, hhalt, hyes, hno⟩ := hdec x + refine ⟨c', ?_, hhalt, hyes, hno⟩ + exact TM.reachesIn.rec Relation.ReflTransGen.refl + (fun hs _ ih => Relation.ReflTransGen.head hs ih) hreachIn + +/-- **P βŠ† PSPACE**: every polynomial-time language uses polynomial space. -/ +theorem P_subset_PSPACE : P βŠ† PSPACE := + Set.iUnion_mono fun _ => DTIME_subset_DSPACE _ + +/-- **RTIME βŠ† NTIME**: one-sided error implies nondeterministic. + The same NTM works: `RejectsWithProb 0` means no accepting paths for `x βˆ‰ L`, + and `AcceptsWithProb (1/2)` means some accepting path exists for `x ∈ L`. -/ +theorem RTIME_subset_NTIME (T : β„• β†’ β„•) : RTIME T βŠ† NTIME T := by + intro L ⟨k, tm, f, hhalt, hacc, hrej, hbig⟩ + refine ⟨k, tm, f, ⟨hhalt, fun x => ?_⟩, hbig⟩ + constructor + Β· -- x ∈ L β†’ AcceptsInTime: acceptProb β‰₯ 1/2 > 0 implies βˆƒ accepting path + intro hx; by_contra hno + simp only [NTM.AcceptsInTime] at hno; push Not at hno + have hcount : tm.acceptCount x (f x.length) = 0 := by + simp only [NTM.acceptCount] + rw [Finset.filter_eq_empty_iff.mpr (fun ch _ => fun ⟨h1, h2⟩ => hno ch h1 h2)] + exact Finset.card_empty + have hprob := hacc x hx + simp [NTM.acceptProb, hcount] at hprob; norm_num at hprob + Β· -- AcceptsInTime β†’ x ∈ L (contrapositive: x βˆ‰ L β†’ Β¬AcceptsInTime) + intro ⟨choices, hhalt_ch, hout_ch⟩; by_contra hx + have hzero : tm.acceptProb x (f x.length) = 0 := + le_antisymm (hrej x hx) (by unfold NTM.acceptProb; positivity) + have hcount : tm.acceptCount x (f x.length) = 0 := by + unfold NTM.acceptProb at hzero + have h2T : (0:β„š) < 2 ^ f x.length := by positivity + rw [div_eq_zero_iff] at hzero + cases hzero with + | inl h => exact_mod_cast h + | inr h => linarith + have hpos : 0 < tm.acceptCount x (f x.length) := by + unfold NTM.acceptCount + exact Finset.card_pos.mpr + ⟨choices, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hhalt_ch, hout_ch⟩⟩ + omega + +/-- **RP βŠ† NP**. -/ +theorem RP_subset_NP : RP βŠ† NP := + Set.iUnion_mono fun _ => RTIME_subset_NTIME _ + +/-- **DTIME βŠ† BPTIME**: every deterministic TM can be viewed as a PTM with + zero error. When the DTM accepts, all paths accept (prob = 1 β‰₯ 2/3). + When it rejects, no path accepts (prob = 0 ≀ 1/3). -/ +theorem DTIME_subset_BPTIME (T : β„• β†’ β„•) : DTIME T βŠ† BPTIME T := by + intro L ⟨k, tm, f, hdec, hbig⟩ + refine ⟨k, tm.toNTM, f, ?_, ?_, ?_, hbig⟩ + Β· -- AllPathsHaltIn: from toNTM_decidesInTime + exact (tm.toNTM_decidesInTime hdec).1 + Β· -- AcceptsWithProb L f (2/3): acceptProb β‰₯ 2/3 for x ∈ L + intro x hx + have ⟨c', t, hle, hreach, hhalt, hyes, _⟩ := hdec x + have htrace : βˆ€ ch, tm.toNTM.trace (f x.length) ch (tm.toNTM.initCfg x) = c' := + fun ch => tm.toNTM_trace_of_reachesIn hreach hhalt hle ch + -- acceptCount = 2^(f x.length) since all paths accept + have hcount : tm.toNTM.acceptCount x (f x.length) = 2 ^ f x.length := by + simp only [NTM.acceptCount] + have : (Finset.univ.filter fun (choices : Fin (f x.length) β†’ Bool) => + let c' := tm.toNTM.trace (f x.length) choices (tm.toNTM.initCfg x) + c'.state = tm.toNTM.qhalt ∧ c'.output.cells 1 = Ξ“.one) = Finset.univ := by + ext ch; simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [show (tm.toNTM.trace (f x.length) ch (tm.toNTM.initCfg x)) = c' from htrace ch] + exact ⟨fun _ => trivial, fun _ => ⟨hhalt, hyes hx⟩⟩ + rw [this, Finset.card_univ, Fintype.card_fun, Fintype.card_bool, Fintype.card_fin] + -- acceptProb = 1 + have hprob : tm.toNTM.acceptProb x (f x.length) = 1 := by + simp [NTM.acceptProb, hcount] + linarith + Β· -- RejectsWithProb L f (1/3): acceptProb ≀ 1/3 for x βˆ‰ L + intro x hx + have ⟨c', t, hle, hreach, hhalt, _, hno⟩ := hdec x + have htrace : βˆ€ ch, tm.toNTM.trace (f x.length) ch (tm.toNTM.initCfg x) = c' := + fun ch => tm.toNTM_trace_of_reachesIn hreach hhalt hle ch + -- acceptCount = 0 since no path accepts + have hcount : tm.toNTM.acceptCount x (f x.length) = 0 := by + simp only [NTM.acceptCount] + rw [Finset.filter_eq_empty_iff.mpr] + Β· exact Finset.card_empty + Β· intro ch _ + rw [show (tm.toNTM.trace (f x.length) ch (tm.toNTM.initCfg x)) = c' from htrace ch] + intro ⟨_, h2⟩ + have := hno hx; simp_all + simp [NTM.acceptProb, hcount] + +/-- **P βŠ† BPP**: every polynomial-time language is also in BPP. -/ +theorem P_subset_BPP : P βŠ† BPP := + Set.iUnion_mono fun _ => DTIME_subset_BPTIME _ + +/-- NTIME is monotone: if `T₁ =O Tβ‚‚`, then `NTIME T₁ βŠ† NTIME Tβ‚‚`. -/ +theorem NTIME_mono {T₁ Tβ‚‚ : β„• β†’ β„•} (h : T₁ =O Tβ‚‚) : NTIME T₁ βŠ† NTIME Tβ‚‚ := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm, f, hdec, hbig.trans h⟩ + +/-- DSPACE is monotone: if `S₁ =O Sβ‚‚`, then `DSPACE S₁ βŠ† DSPACE Sβ‚‚`. -/ +theorem DSPACE_mono {S₁ Sβ‚‚ : β„• β†’ β„•} (h : S₁ =O Sβ‚‚) : DSPACE S₁ βŠ† DSPACE Sβ‚‚ := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm, f, hdec, hbig.trans h⟩ + +/-- **NP βŠ† NEXP**: every nondeterministic polynomial-time language is also + nondeterministic exponential-time. -/ +theorem NP_subset_NEXP : NP βŠ† NEXP := + Set.iUnion_mono fun _ => NTIME_mono (BigO.of_le (fun _ => Nat.lt_two_pow_self.le)) + +/-- **EXP βŠ† NEXP**: every deterministic exponential-time language is also + nondeterministic exponential-time. -/ +theorem EXP_subset_NEXP : EXP βŠ† NEXP := + Set.iUnion_mono fun _ => DTIME_subset_NTIME _ + +/-- **BPTIME βŠ† PPTIME**: two-sided bounded error implies unbounded error, + since 2/3 > 1/2 and 1/3 < 1/2. -/ +theorem BPTIME_subset_PPTIME (T : β„• β†’ β„•) : BPTIME T βŠ† PPTIME T := by + intro L ⟨k, tm, f, hhalt, hacc, hrej, hbig⟩ + refine ⟨k, tm, f, hhalt, fun x => ⟨fun hx => ?_, fun hprob => ?_⟩, hbig⟩ + Β· -- x ∈ L β†’ acceptProb > 1/2: acceptProb β‰₯ 2/3 > 1/2 + have := hacc x hx; linarith + Β· -- acceptProb > 1/2 β†’ x ∈ L: contrapositive + by_contra hx + have := hrej x hx; linarith + +/-- **BPP βŠ† PP**. -/ +theorem BPP_subset_PP : BPP βŠ† PP := + Set.iUnion_mono fun _ => BPTIME_subset_PPTIME _ + +/-- **P is closed under complement**: if `L ∈ P` then `Lᢜ ∈ P`. -/ +theorem P_compl {L : Language} (h : L ∈ P) : Lᢜ ∈ P := by + obtain ⟨k, n_tapes, tm, f, hdec, hbig⟩ := Set.mem_iUnion.mp h + refine Set.mem_iUnion.mpr ⟨k + 1, n_tapes, tm.complementTM, fun n => 2 * f n + 4, + tm.complementTM_decidesInTime hdec, ?_⟩ + have hpow : f =O (Β· ^ (k + 1)) := hbig.trans (BigO.pow_le_pow_succ k) + exact BigO.add (BigO.const_mul_left 2 hpow) (BigO.const_le_pow 4 (k + 1)) + +/-- **DSPACE βŠ† NSPACE**: every language decidable by a DTM in space `O(S)` is also + decidable by an NTM in space `O(S)`, via the `TM.toNTM` embedding. -/ +theorem DSPACE_subset_NSPACE (S : β„• β†’ β„•) : DSPACE S βŠ† NSPACE S := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm.toNTM, f, tm.toNTM_decidesInSpace hdec, hbig⟩ + +/-- NSPACE is monotone: if `S₁ =O Sβ‚‚`, then `NSPACE S₁ βŠ† NSPACE Sβ‚‚`. -/ +theorem NSPACE_mono {S₁ Sβ‚‚ : β„• β†’ β„•} (h : S₁ =O Sβ‚‚) : NSPACE S₁ βŠ† NSPACE Sβ‚‚ := by + intro L ⟨k, tm, f, hdec, hbig⟩ + exact ⟨k, tm, f, hdec, hbig.trans h⟩ + +/-- **L βŠ† NL**: every deterministic log-space transducer language is also in NL. -/ +theorem L_subset_NL : L βŠ† NL := by + intro L ⟨k, tm, f, htrans, hdec, hbig⟩ + exact ⟨k, tm.toNTM, f, tm.toNTM_isTransducer htrans, tm.toNTM_decidesInSpace hdec, hbig⟩ + +/-- **ZPP βŠ† RP**: zero-error probabilistic βŠ† one-sided error. -/ +theorem ZPP_subset_RP : ZPP βŠ† RP := Set.inter_subset_left + +/-- **ZPP βŠ† coRP**. -/ +theorem ZPP_subset_coRP : ZPP βŠ† coRP := Set.inter_subset_right + +/-- **ZPP βŠ† NP** via `ZPP βŠ† RP βŠ† NP`. -/ +theorem ZPP_subset_NP : ZPP βŠ† NP := ZPP_subset_RP.trans RP_subset_NP + +/-- **RP βŠ† NEXP** via `RP βŠ† NP βŠ† NEXP`. -/ +theorem RP_subset_NEXP : RP βŠ† NEXP := RP_subset_NP.trans NP_subset_NEXP + +/-- **ZPP βŠ† NEXP** via `ZPP βŠ† NP βŠ† NEXP`. -/ +theorem ZPP_subset_NEXP : ZPP βŠ† NEXP := ZPP_subset_NP.trans NP_subset_NEXP + +/-- **DTIME βŠ† NSPACE** (composition of `DTIME βŠ† DSPACE` and `DSPACE βŠ† NSPACE`). -/ +theorem DTIME_subset_NSPACE (T : β„• β†’ β„•) : DTIME T βŠ† NSPACE T := + (DTIME_subset_DSPACE T).trans (DSPACE_subset_NSPACE T) + +/-- **P βŠ† NPSPACE** via `P βŠ† PSPACE βŠ† NPSPACE`. -/ +theorem P_subset_NPSPACE : P βŠ† NPSPACE := + Set.iUnion_mono fun _ => (DTIME_subset_DSPACE _).trans (DSPACE_subset_NSPACE _) + +/-- **P βŠ† NEXP** via `P βŠ† EXP βŠ† NEXP`. -/ +theorem P_subset_NEXP : P βŠ† NEXP := + P_subset_EXP.trans EXP_subset_NEXP + +/-- **P βŠ† PP** via `P βŠ† BPP βŠ† PP`. -/ +theorem P_subset_PP : P βŠ† PP := P_subset_BPP.trans BPP_subset_PP + +/-- **P is closed under union**: derived from `DTIME_union` and + polynomial-bound composition. -/ +theorem P_union {L₁ Lβ‚‚ : Language} (h₁ : L₁ ∈ P) (hβ‚‚ : Lβ‚‚ ∈ P) : L₁ βˆͺ Lβ‚‚ ∈ P := by + obtain ⟨k₁, hdtβ‚βŸ© := Set.mem_iUnion.mp h₁ + obtain ⟨kβ‚‚, hdtβ‚‚βŸ© := Set.mem_iUnion.mp hβ‚‚ + have hunion := DTIME_union hdt₁ hdtβ‚‚ + refine Set.mem_iUnion.mpr ⟨max k₁ kβ‚‚, DTIME_mono ?_ hunion⟩ + exact BigO.add + (BigO.pow_le_pow_right (Nat.le_max_left k₁ kβ‚‚)) + (BigO.pow_le_pow_right (Nat.le_max_right k₁ kβ‚‚)) + +/-- **P is closed under intersection**: via `L₁ ∩ Lβ‚‚ = (Lβ‚αΆœ βˆͺ Lβ‚‚αΆœ)ᢜ`. -/ +theorem P_inter {L₁ Lβ‚‚ : Language} (h₁ : L₁ ∈ P) (hβ‚‚ : Lβ‚‚ ∈ P) : L₁ ∩ Lβ‚‚ ∈ P := by + have hcomp : (Lβ‚αΆœ βˆͺ Lβ‚‚αΆœ)ᢜ ∈ P := P_compl (P_union (P_compl h₁) (P_compl hβ‚‚)) + have heq : (Lβ‚αΆœ βˆͺ Lβ‚‚αΆœ)ᢜ = L₁ ∩ Lβ‚‚ := by + ext x; simp + rwa [heq] at hcomp + +/-- **P is closed under set difference**: `L₁ \ Lβ‚‚ = L₁ ∩ Lβ‚‚αΆœ`. -/ +theorem P_diff {L₁ Lβ‚‚ : Language} (h₁ : L₁ ∈ P) (hβ‚‚ : Lβ‚‚ ∈ P) : L₁ \ Lβ‚‚ ∈ P := by + rw [Set.diff_eq] + exact P_inter h₁ (P_compl hβ‚‚) + +/-- **P is closed under symmetric difference**: + `L₁ β–³ Lβ‚‚ = (L₁ \ Lβ‚‚) βˆͺ (Lβ‚‚ \ L₁)`. Together with `P_compl`/`P_union`/`P_inter` + this makes `P` a Boolean subalgebra of the languages. -/ +theorem P_symmDiff {L₁ Lβ‚‚ : Language} (h₁ : L₁ ∈ P) (hβ‚‚ : Lβ‚‚ ∈ P) : + (L₁ \ Lβ‚‚) βˆͺ (Lβ‚‚ \ L₁) ∈ P := + P_union (P_diff h₁ hβ‚‚) (P_diff hβ‚‚ h₁) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Exponential.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Exponential.lean new file mode 100644 index 0000000000..a3ba40ed44 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Exponential.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time + +/-! +# Exponential time complexity classes + +This file defines **EXP** and **NEXP**, the exponential-time analogues of P +and NP respectively. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **EXP** is the class of languages decidable by a deterministic TM in + exponential time: `EXP = ⋃_k DTIME(2^(n^k))`. -/ +def EXP : Set Language := + ⋃ k : β„•, DTIME (fun n => 2 ^ n ^ k) + +/-- **NEXP** is the class of languages decidable by a nondeterministic TM in + exponential time: `NEXP = ⋃_k NTIME(2^(n^k))`. -/ +def NEXP : Set Language := + ⋃ k : β„•, NTIME (fun n => 2 ^ n ^ k) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/FNP.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/FNP.lean new file mode 100644 index 0000000000..17dce70bca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/FNP.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP.Defs + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/FNP/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/FNP/Defs.lean new file mode 100644 index 0000000000..cb98389931 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/FNP/Defs.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs + +/-! +# FNP and TFNP β€” Definitions + +Core definitions for the function/search complexity classes **FNP** and **TFNP**, +and the `OrRelation` combinator used to construct TFNP problems from +NP ∩ coNP witness pairs. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **FNP** is the class of search problems defined by NP relations: binary + relations that are polynomially balanced and decidable in polynomial time. + A relation `R` is in FNP if witnesses have poly-bounded length and the + pair language `{pair(x, y) | R x y}` is in P. -/ +def FNP : Set (List Bool β†’ List Bool β†’ Prop) := + {R | PolyBalanced R ∧ pairLang R ∈ P} + +/-- **TFNP** is the class of total FNP search problems: every instance has at + least one witness. -/ +def TFNP : Set (List Bool β†’ List Bool β†’ Prop) := + {R ∈ FNP | βˆ€ x, βˆƒ y, R x y} + +/-- Combine two witness relations by disjunction. Used to construct TFNP + problems from NP ∩ coNP witness pairs: the combined relation accepts any + witness valid for either component. -/ +def OrRelation (R₁ Rβ‚‚ : List Bool β†’ List Bool β†’ Prop) : + List Bool β†’ List Bool β†’ Prop := + fun x y => R₁ x y ∨ Rβ‚‚ x y + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/L.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/L.lean new file mode 100644 index 0000000000..2f3ee640d7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/L.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time +public import LeanPool.BeyondBethe.Complexitylib.Classes.Pairing + +/-! +# Log-space transducer classes + +This file defines the log-space complexity classes **L**, **NL**, **coNL**, +**FL**, and the search problem classes **FNL**, **TFNL**. + +These classes use the library's honest auxiliary-space convention: work-tape +travel is bounded, excess input-head travel is charged, and language deciders +also charge two-way output-tape travel beyond the verdict cell. They additionally +use the *transducer* discipline (`IsTransducer`), under which the output head +never moves left. `TM.ComputesInSpace` includes this discipline internally so +function output may have unbounded length without becoming read-write workspace. +-/ + + +@[expose] public section + +namespace Complexity + + +/-- **L** (LOGSPACE) is the class of languages decidable by a deterministic + log-space transducer: a DTM with `O(log n)` auxiliary space whose output + tape head never moves left. The transducer constraint prevents the output + tape from being used as extra workspace beyond the space bound. -/ +def L : Set Language := + {Lang | βˆƒ (k : β„•) (tm : TM k) (f : β„• β†’ β„•), + tm.IsTransducer ∧ tm.DecidesInSpace Lang f ∧ f =O (fun n => Nat.log 2 n)} + +/-- **NL** is the class of languages decidable by a nondeterministic log-space + transducer: an NTM with `O(log n)` auxiliary space whose output tape head + never moves left. -/ +def NL : Set Language := + {Lang | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.IsTransducer ∧ tm.DecidesInSpace Lang f ∧ f =O (fun n => Nat.log 2 n)} + +/-- **coNL** is the class of languages whose complements are in NL. + By the Immerman-SzelepcsΓ©nyi theorem coNL = NL, but this is nontrivial. -/ +def coNL : Set Language := complClass NL + +/-- **FL** is the class of functions computable by a deterministic log-space + transducer: a DTM with `O(log n)` auxiliary space whose output tape head + never moves left. -/ +def FL : Set (List Bool β†’ List Bool) := + {f | βˆƒ (k : β„•) (tm : TM k) (S : β„• β†’ β„•), + tm.ComputesInSpace f S ∧ S =O (fun n => Nat.log 2 n)} + +/-- **FNL** is the class of search problems with log-space verifiable relations: + binary relations that are polynomially balanced (witnesses have poly-bounded + length) and whose pair language is decidable in L (deterministic log space). + + This parallels FNP, which uses P (deterministic poly time) for verification. -/ +def FNL : Set (List Bool β†’ List Bool β†’ Prop) := + {R | PolyBalanced R ∧ pairLang R ∈ L} + +/-- **TFNL** is the class of total FNL search problems: every instance has at + least one witness. -/ +def TFNL : Set (List Bool β†’ List Bool β†’ Prop) := + {R ∈ FNL | βˆ€ x, βˆƒ y, R x y} + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/NP.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/NP.lean new file mode 100644 index 0000000000..d7fdac9a16 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/NP.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time +public import LeanPool.BeyondBethe.Complexitylib.Classes.Space + +/-! +# NP, coNP, and NPSPACE + +This file defines **NP** (nondeterministic polynomial time), **coNP**, and +**NPSPACE** (nondeterministic polynomial space) in terms of the base classes +`NTIME` and `NSPACE`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **NP** is the class of languages decidable by a nondeterministic TM in + polynomial time: `NP = ⋃_k NTIME(n^k)`. -/ +def NP : Set Language := + ⋃ k : β„•, NTIME (Β· ^ k) + +/-- **coNP** is the class of languages whose complements are in NP. -/ +def coNP : Set Language := complClass NP + +/-- **NPSPACE** is the class of languages decidable by a nondeterministic TM + using polynomial auxiliary space: `NPSPACE = ⋃_k NSPACE(n^k)`. -/ +def NPSPACE : Set Language := + ⋃ k : β„•, NSPACE (Β· ^ k) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/NP/Witness.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/NP/Witness.lean new file mode 100644 index 0000000000..f3ccb845cb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/NP/Witness.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP +public import LeanPool.BeyondBethe.Complexitylib.Classes.FNP.Defs + +/-! +# NP witness characterization + +This file states and (up to a single TM-engineering lemma) proves the +textbook characterization of `NP` via FNP witness relations: + +> A language `L` is in `NP` iff there is an FNP relation `R` such that +> `x ∈ L ↔ βˆƒ y, R x y`. + +The forward direction (`NP βŠ† witness form`) is a *computation-path* witness +argument and is left for a later pass. + +The reverse direction β€” **the FNP β‡’ NP bridge** used by SAT ∈ NP β€” is +captured here by `mem_NP_of_FNP_witness`, parameterized by the single +TM-engineering construction interface `WitnessNTMConstruction`: build the +nondeterministic "guess-and-verify" machine from a deterministic verifier +of `pairLang R`. Everything above that construction β€” unpacking FNP, +computing polynomial bounds, and packaging the result as membership in +`NP` β€” is proved here unconditionally. + +## Proof strategy for `WitnessNTMConstruction` + +Given: +- a DTM `M` deciding `pairLang R` in polynomial time, and +- a polynomial `p` bounding witness length (`PolyBalanced R`), + +construct an NTM `N` that, on input `x`: + +1. **Guess phase.** Reads `p.eval |x|` nondeterministic bits and writes them + onto a dedicated work tape as a guessed witness `y`. +2. **Pair construction.** Copies `pair(x, y)` onto another work tape using + `x` from the input tape and the guessed `y` from the witness tape. +3. **Verification.** Simulates `M` on the constructed pair (reading from + the work tape that holds `pair(x, y)` instead of the input tape). + +The total running time is polynomial: `O(p(n) + n + T(2n + p(n) + 2))` +where `T(n) = n^c` bounds `M`. + +The construction is mechanical but substantial β€” analogous in size to the +existing `unionTM`/`seqTM` combinators β€” and is deferred to a later pass. +All downstream consequences (including `SAT ∈ NP` conditional on the SAT +verifier being in P) rest only on that single lemma. +-/ + + +@[expose] public section + +namespace Complexity + + +namespace NP + +/-- The witness language of a relation `R` β€” the set of inputs `x` that + admit some witness. Isolated as a definition so the statement of + `mem_NP_of_FNP_witness` reads cleanly. -/ +def witnessLang (R : List Bool β†’ List Bool β†’ Prop) : Language := + {x | βˆƒ y, R x y} + +/-- Membership in `witnessLang R` unfolds to the existence of a witness: + `x ∈ witnessLang R ↔ βˆƒ y, R x y`. -/ +@[simp] theorem mem_witnessLang {R : List Bool β†’ List Bool β†’ Prop} {x : List Bool} : + x ∈ witnessLang R ↔ βˆƒ y, R x y := Iff.rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- The core TM-engineering construction interface +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Guess-and-verify NTM construction interface.** Given a DTM `M` deciding + `pairLang R` within a time bound `T(n) ≀ O(n^c)` and a polynomial `p` + bounding witness length, there exists an NTM deciding + `witnessLang R = {x | βˆƒ y, R x y}` in polynomial time. + + The construction is the standard Arora-Barak guess-and-verify: + nondeterministically write a witness of length `≀ p(|x|)` onto a work + tape, build `pair(x, y)` on another work tape, then simulate `M`. + + This is isolated as a named proposition so results can state precisely + when they rely on the still-to-be-built machine construction, instead of + importing an unproved theorem. + + ## Supporting utilities + When implementing this construction, the following lemmas from + `Complexitylib.Asymptotics` will be useful for packaging the running-time + bound of the constructed NTM: + - `BigO.pow_polynomial_bound` β€” turn the hypothesis `f =O (Β·^c)` into + an explicit `Polynomial β„•` bound on `f`. + - `BigO.of_polynomial_bound` β€” turn the computed polynomial bound on + the constructed NTM's running time back into `g =O (Β·^d)`. + The `pair_length` simp lemma in `Complexitylib.Classes.Pairing` gives + `|pair x y| = 2Β·|x| + 2 + |y|`, needed when substituting the simulated + verifier's input length. -/ +def WitnessNTMConstruction : Prop := + βˆ€ {R : List Bool β†’ List Bool β†’ Prop} + {p : Polynomial β„•} {c k : β„•} + {M : TM k} {f : β„• β†’ β„•}, + (βˆ€ x y, R x y β†’ y.length ≀ p.eval x.length) β†’ + M.DecidesInTime (pairLang R) f β†’ + f =O (Β· ^ c) β†’ + βˆƒ (k' d : β„•) (N : NTM k') (g : β„• β†’ β„•), + N.DecidesInTime (witnessLang R) g ∧ g =O (Β· ^ d) + +-- ════════════════════════════════════════════════════════════════════════ +-- Main theorem: FNP witness relations put L in NP +-- ════════════════════════════════════════════════════════════════════════ + +/-- **FNP β‡’ NP via witnesses.** If the generic guess-and-verify construction + has been implemented, `R ∈ FNP`, and `x ∈ L ↔ βˆƒ y, R x y`, then + `L ∈ NP`. Proof: unpack FNP to get a polynomial-time DTM verifier + `M` for `pairLang R` and a polynomial witness-length bound, apply the + construction to build the guess-and-verify NTM, and package the result as + NP membership. -/ +theorem mem_NP_of_FNP_witness + (hwitness : WitnessNTMConstruction) + {R : List Bool β†’ List Bool β†’ Prop} {L : Language} + (hR : R ∈ FNP) + (hchar : βˆ€ x, x ∈ L ↔ βˆƒ y, R x y) : + L ∈ NP := by + obtain ⟨hPB, hPairP⟩ := hR + -- Unpack `pairLang R ∈ P` to a DTM and a poly time bound. + obtain ⟨c, k, M, f, hM, hfO⟩ := Set.mem_iUnion.mp hPairP + -- Unpack `PolyBalanced R` to a polynomial witness-length bound. + obtain ⟨p, hp⟩ := hPB + -- Build the NTM via the core construction. + obtain ⟨k', d, N, g, hN, hgO⟩ := hwitness hp hM hfO + -- `L = witnessLang R` up to set extensionality. + have hLeq : L = witnessLang R := Set.ext fun x => by + simpa [witnessLang] using hchar x + -- Conclude. + rw [hLeq] + exact Set.mem_iUnion.mpr ⟨d, k', N, g, hN, hgO⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Immediate corollary: FNP ⇔ NP-witness (the "reverse direction" only) +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Restatement in terms of `witnessLang`.** If `R ∈ FNP`, then + `witnessLang R ∈ NP`. This is the useful form for applying to + concrete relations like `Witness`. -/ +theorem witnessLang_mem_NP_of_FNP + (hwitness : WitnessNTMConstruction) + {R : List Bool β†’ List Bool β†’ Prop} (hR : R ∈ FNP) : + witnessLang R ∈ NP := + mem_NP_of_FNP_witness hwitness hR fun _ => Iff.rfl + +end NP + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P.lean new file mode 100644 index 0000000000..021455d465 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Preimage +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyOutput + +/-! +# P β€” surface layer + +This file aggregates the definitions and theorems for P, FP, and PSPACE. + +## Definitions (from `P/Defs.lean`) + +- `P` β€” polynomial time: `⋃ k, DTIME(n^k)` +- `FP` β€” functions computable in polynomial time +- `PSPACE` β€” polynomial space: `⋃ k, DSPACE(n^k)` + +## Theorems + +- `DTIME_union` β€” DTIME is closed under union (AB Claim 1.5) +- `id_mem_FP` β€” the identity function is computable in linear time +- `mem_P_iff_decidesInTime_polynomial` β€” polynomial-evaluation normal form for `P` +- `mem_FP_iff_computesInTime_polynomial` β€” polynomial-evaluation normal form +- `mem_FP_comp` β€” `FP` is closed under function composition +- `mem_FP_pairWithInput` β€” an `FP` result can be paired with its original input +- `mem_P_preimage` β€” `P` is closed under preimages of functions in `FP` +- `unaryLength_mem_FP` β€” materializing the unary input length belongs to `FP` +- `ite_mem_finset_mem_FP` β€” functions supported on a finite set belong to `FP` +- `CobhamFP_eq_FP` β€” Cobham's machine-independent characterization of `FP` +-/ + + +@[expose] public section + +namespace Complexity + + +/-- **DTIME is closed under union** (AB Claim 1.5): if `L₁ ∈ DTIME(T₁)` and + `Lβ‚‚ ∈ DTIME(Tβ‚‚)`, then `L₁ βˆͺ Lβ‚‚ ∈ DTIME(T₁ + Tβ‚‚)`. -/ +theorem DTIME_union {T₁ Tβ‚‚ : β„• β†’ β„•} {L₁ Lβ‚‚ : Language} + (h₁ : L₁ ∈ DTIME T₁) (hβ‚‚ : Lβ‚‚ ∈ DTIME Tβ‚‚) : + L₁ βˆͺ Lβ‚‚ ∈ DTIME (fun n => T₁ n + Tβ‚‚ n) := by + obtain ⟨k₁, tm₁, f₁, hd₁, hoβ‚βŸ© := h₁ + obtain ⟨kβ‚‚, tmβ‚‚, fβ‚‚, hdβ‚‚, hoβ‚‚βŸ© := hβ‚‚ + exact ⟨k₁ + 1 + kβ‚‚, TM.unionTM tm₁ tmβ‚‚, fun n => 10 * f₁ n + fβ‚‚ n, + TM.unionTM_decidesInTime hd₁ hdβ‚‚, + bigO_union_bound ho₁ hoβ‚‚βŸ© + +/-- **The identity function belongs to `FP`.** The executable + `copyInputToOutputTM` copies the input to the output in `n + 2` steps, and + this concrete bound is linear. -/ +theorem id_mem_FP : id ∈ FP := by + refine ⟨1, 0, TM.copyInputToOutputTM, (fun n => n + 2), ?_, ?_⟩ + Β· exact TM.copyInputToOutputTM_computesInTime 0 + Β· have hn : (fun n : β„• => n) =O (Β· ^ 1) := by + simpa [pow_one] using BigO.refl (fun n : β„• => n) + exact BigO.add hn (BigO.const_le_pow 2 1) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham.lean new file mode 100644 index 0000000000..d968b1b079 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal + +/-! +# Cobham's characterization of FP β€” surface layer + +Cobham's theorem (1965): the machine-independent function algebra +`Complexity.Cobham` of `Complexitylib.Classes.P.Cobham.Defs` carves out exactly +the polynomial-time computable string functions. + +## Main results + +- `Cobham.cobham_iff_FPn` β€” the characterization at every fixed arity +- `CobhamFP_subset_FP` β€” every function of the algebra is polynomial-time +- `FP_subset_CobhamFP` β€” every polynomial-time function is in the algebra +- `CobhamFP_eq_FP` β€” **Cobham's theorem**, the two directions together + +## How the two directions are proved + +Both halves live in `Complexitylib.Classes.P.Cobham.Internal`. + +*Soundness* is the induction `Cobham f β†’ FPn f` over the six constructors, where +`Cobham.FPn` lifts `FP` to argument vectors through the tuple encoding +`Cobham.encodeVec`. Four constructors are bespoke transducers +(`Cobham.cons_mem_FP`, `fstBlock_mem_FP`, `sndBlock_mem_FP`, `reorder_mem_FP`, +`mulLenFn_mem_FP`); the fifth, `boundedRec`, is a loop: recursion on notation is +a fold (`Cobham.recFold_eq_recNotation`), Cobham's side condition makes its width +clamp vacuous (`Cobham.recFoldClamp_eq_recFold`), and `Cobham.iterate_mem_FP` +runs the clamped step once per bit under a polynomial ruler. + +*Completeness* simulates a polynomial-time machine inside the algebra. A whole +configuration is one block-aligned bitstring with each tape split at its head, so +a head move is a two-bit shift (`Cobham.cfgCode`); the transition function is the +finite table `Cobham.stepFn`; the run is `Cobham.iterFn` under a clock built from +`smash` (`Cobham.exists_pow_clock`); and the output is read off the output tape +after a rewind (`Cobham.rewindFn`). The assembly is `Cobham.simFn_eq`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The canonical fixed-arity tuple encoding is itself a member of Cobham's +algebra. -/ +theorem encodeVec_mem {n : β„•} : Cobham (@encodeVec n) := + encodeVec_mem_internal + +/-- Multi-arity completeness: every function that is polynomial-time on encoded +argument vectors belongs to Cobham's algebra. -/ +theorem FPn_imp_cobham {n : β„•} {f : (Fin n β†’ List Bool) β†’ List Bool} : + FPn f β†’ Cobham f := + FPn_imp_cobham_internal + +/-- **Cobham's theorem at every fixed arity.** A function belongs to Cobham's +algebra exactly when it is polynomial-time on the canonical encoded vectors. -/ +theorem cobham_iff_FPn {n : β„•} {f : (Fin n β†’ List Bool) β†’ List Bool} : + Cobham f ↔ FPn f := + ⟨cobham_imp_FPn, FPn_imp_cobham⟩ + +end Cobham + +/-- Cobham's algebra is sound for polynomial time: every function of the (unary +fragment of the) algebra is computable by a deterministic TM in polynomial time. + +The multi-arity soundness induction `Cobham.cobham_imp_FPn`, specialized to +arity one. -/ +theorem CobhamFP_subset_FP : CobhamFP βŠ† FP := + Cobham.CobhamFP_subset_FP_of_FPn + +/-- Cobham's algebra is complete for polynomial time: every polynomial-time +computable function belongs to the algebra. + +Proved by simulating the machine inside the algebra (`Cobham.simFn_eq`). -/ +theorem FP_subset_CobhamFP : FP βŠ† CobhamFP := + Cobham.FP_subset_CobhamFP_internal + +/-- **Cobham's theorem** (1965): the machine-independent function algebra of +`Complexitylib.Classes.P.Cobham.Defs` characterizes exactly the polynomial-time +computable string functions. -/ +theorem CobhamFP_eq_FP : CobhamFP = FP := + Set.Subset.antisymm CobhamFP_subset_FP FP_subset_CobhamFP + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Defs.lean new file mode 100644 index 0000000000..9378acc65a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Defs.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.Fin.Tuple.Basic + +/-! +# Cobham's characterization of FP β€” definitions + +This file defines Cobham's machine-independent characterization of the polynomial-time +computable functions on bitstrings (Cobham, *The intrinsic computational difficulty of +functions*, 1965): the smallest class of functions `(Fin n β†’ List Bool) β†’ List Bool` +containing the projections, the empty string, the two bit successors, and the smash +function, and closed under composition and **limited recursion on notation**. + +Bitstrings are LSB-first: in the recursion on notation, the head of the list is the +least-significant (innermost) bit, so the bit successors *prepend* a bit +(`x ↦ b :: x`, the string analogue of `n ↦ 2Β·n + bit`), and recursion on notation +peels bits off the head. + +The functions are multi-arity (indexed by `Fin n` argument vectors) because limited +recursion on notation inherently produces functions of higher arity; the unary fragment +is collected in `CobhamFP`, which `Complexitylib.Classes.P.Cobham` proves equal to the +machine class `FP`. + +## Main definitions + +- `Complexity.smash` β€” binary-word smash: `1^(|x| Β· |y|)` +- `Complexity.recNotation` β€” the recursion-on-notation combinator +- `Complexity.Cobham` β€” the inductive predicate carving out Cobham's function algebra +- `Complexity.CobhamFP` β€” the unary fragment, as a set of string functions + +## Design notes + +The bound in `Cobham.boundedRec` follows Cobham's original formulation: the recursively +defined function must be *length-bounded by another function of the class* (rather than +by an external polynomial). Together with `smash` and the successors this realizes +exactly the polynomial length bounds, which is what makes the class no larger than `FP`; +dropping the bound would admit iterated doubling and hence exponential growth. + +The string toolkit the proof is written in β€” bit dispatch, flags, fixed-width blocks +β€” is not part of this statement and lives in +`Complexitylib.Classes.P.Cobham.Internal.Blocks`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **Cobham's smash function** in the binary-word presentation: +`smash x y = 1^(|x| Β· |y|)`. This is the length-arithmetic engine of the class: +composing `smash` with the bit successors and projections realizes every polynomial +length bound, which is what lets `Cobham.boundedRec` bound recursions by a function of +the class itself. + +This all-one word is the customary string analogue of Cobham's original +number-theoretic smash `x # y = 2^(|x|Β·|y|)`. -/ +def smash (x y : List Bool) : List Bool := + List.replicate (x.length * y.length) true + +@[simp] theorem smash_length (x y : List Bool) : + (smash x y).length = x.length * y.length := by + simp [smash] + + +/-- **Recursion on notation**: the string analogue of primitive recursion, recursing on +the bit structure of the first argument. + +`recNotation g hβ‚€ h₁ x v` computes `g v` when `x` is empty, and on `b :: x` applies the +step function selected by the bit `b` to the argument vector consisting of the tail +`x`, the recursive value on the tail, and the parameters `v`. -/ +def recNotation {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) : + List Bool β†’ (Fin n β†’ List Bool) β†’ List Bool + | [], v => g v + | b :: x, v => + (bif b then h₁ else hβ‚€) (Fin.cons x (Fin.cons (recNotation g hβ‚€ h₁ x v) v)) + +@[simp] theorem recNotation_nil {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) (v : Fin n β†’ List Bool) : + recNotation g hβ‚€ h₁ [] v = g v := rfl + +@[simp] theorem recNotation_cons {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) (b : Bool) (x : List Bool) + (v : Fin n β†’ List Bool) : + recNotation g hβ‚€ h₁ (b :: x) v = + (bif b then h₁ else hβ‚€) (Fin.cons x (Fin.cons (recNotation g hβ‚€ h₁ x v) v)) := rfl + +/-- **Cobham's function algebra**: the smallest class of bitstring functions containing +the projections, the empty string, the bit successors `x ↦ b :: x`, and `smash`, and +closed under composition and limited recursion on notation. + +In `boundedRec`, the recursion is *limited*: the result must be length-bounded, +uniformly in the arguments, by a function `j` already in the class. This is the +polynomial-growth leash that pins the class to exactly `FP` +(see `Complexitylib.Classes.P.Cobham`). -/ +inductive Cobham : βˆ€ {n : β„•}, ((Fin n β†’ List Bool) β†’ List Bool) β†’ Prop + /-- Every projection is in the class. -/ + | proj {n : β„•} (i : Fin n) : Cobham fun v => v i + /-- The empty-string constant (at every arity) is in the class. -/ + | empty {n : β„•} : Cobham fun _ : Fin n β†’ List Bool => [] + /-- The bit successors `x ↦ b :: x` (the string analogue of `n ↦ 2Β·n + b`) are in + the class. -/ + | bit (b : Bool) : Cobham fun v : Fin 1 β†’ List Bool => b :: v 0 + /-- The smash function is in the class. -/ + | smash : Cobham fun v : Fin 2 β†’ List Bool => smash (v 0) (v 1) + /-- The class is closed under composition. -/ + | comp {m n : β„•} {f : (Fin m β†’ List Bool) β†’ List Bool} + {gs : Fin m β†’ (Fin n β†’ List Bool) β†’ List Bool} : + Cobham f β†’ (βˆ€ i, Cobham (gs i)) β†’ Cobham fun v => f fun i => gs i v + /-- The class is closed under **limited recursion on notation**: recursion on the bit + structure of the first argument, provided the result is length-bounded by a function + `j` of the class. -/ + | boundedRec {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} + {hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool} + {j : (Fin (n + 1) β†’ List Bool) β†’ List Bool} : + Cobham g β†’ Cobham hβ‚€ β†’ Cobham h₁ β†’ Cobham j β†’ + (βˆ€ x v, (recNotation g hβ‚€ h₁ x v).length ≀ (j (Fin.cons x v)).length) β†’ + Cobham fun v : Fin (n + 1) β†’ List Bool => recNotation g hβ‚€ h₁ (v 0) (Fin.tail v) + +/-- The unary fragment of Cobham's function algebra, as a class of string functions. +`Complexitylib.Classes.P.Cobham` proves `CobhamFP = FP`: this machine-independent +algebra carves out exactly the polynomial-time computable functions. -/ +def CobhamFP : Set (List Bool β†’ List Bool) := + {f | Cobham fun v : Fin 1 β†’ List Bool => f (v 0)} + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal.lean new file mode 100644 index 0000000000..03cb4562da --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal.lean @@ -0,0 +1,1142 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Cat +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reorder +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Simulate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Iterate +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.TakeLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Reverse +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.MulLen +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Composition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.HeadFlag +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput + +/-! +# Cobham's characterization of FP β€” proof internals + +The assembly of `CobhamFP = FP` (`Complexitylib.Classes.P.Cobham`). Not meant +for human review of the mathematics β€” the surface file carries the auditable +statements; the type checker carries this. + +The machines are in sibling modules (`Internal.BlockScan`, `Internal.Cat`, +`Internal.ConsBit`, `Internal.Reorder`, `Internal.MulLen`, `Internal.Iterate`), +the algebra toolkit in `Internal.Algebra`, and the interpreter of the +completeness direction in `Internal.Encoding`, `Internal.StepAlgebra`, +`Internal.Extract` and `Internal.Simulate`. What remains here is the soundness +induction and the `boundedRec` loop. + +## Contents + +- the six constructor cases `fpn_empty`, `fpn_proj`, `fpn_bit`, `fpn_smash`, + `fpn_comp`, `fpn_boundedRec`, and the induction `cobham_imp_FPn` over them; +- the `FP` closure lemmas they need: `pairFn_mem_FP`, `appendFn_mem_FP`, + `selectHeadFn_mem_FP` (branching on a bit, via `Complexity.headFlag`), + `takeLenFn_mem_FP`, `assembleVec_mem_FP`; +- the `boundedRec` loop: `recNotation_eq_foldr`, `recFold_eq_recNotation`, + `recFoldClamp_eq_recFold`, `loopStep_iterate` and `recFoldClamp_mem_FP`, on top + of `iterate_mem_FP`; +- the rulers `exists_ruler` and `exists_exact_ruler` that carry the loop's width + clamp as data. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## The canonical tuple encoding is in the algebra -/ + +/-- The nested tuple encoding is a Cobham function at every fixed arity. -/ +theorem encodeVec_mem_internal {n : β„•} : Cobham (@encodeVec n) := by + induction n with + | zero => + exact Cobham.empty.of_eq fun v => by simp + | succ n ih => + have htail : Cobham fun v : Fin (n + 1) β†’ List Bool => encodeVec (Fin.tail v) := + (Cobham.comp ih fun i : Fin n => Cobham.proj i.succ).of_eq fun v => rfl + exact (compβ‚‚ pairing htail (Cobham.proj 0)).of_eq fun v => by + rw [encodeVec_succ] + rfl + +/-! ## Soundness: `Cobham f β†’ FPn f`, constructor by constructor -/ + +/-- `empty` case: the constant empty function is `FPn` at every arity, witnessed +by `const_nil_mem_FP`. -/ +theorem fpn_empty {n : β„•} : FPn (fun _ : Fin n β†’ List Bool => ([] : List Bool)) := + ⟨fun _ => [], const_nil_mem_FP, fun _ => rfl⟩ + +/-- `proj` case: extracting the `i`-th component of an encoded vector is `FP`. + +The extraction is `sndBlock` after `i`-fold `fstBlock`: peel `i` leading blocks to +reach the encoding of components `i, i+1, …`, then read its head with `sndBlock`. +Proved here by induction on the arity; each atomic step is `FP` +(`fstBlock_mem_FP`, `sndBlock_mem_FP`) and `FP` is closed under composition +(`mem_FP_comp`), so only those two machine lemmas remain open. -/ +theorem fpn_proj {n : β„•} (i : Fin n) : FPn (fun v : Fin n β†’ List Bool => v i) := by + induction n with + | zero => exact i.elim0 + | succ n ih => + induction i using Fin.cases with + | zero => + exact ⟨sndBlock, sndBlock_mem_FP, fun v => sndBlock_encodeVec_succ v⟩ + | succ j => + obtain ⟨g, hg, hgf⟩ := ih j + refine ⟨g ∘ fstBlock, mem_FP_comp fstBlock_mem_FP hg, fun v => ?_⟩ + show g (fstBlock (encodeVec v)) = v j.succ + rw [fstBlock_encodeVec_succ, hgf] + rfl + +/-- `bit` case: prepending a fixed bit is `FPn` at arity one. On the arity-one +encoding `encodeVec ![x] = pair [] x`, the head component `x` is `sndBlock`, so the +witness is `(b :: Β·) ∘ sndBlock`; both factors are `FP`. -/ +theorem fpn_bit (b : Bool) : + FPn (fun v : Fin 1 β†’ List Bool => b :: v 0) := by + refine ⟨(fun x => b :: x) ∘ sndBlock, + mem_FP_comp sndBlock_mem_FP (cons_mem_FP b), fun v => ?_⟩ + show b :: sndBlock (encodeVec v) = b :: v 0 + rw [sndBlock_encodeVec_succ] + +/-- Pairing two `FP` functions of the same input is `FP`. + +Built without a two-output machine: `mem_FP_pairWithInput` gives the nested triple +`z ↦ pair (a z) (pair (b z) z)` (pairing each computed value against the raw +input, then again), and the self-contained `reorder` drops the trailing input +copy to leave `pair (a z) (b z)`. This is what lets `fpn_comp` avoid a bespoke +tuple-assembly machine. -/ +theorem pairFn_mem_FP {a b : List Bool β†’ List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => pair (a z) (b z)) ∈ FP := by + have h1 : (fun z => pair (b z) z) ∈ FP := mem_FP_pairWithInput hb + have h2 : (fun w => pair (a (sndBlock w)) w) ∈ FP := + mem_FP_pairWithInput (mem_FP_comp sndBlock_mem_FP ha) + have h12 := mem_FP_comp h1 h2 + have heq : ((fun w => pair (a (sndBlock w)) w) ∘ fun z => pair (b z) z) + = fun z => pair (a z) (pair (b z) z) := by + funext z; simp [Function.comp, sndBlock_pair] + rw [heq] at h12 + have hr := mem_FP_comp h12 reorder_mem_FP + have heq2 : (reorder ∘ fun z => pair (a z) (pair (b z) z)) + = fun z => pair (a z) (b z) := by + funext z; simp [Function.comp, reorder_pair_pair] + rwa [heq2] at hr + +/-- **`FP` is closed under concatenation.** -/ +theorem appendFn_mem_FP {a b : List Bool β†’ List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => a z ++ b z) ∈ FP := by + have h := mem_FP_comp (pairFn_mem_FP ha hb) catBlocks_mem_FP + have heq : (catBlocks ∘ fun z => pair (a z) (b z)) = fun z => a z ++ b z := by + funext z + simp [Function.comp] + rwa [heq] at h + +/-- Emitting `|a z| Β· |b z|` copies of `false` is `FP` when `a, b` are. This +zero-filled ruler is an internal length-arithmetic helper, not Cobham's public +all-one smash. It is built as the self-contained `mulUnpair` (see +`Complexitylib.Classes.P.Cobham.Internal.MulLen`) after `pairFn a b`. -/ +theorem mulLenFn_mem_FP {a b : List Bool β†’ List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => List.replicate ((a z).length * (b z).length) false) ∈ FP := by + have hc := mem_FP_comp (pairFn_mem_FP ha hb) mulUnpair_mem_FP + have heq : (mulUnpair ∘ fun z => pair (a z) (b z)) + = fun z => List.replicate ((a z).length * (b z).length) false := by + funext z; simp [Function.comp, mulUnpair_pair] + rwa [heq] at hc + +/-- Truncating one `FP` value to another's length. -/ +theorem takeLenFn_mem_FP {a b : List Bool β†’ List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => (b z).take (a z).length) ∈ FP := by + have hc := mem_FP_comp (pairFn_mem_FP ha hb) takeLen_mem_FP + have heq : (takeLen ∘ fun z => pair (a z) (b z)) + = fun z => (b z).take (a z).length := by + funext z; simp [Function.comp, takeLen_pair] + rwa [heq] at hc + +/-- Select `x` or `y` according to the leading bit of `s`; nothing when `s` is +empty. This is the only shape of value-dependent branching the algebra's loop +needs, and `Complexity.headFlag` is what makes it expressible. -/ +def selectHead (s x y : List Bool) : List Bool := + if s.head? = some true then x else if s.head? = some false then y else [] + +/-- **Selection is masking.** Exactly one of the two masks is full width, so the +concatenation returns exactly one branch. -/ +theorem selectHead_eq (s x y : List Bool) : + selectHead s x y = x.take ((headFlag true s).length * x.length) + ++ y.take ((headFlag false s).length * y.length) := by + rw [selectHead, headFlag, headFlag] + rcases hs : s.head? with _ | a + Β· simp + Β· cases a <;> simp + +/-- **Selecting between two `FP` values by a bit is `FP`.** -/ +theorem selectHeadFn_mem_FP {f a b : List Bool β†’ List Bool} + (hf : f ∈ FP) (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => selectHead (f z) (a z) (b z)) ∈ FP := by + have hflag : βˆ€ t : Bool, (fun z => headFlag t (f z)) ∈ FP := fun t => by + have := mem_FP_comp hf (headFlag_mem_FP t) + simpa [Function.comp] using! this + have hx : (fun z => (a z).take ((headFlag true (f z)).length * (a z).length)) ∈ FP := by + have := takeLenFn_mem_FP (mulLenFn_mem_FP (hflag true) ha) ha + simpa using! this + have hy : (fun z => (b z).take ((headFlag false (f z)).length * (b z).length)) ∈ FP := by + have := takeLenFn_mem_FP (mulLenFn_mem_FP (hflag false) hb) hb + simpa using! this + have h := appendFn_mem_FP hx hy + have heq : (fun z => (a z).take ((headFlag true (f z)).length * (a z).length) + ++ (b z).take ((headFlag false (f z)).length * (b z).length)) + = fun z => selectHead (f z) (a z) (b z) := by + funext z; rw [selectHead_eq] + rwa [heq] at h + +/-- `smash` case: the smash function is `FPn`. On `encodeVec ![x, y]` the two +components are `sndBlock` and `sndBlock ∘ fstBlock`; `smash x y` is +`|x| Β· |y|` copies of `true`, so the witness first computes a zero-filled ruler +with `mulLenFn_mem_FP` and then applies `unaryLength_mem_FP`. -/ +theorem fpn_smash : + FPn (fun v : Fin 2 β†’ List Bool => Complexity.smash (v 0) (v 1)) := by + refine ⟨fun z => + List.replicate ((sndBlock z).length * (sndBlock (fstBlock z)).length) true, + ?_, fun v => ?_⟩ + Β· have hmul := + mulLenFn_mem_FP sndBlock_mem_FP (mem_FP_comp fstBlock_mem_FP sndBlock_mem_FP) + have h := mem_FP_comp hmul unaryLength_mem_FP + have heq : (fun z => + List.replicate ((sndBlock z).length * (sndBlock (fstBlock z)).length) true) = + (fun x => List.replicate x.length true) ∘ fun z => + List.replicate ((sndBlock z).length * (sndBlock (fstBlock z)).length) false := by + funext z + simp [Function.comp] + rw [heq] + exact h + show List.replicate + ((sndBlock (encodeVec v)).length * + (sndBlock (fstBlock (encodeVec v))).length) true + = Complexity.smash (v 0) (v 1) + rw [sndBlock_encodeVec_succ, fstBlock_encodeVec_succ, sndBlock_encodeVec_succ, + Complexity.smash] + rfl + +/-- Assembling an encoded vector out of `FP` component functions of a common input +is `FP`. Proved by induction on the arity: the empty vector is the constant `[]`, +and the successor step is one `pairFn_mem_FP`. -/ +theorem assembleVec_mem_FP {m : β„•} (w : Fin m β†’ (List Bool β†’ List Bool)) + (hw : βˆ€ i, w i ∈ FP) : + (fun z => encodeVec fun i => w i z) ∈ FP := by + induction m with + | zero => + have : (fun z : List Bool => encodeVec fun i : Fin 0 => w i z) + = fun _ => [] := by funext z; rfl + rw [this]; exact const_nil_mem_FP + | succ m ih => + have htail : (fun z => encodeVec fun i : Fin m => Fin.tail w i z) ∈ FP := + ih (Fin.tail w) fun i => hw i.succ + have h0 : w 0 ∈ FP := hw 0 + have hpair := pairFn_mem_FP htail h0 + have heq : (fun z => encodeVec fun i : Fin (m + 1) => w i z) + = fun z => pair (encodeVec fun i : Fin m => Fin.tail w i z) (w 0 z) := by + funext z; rw [encodeVec_succ]; rfl + rw [heq]; exact hpair + +/-- `comp` case: `FPn` is closed under Cobham composition. On `encodeVec v`, each +inner `gs i` is computed by its `FP` witness `G i`, the results are assembled into +`encodeVec (fun i => gs i v)` (`assembleVec_mem_FP`), and the outer `f`'s witness +is applied; `FP` is closed under composition. Rests only on `pairFn_mem_FP`. -/ +theorem fpn_comp {m n : β„•} {f : (Fin m β†’ List Bool) β†’ List Bool} + {gs : Fin m β†’ (Fin n β†’ List Bool) β†’ List Bool} + (ihf : FPn f) (ihgs : βˆ€ i, FPn (gs i)) : + FPn (fun v => f fun i => gs i v) := by + obtain ⟨F, hF, hFf⟩ := ihf + choose G hG hGf using ihgs + refine ⟨F ∘ fun z => encodeVec fun i => G i z, + mem_FP_comp (assembleVec_mem_FP G hG) hF, fun v => ?_⟩ + show F (encodeVec fun i => G i (encodeVec v)) = f fun i => gs i v + have hinner : (fun i => G i (encodeVec v)) = fun i => gs i v := by + funext i; exact hGf i v + rw [hinner, hFf] + +/-- One step of recursion on notation viewed as a fold operation: extend the +running suffix `p.1` by the bit `b` and update the running recursive value `p.2` by +the bit-selected step function. Folding this over a string with `List.foldr` +reproduces `recNotation` (see `recNotation_eq_foldr`); it is the per-iteration +body a loop machine runs. -/ +def recNotationStep {n : β„•} (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) + (w : Fin n β†’ List Bool) (b : Bool) (p : List Bool Γ— List Bool) : + List Bool Γ— List Bool := + (b :: p.1, (bif b then h₁ else hβ‚€) (Fin.cons p.1 (Fin.cons p.2 w))) + +/-- The first component of the recursion-on-notation fold accumulates exactly the +bits processed so far β€” i.e. it rebuilds the input string. -/ +theorem recNotationStep_foldr_fst {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + {hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool} (s : List Bool) + (w : Fin n β†’ List Bool) : + (s.foldr (recNotationStep hβ‚€ h₁ w) ([], g w)).1 = s := by + induction s with + | nil => rfl + | cons b x ih => simp [List.foldr_cons, recNotationStep, ih] + +/-- **Recursion on notation is a fold.** `recNotation g hβ‚€ h₁ s w` is the second +component of folding `recNotationStep` over `s` from the empty suffix and base +value `g w`. This reduces the `boundedRec` case to iterating a single step +function over the bits of `s` β€” exactly what a loop machine computes β€” and is the +target identity for `fpn_boundedRec`. -/ +theorem recNotation_eq_foldr {n : β„•} (g : (Fin n β†’ List Bool) β†’ List Bool) + (hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool) (s : List Bool) + (w : Fin n β†’ List Bool) : + recNotation g hβ‚€ h₁ s w = + (s.foldr (recNotationStep hβ‚€ h₁ w) ([], g w)).2 := by + induction s with + | nil => rfl + | cons b x ih => + rw [recNotation_cons, List.foldr_cons] + simp only [recNotationStep] + rw [recNotationStep_foldr_fst g x w, ih] + +/-! ### The `boundedRec` loop + +The `boundedRec` case runs the recursion as a loop on *encoded* arguments: +`recFold A B e W s` threads a running suffix `t` of `s` and the running +accumulator `a` through the argument encoding `pair (pair W a) t`, which is +exactly `encodeVec (Fin.cons t (Fin.cons a w))` when `W = encodeVec w`. + +A machine cannot run `recFold` as written: nothing stops the accumulator from +doubling in length at every iteration, so intermediate values would need +exponential space. `recFoldClamp` truncates every intermediate value to a +prescribed width, which makes the loop unconditionally polynomial-time +(`recFoldClamp_mem_FP`); Cobham's limited-recursion side condition is then +exactly what shows the truncation never fires (`recFoldClamp_eq_recFold`). -/ + +/-- The recursion-on-notation loop on encoded arguments: fold the bit-selected +step functions `A` (bit `false`) and `B` (bit `true`) over `s`, threading the +running suffix and accumulator through the argument encoding. -/ +def recFold (A B : List Bool β†’ List Bool) (e W : List Bool) : + List Bool β†’ List Bool + | [] => e + | b :: t => (bif b then B else A) (pair (pair W (recFold A B e W t)) t) + +/-- `recFold` with every intermediate value truncated to `bound` bits. This is +the loop a machine can actually run: each iteration's state is length-bounded, +so the whole loop takes polynomial time. -/ +def recFoldClamp (A B : List Bool β†’ List Bool) (bound : β„•) (e W : List Bool) : + List Bool β†’ List Bool + | [] => e.take bound + | b :: t => + ((bif b then B else A) + (pair (pair W (recFoldClamp A B bound e W t)) t)).take bound + +/-- A natural-coefficient polynomial is dominated by a single power of `n + 1` +scaled by the sum of its coefficients. -/ +private theorem poly_eval_le_pow (p : Polynomial β„•) (n : β„•) : + p.eval n ≀ + (βˆ‘ i ∈ Finset.range (p.natDegree + 1), p.coeff i) * (n + 1) ^ p.natDegree := by + rw [Polynomial.eval_eq_sum_range, Finset.sum_mul] + refine Finset.sum_le_sum fun i hi => ?_ + have hi' : i ≀ p.natDegree := by rw [Finset.mem_range] at hi; omega + exact Nat.mul_le_mul_left _ + (le_trans (Nat.pow_le_pow_left (by omega) i) (Nat.pow_le_pow_right (by omega) hi')) + +/-- An `FP` function whose output is at least `c` bits long, for any constant `c`. +Built by iterating `pair Β· []`, which doubles the length and adds two. -/ +theorem exists_const_ruler (c : β„•) : + βˆƒ K : List Bool β†’ List Bool, K ∈ FP ∧ βˆ€ z, c ≀ (K z).length := by + induction c with + | zero => exact ⟨fun _ => [], const_nil_mem_FP, fun _ => by simp⟩ + | succ c ih => + obtain ⟨K, hK, hlen⟩ := ih + refine ⟨fun z => pair (K z) [], pairFn_mem_FP hK const_nil_mem_FP, fun z => ?_⟩ + have := hlen z + simp only [pair_length, List.length_nil] + omega + +/-- **Rulers.** For every constant `c` and exponent `d` there is an `FP` function +whose output is at least `c Β· (|z| + 1) ^ d` bits long. Rulers let the loop of the +`boundedRec` case carry its width clamp as *data* β€” truncating to a string costs +linear time, whereas truncating to a computed number would not. -/ +theorem exists_pow_ruler (c d : β„•) : + βˆƒ R : List Bool β†’ List Bool, R ∈ FP ∧ + βˆ€ z, c * (z.length + 1) ^ d ≀ (R z).length := by + induction d with + | zero => + obtain ⟨K, hK, hlen⟩ := exists_const_ruler c + exact ⟨K, hK, fun z => by simpa using! hlen z⟩ + | succ d ih => + obtain ⟨R, hR, hlen⟩ := ih + refine ⟨fun z => List.replicate ((R z).length * (pair [] z).length) false, + mulLenFn_mem_FP hR pairLeftNil_mem_FP, fun z => ?_⟩ + have hR' := hlen z + have hL : z.length + 1 ≀ (pair [] z).length := by simp + calc c * (z.length + 1) ^ (d + 1) + = (c * (z.length + 1) ^ d) * (z.length + 1) := by ring + _ ≀ (R z).length * (pair [] z).length := Nat.mul_le_mul hR' hL + _ = _ := by simp + +/-- Every polynomial bound has an `FP` ruler. -/ +theorem exists_ruler (p : Polynomial β„•) : + βˆƒ R : List Bool β†’ List Bool, R ∈ FP ∧ βˆ€ z, p.eval z.length ≀ (R z).length := by + obtain ⟨R, hR, hlen⟩ := + exists_pow_ruler (βˆ‘ i ∈ Finset.range (p.natDegree + 1), p.coeff i) p.natDegree + exact ⟨R, hR, fun z => le_trans (poly_eval_le_pow p z.length) (hlen z)⟩ + +/-! ### Exact rulers + +`exists_ruler` builds an `FP` string *at least* `p.eval |z|` bits long, which is +all a clamp needs. The loop needs an exact one: the width it truncates to is the +ruler's length, and that has to be the bound the statement names. Exactness comes +from `Complexity.unaryLength_mem_FP` together with the two exact length +arithmetic operations now available β€” `mulLenFn_mem_FP` multiplies lengths and +`appendFn_mem_FP` adds them. -/ + +/-- Constants of any width are `FP`. -/ +theorem const_replicate_mem_FP (c : β„•) : + (fun _ : List Bool => List.replicate c false) ∈ FP := by + induction c with + | zero => simpa using! const_nil_mem_FP + | succ c ih => + have := mem_FP_comp ih (cons_mem_FP false) + simpa [Function.comp, List.replicate_succ] using! this + +/-- A ruler of length exactly `|z| ^ d`. -/ +private theorem exists_pow_exact_ruler (d : β„•) : + βˆƒ R : List Bool β†’ List Bool, R ∈ FP ∧ βˆ€ z, (R z).length = z.length ^ d := by + induction d with + | zero => exact ⟨fun _ => List.replicate 1 false, const_replicate_mem_FP 1, + fun z => by simp⟩ + | succ d ih => + obtain ⟨R, hR, hlen⟩ := ih + refine ⟨fun z => List.replicate ((R z).length * (List.replicate z.length true).length) + false, mulLenFn_mem_FP hR unaryLength_mem_FP, fun z => ?_⟩ + simp [hlen, pow_succ] + +/-- **A ruler of length exactly `p.eval |z|`.** -/ +theorem exists_exact_ruler (p : Polynomial β„•) : + βˆƒ R : List Bool β†’ List Bool, R ∈ FP ∧ βˆ€ z, (R z).length = p.eval z.length := by + have hsum : βˆ€ N : β„•, βˆƒ R : List Bool β†’ List Bool, R ∈ FP ∧ + βˆ€ z, (R z).length = βˆ‘ i ∈ Finset.range N, p.coeff i * z.length ^ i := by + intro N + induction N with + | zero => exact ⟨fun _ => [], const_nil_mem_FP, fun z => by simp⟩ + | succ N ih => + obtain ⟨R, hR, hlen⟩ := ih + obtain ⟨S, hS, hSlen⟩ := exists_pow_exact_ruler N + refine ⟨fun z => R z ++ List.replicate + ((List.replicate (p.coeff N) false).length * (S z).length) false, + appendFn_mem_FP hR (mulLenFn_mem_FP (const_replicate_mem_FP _) hS), + fun z => ?_⟩ + rw [List.length_append, hlen, List.length_replicate, List.length_replicate, + hSlen, Finset.sum_range_succ] + obtain ⟨R, hR, hlen⟩ := hsum (p.natDegree + 1) + exact ⟨R, hR, fun z => by rw [hlen, ← Polynomial.eval_eq_sum_range]⟩ + +/-! ### The loop as an iteration + +`recFoldClamp` is an iteration of a *single* `FP` step function on a packed +state. Writing `s` for `sndBlock z`, the state after `m` iterations is + + `pair (pair R (pair W s)) (pair (s.drop (|s| - m)) (recFoldClamp … (s.drop (|s| - m))))` + +so the answer is the accumulator after `|s|` iterations. Every ingredient of the +step is now `FP`: the suffix grows by `Complexity.takeLen` against a ruler one +longer, read off `s.reverse`; the branch on the new leading bit is `selectHead`; +and the clamp is `takeLen` against `R`. -/ + +/-- One iteration of the clamped loop, on the loop's components. -/ +def loopStepOn (A B : List Bool β†’ List Bool) (R W s t a : List Bool) : List Bool := + pair (pair R (pair W s)) + (pair ((takeLen (pair (false :: t) s.reverse)).reverse) + (takeLen (pair R + (selectHead ((takeLen (pair (false :: t) s.reverse)).reverse) + (B (pair (pair W a) t)) (A (pair (pair W a) t)))))) + +/-- One iteration of the clamped loop, on the packed state. -/ +def loopStep (A B : List Bool β†’ List Bool) (v : List Bool) : List Bool := + loopStepOn A B (fstBlock (fstBlock v)) (fstBlock (sndBlock (fstBlock v))) + (sndBlock (sndBlock (fstBlock v))) (fstBlock (sndBlock v)) (sndBlock (sndBlock v)) + +@[simp] theorem loopStep_pair (A B : List Bool β†’ List Bool) (R W s t a : List Bool) : + loopStep A B (pair (pair R (pair W s)) (pair t a)) = loopStepOn A B R W s t a := by + simp [loopStep] + +/-- **The step is `FP`.** -/ +theorem loopStep_mem_FP {A B : List Bool β†’ List Bool} (hA : A ∈ FP) (hB : B ∈ FP) : + loopStep A B ∈ FP := by + have hfst : fstBlock ∈ FP := fstBlock_mem_FP + have hsnd : sndBlock ∈ FP := sndBlock_mem_FP + have hcomp₁ : βˆ€ {g : List Bool β†’ List Bool}, g ∈ FP β†’ + (fun v => fstBlock (g v)) ∈ FP := fun hg => by + simpa [Function.comp] using! mem_FP_comp hg hfst + have hcompβ‚‚ : βˆ€ {g : List Bool β†’ List Bool}, g ∈ FP β†’ + (fun v => sndBlock (g v)) ∈ FP := fun hg => by + simpa [Function.comp] using! mem_FP_comp hg hsnd + have hP : (fun v : List Bool => fstBlock v) ∈ FP := hfst + have hR : (fun v : List Bool => fstBlock (fstBlock v)) ∈ FP := hcomp₁ hP + have hW : (fun v : List Bool => fstBlock (sndBlock (fstBlock v))) ∈ FP := + hcomp₁ (hcompβ‚‚ hP) + have hs : (fun v : List Bool => sndBlock (sndBlock (fstBlock v))) ∈ FP := + hcompβ‚‚ (hcompβ‚‚ hP) + have ht : (fun v : List Bool => fstBlock (sndBlock v)) ∈ FP := hcomp₁ hsnd + have ha : (fun v : List Bool => sndBlock (sndBlock v)) ∈ FP := hcompβ‚‚ hsnd + have hrev : βˆ€ {g : List Bool β†’ List Bool}, g ∈ FP β†’ + (fun v => (g v).reverse) ∈ FP := fun hg => by + simpa [Function.comp] using! mem_FP_comp hg reverse_mem_FP + have hcons : (fun v : List Bool => false :: fstBlock (sndBlock v)) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp ht (cons_mem_FP false) + have ht' : (fun v : List Bool => + (takeLen (pair (false :: fstBlock (sndBlock v)) + (sndBlock (sndBlock (fstBlock v))).reverse)).reverse) ∈ FP := by + refine hrev ?_ + have := takeLenFn_mem_FP hcons (hrev hs) + simpa [takeLen_pair] using! this + have hX : (fun v : List Bool => + pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v))) ∈ FP := pairFn_mem_FP (pairFn_mem_FP hW ha) ht + have hsel := selectHeadFn_mem_FP ht' + (by simpa [Function.comp] using! mem_FP_comp hX hB) + (by simpa [Function.comp] using! mem_FP_comp hX hA) + have hacc : (fun v : List Bool => takeLen (pair (fstBlock (fstBlock v)) + (selectHead ((takeLen (pair (false :: fstBlock (sndBlock v)) + (sndBlock (sndBlock (fstBlock v))).reverse)).reverse) + (B (pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v)))) + (A (pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v))))))) ∈ FP := by + have := takeLenFn_mem_FP hR hsel + simpa [takeLen_pair, Function.comp] using! this + have hall := pairFn_mem_FP (pairFn_mem_FP hR (pairFn_mem_FP hW hs)) + (pairFn_mem_FP ht' hacc) + simpa [loopStep, loopStepOn] using! hall + +/-- **The loop's invariant.** After `m` iterations the state holds the suffix +`s.drop (|s| - m)` and the clamped fold over it. -/ +theorem loopStep_iterate {A B : List Bool β†’ List Bool} (R W s e : List Bool) : + βˆ€ m ≀ s.length, + (loopStep A B)^[m] + (pair (pair R (pair W s)) (pair [] (e.take R.length))) + = pair (pair R (pair W s)) + (pair (s.drop (s.length - m)) + (recFoldClamp A B R.length e W (s.drop (s.length - m)))) := by + intro m + induction m with + | zero => intro _; simp [recFoldClamp] + | succ m ih => + intro hm + rw [Function.iterate_succ_apply', ih (by omega), loopStep_pair, loopStepOn] + have hlt : s.length - (m + 1) < s.length := by omega + have hdrop : s.drop (s.length - (m + 1)) + = s[s.length - (m + 1)] :: s.drop (s.length - m) := by + rw [List.drop_eq_getElem_cons hlt, + show s.length - (m + 1) + 1 = s.length - m from by omega] + have hnext : (takeLen (pair (false :: s.drop (s.length - m)) s.reverse)).reverse + = s.drop (s.length - (m + 1)) := by + rw [takeLen_pair, List.length_cons, List.length_drop, + show s.length - (s.length - m) + 1 = s.length - (s.length - (m + 1)) from by omega, + ← List.reverse_drop, List.reverse_reverse] + rw [hnext, hdrop, recFoldClamp] + congr 2 + rw [takeLen_pair, selectHead] + cases hb : s[s.length - (m + 1)] <;> simp + +/-- The clamp really clamps. -/ +theorem recFoldClamp_length_le (A B : List Bool β†’ List Bool) (bound : β„•) + (e W s : List Bool) : (recFoldClamp A B bound e W s).length ≀ bound := by + cases s with + | nil => simp [recFoldClamp] + | cons b t => simp [recFoldClamp] + +/-! ### The loop's step function + +`Complexity.iterate_input_mem_FP` supplies a machine that applies an `FP` +function once per bit of its own input, starting from `pair [] x`. The state +below is `pair (pair C v) x`: a counter `C`, the running value `v`, and the +machine's input `x` kept verbatim. Keeping `x` is what makes the whole +construction work: the ruler and the width stay readable at every step, and +truncating the new state to `|x|` bounds the state length *globally* β€” the +machine's contract needs a bound that holds for every input, not just for the +well-formed ones. -/ + +/-- A flag whose leading bit is `true` exactly when `s` is empty β€” the one test +`Complexity.selectHead` cannot make directly. -/ +def emptyFlag (s : List Bool) : List Bool := + headFlag true s ++ headFlag false s ++ [true] + +@[simp] theorem emptyFlag_nil : emptyFlag [] = [true] := rfl + +theorem emptyFlag_head_cons (b : Bool) (t : List Bool) : + (emptyFlag (b :: t)).head? = some false := by + cases b <;> rfl + +theorem selectHead_emptyFlag_nil (x y : List Bool) : selectHead (emptyFlag []) x y = x := by + rw [emptyFlag_nil, selectHead, + ite_eq_left (show ([true] : List Bool).head? = some true from rfl)] + +theorem length_take_le_arg (n : β„•) (l : List Bool) : (l.take n).length ≀ n := by + rw [List.length_take]; omega + +theorem selectHead_emptyFlag_cons (b : Bool) (t x y : List Bool) : + selectHead (emptyFlag (b :: t)) x y = y := by + rw [selectHead, ite_eq_right (by rw [emptyFlag_head_cons]; simp), + ite_eq_left (emptyFlag_head_cons b t)] + +theorem selectHead_length_le (s x y : List Bool) : + (selectHead s x y).length ≀ max x.length y.length := by + rw [selectHead] + split + Β· exact le_max_left _ _ + Β· split + Β· exact le_max_right _ _ + Β· simp + +/-- The counter of the next iteration: one more mark of the reversed ruler. -/ +def nextCounter (w : List Bool) : List Bool := + (takeLen (pair (false :: fstBlock (fstBlock w)) + (fstBlock (fstBlock (sndBlock w))))).reverse + +/-- The value of the next iteration: the initial value on the first step, then +`F` of the current value until the counter saturates. -/ +def nextValue (F : List Bool β†’ List Bool) (w : List Bool) : List Bool := + selectHead (emptyFlag (fstBlock (fstBlock w))) + (sndBlock (sndBlock w)) + (selectHead (nextCounter w) (sndBlock (fstBlock w)) + (takeLen (pair (sndBlock (fstBlock (sndBlock w))) (F (sndBlock (fstBlock w)))))) + +/-- One iteration of the loop, truncated to the machine's own input length. -/ +def iterStep (F : List Bool β†’ List Bool) (w : List Bool) : List Bool := + pair (takeLen (pair (sndBlock w) (pair (nextCounter w) (nextValue F w)))) (sndBlock w) + +theorem sndBlock_iterStep (F : List Bool β†’ List Bool) (w : List Bool) : + sndBlock (iterStep F w) = sndBlock w := by + rw [iterStep, sndBlock_pair] + +theorem iterStep_length_le (F : List Bool β†’ List Bool) (w : List Bool) : + (iterStep F w).length ≀ 3 * (sndBlock w).length + 2 := by + rw [iterStep, pair_length, takeLen_pair] + have := length_take_le_arg (sndBlock w).length (pair (nextCounter w) (nextValue F w)) + omega + +/-- **The state length is globally bounded**: whatever the input, the state +after one or more iterations fits in `3|x| + 2`. -/ +theorem iterStep_iterate_length_le (F : List Bool β†’ List Bool) (x : List Bool) : + βˆ€ i, ((iterStep F)^[i] (pair [] x)).length ≀ 3 * x.length + 2 := by + have hsnd : βˆ€ i, sndBlock ((iterStep F)^[i] (pair [] x)) = x := by + intro i + induction i with + | zero => exact sndBlock_pair [] x + | succ i ih => rw [Function.iterate_succ_apply', sndBlock_iterStep, ih] + intro i + cases i with + | zero => + rw [Function.iterate_zero_apply, pair_length] + simp + omega + | succ i => + rw [Function.iterate_succ_apply'] + have := iterStep_length_le F ((iterStep F)^[i] (pair [] x)) + rw [hsnd i] at this + exact this + +theorem emptyFlag_mem_FP {f : List Bool β†’ List Bool} (hf : f ∈ FP) : + (fun z => emptyFlag (f z)) ∈ FP := by + have hcst : (fun _ : List Bool => [true]) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp const_nil_mem_FP (cons_mem_FP true) + have h1 : (fun z => headFlag true (f z)) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp hf (headFlag_mem_FP true) + have h2 : (fun z => headFlag false (f z)) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp hf (headFlag_mem_FP false) + exact appendFn_mem_FP (appendFn_mem_FP h1 h2) hcst + +theorem nextCounter_mem_FP : nextCounter ∈ FP := by + have hf : fstBlock ∈ FP := fstBlock_mem_FP + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hc : (fun w => false :: fstBlock (fstBlock w)) ∈ FP := by + simpa [Function.comp] using! + mem_FP_comp (mem_FP_comp hf hf) (cons_mem_FP false) + have hk : (fun w => fstBlock (fstBlock (sndBlock w))) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp hs (mem_FP_comp hf hf) + have := takeLenFn_mem_FP hc hk + have hrev : (fun w => ((fstBlock (fstBlock (sndBlock w))).take + (false :: fstBlock (fstBlock w)).length).reverse) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp this reverse_mem_FP + have heq : (fun w => ((fstBlock (fstBlock (sndBlock w))).take + (false :: fstBlock (fstBlock w)).length).reverse) = nextCounter := by + funext w + rw [nextCounter, takeLen_pair] + rwa [heq] at hrev + +theorem nextValue_mem_FP {F : List Bool β†’ List Bool} (hF : F ∈ FP) : + nextValue F ∈ FP := by + have hf : fstBlock ∈ FP := fstBlock_mem_FP + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hC : (fun w => fstBlock (fstBlock w)) ∈ FP := mem_FP_comp hf hf + have hv : (fun w => sndBlock (fstBlock w)) ∈ FP := mem_FP_comp hf hs + have hv0 : (fun w => sndBlock (sndBlock w)) ∈ FP := mem_FP_comp hs hs + have hW : (fun w => sndBlock (fstBlock (sndBlock w))) ∈ FP := + mem_FP_comp hs (mem_FP_comp hf hs) + have hFv : (fun w => F (sndBlock (fstBlock w))) ∈ FP := mem_FP_comp hv hF + have hclamp : (fun w => takeLen (pair (sndBlock (fstBlock (sndBlock w))) + (F (sndBlock (fstBlock w))))) ∈ FP := by + have := takeLenFn_mem_FP hW hFv + simpa [takeLen_pair] using! this + exact selectHeadFn_mem_FP (emptyFlag_mem_FP hC) hv0 + (selectHeadFn_mem_FP nextCounter_mem_FP hv hclamp) + +theorem iterStep_mem_FP {F : List Bool β†’ List Bool} (hF : F ∈ FP) : + iterStep F ∈ FP := by + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hpair : (fun w => pair (nextCounter w) (nextValue F w)) ∈ FP := + pairFn_mem_FP nextCounter_mem_FP (nextValue_mem_FP hF) + have hclamp : (fun w => takeLen (pair (sndBlock w) + (pair (nextCounter w) (nextValue F w)))) ∈ FP := by + have := takeLenFn_mem_FP hs hpair + simpa [takeLen_pair] using! this + exact pairFn_mem_FP hclamp hs + +/-- The value the loop carries after `i` iterations, from the second on. -/ +def iterVal (F : List Bool β†’ List Bool) (Krev W vβ‚€ : List Bool) : β„• β†’ List Bool + | 0 => vβ‚€ + | i + 1 => selectHead ((Krev.take (i + 2)).reverse) (iterVal F Krev W vβ‚€ i) + ((F (iterVal F Krev W vβ‚€ i)).take W.length) + +theorem iterVal_length_le (F : List Bool β†’ List Bool) (Krev W vβ‚€ : List Bool) : + βˆ€ i, (iterVal F Krev W vβ‚€ i).length ≀ max vβ‚€.length W.length := by + intro i + induction i with + | zero => exact le_max_left _ _ + | succ i ih => + refine le_trans (selectHead_length_le _ _ _) ?_ + have := length_take_le_arg W.length (F (iterVal F Krev W vβ‚€ i)) + omega + +theorem take_succ_min (l : List Bool) (i : β„•) : + l.take (min i l.length + 1) = l.take (i + 1) := by + rcases Nat.lt_or_ge l.length i with h | h + Β· rw [min_eq_right (by omega), List.take_of_length_le (by omega), + List.take_of_length_le (by omega)] + Β· rw [min_eq_left h] + +/-- **The loop's trajectory.** With the counter growing one mark per iteration +and the state always fitting in the input, the `i+1`-st state is exactly the +counter `(Krev.take (i+1)).reverse` beside the value `iterVal … i`. -/ +theorem iterStep_iterate (F : List Bool β†’ List Bool) (Krev W vβ‚€ : List Bool) + (hK : Krev β‰  []) + (hfit : βˆ€ i, (pair ((Krev.take (i + 1)).reverse) (iterVal F Krev W vβ‚€ i)).length + ≀ (pair (pair Krev W) vβ‚€).length) : + βˆ€ i, (iterStep F)^[i + 1] (pair [] (pair (pair Krev W) vβ‚€)) + = pair (pair ((Krev.take (i + 1)).reverse) (iterVal F Krev W vβ‚€ i)) + (pair (pair Krev W) vβ‚€) := by + intro i + induction i with + | zero => + rw [Function.iterate_succ_apply', Function.iterate_zero_apply, iterStep, sndBlock_pair] + rw [show nextCounter (pair [] (pair (pair Krev W) vβ‚€)) = (Krev.take 1).reverse from by + rw [nextCounter, fstBlock_pair, sndBlock_pair, fstBlock_pair, fstBlock_pair, + takeLen_pair] + simp [fstBlock]] + rw [show nextValue F (pair [] (pair (pair Krev W) vβ‚€)) = vβ‚€ from by + rw [nextValue, fstBlock_pair, show fstBlock ([] : List Bool) = [] from rfl, + selectHead_emptyFlag_nil, sndBlock_pair, sndBlock_pair]] + rw [takeLen_pair] + show pair ((pair ((Krev.take (0 + 1)).reverse) (iterVal F Krev W vβ‚€ 0)).take + (pair (pair Krev W) vβ‚€).length) (pair (pair Krev W) vβ‚€) = _ + rw [List.take_of_length_le (hfit 0)] + | succ i ih => + rw [Function.iterate_succ_apply', ih, iterStep, sndBlock_pair] + have hlen : ((Krev.take (i + 1)).reverse).length = min (i + 1) Krev.length := by + simp + have hC : nextCounter (pair (pair ((Krev.take (i + 1)).reverse) + (iterVal F Krev W vβ‚€ i)) (pair (pair Krev W) vβ‚€)) + = (Krev.take (i + 2)).reverse := by + rw [nextCounter, fstBlock_pair, sndBlock_pair, fstBlock_pair, fstBlock_pair, + fstBlock_pair, takeLen_pair, List.length_cons, hlen, take_succ_min] + have hne : (Krev.take (i + 1)).reverse β‰  [] := by + intro hc + have : Krev.length = 0 := by + have h0 : ((Krev.take (i + 1)).reverse).length = 0 := by rw [hc]; rfl + rw [hlen] at h0 + omega + exact hK (List.eq_nil_of_length_eq_zero this) + obtain ⟨b, t, hbt⟩ := List.exists_cons_of_ne_nil hne + have hV : nextValue F (pair (pair ((Krev.take (i + 1)).reverse) + (iterVal F Krev W vβ‚€ i)) (pair (pair Krev W) vβ‚€)) + = iterVal F Krev W vβ‚€ (i + 1) := by + rw [nextValue, fstBlock_pair, fstBlock_pair, sndBlock_pair, sndBlock_pair, + fstBlock_pair, sndBlock_pair, hbt, selectHead_emptyFlag_cons, ← hbt, hC, + takeLen_pair, sndBlock_pair, iterVal] + rw [hC, hV, takeLen_pair, List.take_of_length_le (hfit (i + 1))] + +theorem counter_take_le (a j : β„•) (h : j ≀ a) : + (List.replicate a false ++ [true]).take j = List.replicate j false := by + rw [List.take_append_of_le_length (by simpa using! h), List.take_replicate, min_eq_left h] + +theorem counter_head_false (a j : β„•) (h1 : 1 ≀ j) (h2 : j ≀ a) : + (((List.replicate a false ++ [true]).take j).reverse).head? = some false := by + rw [counter_take_le a j h2, List.reverse_replicate] + cases j with + | zero => omega + | succ j => rfl + +theorem counter_head_true (a j : β„•) (h : a + 1 ≀ j) : + (((List.replicate a false ++ [true]).take j).reverse).head? = some true := by + rw [List.take_of_length_le (by simp; omega), List.reverse_append, List.reverse_replicate] + rfl + +/-- **The value sequence is the iterate.** While the counter has marks left the +step applies `F`; once it saturates the value stops changing. The clamp is a +no-op because every intermediate value fits in `W`. -/ +theorem iterVal_eq_iterate (F : List Bool β†’ List Bool) (W vβ‚€ : List Bool) (M : β„•) + (hclamp : βˆ€ j, j ≀ M β†’ (F^[j] vβ‚€).length ≀ W.length) : + βˆ€ i, iterVal F (List.replicate (M + 1) false ++ [true]) W vβ‚€ i = F^[min i M] vβ‚€ := by + intro i + induction i with + | zero => simp [iterVal] + | succ i ih => + rw [iterVal, ih] + by_cases h : i + 2 ≀ M + 1 + Β· have hhead := counter_head_false (M + 1) (i + 2) (by omega) h + rw [selectHead, ite_eq_right (by rw [hhead]; simp), ite_eq_left hhead, + show min i M = i from by omega, ← Function.iterate_succ_apply' F i vβ‚€, + List.take_of_length_le (hclamp (i + 1) (by omega)), + show min (i + 1) M = i + 1 from by omega] + Β· have hhead := counter_head_true (M + 1) (i + 2) (by omega) + rw [selectHead, ite_eq_left hhead, show min i M = M from by omega, + show min (i + 1) M = M from by omega] + +/-- **`FP` is closed under bounded iteration** β€” the one machine-level fact the +soundness direction needs. + +*Construction.* The machine is assembled in +`Complexitylib.Classes.P.Cobham.Internal.Iterate` out of the phase contracts of +`Complexitylib.Classes.P.Cobham.Internal.IterateLayout`; `iterate_input_mem_FP` is its +interface. Three details are worth recording, because three earlier plans died +on them. + +*Why resetting scratch is the crux.* `F`'s machine `M` comes from an +existential (`F ∈ FP`), so nothing is known about the shape it leaves its +scratch tapes in. Re-running it needs those tapes genuinely blank, but a +content-driven eraser (`TM.blankWorkTM` scans right to the *first* blank) +under-wipes whenever `M` left a gap β€” an isolated blank cell with more content +beyond it. `TM.wipeStepTM` therefore writes blank *unconditionally*, and +`Complexity.resetTapesTM` drives it a fixed number of times off a fuel register +that is unrelated to the wiped tapes' content. `TM.reachesIn_work_cells_far` +supplies the bound that makes the fixed count sufficient: a `t`-step run cannot +have touched anything past `head + t`. `Complexity.iterTail` is the resulting +five-phase cleanup, shared by the loop body and the setup; its first two phases +are not bookkeeping either, since `Ξ΄_right_of_start` only forces a head +*reading* `β–·` to move right, so an arbitrary witness machine may legitimately +*halt* with a head at cell `0`. + +*Why the state carries the machine's own input.* `TM.ComputesInTime` quantifies +over *all* inputs, so the loop's contract has to survive malformed ones: the +state is `pair (pair C v) x` with the machine's input `x` kept verbatim, and +every new state is truncated to `|x|` (`iterStep`). That makes +`iterStep_iterate_length_le` β€” a state-length bound holding for every input, +not just the well-formed ones β€” available for free, and keeps the ruler and the +width readable at every step. On the intended trajectory the truncation is a +no-op (`iterStep_iterate`). + +*How the counter avoids a second fuel value.* The loop runs `|x| + 1` times, one +per bit of the machine's own input (`TM.inputLenRegTM`), which is more +iterations than needed; the surplus is absorbed by a counter that grows one mark +of `Krev = 0^(m+1) 1` per step, whose leading bit turns `true` exactly when the +`m` real applications are done (`counter_head_false`, `counter_head_true`). So +`iterVal` is `F` iterated `min i m` times, and over-iteration is harmless +(`iterVal_eq_iterate`). The wipe width is a *different* register, `p.eval |x|`, +computed by `TM.polyEvalTM` β€” the state is longer than the input, so `|x|` +alone cannot pay for the reset. + +*Time.* Each iteration costs `iterStep`'s own polynomial bound at width +`(width z).length` β€” which is why `hbound` is a hypothesis β€” plus the linear +copies and the wipe, and there are `|x| + 1` of them, so the total is polynomial +(`polyBnd_iterBound`). -/ +theorem iterate_mem_FP {F init ruler width : List Bool β†’ List Bool} + (hF : F ∈ FP) (hinit : init ∈ FP) (hruler : ruler ∈ FP) (hwidth : width ∈ FP) + (hbound : βˆ€ z, βˆ€ n ≀ (ruler z).length, + (F^[n] (init z)).length ≀ (width z).length) : + (fun z => F^[(ruler z).length] (init z)) ∈ FP := by + set Krev : List Bool β†’ List Bool := + fun z => List.replicate ((ruler z).length + 1) false ++ [true] with hKrev + have hKrevLen : βˆ€ z, (Krev z).length = (ruler z).length + 2 := by + intro z; rw [hKrev]; simp + have hKrevNe : βˆ€ z, Krev z β‰  [] := by + intro z h + have := hKrevLen z + rw [h] at this + simp at this + -- the machine's input + set X : List Bool β†’ List Bool := + fun z => pair (pair (Krev z) (width z)) (init z) with hX + have hXlen : βˆ€ z, (X z).length + = 4 * (Krev z).length + 2 * (width z).length + (init z).length + 6 := by + intro z; rw [hX]; simp only [pair_length]; omega + -- the iterated step is `FP`, and its state length is globally bounded + have hstep : iterStep F ∈ FP := iterStep_mem_FP hF + have hr : βˆ€ (x : List Bool), βˆ€ i ≀ x.length, + ((iterStep F)^[i] (pair [] x)).length + ≀ (3 * Polynomial.X + Polynomial.C 2 : Polynomial β„•).eval x.length := by + intro x i _ + have := iterStep_iterate_length_le F x i + simpa using! this + have hΞ› := iterate_input_mem_FP hstep (3 * Polynomial.X + Polynomial.C 2) hr + -- the wrapper is `FP`, so the composite is + have hXFP : X ∈ FP := by + have hone : (fun _ : List Bool => [false]) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp const_nil_mem_FP (cons_mem_FP false) + have htrue : (fun _ : List Bool => [true]) ∈ FP := by + simpa [Function.comp] using! mem_FP_comp const_nil_mem_FP (cons_mem_FP true) + have hrl : (fun z => ruler z ++ [false]) ∈ FP := appendFn_mem_FP hruler hone + have hrep : (fun z => List.replicate ((ruler z).length + 1) false) ∈ FP := by + have := mulLenFn_mem_FP hrl hone + simpa using! this + exact pairFn_mem_FP (pairFn_mem_FP (appendFn_mem_FP hrep htrue) hwidth) hinit + have hXeq : βˆ€ z, X z = pair (pair (Krev z) (width z)) (init z) := fun z => by rw [hX] + have heq : (fun z => F^[(ruler z).length] (init z)) + = sndBlock ∘ (fstBlock ∘ ((fun x => (iterStep F)^[x.length + 1] (pair [] x)) ∘ X)) := by + funext z + simp only [Function.comp_apply] + have hfit : βˆ€ i, (pair (((Krev z).take (i + 1)).reverse) + (iterVal F (Krev z) (width z) (init z) i)).length ≀ (X z).length := by + intro i + have h1 : (((Krev z).take (i + 1)).reverse).length ≀ (Krev z).length := by simp + have h2 := iterVal_length_le F (Krev z) (width z) (init z) i + rw [pair_length, hXlen z] + omega + have hval : βˆ€ i, iterVal F (Krev z) (width z) (init z) i + = F^[min i (ruler z).length] (init z) := by + have hclamp : βˆ€ j, j ≀ (ruler z).length β†’ (F^[j] (init z)).length ≀ (width z).length := + fun j hj => hbound z j hj + intro i + exact iterVal_eq_iterate F (width z) (init z) (ruler z).length hclamp i + have hiter := iterStep_iterate F (Krev z) (width z) (init z) (hKrevNe z) hfit (X z).length + have hlarge : (ruler z).length ≀ (X z).length := by + have := hKrevLen z + rw [hXlen z]; omega + rw [hXeq z, hiter, fstBlock_pair, sndBlock_pair, hval, min_eq_right hlarge] + rw [heq] + exact mem_FP_comp (mem_FP_comp (mem_FP_comp hXFP hΞ›) fstBlock_mem_FP) sndBlock_mem_FP + +/-- **The loop of the `boundedRec` case.** `recFoldClamp` is `loopStep` iterated +once per bit of `sndBlock z` (`loopStep_iterate`), started from the packed state +`pair (pair R (pair W s)) (pair [] (e.take |R|))` β€” with `R` an *exact* ruler for +the clamp (`exists_exact_ruler`) β€” and read off with two `sndBlock`s. -/ +theorem recFoldClamp_mem_FP {A B E : List Bool β†’ List Bool} + (hA : A ∈ FP) (hB : B ∈ FP) (hE : E ∈ FP) (p : Polynomial β„•) : + (fun z => recFoldClamp A B (p.eval z.length) (E z) (fstBlock z) (sndBlock z)) + ∈ FP := by + obtain ⟨R, hR, hRlen⟩ := exists_exact_ruler p + have hfst : fstBlock ∈ FP := fstBlock_mem_FP + have hsnd : sndBlock ∈ FP := sndBlock_mem_FP + have hP : (fun z => pair (R z) (pair (fstBlock z) (sndBlock z))) ∈ FP := + pairFn_mem_FP hR (pairFn_mem_FP hfst hsnd) + have hinit : (fun z => pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length))) ∈ FP := + pairFn_mem_FP hP (pairFn_mem_FP const_nil_mem_FP (takeLenFn_mem_FP hR hE)) + have hwidth : (fun z => pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair (sndBlock z) (R z))) ∈ FP := pairFn_mem_FP hP (pairFn_mem_FP hsnd hR) + have hbound : βˆ€ z, βˆ€ n ≀ (sndBlock z).length, + ((loopStep A B)^[n] (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length)))).length + ≀ (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair (sndBlock z) (R z))).length := by + intro z n hn + rw [loopStep_iterate (A := A) (B := B) (R z) (fstBlock z) (sndBlock z) (E z) n hn] + have h1 : ((sndBlock z).drop ((sndBlock z).length - n)).length + ≀ (sndBlock z).length := by simp + have h2 : (recFoldClamp A B (R z).length (E z) (fstBlock z) + ((sndBlock z).drop ((sndBlock z).length - n))).length ≀ (R z).length := + recFoldClamp_length_le _ _ _ _ _ _ + simp only [pair_length] + omega + have hiter := iterate_mem_FP (loopStep_mem_FP hA hB) hinit hsnd hwidth hbound + have hout := mem_FP_comp hiter (mem_FP_comp hsnd hsnd) + have heq : ((sndBlock ∘ sndBlock) ∘ fun z => + (loopStep A B)^[(sndBlock z).length] + (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length)))) + = fun z => recFoldClamp A B (p.eval z.length) (E z) (fstBlock z) (sndBlock z) := by + funext z + rw [Function.comp, Function.comp, + loopStep_iterate (A := A) (B := B) (R z) (fstBlock z) (sndBlock z) (E z) + (sndBlock z).length le_rfl] + simp [hRlen z] + rwa [heq] at hout + +/-- Truncation is a no-op as soon as every intermediate value already fits. -/ +theorem recFoldClamp_eq_recFold {A B : List Bool β†’ List Bool} {bound : β„•} + {e W : List Bool} (s : List Bool) + (hle : βˆ€ t : List Bool, t.length ≀ s.length β†’ + (recFold A B e W t).length ≀ bound) : + recFoldClamp A B bound e W s = recFold A B e W s := by + induction s with + | nil => + show e.take bound = e + exact List.take_of_length_le (hle [] (by simp)) + | cons b t ih => + have htail : recFoldClamp A B bound e W t = recFold A B e W t := + ih fun u hu => hle u (by simp only [List.length_cons]; omega) + show ((bif b then B else A) + (pair (pair W (recFoldClamp A B bound e W t)) t)).take bound = _ + rw [htail] + exact List.take_of_length_le (hle (b :: t) le_rfl) + +/-- On encoded arguments the loop computes recursion on notation: `recFold` over +the `FP` witnesses of `g`, `hβ‚€`, `h₁` reproduces `recNotation`. -/ +theorem recFold_eq_recNotation {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} + {hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool} + {G Hβ‚€ H₁ : List Bool β†’ List Bool} + (hG : βˆ€ u : Fin n β†’ List Bool, G (encodeVec u) = g u) + (hHβ‚€ : βˆ€ u : Fin (n + 2) β†’ List Bool, Hβ‚€ (encodeVec u) = hβ‚€ u) + (hH₁ : βˆ€ u : Fin (n + 2) β†’ List Bool, H₁ (encodeVec u) = h₁ u) + (w : Fin n β†’ List Bool) (s : List Bool) : + recFold Hβ‚€ H₁ (G (encodeVec w)) (encodeVec w) s = recNotation g hβ‚€ h₁ s w := by + -- The encoded step argument is exactly the vector `Fin.cons t (Fin.cons a w)`. + have henc : βˆ€ (t a : List Bool), + pair (pair (encodeVec w) a) t = encodeVec (Fin.cons t (Fin.cons a w)) := by + intro t a + rw [encodeVec_succ, encodeVec_succ] + simp [Fin.tail_cons] + induction s with + | nil => exact hG w + | cons b t ih => + show (bif b then H₁ else Hβ‚€) + (pair (pair (encodeVec w) (recFold Hβ‚€ H₁ (G (encodeVec w)) (encodeVec w) t)) t) + = _ + rw [ih, henc, recNotation_cons] + cases b + Β· simp only [Bool.cond_false]; exact hHβ‚€ _ + Β· simp only [Bool.cond_true]; exact hH₁ _ + +/-- Every `FP` function has polynomially bounded output length: a time bound is +also an output-length bound (`TM.ComputesInTime.output_length_le`). -/ +theorem output_length_poly_of_mem_FP {f : List Bool β†’ List Bool} (hf : f ∈ FP) : + βˆƒ p : Polynomial β„•, βˆ€ x, (f x).length ≀ p.eval x.length := by + obtain ⟨k, tm, p, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hf + exact ⟨p, fun x => hcomp.output_length_le x⟩ + +/-- `boundedRec` case: `FPn` is closed under limited recursion on notation. + +By `recFold_eq_recNotation` the value is the encoded-argument loop `recFold` run +over the bits of `v 0`. Cobham's limited-recursion side condition `hbound` caps +every intermediate accumulator by `|j (…)|`, which is polynomial in `|encodeVec v|` +(`output_length_poly_of_mem_FP`), so the clamped loop `recFoldClamp` β€” which a +machine can run in polynomial time (`recFoldClamp_mem_FP`) β€” never truncates and +therefore agrees with `recFold`. -/ +theorem fpn_boundedRec {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} + {hβ‚€ h₁ : (Fin (n + 2) β†’ List Bool) β†’ List Bool} + {j : (Fin (n + 1) β†’ List Bool) β†’ List Bool} + (ihg : FPn g) (ih0 : FPn hβ‚€) (ih1 : FPn h₁) (ihj : FPn j) + (hbound : βˆ€ x v, (recNotation g hβ‚€ h₁ x v).length ≀ (j (Fin.cons x v)).length) : + FPn (fun v : Fin (n + 1) β†’ List Bool => + recNotation g hβ‚€ h₁ (v 0) (Fin.tail v)) := by + obtain ⟨G, hGFP, hG⟩ := ihg + obtain ⟨Hβ‚€, hH0FP, hH0⟩ := ih0 + obtain ⟨H₁, hH1FP, hH1⟩ := ih1 + obtain ⟨J, hJFP, hJ⟩ := ihj + obtain ⟨p, hp⟩ := output_length_poly_of_mem_FP hJFP + have hE : (fun z => G (fstBlock z)) ∈ FP := mem_FP_comp fstBlock_mem_FP hGFP + refine ⟨fun z => recFoldClamp Hβ‚€ H₁ (p.eval z.length) (G (fstBlock z)) (fstBlock z) + (sndBlock z), recFoldClamp_mem_FP hH0FP hH1FP hE p, fun v => ?_⟩ + show recFoldClamp Hβ‚€ H₁ (p.eval (encodeVec v).length) (G (fstBlock (encodeVec v))) + (fstBlock (encodeVec v)) (sndBlock (encodeVec v)) + = recNotation g hβ‚€ h₁ (v 0) (Fin.tail v) + rw [fstBlock_encodeVec_succ, sndBlock_encodeVec_succ] + rw [recFoldClamp_eq_recFold (v 0) ?_] + Β· exact recFold_eq_recNotation hG hH0 hH1 (Fin.tail v) (v 0) + Β· -- Cobham's limited-recursion bound caps every intermediate accumulator. + intro t ht + rw [recFold_eq_recNotation hG hH0 hH1 (Fin.tail v) t] + refine le_trans (hbound t (Fin.tail v)) ?_ + have hJt : (j (Fin.cons t (Fin.tail v))).length + ≀ p.eval (encodeVec (Fin.cons t (Fin.tail v))).length := by + rw [← hJ (Fin.cons t (Fin.tail v))] + exact hp _ + refine le_trans hJt (polynomial_eval_mono_nat p ?_) + have e1 : (encodeVec (Fin.cons t (Fin.tail v))).length + = 2 * (encodeVec (Fin.tail v)).length + 2 + t.length := by + simp [encodeVec_succ, Fin.tail_cons] + have e2 : (encodeVec v).length + = 2 * (encodeVec (Fin.tail v)).length + 2 + (v 0).length := by + simp [encodeVec_succ] + omega + +/-- **Soundness induction.** Every function of Cobham's algebra is polynomial +time on encoded argument vectors. -/ +theorem cobham_imp_FPn : βˆ€ {n : β„•} {f : (Fin n β†’ List Bool) β†’ List Bool}, + Cobham f β†’ FPn f := by + intro n f h + induction h with + | proj i => exact fpn_proj i + | empty => exact fpn_empty + | bit b => exact fpn_bit b + | smash => exact fpn_smash + | comp _ _ ihf ihgs => exact fpn_comp ihf ihgs + | boundedRec _ _ _ _ hbound ihg ih0 ih1 ihj => + exact fpn_boundedRec ihg ih0 ih1 ihj hbound + +/-- Arity-one specialization: from the multi-arity soundness induction, the +unary fragment `CobhamFP` lands in `FP`. -/ +theorem CobhamFP_subset_FP_of_FPn : CobhamFP βŠ† FP := by + intro f hf + obtain ⟨g, hg, hgf⟩ := cobham_imp_FPn hf + -- `hgf` specialized to `![x]`: `g (pair [] x) = f x`. + have hval : βˆ€ x : List Bool, g (pair [] x) = f x := by + intro x + have := hgf ![x] + rwa [encodeVec_one] at this + -- Hence `f = g ∘ (x ↦ pair [] x)`, a composition of `FP` functions. + have hfeq : f = g ∘ fun x : List Bool => pair [] x := by + funext x; simp [Function.comp, hval x] + rw [hfeq] + exact mem_FP_comp pairLeftNil_mem_FP hg + +/-! ## Completeness: `FP βŠ† CobhamFP` -/ + +/-- **Completeness direction.** Every polynomial-time function belongs to +Cobham's algebra. + +*Construction:* a polynomial-time Turing machine is simulated inside the algebra. +1. A whole configuration β€” state, input tape, output tape, work tapes and every + head position β€” is one bitstring of equal-width blocks, each tape split at its + head so that a head move is a two-bit shift (`Cobham.cfgCode`). +2. The one-step transition is a finite case split on (state, symbols read), which + is `Cobham.tableFn` against the finitely many constant key patterns, with each + branch built from `takeFn`/`dropFn`/`appendFn`/`padFn` (`Cobham.stepFn`). At + the halting state the branch is the identity, so the encoding is a fixed point + once the machine stops. +3. The step is iterated once per bit of a clock string built from `smash` + (`Cobham.exists_pow_clock`), long enough by the polynomial normal form + `mem_FP_iff_computesInTime_polynomial`. +4. A second iteration walks the output head back to cell `0` + (`Cobham.rewindFn`), after which that tape's right half-block is the whole + tape in order, and the output is read off it by two `Complexity.cellBits` + recursions and one `Complexity.runTrue` (`Cobham.simFn`). +The length bounds throughout are polynomial, so every `boundedRec` side condition +is met. -/ +theorem FP_subset_CobhamFP_internal : FP βŠ† CobhamFP := by + intro f hf + obtain ⟨k, tm, p, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hf + exact computes_mem_CobhamFP tm + (S := βˆ‘ i ∈ Finset.range (p.natDegree + 1), p.coeff i) (D := p.natDegree) + (poly_eval_le_pow p) hcomp + +/-- **Multi-arity completeness.** A unary `FP` witness on canonical encodings is +first translated into the unary Cobham algebra and then composed with +`encodeVec_mem_internal`. -/ +theorem FPn_imp_cobham_internal {n : β„•} {f : (Fin n β†’ List Bool) β†’ List Bool} + (hf : FPn f) : Cobham f := by + obtain ⟨g, hg, hgf⟩ := hf + have hgCobham : Cobham fun v : Fin 1 β†’ List Bool => g (v 0) := + FP_subset_CobhamFP_internal hg + refine (Cobham.comp hgCobham fun _ : Fin 1 => encodeVec_mem_internal).of_eq fun v => ?_ + exact hgf v diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean new file mode 100644 index 0000000000..605a2ec9b5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean @@ -0,0 +1,543 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Blocks +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import Mathlib.Data.Fin.VecNotation +public import Mathlib.Data.Fintype.Basic +public import Mathlib.Tactic.FinCases +public import Mathlib.Tactic.Ring + +/-! +# Cobham's algebra β€” the working toolkit + +Derived members of `Complexity.Cobham`: the operations a Turing-machine +interpreter written inside the algebra needs. Each is a single limited recursion +on notation, or a finite composition of such. + +Two of these carry the weight. `dispatch` shows that branching is free: the step +functions of `recNotation` are already selected by the bit being peeled, so a +one-step recursion on `v 0` *is* an if-then-else on its leading bit. +`dropPrefix` shows how to move an argument that changes along a recursion β€” +`recNotation` fixes its parameters, so the changing value has to live in the +recursion's *value*, and iterating `tail` there gives `drop`. With `drop` in +hand, `takePrefix` reads off successive bits, and fixed-width pairing with +projections follows. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The class respects pointwise equality of functions. Useful because the constructors +of `Cobham` produce syntactically specific lambda terms. -/ +theorem of_eq {n : β„•} {f g : (Fin n β†’ List Bool) β†’ List Bool} (hf : Cobham f) + (h : βˆ€ v, f v = g v) : Cobham g := + (funext h : f = g) β–Έ hf + +/-- Every constant function is in the class: build the constant string bit by bit from +`empty` and the successors. -/ +theorem const {n : β„•} (s : List Bool) : Cobham fun _ : Fin n β†’ List Bool => s := by + induction s with + | nil => exact .empty + | cons b s ih => exact (Cobham.comp (.bit b) fun _ : Fin 1 => ih).of_eq fun v => rfl + +/-- Composition with two inner functions, packaged for readability: the +constructor's `Fin`-indexed family is awkward to supply when the two components +differ. -/ +theorem compβ‚‚ {n : β„•} {f : (Fin 2 β†’ List Bool) β†’ List Bool} + {gβ‚€ g₁ : (Fin n β†’ List Bool) β†’ List Bool} + (hf : Cobham f) (hβ‚€ : Cobham gβ‚€) (h₁ : Cobham g₁) : + Cobham fun v : Fin n β†’ List Bool => f ![gβ‚€ v, g₁ v] := by + refine (Cobham.comp hf (gs := ![gβ‚€, g₁]) ?_).of_eq fun v => ?_ + Β· intro i; fin_cases i <;> assumption + Β· congr 1 + funext i + fin_cases i <;> rfl + +/-- Composition with three inner functions. -/ +theorem comp₃ {n : β„•} {f : (Fin 3 β†’ List Bool) β†’ List Bool} + {gβ‚€ g₁ gβ‚‚ : (Fin n β†’ List Bool) β†’ List Bool} + (hf : Cobham f) (hβ‚€ : Cobham gβ‚€) (h₁ : Cobham g₁) (hβ‚‚ : Cobham gβ‚‚) : + Cobham fun v : Fin n β†’ List Bool => f ![gβ‚€ v, g₁ v, gβ‚‚ v] := by + refine (Cobham.comp hf (gs := ![gβ‚€, g₁, gβ‚‚]) ?_).of_eq fun v => ?_ + Β· intro i; fin_cases i <;> assumption + Β· congr 1 + funext i + fin_cases i <;> rfl + +/-- Concatenation is in the class, by limited recursion on notation on the first +argument with bound `smash (true :: x) (true :: y)`. -/ +theorem append : Cobham fun v : Fin 2 β†’ List Bool => v 0 ++ v 1 := by + -- Recursion on notation computing `x ++ y`: base `y`, step `b :: Β·` on the + -- recursive value. + have hrec : βˆ€ (x : List Bool) (v : Fin 1 β†’ List Bool), + recNotation (fun v : Fin 1 β†’ List Bool => v 0) + (fun w : Fin 3 β†’ List Bool => false :: w 1) + (fun w : Fin 3 β†’ List Bool => true :: w 1) x v = x ++ v 0 := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [ih] + -- The bit-prepending step functions are in the class. + have hstep : βˆ€ b : Bool, Cobham fun w : Fin 3 β†’ List Bool => b :: w 1 := fun b => + (Cobham.comp (.bit b) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl + -- The length bound `smash (true :: x) (true :: y)` is in the class. + have hj : Cobham fun w : Fin 2 β†’ List Bool => + Complexity.smash (true :: w 0) (true :: w 1) := + (Cobham.comp .smash fun i : Fin 2 => + (Cobham.comp (.bit true) fun _ : Fin 1 => .proj i).of_eq fun v => rfl).of_eq + fun v => rfl + refine (Cobham.boundedRec (.proj 0) (hstep false) (hstep true) hj ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec] + have h1 : (Fin.cons x v : Fin 2 β†’ List Bool) 1 = v 0 := rfl + have hexp : (x.length + 1) * ((v 0).length + 1) = + x.length * (v 0).length + x.length + (v 0).length + 1 := by ring + simp only [Fin.cons_zero, h1, smash_length, List.length_append, List.length_cons] + omega + Β· rw [hrec] + rfl + +/-- Concatenation of two members of the class is a member of the class. -/ +theorem appendFn {n : β„•} {gβ‚€ g₁ : (Fin n β†’ List Bool) β†’ List Bool} + (hβ‚€ : Cobham gβ‚€) (h₁ : Cobham g₁) : + Cobham fun v : Fin n β†’ List Bool => gβ‚€ v ++ g₁ v := + (compβ‚‚ append hβ‚€ h₁).of_eq fun v => by simp + +/-- The self-delimiting pairing `pair x y = delimit x ++ y` is in the class, by +limited recursion on notation on `x`: each peeled bit is doubled onto the +recursive value, and the base case emits the separator `01` followed by `y`. The +bound is exact β€” `|pair x y| = |x ++ x| + |y ++ [0,1]|`. -/ +theorem pairing : Cobham fun v : Fin 2 β†’ List Bool => pair (v 0) (v 1) := by + have hrec : βˆ€ (x : List Bool) (v : Fin 1 β†’ List Bool), + recNotation (fun u : Fin 1 β†’ List Bool => false :: true :: u 0) + (fun w : Fin 3 β†’ List Bool => false :: false :: w 1) + (fun w : Fin 3 β†’ List Bool => true :: true :: w 1) x v + = pair x (v 0) := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [pair_cons_eq, ih] + have hg : Cobham fun u : Fin 1 β†’ List Bool => false :: true :: u 0 := + (Cobham.comp (.bit false) fun _ : Fin 1 => + (Cobham.comp (.bit true) fun _ : Fin 1 => .proj 0).of_eq fun v => rfl).of_eq + fun v => rfl + have hstep : βˆ€ b : Bool, Cobham fun w : Fin 3 β†’ List Bool => b :: b :: w 1 := fun b => + (Cobham.comp (.bit b) fun _ : Fin 1 => + (Cobham.comp (.bit b) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl).of_eq + fun v => rfl + have hj : Cobham fun w : Fin 2 β†’ List Bool => + (w 0 ++ w 0) ++ (w 1 ++ [false, true]) := + appendFn (appendFn (.proj 0) (.proj 0)) + (appendFn (.proj 1) (Cobham.const [false, true])) + refine (Cobham.boundedRec hg (hstep false) (hstep true) hj ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec] + have h0 : (Fin.cons x v : Fin 2 β†’ List Bool) 0 = x := rfl + have h1 : (Fin.cons x v : Fin 2 β†’ List Bool) 1 = v 0 := rfl + simp only [h0, h1, pair_length, List.length_append, List.length_cons, + List.length_nil] + omega + Β· rw [hrec] + rfl + +/-- Dropping the leading bit is in the class, by limited recursion on notation: +on `b :: x` both step functions return the peeled tail `x`, and the argument +itself bounds the result. -/ +theorem tail : Cobham fun v : Fin 1 β†’ List Bool => (v 0).tail := by + have hrec : βˆ€ (x : List Bool) (v : Fin 0 β†’ List Bool), + recNotation (fun _ : Fin 0 β†’ List Bool => ([] : List Bool)) + (fun w : Fin 2 β†’ List Bool => w 0) (fun w : Fin 2 β†’ List Bool => w 0) x v + = x.tail := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + refine (Cobham.boundedRec .empty (.proj 0) (.proj 0) (.proj 0) ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec, Fin.cons_zero] + cases x <;> simp + Β· rw [hrec] + +/-- **Bit dispatch is in the class.** `caseBit (v 0) (v 1) (v 2)` is a single +limited recursion on notation over `v 0`: the recursion's own bit-selected step +functions do the branching, projecting out `v 1` or `v 2`, and the concatenation +of the two branches bounds the result. -/ +theorem dispatch : Cobham fun v : Fin 3 β†’ List Bool => + caseBit (v 0) (v 1) (v 2) := by + -- On `b :: x` the step argument is `⟨x, rec, v 1, v 2⟩`, so the branches are + -- projections 3 (bit `0`) and 2 (bit `1`). + have hrec : βˆ€ (x : List Bool) (v : Fin 2 β†’ List Bool), + recNotation (fun _ : Fin 2 β†’ List Bool => ([] : List Bool)) + (fun w : Fin 4 β†’ List Bool => w 3) (fun w : Fin 4 β†’ List Bool => w 2) x v + = caseBit x (v 0) (v 1) := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + -- The bound: the two branches concatenated. + have hj : Cobham fun w : Fin 3 β†’ List Bool => w 1 ++ w 2 := + (Cobham.comp Cobham.append fun i : Fin 2 => Cobham.proj i.succ).of_eq fun v => rfl + refine (Cobham.boundedRec .empty (.proj 3) (.proj 2) hj ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec] + exact caseBit_length_le _ _ _ + Β· rw [hrec] + rfl + +/-- **Dropping a prefix of a given length is in the class.** `v 1` is advanced by +one `tail` per bit of the ruler `v 0`: the recursion applies `tail` to its own +recursive value, so the changing argument lives in the recursion's value rather +than in its parameters β€” which is what makes it expressible at all. -/ +theorem dropPrefix : + Cobham fun v : Fin 2 β†’ List Bool => (v 1).drop (v 0).length := by + have hrec : βˆ€ (r : List Bool) (u : Fin 1 β†’ List Bool), + recNotation (fun u : Fin 1 β†’ List Bool => u 0) + (fun w : Fin 3 β†’ List Bool => (w 1).tail) + (fun w : Fin 3 β†’ List Bool => (w 1).tail) r u + = (u 0).drop r.length := by + intro r u + induction r with + | nil => rfl + | cons b r ih => cases b <;> simp [ih, List.tail_drop] + have hstep : Cobham fun w : Fin 3 β†’ List Bool => (w 1).tail := + (Cobham.comp Cobham.tail fun _ : Fin 1 => Cobham.proj 1).of_eq fun v => rfl + refine (Cobham.boundedRec (.proj 0) hstep hstep (.proj 1) ?_).of_eq fun v => ?_ + Β· intro r u + rw [hrec, show (Fin.cons r u : Fin 2 β†’ List Bool) 1 = u 0 from rfl] + simp + Β· rw [hrec] + rfl + +/-- One more bit of a prefix is the prefix plus the first bit of what remains. -/ +private theorem take_succ_eq (x : List Bool) (n : β„•) : + x.take (n + 1) = x.take n ++ (x.drop n).take 1 := by + induction n generalizing x with + | zero => simp + | succ n ih => + cases x with + | nil => simp + | cons a x => simpa using ih x + +/-- **Taking a prefix of a given length is in the class.** Each bit of the ruler +`v 0` appends one more bit of `v 1`, read off by dispatching on the head of what +is still undropped β€” so `dropPrefix` and `dispatch` together give `take`. -/ +theorem takePrefix : + Cobham fun v : Fin 2 β†’ List Bool => (v 1).take (v 0).length := by + have hbit : βˆ€ z : List Bool, caseBit z [true] [false] = z.take 1 := by + intro z; cases z with + | nil => rfl + | cons b z => cases b <;> rfl + have hrec : βˆ€ (r : List Bool) (u : Fin 1 β†’ List Bool), + recNotation (fun _ : Fin 1 β†’ List Bool => ([] : List Bool)) + (fun w : Fin 3 β†’ List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false]) + (fun w : Fin 3 β†’ List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false]) r u + = (u 0).take r.length := by + intro r u + induction r with + | nil => rfl + | cons b r ih => + cases b <;> + Β· show (recNotation _ _ _ r u) ++ caseBit _ _ _ = _ + rw [ih, hbit] + exact (take_succ_eq (u 0) r.length).symm + -- The step: append the next bit of `u 0`, located by dropping `|r|` bits. + have hdrop : Cobham fun w : Fin 3 β†’ List Bool => (w 2).drop (w 0).length := + (compβ‚‚ dropPrefix (.proj 0) (.proj 2)).of_eq fun v => by simp + have hbitFn : Cobham fun w : Fin 3 β†’ List Bool => + caseBit ((w 2).drop (w 0).length) [true] [false] := + (comp₃ dispatch hdrop (Cobham.const [true]) (Cobham.const [false])).of_eq + fun v => by simp + have hstep : Cobham fun w : Fin 3 β†’ List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false] := + appendFn (.proj 1) hbitFn + refine (Cobham.boundedRec .empty hstep hstep (.proj 1) ?_).of_eq fun v => ?_ + Β· intro r u + rw [hrec, show (Fin.cons r u : Fin 2 β†’ List Bool) 1 = u 0 from rfl] + simp + Β· rw [hrec] + rfl + +/-- **Total bit dispatch is in the class.** Same recursion as `dispatch`, except +the base case returns the `false` branch instead of the empty string β€” so the +empty string reads as `false` and every flag is genuinely one bit. -/ +theorem dispatchβ‚€ : Cobham fun v : Fin 3 β†’ List Bool => + caseBitβ‚€ (v 0) (v 1) (v 2) := by + have hrec : βˆ€ (x : List Bool) (v : Fin 2 β†’ List Bool), + recNotation (fun u : Fin 2 β†’ List Bool => u 1) + (fun w : Fin 4 β†’ List Bool => w 3) (fun w : Fin 4 β†’ List Bool => w 2) x v + = caseBitβ‚€ x (v 0) (v 1) := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + have hj : Cobham fun w : Fin 3 β†’ List Bool => w 1 ++ w 2 := + (Cobham.comp Cobham.append fun i : Fin 2 => Cobham.proj i.succ).of_eq fun v => rfl + refine (Cobham.boundedRec (.proj 1) (.proj 3) (.proj 2) hj ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec] + exact caseBitβ‚€_length_le _ _ _ + Β· rw [hrec] + rfl + +/-- Applying `tail` to a member of the class. -/ +theorem tailFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => (g v).tail := + (Cobham.comp Cobham.tail fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- Total if-then-else on a flag is in the class. -/ +theorem iteFn {n : β„•} {gc gx gy : (Fin n β†’ List Bool) β†’ List Bool} + (hc : Cobham gc) (hx : Cobham gx) (hy : Cobham gy) : + Cobham fun v : Fin n β†’ List Bool => caseBitβ‚€ (gc v) (gx v) (gy v) := + (comp₃ dispatchβ‚€ hc hx hy).of_eq fun v => by simp + +/-- The flag connectives are in the class: each is one `dispatchβ‚€`. -/ +theorem andFn {n : β„•} {gβ‚€ g₁ : (Fin n β†’ List Bool) β†’ List Bool} + (hβ‚€ : Cobham gβ‚€) (h₁ : Cobham g₁) : + Cobham fun v : Fin n β†’ List Bool => andBit (gβ‚€ v) (g₁ v) := + iteFn hβ‚€ (iteFn h₁ (Cobham.const [true]) (Cobham.const [false])) + (Cobham.const [false]) + +/-- Disjunction of flags is in the class. -/ +theorem orFn {n : β„•} {gβ‚€ g₁ : (Fin n β†’ List Bool) β†’ List Bool} + (hβ‚€ : Cobham gβ‚€) (h₁ : Cobham g₁) : + Cobham fun v : Fin n β†’ List Bool => orBit (gβ‚€ v) (g₁ v) := + iteFn hβ‚€ (Cobham.const [true]) + (iteFn h₁ (Cobham.const [true]) (Cobham.const [false])) + +/-- Negation of a flag is in the class. -/ +theorem notFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => notBit (g v) := + iteFn h (Cobham.const [false]) (Cobham.const [true]) + +/-- **Bit extraction is in the class**: drop to the marked position and dispatch +on what is left. -/ +theorem bitAtFn : Cobham fun v : Fin 2 β†’ List Bool => bitAt (v 0) (v 1) := + (comp₃ dispatchβ‚€ dropPrefix (Cobham.const [true]) (Cobham.const [false])).of_eq + fun v => by simp [bitAt] + +/-- Extracting the leading bit of a member of the class, as a flag. -/ +theorem headFlagFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => bitAt [] (g v) := + (compβ‚‚ bitAtFn (Cobham.const []) h).of_eq fun v => by simp + +/-- **The nonemptiness flag is in the class.** This is the one consumer of the +*partial* dispatcher: both branches are `[true]`, so the flag is `[true]` exactly +when there is a bit to read and `[]` otherwise. -/ +theorem nonemptyFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => nonemptyFlag (g v) := + (comp₃ dispatch h (Cobham.const [true]) (Cobham.const [true])).of_eq + fun v => by simp [nonemptyFlag] + +/-- **Matching against a fixed constant is in the class.** For each constant the +test unfolds into finitely many bit comparisons joined by `andFn`, so this is a +finite composition β€” the meta-level induction is on the constant, not a +recursion inside the algebra. -/ +theorem matchPrefixFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) + (c : List Bool) : + Cobham fun v : Fin n β†’ List Bool => matchPrefix c (g v) := by + induction c generalizing g with + | nil => exact (Cobham.const [true]).of_eq fun v => rfl + | cons b c ih => + have htail := ih (tailFn h) + have hhead : Cobham fun v : Fin n β†’ List Bool => + bif b then bitAt [] (g v) else notBit (bitAt [] (g v)) := by + cases b + Β· exact (notFn (headFlagFn h)).of_eq fun v => rfl + Β· exact (headFlagFn h).of_eq fun v => rfl + exact (andFn (nonemptyFn h) (andFn hhead htail)).of_eq fun v => rfl + +/-- Taking a prefix of one member of the class at the width of another. -/ +theorem takeFn {n : β„•} {gr gx : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n β†’ List Bool => (gx v).take (gr v).length := + (compβ‚‚ takePrefix hr hx).of_eq fun v => by simp + +/-- Dropping a prefix of one member of the class at the width of another. -/ +theorem dropFn {n : β„•} {gr gx : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n β†’ List Bool => (gx v).drop (gr v).length := + (compβ‚‚ dropPrefix hr hx).of_eq fun v => by simp + +/-- A block of `|x|` zeros is in the class, by limited recursion on notation: +each peeled bit prepends one `0` to the recursive value, and the argument bounds +the result. -/ +theorem lengthPad : + Cobham fun v : Fin 1 β†’ List Bool => List.replicate (v 0).length false := by + have hrec : βˆ€ (x : List Bool) (v : Fin 0 β†’ List Bool), + recNotation (fun _ : Fin 0 β†’ List Bool => ([] : List Bool)) + (fun w : Fin 2 β†’ List Bool => false :: w 1) + (fun w : Fin 2 β†’ List Bool => false :: w 1) x v + = List.replicate x.length false := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [ih, List.replicate_succ] + have hstep : Cobham fun w : Fin 2 β†’ List Bool => false :: w 1 := + (Cobham.comp (.bit false) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl + refine (Cobham.boundedRec .empty hstep hstep (.proj 0) ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec, Fin.cons_zero] + simp + Β· rw [hrec] + +/-- A block of zeros as wide as a member of the class. -/ +theorem zeroBlockFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => List.replicate (g v).length false := + (Cobham.comp lengthPad fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- Concatenating `i` copies of a member of the class β€” a finite composition, so +the induction is at the meta level. -/ +theorem repeatFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + βˆ€ i : β„•, Cobham fun v : Fin n β†’ List Bool => (List.replicate i (g v)).flatten + | 0 => Cobham.empty.of_eq fun _ => rfl + | i + 1 => (appendFn h (repeatFn h i)).of_eq fun _ => by + simp [List.replicate_succ] + +/-- **Block addressing is in the class.** With every field of a configuration +padded to the ruler's width, field `i` is `takeFn` after dropping `i` rulers β€” +and `i` is a fixed natural number, so the drop is a finite concatenation. -/ +theorem blockFn {n : β„•} {gr gx : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hx : Cobham gx) (i : β„•) : + Cobham fun v : Fin n β†’ List Bool => blockAt (gr v) (gx v) i := + (takeFn hr (dropFn (repeatFn hr i) hx)).of_eq fun v => by + rw [blockAt] + congr 2 + simp + +/-- **Fixed-width padding is in the class.** With every field of a simulated +configuration padded to one ruler's width, field `i` is recovered by dropping `i` +rulers and taking one β€” so no self-delimiting decoder is ever needed inside the +algebra. -/ +theorem padFn {n : β„•} {gr gx : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n β†’ List Bool => padTo (gr v) (gx v) := + (takeFn hr (appendFn hx (zeroBlockFn hr))).of_eq fun _ => rfl + +/-- **Finite table dispatch is in the class.** Matching a member of the class +against each of finitely many constant patterns in turn, taking the first +branch that fires and a default otherwise, is a finite chain of `iteFn`s. + +This is exactly the shape of a Turing machine's transition function: the patterns +are the (state, symbols-read) combinations, of which there are finitely many for +a fixed machine, and the branches assemble the successor configuration. -/ +theorem tableFn {n : β„•} {g d : (Fin n β†’ List Bool) β†’ List Bool} + (hg : Cobham g) (hd : Cobham d) + (table : List (List Bool Γ— ((Fin n β†’ List Bool) β†’ List Bool))) + (hbranch : βˆ€ p ∈ table, Cobham p.2) : + Cobham fun v : Fin n β†’ List Bool => + table.foldr (fun p acc => caseBitβ‚€ (matchPrefix p.1 (g v)) (p.2 v) acc) + (d v) := by + induction table with + | nil => exact hd + | cons p t ih => + exact iteFn (matchPrefixFn hg p.1) (hbranch p (by simp)) + (ih fun q hq => hbranch q (by simp [hq])) + +/-- **A table of constant patterns is a case analysis.** If some entry's pattern +prefixes the key, and every entry whose pattern prefixes the key carries the same +value, then the fold returns that value β€” regardless of the order the entries +appear in. + +Phrasing it as "all matching entries agree" rather than "exactly one matches" +avoids having to prove the patterns pairwise distinct: for a transition table the +patterns *are* distinct, but agreement is the weaker and more convenient +obligation. -/ +theorem foldr_table_eq (g d val : List Bool) : + βˆ€ table : List (List Bool Γ— List Bool), + (βˆƒ p ∈ table, p.1 <+: g) β†’ + (βˆ€ q ∈ table, q.1 <+: g β†’ q.2 = val) β†’ + table.foldr (fun q acc => caseBitβ‚€ (matchPrefix q.1 g) q.2 acc) d = val := by + intro table + induction table with + | nil => rintro ⟨p, hp, -⟩ -; simp at hp + | cons a rest ih => + rintro ⟨p, hp, hpre⟩ hall + rcases Decidable.em (a.1 <+: g) with hm | hm + Β· rw [List.foldr_cons, (matchPrefix_eq_true_iff a.1 g).mpr hm, caseBitβ‚€_cons, + Bool.cond_true] + exact hall a (by simp) hm + Β· have hmf : matchPrefix a.1 g = [false] := by + rcases matchPrefix_flag a.1 g with h | h + Β· exact absurd ((matchPrefix_eq_true_iff a.1 g).mp h) hm + Β· exact h + rw [List.foldr_cons, hmf, caseBitβ‚€_cons, Bool.cond_false] + refine ih ⟨p, ?_, hpre⟩ fun q hq => hall q (by simp [hq]) + rcases List.mem_cons.mp hp with rfl | hp' + Β· exact absurd hpre hm + Β· exact hp' + +/-! ### Clocked iteration + +The engine of the completeness direction: a machine is simulated by iterating its +one-step transition function a polynomial number of times, and both halves of +that β€” the iteration and the polynomial clock β€” are cheap inside the algebra. -/ + +/-- **Bounded iteration is in the class.** Iterating a step function once per bit +of a clock string is a single limited recursion on notation: the recursion +ignores *which* bit it peels and simply applies the step to its own recursive +value, so `hβ‚€ = h₁ = f ∘ Fin.tail`. The clock's length is the iteration count, +which is why polynomial clocks (`exists_pow_clock`) give polynomially many +steps. -/ +theorem iterFn {n : β„•} {e : (Fin n β†’ List Bool) β†’ List Bool} + {f j : (Fin (n + 1) β†’ List Bool) β†’ List Bool} + (he : Cobham e) (hf : Cobham f) (hj : Cobham j) + (hbound : βˆ€ (c : List Bool) (v : Fin n β†’ List Bool), + ((fun s => f (Fin.cons s v))^[c.length] (e v)).length + ≀ (j (Fin.cons c v)).length) : + Cobham fun v : Fin (n + 1) β†’ List Bool => + (fun s => f (Fin.cons s (Fin.tail v)))^[(v 0).length] (e (Fin.tail v)) := by + have hstep : Cobham fun w : Fin (n + 1 + 1) β†’ List Bool => f (Fin.tail w) := + (Cobham.comp hf fun i : Fin (n + 1) => Cobham.proj i.succ).of_eq fun w => rfl + have hrec : βˆ€ (c : List Bool) (v : Fin n β†’ List Bool), + recNotation e (fun w : Fin (n + 1 + 1) β†’ List Bool => f (Fin.tail w)) + (fun w : Fin (n + 1 + 1) β†’ List Bool => f (Fin.tail w)) c v + = (fun s => f (Fin.cons s v))^[c.length] (e v) := by + intro c v + induction c with + | nil => rfl + | cons b c ih => + rw [List.length_cons, Function.iterate_succ_apply', ← ih] + cases b <;> simp [Fin.tail_cons] + refine (Cobham.boundedRec he hstep hstep hj ?_).of_eq fun v => ?_ + Β· intro c v + rw [hrec] + exact hbound c v + Β· rw [hrec] + +/-- **Clocks.** For every constant `c` and exponent `d` there is a member of the +class whose value on `v` is at least `c Β· (|v 0| + 1) ^ d` bits long β€” built from +constants and `smash`, which is exactly what `smash` is for. -/ +theorem exists_pow_clock (c d : β„•) : + βˆƒ f : (Fin 1 β†’ List Bool) β†’ List Bool, Cobham f ∧ + βˆ€ v : Fin 1 β†’ List Bool, c * ((v 0).length + 1) ^ d ≀ (f v).length := by + induction d with + | zero => + exact ⟨fun _ => List.replicate c false, Cobham.const _, fun v => by simp⟩ + | succ d ih => + obtain ⟨f, hf, hlen⟩ := ih + have hsucc : Cobham fun v : Fin 1 β†’ List Bool => false :: v 0 := + (Cobham.comp (.bit false) fun _ : Fin 1 => .proj 0).of_eq fun v => rfl + refine ⟨fun v => Complexity.smash (f v) (false :: v 0), + (compβ‚‚ Cobham.smash hf hsucc).of_eq fun v => by simp, fun v => ?_⟩ + have h1 := hlen v + calc c * ((v 0).length + 1) ^ (d + 1) + = (c * ((v 0).length + 1) ^ d) * ((v 0).length + 1) := by ring + _ ≀ (f v).length * (false :: v 0).length := by + exact Nat.mul_le_mul h1 (by simp) + _ = _ := by simp + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean new file mode 100644 index 0000000000..5356e65cd6 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Vec + +/-! +# What the block scanners compute β€” proof internals + +The two total parsers of a self-delimiting block β€” `Cobham.fstBlock` decodes the +leading block's payload, `Cobham.sndBlock` returns the suffix after it β€” and the +control states their scanners share. `Complexity.pairSplitCoreTM` handles only +valid pair inputs, so the total decoders need machines of their own; those are +`Internal.SndBlock`, `Internal.FstBlock` and `Internal.Cat`, one per machine. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- Decode the payload of the leading self-delimiting block: read doubled bits +until the `[false, true]` separator. On a valid pair `pair x y` this +returns `x` (see `fstBlock_pair`); on malformed input it returns the bits decoded +so far. This total, incremental form is what the `fstBlockTM` scanner computes. -/ +def fstBlock : List Bool β†’ List Bool + | false :: false :: z => false :: fstBlock z + | true :: true :: z => true :: fstBlock z + | _ => [] + +/-- Take the suffix after the leading self-delimiting block (the second `unpair?` +component), or `[]` if the input is not a valid block. On `encodeVec` of a +nonempty vector this returns the head component `v 0`. -/ +def sndBlock (z : List Bool) : List Bool := + match unpair? z with + | some (_, s) => s + | none => [] + +@[simp] theorem fstBlock_pair (x y : List Bool) : fstBlock (pair x y) = x := by + induction x with + | nil => rfl + | cons b x ih => cases b <;> (rw [pair_cons_eq]; simp [fstBlock, ih]) + +@[simp] theorem sndBlock_pair (x y : List Bool) : sndBlock (pair x y) = y := by + simp [sndBlock] + +/-- Stripping the head component of an encoded vector yields the encoded tail. +(Not a `simp` lemma: `simp` already reaches this via `encodeVec_succ` and +`fstBlock_pair`.) -/ +theorem fstBlock_encodeVec_succ {n : β„•} (v : Fin (n + 1) β†’ List Bool) : + fstBlock (encodeVec v) = encodeVec (Fin.tail v) := by + simp + +/-- The suffix of an encoded vector is its head component. +(Not a `simp` lemma: `simp` already reaches this via `encodeVec_succ` and +`sndBlock_pair`.) -/ +theorem sndBlock_encodeVec_succ {n : β„•} (v : Fin (n + 1) β†’ List Bool) : + sndBlock (encodeVec v) = v 0 := by + simp + +/-- Control states of the block-decoding scanners. -/ +inductive ScanPhase where + | skip | scanA | scanBfalse | scanBtrue | emit | done + deriving DecidableEq + +instance : Fintype ScanPhase where + elems := {.skip, .scanA, .scanBfalse, .scanBtrue, .emit, .done} + complete := fun x => by cases x <;> simp + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean new file mode 100644 index 0000000000..9910c1262a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.List.Basic + +/-! +# Blocks, flags, and bit dispatch β€” proof internals + +The string toolkit the simulation of a machine inside Cobham's algebra is +written in. None of it appears in the statement of `CobhamFP_eq_FP`; it is the +vocabulary of the proof. + +* *Dispatch* β€” `Complexity.caseBit` selects on a leading bit and returns nothing + on the empty string; `Complexity.caseBitβ‚€` reads "no bit" as `false`. Both are + needed: the partial one to read off the end of a string, the total one so that + a *flag* (a one-bit string) is always genuinely one bit. +* *Flags* β€” `Complexity.andBit`, `orBit`, `notBit`, `bitAt`, + `Complexity.nonemptyFlag` and `Complexity.matchPrefix`, the Boolean layer a + machine's finite transition table is written in. `matchPrefix` unfolds into + `|c|` bit tests for each fixed constant `c`, so it is a *finite* composition β€” + the induction is at the meta level, not inside the algebra. +* *Blocks* β€” `Complexity.padTo` pads a field to one ruler's width and + `Complexity.blockAt` reads field `i` back, so a packed configuration needs no + self-delimiting decoder inside the algebra. The padding algebra + (`padTo_append_padTo`, `take_padTo`, `drop_padTo`, `padTo_drop`) says that + re-padding commutes with the edits a simulated step performs. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **Bit dispatch**: select `x` or `y` according to the leading bit of `s`, +returning the empty string when `s` is empty. + +This is the branching primitive of the algebra. It is definable by a single +limited recursion on notation (`Cobham.caseBit`) because the step functions of +`recNotation` are already selected by the bit being peeled β€” dispatching on a bit +costs nothing beyond the recursion that is there anyway. -/ +def caseBit (s x y : List Bool) : List Bool := + match s with + | [] => [] + | b :: _ => bif b then x else y + +@[simp] theorem caseBit_nil (x y : List Bool) : caseBit [] x y = [] := rfl + +@[simp] theorem caseBit_cons (b : Bool) (s x y : List Bool) : + caseBit (b :: s) x y = bif b then x else y := rfl + +/-- Bit dispatch never returns more than its two branches together. -/ +theorem caseBit_length_le (s x y : List Bool) : + (caseBit s x y).length ≀ (x ++ y).length := by + cases s with + | nil => simp + | cons b s => cases b <;> simp + +/-- **Total bit dispatch**: like `caseBit`, but the empty string selects the +`false` branch instead of returning nothing. + +Both variants are needed. `caseBit` is the *partial* reader used when running off +the end of a string must produce nothing (`Cobham.takePrefix` reads bits this +way); `caseBitβ‚€` is the *total* one used for Boolean logic, where "no bit" has to +mean `false` so that flags are always exactly `[true]` or `[false]`. -/ +def caseBitβ‚€ (s x y : List Bool) : List Bool := + match s with + | [] => y + | b :: _ => bif b then x else y + +@[simp] theorem caseBitβ‚€_nil (x y : List Bool) : caseBitβ‚€ [] x y = y := rfl + +@[simp] theorem caseBitβ‚€_cons (b : Bool) (s x y : List Bool) : + caseBitβ‚€ (b :: s) x y = bif b then x else y := rfl + +/-- Total bit dispatch never returns more than its two branches together. -/ +theorem caseBitβ‚€_length_le (s x y : List Bool) : + (caseBitβ‚€ s x y).length ≀ (x ++ y).length := by + cases s with + | nil => simp + | cons b s => cases b <;> simp + +/-! ### Flags + +A *flag* is a one-bit string, `[true]` or `[false]`. The connectives below are +each one `caseBitβ‚€`, so they are in the algebra as soon as `caseBitβ‚€` is, and +they are how the finite case analysis of a machine's transition function gets +written inside it. Because they are built on the *total* dispatcher, every flag +these produce is genuinely one bit β€” never empty β€” so they compose. -/ + +/-- Conjunction of flags. -/ +def andBit (x y : List Bool) : List Bool := + caseBitβ‚€ x (caseBitβ‚€ y [true] [false]) [false] + +/-- Disjunction of flags. -/ +def orBit (x y : List Bool) : List Bool := + caseBitβ‚€ x [true] (caseBitβ‚€ y [true] [false]) + +/-- Negation of a flag. -/ +def notBit (x : List Bool) : List Bool := caseBitβ‚€ x [false] [true] + +/-- The bit of `x` at the position marked by the ruler `r`, as a flag; `false` +when the position is past the end of `x`. -/ +def bitAt (r x : List Bool) : List Bool := + caseBitβ‚€ (x.drop r.length) [true] [false] + +@[simp] theorem bitAt_nil_left (x : List Bool) : + bitAt [] x = caseBitβ‚€ x [true] [false] := by simp [bitAt] + +/-- A flag is exactly one bit long. -/ +theorem bitAt_length (r x : List Bool) : (bitAt r x).length = 1 := by + rw [bitAt] + rcases hx : x.drop r.length with _ | ⟨b, z⟩ + Β· simp + Β· cases b <;> simp + +/-- Pad (or truncate) `x` to exactly the width of the ruler `r`, filling with +zeros. + +Fixed-width blocks are how a simulated machine's configuration is packed into the +single string a member of the class returns: every field occupies `|r|` bits, so +field `i` is recovered by dropping `i` rulers and taking one β€” no self-delimiting +decoder is needed inside the algebra. -/ +def padTo (r x : List Bool) : List Bool := + (x ++ List.replicate r.length false).take r.length + +/-- A padded block always has exactly the ruler's width. -/ +@[simp] theorem padTo_length (r x : List Bool) : (padTo r x).length = r.length := by + rw [padTo, List.length_take, List.length_append, List.length_replicate] + omega + +/-- Padding a short string appends zeros. -/ +theorem padTo_eq_append (r x : List Bool) (h : x.length ≀ r.length) : + padTo r x = x ++ List.replicate (r.length - x.length) false := by + rw [padTo] + simp [List.take_append, List.take_replicate, List.take_of_length_le h] + +/-- The `i`-th block of `x`, when `x` is a concatenation of blocks each as wide +as the ruler `r`. -/ +def blockAt (r x : List Bool) (i : β„•) : List Bool := + (x.drop (i * r.length)).take r.length + +/-- Block zero of a block-aligned string is its first block. -/ +@[simp] theorem blockAt_zero_append (r a x : List Bool) (h : a.length = r.length) : + blockAt r (a ++ x) 0 = a := by + rw [blockAt, Nat.zero_mul, List.drop_zero, ← h, List.take_left] + +/-- Later blocks of a block-aligned string are the blocks of its tail. -/ +theorem blockAt_succ_append (r a x : List Bool) (h : a.length = r.length) (i : β„•) : + blockAt r (a ++ x) (i + 1) = blockAt r x i := by + have hd : (a ++ x).drop (i * a.length + a.length) = x.drop (i * a.length) := by + rw [Nat.add_comm] + simp + rw [blockAt, blockAt, Nat.succ_mul, ← h, hd] + +/-! ### Padding algebra + +A simulated step reads a padded block, edits it, and re-pads. These three lemmas +say that the padding is invisible to that: re-padding commutes with the edits, so +the encoded step can be reasoned about on raw contents. -/ + +/-- Extra zero padding is invisible to `padTo`. -/ +theorem padTo_append_replicate (r z : List Bool) (m : β„•) : + padTo r (z ++ List.replicate m false) = padTo r z := by + rw [padTo, padTo, List.append_assoc, ← List.replicate_add, List.take_append, + List.take_append, List.take_replicate, List.take_replicate] + congr 2 + omega + +/-- Re-padding a padded block is the same as padding its raw content. -/ +theorem padTo_append_padTo (r y x : List Bool) (hx : x.length ≀ r.length) : + padTo r (y ++ padTo r x) = padTo r (y ++ x) := by + rw [padTo_eq_append r x hx, ← List.append_assoc, padTo_append_replicate] + +/-- Taking from within the content of a padded block ignores the padding. -/ +theorem take_padTo (r x : List Bool) (n : β„•) (hn : n ≀ x.length) + (hx : x.length ≀ r.length) : + (padTo r x).take n = x.take n := by + rw [padTo, List.take_take, Nat.min_eq_left (by omega : n ≀ r.length), + List.take_append, Nat.sub_eq_zero_of_le hn, List.take_zero, List.append_nil] + +/-- Dropping from a padded block leaves the padding trailing at the end. -/ +theorem drop_padTo (r x : List Bool) (n : β„•) (hn : n ≀ x.length) + (hx : x.length ≀ r.length) : + (padTo r x).drop n = x.drop n ++ List.replicate (r.length - x.length) false := by + rw [padTo_eq_append r x hx, List.drop_append, Nat.sub_eq_zero_of_le hn, + List.drop_zero] + +/-- Dropping from a padded block and re-padding ignores the padding. -/ +theorem padTo_drop (r x : List Bool) (n : β„•) (hn : n ≀ x.length) + (hx : x.length ≀ r.length) : + padTo r ((padTo r x).drop n) = padTo r (x.drop n) := by + rw [padTo_eq_append r x hx, List.drop_append, Nat.sub_eq_zero_of_le hn, + List.drop_zero, padTo_append_replicate] + +/-- **Reading a field out of a block-aligned record.** When `bs` is a list of +blocks all as wide as the ruler `r`, block `i` of their concatenation is `bs[i]`. +This is what makes `Cobham.blockFn` a field accessor. -/ +theorem blockAt_flatten (r : List Bool) : + βˆ€ (bs : List (List Bool)), (βˆ€ b ∈ bs, b.length = r.length) β†’ + βˆ€ (i : β„•) (hi : i < bs.length), blockAt r bs.flatten i = bs[i] := by + intro bs + induction bs with + | nil => intro _ i hi; simp at hi + | cons b bs ih => + intro hb i hi + cases i with + | zero => + rw [List.flatten_cons] + exact blockAt_zero_append r b _ (hb b (by simp)) + | succ i => + rw [List.flatten_cons, blockAt_succ_append _ _ _ (hb b (by simp))] + rw [ih (fun c hc => hb c (by simp [hc])) i (by simpa using hi)] + simp + +/-- Flag: is `x` nonempty? The *partial* dispatcher returns `[]` on the empty +string, and `[]` reads as false to the flag connectives β€” so this is the one +place `caseBit` rather than `caseBitβ‚€` is what is wanted. + +Without it `matchPrefix` could not tell "the head bit is `0`" from "there is no +head bit", and would report a match of `[0]` against `[]`. -/ +def nonemptyFlag (x : List Bool) : List Bool := caseBit x [true] [true] + +@[simp] theorem nonemptyFlag_nil : nonemptyFlag [] = [] := rfl + +@[simp] theorem nonemptyFlag_cons (b : Bool) (x : List Bool) : + nonemptyFlag (b :: x) = [true] := by cases b <;> rfl + +/-- Flag: does `x` begin with the fixed constant `c`? Unfolds into `|c|` bit +tests joined by `andBit`, so for each constant it is a *finite* composition β€” +no recursion on notation is needed. -/ +def matchPrefix : List Bool β†’ List Bool β†’ List Bool + | [], _ => [true] + | b :: c, x => + andBit (nonemptyFlag x) + (andBit (bif b then bitAt [] x else notBit (bitAt [] x)) + (matchPrefix c x.tail)) + +@[simp] theorem matchPrefix_nil (x : List Bool) : matchPrefix [] x = [true] := rfl + +@[simp] theorem matchPrefix_cons (b : Bool) (c x : List Bool) : + matchPrefix (b :: c) x = + andBit (nonemptyFlag x) + (andBit (bif b then bitAt [] x else notBit (bitAt [] x)) + (matchPrefix c x.tail)) := rfl + +/-- A constant is matched by anything it prefixes. -/ +theorem matchPrefix_append (c y : List Bool) : matchPrefix c (c ++ y) = [true] := by + induction c generalizing y with + | nil => rfl + | cons b c ih => cases b <;> simp [andBit, notBit, ih] + +/-- Nothing but the empty constant matches the empty string. (Not a `simp` +lemma: `simp` unfolds the left-hand side past this shape.) -/ +theorem matchPrefix_nil_right (b : Bool) (c : List Bool) : + matchPrefix (b :: c) [] = [false] := by + cases b <;> rfl + +/-- Conjunction always returns a genuine one-bit flag, whatever it is given. -/ +theorem andBit_flag (x y : List Bool) : + andBit x y = [true] ∨ andBit x y = [false] := by + rw [andBit] + cases x with + | nil => exact Or.inr rfl + | cons a x => + cases a + Β· exact Or.inr rfl + Β· rw [caseBitβ‚€_cons, Bool.cond_true] + cases y with + | nil => exact Or.inr rfl + | cons d y => cases d <;> simp + +/-- The match test always returns a genuine one-bit flag. -/ +theorem matchPrefix_flag (c x : List Bool) : + matchPrefix c x = [true] ∨ matchPrefix c x = [false] := by + cases c with + | nil => exact Or.inl rfl + | cons b c => rw [matchPrefix_cons]; exact andBit_flag _ _ + +/-- **The match test is exactly the prefix test.** This is what makes a table of +constant patterns behave like a case analysis: the entry whose pattern is a +prefix of the key fires, and no other does. -/ +theorem matchPrefix_eq_true_iff (c x : List Bool) : + matchPrefix c x = [true] ↔ c <+: x := by + induction c generalizing x with + | nil => simp + | cons b c ih => + cases x with + | nil => simp [andBit] + | cons a x => + rw [matchPrefix_cons, nonemptyFlag_cons, andBit, caseBitβ‚€_cons, Bool.cond_true, + andBit] + have hbit : (bif b then bitAt [] (a :: x) else notBit (bitAt [] (a :: x))) + = [decide (a = b)] := by + cases a <;> cases b <;> rfl + rw [hbit, List.cons_prefix_cons] + rcases matchPrefix_flag c x with h | h <;> cases a <;> cases b <;> + simp [h, ← ih x] + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Cat.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Cat.lean new file mode 100644 index 0000000000..b76b94eb3d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Cat.lean @@ -0,0 +1,413 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.SndBlock + +/-! +# Concatenating two blocks β€” proof internals + +`Cobham.catBlocks` appends the payloads of two consecutive blocks, the string +concatenation behind `Cobham.appendFn_mem_FP`, together with the `Cobham.catTM` +scanner that computes it. + +## Main results + +- `Cobham.catBlocks_mem_FP` β€” concatenation is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ### Concatenation + +`catBlocks` is `fstBlock` and `sndBlock` fused: decode the leading block's +payload *and* keep the suffix, so on a genuine pair it is concatenation. Its +machine is `sndBlockTM` with the scan also emitting each decoded bit β€” the one +`FP` primitive that lets two computed strings be joined. -/ + +/-- Decode the leading self-delimiting block's payload and keep the suffix. On +`pair x y` this is `x ++ y` (`catBlocks_pair`); on malformed input it returns the +bits decoded so far. -/ +def catBlocks : List Bool β†’ List Bool + | false :: false :: z => false :: catBlocks z + | true :: true :: z => true :: catBlocks z + | false :: true :: z => z + | _ => [] + +@[simp] theorem catBlocks_pair (x y : List Bool) : catBlocks (pair x y) = x ++ y := by + induction x with + | nil => rfl + | cons b x ih => cases b <;> (rw [pair_cons_eq]; simp [catBlocks, ih]) + +/-- The concatenator: like `sndBlockTM`, but the scan also emits each decoded +payload bit, so the output ends up holding the payload followed by the suffix. +Computes `catBlocks`. -/ +def catTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Ξ“.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Ξ“.one => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.zero => + (.scanA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Ξ“.one => + (.scanA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `catTM`: from `emit` with input cursor on suffix `y` and +output holding `acc`, the machine copies `y` after `acc` and halts. -/ +private theorem catTM_emit_loop : + βˆ€ (y acc : List Bool) (c : Cfg 0 catTM.Q), + c.state = ScanPhase.emit β†’ + c.input.HasBinarySuffix y β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ y.length + 1 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y) := by + intro y + induction y with + | nil => + intro acc c hstate hsuf hpre + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, catTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa using hpre + | cons bit y ih => + intro acc c hstate hsuf hpre + have hread : c.input.read = Ξ“.ofBool bit := hsuf.read_cons + have hne : c.input.read β‰  Ξ“.blank := by rw [hread]; cases bit <;> decide + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.emit + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hne, c1] + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [bit]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool bit := by + rw [hread]; cases bit <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [bit]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit bit hpre + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih (acc ++ [bit]) c1 rfl hsuf.move_right_cons hpre1 + refine ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, ?_⟩ + rwa [List.append_assoc, List.cons_append, List.nil_append] at hout + +/-- A one-step halt from a scan state whose input reads a symbol that ends the +block: the output is untouched. -/ +private theorem catTM_halt_step {c : Cfg 0 catTM.Q} {acc : List Bool} + (hstep : catTM.step c = some + { state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }) + (hpre : c.output.HasBinaryPrefix acc) : + βˆƒ c' t, t ≀ 1 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix acc := by + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + refine ⟨_, 1, le_rfl, .step hstep .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + +/-- The scan phase of `catTM`: from `scanA` with input cursor on `w` and output +holding `acc`, the machine halts with output `acc ++ catBlocks w`. -/ +private theorem catTM_scan_loop : + βˆ€ (fuel : β„•) (w acc : List Bool), w.length ≀ fuel β†’ βˆ€ (c : Cfg 0 catTM.Q), + c.state = ScanPhase.scanA β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ 2 * w.length + 2 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ catBlocks w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c) (acc := acc) + (by simp [TM.step, hstate, catTM, hread]) hpre + exact ⟨c', t, by omega, hreach, hhalt, by simpa [catBlocks] using hout⟩ + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c) (acc := acc) + (by simp [TM.step, hstate, catTM, hread]) hpre + exact ⟨c', t, by omega, hreach, hhalt, by simpa [catBlocks] using hout⟩ + | [b0] => + have hread : c.input.read = Ξ“.ofBool b0 := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := if b0 then ScanPhase.scanBtrue else ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : catTM.step c = some c1 := by + cases b0 <;> simp [TM.step, hstate, catTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c1) (acc := acc) + (by cases b0 <;> simp [TM.step, catTM, hread1, c1]) hpre1 + exact ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, + by cases b0 <;> simpa [catBlocks] using hout⟩ + | false :: true :: y => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.emit + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix acc := by + show (c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1]; exact hpre1 + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := catTM_emit_loop y acc c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + simpa [catBlocks] using hout + | true :: false :: rest => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c1) (acc := acc) + (by simp [TM.step, catTM, hreadB, Ξ“.ofBool, c1]) hpre1 + exact ⟨c', t + 1, by simp only [List.length_cons]; omega, + .step hstepA hreach, hhalt, by simpa [catBlocks] using hout⟩ + | false :: false :: rest => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool false) Dir3.right } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix rest := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool false).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hrfuel : rest.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih rest (acc ++ [false]) hrfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hcb : catBlocks (false :: false :: rest) = false :: catBlocks rest := rfl + rw [hcb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hout + | true :: true :: rest => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool true) Dir3.right } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix rest := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool true).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hrfuel : rest.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih rest (acc ++ [true]) hrfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hcb : catBlocks (true :: true :: rest) = true :: catBlocks rest := rfl + rw [hcb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hout + +/-- **Concatenation is polynomial-time.** -/ +theorem catBlocks_mem_FP : catBlocks ∈ FP := by + refine ⟨1, 0, catTM, (fun m => 2 * m + 3), ?_, ?_⟩ + Β· intro z + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : catTM.step (catTM.initCfg z) = some c1 := by + simp [TM.step, catTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + catTM_scan_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≀ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + Β· have hn : (fun m : β„• => 2 * m) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using (BigO.refl (fun m : β„• => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean new file mode 100644 index 0000000000..4893dc5920 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# The bit successor β€” proof internals + +`Cobham.consBitTM b` prepends the fixed bit `b` to its input: the machine behind +the `bit` constructor of Cobham's algebra. + +## Main results + +- `Cobham.cons_mem_FP` β€” prepending a fixed bit is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ### The bit-successor transducer + +A small machine computing `x ↦ b :: x`: skip the left marker, emit `b`, then copy +the input verbatim after it. Modelled on `TM.copyInputToOutputTM`. -/ + + +/-- Control states of `consBitTM`: skip the `β–·` marker, emit the fixed bit, copy +the input, halt. -/ +inductive ConsPhase where + | skip | emit | copy | done + deriving DecidableEq + +instance : Fintype ConsPhase where + elems := {.skip, .emit, .copy, .done} + complete := fun x => by cases x <;> simp + +/-- The bit-successor machine: on input `x` it writes `b :: x` to the output tape +in `|x| + 3` steps. First `skip` advances past the left markers, `emit` writes `b` +into output cell 1, and `copy` copies the input bits after it. -/ +def consBitTM (b : Bool) : TM 0 where + Q := ConsPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .emit => + (.copy, fun i => readBackWrite (wHeads i), Ξ“w.ofBool b, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + | .copy => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.copy, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .emit => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .copy => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `consBitTM`: from a configuration whose output already holds +`b :: x.take k` and whose input head is at the first uncopied cell, the remaining +`rem = |x| - k` bits are copied and the machine halts with output `b :: x`. -/ +private theorem consBitTM_copy_loop (b : Bool) (x : List Bool) : + βˆ€ rem k (c : Cfg 0 (consBitTM b).Q), + rem = x.length - k β†’ + c.state = ConsPhase.copy β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + c.output.HasBinaryPrefix (b :: x.take k) β†’ + k ≀ x.length β†’ + βˆƒ c', + (consBitTM b).reachesIn (rem + 1) c c' ∧ + (consBitTM b).halted c' ∧ + c'.output.HasBinaryPrefix (b :: x) := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_eq : k = x.length := by omega + subst hk_eq + have hread : c.input.read = Ξ“.blank := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : c.output.HasBinaryPrefix (b :: x) := by + simpa using hprefix + have houtput_blank : c.output.read = Ξ“.blank := hprefix_full.read_blank + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hinput_keep : c.input.move (idleDir c.input.read) = c.input := by + simp [idleDir, hread, Tape.move] + have houtput_keep : + c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) = c.output := by + rw [writeAndMove_readBack c.output (by simp [houtput_blank]), + idleDir, ite_eq_right (by simp [houtput_blank]), Tape.move] + have hstep : (consBitTM b).step c = some c1 := by + simp [TM.step, hstate, consBitTM, hread, c1] + refine ⟨c1, .step hstep .zero, rfl, ?_⟩ + rw [show c1.output = c.output by simpa [c1] using houtput_keep] + exact hprefix_full + | succ rem ih => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_lt : k < x.length := by omega + have hread : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hread_ne : c.input.read β‰  Ξ“.blank := by + rw [hread]; cases x[k]'hk_lt <;> simp [Ξ“.ofBool] + have hprefix_next : + (c.output.writeAndMove (Ξ“.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (b :: x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + have heq : (b :: x.take k) ++ [x[k]'hk_lt] = b :: x.take (k + 1) := by + rw [List.cons_append, List.take_concat_get' x k hk_lt] + rwa [heq] at hwrite + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.copy + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : (consBitTM b).step c = some c1 := by + simp [TM.step, hstate, consBitTM, hread_ne, c1] + have hcells1 : c1.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simpa [c1, Tape.move_cells] using hcells + have hhead1 : c1.input.head = (k + 1) + 1 := by simp [c1, Tape.move, hhead] + have hprefix1 : c1.output.HasBinaryPrefix (b :: x.take (k + 1)) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool (x[k]'hk_lt) := by + rw [hread]; cases x[k]'hk_lt <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) Dir3.right).HasBinaryPrefix + (b :: x.take (k + 1)) + rw [hco]; exact hprefix_next + obtain ⟨c', hreach, hhalt, hprefix'⟩ := + ih (k + 1) c1 (by omega) rfl hcells1 hhead1 hprefix1 (by omega) + exact ⟨c', .step hstep hreach, hhalt, hprefix'⟩ + +/-- `consBitTM b` computes `x ↦ b :: x` within the linear bound `|x| + 3`. -/ +theorem consBitTM_computesInTime (b : Bool) : + (consBitTM b).ComputesInTime (fun x => b :: x) (fun m => m + 3) := by + intro x + -- Step 1: `skip` advances past the left markers. + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.emit + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).writeAndMove (readBackWrite (Tape.init []).read) + (idleDir (Tape.init []).read) + output := (Tape.init []).move Dir3.right } + have hstep1 : (consBitTM b).step ((consBitTM b).initCfg x) = some c1 := by + simp [TM.step, consBitTM, c1, Tape.read, Tape.init, idleDir, Tape.writeAndMove, + Tape.write, Tape.move] + -- The input head after `skip` reads a data/blank cell, never the marker. + have hne : c1.input.read β‰  Ξ“.start := by + cases x with + | nil => simp [c1, Tape.read, Tape.move, Tape.init] + | cons a t => cases a <;> simp [c1, Tape.read, Tape.move, Tape.init, Ξ“.ofBool] + -- Step 2: `emit` writes `b` into output cell 1. + let c2 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.copy + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool b) Dir3.right } + have hstep2 : (consBitTM b).step c1 = some c2 := by + simp [TM.step, consBitTM, c1, c2] + have hc2_input_cells : c2.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simp [c2, c1, Tape.move_cells] + have hc2_input_head : c2.input.head = 0 + 1 := by + show (c1.input.move (idleDir c1.input.read)).head = 0 + 1 + rw [idleDir, ite_eq_right hne] + simp [Tape.move, c1, Tape.init] + have hc2_output : c2.output.HasBinaryPrefix (b :: x.take 0) := by + have hbase : ((Tape.init []).move Dir3.right).HasBinaryPrefix [] := + Tape.init_nil_move_right_hasBinaryPrefix_nil + have hw := Tape.hasBinaryPrefix_write_bit (t := (Tape.init []).move Dir3.right) b hbase + show (c1.output.writeAndMove ((Ξ“w.ofBool b).toΞ“) Dir3.right).HasBinaryPrefix (b :: x.take 0) + rw [Ξ“w.ofBool_toΞ“, show c1.output = (Tape.init []).move Dir3.right from rfl] + simpa using hw + obtain ⟨c', hreach, hhalt, hprefix⟩ := + consBitTM_copy_loop b x x.length 0 c2 (by simp) rfl hc2_input_cells + hc2_input_head hc2_output (Nat.zero_le _) + refine ⟨c', x.length + 3, le_rfl, ?_, hhalt, (hprefix.hasOutput)⟩ + have : (consBitTM b).reachesIn (x.length + 1 + 1 + 1) ((consBitTM b).initCfg x) c' := + .step hstep1 (.step hstep2 hreach) + simpa [Nat.add_assoc] using this + +/-- Prepending a fixed bit is polynomial-time β€” the string-successor underlying +the `bit` constructor. Witnessed by `consBitTM`. -/ +theorem cons_mem_FP (b : Bool) : (fun x : List Bool => b :: x) ∈ FP := by + refine ⟨1, 0, consBitTM b, (fun m => m + 3), consBitTM_computesInTime b, ?_⟩ + have hn : (fun m : β„• => m) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa only [pow_one] using BigO.refl (fun m : β„• => m) + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean new file mode 100644 index 0000000000..c0526edf9a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean @@ -0,0 +1,971 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Blocks +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# Encoding machine configurations as bitstrings β€” proof internals + +The completeness direction of Cobham's theorem simulates a polynomial-time +machine inside the function algebra, so a configuration has to become a single +bitstring. This module fixes that encoding and proves the arithmetic facts about +it; the algebra-side operations that act on it live in +`Complexitylib.Classes.P.Cobham.Internal.StepAlgebra`. + +## The two design choices + +**Two bits per symbol, with blank `= 00`.** Fixed-width blocks are padded with +zeros (`Complexity.padTo`), so making blank the all-zero code means padding a +tape block with zeros *is* extending it with blanks β€” the padding needs no +special treatment anywhere. + +**Tapes split at the head.** A tape is stored as its cells to the left of the +head, nearest first, and its cells from the head rightwards. Then a head move is +transferring one symbol between the two sides, i.e. a `take`/`drop`/`append` of +two bits, rather than arithmetic on a position index. Reading is the first two +bits of the right part. + +Cell `0` is the only `β–·` (the writable alphabet `Ξ“w` excludes it), so "the head +is at cell 0" is exactly "the read symbol is `β–·`" β€” and in that case +`TM.Ξ΄_right_of_start` forces a move right. The left part is therefore never +consulted when it is empty, which is why it needs no emptiness test. + +## Main definitions + +- `Complexity.Cobham.symCode` β€” two-bit code for `Ξ“` +- `Complexity.Cobham.cellsCode` β€” a window of cells as a bitstring +- `Complexity.Cobham.leftCode`, `Complexity.Cobham.rightCode` β€” a tape split at + its head + +## Main results + +The six lemmas that make the split representation simulate `Tape.writeAndMove`, +each expressing one head move as two bits crossing the split: + +- `leftCode_write_stay`, `rightCode_write_stay` +- `leftCode_write_right`, `rightCode_write_right` +- `leftCode_write_left`, `rightCode_write_left` + +Every right-hand side is built from `take 2`, `drop 2`, `++` and the constant +`symCode s` β€” all of which the algebra has (`Cobham.takeFn`, `Cobham.dropFn`, +`Cobham.appendFn`, `Cobham.const`). +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## The symbol code -/ + +/-- Two-bit code for the tape alphabet. Blank is `00`, so zero-padding a block is +blank-padding it. -/ +def symCode : Ξ“ β†’ List Bool + | .blank => [false, false] + | .start => [false, true] + | .zero => [true, false] + | .one => [true, true] + +/-- Decode the leading two bits of a string as a tape symbol; anything shorter +than two bits reads as blank. -/ +def symDecode : List Bool β†’ Ξ“ + | false :: false :: _ => .blank + | false :: true :: _ => .start + | true :: false :: _ => .zero + | true :: true :: _ => .one + | _ => .blank + +@[simp] theorem symCode_length (g : Ξ“) : (symCode g).length = 2 := by cases g <;> rfl + +@[simp] theorem symCode_blank : symCode Ξ“.blank = [false, false] := rfl + +/-- The code round-trips, even with arbitrary trailing bits β€” which is what lets +the decoder read a symbol off the front of a longer block. -/ +@[simp] theorem symDecode_symCode (g : Ξ“) (rest : List Bool) : + symDecode (symCode g ++ rest) = g := by cases g <;> rfl + +/-- The decoder only ever looks at two bits, so truncating first changes +nothing. -/ +theorem symDecode_take_two (l : List Bool) : symDecode (l.take 2) = symDecode l := by + match l with + | [] => rfl + | [b] => cases b <;> rfl + | b :: b' :: t => cases b <;> cases b' <;> rfl + +/-- Zero padding decodes as blank: the reason `symCode Ξ“.blank = [0,0]`. -/ +theorem symDecode_replicate_false {n : β„•} (h : 2 ≀ n) : + symDecode (List.replicate n false) = Ξ“.blank := by + obtain ⟨m, rfl⟩ : βˆƒ m, n = m + 2 := ⟨n - 2, by omega⟩ + rw [show m + 2 = 2 + m from by omega, List.replicate_add] + rfl + +/-- The code is injective. -/ +theorem symCode_injective : Function.Injective symCode := by + intro a b hab + have h1 : symDecode (symCode a ++ []) = a := symDecode_symCode a [] + rw [hab, symDecode_symCode] at h1 + exact h1.symm + +/-- Every symbol costs two bits, so a run of coded symbols has twice the +length. -/ +private theorem length_flatMap_symCode (l : List β„•) (f : β„• β†’ Ξ“) : + ((l.flatMap fun j => symCode (f j)).length) = 2 * l.length := by + induction l with + | nil => rfl + | cons a l ih => simp only [List.flatMap_cons, List.length_append, ih, + symCode_length, List.length_cons]; omega + +/-! ## The control state + +The state is stored one-hot: `|Q|` bits with a single `1`. Fixed width and +injective, and β€” the point β€” every state's code is a *constant* for a fixed +machine, so the transition table is finitely many `Cobham.matchPrefixFn` tests +against constants (`Cobham.tableFn`). Binary would need arithmetic; one-hot needs +none. -/ + +/-- One-hot code for a control state: one bit per element of `Q`, set exactly at +the state itself. + +Noncomputable only because `Finset.toList` picks an enumeration order; the code +appears solely in specifications, never in a machine that must run. -/ +noncomputable def stateCode {Q : Type} [Fintype Q] [DecidableEq Q] (q : Q) : + List Bool := + (Finset.univ.toList (Ξ± := Q)).map fun p => decide (p = q) + +@[simp] theorem stateCode_length {Q : Type} [Fintype Q] [DecidableEq Q] (q : Q) : + (stateCode q).length = Fintype.card Q := by + rw [stateCode, List.length_map, Finset.length_toList, Finset.card_univ] + +/-- Distinct states get distinct codes. -/ +theorem stateCode_injective {Q : Type} [Fintype Q] [DecidableEq Q] : + Function.Injective (stateCode (Q := Q)) := by + intro a b hab + rw [stateCode, stateCode, List.map_inj_left] at hab + have h := hab a (by simp) + simpa using h.symm + +/-! ## Windows of cells -/ + +/-- The `w` cells of `t` starting at cell `i`, two bits each. -/ +def cellsCode (t : Tape) (i w : β„•) : List Bool := + (List.range w).flatMap fun j => symCode (t.cells (i + j)) + +@[simp] theorem cellsCode_zero (t : Tape) (i : β„•) : cellsCode t i 0 = [] := rfl + +@[simp] theorem cellsCode_length (t : Tape) (i w : β„•) : + (cellsCode t i w).length = 2 * w := by + rw [cellsCode, length_flatMap_symCode, List.length_range] + +/-- Peeling the first cell off a window. -/ +theorem cellsCode_succ_left (t : Tape) (i w : β„•) : + cellsCode t i (w + 1) = symCode (t.cells i) ++ cellsCode t (i + 1) w := by + rw [cellsCode, cellsCode, List.range_succ_eq_map, List.flatMap_cons] + simp [List.flatMap_map, Nat.add_comm, Nat.add_left_comm] + +/-! ## Tapes split at the head -/ + +/-- The cells `n-1, n-2, …, 0` of `t`, nearest first. -/ +def leftCodeFrom (t : Tape) : β„• β†’ List Bool + | 0 => [] + | n + 1 => symCode (t.cells n) ++ leftCodeFrom t n + +/-- The cells strictly left of the head, nearest first. -/ +def leftCode (t : Tape) : List Bool := leftCodeFrom t t.head + +@[simp] theorem leftCodeFrom_zero (t : Tape) : leftCodeFrom t 0 = [] := rfl + +@[simp] theorem leftCodeFrom_succ (t : Tape) (n : β„•) : + leftCodeFrom t (n + 1) = symCode (t.cells n) ++ leftCodeFrom t n := rfl + +@[simp] theorem leftCodeFrom_length (t : Tape) (n : β„•) : + (leftCodeFrom t n).length = 2 * n := by + induction n with + | zero => rfl + | succ n ih => simp only [leftCodeFrom_succ, List.length_append, ih, symCode_length]; omega + +/-- The nearest-left window depends only on the cells it covers. -/ +theorem leftCodeFrom_congr {t t' : Tape} {n : β„•} + (h : βˆ€ j, j < n β†’ t.cells j = t'.cells j) : + leftCodeFrom t n = leftCodeFrom t' n := by + induction n with + | zero => rfl + | succ n ih => + rw [leftCodeFrom_succ, leftCodeFrom_succ, h n (by omega), + ih fun j hj => h j (by omega)] + +/-- The cells from the head rightwards, out to cell `W`. + +The width is `W + 1 - head`, complementary to `leftCode`'s `head`, so the two +parts always account for exactly the cells `0 … W`: their total width is the +constant `2 Β· (W + 1)` and a head move just shifts two bits across the split. -/ +def rightCode (t : Tape) (W : β„•) : List Bool := cellsCode t t.head (W + 1 - t.head) + +@[simp] theorem leftCode_length (t : Tape) : (leftCode t).length = 2 * t.head := + leftCodeFrom_length t t.head + +@[simp] theorem rightCode_length (t : Tape) (W : β„•) : + (rightCode t W).length = 2 * (W + 1 - t.head) := cellsCode_length _ _ _ + +/-- The two halves together always span the same window. -/ +theorem leftCode_rightCode_length (t : Tape) {W : β„•} (h : t.head ≀ W + 1) : + (leftCode t).length + (rightCode t W).length = 2 * (W + 1) := by + simp only [leftCode_length, rightCode_length] + omega + +/-- The read symbol is the first two bits of the right part. -/ +theorem symDecode_rightCode (t : Tape) {W : β„•} (hw : t.head ≀ W) : + symDecode (rightCode t W) = t.read := by + rw [rightCode, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left] + exact symDecode_symCode _ _ + +/-! ### Congruence + +Both halves read only the cells in their own window, so an update outside that +window is invisible to them. These are the lemmas that let a single-cell write be +localized. -/ + +/-- A window depends only on the cells it covers. -/ +theorem cellsCode_congr {t t' : Tape} {i w : β„•} + (h : βˆ€ j, j < w β†’ t.cells (i + j) = t'.cells (i + j)) : + cellsCode t i w = cellsCode t' i w := by + rw [cellsCode, cellsCode] + refine List.flatMap_congr fun j hj => ?_ + rw [h j (List.mem_range.mp hj)] + +/-- The left half depends only on the head and the cells strictly below it. -/ +theorem leftCode_congr {t t' : Tape} (hh : t.head = t'.head) + (h : βˆ€ j, j < t.head β†’ t.cells j = t'.cells j) : leftCode t = leftCode t' := by + rw [leftCode, leftCode, ← hh] + exact leftCodeFrom_congr h + +/-! ### Writing and moving + +`Tape.write` never touches cell `0` (the model makes writing there a no-op), and +`Ξ“w` cannot produce `β–·`, so cell `0` is permanently the unique `β–·`. Hence "the +head is at `0`" is exactly "the read symbol is `β–·`", and `TM.Ξ΄_right_of_start` +then forces a right move β€” which is why the left half is never consulted while +empty. -/ + +/-- Writing at the head leaves every other cell alone. -/ +theorem write_cells_of_ne {t : Tape} {s : Ξ“} {j : β„•} (h : j β‰  t.head) : + (t.write s).cells j = t.cells j := by + rw [Tape.write] + split + Β· rfl + Β· exact Function.update_of_ne h _ _ + +/-- Writing at the head sets exactly that cell β€” except at cell `0`, where the +model makes the write a no-op, so callers must establish that the modeled symbol +already agrees with what is there. A raw `TM` transition writes only `Ξ“w`, which +excludes `β–·`; the encoded simulator later supplies the corrected symbol through +`correctWrite`. -/ +theorem write_cells_head {t : Tape} {s : Ξ“} (hs : t.head = 0 β†’ s = t.cells t.head) : + (t.write s).cells t.head = s := by + rw [Tape.write] + split + Β· next h => exact (hs h).symm + Β· exact Function.update_self _ _ _ + +/-- Writing at the head sets exactly that cell, away from cell `0`. -/ +theorem write_cells_self {t : Tape} {s : Ξ“} (h : t.head β‰  0) : + (t.write s).cells t.head = s := + write_cells_head fun h0 => absurd h0 h + +/-- **Staying put**: the left half is untouched and the right half gets its +leading symbol replaced. -/ +theorem leftCode_write_stay {t : Tape} {s : Ξ“} : + leftCode ((t.write s).move Dir3.stay) = leftCode t := by + have hhead : ((t.write s).move Dir3.stay).head = t.head := Tape.write_head t s + refine leftCode_congr hhead fun j hj => ?_ + rw [hhead] at hj + show (t.write s).cells j = t.cells j + exact write_cells_of_ne (by omega) + +/-- **Moving right**: the written symbol crosses over to the left half. This is +the one direction a head at cell `0` can take, so it is stated with the weaker +hypothesis that the write agrees with cell `0` when the head is there. -/ +theorem leftCode_write_right {t : Tape} {s : Ξ“} + (h : t.head = 0 β†’ s = t.cells t.head) : + leftCode ((t.write s).move Dir3.right) = symCode s ++ leftCode t := by + have hhead : ((t.write s).move Dir3.right).head = t.head + 1 := by + rw [Tape.move, Tape.write_head] + rw [leftCode, leftCode, hhead, leftCodeFrom_succ] + congr 1 + Β· show symCode (((t.write s).move Dir3.right).cells t.head) = _ + rw [Tape.move_cells, write_cells_head h] + Β· exact leftCodeFrom_congr fun j hj => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Moving left**: the nearest left symbol crosses over to the right half, so +the left half loses its first two bits. -/ +theorem leftCode_write_left {t : Tape} {s : Ξ“} (h : t.head β‰  0) : + leftCode ((t.write s).move Dir3.left) = (leftCode t).drop 2 := by + have hhead : ((t.write s).move Dir3.left).head = t.head - 1 := by + rw [Tape.move, Tape.write_head] + obtain ⟨m, hm⟩ : βˆƒ m, t.head = m + 1 := ⟨t.head - 1, by omega⟩ + rw [leftCode, leftCode, hhead, hm, Nat.add_sub_cancel, leftCodeFrom_succ] + rw [show (symCode (t.cells m) ++ leftCodeFrom t m).drop 2 + = leftCodeFrom t m from by + rw [List.drop_left' (by simp)]] + exact leftCodeFrom_congr fun j hj => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Staying put**, right half: the leading symbol is replaced. -/ +theorem rightCode_write_stay {t : Tape} {s : Ξ“} {W : β„•} (h : t.head β‰  0) + (hW : t.head ≀ W) : + rightCode ((t.write s).move Dir3.stay) W = symCode s ++ (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.stay).head = t.head := Tape.write_head t s + rw [rightCode, rightCode, hhead, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, cellsCode_succ_left] + congr 1 + Β· show symCode ((t.write s).cells t.head) = _ + rw [write_cells_self h] + Β· rw [List.drop_left' (by simp)] + exact cellsCode_congr fun j _ => write_cells_of_ne (by omega) + +/-- **Moving right**, right half: the leading symbol is consumed. -/ +theorem rightCode_write_right {t : Tape} {s : Ξ“} {W : β„•} (hW : t.head ≀ W) : + rightCode ((t.write s).move Dir3.right) W = (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.right).head = t.head + 1 := by + rw [Tape.move, Tape.write_head] + rw [rightCode, rightCode, hhead, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, List.drop_left' (by simp), + show W + 1 - (t.head + 1) = W - t.head from by omega] + exact cellsCode_congr fun j _ => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Moving left**, right half: the nearest left symbol and the written symbol +both join it. -/ +theorem rightCode_write_left {t : Tape} {s : Ξ“} {W : β„•} (h : t.head β‰  0) + (hW : t.head ≀ W) : + rightCode ((t.write s).move Dir3.left) W = + (leftCode t).take 2 ++ symCode s ++ (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.left).head = t.head - 1 := by + rw [Tape.move, Tape.write_head] + obtain ⟨m, hm⟩ : βˆƒ m, t.head = m + 1 := ⟨t.head - 1, by omega⟩ + have hleft : (leftCode t).take 2 = symCode (t.cells m) := by + rw [leftCode, hm, leftCodeFrom_succ, List.take_left' (by simp)] + rw [rightCode, rightCode, hhead, hm, Nat.add_sub_cancel, hleft, + show W + 1 - m = (W - m) + 1 from by omega, cellsCode_succ_left, + show W + 1 - (m + 1) = (W - (m + 1)) + 1 from by omega, cellsCode_succ_left, + List.drop_left' (by simp), List.append_assoc] + have hwrite : (t.write s).cells (m + 1) = s := by + rw [← hm]; exact write_cells_self h + congr 1 + Β· show symCode (((t.write s).move Dir3.left).cells m) = _ + rw [Tape.move_cells] + exact congrArg symCode (write_cells_of_ne (by omega)) + Β· rw [show W - m = (W - (m + 1)) + 1 from by omega, cellsCode_succ_left] + congr 1 + Β· show symCode (((t.write s).move Dir3.left).cells (m + 1)) = _ + rw [Tape.move_cells] + exact congrArg symCode hwrite + Β· refine cellsCode_congr fun j _ => ?_ + rw [Tape.move_cells] + exact write_cells_of_ne (by omega) + +/-! ## Whole configurations + +Every field occupies a block of the same width, so field `i` is recovered by +`Cobham.blockFn … i` β€” the algebra never needs a self-delimiting decoder. A tape +costs two blocks (its two halves); the state costs one, padded to the same +width. -/ + +/-- The block width used throughout: wide enough for either half of a tape whose +head stays within `0 … W`. -/ +def blockWidth (W : β„•) : β„• := 2 * (W + 1) + +/-- The canonical ruler of one block's width. -/ +def blockRuler (W : β„•) : List Bool := List.replicate (blockWidth W) false + +@[simp] theorem blockRuler_length (W : β„•) : (blockRuler W).length = blockWidth W := by + simp [blockRuler] + +/-- A tape as two padded half-blocks: the cells left of the head (nearest first) +and the cells from the head rightwards. -/ +def tapeBlocks (W : β„•) (t : Tape) : List (List Bool) := + [padTo (blockRuler W) (leftCode t), padTo (blockRuler W) (rightCode t W)] + +/-- Both halves of a tape occupy one block each. -/ +theorem tapeBlocks_width (W : β„•) (t : Tape) : + βˆ€ b ∈ tapeBlocks W t, b.length = (blockRuler W).length := by + intro b hb + rw [blockRuler_length] + rcases List.mem_cons.mp hb with rfl | hb + Β· simp + Β· rcases List.mem_cons.mp hb with rfl | hb + Β· simp + Β· simp at hb + +@[simp] theorem tapeBlocks_length (W : β„•) (t : Tape) : + (tapeBlocks W t).length = 2 := rfl + +/-- A tape as a bitstring: its two half-blocks concatenated. -/ +def tapeCode (W : β„•) (t : Tape) : List Bool := (tapeBlocks W t).flatten + +@[simp] theorem tapeCode_length (W : β„•) (t : Tape) : + (tapeCode W t).length = 2 * blockWidth W := by + rw [tapeCode, tapeBlocks, List.flatten_cons, List.flatten_cons, + List.flatten_nil, List.length_append, List.length_append, padTo_length, + padTo_length, blockRuler_length] + simp + omega + +/-- Blocks of a common width concatenate to a predictable length. -/ +private theorem length_flatMap_const {Ξ± Ξ² : Type} (l : List Ξ±) (f : Ξ± β†’ List Ξ²) + (m : β„•) (h : βˆ€ a, (f a).length = m) : (l.flatMap f).length = l.length * m := by + induction l with + | nil => simp + | cons a l ih => + rw [List.flatMap_cons, List.length_append, ih, h a, List.length_cons, + Nat.succ_mul] + exact Nat.add_comm _ _ + +/-- The work tapes, one after another. -/ +def worksCode {k : β„•} (W : β„•) (work : Fin k β†’ Tape) : List Bool := + (List.finRange k).flatMap fun i => tapeCode W (work i) + +@[simp] theorem worksCode_length {k : β„•} (W : β„•) (work : Fin k β†’ Tape) : + (worksCode W work).length = k * (2 * blockWidth W) := by + rw [worksCode, length_flatMap_const _ _ _ (fun i => tapeCode_length W (work i)), + List.length_finRange] + +/-! ### The window invariant + +A head moves at most one cell per step and starts at cell `0`, so after `t` steps +every head is within `0 … t`. Taking the window `W` to be the machine's time +bound therefore discharges the `head ≀ W` side condition of every encoding lemma +β€” the simulated machine can never reach outside the encoded window. -/ + +/-- After `t` steps from the initial configuration every head is at most `t`. -/ +theorem heads_le_of_reachesIn {k : β„•} (tm : TM k) {x : List Bool} {t : β„•} + {c : Cfg k tm.Q} (h : tm.reachesIn t (tm.initCfg x) c) : + c.input.head ≀ t ∧ c.output.head ≀ t ∧ βˆ€ i, (c.work i).head ≀ t := by + obtain ⟨hin, hout, hwork⟩ := TM.head_le_start_add_of_reachesIn tm h + exact ⟨by simpa using hin, by simpa using hout, fun i => by simpa using hwork i⟩ + +/-- **Reading a symbol out of an encoded tape.** The head symbol is the first two +bits of the padded right half-block β€” one `takeFn` in the algebra. -/ +theorem symDecode_take_padTo_rightCode {W : β„•} (t : Tape) (hW : t.head ≀ W) : + symDecode ((padTo (blockRuler W) (rightCode t W)).take 2) = t.read := by + rw [take_padTo _ _ 2 (by rw [rightCode_length]; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth]; omega), + symDecode_take_two] + exact symDecode_rightCode t hW + +/-! ### One tape's step + +The encoded step on a tape's two half-blocks. Every right-hand side is +`take 2` / `drop 2` / `++` / a constant and a re-pad, so the algebra realizes it +with `Cobham.takeFn`, `Cobham.dropFn`, `Cobham.appendFn`, `Cobham.const` and +`Cobham.padFn` β€” and within one branch of `Cobham.tableFn` the symbol `s` and the +direction `d` are *constants*. -/ + +/-- The two half-blocks of a tape after writing `s` and moving `d`. -/ +def tapeStepBlocks (R : List Bool) (s : Ξ“) (d : Dir3) (L Rt : List Bool) : + List Bool Γ— List Bool := + match d with + | .stay => (L, padTo R (symCode s ++ Rt.drop 2)) + | .right => (padTo R (symCode s ++ L), padTo R (Rt.drop 2)) + | .left => (padTo R (L.drop 2), padTo R (L.take 2 ++ symCode s ++ Rt.drop 2)) + +/-- **The encoded step simulates `Tape.writeAndMove`** on both half-blocks. + +The hypotheses are exactly what the corrected encoded action supplies. `hs`: at +cell `0` the write is a no-op, so `correctWrite` replaces the raw `Ξ“w` symbol by +the existing `β–·`. `hne`: `TM.Ξ΄_right_of_start` ensures that a head at cell `0` +can only move *right*, so the stay and left cases never arise there. -/ +theorem tapeStepBlocks_eq {W : β„•} (t : Tape) (s : Ξ“) (d : Dir3) + (hs : t.head = 0 β†’ s = t.cells t.head) + (hne : d β‰  Dir3.right β†’ t.head β‰  0) (hW : t.head ≀ W) : + tapeStepBlocks (blockRuler W) s d + (padTo (blockRuler W) (leftCode t)) (padTo (blockRuler W) (rightCode t W)) + = (padTo (blockRuler W) (leftCode ((t.write s).move d)), + padTo (blockRuler W) (rightCode ((t.write s).move d) W)) := by + have hLlen : (leftCode t).length ≀ (blockRuler W).length := by + rw [leftCode_length, blockRuler_length, blockWidth]; omega + have hRlen : (rightCode t W).length ≀ (blockRuler W).length := by + rw [rightCode_length, blockRuler_length, blockWidth]; omega + have hR2 : 2 ≀ (rightCode t W).length := by rw [rightCode_length]; omega + have hdrop : (padTo (blockRuler W) (rightCode t W)).drop 2 + = (rightCode t W).drop 2 ++ + List.replicate ((blockRuler W).length - (rightCode t W).length) false := + drop_padTo _ _ 2 hR2 hRlen + cases d with + | stay => + have h0 : t.head β‰  0 := hne (by decide) + rw [tapeStepBlocks, leftCode_write_stay, rightCode_write_stay h0 hW, hdrop, + ← List.append_assoc, padTo_append_replicate] + | right => + rw [tapeStepBlocks, leftCode_write_right hs, rightCode_write_right hW, hdrop, + padTo_append_padTo _ _ _ hLlen, padTo_append_replicate] + | left => + have h0 : t.head β‰  0 := hne (by decide) + have hL2 : 2 ≀ (leftCode t).length := by + rw [leftCode_length]; omega + rw [tapeStepBlocks, leftCode_write_left h0, rightCode_write_left h0 hW, + padTo_drop _ _ 2 hL2 hLlen, take_padTo _ _ 2 hL2 hLlen, hdrop, + ← List.append_assoc, padTo_append_replicate] + +/-! ### All the tapes at once + +`TM.step` writes and moves on every tape independently, so the encoded step is +the same operation applied tapewise. Treating the tapes as one list β€” input, +output, then work tapes, the order the encoding uses β€” makes that a +`List.zipWith` against the transition's per-tape actions, with no positional +index arithmetic. -/ + +/-- Writing back the symbol already under the head changes nothing. This is what +lets the read-only input tape take part in the uniform tapewise step: its action +is "write what you read, then move". -/ +theorem write_read_self (t : Tape) : t.write t.read = t := by + rw [Tape.write] + split + Β· rfl + Β· exact Tape.ext rfl (by rw [Tape.read]; exact Function.update_eq_self _ _) + +/-- All of a configuration's tapes in encoding order. -/ +def cfgTapes {k : β„•} {Q : Type} (c : Cfg k Q) : List Tape := + c.input :: c.output :: List.ofFn c.work + +@[simp] theorem cfgTapes_length {k : β„•} {Q : Type} (c : Cfg k Q) : + (cfgTapes c).length = k + 2 := by + rw [cfgTapes, List.length_cons, List.length_cons, List.length_ofFn] + +/-! ### The transition key + +The transition function is indexed by the current state together with the symbol +under every head. Packing those into one string turns the whole finite case +analysis into `Cobham.tableFn`: each (state, symbols) combination is a *constant* +pattern, and there are finitely many of them for a fixed machine. -/ + +/-- The state and the symbols under every head, in tape order. -/ +noncomputable def keyCode {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (c : Cfg k Q) : List Bool := + stateCode c.state ++ (cfgTapes c).flatMap fun t => symCode t.read + +@[simp] theorem keyCode_length {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (c : Cfg k Q) : (keyCode c).length = Fintype.card Q + 2 * (k + 2) := by + rw [keyCode, List.length_append, stateCode_length, + length_flatMap_const (cfgTapes c) (fun t => symCode t.read) 2 + (fun t => symCode_length t.read), cfgTapes_length, Nat.mul_comm] + +/-- The first two bits of a tape's right half-block are its read symbol. -/ +theorem take_rightCode (t : Tape) {W : β„•} (hW : t.head ≀ W) : + (rightCode t W).take 2 = symCode t.read := by + rw [rightCode, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, List.take_left' (by simp)] + rfl + + +/-- The blocks of a list of tapes: two per tape. -/ +def tapesBlocks (W : β„•) (ts : List Tape) : List (List Bool) := + ts.flatMap (tapeBlocks W) + +@[simp] theorem tapesBlocks_length (W : β„•) (ts : List Tape) : + (tapesBlocks W ts).length = 2 * ts.length := by + rw [tapesBlocks, length_flatMap_const _ _ 2 (fun t => tapeBlocks_length W t)] + omega + +/-- The tapes after one step, given each tape's write and move. -/ +def tapesStep (acts : List (Ξ“ Γ— Dir3)) (ts : List Tape) : List Tape := + List.zipWith (fun a t => (t.write a.1).move a.2) acts ts + +/-- `zipWith` over two tuples is the tuple of the pointwise results. -/ +private theorem zipWith_ofFn {Ξ± Ξ² Ξ³ : Type} {n : β„•} (f : Ξ± β†’ Ξ² β†’ Ξ³) + (g : Fin n β†’ Ξ±) (h : Fin n β†’ Ξ²) : + List.zipWith f (List.ofFn g) (List.ofFn h) = List.ofFn fun i => f (g i) (h i) := by + induction n with + | zero => rfl + | succ n ih => + rw [List.ofFn_succ, List.ofFn_succ, List.ofFn_succ, List.zipWith_cons_cons, ih] + +/-- The write a transition *really* performs: at cell `0` the model makes the +write a no-op, and this records that. Under `Tape.StartInvariant` the test is on +the **read symbol**, which the transition table already branches on β€” so the +correction costs the algebra nothing, it just picks a different constant in the +`β–·` branch. -/ +def correctWriteSym (r s : Ξ“) : Ξ“ := if r = Ξ“.start then Ξ“.start else s + +/-- The corrected write on a tape β€” a function of its read symbol alone, which is +what puts it inside the transition key. -/ +def correctWrite (t : Tape) (s : Ξ“) : Ξ“ := correctWriteSym t.read s + +/-- Correcting the write does not change what the write does. -/ +theorem write_correctWrite {t : Tape} (s : Ξ“) (h : t.StartInvariant) : + t.write (correctWrite t s) = t.write s := by + rw [correctWrite, correctWriteSym] + split + Β· next hr => + have hh : t.head = 0 := by + by_contra hne + exact h.read_ne_start (by omega) hr + rw [Tape.write, ite_eq_left hh, Tape.write, ite_eq_left hh] + Β· rfl + +/-- Under the invariant, the corrected write agrees with cell `0` when the head +is there β€” the hypothesis `tapeStepBlocks_eq` needs. -/ +theorem correctWrite_at_zero {t : Tape} (s : Ξ“) (h : t.StartInvariant) + (hh : t.head = 0) : correctWrite t s = t.cells t.head := by + have hr : t.read = Ξ“.start := by rw [Tape.read, hh]; exact h.1 + rw [correctWrite, correctWriteSym, ite_eq_left hr] + show Ξ“.start = t.cells t.head + rw [hh] + exact h.1.symm + +/-- The per-tape (write, move) actions a transition prescribes, in encoding +order. The input tape's "write" is the symbol it just read, which by +`write_read_self` leaves it unchanged β€” so the read-only input tape fits the +uniform tapewise step with no special case. -/ +def stepActs {k : β„•} (tm : TM k) (c : Cfg k tm.Q) : List (Ξ“ Γ— Dir3) := + let d := tm.Ξ΄ c.state c.input.read (fun i => (c.work i).read) c.output.read + (c.input.read, d.2.2.2.1) :: + (correctWrite c.output d.2.2.1.toΞ“, d.2.2.2.2.2) :: + List.ofFn fun i => (correctWrite (c.work i) (d.2.1 i).toΞ“, d.2.2.2.2.1 i) + +/-! ### The transition key determines the step + +Everything the successor configuration depends on β€” the new state and every +tape's write and direction β€” is a function of the state together with the symbol +under each head. That is exactly what a `Cobham.tableFn` entry can be indexed by, +and it is why any entry matching a configuration's key carries the right +branch. -/ + +/-- The symbols under a configuration's heads, in `cfgTapes` order. -/ +def cfgReads {k : β„•} {Q : Type} (c : Cfg k Q) : Fin (k + 2) β†’ Ξ“ := + Fin.cons c.input.read (Fin.cons c.output.read fun i => (c.work i).read) + +/-- A transition key's pattern string: the state's one-hot code followed by the +symbol under each head. Constant for each key, so it is what a +`Cobham.tableFn` entry matches against. -/ +noncomputable def keyPattern {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (p : Q Γ— (Fin (k + 2) β†’ Ξ“)) : List Bool := + stateCode p.1 ++ (List.ofFn p.2).flatMap symCode + +@[simp] theorem keyPattern_length {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (p : Q Γ— (Fin (k + 2) β†’ Ξ“)) : + (keyPattern p).length = Fintype.card Q + 2 * (k + 2) := by + rw [keyPattern, List.length_append, stateCode_length, + length_flatMap_const (List.ofFn p.2) symCode 2 symCode_length, List.length_ofFn, + Nat.mul_comm] + +/-- Runs of coded symbols determine their symbols. -/ +private theorem flatMap_symCode_injective : + βˆ€ l₁ lβ‚‚ : List Ξ“, l₁.length = lβ‚‚.length β†’ + l₁.flatMap symCode = lβ‚‚.flatMap symCode β†’ l₁ = lβ‚‚ := by + intro l₁ + induction l₁ with + | nil => intro lβ‚‚ hlen _; exact (List.length_eq_zero_iff.mp hlen.symm).symm + | cons a l₁ ih => + intro lβ‚‚ hlen heq + cases lβ‚‚ with + | nil => simp at hlen + | cons b lβ‚‚ => + rw [List.flatMap_cons, List.flatMap_cons] at heq + obtain ⟨h1, h2⟩ := List.append_inj heq (by simp) + rw [symCode_injective h1, ih lβ‚‚ (by simpa using hlen) h2] + +/-- **Distinct keys get distinct patterns.** Together with the fact that all +patterns have the same length, this is what makes at most one table entry match a +given key. -/ +theorem keyPattern_injective {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] : + Function.Injective (keyPattern (k := k) (Q := Q)) := by + rintro ⟨q₁, sβ‚βŸ© ⟨qβ‚‚, sβ‚‚βŸ© h + rw [keyPattern, keyPattern] at h + obtain ⟨h1, h2⟩ := List.append_inj h (by simp) + have hq := stateCode_injective h1 + have hs := flatMap_symCode_injective _ _ (by simp) h2 + subst hq + simp only [Prod.mk.injEq, true_and] + exact List.ofFn_inj.mp hs + +/-- The tapes' read symbols, listed, are the configuration's read tuple. -/ +theorem cfgTapes_map_read {k : β„•} {Q : Type} (c : Cfg k Q) : + (cfgTapes c).map Tape.read = List.ofFn (cfgReads c) := by + rw [cfgTapes, cfgReads] + simp [List.ofFn_succ, Function.comp_def] + +/-- **A configuration's key is its key's pattern.** So the table entry indexed by +`(state, reads)` is the one that matches. -/ +theorem keyCode_eq {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] (c : Cfg k Q) : + keyCode c = keyPattern (c.state, cfgReads c) := by + rw [keyCode, keyPattern] + congr 1 + rw [← cfgTapes_map_read] + simp [List.flatMap_map] + +/-- The per-tape actions determined by a transition key. -/ +def stepActsOf {k : β„•} (tm : TM k) (q : tm.Q) (syms : Fin (k + 2) β†’ Ξ“) : + List (Ξ“ Γ— Dir3) := + let d := tm.Ξ΄ q (syms 0) (fun i => syms i.succ.succ) (syms 1) + (syms 0, d.2.2.2.1) :: + (correctWriteSym (syms 1) d.2.2.1.toΞ“, d.2.2.2.2.2) :: + List.ofFn fun i => + (correctWriteSym (syms i.succ.succ) (d.2.1 i).toΞ“, d.2.2.2.2.1 i) + +/-- The successor state determined by a transition key. -/ +def stepStateOf {k : β„•} (tm : TM k) (q : tm.Q) (syms : Fin (k + 2) β†’ Ξ“) : tm.Q := + (tm.Ξ΄ q (syms 0) (fun i => syms i.succ.succ) (syms 1)).1 + +/-- The actions a configuration prescribes are the ones its key prescribes. -/ +theorem stepActs_eq_stepActsOf {k : β„•} (tm : TM k) (c : Cfg k tm.Q) : + stepActs tm c = stepActsOf tm c.state (cfgReads c) := rfl + +/-- The successor state is the one the key prescribes. -/ +theorem step_state_eq {k : β„•} (tm : TM k) {c c' : Cfg k tm.Q} + (h : tm.step c = some c') : c'.state = stepStateOf tm c.state (cfgReads c) := by + have hne : Β¬ c.state = tm.qhalt := fun hq => by simp [TM.step, hq] at h + rw [TM.step, ite_eq_right hne] at h + injection h with h + subst h + rfl + +/-- **`TM.step` is the tapewise action.** Every tape writes and moves according +to `stepActs`, so the whole configuration's tapes step uniformly. -/ +theorem cfgTapes_step {k : β„•} (tm : TM k) {c c' : Cfg k tm.Q} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : βˆ€ i, (c.work i).StartInvariant) : + cfgTapes c' = tapesStep (stepActs tm c) (cfgTapes c) := by + have hne : Β¬ c.state = tm.qhalt := fun hq => by simp [TM.step, hq] at h + rw [TM.step, ite_eq_right hne] at h + injection h with h + subst h + rw [cfgTapes, cfgTapes, stepActs, tapesStep] + dsimp only + rw [List.zipWith_cons_cons, List.zipWith_cons_cons, zipWith_ofFn] + dsimp only + simp only [write_read_self, write_correctWrite _ hout, + write_correctWrite _ (hwork _)] + +/-- **One tape's blocks after a step.** Immediate from `tapeStepBlocks_eq`; this +is the form that lifts tapewise across a whole configuration. -/ +theorem tapeBlocks_step {W : β„•} (a : Ξ“ Γ— Dir3) (t : Tape) + (hs : t.head = 0 β†’ a.1 = t.cells t.head) + (hne : a.2 β‰  Dir3.right β†’ t.head β‰  0) (hW : t.head ≀ W) : + tapeBlocks W ((t.write a.1).move a.2) = + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2] := by + rw [tapeStepBlocks_eq t a.1 a.2 hs hne hW] + rfl + +/-- The tapewise step acts blockwise on the encoding. -/ +theorem tapesBlocks_tapesStep {W : β„•} : + βˆ€ (acts : List (Ξ“ Γ— Dir3)) (ts : List Tape), + List.Forallβ‚‚ (fun (a : Ξ“ Γ— Dir3) (t : Tape) => + (t.head = 0 β†’ a.1 = t.cells t.head) ∧ + (a.2 β‰  Dir3.right β†’ t.head β‰  0) ∧ t.head ≀ W) acts ts β†’ + tapesBlocks W (tapesStep acts ts) = + (List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) acts ts).flatten := by + intro acts ts h + induction h with + | nil => rfl + | @cons a t acts ts hat _ ih => + rw [tapesStep, List.zipWith_cons_cons, tapesBlocks, List.flatMap_cons, + tapeBlocks_step a t hat.1 hat.2.1 hat.2.2, List.zipWith_cons_cons, + List.flatten_cons] + exact congrArg (List.append _) ih + +/-- A whole configuration as a list of equal-width blocks: the one-hot state +padded to a block, then the input tape, the output tape, and the work tapes, +each as two half-blocks. -/ +noncomputable def cfgBlocks {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : List (List Bool) := + padTo (blockRuler W) (stateCode c.state) :: tapesBlocks W (cfgTapes c) + +theorem cfgBlocks_eq {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + cfgBlocks W c = + padTo (blockRuler W) (stateCode c.state) :: tapesBlocks W (cfgTapes c) := rfl + +/-- Every field of a configuration occupies exactly one block. -/ +theorem cfgBlocks_width {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + βˆ€ b ∈ cfgBlocks W c, b.length = (blockRuler W).length := by + intro b hb + rw [cfgBlocks, List.mem_cons] at hb + rcases hb with rfl | hb + Β· simp + Β· obtain ⟨t, _, ht⟩ := List.mem_flatMap.mp hb + exact tapeBlocks_width W t b ht + +/-- A whole configuration as a bitstring. -/ +noncomputable def cfgCode {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : List Bool := (cfgBlocks W c).flatten + +/-- **Field access.** Block `i` of an encoded configuration is field `i` β€” so +`Cobham.blockFn … i` reads it, and no self-delimiting decoder is ever needed. -/ +theorem blockAt_cfgCode {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (i : β„•) (hi : i < (cfgBlocks W c).length) : + blockAt (blockRuler W) (cfgCode W c) i = (cfgBlocks W c)[i] := + blockAt_flatten _ _ (cfgBlocks_width W c) i hi + +/-- A configuration has `2(k+2) + 1` blocks: one per tape half plus the state. -/ +@[simp] theorem cfgBlocks_length {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : (cfgBlocks W c).length = 2 * (k + 2) + 1 := by + rw [cfgBlocks, List.length_cons, tapesBlocks, + length_flatMap_const _ _ 2 (fun t => tapeBlocks_length W t), cfgTapes_length] + omega + +/-- **The encoded configuration steps blockwise.** Composing `cfgTapes_step` +(`TM.step` is the tapewise action) with `tapesBlocks_tapesStep` (that action is +blockwise on the encoding): the successor's blocks are the new state block +followed by the old blocks transformed two at a time by `tapeStepBlocks`. + +The `Forallβ‚‚` hypothesis pairs each tape with its own action, which is what a run +supplies: `Ξ΄_right_of_start` constrains a tape at cell `0` only through *its own* +transition entry. -/ +theorem cfgBlocks_step {k : β„•} (tm : TM k) {c c' : Cfg k tm.Q} {W : β„•} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : βˆ€ i, (c.work i).StartInvariant) + (hgood : List.Forallβ‚‚ (fun (a : Ξ“ Γ— Dir3) (t : Tape) => + (t.head = 0 β†’ a.1 = t.cells t.head) ∧ + (a.2 β‰  Dir3.right β†’ t.head β‰  0) ∧ t.head ≀ W) (stepActs tm c) (cfgTapes c)) : + cfgBlocks W c' = + padTo (blockRuler W) (stateCode c'.state) :: + (List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) + (stepActs tm c) (cfgTapes c)).flatten := by + rw [cfgBlocks, cfgTapes_step tm h hout hwork, + tapesBlocks_tapesStep (stepActs tm c) (cfgTapes c) hgood] + +/-- `Forallβ‚‚` over two tuples follows pointwise. -/ +private theorem forallβ‚‚_ofFn {Ξ± Ξ² : Type} {R : Ξ± β†’ Ξ² β†’ Prop} {n : β„•} + {f : Fin n β†’ Ξ±} {g : Fin n β†’ Ξ²} (h : βˆ€ i, R (f i) (g i)) : + List.Forallβ‚‚ R (List.ofFn f) (List.ofFn g) := by + induction n with + | zero => exact List.Forallβ‚‚.nil + | succ n ih => + rw [List.ofFn_succ, List.ofFn_succ] + exact List.Forallβ‚‚.cons (h 0) (ih fun i => h i.succ) + +/-- **The step's side conditions hold in any run.** The write-agreement at cell +`0` is `correctWrite_at_zero`, and "a head at cell `0` can only move right" is +exactly `TM.Ξ΄_right_of_start` read through the invariant: at cell `0` the tape +reads `β–·`, which is the hypothesis that rule fires on. -/ +theorem stepActs_forallβ‚‚ {k : β„•} (tm : TM k) (c : Cfg k tm.Q) {W : β„•} + (hinv : βˆ€ t ∈ cfgTapes c, t.StartInvariant) + (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) : + List.Forallβ‚‚ (fun (a : Ξ“ Γ— Dir3) (t : Tape) => + (t.head = 0 β†’ a.1 = t.cells t.head) ∧ + (a.2 β‰  Dir3.right β†’ t.head β‰  0) ∧ t.head ≀ W) + (stepActs tm c) (cfgTapes c) := by + obtain ⟨hri, hrw, hro⟩ := + tm.Ξ΄_right_of_start c.state c.input.read (fun i => (c.work i).read) c.output.read + have hmem_in : c.input ∈ cfgTapes c := by simp [cfgTapes] + have hmem_out : c.output ∈ cfgTapes c := by simp [cfgTapes] + have hmem_work : βˆ€ i, c.work i ∈ cfgTapes c := fun i => by + simp only [cfgTapes, List.mem_cons] + exact Or.inr (Or.inr (List.mem_ofFn.mpr ⟨i, rfl⟩)) + -- At cell `0` a tape reads `β–·`, which is what `Ξ΄_right_of_start` fires on. + have hzero : βˆ€ t ∈ cfgTapes c, t.head = 0 β†’ t.read = Ξ“.start := fun t ht h0 => by + rw [Tape.read, h0]; exact (hinv t ht).1 + rw [stepActs, cfgTapes] + refine List.Forallβ‚‚.cons ⟨fun _ => rfl, fun hd h0 => hd ?_, hW _ hmem_in⟩ + (List.Forallβ‚‚.cons + ⟨fun h0 => correctWrite_at_zero _ (hinv _ hmem_out) h0, + fun hd h0 => hd ?_, hW _ hmem_out⟩ + (forallβ‚‚_ofFn fun i => + ⟨fun h0 => correctWrite_at_zero _ (hinv _ (hmem_work i)) h0, + fun hd h0 => hd ?_, hW _ (hmem_work i)⟩)) + Β· exact hri (hzero _ hmem_in h0) + Β· exact hro (hzero _ hmem_out h0) + Β· exact hrw i (hzero _ (hmem_work i) h0) + +/-- **Tape `j` lives in blocks `2j` and `2j+1`** of the tape-block list. Combined +with the state block at the front of `cfgBlocks`, tape `j` of a configuration +occupies blocks `2j+1` and `2j+2` β€” which is how `Cobham.blockFn` addresses +them. -/ +theorem getElem?_tapesBlocks (W : β„•) : + βˆ€ (ts : List Tape) (j : β„•), + (tapesBlocks W ts)[2 * j]? = + (ts[j]?).map (fun t => padTo (blockRuler W) (leftCode t)) ∧ + (tapesBlocks W ts)[2 * j + 1]? = + (ts[j]?).map (fun t => padTo (blockRuler W) (rightCode t W)) := by + intro ts + induction ts with + | nil => intro j; simp [tapesBlocks] + | cons t ts ih => + intro j + cases j with + | zero => simp [tapesBlocks, tapeBlocks] + | succ j => + have hlen : (tapeBlocks W t).length = 2 := rfl + have e1 : 2 * (j + 1) = (tapeBlocks W t).length + 2 * j := by + rw [hlen]; omega + rw [tapesBlocks, List.flatMap_cons, e1, + List.getElem?_append_right (by omega), + List.getElem?_append_right (by omega)] + simp only [Nat.add_sub_cancel_left, List.getElem?_cons_succ, + show (tapeBlocks W t).length + 2 * j + 1 - (tapeBlocks W t).length + = 2 * j + 1 from by omega] + exact ⟨(ih j).1, (ih j).2⟩ + +/-! ### Field accessors + +The first three blocks β€” the state and the input tape's two halves β€” read out +directly. Each is one `Cobham.blockFn` on the algebra side. -/ + +/-- Block `0` holds the state. -/ +theorem blockAt_cfgCode_state {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 0 + = padTo (blockRuler W) (stateCode c.state) := by + rw [blockAt_cfgCode W c 0 (by simp)] + rfl + +/-- Unpadding block `0` recovers the one-hot state code, which the transition +table then matches against its finitely many constants. -/ +theorem state_of_cfgCode {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (hW : Fintype.card Q ≀ blockWidth W) : + (blockAt (blockRuler W) (cfgCode W c) 0).take (Fintype.card Q) + = stateCode c.state := by + rw [blockAt_cfgCode_state, + take_padTo _ _ _ (by simp) (by rw [stateCode_length, blockRuler_length]; omega), + List.take_of_length_le (by simp)] + +/-- Block `1` is the input tape's left half. -/ +theorem blockAt_cfgCode_inputLeft {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 1 + = padTo (blockRuler W) (leftCode c.input) := by + rw [blockAt_cfgCode W c 1 (by simp)] + rfl + +/-- Block `2` is the input tape's right half β€” the one the read symbol comes +from. -/ +theorem blockAt_cfgCode_inputRight {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 2 + = padTo (blockRuler W) (rightCode c.input W) := by + rw [blockAt_cfgCode W c 2 (by rw [cfgBlocks_length]; omega)] + rfl + +/-- The input head's symbol, read straight out of the encoding. -/ +theorem inputRead_of_cfgCode {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (hW : c.input.head ≀ W) : + symDecode ((blockAt (blockRuler W) (cfgCode W c) 2).take 2) = c.input.read := by + rw [blockAt_cfgCode_inputRight] + exact symDecode_take_padTo_rightCode c.input hW + + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Extract.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Extract.lean new file mode 100644 index 0000000000..8adebd3e76 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Extract.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Blocks +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra + +/-! +# Reading a string out of an encoded tape β€” proof internals + +The completeness direction ends by reading the simulated machine's output off +its encoded output tape. Once the output head has been driven back to cell `0` +(see `Complexitylib.Classes.P.Cobham.Internal.StepAlgebra`), that tape's right +half-block is the whole tape in order, two bits per cell: the first bit of a +cell says whether it holds data, the second is the data bit. + +So the output is recovered by two short recursions on notation, both collected +here: + +* `Complexity.cellBits` β€” every second bit of a string, from a fixed offset; + used twice, once for the "is data" bits and once for the data bits; +* `Complexity.runTrue` β€” the leading run of `true`s, as a ruler; its length is + where the first blank cell is, hence the output's length. + +## Main results + +- `Complexity.Cobham.cellBitsFn`, `Complexity.Cobham.runTrueFn` β€” both are in + the algebra +- `Complexity.runTrue_length` β€” the run's length is where the first `false` is, + clamped by the ruler +-/ + + +@[expose] public section + +namespace Complexity + +/-! ## Reading a single bit -/ + +/-- The bit of `z` at position `p`, `false` past the end. -/ +def bitOf (z : List Bool) (p : β„•) : Bool := (z.drop p).headD false + +/-- Within range, `bitOf` is the indexed bit. -/ +theorem bitOf_eq_getElem {z : List Bool} {p : β„•} (h : p < z.length) : + bitOf z p = z[p] := by + rw [bitOf, List.drop_eq_getElem_cons h, List.headD_cons] + +/-- Past the end there is no bit. -/ +theorem bitOf_of_le {z : List Bool} {p : β„•} (h : z.length ≀ p) : + bitOf z p = false := by + rw [bitOf, List.drop_eq_nil_of_le h, List.headD_nil] + +/-- Reading inside the first part of a concatenation. -/ +theorem bitOf_append_left {a : List Bool} {p : β„•} (h : p < a.length) (b : List Bool) : + bitOf (a ++ b) p = bitOf a p := by + rw [bitOf, bitOf, List.drop_append_of_le_length h.le, List.drop_eq_getElem_cons h] + rw [List.cons_append, List.headD_cons, List.headD_cons] + +/-- Reading past the first part of a concatenation. -/ +theorem bitOf_append_right {a : List Bool} {p : β„•} (h : a.length ≀ p) (b : List Bool) : + bitOf (a ++ b) p = bitOf b (p - a.length) := by + rw [bitOf, bitOf, List.drop_append, List.drop_eq_nil_of_le h, List.nil_append] + +/-- `Cobham.bitAt` reads exactly one bit, and it is `bitOf`. -/ +theorem bitAt_eq (r z : List Bool) : bitAt r z = [bitOf z r.length] := by + rw [bitAt, bitOf] + cases h : z.drop r.length with + | nil => rw [caseBitβ‚€_nil, List.headD_nil] + | cons b l => cases b <;> rw [caseBitβ‚€_cons] <;> rfl + +/-! ## Every second bit + +`cellBits o z m` lists the bits of `z` at positions `o, o + 2, …, o + 2(m-1)`. +With `z` a run of two-bit symbol codes, offset `o` picks out one bit of each +symbol β€” which is how both halves of a coded cell are read. -/ + +/-- The bits of `z` at positions `2i + o` for `i < m`. -/ +def cellBits (o : β„•) (z : List Bool) : β„• β†’ List Bool + | 0 => [] + | m + 1 => cellBits o z m ++ [bitOf z (2 * m + o)] + +@[simp] theorem cellBits_length (o : β„•) (z : List Bool) (m : β„•) : + (cellBits o z m).length = m := by + induction m with + | zero => rfl + | succ m ih => rw [cellBits, List.length_append, ih]; rfl + +theorem cellBits_getElem? (o : β„•) (z : List Bool) : + βˆ€ (m i : β„•), i < m β†’ (cellBits o z m)[i]? = some (bitOf z (2 * i + o)) := by + intro m + induction m with + | zero => intro i h; omega + | succ m ih => + intro i h + rw [cellBits] + rcases Nat.lt_or_ge i m with hi | hi + Β· rw [List.getElem?_append_left (by simpa using hi)] + exact ih i hi + Β· have him : i = m := by omega + subst him + rw [List.getElem?_append_right (by simp)] + simp + +/-! ## The leading run of `true`s + +The output tape's "is data" bits are `true` on the output and `false` at the +first blank past it, so the output's length is the length of the leading run of +`true`s. The recursion below computes it as a ruler, clamped at the width it is +run to: the guard `m ≀ |previous|` is what stops the run at the first `false` +rather than restarting after it. -/ + +/-- The leading run of `true`s of `z`, clamped to `m` bits, as a ruler. -/ +def runTrue (z : List Bool) : β„• β†’ List Bool + | 0 => [] + | m + 1 => + runTrue z m ++ (if m ≀ (runTrue z m).length ∧ bitOf z m = true then [true] else []) + +theorem runTrue_length_le (z : List Bool) (m : β„•) : (runTrue z m).length ≀ m := by + induction m with + | zero => rfl + | succ m ih => + rw [runTrue, List.length_append] + split <;> simp <;> omega + +/-- **The run's length is where the first `false` is.** The guard in `runTrue` +stops the run at the first `false` rather than restarting after it, so the run's +length is the position of the first `false`, clamped by the width. -/ +theorem runTrue_length {z : List Bool} {n : β„•} (htrue : βˆ€ i < n, bitOf z i = true) + (hfalse : bitOf z n = false) (m : β„•) : + (runTrue z m).length = min m n := by + induction m with + | zero => simp [runTrue] + | succ m ih => + rw [runTrue, List.length_append, ih] + rcases Nat.lt_or_ge m n with hm | hm + Β· rw [ite_eq_left ⟨by omega, htrue m hm⟩] + simp only [List.length_cons, List.length_nil] + omega + Β· rw [ite_eq_right ?_] + Β· simp only [List.length_nil] + omega + Β· rintro ⟨h1, h2⟩ + have hme : m = n := by omega + rw [hme, hfalse] at h2 + exact Bool.noConfusion h2 + +/-! ## Both recursions are in the algebra -/ + +namespace Cobham + +/-- The step of `cellBits`: append the bit of the string at twice the remaining +ruler's length, plus the offset. -/ +private def cellStep (o : β„•) (w : Fin 3 β†’ List Bool) : List Bool := + w 1 ++ bitAt (w 0 ++ w 0 ++ List.replicate o false) (w 2) + +private theorem cellStep_cons (o : β„•) (x p : List Bool) (v : Fin 1 β†’ List Bool) : + cellStep o (Fin.cons x (Fin.cons p v)) + = p ++ bitAt (x ++ x ++ List.replicate o false) (v 0) := rfl + +/-- The step of `runTrue`: extend the run by one only when it has kept pace with +the ruler so far and the next bit is `true`. -/ +private def runStep (w : Fin 3 β†’ List Bool) : List Bool := + w 1 ++ caseBitβ‚€ + (andBit (notBit (nonemptyFlag ((w 0).drop (w 1).length))) (bitAt (w 0) (w 2))) + [true] [] + +private theorem runStep_cons (x p : List Bool) (v : Fin 1 β†’ List Bool) : + runStep (Fin.cons x (Fin.cons p v)) + = p ++ caseBitβ‚€ + (andBit (notBit (nonemptyFlag (x.drop p.length))) (bitAt x (v 0))) [true] [] := + rfl + +/-- **Every second bit is in the algebra.** One limited recursion on notation: +each peeled bit of the ruler appends one more bit of `z`, read at twice the +remaining ruler's length plus the offset. -/ +theorem cellBitsFn {n : β„•} (o : β„•) {gr gz : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => cellBits o (gz v) (gr v).length := by + have hrec : βˆ€ (x : List Bool) (v : Fin 1 β†’ List Bool), + recNotation (fun _ : Fin 1 β†’ List Bool => ([] : List Bool)) (cellStep o) + (cellStep o) x v = cellBits o (v 0) x.length := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + have hlen : (x ++ x ++ List.replicate o false).length = 2 * x.length + o := by + simp; omega + cases b <;> + Β· rw [recNotation_cons] + simp only [Bool.cond_true, Bool.cond_false] + rw [cellStep_cons, ih, bitAt_eq, hlen, List.length_cons, cellBits] + have hh : Cobham (cellStep o) := + (appendFn (Cobham.proj 1) + (compβ‚‚ bitAtFn + (appendFn (appendFn (Cobham.proj 0) (Cobham.proj 0)) + (Cobham.const (List.replicate o false))) + (Cobham.proj 2))).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 2 β†’ List Bool => cellBits o (v 1) (v 0).length := by + refine (Cobham.boundedRec Cobham.empty hh hh (Cobham.proj 0) ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec, cellBits_length, Fin.cons_zero] + Β· rw [hrec]; rfl + exact (compβ‚‚ hbase hr hz).of_eq fun _ => rfl + +/-- **The leading run of `true`s is in the algebra.** One limited recursion on +notation: the run grows by one only while it has kept pace with the ruler, which +is the length comparison `nonemptyFn`/`notFn` performs. -/ +theorem runTrueFn {n : β„•} {gr gz : (Fin n β†’ List Bool) β†’ List Bool} + (hr : Cobham gr) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => runTrue (gz v) (gr v).length := by + have hrec : βˆ€ (x : List Bool) (v : Fin 1 β†’ List Bool), + recNotation (fun _ : Fin 1 β†’ List Bool => ([] : List Bool)) runStep runStep x v + = runTrue (v 0) x.length := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + cases b <;> + Β· rw [recNotation_cons] + simp only [Bool.cond_true, Bool.cond_false] + rw [runStep_cons, ih, bitAt_eq, List.length_cons, runTrue] + congr 1 + rcases Nat.lt_or_ge (runTrue (v 0) x.length).length x.length with hlt | hge + Β· rw [ite_eq_right (by omega)] + cases hd : x.drop (runTrue (v 0) x.length).length with + | nil => rw [List.drop_eq_nil_iff] at hd; omega + | cons c l => cases c <;> rfl + Β· rw [List.drop_eq_nil_of_le hge] + cases hb : bitOf (v 0) x.length + Β· rw [ite_eq_right (by simp)]; rfl + Β· rw [ite_eq_left ⟨hge, rfl⟩]; rfl + have hh : Cobham runStep := + (appendFn (Cobham.proj 1) + (iteFn + (andFn (notFn (nonemptyFn (dropFn (Cobham.proj 1) (Cobham.proj 0)))) + (compβ‚‚ bitAtFn (Cobham.proj 0) (Cobham.proj 2))) + (Cobham.const [true]) Cobham.empty)).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 2 β†’ List Bool => runTrue (v 1) (v 0).length := by + refine (Cobham.boundedRec Cobham.empty hh hh (Cobham.proj 0) ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec, Fin.cons_zero] + exact runTrue_length_le _ _ + Β· rw [hrec]; rfl + exact (compβ‚‚ hbase hr hz).of_eq fun _ => rfl + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean new file mode 100644 index 0000000000..1eaafe5833 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# The block-payload decoder β€” proof internals + +`Cobham.fstBlockTM` is the same scan as `Cobham.sndBlockTM`, emitting each +decoded payload bit as it goes and stopping at the separator. Malformed input +halts with empty output. + +## Main results + +- `Cobham.fstBlock_mem_FP` β€” the payload decoder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- The payload decoder: scan doubled payload bits, emitting each decoded bit to +the output, until the `[false, true]` separator or end of input. Computes +`fstBlock`. -/ +def fstBlockTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Ξ“.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Ξ“.zero => + (.scanA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Ξ“.one => + (.scanA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => allIdle .done iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => exact rightOfStart_allIdle iHead wHeads oHead + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- An incomplete final payload bit stops the first-block scanner without emitting output. -/ +private theorem fstBlockTM_scan_single + (b : Bool) (acc : List Bool) (c : Cfg 0 fstBlockTM.Q) + (hstate : c.state = ScanPhase.scanA) + (hsuf : c.input.HasBinarySuffix [b]) + (hpre : c.output.HasBinaryPrefix acc) : + βˆƒ c' t, t ≀ 2 * [b].length + 2 ∧ fstBlockTM.reachesIn t c c' ∧ + fstBlockTM.halted c' ∧ c'.output.HasBinaryPrefix (acc ++ fstBlock [b]) := by + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + cases b with + | false => + have hread : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, fstBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true => + have hread : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, fstBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + +/-- The scan of `fstBlockTM`: from `scanA` on input `w` with output holding `acc`, +the machine emits the decoded payload of `w`, halting with `acc ++ fstBlock w`. -/ +private theorem fstBlockTM_scan_loop : + βˆ€ (fuel : β„•) (w acc : List Bool), w.length ≀ fuel β†’ βˆ€ (c : Cfg 0 fstBlockTM.Q), + c.state = ScanPhase.scanA β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ 2 * w.length + 2 ∧ fstBlockTM.reachesIn t c c' ∧ fstBlockTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ fstBlock w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, fstBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, fstBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | [false] => exact fstBlockTM_scan_single false acc c hstate hsuf hpre + | [true] => exact fstBlockTM_scan_single true acc c hstate hsuf hpre + | false :: true :: y => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, fstBlockTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true :: false :: rest => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, fstBlockTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: false :: z => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool false) Dir3.right } + have hstepB : fstBlockTM.step c1 = some c2 := by + simp [TM.step, fstBlockTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool false).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (false :: false :: z) = false :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + | true :: true :: z => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool true) Dir3.right } + have hstepB : fstBlockTM.step c1 = some c2 := by + simp [TM.step, fstBlockTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool true).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (true :: true :: z) = true :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + +/-- `fstBlock` is polynomial-time, via the `fstBlockTM` scanner. -/ +theorem fstBlock_mem_FP : fstBlock ∈ FP := by + refine ⟨1, 0, fstBlockTM, (fun m => 2 * m + 3), ?_, ?_⟩ + Β· intro z + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : fstBlockTM.step (fstBlockTM.initCfg z) = some c1 := by + simp [TM.step, fstBlockTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + fstBlockTM_scan_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≀ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + Β· have hn : (fun m : β„• => 2 * m) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using (BigO.refl (fun m : β„• => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean new file mode 100644 index 0000000000..ea9773f87a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines + +/-! +# Testing a leading bit β€” proof internals + +Every other `FP` primitive the Cobham proof uses β€” `Complexity.takeLen`, +`List.reverse`, `Complexity.pair`, `Cobham.mulUnpair` β€” fixes its output's +*length* from its inputs' lengths alone, so none of them can react to a bit's +value. `Complexity.headFlag` closes that gap by turning a bit test into a length: +the answer is carried by whether the result is empty. Its two-state transducer +moves off the left-end marker, then emits one bit exactly when the first input +bit matches. + +## Main results + +- `Complexity.headFlag_mem_FP` β€” the leading-bit test is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-- `[false]` when `x` begins with `target`, and `[]` otherwise: a bit test whose +answer is carried by the *length* of the result. -/ +def headFlag (target : Bool) (x : List Bool) : List Bool := + if x.head? = some target then [false] else [] + +/-- Control states of the head-bit flag machine. -/ +inductive HeadPhase where + /-- Advance past the left-end markers. -/ + | skip + /-- Read the first input bit. -/ + | test + /-- Halted. -/ + | done + deriving DecidableEq + +instance instFintypeHeadPhase : Fintype HeadPhase where + elems := {.skip, .test, .done} + complete := fun p => by cases p <;> simp + +/-- Read the first input bit and emit one output bit exactly when it is +`target`. Two steps: `skip` moves off the left-end markers, `test` reads the bit +and either writes or not. -/ +def headFlagTM (target : Bool) : TM 0 where + Q := HeadPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.test, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .test => + if iHead = Ξ“.ofBool target then + (.done, fun i => readBackWrite (wHeads i), Ξ“w.zero, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + else + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .test => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Writing back the symbol already under the head changes nothing. -/ +private theorem write_read_self' (t : Tape) : t.write t.read = t := by + rw [Tape.write] + split + Β· rfl + Β· exact Tape.ext rfl (Function.update_eq_self _ _) + +/-- The input's first cell after the marker holds the first bit, or blank. -/ +private theorem headFlagTM_read (x : List Bool) : + ((Tape.init (x.map Ξ“.ofBool)).move Dir3.right).read + = (x.head?).elim Ξ“.blank Ξ“.ofBool := by + cases x with + | nil => simp [Tape.read, Tape.move, Tape.init] + | cons a t => cases a <;> simp [Tape.read, Tape.move, Tape.init, Ξ“.ofBool] + +/-- `headFlagTM target` computes `headFlag target` in two steps. -/ +theorem headFlagTM_computesInTime (target : Bool) : + (headFlagTM target).ComputesInTime (headFlag target) (fun _ => 2) := by + intro x + let c1 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.test + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).writeAndMove + (readBackWrite (Tape.init []).read) (idleDir (Tape.init []).read) + output := (Tape.init []).move Dir3.right } + have hstep1 : (headFlagTM target).step ((headFlagTM target).initCfg x) = some c1 := by + simp [TM.step, headFlagTM, c1, Tape.read, Tape.init, idleDir, Tape.writeAndMove, + Tape.write, Tape.move] + have hread : c1.input.read = (x.head?).elim Ξ“.blank Ξ“.ofBool := + headFlagTM_read x + by_cases hb : x.head? = some target + Β· -- The bit matches: one output cell is written. + have hri : c1.input.read = Ξ“.ofBool target := by rw [hread, hb]; rfl + let c2 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove + (readBackWrite (c1.work i).read) (idleDir (c1.work i).read) + output := c1.output.writeAndMove Ξ“w.zero.toΞ“ Dir3.right } + have hstep2 : (headFlagTM target).step c1 = some c2 := by + simp [TM.step, headFlagTM, c1, c2, hri] + refine ⟨c2, 2, le_rfl, .step hstep1 (.step hstep2 .zero), rfl, ?_⟩ + rw [headFlag, ite_eq_left hb] + refine ⟨fun i hi => ?_, ?_⟩ + Β· have hi0 : i = 0 := by simpa using hi + subst hi0 + simp [c2, c1, Tape.write, Tape.move, Tape.init, Ξ“w.toΞ“, Ξ“.ofBool] + Β· simp [c2, c1, Tape.write, Tape.move, Tape.init, Ξ“w.toΞ“] + Β· -- The bit does not match: nothing is written. + have hri : c1.input.read β‰  Ξ“.ofBool target := by + rw [hread] + cases hx : x.head? with + | none => cases target <;> simp [Ξ“.ofBool] + | some a => + rw [hx] at hb + simp only [Option.elim] + cases a <;> cases target <;> simp_all [Ξ“.ofBool] + let c2 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove + (readBackWrite (c1.work i).read) (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read).toΞ“ + (idleDir c1.output.read) } + have hstep2 : (headFlagTM target).step c1 = some c2 := by + simp [TM.step, headFlagTM, c1, c2, hri] + refine ⟨c2, 2, le_rfl, .step hstep1 (.step hstep2 .zero), rfl, ?_⟩ + rw [headFlag, ite_eq_right hb] + refine ⟨fun i hi => by simp at hi, ?_⟩ + have hoc : c1.output.read = Ξ“.blank := by + simp [c1, Tape.read, Tape.move, Tape.init] + have hcells : c2.output.cells = c1.output.cells := by + show ((c1.output.write ((readBackWrite c1.output.read).toΞ“)).move + (idleDir c1.output.read)).cells = c1.output.cells + rw [Tape.move_cells, + show (readBackWrite c1.output.read).toΞ“ = c1.output.read from by rw [hoc]; rfl, + write_read_self'] + rw [hcells] + simp [c1, Tape.move, Tape.init] + +/-- **A bit test, as a length.** -/ +theorem headFlag_mem_FP (target : Bool) : headFlag target ∈ FP := + ⟨1, 0, headFlagTM target, (fun _ => 2), headFlagTM_computesInTime target, + BigO.const_le_pow 2 1⟩ + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean new file mode 100644 index 0000000000..2ca0122f51 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean @@ -0,0 +1,966 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Horner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.InputLen +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolyBound +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm + +/-! +# The bounded-iteration machine β€” proof internals + +`Complexity.Cobham.iterate_mem_FP` needs one machine: given a polynomial-time +`G`, a machine that applies `G` to its own input `|x|` times. This file builds +it out of the phase contracts of +`Complexitylib.Classes.P.Cobham.Internal.IterateLayout`. + +## Layout + +Three bookkeeping tapes (`rfIdx` the loop's fuel register, `wfIdx` the reset's +fuel register, `junkIdx` scratch for the register arithmetic) followed by +`TM.applyTM`'s own block (`appIdx`), whose virtual input `vinIdx` carries the +running value and whose last tape `resIdx` receives each result. + +## Phases + +* `Complexity.iterTail` β€” the five phases that follow every application: park, + rewind the result, blank the scratch, move the result into virtual-input + position, blank the result tape. Shared by the loop body and the setup. +* `Complexity.iterBody` β€” one application of the iterated function followed by + the tail; this is what the loop iterates. +* `Complexity.iterSetup` β€” bump, load `|x|` into the loop register, evaluate a + padding polynomial into the reset register, put `pair [] x` on the result + tape, then the tail. +* `Complexity.iterTM` β€” setup, loop, and one final application whose output is + the real output tape. +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +variable {k : β„•} + +/-! ## A confinement frame for an arbitrary bounded run + +Resetting the scratch of an opaque machine needs to know how far its heads can +have travelled. Any `b`-step run from tapes parked at cell `1` and blank beyond +it stays inside cell `1 + b`. -/ + +/-- **Every bounded run is confined.** From work tapes parked at cell `1` whose +content is confined to cell `1`, a `b`-step run leaves every work tape inside +`H` and blank beyond `H`. -/ +theorem hoareTime_confined {n : β„•} {tm : TM n} {pre post : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) (W : Fin n β†’ Tape) (H : β„•) (hH : 1 + b ≀ H) + (S : Fin n β†’ Prop) (hWSI : βˆ€ i, Tape.StartInvariant (W i)) + (hWh : βˆ€ i, S i β†’ (W i).head = 1) + (hWfar : βˆ€ i, S i β†’ βˆ€ j, 1 < j β†’ (W i).cells j = Ξ“.blank) : + tm.HoareTime + (fun inp work out => pre inp work out ∧ work = W ∧ + Tape.StartInvariant inp ∧ Tape.StartInvariant out) + (fun inp work out => post inp work out ∧ Tape.StartInvariant inp ∧ + Tape.StartInvariant out ∧ + βˆ€ i, Tape.StartInvariant (work i) ∧ (S i β†’ + (work i).head ≀ H ∧ βˆ€ j, H < j β†’ (work i).cells j = Ξ“.blank)) + b := by + rintro inp work out ⟨hpre, rfl, hinpSI, houtSI⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp work out hpre + have hSI := TM.reachesIn_startInvariant hreach hinpSI hWSI houtSI + refine ⟨c', t, ht, hreach, hhalt, hpost, hSI.1, hSI.2.2, + fun i => ⟨hSI.2.1 i, fun hSi => ⟨?_, fun j hj => ?_⟩⟩⟩ + Β· have hh := (head_le_start_add_of_reachesIn tm hreach).2.2 i + rw [show ((⟨tm.qstart, inp, work, out⟩ : Cfg n tm.Q).work i).head = 1 from hWh i hSi] at hh + omega + Β· rw [TM.reachesIn_work_cells_far hreach i j (by rw [show + ((⟨tm.qstart, inp, work, out⟩ : Cfg n tm.Q).work i).head = 1 from hWh i hSi]; omega)] + exact hWfar i hSi j (by omega) + +/-! ## The shared tail + +Every application of the iterated function β€” the loop body's, and the setup's +`pair [] x` β€” leaves its result on `resIdx` with the scratch dirty. The five +phases below restore the entry shape `TM.applyPre` demands. -/ + +/-- Park, rewind the result, blank the witness machine's scratch and the +virtual input, move the result into virtual-input position, blank the result +tape. -/ +def iterTail (k : β„•) : TM (3 + (k + 2) + 0) := + seqTM + (seqTM (seqTM skipTM (rewindWorkTM resIdx)) (resetTapesTM (resetTargets k) wfIdx)) + (seqTM (copyToVirtualInputTM resIdx vinIdx) (resetTapesTM (resetResult k) wfIdx)) + +/-- `Complexity.iterTail`'s time bound. -/ +def tailBound (k H m : β„•) : β„• := + 1 + 1 + (H + 1 + 2) + 1 + + ((k + 1) * (H + 4) + H * 4 + 8 + 1 + ((k + 1) * (H + 4) + 1)) + 1 + + (2 * m + 5 + 1 + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1))) + +theorem startInvariant_regTape (H : β„•) : Tape.StartInvariant (regTape H) := + ⟨by rw [regT_cells]; simp [regCells], (parked_regTape H).2⟩ + +/-- **The tail's contract.** From a result tape carrying `v` and a block whose +tapes are confined to `1 … H`, the five phases rebuild `TM.applyPre M v`. -/ +theorem iterTail_hoareTime (M : TM k) (H : β„•) (v : List Bool) (hv : v.length + 1 ≀ H) + (inpβ‚€ : Tape) (hinpP : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (rfT junkT : Tape) (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (iterTail k).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work resIdx).HasOutput v ∧ + (βˆ€ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + work rfIdx = rfT ∧ work wfIdx = regTape H ∧ work junkIdx = junkT) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (βˆ€ j, work (appIdx j) = TM.applyPre M v inpβ‚€ j)) + (tailBound k H v.length) := by + intro inp work out hpre + obtain ⟨hi, ho, hres, hbnd, hrf, hwf, hjunk⟩ := hpre + subst hi + subst ho + have houtP : Parked parkedBlank := parked_parkedBlank + have houtSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hregSI : Tape.StartInvariant (regTape H) := startInvariant_regTape H + have hSI : βˆ€ i, Tape.StartInvariant (work i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, hrf]; exact hrfSI + Β· rw [h, hwf]; exact hregSI + Β· rw [h, hjunk]; exact hjunkSI + Β· rw [h]; exact (hbnd j).1 + -- the three phase contracts, instantiated at the actual tape family + have hpark := iterPark_hoareTime H inp hinpP hinpSI work hSI (hbnd (Fin.last (k + 1))).2.1 + have hrst := iterResetScratch_hoareTime H (by omega) inp hinpP hinpSI work hSI + (fun j => (hbnd (Fin.castSucc j)).2.1) + (fun j c hc => (hbnd (Fin.castSucc j)).2.2 c hc) hwf + have hrfeq : (⟨max (work rfIdx).head 1, (work rfIdx).cells⟩ : Tape) = rfT := by + rw [hrf] + exact Tape.ext (by show max rfT.head 1 = rfT.head; have := hrfP.1; omega) rfl + have hjunkeq : (⟨max (work junkIdx).head 1, (work junkIdx).cells⟩ : Tape) = junkT := by + rw [hjunk] + exact Tape.ext (by show max junkT.head 1 = junkT.head; have := hjunkP.1; omega) rfl + have hfin := iterFinish_hoareTime M H v hv inp hinpP hinpSI + (⟨1, (work resIdx).cells⟩ : Tape) rfT junkT rfl + ((Tape.hasOutput_congr rfl v).mp hres) + ⟨(hbnd (Fin.last (k + 1))).1.1, fun c hc => (hbnd (Fin.last (k + 1))).1.2 c hc⟩ + (fun c hc => (hbnd (Fin.last (k + 1))).2.2 c hc) + hrfP hrfSI hjunkP hjunkSI + -- chain the three, converting the seams through the parked frame + have hAB := seqTM_hoareTime _ _ hpark (by + rintro inp' work' out' ⟨rfl, rfl, e3, e4, e5⟩ + have hP : βˆ€ i, Parked (work' i) := by + intro i + by_cases hir : i = resIdx + Β· exact ⟨by rw [hir, e3], fun c hc => by rw [hir, e4]; exact (hSI resIdx).2 c hc⟩ + Β· rw [e5 i hir] + exact ⟨le_max_right _ _, fun c hc => (hSI i).2 c hc⟩ + obtain ⟨t1, t2, t3⟩ := parked_transition hinpP hP houtP + rw [t1, t2, t3] + exact ⟨rfl, rfl, e3, e4, e5⟩) hrst + have hABC := seqTM_hoareTime _ _ hAB (by + rintro inp' work' out' ⟨rfl, rfl, e3, e4, e5, e6, e7, e8⟩ + have hP : βˆ€ i, Parked (work' i) := by + intro i + by_cases hir : i = resIdx + Β· exact ⟨by rw [hir, e3], fun c hc => by rw [hir, e4]; exact (hSI resIdx).2 c hc⟩ + Β· rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, e7, hrfeq]; exact hrfP + Β· rw [h, e6]; exact parked_regTape H + Β· rw [h, e8, hjunkeq]; exact hjunkP + Β· by_cases hjl : j = Fin.last (k + 1) + Β· exact absurd (by rw [h, hjl]; rfl) hir + Β· have hjv : j.val < k + 1 := + lt_of_le_of_ne (Nat.lt_succ_iff.mp j.isLt) (fun hc => hjl (Fin.ext hc)) + rw [h, show j = Fin.castSucc (⟨j.val, hjv⟩ : Fin (k + 1)) from Fin.ext rfl, + e5 ⟨j.val, hjv⟩] + exact houtP + obtain ⟨t1, t2, t3⟩ := parked_transition hinpP hP houtP + rw [t1, t2, t3] + exact ⟨rfl, rfl, Tape.ext e3 e4, e7.trans hrfeq, e8.trans hjunkeq, e6, e5⟩) hfin + exact hABC inp work parkedBlank ⟨rfl, rfl, rfl⟩ + +/-! ## One iteration + +The loop body is one application of the iterated function followed by the +tail. -/ + +/-- One combinator seam on a tape satisfying the left-marker invariant: the +cells are untouched and the head only ever bounces off `β–·`. -/ +theorem transitionTape_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + transitionTape t = (⟨max t.head 1, t.cells⟩ : Tape) := by + by_cases hh : t.read = Ξ“.start + Β· have hh0 : t.head = 0 := by + by_contra hc + exact (h.2 t.head (by omega)) hh + refine Tape.ext ?_ (transitionTape_cells t (fun j hj => h.2 j hj)) + have h1 := one_le_head_transitionTape t h.1 + have h2 := head_transitionTape_le (p_bound := 0) h.1 (le_of_eq hh0) + show (transitionTape t).head = max t.head 1 + omega + Β· rw [transitionTape_eq_self hh] + have hh0 : t.head β‰  0 := fun hc => hh (by rw [Tape.read, hc]; exact h.1) + exact Tape.ext (by show t.head = max t.head 1; omega) rfl + +/-- The three bookkeeping tapes, packaged as a placement frame. -/ +def bookTapes (rfT junkT : Tape) (H : β„•) : Fin (3 + (k + 2) + 0) β†’ Tape := + fun i => if i = rfIdx then rfT else if i = wfIdx then regTape H else junkT + +@[simp] theorem bookTapes_rf (rfT junkT : Tape) (H : β„•) : + bookTapes (k := k) rfT junkT H rfIdx = rfT := by + rw [bookTapes, ite_eq_left rfl] + +@[simp] theorem bookTapes_wf (rfT junkT : Tape) (H : β„•) : + bookTapes (k := k) rfT junkT H wfIdx = regTape H := by + rw [bookTapes, ite_eq_right (fun h => rfIdx_ne_wfIdx h.symm), ite_eq_left rfl] + +@[simp] theorem bookTapes_junk (rfT junkT : Tape) (H : β„•) : + bookTapes (k := k) rfT junkT H junkIdx = junkT := by + rw [bookTapes, ite_eq_right junkIdx_ne_rfIdx, ite_eq_right junkIdx_ne_wfIdx] + +theorem eq_bookTapes_of_not_middle {work : Fin (3 + (k + 2) + 0) β†’ Tape} + {rfT junkT : Tape} {H : β„•} + (hrf : work rfIdx = rfT) (hwf : work wfIdx = regTape H) (hjunk : work junkIdx = junkT) : + βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ work i = bookTapes rfT junkT H i := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, hrf, bookTapes_rf] + Β· rw [h, hwf, bookTapes_wf] + Β· rw [h, hjunk, bookTapes_junk] + Β· exact absurd (h β–Έ appIdx_middle j) hi + +theorem bookTapes_startInvariant {rfT junkT : Tape} {H : β„•} + (hrfSI : Tape.StartInvariant rfT) (hjunkSI : Tape.StartInvariant junkT) : + βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ Tape.StartInvariant (bookTapes rfT junkT H i) := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, bookTapes_rf]; exact hrfSI + Β· rw [h, bookTapes_wf]; exact startInvariant_regTape H + Β· rw [h, bookTapes_junk]; exact hjunkSI + Β· exact absurd (h β–Έ appIdx_middle j) hi + +theorem bookTapes_head {rfT junkT : Tape} {H : β„•} + (hrfP : Parked rfT) (hjunkP : Parked junkT) : + βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ 1 ≀ (bookTapes rfT junkT H i).head := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, bookTapes_rf]; exact hrfP.1 + Β· rw [h, bookTapes_wf]; exact (parked_regTape H).1 + Β· rw [h, bookTapes_junk]; exact hjunkP.1 + Β· exact absurd (h β–Έ appIdx_middle j) hi + +/-- The loop body: apply the iterated function once, then restore the entry +shape. -/ +def iterBody (M : TM k) : TM (3 + (k + 2) + 0) := + seqTM (placeWorkTM 3 0 (TM.applyTM M)) (iterTail k) + +/-- **The body's contract.** From the entry shape for `y`, the body reaches the +entry shape for `G y`, holding both registers and the junk tape fixed. -/ +theorem iterBody_hoareTime (M : TM k) {G : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime G T) (H : β„•) (y : List Bool) + (hHy : y.length ≀ H) (hHT : 1 + T y.length ≀ H) (hGy : (G y).length + 1 ≀ H) + (inpβ‚€ : Tape) (hinpP : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (rfT junkT : Tape) (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (iterBody M).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (βˆ€ j, work (appIdx j) = TM.applyPre M y inpβ‚€ j) ∧ + work rfIdx = rfT ∧ work wfIdx = regTape H ∧ work junkIdx = junkT) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (βˆ€ j, work (appIdx j) = TM.applyPre M (G y) inpβ‚€ j)) + (T y.length + 1 + tailBound k H (G y).length) := by + have happ := placedApply_hoareTime M hcomp y inpβ‚€ hinpP hinpSI H hHy hHT + (bookTapes rfT junkT H) (bookTapes_startInvariant hrfSI hjunkSI) + (bookTapes_head hrfP hjunkP) + refine seqTM_hoareTime _ _ (happ.weaken_pre ?_) ?_ + (iterTail_hoareTime M H (G y) hGy inpβ‚€ hinpP hinpSI rfT junkT hrfP hrfSI hjunkP hjunkSI) + Β· rintro inp work out ⟨hi, ho, happ', hrf, hwf, hjunk⟩ + exact ⟨hi, happ', eq_bookTapes_of_not_middle hrf hwf hjunk, ho⟩ + Β· rintro inp work out ⟨rfl, rfl, hres, hbnd, hext⟩ + dsimp only + have hrfe : work rfIdx = rfT := by + rw [hext rfIdx rfIdx_not_middle, bookTapes_rf] + have hwfe : work wfIdx = regTape H := by + rw [hext wfIdx wfIdx_not_middle, bookTapes_wf] + have hjunke : work junkIdx = junkT := by + rw [hext junkIdx junkIdx_not_middle, bookTapes_junk] + have hSIall : βˆ€ i, Tape.StartInvariant (work i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, hrfe]; exact hrfSI + Β· rw [h, hwfe]; exact startInvariant_regTape H + Β· rw [h, hjunke]; exact hjunkSI + Β· rw [h]; exact (hbnd j).1 + have htin : transitionInput inp = inp := transitionInput_eq_self hinpP.read_ne_start + have htout : transitionTape parkedBlank = parkedBlank := + transitionTape_eq_self parked_parkedBlank.read_ne_start + have hcells : βˆ€ i, (transitionTape (work i)).cells = (work i).cells := fun i => + transitionTape_cells _ (fun j hj => (hSIall i).2 j hj) + refine ⟨htin, htout, ?_, fun j => ⟨?_, ?_, ?_⟩, ?_, ?_, ?_⟩ + Β· exact (Tape.hasOutput_congr (hcells resIdx).symm (G y)).mp hres + Β· exact ⟨(hcells (appIdx j)) β–Έ (hbnd j).1.1, + fun c hc => (hcells (appIdx j)) β–Έ (hbnd j).1.2 c hc⟩ + Β· rw [transitionTape_of_startInvariant (hSIall (appIdx j))] + show max (work (appIdx j)).head 1 ≀ H + have := (hbnd j).2.1 + omega + Β· intro c hc + rw [hcells (appIdx j)] + exact (hbnd j).2.2 c hc + Β· rw [hrfe, transitionTape_eq_self hrfP.read_ne_start] + Β· rw [hwfe, transitionTape_eq_self (parked_regTape H).read_ne_start] + Β· rw [hjunke, transitionTape_eq_self hjunkP.read_ne_start] + +/-! ## The loop + +`TM.forRegTM` drives the body once per mark of the fuel register `rfIdx`, +threading the iteration-indexed ghost family below. -/ + +/-- The whole tape family at iteration `i`: the entry shape for the `i`-th +iterate on `TM.applyTM`'s block, the two registers, and the junk tape. -/ +def iterFamily (M : TM k) (Y : β„• β†’ List Bool) (inpβ‚€ junkT : Tape) (v H : β„•) : + β„• β†’ Fin (3 + (k + 2) + 0) β†’ Tape := + fun i j => if hj : placeWorkInMiddle 3 (k + 2) j + then TM.applyPre M (Y i) inpβ‚€ (placeWorkCoord 3 (k + 2) j hj) + else bookTapes (regTape v) junkT H j + +variable {M : TM k} {Y : β„• β†’ List Bool} {inpβ‚€ junkT : Tape} {v H : β„•} + +@[simp] theorem iterFamily_app (i : β„•) (j : Fin (k + 2)) : + iterFamily M Y inpβ‚€ junkT v H i (appIdx j) = TM.applyPre M (Y i) inpβ‚€ j := by + rw [iterFamily] + rw [dif_pos (appIdx_middle j)] + congr 1 + exact placeWorkCoord_placeWorkIdx 3 0 j + +theorem iterFamily_book (i : β„•) (j : Fin (3 + (k + 2) + 0)) + (hj : Β¬ placeWorkInMiddle 3 (k + 2) j) : + iterFamily M Y inpβ‚€ junkT v H i j = bookTapes (regTape v) junkT H j := by + rw [iterFamily, dite_eq_right hj] + +@[simp] theorem iterFamily_rf (i : β„•) : + iterFamily M Y inpβ‚€ junkT v H i rfIdx = regTape v := by + rw [iterFamily_book i rfIdx rfIdx_not_middle, bookTapes_rf] + +@[simp] theorem iterFamily_wf (i : β„•) : + iterFamily M Y inpβ‚€ junkT v H i wfIdx = regTape H := by + rw [iterFamily_book i wfIdx wfIdx_not_middle, bookTapes_wf] + +@[simp] theorem iterFamily_junk (i : β„•) : + iterFamily M Y inpβ‚€ junkT v H i junkIdx = junkT := by + rw [iterFamily_book i junkIdx junkIdx_not_middle, bookTapes_junk] + +theorem iterFamily_parked (hjunkP : Parked junkT) (i : β„•) (j : Fin (3 + (k + 2) + 0)) + (hj : j β‰  rfIdx) : Parked (iterFamily M Y inpβ‚€ junkT v H i j) := by + rcases layout_cases j with h | h | h | ⟨jj, h⟩ + Β· exact absurd h hj + Β· rw [h, iterFamily_wf]; exact parked_regTape H + Β· rw [h, iterFamily_junk]; exact hjunkP + Β· rw [h, iterFamily_app] + exact ⟨le_of_eq (TM.applyPre_head M (Y i) inpβ‚€ jj).symm, + fun c hc => (TM.applyPre_startInvariant M (Y i) inpβ‚€ jj).2 c hc⟩ + +/-- **The loop's contract.** `v` applications of the iterated function, each +returning the block to its entry shape. -/ +theorem iterLoop_hoareTime {G : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime G T) + (hY : βˆ€ i, Y (i + 1) = G (Y i)) + (hlen : βˆ€ i, i ≀ v β†’ (Y i).length + 1 ≀ H) + (hT : βˆ€ i, i < v β†’ 1 + T (Y i).length ≀ H) + (b_iter : β„•) + (hb : βˆ€ i, i < v β†’ T (Y i).length + 1 + tailBound k H (Y (i + 1)).length ≀ b_iter) + (hinpP : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (forRegTM (iterBody M) rfIdx).HoareTime + (EmitPred inpβ‚€ (iterFamily M Y inpβ‚€ junkT v H 0) []) + (EmitPred inpβ‚€ (iterFamily M Y inpβ‚€ junkT v H v) []) + (v * (b_iter + 2) + (v + 2)) := by + refine forRegTM_hoareTime (iterBody M) rfIdx v inpβ‚€ (iterFamily M Y inpβ‚€ junkT v H) + (fun _ => []) b_iter hinpP (fun i => iterFamily_rf i) + (fun i j hj => iterFamily_parked hjunkP i j hj) (fun i hi => ?_) + have hrfP : Parked (⟨i + 2, regCells v⟩ : Tape) := regIterCells_parked v i + have hrfSI : Tape.StartInvariant (⟨i + 2, regCells v⟩ : Tape) := + ⟨(startInvariant_regTape v).1, hrfP.2⟩ + have hbody := iterBody_hoareTime M hcomp H (Y i) + (by have := hlen i (by omega); omega) (hT i hi) + (by rw [← hY i]; exact hlen (i + 1) (by omega)) + inpβ‚€ hinpP hinpSI (⟨i + 2, regCells v⟩ : Tape) junkT hrfP hrfSI hjunkP hjunkSI + refine ((hbody.weaken_pre ?_).strengthen_post ?_).mono_bound ?_ + Β· rintro inp work out ⟨hi', hw, hout⟩ + refine ⟨hi', eq_parkedBlank_of_outAcc_nil hout, fun j => ?_, ?_, ?_, ?_⟩ + Β· rw [hw, Function.update_of_ne (fun h => rfIdx_ne_appIdx j h.symm), iterFamily_app] + Β· rw [hw, Function.update_self] + Β· rw [hw, Function.update_of_ne rfIdx_ne_wfIdx.symm, iterFamily_wf] + Β· rw [hw, Function.update_of_ne junkIdx_ne_rfIdx, iterFamily_junk] + Β· rintro inp work out ⟨hi', hout, hrf, hjunk, hwf, happ⟩ + refine ⟨hi', funext fun j => ?_, ?_⟩ + Β· rcases layout_cases j with h | h | h | ⟨jj, h⟩ + Β· rw [h, hrf, Function.update_self] + Β· rw [h, hwf, Function.update_of_ne rfIdx_ne_wfIdx.symm, iterFamily_wf] + Β· rw [h, hjunk, Function.update_of_ne junkIdx_ne_rfIdx, iterFamily_junk] + Β· rw [h, happ jj, Function.update_of_ne (fun hc => rfIdx_ne_appIdx jj hc.symm), + iterFamily_app, hY i] + Β· rw [hout] + exact outAcc_nil_of_parkedBlank + Β· rw [← hY i] + exact hb i hi + +/-! ## The setup + +Bump, load `|x|` into the loop register, evaluate the padding polynomial into +the reset register, and put `pair [] x` on the result tape. -/ + +@[simp] theorem parkedBlank_head : parkedBlank.head = 1 := rfl + +theorem parkedBlank_cells (j : β„•) : + parkedBlank.cells j = if j = 0 then Ξ“.start else Ξ“.blank := by + show ((Tape.init ([] : List Ξ“)).move Dir3.right).cells j = _ + rw [Tape.move_cells, initNil_cells] + +theorem hasOutput_nil_parkedBlank : parkedBlank.HasOutput [] := + ⟨fun i hi => absurd hi (Nat.not_lt_zero i), by simp [parkedBlank_cells]⟩ + +/-- The tape family the emission phase starts from: `TM.applyTM`'s block blank, +the bookkeeping tapes as given. -/ +def emitStart (extras : Fin (3 + (k + 2) + 0) β†’ Tape) : Fin (3 + (k + 2) + 0) β†’ Tape := + fun i => if placeWorkInMiddle 3 (k + 2) i then parkedBlank else extras i + +theorem emitStart_middle (extras : Fin (3 + (k + 2) + 0) β†’ Tape) (j : Fin (k + 2)) : + emitStart extras (appIdx j) = parkedBlank := by + rw [emitStart, ite_eq_left (appIdx_middle j)] + +theorem emitStart_extra (extras : Fin (3 + (k + 2) + 0) β†’ Tape) + (i : Fin (3 + (k + 2) + 0)) (hi : Β¬ placeWorkInMiddle 3 (k + 2) i) : + emitStart extras i = extras i := by + rw [emitStart, ite_eq_right hi] + +/-- **The setup's emission phase.** From the bumped input holding `x` and an +all-blank block, `pair [] x` lands on the result tape and the whole block stays +inside `H`. -/ +theorem placedEmit_hoareTime (x : List Bool) (H : β„•) (hH : x.length + 4 ≀ H) + (extras : Fin (3 + (k + 2) + 0) β†’ Tape) + (hextraSI : βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ Tape.StartInvariant (extras i)) + (hextraH : βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ 1 ≀ (extras i).head) : + (placeWorkTM 3 0 (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k)))).HoareTime + (fun inp work out => inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + out = parkedBlank ∧ work = emitStart extras) + (fun inp work out => Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (βˆ€ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + (βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ work i = extras i)) + (x.length + 3) := by + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hplaced := TM.placeWorkTM_hoareTime_frame (pre := 3) (post := 0) + (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k))) + (TM.retargetOutput_hoareTime _ (TM.pairInputWorkTM_hoareTime (Fin.last k) [] x)) + extras hextraSI hextraH + have hconf := hoareTime_confined hplaced (emitStart extras) H + (by simp only [TM.pairInputWorkTime, List.length_nil]; omega) + (placeWorkInMiddle 3 (k + 2)) + (fun i => by + by_cases hi : placeWorkInMiddle 3 (k + 2) i + Β· rw [emitStart, ite_eq_left hi]; exact hblankSI + Β· rw [emitStart, ite_eq_right hi]; exact hextraSI i hi) + (fun i hi => by rw [emitStart, ite_eq_left hi, parkedBlank_head]) + (fun i hi j hj => by + rw [emitStart, ite_eq_left hi] + show ((Tape.init ([] : List Ξ“)).move Dir3.right).cells j = Ξ“.blank + rw [Tape.move_cells, initNil_cells, ite_eq_right (by omega)]) + refine ((hconf.weaken_pre ?_).strengthen_post ?_).mono_bound + (by simp only [TM.pairInputWorkTime, List.length_nil]; omega) + Β· rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨⟨⟨⟨rfl, ?_, ?_, ?_, ?_⟩, rfl⟩, + fun i hi => emitStart_extra extras i hi⟩, rfl, + (startInvariant_initOfBool x).move Dir3.right, hblankSI⟩ + Β· show (emitStart extras (appIdx (Fin.castSucc (Fin.last k)))).head = 1 + rw [emitStart_middle, parkedBlank_head] + Β· show (emitStart extras (appIdx (Fin.castSucc (Fin.last k)))).HasOutput [] + rw [emitStart_middle] + exact hasOutput_nil_parkedBlank + Β· intro i + show Tape.StartInvariant (emitStart extras (appIdx (Fin.castSucc i))) ∧ + 1 ≀ (emitStart extras (appIdx (Fin.castSucc i))).head + rw [emitStart_middle] + exact ⟨hblankSI, le_refl 1⟩ + Β· show emitStart extras (appIdx (Fin.last (k + 1))) = (Tape.init []).move Dir3.right + rw [emitStart_middle] + rfl + Β· rintro inp work out ⟨⟨⟨hout, ho⟩, hext⟩, hinpSI, -, hconf'⟩ + exact ⟨hinpSI, ho, hout, fun j => ⟨(hconf' (appIdx j)).1, + ((hconf' (appIdx j)).2 (appIdx_middle j)).1, + ((hconf' (appIdx j)).2 (appIdx_middle j)).2⟩, hext⟩ + +theorem parkedBlank_eq_regTape_zero : parkedBlank = regTape 0 := by + refine Tape.ext rfl (funext fun j => ?_) + rw [parkedBlank_cells, regT_cells] + show _ = regCells 0 j + rw [regCells] + by_cases hj : j = 0 + Β· rw [ite_eq_left hj, ite_eq_left hj] + Β· rw [ite_eq_right hj, ite_eq_right hj, ite_eq_right (by omega)] + +/-- The register value cap the padding polynomial's evaluation runs under. -/ +def polyM (p : Polynomial β„•) (n : β„•) : β„• := + ((polyCoeffs p).sum + 1) * (n + 1) ^ (polyCoeffs p).length + n + p.eval n + +/-- The setup machine: bump every head off cell `0`, load `|x|` into the loop +register, evaluate the padding polynomial into the reset register, and emit +`pair [] x` onto the result tape. -/ +def iterSetup (k : β„•) (p : Polynomial β„•) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (seqTM skipTM (inputLenRegTM rfIdx)) (polyEvalTM rfIdx wfIdx junkIdx p)) + (placeWorkTM 3 0 (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k)))) + +/-- `Complexity.iterSetup`'s time bound. -/ +def setupBound (p : Polynomial β„•) (n : β„•) : β„• := + 1 + 1 + (2 * n + 4) + 1 + + (opBudget (polyM p n) + 1 + ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + + 1 + (n + 3) + +theorem iterSetup_hoareTime (p : Polynomial β„•) (x : List Bool) (H : β„•) + (hH : H = p.eval x.length) (hHx : x.length + 4 ≀ H) : + (iterSetup k p).HoareTime + (fun inp work out => inp = Tape.init (x.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (βˆ€ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + work rfIdx = regTape x.length ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) + (setupBound p x.length) := by + set inpx : Tape := ⟨1, (Tape.init (x.map Ξ“.ofBool)).cells⟩ with hinpx + have hinpxP : Parked inpx := + ⟨le_refl 1, fun j hj => (startInvariant_initOfBool x).2 j hj⟩ + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + set Wβ‚€ : Fin (3 + (k + 2) + 0) β†’ Tape := fun _ => parkedBlank with hWβ‚€ + have hWβ‚€P : βˆ€ i, Parked (Wβ‚€ i) := fun _ => parked_parkedBlank + -- phase 1: bump + have hA : (skipTM (n := 3 + (k + 2) + 0)).HoareTime + (fun inp work out => inp = Tape.init (x.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (EmitPred inpx Wβ‚€ []) 1 := by + refine (parkAll_hoareTime (Tape.init (x.map Ξ“.ofBool)) (fun _ => Tape.init []) + (Tape.init []) (startInvariant_initOfBool x) (fun _ => startInvariant_initNil) + startInvariant_initNil).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, funext fun i => (hw i).trans ?_, ?_⟩ + Β· rw [hWβ‚€] + exact Tape.ext (by show max 0 1 = 1; omega) rfl + Β· rw [ho] + show OutAcc [] (⟨max 0 1, (Tape.init ([] : List Ξ“)).cells⟩ : Tape) + have : (⟨max 0 1, (Tape.init ([] : List Ξ“)).cells⟩ : Tape) = parkedBlank := + Tape.ext (by show max 0 1 = 1; omega) rfl + rw [this] + exact outAcc_nil_of_parkedBlank + -- phase 2: the loop register + have hB := inputLenRegTM_hoareTime (n := 3 + (k + 2) + 0) rfIdx x Wβ‚€ [] + (fun i _ => hWβ‚€P i) (by rw [hWβ‚€]; exact parkedBlank_eq_regTape_zero) + set W₁ : Fin (3 + (k + 2) + 0) β†’ Tape := + Function.update Wβ‚€ rfIdx (regTape x.length) with hW₁ + have hW₁P : βˆ€ i, Parked (W₁ i) := by + intro i + by_cases hi : i = rfIdx + Β· rw [hW₁, hi, Function.update_self]; exact parked_regTape _ + Β· rw [hW₁, Function.update_of_ne hi]; exact hWβ‚€P i + -- phase 3: the reset register + have hC := polyEvalTM_hoareTime rfIdx wfIdx junkIdx rfIdx_ne_wfIdx + (fun h => junkIdx_ne_rfIdx h.symm) junkIdx_ne_wfIdx.symm p (polyM p x.length) + x.length 0 0 (by rw [polyM]; omega) (by omega) (by omega) + (fun j _ => le_trans (hornerFold_take_le x.length (polyCoeffs p) j) (by rw [polyM]; omega)) + inpx W₁ [] hinpxP hW₁P (by rw [hW₁, Function.update_self]) + (by rw [hW₁, Function.update_of_ne rfIdx_ne_wfIdx.symm, hWβ‚€] + exact parkedBlank_eq_regTape_zero) + (by rw [hW₁, Function.update_of_ne junkIdx_ne_rfIdx, hWβ‚€] + exact parkedBlank_eq_regTape_zero) + -- phase 4: the emission + have hfam : Function.update (Function.update W₁ junkIdx (regTape (p.eval x.length))) wfIdx + (regTape (p.eval x.length)) + = emitStart (bookTapes (regTape x.length) (regTape H) H) := by + funext i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, Function.update_of_ne rfIdx_ne_wfIdx, Function.update_of_ne junkIdx_ne_rfIdx.symm, + hW₁, Function.update_self, emitStart_extra _ _ rfIdx_not_middle, bookTapes_rf] + Β· rw [h, Function.update_self, emitStart_extra _ _ wfIdx_not_middle, bookTapes_wf, hH] + Β· rw [h, Function.update_of_ne junkIdx_ne_wfIdx, Function.update_self, + emitStart_extra _ _ junkIdx_not_middle, bookTapes_junk, hH] + Β· rw [h, Function.update_of_ne (fun hc => wfIdx_ne_appIdx j hc.symm), + Function.update_of_ne (fun hc => junkIdx_ne_appIdx j hc.symm), hW₁, + Function.update_of_ne (fun hc => rfIdx_ne_appIdx j hc.symm), hWβ‚€, emitStart_middle] + have hD := placedEmit_hoareTime (k := k) x H (by omega) + (bookTapes (regTape x.length) (regTape H) H) + (bookTapes_startInvariant (startInvariant_regTape _) (startInvariant_regTape _)) + (bookTapes_head (parked_regTape _) (parked_regTape _)) + -- chain + have hAB := seqTM_hoareTime _ _ hA (emitPred_transition hinpxP hWβ‚€P []) hB + have hBC := seqTM_hoareTime _ _ hAB (emitPred_transition hinpxP hW₁P []) hC + refine ((seqTM_hoareTime _ _ hBC ?_ hD).strengthen_post ?_).mono_bound (by rw [setupBound]) + Β· rintro inp work out ⟨rfl, hw, hout⟩ + rw [hfam] at hw + subst hw + have houtEq := eq_parkedBlank_of_outAcc_nil hout + have hPall : βˆ€ i : Fin (3 + (k + 2) + 0), + Parked (emitStart (bookTapes (regTape x.length) (regTape H) H) i) := by + intro i + by_cases hi : placeWorkInMiddle 3 (k + 2) i + Β· rw [emitStart, ite_eq_left hi]; exact parked_parkedBlank + Β· rw [emitStart, ite_eq_right hi] + exact ⟨bookTapes_head (parked_regTape _) (parked_regTape _) i hi, + (bookTapes_startInvariant (startInvariant_regTape _) + (startInvariant_regTape _) i hi).2⟩ + obtain ⟨t1, t2, t3⟩ := parked_transition (inpβ‚€ := inpx) (outβ‚€ := out) hinpxP hPall + (houtEq β–Έ parked_parkedBlank) + rw [t1, t2, t3] + exact ⟨rfl, houtEq, rfl⟩ + Β· rintro inp work out ⟨hinpSI, ho, hres, hbnd, hext⟩ + refine ⟨hinpSI, ho, hres, hbnd, ?_, ?_, ?_⟩ + Β· rw [hext rfIdx rfIdx_not_middle, bookTapes_rf] + Β· rw [hext wfIdx wfIdx_not_middle, bookTapes_wf] + Β· rw [hext junkIdx junkIdx_not_middle, bookTapes_junk] + +/-! ## The whole machine + +Setup, loop, and one final application whose output lands on the real output +tape. Over-iteration is harmless, so that last application is just one more +iteration. -/ + +theorem not_middle_succ_cases (i : Fin (3 + (k + 2) + 0)) + (hi : Β¬ placeWorkInMiddle (post := 1) 3 (k + 1) i) : + i = rfIdx ∨ i = wfIdx ∨ i = junkIdx ∨ i = resIdx := by + have hlt := i.isLt + have hres : (resIdx (k := k)).val = 3 + (k + 1) := rfl + unfold placeWorkInMiddle at hi + have h : i.val = 0 ∨ i.val = 1 ∨ i.val = 2 ∨ i.val = 3 + (k + 1) := by omega + rcases h with h | h | h | h + Β· exact Or.inl (Fin.ext h) + Β· exact Or.inr (Or.inl (Fin.ext h)) + Β· exact Or.inr (Or.inr (Or.inl (Fin.ext h))) + Β· exact Or.inr (Or.inr (Or.inr (Fin.ext (h.trans hres.symm)))) + +/-- The frame of the final application: the three bookkeeping tapes and the +result tape, which the last application no longer needs. -/ +def teardownExtras (v H : β„•) : Fin (3 + (k + 2) + 0) β†’ Tape := + fun i => if i = resIdx then parkedBlank else bookTapes (regTape v) (regTape H) H i + +/-- Setup, loop, and the final application. -/ +def iterMain (M : TM k) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (iterTail k) (forRegTM (iterBody M) rfIdx)) + (placeWorkTM 3 1 (TM.retargetInputStarted M)) + +/-- **The main run.** From the result tape carrying the initial value, the +machine iterates `v + 1` times and writes the last value to the real output. -/ +theorem iterMain_hoareTime (M : TM k) {G : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime G T) (H : β„•) (v : β„•) + (Y : β„• β†’ List Bool) (hY : βˆ€ i, Y (i + 1) = G (Y i)) + (hlen : βˆ€ i, i ≀ v β†’ (Y i).length + 1 ≀ H) + (hT : βˆ€ i, i < v β†’ 1 + T (Y i).length ≀ H) + (b_iter : β„•) + (hb : βˆ€ i, i < v β†’ T (Y i).length + 1 + tailBound k H (Y (i + 1)).length ≀ b_iter) : + (iterMain M).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (Y 0) ∧ + (βˆ€ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + work rfIdx = regTape v ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) + (fun _inp _work out => out.HasOutput (G (Y v))) + (tailBound k H (Y 0).length + 1 + (v * (b_iter + 2) + (v + 2)) + 1 + T (Y v).length) := by + rw [iterMain] + intro inp work out hpre + obtain ⟨hinpP, hinpSI, ho, hres, hbnd, hrf, hwf, hjunk⟩ := hpre + have hregP := parked_regTape H + have hregSI := startInvariant_regTape H + have hfamP : βˆ€ (i : β„•) (j : Fin (3 + (k + 2) + 0)), + Parked (iterFamily M Y inp (regTape H) v H i j) := by + intro i j + by_cases hj : j = rfIdx + Β· rw [hj, iterFamily_rf]; exact parked_regTape v + Β· exact iterFamily_parked hregP i j hj + -- the tail, the loop, and the final application + have h1 := iterTail_hoareTime M H (Y 0) (hlen 0 (by omega)) inp hinpP hinpSI + (regTape v) (regTape H) (parked_regTape v) (startInvariant_regTape v) hregP hregSI + have h2 := iterLoop_hoareTime (M := M) (Y := Y) (inpβ‚€ := inp) (junkT := regTape H) + (v := v) (H := H) hcomp hY hlen hT b_iter hb hinpP hinpSI hregP hregSI + have h3 := TM.placeWorkTM_hoareTime_frame (pre := 3) (post := 1) + (TM.retargetInputStarted M) (TM.retargetInputStarted_hoareTime M hcomp (Y v)) + (teardownExtras v H) + (fun i hi => by + rcases not_middle_succ_cases i hi with h | h | h | h + Β· rw [h, teardownExtras, ite_eq_right rfIdx_ne_resIdx, bookTapes_rf] + exact startInvariant_regTape v + Β· rw [h, teardownExtras, ite_eq_right wfIdx_ne_resIdx, bookTapes_wf]; exact hregSI + Β· rw [h, teardownExtras, ite_eq_right junkIdx_ne_resIdx, bookTapes_junk]; exact hregSI + Β· rw [h, teardownExtras, ite_eq_left rfl] + exact startInvariant_initNil.move Dir3.right) + (fun i hi => by + rcases not_middle_succ_cases i hi with h | h | h | h + Β· rw [h, teardownExtras, ite_eq_right rfIdx_ne_resIdx, bookTapes_rf] + exact (parked_regTape v).1 + Β· rw [h, teardownExtras, ite_eq_right wfIdx_ne_resIdx, bookTapes_wf]; exact hregP.1 + Β· rw [h, teardownExtras, ite_eq_right junkIdx_ne_resIdx, bookTapes_junk]; exact hregP.1 + Β· rw [h, teardownExtras, ite_eq_left rfl]; exact parked_parkedBlank.1) + -- the two seams are the identity: every tape is parked + have hseam : βˆ€ (W : Fin (3 + (k + 2) + 0) β†’ Tape), (βˆ€ i, Parked (W i)) β†’ + βˆ€ (inp' : Tape) (out' : Tape), inp' = inp β†’ out' = parkedBlank β†’ + transitionInput inp' = inp ∧ (fun i => transitionTape (W i)) = W ∧ + transitionTape out' = parkedBlank := by + rintro W hW inp' out' rfl rfl + exact parked_transition hinpP hW parked_parkedBlank + have h12 := seqTM_hoareTime _ _ h1 (by + rintro inp' work' out' ⟨rfl, rfl, hrf', hjunk', hwf', happ'⟩ + have hWP : βˆ€ i, Parked (work' i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, hrf']; exact parked_regTape v + Β· rw [h, hwf']; exact hregP + Β· rw [h, hjunk']; exact hregP + Β· rw [h, happ' j] + exact ⟨le_of_eq (TM.applyPre_head M (Y 0) _ j).symm, + fun c hc => (TM.applyPre_startInvariant M (Y 0) _ j).2 c hc⟩ + obtain ⟨t1, t2, t3⟩ := hseam work' hWP inp' parkedBlank rfl rfl + rw [t1, t2, t3] + refine ⟨rfl, funext fun i => ?_, outAcc_nil_of_parkedBlank⟩ + rcases layout_cases i with h | h | h | ⟨j, h⟩ + Β· rw [h, hrf', iterFamily_rf] + Β· rw [h, hwf', iterFamily_wf] + Β· rw [h, hjunk', iterFamily_junk] + Β· rw [h, happ' j, iterFamily_app]) h2 + refine (seqTM_hoareTime _ _ h12 ?_ h3).strengthen_post + (post' := fun _inp _work out => out.HasOutput (G (Y v))) ?_ inp work out + ⟨rfl, ho, hres, hbnd, hrf, hwf, hjunk⟩ + Β· rintro inp' work' out' ⟨rfl, rfl, hout'⟩ + obtain ⟨t1, t2, t3⟩ := hseam _ (hfamP v) inp' out' + rfl (eq_parkedBlank_of_outAcc_nil hout') + rw [t1, t2, t3] + refine ⟨⟨funext fun i => ?_, rfl⟩, fun i hi => ?_⟩ + Β· show iterFamily M Y inp' (regTape H) v H v (appIdx (Fin.castSucc i)) = _ + rw [iterFamily_app] + exact congrFun (TM.applyPre_spec M (Y v) inp').1 i + Β· rcases not_middle_succ_cases i hi with h | h | h | h + Β· rw [h, iterFamily_rf, teardownExtras, ite_eq_right rfIdx_ne_resIdx, bookTapes_rf] + Β· rw [h, iterFamily_wf, teardownExtras, ite_eq_right wfIdx_ne_resIdx, bookTapes_wf] + Β· rw [h, iterFamily_junk, teardownExtras, ite_eq_right junkIdx_ne_resIdx, bookTapes_junk] + Β· rw [h, show (resIdx (k := k)) = appIdx (Fin.last (k + 1)) from rfl, iterFamily_app, + teardownExtras, ite_eq_left (show appIdx (Fin.last (k + 1)) = resIdx from rfl), + TM.applyPre, Fin.snoc_last] + Β· rintro inp' work' out' ⟨hout, -⟩ + exact hout + +/-- The complete iteration machine. -/ +def iterTM (M : TM k) (p : Polynomial β„•) : TM (3 + (k + 2) + 0) := + seqTM (iterSetup k p) (iterMain M) + +theorem tailBound_mono (k H : β„•) {m m' : β„•} (h : m ≀ m') : + tailBound k H m ≀ tailBound k H m' := by + rw [tailBound, tailBound]; omega + +/-- `Complexity.iterTM`'s time bound. -/ +def iterBound (k : β„•) (tp p r : Polynomial β„•) (n : β„•) : β„• := + setupBound p n + 1 + + (tailBound k (p.eval n) (n + 2) + 1 + + (n * (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n) + 2) + (n + 2)) + 1 + + tp.eval (r.eval n)) + +/-- **The iteration machine computes the iterate.** On input `x` it applies `G` +to `pair [] x` exactly `|x| + 1` times, provided the padding polynomial `p` +dominates the length bound `r` and the source machine's own bound `tp`. -/ +theorem iterTM_computesInTime (M : TM k) {G : List Bool β†’ List Bool} {tp : Polynomial β„•} + (hcomp : M.ComputesInTime G tp.eval) (p r : Polynomial β„•) + (hp₁ : βˆ€ n, n + 4 ≀ p.eval n) (hpβ‚‚ : βˆ€ n, r.eval n + 1 ≀ p.eval n) + (hp₃ : βˆ€ n, 1 + tp.eval (r.eval n) ≀ p.eval n) + (hr : βˆ€ (x : List Bool), βˆ€ i ≀ x.length, (G^[i] (pair [] x)).length ≀ r.eval x.length) : + (iterTM M p).ComputesInTime (fun x => G^[x.length + 1] (pair [] x)) + (iterBound k tp p r) := by + intro x + set n := x.length with hn + set H := p.eval n with hH + set Y : β„• β†’ List Bool := fun i => G^[i] (pair [] x) with hY0 + have hYsucc : βˆ€ i, Y (i + 1) = G (Y i) := by + intro i + rw [hY0] + exact Function.iterate_succ_apply' G i (pair [] x) + have hYlen : βˆ€ i, i ≀ n β†’ (Y i).length ≀ r.eval n := fun i hi => hr x i hi + have hHpos : 1 ≀ H := by have := hp₁ n; omega + have hlen : βˆ€ i, i ≀ n β†’ (Y i).length + 1 ≀ H := by + intro i hi + have := hYlen i hi + have := hpβ‚‚ n + omega + have hTle : βˆ€ i, i ≀ n β†’ tp.eval (Y i).length ≀ tp.eval (r.eval n) := fun i hi => + polynomial_eval_mono_nat tp (hYlen i hi) + have hsetup := iterSetup_hoareTime (k := k) p x H rfl (by have := hp₁ n; omega) + have hmain := iterMain_hoareTime M hcomp H n Y hYsucc hlen + (fun i hi => by have := hTle i (by omega); have := hp₃ n; omega) + (tp.eval (r.eval n) + 1 + tailBound k H (r.eval n)) + (fun i hi => by + have h1 := hTle i (by omega) + have h2 := tailBound_mono k H (hYlen (i + 1) (by omega)) + omega) + have hseam : βˆ€ (inp : Tape) (work : Fin (3 + (k + 2) + 0) β†’ Tape) (out : Tape), + (Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (βˆ€ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + work rfIdx = regTape n ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) β†’ + (Parked (transitionInput inp) ∧ Tape.StartInvariant (transitionInput inp) ∧ + transitionTape out = parkedBlank ∧ + ((fun i => transitionTape (work i)) resIdx).HasOutput (Y 0) ∧ + (βˆ€ j : Fin (k + 2), + Tape.StartInvariant ((fun i => transitionTape (work i)) (appIdx j)) ∧ + ((fun i => transitionTape (work i)) (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ ((fun i => transitionTape (work i)) (appIdx j)).cells c = Ξ“.blank) ∧ + (fun i => transitionTape (work i)) rfIdx = regTape n ∧ + (fun i => transitionTape (work i)) wfIdx = regTape H ∧ + (fun i => transitionTape (work i)) junkIdx = regTape H) := by + rintro inp work out ⟨hinpSI, rfl, hres, hbnd, hrf, hwf, hjunk⟩ + dsimp only + have hinpEq : transitionInput inp = (⟨max inp.head 1, inp.cells⟩ : Tape) := + move_idleDir_eq_of_startInvariant hinpSI + refine ⟨?_, ?_, transitionTape_eq_self parked_parkedBlank.read_ne_start, ?_, + fun j => ⟨?_, ?_, ?_⟩, ?_, ?_, ?_⟩ + Β· rw [hinpEq]; exact ⟨le_max_right _ _, fun c hc => hinpSI.2 c hc⟩ + Β· rw [hinpEq]; exact ⟨hinpSI.1, fun c hc => hinpSI.2 c hc⟩ + Β· exact (Tape.hasOutput_congr + (transitionTape_cells _ (fun c hc => (hbnd (Fin.last (k + 1))).1.2 c hc)).symm _).mp hres + Β· refine ⟨?_, fun c hc => ?_⟩ + Β· rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.1 + Β· rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.2 c hc + Β· rw [transitionTape_of_startInvariant (hbnd j).1] + show max (work (appIdx j)).head 1 ≀ H + have := (hbnd j).2.1 + omega + Β· intro c hc + rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).2.2 c hc + Β· show transitionTape (work rfIdx) = regTape n + rw [hrf]; exact transitionTape_eq_self (parked_regTape n).read_ne_start + Β· show transitionTape (work wfIdx) = regTape H + rw [hwf]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + Β· show transitionTape (work junkIdx) = regTape H + rw [hjunk]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + have hfull := seqTM_hoareTime _ _ hsetup hseam hmain + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := hfull (Tape.init (x.map Ξ“.ofBool)) + (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + have hY0len : (Y 0).length = n + 2 := by + rw [hY0] + show (pair [] x).length = n + 2 + rw [pair_length] + simp + omega + refine ⟨c', t, ?_, hreach, hhalt, ?_⟩ + Β· refine le_trans ht ?_ + rw [iterBound, hY0len] + simp only [← hn, hH] + have := hTle n le_rfl + omega + Β· show c'.output.HasOutput (G^[x.length + 1] (pair [] x)) + rw [Function.iterate_succ_apply'] + exact hpost + +/-! ## Polynomial bounds + +`Complexity.iterBound` is a sum of products of polynomial evaluations, so the +closure API of `Complexitylib.Asymptotics.PolyBound` bounds it directly. -/ + +theorem polyBound_iterBound (k : β„•) (tp p r : Polynomial β„•) : + PolyBound (iterBound k tp p r) := by + have hcomp : PolyBound (fun n => tp.eval (r.eval n)) := + PolyBound.mono (PolyBound.eval (tp.comp r)) + (fun n => le_of_eq (by rw [Polynomial.eval_comp])) + have hp : PolyBound (fun n => p.eval n) := PolyBound.eval p + have hr : PolyBound (fun n => r.eval n) := PolyBound.eval r + have hpow : PolyBound (fun n => (n + 1) ^ (polyCoeffs p).length) := + PolyBound.pow (PolyBound.add PolyBound.id (PolyBound.const 1)) _ + have hM : PolyBound (fun n => polyM p n) := by + rw [show (fun n => polyM p n) = fun n => + ((polyCoeffs p).sum + 1) * (n + 1) ^ (polyCoeffs p).length + n + p.eval n from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const _) hpow) PolyBound.id) hp + have hop : PolyBound (fun n => opBudget (polyM p n)) := by + rw [show (fun n => opBudget (polyM p n)) = fun n => + 32 * ((polyM p n + 2) * (polyM p n + 2) * (polyM p n + 2)) from rfl] + exact PolyBound.mul (PolyBound.const _) + (PolyBound.mul (PolyBound.mul (PolyBound.add hM (PolyBound.const _)) + (PolyBound.add hM (PolyBound.const _))) (PolyBound.add hM (PolyBound.const _))) + have hlayer : PolyBound (fun n => layerBudget (polyM p n)) := by + rw [show (fun n => layerBudget (polyM p n)) = fun n => + 4 * opBudget (polyM p n) + 3 from rfl] + exact PolyBound.add (PolyBound.mul (PolyBound.const _) hop) (PolyBound.const _) + have hsetup : PolyBound (setupBound p) := by + rw [show setupBound p = fun n => 1 + 1 + (2 * n + 4) + 1 + + (opBudget (polyM p n) + 1 + + ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + 1 + (n + 3) from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul (PolyBound.const 2) PolyBound.id) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add hop (PolyBound.const _)) + (PolyBound.add + (PolyBound.mul (PolyBound.const _) (PolyBound.add hlayer (PolyBound.const _))) + (PolyBound.const _)))) + (PolyBound.const _)) (PolyBound.add PolyBound.id (PolyBound.const _)) + have htail : βˆ€ m : β„• β†’ β„•, PolyBound m β†’ + PolyBound (fun n => tailBound k (p.eval n) (m n)) := by + intro m hm + rw [show (fun n => tailBound k (p.eval n) (m n)) = fun n => + 1 + 1 + (p.eval n + 1 + 2) + 1 + + ((k + 1) * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + ((k + 1) * (p.eval n + 4) + 1)) + 1 + + (2 * m n + 5 + 1 + + (1 * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + (1 * (p.eval n + 4) + 1))) from rfl] + have hbase : PolyBound (fun n => p.eval n + 4) := PolyBound.add hp (PolyBound.const _) + have hk : PolyBound (fun n => (k + 1) * (p.eval n + 4)) := + PolyBound.mul (PolyBound.const _) hbase + have h1 : PolyBound (fun n => 1 * (p.eval n + 4)) := PolyBound.mul (PolyBound.const _) hbase + have h4 : PolyBound (fun n => p.eval n * 4) := PolyBound.mul hp (PolyBound.const _) + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.add hp (PolyBound.const _)) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add hk h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add hk (PolyBound.const _)))) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const 2) hm) + (PolyBound.const _)) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add h1 h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add h1 (PolyBound.const _)))) + rw [show iterBound k tp p r = fun n => setupBound p n + 1 + + (tailBound k (p.eval n) (n + 2) + 1 + + (n * (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n) + 2) + (n + 2)) + 1 + + tp.eval (r.eval n)) from rfl] + exact PolyBound.add (PolyBound.add hsetup (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (htail _ (PolyBound.add PolyBound.id (PolyBound.const _))) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul PolyBound.id (PolyBound.add (PolyBound.add (PolyBound.add hcomp + (PolyBound.const _)) (htail _ hr)) (PolyBound.const _))) + (PolyBound.add PolyBound.id (PolyBound.const _)))) (PolyBound.const _)) hcomp) + +/-- **`FP` is closed under iterating a polynomial-time function once per input +bit**, provided every intermediate value stays polynomially bounded. -/ +theorem iterate_input_mem_FP {G : List Bool β†’ List Bool} (hG : G ∈ FP) (r : Polynomial β„•) + (hr : βˆ€ (x : List Bool), βˆ€ i ≀ x.length, (G^[i] (pair [] x)).length ≀ r.eval x.length) : + (fun x => G^[x.length + 1] (pair [] x)) ∈ FP := by + obtain ⟨k, M, tp, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hG + set p : Polynomial β„• := + Polynomial.X + Polynomial.C 4 + r + Polynomial.C 1 + tp.comp r + Polynomial.C 1 with hpdef + have hpeval : βˆ€ n, p.eval n = n + 4 + r.eval n + 1 + tp.eval (r.eval n) + 1 := by + intro n + rw [hpdef] + simp [Polynomial.eval_comp] + obtain ⟨d, hd⟩ := (polyBound_iterBound k tp p r).bigO + exact ⟨d, 3 + (k + 2) + 0, iterTM M p, iterBound k tp p r, + iterTM_computesInTime M hcomp p r (fun n => by rw [hpeval]; omega) + (fun n => by rw [hpeval]; omega) (fun n => by rw [hpeval]; omega) hr, hd⟩ + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean new file mode 100644 index 0000000000..bedd7978c3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean @@ -0,0 +1,577 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Apply +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput + +/-! +# The bounded-iteration machine's tape layout β€” proof internals + +The tape layout and phase contracts that +`Complexitylib.Classes.P.Cobham.Internal.Iterate` assembles into the +bounded-iteration machine: two unary fuel registers (one consumed by the outer +loop, one reused by every reset), one junk tape for the register arithmetic, and +then `TM.applyTM`'s own tapes placed after them. The running value needs no tape +of its own β€” it lives on `applyTM`'s virtual-input tape, which is exactly where +the next call wants it. + +## Main results + +- `Complexity.rfIdx`, `wfIdx`, `junkIdx`, `appIdx`, `vinIdx`, `resIdx` β€” the layout +- `Complexity.placedApply_hoareTime` β€” one embedded application of the iterated function +- `Complexity.iterPark_hoareTime`, `iterResetScratch_hoareTime`, + `iterFinish_hoareTime` β€” the phase contracts around it +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +variable {k : β„•} + +/-- The outer loop's fuel register. -/ +def rfIdx : Fin (3 + (k + 2) + 0) := ⟨0, by omega⟩ + +/-- The reset's fuel register, restored by every reset. -/ +def wfIdx : Fin (3 + (k + 2) + 0) := ⟨1, by omega⟩ + +/-- Holds the input's padding block; never read again. -/ +def junkIdx : Fin (3 + (k + 2) + 0) := ⟨2, by omega⟩ + +/-- Where `TM.applyTM`'s tape `j` sits in the composite layout. -/ +def appIdx (j : Fin (k + 2)) : Fin (3 + (k + 2) + 0) := placeWorkIdx 3 0 j + +/-- The running value's tape β€” `applyTM`'s virtual input. -/ +def vinIdx : Fin (3 + (k + 2) + 0) := appIdx (Fin.castSucc (Fin.last k)) + +/-- Where one application of the iterated function leaves its result. -/ +def resIdx : Fin (3 + (k + 2) + 0) := appIdx (Fin.last (k + 1)) + +@[simp] theorem rfIdx_val : (rfIdx (k := k)).val = 0 := rfl +@[simp] theorem wfIdx_val : (wfIdx (k := k)).val = 1 := rfl +@[simp] theorem junkIdx_val : (junkIdx (k := k)).val = 2 := rfl +@[simp] theorem appIdx_val (j : Fin (k + 2)) : (appIdx j).val = 3 + j.val := rfl + +/-- The three bookkeeping tapes are exactly the ones outside `applyTM`'s +block. -/ +theorem not_middle_iff (i : Fin (3 + (k + 2) + 0)) : + Β¬ placeWorkInMiddle 3 (k + 2) i ↔ i.val < 3 := by + have hlt := i.isLt + unfold placeWorkInMiddle + constructor <;> intro h <;> omega + +theorem appIdx_middle (j : Fin (k + 2)) : placeWorkInMiddle 3 (k + 2) (appIdx j) := + placeWorkInMiddle_placeWorkIdx 3 0 j + +theorem appIdx_injective : Function.Injective (appIdx (k := k)) := + placeWorkIdx_injective 3 0 + +theorem rfIdx_not_middle : Β¬ placeWorkInMiddle 3 (k + 2) (rfIdx (k := k)) := + (not_middle_iff _).mpr (by rw [rfIdx_val]; omega) + +theorem wfIdx_not_middle : Β¬ placeWorkInMiddle 3 (k + 2) (wfIdx (k := k)) := + (not_middle_iff _).mpr (by rw [wfIdx_val]; omega) + +theorem junkIdx_not_middle : Β¬ placeWorkInMiddle 3 (k + 2) (junkIdx (k := k)) := + (not_middle_iff _).mpr (by rw [junkIdx_val]; omega) + +theorem wfIdx_ne_appIdx (j : Fin (k + 2)) : wfIdx β‰  appIdx j := by + intro h + exact wfIdx_not_middle (h β–Έ appIdx_middle j) + +theorem rfIdx_ne_appIdx (j : Fin (k + 2)) : rfIdx β‰  appIdx j := by + intro h + exact rfIdx_not_middle (h β–Έ appIdx_middle j) + +theorem junkIdx_ne_appIdx (j : Fin (k + 2)) : junkIdx β‰  appIdx j := by + intro h + exact junkIdx_not_middle (h β–Έ appIdx_middle j) + +/-- **The layout is exhaustive.** Every tape of the composite machine is one of +the three bookkeeping tapes or one of `TM.applyTM`'s own, so a predicate that +names all four kinds pins down the whole tape family. -/ +theorem layout_cases (i : Fin (3 + (k + 2) + 0)) : + i = rfIdx ∨ i = wfIdx ∨ i = junkIdx ∨ βˆƒ j : Fin (k + 2), i = appIdx j := by + by_cases hmid : placeWorkInMiddle 3 (k + 2) i + Β· exact Or.inr (Or.inr (Or.inr + ⟨placeWorkCoord 3 (k + 2) i hmid, (placeWorkIdx_placeWorkCoord i hmid).symm⟩)) + Β· rw [not_middle_iff] at hmid + have h : i.val = 0 ∨ i.val = 1 ∨ i.val = 2 := by omega + rcases h with h | h | h + Β· exact Or.inl (Fin.ext h) + Β· exact Or.inr (Or.inl (Fin.ext h)) + Β· exact Or.inr (Or.inr (Or.inl (Fin.ext h))) + +/-- **One application of the iterated function, in the composite layout.** +The bookkeeping tapes are held fixed; `applyTM`'s block goes from its entry +shape for `y` to a state where the result tape holds `G y` and every tape of +the block is still confined to cells `1 … H` β€” the two facts +`Complexity.resetTapesTM` needs to clean up afterwards. -/ +theorem placedApply_hoareTime (M : TM k) {G : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime G T) (y : List Bool) + (inpβ‚€ : Tape) (hinp : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (H : β„•) (hHy : y.length ≀ H) (hHT : 1 + T y.length ≀ H) + (extras : Fin (3 + (k + 2) + 0) β†’ Tape) + (hextraSI : βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ Tape.StartInvariant (extras i)) + (hextraH : βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ 1 ≀ (extras i).head) : + (placeWorkTM 3 0 (applyTM M)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + (βˆ€ j, work (appIdx j) = applyPre M y inpβ‚€ j) ∧ + (βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ work i = extras i) ∧ + out = parkedBlank) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (G y) ∧ + (βˆ€ j, Tape.StartInvariant (work (appIdx j)) ∧ (work (appIdx j)).head ≀ H ∧ + βˆ€ c, H < c β†’ (work (appIdx j)).cells c = Ξ“.blank) ∧ + (βˆ€ i, Β¬ placeWorkInMiddle 3 (k + 2) i β†’ work i = extras i)) + (T y.length) := by + have hbase := placeWorkTM_hoareTime_frame (pre := 3) (post := 0) (applyTM M) + (applyTM_hoareTime_frame M hcomp y inpβ‚€ hinp hinpSI H hHy hHT) extras hextraSI hextraH + refine (hbase.weaken_pre ?_).strengthen_post ?_ + Β· rintro inp work out ⟨hi, hmid, hext, ho⟩ + exact ⟨⟨hi, funext hmid, ho⟩, hext⟩ + Β· rintro inp work out ⟨⟨hi, ho, hres, hall⟩, hext⟩ + exact ⟨hi, ho, hres, hall, hext⟩ + +/-- The tapes cleaned between two applications of the iterated function: the +witness machine's own scratch together with the virtual-input tape. The result +tape is deliberately excluded β€” it still carries the value being moved. -/ +def resetTargets (k : β„•) : List (Fin (3 + (k + 2) + 0)) := + (List.finRange (k + 1)).map (fun j => appIdx (Fin.castSucc j)) + +theorem resetTargets_nodup : (resetTargets k).Nodup := by + refine (List.nodup_finRange (k + 1)).map ?_ + intro a b hab + exact Fin.castSucc_injective (k + 1) (appIdx_injective hab) + +@[simp] theorem resetTargets_length : (resetTargets k).length = k + 1 := by + simp [resetTargets] + +theorem mem_resetTargets_iff (i : Fin (3 + (k + 2) + 0)) : + i ∈ resetTargets k ↔ βˆƒ j : Fin (k + 1), appIdx (Fin.castSucc j) = i := by + simp [resetTargets, eq_comm] + +theorem wfIdx_notMem_resetTargets : wfIdx βˆ‰ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact wfIdx_ne_appIdx _ hj.symm + +theorem resIdx_notMem_resetTargets : resIdx βˆ‰ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + have := appIdx_injective hj + exact absurd (congrArg Fin.val this) (by simp; omega) + +theorem vinIdx_mem_resetTargets : vinIdx ∈ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + exact ⟨Fin.last k, rfl⟩ + +/-- The tape cleaned after the result has been moved back. -/ +def resetResult (k : β„•) : List (Fin (3 + (k + 2) + 0)) := [resIdx] + +theorem resetResult_nodup : (resetResult k).Nodup := List.nodup_singleton _ + +theorem wfIdx_notMem_resetResult : wfIdx βˆ‰ resetResult (k := k) := by + simp only [resetResult, List.mem_singleton] + exact wfIdx_ne_appIdx _ + +/-- **Phases 2–3 of the body.** `Ξ΄_right_of_start` only constrains a head that +*reads* `β–·`, so an arbitrary witness machine may halt with a head parked on +cell `0`. One idle step lifts every head to at least cell `1`, and one rewind +then brings the result tape's head back to exactly cell `1` β€” the shape both +`Complexity.resetTapesTM` (which preserves non-target tapes only when they are +parked) and `TM.copyWorkToWorkTM` (which wants its source at cell `1`) +require. -/ +theorem iterPark_hoareTime (H : β„•) (inpβ‚€ : Tape) (hinpP : Parked inpβ‚€) + (hinpSI : Tape.StartInvariant inpβ‚€) + (W : Fin (3 + (k + 2) + 0) β†’ Tape) + (hSI : βˆ€ i, Tape.StartInvariant (W i)) + (hB : (W resIdx).head ≀ H) : + (seqTM skipTM (rewindWorkTM resIdx)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = W ∧ out = parkedBlank) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (βˆ€ i, i β‰  resIdx β†’ work i = (⟨max (W i).head 1, (W i).cells⟩ : Tape))) + (1 + 1 + (H + 1 + 2)) := by + set WA : Fin (3 + (k + 2) + 0) β†’ Tape := + fun i => (⟨max (W i).head 1, (W i).cells⟩ : Tape) with hWA + have hWAP : βˆ€ i, Parked (WA i) := fun i => ⟨le_max_right _ _, fun j hj => (hSI i).2 j hj⟩ + have houtP : Parked parkedBlank := parked_parkedBlank + have houtSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hinpEq : (⟨max inpβ‚€.head 1, inpβ‚€.cells⟩ : Tape) = inpβ‚€ := + Tape.ext (by show max inpβ‚€.head 1 = inpβ‚€.head; have := hinpP.1; omega) rfl + have houtEq : (⟨max parkedBlank.head 1, parkedBlank.cells⟩ : Tape) = parkedBlank := + Tape.ext (by show max parkedBlank.head 1 = parkedBlank.head; have := houtP.1; omega) rfl + have hA' : (skipTM (n := 3 + (k + 2) + 0)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = W ∧ out = parkedBlank) + (fun inp work out => inp = inpβ‚€ ∧ work = WA ∧ out = parkedBlank) 1 := + (parkAll_hoareTime inpβ‚€ W parkedBlank hinpSI hSI houtSI).strengthen_post (by + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi.trans hinpEq, funext hw, ho.trans houtEq⟩) + have hP : βˆ€ (inp : Tape) (work : Fin (3 + (k + 2) + 0) β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin (3 + (k + 2) + 0) β†’ Tape) (out' : Tape), + ((work resIdx).cells = (W resIdx).cells ∧ inp = inpβ‚€ ∧ out = parkedBlank ∧ + βˆ€ i, i β‰  resIdx β†’ work i = WA i) β†’ + (work' resIdx).cells = (work resIdx).cells β†’ + (work' resIdx).head = 1 β†’ + (βˆ€ i, i β‰  resIdx β†’ work' i = work i) β†’ + inp' = inp β†’ out'.cells = out.cells β†’ out'.head = out.head β†’ + ((work' resIdx).cells = (W resIdx).cells ∧ inp' = inpβ‚€ ∧ out' = parkedBlank ∧ + βˆ€ i, i β‰  resIdx β†’ work' i = WA i) := by + rintro inp work out inp' work' out' ⟨hc, rfl, rfl, hrest⟩ hc' _ hkeep rfl hoc hoh + exact ⟨hc'.trans hc, rfl, Tape.ext hoh hoc, + fun i hi => (hkeep i hi).trans (hrest i hi)⟩ + have hC := rewindWorkTM_hoareTime_frame (n := 3 + (k + 2) + 0) resIdx (H + 1) + (P := fun inp work out => (work resIdx).cells = (W resIdx).cells ∧ + inp = inpβ‚€ ∧ out = parkedBlank ∧ βˆ€ i, i β‰  resIdx β†’ work i = WA i) hP + have hpreC : βˆ€ (inp : Tape) (work : Fin (3 + (k + 2) + 0) β†’ Tape) (out : Tape), + (inp = inpβ‚€ ∧ work = WA ∧ out = parkedBlank) β†’ + ((work resIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work resIdx).cells j β‰  Ξ“.start) ∧ + (work resIdx).head ≀ H + 1 ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  resIdx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + ((work resIdx).cells = (W resIdx).cells ∧ inp = inpβ‚€ ∧ out = parkedBlank ∧ + βˆ€ i, i β‰  resIdx β†’ work i = WA i)) := by + rintro inp work out ⟨hi, hw, ho⟩ + subst hw + refine ⟨(hSI resIdx).1, fun j hj => (hSI resIdx).2 j hj, ?_, + by rw [hi]; exact hinpP.read_ne_start, by rw [ho]; exact houtP.read_ne_start, + by rw [ho]; exact houtP.1, + fun i _ => ⟨(hWAP i).read_ne_start, (hWAP i).1⟩, rfl, hi, ho, fun i _ => rfl⟩ + show max (W resIdx).head 1 ≀ H + 1 + omega + have hC' := hC.weaken_pre hpreC + refine (seqTM_hoareTime _ _ hA' ?_ hC').strengthen_post ?_ + Β· rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨transitionInput_eq_self hinpP.read_ne_start, + funext fun i => transitionTape_eq_self (hWAP i).read_ne_start, + transitionTape_eq_self houtP.read_ne_start⟩ + Β· rintro inp work out ⟨hh, hc, hi, ho, hrest⟩ + exact ⟨hi, ho, hh, hc, hrest⟩ + +theorem rfIdx_ne_wfIdx : rfIdx (k := k) β‰  wfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +theorem junkIdx_ne_wfIdx : junkIdx (k := k) β‰  wfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +theorem resIdx_ne_wfIdx : resIdx (k := k) β‰  wfIdx := fun h => wfIdx_ne_appIdx _ h.symm + +theorem rfIdx_notMem_resetTargets : rfIdx βˆ‰ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact rfIdx_ne_appIdx _ hj.symm + +theorem junkIdx_notMem_resetTargets : junkIdx βˆ‰ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact junkIdx_ne_appIdx _ hj.symm + +/-- **Phase 4 of the body.** Blank the witness machine's scratch tapes and the +virtual-input tape, leaving the result tape (which carries the value being +moved), both fuel registers, and the junk tape exactly as they were. -/ +theorem iterResetScratch_hoareTime (H : β„•) (hH : 1 ≀ H) + (inpβ‚€ : Tape) (hinpP : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (W : Fin (3 + (k + 2) + 0) β†’ Tape) + (hSI : βˆ€ i, Tape.StartInvariant (W i)) + (hB : βˆ€ j : Fin (k + 1), (W (appIdx (Fin.castSucc j))).head ≀ H) + (hfar : βˆ€ j : Fin (k + 1), βˆ€ c, H < c β†’ (W (appIdx (Fin.castSucc j))).cells c = Ξ“.blank) + (hwf : W wfIdx = regTape H) : + (resetTapesTM (resetTargets k) wfIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (βˆ€ i, i β‰  resIdx β†’ work i = (⟨max (W i).head 1, (W i).cells⟩ : Tape))) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (βˆ€ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank) ∧ + work wfIdx = regTape H ∧ + work rfIdx = (⟨max (W rfIdx).head 1, (W rfIdx).cells⟩ : Tape) ∧ + work junkIdx = (⟨max (W junkIdx).head 1, (W junkIdx).cells⟩ : Tape)) + ((k + 1) * (H + 4) + H * 4 + 8 + 1 + ((k + 1) * (H + 4) + 1)) := by + intro inp work out hpre + obtain ⟨hi, ho, hrh, hrc, hrest⟩ := hpre + rw [hi, ho] + have hworkSI : βˆ€ j, j β‰  wfIdx β†’ Tape.StartInvariant (work j) := by + intro j _ + by_cases hjr : j = resIdx + Β· exact ⟨by rw [hjr, hrc]; exact (hSI resIdx).1, + fun c hc => by rw [hjr, hrc]; exact (hSI resIdx).2 c hc⟩ + Β· rw [hrest j hjr] + exact ⟨(hSI j).1, fun c hc => (hSI j).2 c hc⟩ + have hbnd : βˆ€ j, j ∈ resetTargets k β†’ + (work j).head ≀ H ∧ βˆ€ c, H < c β†’ (work j).cells c = Ξ“.blank := by + intro j hj + obtain ⟨j', rfl⟩ := (mem_resetTargets_iff j).mp hj + have hne : appIdx (Fin.castSucc j') β‰  resIdx := by + intro hc + exact absurd (congrArg Fin.val (appIdx_injective hc)) (by simp; omega) + rw [hrest _ hne] + refine ⟨?_, fun c hc => hfar j' c hc⟩ + show max (W (appIdx (Fin.castSucc j'))).head 1 ≀ H + have := hB j' + omega + have hwfEq : work wfIdx = regTape H := by + rw [hrest wfIdx (fun h => resIdx_ne_wfIdx h.symm), hwf] + refine Tape.ext ?_ rfl + show max (regTape H).head 1 = 1 + rw [regT_head] + omega + obtain ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', hkeep⟩ := + resetTapesTM_hoareTime_of_bounds (resetTargets k) resetTargets_nodup wfIdx + wfIdx_notMem_resetTargets H inpβ‚€ work parkedBlank hinpSI hinpP rfl + (fun j hjw hjt => by + by_cases hjr : j = resIdx + Β· exact ⟨by rw [hjr, hrh], fun c hc => by + rw [hjr, hrc]; exact (hSI resIdx).2 c hc⟩ + Β· rw [hrest j hjr] + exact ⟨le_max_right _ _, fun c hc => (hSI j).2 c hc⟩) + inpβ‚€ work parkedBlank ⟨rfl, rfl, hworkSI, hbnd, hwfEq, fun _ _ _ => rfl⟩ + rw [resetTargets_length] at ht + refine ⟨c', t, ht, hreach, hhalt, hi', ho', ?_, ?_, ?_, hR', ?_, ?_⟩ + Β· rw [hkeep resIdx (fun h => resIdx_ne_wfIdx h) resIdx_notMem_resetTargets]; exact hrh + Β· rw [hkeep resIdx (fun h => resIdx_ne_wfIdx h) resIdx_notMem_resetTargets]; exact hrc + Β· intro j + exact hts _ ((mem_resetTargets_iff _).mpr ⟨j, rfl⟩) + Β· rw [hkeep rfIdx rfIdx_ne_wfIdx rfIdx_notMem_resetTargets] + exact hrest rfIdx (fun h => rfIdx_ne_appIdx _ h) + Β· rw [hkeep junkIdx junkIdx_ne_wfIdx junkIdx_notMem_resetTargets] + exact hrest junkIdx (fun h => junkIdx_ne_appIdx _ h) + +/-- `TM.applyPre` in closed form: the virtual-input tape carries the value, and +every other tape of the block is blank. -/ +theorem applyPre_eq (M : TM k) (x : List Bool) (inpβ‚€ : Tape) (j : Fin (k + 2)) : + TM.applyPre M x inpβ‚€ j = + if j = Fin.castSucc (Fin.last k) then (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + else parkedBlank := by + refine Fin.lastCases ?_ ?_ j + Β· rw [TM.applyPre, Fin.snoc_last, ite_eq_right] + intro hc + exact absurd (congrArg Fin.val hc) (by simp) + Β· intro j' + rw [TM.applyPre, Fin.snoc_castSucc] + show (TM.retargetInputStartedCfg M x inpβ‚€).work j' = _ + rw [TM.retargetInputStartedCfg] + dsimp only + by_cases hj : j' = Fin.last k + Β· rw [hj, ite_eq_right (by simp), ite_eq_left rfl] + Β· have hlt : j'.val < k := by + have := j'.isLt + rcases Nat.lt_or_ge j'.val k with h | h + Β· exact h + Β· exact absurd (Fin.ext (show j'.val = (Fin.last k).val by + rw [Fin.val_last]; omega)) hj + rw [ite_eq_left hlt, ite_eq_right (fun hc => hj (Fin.castSucc_injective (k + 1) hc))] + rfl + +theorem resIdx_ne_vinIdx : resIdx (k := k) β‰  vinIdx := by + intro h + exact absurd (congrArg Fin.val (appIdx_injective h)) (by simp) + +theorem rfIdx_ne_resIdx : rfIdx (k := k) β‰  resIdx := rfIdx_ne_appIdx _ +theorem junkIdx_ne_resIdx : junkIdx (k := k) β‰  resIdx := junkIdx_ne_appIdx _ +theorem wfIdx_ne_resIdx : wfIdx (k := k) β‰  resIdx := wfIdx_ne_appIdx _ +theorem rfIdx_ne_vinIdx : rfIdx (k := k) β‰  vinIdx := rfIdx_ne_appIdx _ +theorem junkIdx_ne_vinIdx : junkIdx (k := k) β‰  vinIdx := junkIdx_ne_appIdx _ +theorem wfIdx_ne_vinIdx : wfIdx (k := k) β‰  vinIdx := wfIdx_ne_appIdx _ + +theorem junkIdx_ne_rfIdx : junkIdx (k := k) β‰  rfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +/-- **Phases 5–6 of the body.** Move the freshly computed value from the result +tape onto the virtual-input tape β€” where the next application will read it β€” +and then blank the result tape, restoring `TM.applyPre`'s entry shape for the +new value. -/ +theorem iterFinish_hoareTime (M : TM k) (H : β„•) + (x : List Bool) (hx : x.length + 1 ≀ H) + (inpβ‚€ : Tape) (hinpP : Parked inpβ‚€) (hinpSI : Tape.StartInvariant inpβ‚€) + (resT rfT junkT : Tape) + (hresH : resT.head = 1) (hresOut : resT.HasOutput x) + (hresSI : Tape.StartInvariant resT) + (hresFar : βˆ€ c, H < c β†’ resT.cells c = Ξ“.blank) + (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (seqTM (copyToVirtualInputTM resIdx vinIdx) + (resetTapesTM (resetResult k) wfIdx)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + work resIdx = resT ∧ work rfIdx = rfT ∧ work junkIdx = junkT ∧ + work wfIdx = regTape H ∧ + (βˆ€ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank)) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (βˆ€ j, work (appIdx j) = TM.applyPre M x inpβ‚€ j)) + (2 * x.length + 5 + 1 + + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1))) := by + have hregP : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i β‰  Ξ“.start + simp only [regCells]; split + Β· omega + Β· split <;> decide⟩ + have hregSI : Tape.StartInvariant (regTape H) := ⟨rfl, hregP.2⟩ + have houtP : Parked parkedBlank := parked_parkedBlank + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + -- the tape family entering phase 5 + set Wβ‚€ : Fin (3 + (k + 2) + 0) β†’ Tape := fun i => + if i = resIdx then resT else if i = rfIdx then rfT else if i = junkIdx then junkT + else if i = wfIdx then regTape H else parkedBlank with hWβ‚€ + have hWβ‚€SI : βˆ€ i, Tape.StartInvariant (Wβ‚€ i) := by + intro i; rw [hWβ‚€]; dsimp only + split; Β· exact hresSI + split; Β· exact hrfSI + split; Β· exact hjunkSI + split; Β· exact hregSI + exact hblankSI + have hWβ‚€other : βˆ€ i, i β‰  resIdx β†’ i β‰  vinIdx β†’ Parked (Wβ‚€ i) := by + intro i hir _; rw [hWβ‚€]; dsimp only + rw [ite_eq_right hir] + split; Β· exact hrfP + split; Β· exact hjunkP + split; Β· exact hregP + exact houtP + have hWβ‚€res : Wβ‚€ resIdx = resT := by rw [hWβ‚€]; simp + have hWβ‚€vin : Wβ‚€ vinIdx = parkedBlank := by + rw [hWβ‚€] + dsimp only + rw [ite_eq_right (fun h => resIdx_ne_vinIdx h.symm), + ite_eq_right (fun h => rfIdx_ne_appIdx _ h.symm), + ite_eq_right (fun h => junkIdx_ne_appIdx _ h.symm), + ite_eq_right (fun h => wfIdx_ne_appIdx _ h.symm)] + have hWβ‚€app : βˆ€ j : Fin (k + 2), appIdx j β‰  resIdx β†’ Wβ‚€ (appIdx j) = parkedBlank := by + intro j hj + rw [hWβ‚€] + dsimp only + rw [ite_eq_right hj, ite_eq_right (fun h => rfIdx_ne_appIdx _ h.symm), + ite_eq_right (fun h => junkIdx_ne_appIdx _ h.symm), + ite_eq_right (fun h => wfIdx_ne_appIdx _ h.symm)] + have hWβ‚€rf : Wβ‚€ rfIdx = rfT := by + rw [hWβ‚€] + dsimp only + rw [ite_eq_right rfIdx_ne_resIdx, ite_eq_left rfl] + have hWβ‚€junk : Wβ‚€ junkIdx = junkT := by + rw [hWβ‚€] + dsimp only + rw [ite_eq_right junkIdx_ne_resIdx, ite_eq_right junkIdx_ne_rfIdx, ite_eq_left rfl] + have hWβ‚€wf : Wβ‚€ wfIdx = regTape H := by + rw [hWβ‚€] + dsimp only + rw [ite_eq_right wfIdx_ne_resIdx, ite_eq_right (fun h => rfIdx_ne_wfIdx h.symm), + ite_eq_right (fun h => junkIdx_ne_wfIdx h.symm), ite_eq_left rfl] + -- the value tape produced by the copy, and the family after each phase + set vinT : Tape := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right with hvinT + have hvinSI : Tape.StartInvariant vinT := (startInvariant_initOfBool x).move Dir3.right + have hvinP : Parked vinT := ⟨le_refl 1, hvinSI.2⟩ + set W₁ : Fin (3 + (k + 2) + 0) β†’ Tape := + Function.update (Function.update Wβ‚€ vinIdx vinT) resIdx + (⟨x.length + 1, (Wβ‚€ resIdx).cells⟩ : Tape) with hW₁ + set Wβ‚‚ : Fin (3 + (k + 2) + 0) β†’ Tape := Function.update W₁ resIdx parkedBlank with hWβ‚‚ + have hW₁res : W₁ resIdx = (⟨x.length + 1, resT.cells⟩ : Tape) := by + rw [hW₁, Function.update_self, hWβ‚€res] + have hW₁vin : W₁ vinIdx = vinT := by + rw [hW₁, Function.update_of_ne resIdx_ne_vinIdx.symm, Function.update_self] + have hW₁other : βˆ€ i, i β‰  resIdx β†’ i β‰  vinIdx β†’ W₁ i = Wβ‚€ i := by + intro i hir hiv + rw [hW₁, Function.update_of_ne hir, Function.update_of_ne hiv] + have hW₁P : βˆ€ i, Parked (W₁ i) := by + intro i + by_cases hir : i = resIdx + Β· rw [hir, hW₁res] + exact ⟨show 1 ≀ x.length + 1 by omega, fun j hj => hresSI.2 j hj⟩ + Β· by_cases hiv : i = vinIdx + Β· rw [hiv, hW₁vin]; exact hvinP + Β· rw [hW₁other i hir hiv]; exact hWβ‚€other i hir hiv + -- phase 5: the copy + have hcopy := copyToVirtualInputTM_hoareTime resIdx vinIdx resIdx_ne_vinIdx x inpβ‚€ Wβ‚€ + parkedBlank (by rw [hWβ‚€res]; exact hresH) (by rw [hWβ‚€res]; exact hresOut) + (by rw [hWβ‚€res]; exact ⟨by omega, fun j hj => hresSI.2 j hj⟩) hWβ‚€vin hinpP houtP hWβ‚€other + -- phase 6: blanking the result tape + have hreset := resetTapesTM_hoareTime (resetResult k) resetResult_nodup wfIdx + wfIdx_notMem_resetResult H inpβ‚€ W₁ parkedBlank hinpSI hinpP rfl + (fun j _ => by + by_cases hjr : j = resIdx + Β· rw [hjr, hW₁res]; exact ⟨hresSI.1, fun c hc => hresSI.2 c hc⟩ + Β· by_cases hjv : j = vinIdx + Β· rw [hjv, hW₁vin]; exact hvinSI + Β· rw [hW₁other j hjr hjv]; exact hWβ‚€SI j) + (fun j hj => by + rw [List.mem_singleton.mp hj, hW₁res] + show x.length + 1 ≀ H + omega) + (fun j hj c hc => by + rw [List.mem_singleton.mp hj, hW₁res] + exact hresFar c hc) + (by rw [hW₁other wfIdx (fun h => resIdx_ne_wfIdx h.symm) (fun h => wfIdx_ne_appIdx _ h), + hWβ‚€wf]) + (fun j hjw hjt => hW₁P j) + have hreset' : (resetTapesTM (resetResult k) wfIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = parkedBlank) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚‚ ∧ out = parkedBlank) + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1)) := by + refine (hreset.strengthen_post ?_).mono_bound (by simp [resetResult]) + rintro inp work out ⟨hi, ho, hts, hR, hrest⟩ + refine ⟨hi, funext fun j => ?_, ho⟩ + by_cases hjr : j = resIdx + Β· rw [hjr, hts resIdx (by simp [resetResult]), hWβ‚‚, Function.update_self] + rfl + Β· rw [hWβ‚‚, Function.update_of_ne hjr] + by_cases hjw : j = wfIdx + Β· rw [hjw, hR, hW₁other wfIdx (fun h => resIdx_ne_wfIdx h.symm) + (fun h => wfIdx_ne_appIdx _ h), hWβ‚€wf] + Β· exact hrest j hjw (by simp only [resetResult, List.mem_singleton]; exact hjr) + -- chain the two phases and read the result off + have hpre_imp : βˆ€ (inp : Tape) (work : Fin (3 + (k + 2) + 0) β†’ Tape) (out : Tape), + (inp = inpβ‚€ ∧ out = parkedBlank ∧ + work resIdx = resT ∧ work rfIdx = rfT ∧ work junkIdx = junkT ∧ + work wfIdx = regTape H ∧ + (βˆ€ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank)) β†’ + (inp = inpβ‚€ ∧ work = Wβ‚€ ∧ out = parkedBlank) := by + rintro inp work out ⟨hi, ho, hres, hrf, hjunk, hwf, happ⟩ + refine ⟨hi, funext fun i => ?_, ho⟩ + rcases layout_cases i with hi' | hi' | hi' | ⟨j, hi'⟩ + Β· rw [hi', hrf, hWβ‚€rf] + Β· rw [hi', hwf, hWβ‚€wf] + Β· rw [hi', hjunk, hWβ‚€junk] + Β· subst hi' + refine Fin.lastCases ?_ ?_ j + Β· rw [show appIdx (Fin.last (k + 1)) = resIdx from rfl, hres, hWβ‚€res] + Β· intro j' + rw [happ j', hWβ‚€app _ (fun h => absurd (appIdx_injective h) + (Fin.castSucc_lt_last j').ne)] + refine (((seqTM_det (copyToVirtualInputTM resIdx vinIdx) + (resetTapesTM (resetResult k) wfIdx) hinpP houtP hW₁P hcopy + hreset').weaken_pre hpre_imp).strengthen_post ?_).mono_bound le_rfl + Β· rintro inp work out ⟨hi, hw, ho⟩ + subst hw + refine ⟨hi, ho, ?_, ?_, ?_, fun j => ?_⟩ + Β· rw [hWβ‚‚, Function.update_of_ne rfIdx_ne_resIdx, + hW₁other rfIdx rfIdx_ne_resIdx rfIdx_ne_vinIdx, hWβ‚€rf] + Β· rw [hWβ‚‚, Function.update_of_ne junkIdx_ne_resIdx, + hW₁other junkIdx junkIdx_ne_resIdx junkIdx_ne_vinIdx, hWβ‚€junk] + Β· rw [hWβ‚‚, Function.update_of_ne wfIdx_ne_resIdx, + hW₁other wfIdx wfIdx_ne_resIdx wfIdx_ne_vinIdx, hWβ‚€wf] + Β· rw [applyPre_eq] + by_cases hj : j = Fin.castSucc (Fin.last k) + Β· rw [ite_eq_left hj, hj, show appIdx (Fin.castSucc (Fin.last k)) = vinIdx from rfl, + hWβ‚‚, Function.update_of_ne resIdx_ne_vinIdx.symm, hW₁vin] + Β· rw [ite_eq_right hj] + by_cases hjl : j = Fin.last (k + 1) + Β· rw [hjl, show appIdx (Fin.last (k + 1)) = resIdx from rfl, hWβ‚‚, Function.update_self] + Β· have hjr : appIdx j β‰  resIdx := fun h => + hjl (appIdx_injective (h.trans (rfl : resIdx = appIdx (Fin.last (k + 1))))) + have hjv : appIdx j β‰  vinIdx := fun h => + hj (appIdx_injective (h.trans (rfl : vinIdx = appIdx (Fin.castSucc (Fin.last k))))) + rw [hWβ‚‚, Function.update_of_ne hjr, hW₁other _ hjr hjv, hWβ‚€app j hjr] + + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean new file mode 100644 index 0000000000..28f18e264d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean @@ -0,0 +1,718 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Multiplying the block lengths of a pair β€” proof internals + +This module builds the one quadratic-output transducer needed by Cobham's +soundness direction: from `pair A B` it emits `|A| Β· |B|` copies of `false`, +which is exactly the length behaviour of `Complexity.smash`. The soundness proof +then applies `unaryLength_mem_FP` to turn this internal zero-filled ruler into +Cobham's all-one smash word. + +The machine `mulLenTM` is self-contained (one work tape, eight control states): + +1. *scan* β€” parse the leading self-delimiting block two symbols at a time, + writing one unary mark on the work tape per payload bit, so the work tape + ends up holding `|A|` in unary; +2. *outer loop* β€” for every remaining input symbol (i.e. `|B|` times) run the + *emit* pass, which walks the `|A|` marks writing one `false` per mark, and + the *rewind* pass, which returns the work head to cell one. + +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Complexity.Cobham.mulUnpair_mem_FP` β€” the block-length product is `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ## The function computed by the scanner -/ + +/-- The remaining output of the length-multiplication scanner when `k` payload +bits of the leading block have already been counted and `w` is the unread part +of the input: `|A| Β· |B|` copies of `false` for a well-formed remainder, and +nothing at all when the block framing is broken. -/ +def mulAux (k : β„•) (w : List Bool) : List Bool := + match unpair? w with + | some (x, y) => List.replicate ((k + x.length) * y.length) false + | none => [] + +/-- Emit `|A| Β· |B|` copies of `false` from a pair `pair A B`; the empty string +on input that is not a valid pair encoding. -/ +def mulUnpair (p : List Bool) : List Bool := mulAux 0 p + +@[simp] theorem mulAux_nil (k : β„•) : mulAux k [] = [] := rfl + +@[simp] theorem mulAux_singleton (k : β„•) (b : Bool) : mulAux k [b] = [] := by + cases b <;> rfl + +/-- Reaching the separator ends the block: only the suffix remains. -/ +@[simp] theorem mulAux_sep (k : β„•) (z : List Bool) : + mulAux k (false :: true :: z) = List.replicate (k * z.length) false := by + simp [mulAux, unpair?] + +/-- A doubled payload bit increments the counted length. -/ +theorem mulAux_double (k : β„•) (b : Bool) (z : List Bool) : + mulAux k (b :: b :: z) = mulAux (k + 1) z := by + cases b <;> + Β· simp only [mulAux, unpair?] + cases h : unpair? z with + | none => simp + | some xy => + obtain ⟨x, y⟩ := xy + simp only [Option.map_some, List.length_cons] + congr 2 + omega + +/-- A broken doubling halts the scan with no output. -/ +@[simp] theorem mulAux_broken (k : β„•) (z : List Bool) : + mulAux k (true :: false :: z) = [] := rfl + +/-- On a genuine pair the scanner emits `|A| Β· |B|` copies of `false`. -/ +theorem mulUnpair_pair (A B : List Bool) : + mulUnpair (pair A B) = List.replicate (A.length * B.length) false := by + simp [mulUnpair, mulAux] + +/-! ## The scanner -/ + +section MulLenMachine + +/-- Control states of `mulLenTM`. -/ +inductive MulPhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Read the first symbol of a doubled payload bit. -/ + | scanA + /-- The first symbol of the pair was `0`. -/ + | scanB0 + /-- The first symbol of the pair was `1`. -/ + | scanB1 + /-- Consume one symbol of the suffix, or halt at its end. -/ + | outer + /-- Walk the unary marks, emitting one `false` per mark. -/ + | emit + /-- Rewind the work head to cell one. -/ + | rew + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype MulPhase where + elems := {.skip, .scanA, .scanB0, .scanB1, .outer, .emit, .rew, .done} + complete := fun x => by cases x <;> simp + +/-- **The length-multiplication scanner.** Parses the leading self-delimiting +block into `|A|` unary marks on its work tape, then emits `|A|` zeros for each +of the `|B|` remaining input symbols. Computes `mulUnpair`. -/ +def mulLenTM : TM 1 where + Q := MulPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .scanA => + match iHead with + | Ξ“.zero => + (.scanB0, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.scanB1, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB0 => + match iHead with + | Ξ“.zero => + (.scanA, fun _ => Ξ“w.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Ξ“.one => + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB1 => + match iHead with + | Ξ“.one => + (.scanA, fun _ => Ξ“w.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .outer => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if wHeads 0 = Ξ“.one then + (.emit, fun i => readBackWrite (wHeads i), Ξ“w.zero, + idleDir iHead, fun _ => Dir3.right, Dir3.right) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rew => + if wHeads 0 = Ξ“.start then + (.outer, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun _ => Dir3.right, idleDir oHead) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB0 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB1 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .outer => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ _ => rfl, fun _ => rfl⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .rew => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ _ => rfl, idleDir_right_of_start⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-! ## Correctness of the scanner -/ + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem idle_eq {t : Tape} (h : t.read β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, ite_eq_right h, Tape.move] + +/-- The emit pass: from `emit`, with `m` marks on the work tape and the work +head at cell `k + 1`, the machine writes one `false` for each of the `r` +remaining marks and enters `rew` with the work head past the last mark. -/ +private theorem mulLenTM_emit_loop : + βˆ€ (r k m : β„•), k + r = m β†’ βˆ€ (acc : List Bool) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.emit β†’ + (c.work 0).cells = regCells m β†’ + (c.work 0).head = k + 1 β†’ + c.input.read β‰  Ξ“.start β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c', mulLenTM.reachesIn (r + 1) c c' ∧ + c'.state = MulPhase.rew ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = m + 1 ∧ + c'.input = c.input ∧ + c'.output.HasBinaryPrefix (acc ++ List.replicate r false) := by + intro r + induction r with + | zero => + intro k m hkm acc c hstate hcells hhead hinp hpre + have hwread : (c.work 0).read = Ξ“.blank := by + rw [Tape.read, hcells, hhead]; exact regCells_blank (by omega) + have hwne : (c.work 0).read β‰  Ξ“.start := by rw [hwread]; decide + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + refine ⟨{ state := MulPhase.rew + input := c.input + work := c.work + output := c.output }, ?_, rfl, hcells, by rw [hhead]; omega, rfl, by simpa⟩ + refine .step ?_ .zero + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)) + (idleDir ((c.work i).read))) = c.work := by + funext i + have : i = 0 := Subsingleton.elim i 0 + subst this + exact idle_eq hwne + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, reduceCtorEq, ite_false] + rw [hwork, idle_eq houtne] + | succ r ih => + intro k m hkm acc c hstate hcells hhead hinp hpre + have hwread : (c.work 0).read = Ξ“.one := by + rw [Tape.read, hcells, hhead]; exact regCells_one (by omega) (by omega) + have hwne : (c.work 0).read β‰  Ξ“.start := by rw [hwread]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output.writeAndMove (Ξ“.ofBool false) Dir3.right } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact writeAndMove_readBack _ hwne _ + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, hc1, reduceCtorEq, ite_false, + reduceIte] + rw [hwork] + rfl + obtain ⟨c', hreach, hst, hcl, hhd, hin, hout⟩ := + ih (k + 1) m (by omega) (acc ++ [false]) c1 rfl + (by rw [hc1]; simpa using! hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit false hpre) + refine ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], ?_⟩ + rw [List.append_assoc] at hout + simpa using! hout + +/-- The rewind pass: from `rew` with the work head at cell `h`, the machine walks +back to the left-end marker and re-enters `outer` with the work head at cell one, +leaving every tape's contents untouched. -/ +private theorem mulLenTM_rew_loop : + βˆ€ (h m : β„•) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.rew β†’ + (c.work 0).cells = regCells m β†’ + (c.work 0).head = h β†’ + c.input.read β‰  Ξ“.start β†’ + c.output.read β‰  Ξ“.start β†’ + βˆƒ c', mulLenTM.reachesIn (h + 1) c c' ∧ + c'.state = MulPhase.outer ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = 1 ∧ + c'.input = c.input ∧ + c'.output = c.output := by + intro h + induction h with + | zero => + intro m c hstate hcells hhead hinp hout + have hwread : (c.work 0).read = Ξ“.start := by + rw [Tape.read, hcells, hhead]; rfl + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + show ((c.work 0).write _).move Dir3.right = (c.work 0).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + refine ⟨{ state := MulPhase.outer + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simp [Tape.move_cells, hcells], + by simp [Tape.move, hhead], rfl, rfl⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, reduceIte, reduceCtorEq, + ite_false] + rw [hwork, idle_eq hout] + | succ h ih => + intro m c hstate hcells hhead hinp hout + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.rew + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, ite_eq_right hwne] + exact writeAndMove_readBack _ hwne _ + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hinp_eq, hc1, ite_eq_right hwne, reduceCtorEq, + ite_false] + rw [hwork, idle_eq hout] + obtain ⟨c', hreach, hst, hcl, hhd, hin, hou⟩ := + ih m c1 rfl (by rw [hc1]; simpa [Tape.move_cells] using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) (by rw [hc1]; simpa using hout) + exact ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], by rw [hou, hc1]⟩ + +/-- The outer loop: from `outer`, with `m` marks on the work tape and `B` left to +read, the machine runs one emit-and-rewind pass per symbol of `B` and halts with +`|B| Β· m` zeros appended to the output. -/ +private theorem mulLenTM_outer_loop : + βˆ€ (B : List Bool) (m : β„•) (acc : List Bool) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.outer β†’ + (c.work 0).cells = regCells m β†’ + (c.work 0).head = 1 β†’ + c.input.HasBinarySuffix B β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ B.length * (2 * m + 4) + 1 ∧ mulLenTM.reachesIn t c c' ∧ + mulLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ List.replicate (B.length * m) false) := by + intro B + induction B with + | nil => + intro m acc c hstate hcells hhead hsuf hpre + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have hinp : c.input.read β‰  Ξ“.start := by rw [hread]; decide + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir Ξ“.blank) = c.input := by + rw [idleDir, ite_eq_right (by decide), Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hinp_eq, reduceIte, reduceCtorEq, + ite_false] + rw [hwork, idle_eq houtne] + | cons b B ih => + intro m acc c hstate hcells hhead hsuf hpre + have hread : c.input.read = Ξ“.ofBool b := hsuf.read_cons + have hnb : Β¬ c.input.read = Ξ“.blank := by rw [hread]; cases b <;> decide + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.emit + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hnb, hc1, reduceCtorEq, ite_false] + rw [hwork, idle_eq houtne] + have hsuf1 : c1.input.HasBinarySuffix B := hsuf.move_right_cons + obtain ⟨c2, hreach2, hst2, hcl2, hhd2, hin2, hout2⟩ := + mulLenTM_emit_loop m 0 m (by omega) acc c1 rfl (by rw [hc1]; exact hcells) + (by rw [hc1]; simpa using hhead) hsuf1.read_ne_start (by rw [hc1]; exact hpre) + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hout3⟩ := + mulLenTM_rew_loop (m + 1) m c2 hst2 hcl2 hhd2 + (by rw [hin2]; exact hsuf1.read_ne_start) + (by rw [hout2.read_blank]; decide) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih m (acc ++ List.replicate m false) c3 hst3 hcl3 hhd3 + (by rw [hin3, hin2]; exact hsuf1) (by rw [hout3]; exact hout2) + refine ⟨c', (m + 1 + (m + 1 + 1 + t)) + 1, ?_, ?_, hhalt', ?_⟩ + Β· simp only [List.length_cons] + have : (B.length + 1) * (2 * m + 4) = B.length * (2 * m + 4) + (2 * m + 4) := by ring + omega + Β· exact .step hstep + (mulLenTM.reachesIn_trans hreach2 (mulLenTM.reachesIn_trans hreach3 hreach')) + Β· rw [List.append_assoc, ← List.replicate_add] at hout' + have : m + B.length * m = (b :: B).length * m := by + simp only [List.length_cons]; ring + rwa [this] at hout' + +/-- The scan pass: from `scanA`, with `k` payload bits already counted as marks on +the work tape and `w` still unread, the machine runs the rest of the computation +and halts with `mulAux k w` on the output tape. The parameter `N` is a fuel bound +on `k + |w|`, which strictly decreases across the recursive step. -/ +private theorem mulLenTM_scan_loop : + βˆ€ (N : β„•) (w : List Bool) (k : β„•), k + w.length ≀ N β†’ + βˆ€ (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.scanA β†’ + (c.work 0).cells = regCells k β†’ + (c.work 0).head = k + 1 β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix [] β†’ + βˆƒ c' t, t ≀ 2 * N ^ 2 + 5 * N + 5 ∧ mulLenTM.reachesIn t c c' ∧ + mulLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (mulAux k w) := by + intro N + induction N with + | zero => + intro w k hN c hstate hcells hhead hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (by omega) + subst hwnil + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have hinp_eq : c.input.move (idleDir Ξ“.blank) = c.input := by + rw [idleDir, ite_eq_right (by decide), Tape.move] + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hinp_eq, reduceCtorEq, ite_false] + rw [hwork, idle_eq houtne] + | succ N ih => + intro w k hN c hstate hcells hhead hsuf hpre + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + have hidleB : βˆ€ t : Tape, t.move (idleDir Ξ“.blank) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + have hidleZ : βˆ€ t : Tape, t.move (idleDir Ξ“.zero) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + -- The one-step transition out of `scanA` on a payload bit. + have hstepA : βˆ€ b : Bool, + c.input.read = Ξ“.ofBool b β†’ + mulLenTM.step c = some + { state := (bif b then MulPhase.scanB1 else MulPhase.scanB0) + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + intro b hread + cases b <;> + Β· simp only [TM.step, hstate, mulLenTM, hread, Ξ“.ofBool, reduceCtorEq, ite_false, + Bool.cond_true, Bool.cond_false] + rw [hwork, idle_eq houtne] + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hidleB, reduceCtorEq, ite_false] + rw [hwork, idle_eq houtne] + | [b] => + -- One payload symbol then end of input: the block framing is broken. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix [] := hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.blank := hsuf1.read_nil + refine ⟨{ state := MulPhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [mulAux_singleton] using hpre⟩ + refine .step (hstepA b hsuf.read_cons) (.step ?_ .zero) + cases b <;> + Β· simp only [TM.step, mulLenTM, hread1, hidleB, reduceCtorEq, ite_false, + Bool.cond_true, Bool.cond_false] + rw [hwork, idle_eq houtne] + | true :: false :: z => + -- A broken doubling: halt with empty output. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.zero := hsuf1.read_cons + refine ⟨{ state := MulPhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [mulAux_broken] using hpre⟩ + refine .step (hstepA true hsuf.read_cons) (.step ?_ .zero) + simp only [TM.step, mulLenTM, hread1, hidleZ, reduceCtorEq, ite_false, + Bool.cond_true] + rw [hwork, idle_eq houtne] + | false :: true :: z => + -- The separator: rewind the work tape and run the outer loop over `z`. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.one := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.rew + input := (c.input.move Dir3.right).move Dir3.right + work := c.work + output := c.output } with hc2 + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, ite_false] + rw [hwork, idle_eq houtne] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hou3⟩ := + mulLenTM_rew_loop (k + 1) k c2 rfl (by rw [hc2]; exact hcells) + (by rw [hc2]; exact hhead) hsuf2.read_ne_start (by rw [hc2]; exact houtne) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + mulLenTM_outer_loop z k [] c3 hst3 hcl3 hhd3 (by rw [hin3]; exact hsuf2) + (by rw [hou3]; exact hpre) + refine ⟨c', (k + 1 + 1 + t) + 1 + 1, ?_, ?_, hhalt', ?_⟩ + Β· simp only [List.length_cons] at hN + have hz : z.length ≀ N := by omega + have hk : k ≀ N := by omega + have ht' : t ≀ z.length * (2 * k + 4) + 1 := ht + have : z.length * (2 * k + 4) ≀ N * (2 * N + 4) := by + exact Nat.mul_le_mul hz (by omega) + nlinarith [sq_nonneg N] + Β· exact .step hstep1 (.step hstep2 (mulLenTM.reachesIn_trans hreach3 hreach')) + Β· rw [mulAux_sep] + have : z.length * k = k * z.length := Nat.mul_comm _ _ + rw [this] at hout' + simpa using hout' + | false :: false :: z => + -- A doubled `0`: write one mark and continue scanning. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.zero := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Ξ“.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Ξ“w.one).toΞ“ Dir3.right) + = fun i => ((c.work i).write Ξ“.one).move Dir3.right := rfl + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, ite_false] + rw [hwmark, idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, ite_eq_right (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Ξ“.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 hhead2 + (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, ?_, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + Β· nlinarith [sq_nonneg N] + Β· rwa [mulAux_double] + | true :: true :: z => + -- A doubled `1`: write one mark and continue scanning. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.one := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB1 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA true hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Ξ“.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Ξ“w.one).toΞ“ Dir3.right) + = fun i => ((c.work i).write Ξ“.one).move Dir3.right := rfl + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, ite_false] + rw [hwmark, idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, ite_eq_right (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Ξ“.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 hhead2 + (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, ?_, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + Β· nlinarith [sq_nonneg N] + Β· rwa [mulAux_double] + +/-- The blank work tape of the initial configuration is the zero register. -/ +private theorem init_nil_cells_eq_regCells_zero : + (Tape.init ([] : List Ξ“)).cells = regCells 0 := by + funext j + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rfl + Β· obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_ge _ _ (by simp), regCells_blank (by omega)] + +/-- `mulUnpair` is polynomial-time, via the `mulLenTM` scanner. -/ +theorem mulUnpair_mem_FP : mulUnpair ∈ FP := by + refine ⟨2, 1, mulLenTM, (fun m => 2 * m ^ 2 + 5 * m + 6), ?_, ?_⟩ + Β· intro z + -- Step 1: move every head off the left-end marker. + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (Tape.init (z.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : mulLenTM.step (mulLenTM.initCfg z) = some c1 := by + simp [TM.step, mulLenTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + mulLenTM_scan_loop z.length z 0 (by omega) c1 rfl + (by rw [hc1]; show ((Tape.init []).move Dir3.right).cells = _ + rw [Tape.move_cells, init_nil_cells_eq_regCells_zero]) + (by rw [hc1]; show ((Tape.init []).move Dir3.right).head = _ + simp [Tape.move]) + hsuf hpre + exact ⟨c', t + 1, by simpa using by omega, .step hstep1 hreach, hhalt, + hout.hasOutput⟩ + Β· have h1 : (fun m : β„• => 2 * m ^ 2) =O ((Β· ^ 2) : β„• β†’ β„•) := by + simpa using (BigO.refl (fun m : β„• => m ^ 2)).const_mul_left 2 + have h2 : (fun m : β„• => 5 * m) =O ((Β· ^ 2) : β„• β†’ β„•) := + BigO.const_mul_left 5 + (by simpa [pow_one] using (BigO.pow_le_pow_right (by omega : 1 ≀ 2))) + exact BigO.add (BigO.add h1 h2) (BigO.const_le_pow 6 2) + +end MulLenMachine + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean new file mode 100644 index 0000000000..74a38775b8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean @@ -0,0 +1,733 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.SndBlock + +/-! +# Dropping the third component of a triple β€” proof internals + +`Cobham.reorder` turns `pair A (pair B C)` into `pair A B`: copy the leading +block verbatim, then decode the next block's payload. It is the one machine the +`comp` constructor needs, via `Cobham.pairFn_mem_FP`. + +## Main results + +- `Cobham.reorder_mem_FP` β€” the triple reorder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- Drop the third component of a right-nested triple. Copy doubled payload bits +verbatim until the `[false, true]` separator, then decode the *next* block's +payload (`fstBlock`). On a valid triple this satisfies +`reorder (pair A (pair B C)) = pair A B` (`reorder_pair_pair`). The incremental +recursion (writing before knowing validity) is what the `reorderTM` scanner +computes; it is total and needs no sub-machines. -/ +def reorder : List Bool β†’ List Bool + | false :: false :: z => false :: false :: reorder z + | true :: true :: z => true :: true :: reorder z + | false :: true :: z => false :: true :: fstBlock z + | c :: _ => [c] + | [] => [] + +theorem reorder_pair_pair (A B C : List Bool) : + reorder (pair A (pair B C)) = pair A B := by + induction A with + | nil => + show false :: true :: fstBlock (pair B C) = false :: true :: B + rw [fstBlock_pair] + | cons a A ih => + rw [pair_cons_eq] + cases a + Β· show false :: false :: reorder (pair A (pair B C)) = pair (false :: A) B + rw [ih, pair_cons_eq] + Β· show true :: true :: reorder (pair A (pair B C)) = pair (true :: A) B + rw [ih, pair_cons_eq] + +/-- Control states of `reorderTM`: skip the marker; phase 1 (`rcopyA`/`rcopyBf`/ +`rcopyBt`) copies doubled pairs verbatim until the separator; phase 2 +(`rdecA`/`rdecBf`/`rdecBt`) decodes the next block's payload; then halt. -/ +inductive ReorderPhase where + | rskip | rcopyA | rcopyBf | rcopyBt | rdecA | rdecBf | rdecBt | rdone + deriving DecidableEq + +instance : Fintype ReorderPhase where + elems := {.rskip, .rcopyA, .rcopyBf, .rcopyBt, .rdecA, .rdecBf, .rdecBt, .rdone} + complete := fun x => by cases x <;> simp + +/-- The reorder transducer computing `reorder`: copy the leading block verbatim +(phase 1) up to and including the `[false,true]` separator, then decode and emit +the payload of the following block (phase 2). -/ +def reorderTM : TM 0 where + Q := ReorderPhase + qstart := .rskip + qhalt := .rdone + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .rskip => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .rcopyA => + match iHead with + | Ξ“.zero => + (.rcopyBf, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | Ξ“.one => + (.rcopyBt, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rcopyBf => + match iHead with + | Ξ“.zero => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | Ξ“.one => + (.rdecA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rcopyBt => + match iHead with + | Ξ“.one => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecA => + match iHead with + | Ξ“.zero => + (.rdecBf, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.rdecBt, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecBf => + match iHead with + | Ξ“.zero => + (.rdecA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecBt => + match iHead with + | Ξ“.one => + (.rdecA, fun i => readBackWrite (wHeads i), Ξ“w.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdone => allIdle .rdone iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .rskip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .rcopyA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rcopyBf => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rcopyBt => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecBf => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecBt => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdone => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The decode phase stops on an incomplete final payload bit without emitting it. -/ +private theorem reorderTM_dec_single + (b : Bool) (acc : List Bool) (c : Cfg 0 reorderTM.Q) + (hstate : c.state = ReorderPhase.rdecA) + (hsuf : c.input.HasBinarySuffix [b]) + (hpre : c.output.HasBinaryPrefix acc) : + βˆƒ c' t, t ≀ 2 * [b].length + 2 ∧ reorderTM.reachesIn t c c' ∧ + reorderTM.halted c' ∧ c'.output.HasBinaryPrefix (acc ++ fstBlock [b]) := by + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + cases b with + | false => + have hread : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true => + have hread : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + +/-- Phase 2 of `reorderTM`: from `rdecA` on input `w` with output holding `acc`, +decode and emit `fstBlock w`, halting with `acc ++ fstBlock w`. Identical in shape +to `fstBlockTM_scan_loop`. -/ +private theorem reorderTM_dec_loop : + βˆ€ (fuel : β„•) (w acc : List Bool), w.length ≀ fuel β†’ βˆ€ (c : Cfg 0 reorderTM.Q), + c.state = ReorderPhase.rdecA β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ 2 * w.length + 2 ∧ reorderTM.reachesIn t c c' ∧ reorderTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ fstBlock w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | [false] => exact reorderTM_dec_single false acc c hstate hsuf hpre + | [true] => exact reorderTM_dec_single true acc c hstate hsuf hpre + | false :: true :: y => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true :: false :: rest => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: false :: z => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool false) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool false).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (false :: false :: z) = false :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + | true :: true :: z => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Ξ“w.ofBool true) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Ξ“w.ofBool true).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Ξ“w.ofBool_toΞ“]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (true :: true :: z) = true :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + +/-- The copy phase emits a lone remaining bit and then halts. -/ +private theorem reorderTM_copy_single + (b : Bool) (acc : List Bool) (c : Cfg 0 reorderTM.Q) + (hstate : c.state = ReorderPhase.rcopyA) + (hsuf : c.input.HasBinarySuffix [b]) + (hpre : c.output.HasBinaryPrefix acc) : + βˆƒ c' t, t ≀ 3 * [b].length + 3 ∧ reorderTM.reachesIn t c c' ∧ + reorderTM.halted c' ∧ c'.output.HasBinaryPrefix (acc ++ reorder [b]) := by + cases b with + | false => + have hread : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool false := by rw [hread]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [reorder] using hpre1 + | true => + have hread : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool true := by rw [hread]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [reorder] using hpre1 + +/-- The copy phase halts on empty input without changing the output prefix. -/ +private theorem reorderTM_copy_empty + (acc : List Bool) (c : Cfg 0 reorderTM.Q) + (hstate : c.state = ReorderPhase.rcopyA) + (hsuf : c.input.HasBinarySuffix []) + (hpre : c.output.HasBinaryPrefix acc) : + βˆƒ c' t, t ≀ 3 ∧ reorderTM.reachesIn t c c' ∧ reorderTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ reorder []) := by + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [reorder] using hpre + +/-- Phase 1 of `reorderTM`: from `rcopyA` on input `w` with output holding `acc`, +copy `w`'s leading block verbatim and decode the following block, halting with +`acc ++ reorder w`. The separator case hands off to `reorderTM_dec_loop`. -/ +private theorem reorderTM_copy_loop : + βˆ€ (fuel : β„•) (w acc : List Bool), w.length ≀ fuel β†’ βˆ€ (c : Cfg 0 reorderTM.Q), + c.state = ReorderPhase.rcopyA β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ 3 * w.length + 3 ∧ reorderTM.reachesIn t c c' ∧ reorderTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ reorder w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + exact reorderTM_copy_empty acc c hstate hsuf hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + -- The `rcopyA` step emits the first bit `c1` verbatim. + match w with + | [] => exact reorderTM_copy_empty acc c hstate hsuf hpre + | [false] => exact reorderTM_copy_single false acc c hstate hsuf hpre + | [true] => exact reorderTM_copy_single true acc c hstate hsuf hpre + | false :: true :: y => + -- separator: copy `false` then `true`, then decode `y`. + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool false := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false, true]) := by + have hco : (readBackWrite c1.input.read).toΞ“ = Ξ“.ofBool true := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [false, true]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit true hpre1 + rwa [List.append_assoc] at this + have hyfuel : y.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + reorderTM_dec_loop fuel y (acc ++ [false, true]) hyfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (false :: true :: y) = false :: true :: fstBlock y := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | false :: false :: z => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool false := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false, false]) := by + have hco : (readBackWrite c1.input.read).toΞ“ = Ξ“.ofBool false := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [false, false]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit false hpre1 + rwa [List.append_assoc] at this + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false, false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (false :: false :: z) = false :: false :: reorder z := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | true :: true :: z => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool true := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true, true]) := by + have hco : (readBackWrite c1.input.read).toΞ“ = Ξ“.ofBool true := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [true, true]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit true hpre1 + rwa [List.append_assoc] at this + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true, true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (true :: true :: z) = true :: true :: reorder z := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | true :: false :: rest => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool true := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + have hr : reorder (true :: false :: rest) = [true] := rfl + rw [hr] + exact hpre1 + +/-- `reorder` is polynomial-time, via the `reorderTM` scanner. -/ +theorem reorder_mem_FP : reorder ∈ FP := by + refine ⟨1, 0, reorderTM, (fun m => 3 * m + 4), ?_, ?_⟩ + Β· intro z + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := (Tape.init (z.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : reorderTM.step (reorderTM.initCfg z) = some c1 := by + simp [TM.step, reorderTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + reorderTM_copy_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≀ 3 * z.length + 4; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + Β· have hn : (fun m : β„• => 3 * m) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using (BigO.refl (fun m : β„• => m)).const_mul_left 3 + exact BigO.add hn (BigO.const_le_pow 4 1) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean new file mode 100644 index 0000000000..adf0c7205b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Polynomial-time string reversal β€” proof internals + +The transducer `reverseTM` has one work tape and four control states: it copies +the input onto the work tape left to right, then walks the work head back to the +left-end marker, emitting each cell to the output as it passes. The result is the +input read backwards, in `2 Β· |x| + 3` steps. + +Reversal is what turns a right-to-left recursion into a left-to-right loop: +recursion on notation peels the *head* of a string, so an iterative evaluation +consumes the *last* bit first. + +## Main results + +- `Complexity.reverse_mem_FP` β€” reversal is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-- Control states of `reverseTM`. -/ +inductive RevPhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Copy the input onto the work tape, left to right. -/ + | copy + /-- Walk the work head back, emitting each cell to the output. -/ + | emit + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype RevPhase where + elems := {.skip, .copy, .emit, .done} + complete := fun x => by cases x <;> simp + +/-- **The reversal transducer.** Copies the input onto its work tape, then +sweeps the work head back to the left-end marker, writing each cell it passes to +the output tape. Computes `List.reverse`. -/ +def reverseTM : TM 1 where + Q := RevPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.copy, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .copy => + match iHead with + | Ξ“.zero => + (.copy, fun _ => Ξ“w.zero, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Ξ“.one => + (.copy, fun _ => Ξ“w.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .emit => + if wHeads 0 = Ξ“.zero then + (.emit, fun i => readBackWrite (wHeads i), Ξ“w.zero, + idleDir iHead, fun i => moveLeftDir (wHeads i), Dir3.right) + else if wHeads 0 = Ξ“.one then + (.emit, fun i => readBackWrite (wHeads i), Ξ“w.one, + idleDir iHead, fun i => moveLeftDir (wHeads i), Dir3.right) + else + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .copy => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => moveLeftDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + fun _ => rfl⟩ + Β· split + Β· exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + fun _ => rfl⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem rev_idle_eq {t : Tape} (h : t.read β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, ite_eq_right h, Tape.move] + +/-- The copy phase: from `copy` with the input cursor on `w` and the work tape +holding `acc`, the machine appends `w` to the work tape and enters `emit` with +the work head on the last copied cell. -/ +private theorem reverseTM_copy_loop : + βˆ€ (w acc : List Bool) (c : Cfg 1 reverseTM.Q), + c.state = RevPhase.copy β†’ + c.input.HasBinarySuffix w β†’ + (c.work 0).HasBinaryPrefix acc β†’ + (c.work 0).cells 0 = Ξ“.start β†’ + c.output.HasBinaryPrefix [] β†’ + βˆƒ c', reverseTM.reachesIn (w.length + 1) c c' ∧ + c'.state = RevPhase.emit ∧ + (c'.work 0).HasBinaryContent (acc ++ w) ∧ + (c'.work 0).cells 0 = Ξ“.start ∧ + (c'.work 0).head = (acc ++ w).length ∧ + c'.input.read β‰  Ξ“.start ∧ + c'.output.HasBinaryPrefix [] := by + intro w + induction w with + | nil => + intro acc c hstate hsuf hwork hw0 hout + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have houtne : c.output.read β‰  Ξ“.start := by rw [hout.read_blank]; decide + have hwread : (c.work 0).read = Ξ“.blank := by + rw [Tape.read, hwork.1] + exact hwork.2.2 acc.length le_rfl + have hwne : (c.work 0).read β‰  Ξ“.start := by rw [hwread]; decide + have hinp_eq : c.input.move (idleDir Ξ“.blank) = c.input := by + rw [idleDir, ite_eq_right (by decide), Tape.move] + have hwmove : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, ite_eq_right hwne] + exact writeAndMove_readBack _ hwne _ + refine ⟨{ state := RevPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output }, ?_, rfl, ?_, ?_, ?_, by rw [hread]; decide, by simpa⟩ + Β· refine .step ?_ .zero + simp only [TM.step, hstate, reverseTM, hread, hinp_eq, reduceCtorEq, ite_false] + rw [hwmove, rev_idle_eq houtne] + Β· have hc : (c.work 0).HasBinaryContent acc := hwork.2 + simpa using hc.move Dir3.left + Β· show ((c.work 0).move Dir3.left).cells 0 = _ + rw [Tape.move_cells]; exact hw0 + Β· show ((c.work 0).move Dir3.left).head = _ + simp only [Tape.move, hwork.1, List.append_nil] + omega + | cons b w ih => + intro acc c hstate hsuf hwork hw0 hout + have hread : c.input.read = Ξ“.ofBool b := hsuf.read_cons + have houtne : c.output.read β‰  Ξ“.start := by rw [hout.read_blank]; decide + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.copy + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (Ξ“.ofBool b) Dir3.right + output := c.output } with hc1 + have hstep : reverseTM.step c = some c1 := by + cases b <;> + Β· simp only [TM.step, hstate, reverseTM, hread, Ξ“.ofBool, hc1, + reduceCtorEq, ite_false] + rw [rev_idle_eq houtne] + rfl + obtain ⟨c', hreach, hst, hcont, hcz, hhd, hinp, hpre⟩ := + ih (acc ++ [b]) c1 rfl hsuf.move_right_cons + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit b hwork) + (by + show ((c.work 0).writeAndMove (Ξ“.ofBool b) Dir3.right).cells 0 = Ξ“.start + exact Tape.write_move_cell0 _ _ hw0) + (by rw [hc1]; exact hout) + refine ⟨c', .step hstep hreach, hst, ?_, hcz, ?_, hinp, hpre⟩ + Β· simpa using hcont + Β· simpa using hhd + +/-- The emit phase: from `emit` with the work tape holding `bits` and its head on +cell `j`, the machine writes `bits.take j` backwards to the output and halts. -/ +private theorem reverseTM_emit_loop : + βˆ€ (j : β„•) (bits acc : List Bool) (c : Cfg 1 reverseTM.Q), + c.state = RevPhase.emit β†’ + (c.work 0).HasBinaryContent bits β†’ + (c.work 0).cells 0 = Ξ“.start β†’ + (c.work 0).head = j β†’ j ≀ bits.length β†’ + c.input.read β‰  Ξ“.start β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c', reverseTM.reachesIn (j + 1) c c' ∧ reverseTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ (bits.take j).reverse) := by + intro j + induction j with + | zero => + intro bits acc c hstate hcont hw0 hhead _ hinp hout + have hwread : (c.work 0).read = Ξ“.start := by rw [Tape.read, hhead]; exact hw0 + have hwne0 : Β¬ (c.work 0).read = Ξ“.zero := by rw [hwread]; decide + have hwne1 : Β¬ (c.work 0).read = Ξ“.one := by rw [hwread]; decide + have houtne : c.output.read β‰  Ξ“.start := by rw [hout.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + refine ⟨{ state := RevPhase.done + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simpa using hout⟩ + refine .step ?_ .zero + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [Tape.writeAndMove, Tape.write, ite_eq_left (by omega : (c.work 0).head = 0), + idleDir, ite_eq_left hwread] + simp only [TM.step, hstate, reverseTM, hinp_eq, hwne0, hwne1, reduceCtorEq, + ite_false] + rw [hwork, rev_idle_eq houtne] + | succ j ih => + intro bits acc c hstate hcont hw0 hhead hjb hinp hout + have hjlt : j < bits.length := by omega + have hwread : (c.work 0).read = Ξ“.ofBool (bits[j]'hjlt) := by + rw [Tape.read, hhead]; exact hcont.1 j hjlt + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [hwread]; exact Ξ“.ofBool_ne_start _ + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + have hwmove : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, ite_eq_right hwne] + exact writeAndMove_readBack _ hwne _ + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output.writeAndMove (Ξ“.ofBool (bits[j]'hjlt)) Dir3.right } with hc1 + have hstep : reverseTM.step c = some c1 := by + rcases hb : bits[j]'hjlt with _ | _ + Β· have h0 : (c.work 0).read = Ξ“.zero := by rw [hwread, hb]; rfl + simp only [TM.step, hstate, reverseTM, hinp_eq, h0, hc1, hb, Ξ“.ofBool, + reduceCtorEq, ite_false, reduceIte] + rw [hwmove] + rfl + Β· have h1 : (c.work 0).read = Ξ“.one := by rw [hwread, hb]; rfl + simp only [TM.step, hstate, reverseTM, hinp_eq, h1, hc1, hb, Ξ“.ofBool, + reduceCtorEq, ite_false, reduceIte] + rw [hwmove] + rfl + obtain ⟨c', hreach, hhalt, hfin⟩ := + ih bits (acc ++ [bits[j]'hjlt]) c1 rfl + (by rw [hc1]; exact hcont.move Dir3.left) + (by rw [hc1]; show ((c.work 0).move Dir3.left).cells 0 = _ + rw [Tape.move_cells]; exact hw0) + (by rw [hc1]; show ((c.work 0).move Dir3.left).head = _ + simp only [Tape.move, hhead]; omega) + (by omega) + (by rw [hc1]; exact hinp) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit _ hout) + refine ⟨c', .step hstep hreach, hhalt, ?_⟩ + have hsplit : bits.take (j + 1) = bits.take j ++ [bits[j]'hjlt] := by + rw [List.take_add_one, List.getElem?_eq_getElem hjlt] + rfl + have heq : acc ++ (bits.take (j + 1)).reverse + = (acc ++ [bits[j]'hjlt]) ++ (bits.take j).reverse := by + rw [hsplit]; simp + rw [heq] + exact hfin + +/-- `reverseTM` computes `List.reverse` in `2 Β· |x| + 3` steps. -/ +theorem reverseTM_computesInTime : + reverseTM.ComputesInTime (fun x : List Bool => x.reverse) (fun n => 2 * n + 3) := by + intro x + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.copy + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : reverseTM.step (reverseTM.initCfg x) = some c1 := by + simp [TM.step, reverseTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c2, hreach2, hst2, hcont2, hcz2, hhd2, hinp2, hout2⟩ := + reverseTM_copy_loop x [] c1 rfl + (by rw [hc1]; exact Tape.init_move_right_hasBinarySuffix x) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + (by rw [hc1]; show ((Tape.init ([] : List Ξ“)).move Dir3.right).cells 0 = _ + rw [Tape.move_cells]; simp) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + obtain ⟨c', hreach', hhalt', hfin⟩ := + reverseTM_emit_loop x.length x [] c2 hst2 (by simpa using hcont2) hcz2 + (by simpa using hhd2) le_rfl hinp2 hout2 + refine ⟨c', ((x.length + 1) + (x.length + 1)) + 1, by simp; omega, + .step hstep1 (reverseTM.reachesIn_trans hreach2 hreach'), hhalt', ?_⟩ + rw [List.nil_append, List.take_length] at hfin + exact hfin.hasOutput + +/-- Internal proof that string reversal is in `FP`. -/ +theorem reverse_mem_FP : + (fun x : List Bool => x.reverse) ∈ FP := by + refine ⟨1, 1, reverseTM, (fun n => 2 * n + 3), reverseTM_computesInTime, ?_⟩ + have hn : (fun n : β„• => 2 * n) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using (BigO.refl (fun n : β„• => n)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean new file mode 100644 index 0000000000..7a1005d98c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean @@ -0,0 +1,536 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Extract +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.OutputBounds + +/-! +# Running a machine inside the algebra β€” proof internals + +Everything the completeness direction needs about a *run*, as opposed to a single +step: a total step function that stands still once the machine has halted, the +standing invariants of a run (the left-end marker where it belongs, every head +inside the encoded window), and the iterated versions of `Cobham.stepFn` and +`Cobham.rewindFn`. + +## Main results + +- `Complexity.TM.runCfg` β€” the configuration after `n` steps, halting-idempotent +- `Complexity.Cobham.iterate_stepFn` β€” the encoded iteration tracks it +- `Complexity.Cobham.iterate_rewindFn` β€” the rewind iteration drives the head to + cell `0` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : β„•} + +/-! ## A total run -/ + +/-- The configuration after `n` steps, standing still once halted. -/ +def runCfg (tm : TM k) (c : Cfg k tm.Q) : β„• β†’ Cfg k tm.Q + | 0 => c + | n + 1 => (tm.step (runCfg tm c n)).getD (runCfg tm c n) + +@[simp] theorem runCfg_zero (tm : TM k) (c : Cfg k tm.Q) : runCfg tm c 0 = c := rfl + +theorem runCfg_succ (tm : TM k) (c : Cfg k tm.Q) (n : β„•) : + runCfg tm c (n + 1) = (tm.step (runCfg tm c n)).getD (runCfg tm c n) := rfl + +theorem runCfg_add (tm : TM k) (c : Cfg k tm.Q) (a b : β„•) : + runCfg tm c (a + b) = runCfg tm (runCfg tm c a) b := by + induction b with + | zero => rfl + | succ b ih => rw [show a + (b + 1) = (a + b) + 1 from by omega, runCfg_succ, ih, + runCfg_succ] + +/-- Once halted, the run stands still. -/ +theorem runCfg_of_halted (tm : TM k) {c : Cfg k tm.Q} (h : c.state = tm.qhalt) (n : β„•) : + runCfg tm c n = c := by + induction n with + | zero => rfl + | succ n ih => rw [runCfg_succ, ih, TM.step, ite_eq_left h, Option.getD_none] + +/-- A run of exactly `t` steps is the `t`-th iterate. -/ +theorem runCfg_of_reachesIn (tm : TM k) {c c' : Cfg k tm.Q} {t : β„•} + (h : tm.reachesIn t c c') : runCfg tm c t = c' := by + induction h with + | zero => rfl + | @step c c'' t c' hstep _ ih => + rw [show t + 1 = 1 + t from by omega, runCfg_add, runCfg_succ, runCfg_zero, hstep, + Option.getD_some, ih] + +/-! ## The standing invariants of a run -/ + +/-- One step preserves the left-end marker's position on every tape. -/ +theorem step_startInvariant (tm : TM k) {c c' : Cfg k tm.Q} (h : tm.step c = some c') + (hin : c.input.StartInvariant) (hwork : βˆ€ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.StartInvariant ∧ (βˆ€ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + rw [TM.step, ite_eq_right (TM.state_ne_qhalt_of_step h)] at h + injection h with h + subst h + exact ⟨hin.move _, fun i => (hwork i).writeAndMove _ _, hout.writeAndMove _ _⟩ + +/-- One step moves every head by at most one cell. -/ +theorem step_head_le (tm : TM k) {c c' : Cfg k tm.Q} (h : tm.step c = some c') : + c'.input.head ≀ c.input.head + 1 ∧ (βˆ€ i, (c'.work i).head ≀ (c.work i).head + 1) ∧ + c'.output.head ≀ c.output.head + 1 := by + rw [TM.step, ite_eq_right (TM.state_ne_qhalt_of_step h)] at h + injection h with h + subst h + exact ⟨Tape.head_move_le _ _, fun i => Tape.head_writeAndMove_le _ _ _, + Tape.head_writeAndMove_le _ _ _⟩ + +/-- **Every tape of a run keeps its left-end marker.** -/ +theorem runCfg_startInvariant (tm : TM k) (x : List Bool) (n : β„•) : + (runCfg tm (tm.initCfg x) n).input.StartInvariant ∧ + (βˆ€ i, ((runCfg tm (tm.initCfg x) n).work i).StartInvariant) ∧ + (runCfg tm (tm.initCfg x) n).output.StartInvariant := by + induction n with + | zero => + exact ⟨Tape.StartInvariant.init_ofBool x, fun _ => Tape.StartInvariant.init_nil, + Tape.StartInvariant.init_nil⟩ + | succ n ih => + rw [runCfg_succ] + cases hs : tm.step (runCfg tm (tm.initCfg x) n) with + | none => rw [Option.getD_none]; exact ih + | some c' => + rw [Option.getD_some] + exact step_startInvariant tm hs ih.1 ih.2.1 ih.2.2 + +/-- **After `n` steps every head is within `n` cells of the start.** -/ +theorem runCfg_head_le (tm : TM k) (x : List Bool) (n : β„•) : + (runCfg tm (tm.initCfg x) n).input.head ≀ n ∧ + (βˆ€ i, ((runCfg tm (tm.initCfg x) n).work i).head ≀ n) ∧ + (runCfg tm (tm.initCfg x) n).output.head ≀ n := by + induction n with + | zero => exact ⟨by simp, fun _ => by simp, by simp⟩ + | succ n ih => + rw [runCfg_succ] + cases hs : tm.step (runCfg tm (tm.initCfg x) n) with + | none => rw [Option.getD_none]; exact ⟨by omega, fun i => by have := ih.2.1 i; omega, + by omega⟩ + | some c' => + rw [Option.getD_some] + obtain ⟨h1, h2, h3⟩ := step_head_le tm hs + exact ⟨by omega, fun i => by have := h2 i; have := ih.2.1 i; omega, by omega⟩ + +end TM + +namespace Cobham + +variable {k : β„•} + +/-- The invariants of a run, in the form the encoding lemmas want. -/ +theorem cfgTapes_runCfg_inv (tm : TM k) (x : List Bool) (n W : β„•) (hn : n ≀ W) : + (βˆ€ t ∈ cfgTapes (TM.runCfg tm (tm.initCfg x) n), t.StartInvariant) ∧ + (βˆ€ t ∈ cfgTapes (TM.runCfg tm (tm.initCfg x) n), t.head ≀ W) := by + obtain ⟨i1, w1, o1⟩ := TM.runCfg_startInvariant tm x n + obtain ⟨i2, w2, o2⟩ := TM.runCfg_head_le tm x n + constructor <;> intro t ht <;> + Β· rw [cfgTapes, List.mem_cons, List.mem_cons, List.mem_ofFn] at ht + rcases ht with rfl | rfl | ⟨i, rfl⟩ + Β· first | exact i1 | omega + Β· first | exact o1 | omega + Β· first | exact w1 i | (have := w2 i; omega) + +/-- **The encoded iteration tracks the run.** -/ +theorem iterate_stepFn (tm : TM k) (W : β„•) (x : List Bool) + (hq : Fintype.card tm.Q ≀ blockWidth W) : + βˆ€ n : β„•, n ≀ W β†’ + (stepFn tm (blockRuler W))^[n] (cfgCode W (tm.initCfg x)) + = cfgCode W (TM.runCfg tm (tm.initCfg x) n) := by + intro n + induction n with + | zero => intro _; rfl + | succ n ih => + intro hn + obtain ⟨hinv, hW⟩ := cfgTapes_runCfg_inv tm x n W (by omega) + rw [Function.iterate_succ_apply', ih (by omega), TM.runCfg_succ] + cases hs : tm.step (TM.runCfg tm (tm.initCfg x) n) with + | none => + rw [Option.getD_none] + exact stepFn_halted tm (TM.step_eq_none_iff_halted.mp hs) hq hW + | some c' => + rw [Option.getD_some] + have hgood := stepActs_forallβ‚‚ tm _ hinv hW + refine stepFn_eq tm hs hq hW ?_ ?_ hgood + Β· exact hinv _ (by simp [cfgTapes]) + Β· intro i + exact hinv _ (by + rw [cfgTapes] + exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ + (List.mem_ofFn.mpr ⟨i, rfl⟩))) + +/-! ## The rewind iteration -/ + +private theorem head_move_left (s : Tape) : (s.move Dir3.left).head = s.head - 1 := rfl + +/-- Iterated left moves. -/ +private theorem head_moveLeft (t : Tape) (n : β„•) : + ((fun s : Tape => s.move Dir3.left)^[n] t).head = t.head - n ∧ + ((fun s : Tape => s.move Dir3.left)^[n] t).cells = t.cells := by + induction n with + | zero => exact ⟨rfl, rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply'] + refine ⟨?_, ?_⟩ + Β· rw [head_move_left, ih.1] + omega + Β· rw [Tape.move_cells, ih.2] + +private theorem startInvariant_moveLeft (t : Tape) (h : t.StartInvariant) (n : β„•) : + ((fun s : Tape => s.move Dir3.left)^[n] t).StartInvariant := by + induction n with + | zero => exact h + | succ n ih => rw [Function.iterate_succ_apply']; exact ih.move _ + +/-- **The rewind iteration walks the head left.** -/ +theorem iterate_rewindFn {W : β„•} (t : Tape) (hinv : t.StartInvariant) (hW : t.head ≀ W) : + βˆ€ n : β„•, (rewindFn (blockRuler W))^[n] (pairCode W t) + = pairCode W ((fun s : Tape => s.move Dir3.left)^[n] t) := by + intro n + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', ih, Function.iterate_succ_apply'] + exact rewindFn_eq _ (startInvariant_moveLeft t hinv n) + (by have := (head_moveLeft t n).1; omega) + +/-- **After enough rewinding the head is at cell `0`.** -/ +theorem rewound (t : Tape) {n : β„•} (h : t.head ≀ n) : + (fun s : Tape => s.move Dir3.left)^[n] t + = { head := 0, cells := t.cells } := by + obtain ⟨h1, h2⟩ := head_moveLeft t n + refine Tape.ext ?_ h2 + show ((fun s : Tape => s.move Dir3.left)^[n] t).head = 0 + rw [h1] + omega + +/-! ## Reading the output off the rewound tape + +With the head at cell `0` the tape's right half-block is the whole window, in +order and two bits per cell. The first bit of each cell says whether it holds +data β€” `symCode` is arranged so that only `0` and `1` have it set β€” and the +second is the bit itself. So the output is the second bits, truncated where the +first bits stop: `Complexity.cellBits` twice and one `Complexity.runTrue`. -/ + +@[simp] theorem cellsCode_one (t : Tape) (i : β„•) : + cellsCode t i 1 = symCode (t.cells i) := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil] + +/-- Reading one bit of an aligned window is reading one bit of a cell's code. -/ +theorem bitOf_cellsCode (t : Tape) {w j : β„•} (hj : j < w) {o : β„•} (ho : o < 2) : + bitOf (cellsCode t 0 w) (2 * j + o) = bitOf (symCode (t.cells j)) o := by + have hsplit : cellsCode t 0 w + = cellsCode t 0 j ++ (cellsCode t j 1 ++ cellsCode t (j + 1) (w - j - 1)) := by + conv_lhs => rw [show w = j + (1 + (w - j - 1)) from by omega] + rw [cellsCode_add t 0 j, cellsCode_add t (0 + j) 1 (w - j - 1)] + simp only [Nat.zero_add] + have hlen1 : (cellsCode t 0 j).length = 2 * j := cellsCode_length _ _ _ + have hlen2 : (cellsCode t j 1).length = 2 := by rw [cellsCode_one, symCode_length] + rw [hsplit, bitOf_append_right (by omega), hlen1, + show 2 * j + o - 2 * j = o from by omega, bitOf_append_left (by omega), + cellsCode_one] + +/-- A padded block of exactly the ruler's width is the block itself. -/ +private theorem padTo_of_length_eq {r x : List Bool} (h : x.length = r.length) : + padTo r x = x := by + rw [padTo_eq_append r x h.le, h, Nat.sub_self, List.replicate_zero, List.append_nil] + +/-- The aligned window of a rewound tape is its right half-block. -/ +theorem drop_pairCode_rewound (W : β„•) (t : Tape) : + (pairCode W { head := 0, cells := t.cells }).drop (blockRuler W).length + = cellsCode t 0 (W + 1) := by + rw [drop_pairCode, rightCode] + refine padTo_of_length_eq ?_ + rw [cellsCode_length, blockRuler_length, blockWidth] + rfl + +/-- **Reading the output off an aligned window.** -/ +theorem output_of_cellsCode {W : β„•} (t : Tape) (y : List Bool) + (hy : t.HasOutput y) (hyW : y.length + 1 ≀ W) : + (cellBits 3 (cellsCode t 0 (W + 1)) W).take + (runTrue (cellBits 2 (cellsCode t 0 (W + 1)) W) W).length = y := by + set u := cellsCode t 0 (W + 1) with hu + -- Each cell's two bits, read out of the window. + have hcell : βˆ€ (i : β„•), i < W β†’ βˆ€ o < 2, + bitOf u (2 * i + (2 + o)) = bitOf (symCode (t.cells (i + 1))) o := by + intro i hi o ho + rw [hu, show 2 * i + (2 + o) = 2 * (i + 1) + o from by omega, + bitOf_cellsCode t (by omega) ho] + have hflag : βˆ€ i < W, bitOf (cellBits 2 u W) i + = bitOf (symCode (t.cells (i + 1))) 0 := by + intro i hi + rw [bitOf_eq_getElem (by rw [cellBits_length]; exact hi), + ← Option.some_inj, ← List.getElem?_eq_getElem, cellBits_getElem? 2 u W i hi, + Option.some_inj] + exact hcell i hi 0 (by omega) + have hbit : βˆ€ i < W, bitOf (cellBits 3 u W) i + = bitOf (symCode (t.cells (i + 1))) 1 := by + intro i hi + rw [bitOf_eq_getElem (by rw [cellBits_length]; exact hi), + ← Option.some_inj, ← List.getElem?_eq_getElem, cellBits_getElem? 3 u W i hi, + Option.some_inj] + have := hcell i hi 1 (by omega) + rwa [show 2 * i + (2 + 1) = 2 * i + 3 from by omega] at this + -- The data flags are `true` exactly on the output. + have hlen : (runTrue (cellBits 2 u W) W).length = y.length := by + have h1 : βˆ€ i < y.length, bitOf (cellBits 2 u W) i = true := by + intro i hi + rw [hflag i (by omega), hy.1 i hi] + cases y[i] <;> rfl + have h2 : bitOf (cellBits 2 u W) y.length = false := by + rw [hflag y.length (by omega), hy.2] + rfl + rw [runTrue_length h1 h2 W] + omega + rw [hlen] + refine List.ext_getElem (by rw [List.length_take, cellBits_length]; omega) ?_ + intro i h1 h2 + rw [List.getElem_take] + have hiy : i < y.length := by + rwa [List.length_take, cellBits_length, min_eq_left (by omega : y.length ≀ W)] at h1 + rw [← bitOf_eq_getElem (by rw [cellBits_length]; omega), hbit i (by omega), + hy.1 i hiy] + cases hb : y[i] <;> rfl + +/-! ## The whole simulation + +Everything above, wired together: a clock long enough to run the machine to a +halt and to rewind the output head, a first iteration that runs the machine, a +second that rewinds, and the extraction. -/ + +private theorem length_flatten_replicate (u : List Bool) : + βˆ€ n : β„•, (List.replicate n u).flatten.length = n * u.length := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [List.replicate_succ, List.flatten_cons, List.length_append, ih] + ring + +theorem initFn_length (tm : TM k) (R x : List Bool) : + (initFn tm R x).length = (2 * (k + 2) + 1) * R.length := by + rw [initFn] + simp only [List.length_append, padTo_length, length_flatten_replicate] + ring + +/-- **A polynomial bound with room for the clock's other duties**: the clock has +to outlast the machine, cover the input, and be wide enough for the state code. -/ +private theorem exists_clock_bound (tm : TM k) {T : β„• β†’ β„•} {S D : β„•} + (hSD : βˆ€ n, T n ≀ S * (n + 1) ^ D) : + βˆƒ C E : β„•, βˆ€ n : β„•, T n + n + Fintype.card tm.Q + 2 ≀ C * (n + 1) ^ E := by + refine ⟨S + Fintype.card tm.Q + 2, max D 1, fun n => ?_⟩ + have h1 : T n ≀ S * (n + 1) ^ max D 1 := + le_trans (hSD n) + (Nat.mul_le_mul_left _ (Nat.pow_le_pow_right (by omega) (le_max_left _ _))) + have h2 : n + 1 ≀ (n + 1) ^ max D 1 := Nat.le_self_pow (by omega) _ + have h3 : n + Fintype.card tm.Q + 2 ≀ (Fintype.card tm.Q + 2) * (n + 1) := by + have : 1 * n ≀ (Fintype.card tm.Q + 2) * n := Nat.mul_le_mul_right _ (by omega) + rw [Nat.mul_add, Nat.mul_one] + omega + calc T n + n + Fintype.card tm.Q + 2 + ≀ S * (n + 1) ^ max D 1 + (Fintype.card tm.Q + 2) * (n + 1) := by omega + _ ≀ S * (n + 1) ^ max D 1 + (Fintype.card tm.Q + 2) * (n + 1) ^ max D 1 := + Nat.add_le_add_left (Nat.mul_le_mul_left _ h2) _ + _ = (S + Fintype.card tm.Q + 2) * (n + 1) ^ max D 1 := by ring + +/-! ### The three stages, as functions of the clock + +The clock string `u` fixes the encoded window: the ruler is `2|u|` bits wide, so +the window is `W = |u| - 1` cells and `u.tail` is a ruler of exactly `W` bits. -/ + +/-- The block ruler belonging to a clock value. -/ +def clockRuler (u : List Bool) : List Bool := List.replicate (u ++ u).length false + +theorem clockRuler_eq {u : List Bool} (h : 1 ≀ u.length) : + clockRuler u = blockRuler (u.length - 1) := by + rw [clockRuler, blockRuler, blockWidth] + congr 1 + rw [List.length_append] + omega + +theorem clockRulerFn {n : β„•} {gu : (Fin n β†’ List Bool) β†’ List Bool} (hu : Cobham gu) : + Cobham fun w : Fin n β†’ List Bool => clockRuler (gu w) := + (zeroBlockFn (appendFn hu hu)).of_eq fun _ => rfl + +/-- Stage one: the encoding after running the machine to a halt. -/ +noncomputable def runFn (tm : TM k) (u x : List Bool) : List Bool := + (stepFn tm (clockRuler u))^[u.tail.length] (initFn tm (clockRuler u) x) + +/-- Stage two: the output tape's two half-blocks, head rewound to cell `0`. -/ +noncomputable def outPairFn (tm : TM k) (u x : List Bool) : List Bool := + (rewindFn (clockRuler u))^[u.length] + (blockAt (clockRuler u) (runFn tm u x) 3 ++ blockAt (clockRuler u) (runFn tm u x) 4) + +/-- Stage three: the string on the rewound output tape. -/ +noncomputable def simFn (tm : TM k) (u x : List Bool) : List Bool := + (cellBits 3 ((outPairFn tm u x).drop (clockRuler u).length) u.tail.length).take + (runTrue (cellBits 2 ((outPairFn tm u x).drop (clockRuler u).length) u.tail.length) + u.tail.length).length + +/-- The simulated run never leaves its blocks. -/ +theorem iterate_stepFn_length_le (tm : TM k) (R x : List Bool) (n : β„•) : + ((stepFn tm R)^[n] (initFn tm R x)).length ≀ (2 * (k + 2) + 1) * R.length := by + induction n with + | zero => exact (initFn_length tm R x).le + | succ n ih => rw [Function.iterate_succ_apply']; exact stepFn_length_le tm R _ ih + +/-- The rewind never leaves its two blocks. -/ +theorem iterate_rewindFn_length_le (R z : List Bool) (hz : z.length ≀ 2 * R.length) + (n : β„•) : ((rewindFn R)^[n] z).length ≀ 2 * R.length := by + induction n with + | zero => exact hz + | succ n ih => rw [Function.iterate_succ_apply']; exact rewindFn_length_le R _ ih + +private theorem tail_consβ‚‚ (a b : List Bool) : Fin.tail ![a, b] = fun _ => b := by + funext i + rw [Subsingleton.elim i 0] + rfl + +private theorem cons_val_one (s : List Bool) (v : Fin 1 β†’ List Bool) : + (Fin.cons s v : Fin 2 β†’ List Bool) 1 = v 0 := rfl + +private theorem cons_val_zero' (s : List Bool) (v : Fin 1 β†’ List Bool) : + (Fin.cons s v : Fin 2 β†’ List Bool) 0 = s := rfl + +/-- **The whole simulation is in the algebra.** -/ +theorem simFn_mem (tm : TM k) {gu : (Fin 1 β†’ List Bool) β†’ List Bool} + (hu : Cobham gu) : Cobham fun v : Fin 1 β†’ List Bool => simFn tm (gu v) (v 0) := by + have hu2 : Cobham fun w : Fin 2 β†’ List Bool => gu (fun _ => w 1) := + (Cobham.comp hu fun _ : Fin 1 => Cobham.proj 1).of_eq fun _ => rfl + have hu1 : Cobham fun w : Fin 1 β†’ List Bool => gu (fun _ => w 0) := + (Cobham.comp hu fun _ : Fin 1 => Cobham.proj 0).of_eq fun _ => rfl + have huu : βˆ€ w : Fin 1 β†’ List Bool, gu (fun _ => w 0) = gu w := fun w => by + congr 1 + funext i + rw [Subsingleton.elim i 0] + -- Stage one. + have hrun : Cobham fun v : Fin 1 β†’ List Bool => runFn tm (gu v) (v 0) := by + have hstage := + iterFn (e := fun w : Fin 1 β†’ List Bool => + initFn tm (clockRuler (gu (fun _ => w 0))) (w 0)) + (f := fun w : Fin 2 β†’ List Bool => + stepFn tm (clockRuler (gu (fun _ => w 1))) (w 0)) + (j := fun w : Fin 2 β†’ List Bool => + (List.replicate (2 * (k + 2) + 1) + (clockRuler (gu (fun _ => w 1)))).flatten) + (initFn_mem tm (clockRulerFn hu1) (Cobham.proj 0)) + (stepFn_mem tm (clockRulerFn hu2) (Cobham.proj 0)) + (repeatFn (clockRulerFn hu2) _) ?_ + Β· refine (compβ‚‚ hstage (tailFn hu1) (Cobham.proj 0)).of_eq fun v => ?_ + simp only [tail_consβ‚‚, cons_val_one, cons_val_zero', Matrix.cons_val_zero] + rw [runFn, huu] + Β· intro c v + have := iterate_stepFn_length_le tm (clockRuler (gu fun _ => v 0)) (v 0) c.length + rw [length_flatten_replicate] + exact this + -- Stage two. + have hpair : Cobham fun v : Fin 1 β†’ List Bool => outPairFn tm (gu v) (v 0) := by + have hstage := + iterFn (e := fun w : Fin 1 β†’ List Bool => + blockAt (clockRuler (gu (fun _ => w 0))) (runFn tm (gu (fun _ => w 0)) (w 0)) 3 + ++ blockAt (clockRuler (gu (fun _ => w 0))) + (runFn tm (gu (fun _ => w 0)) (w 0)) 4) + (f := fun w : Fin 2 β†’ List Bool => + rewindFn (clockRuler (gu (fun _ => w 1))) (w 0)) + (j := fun w : Fin 2 β†’ List Bool => + clockRuler (gu (fun _ => w 1)) ++ clockRuler (gu (fun _ => w 1))) + (appendFn (blockFn (clockRulerFn hu1) (hrun.of_eq fun v => by rw [huu]) 3) + (blockFn (clockRulerFn hu1) (hrun.of_eq fun v => by rw [huu]) 4)) + (rewindFn_mem (clockRulerFn hu2) (Cobham.proj 0)) + (appendFn (clockRulerFn hu2) (clockRulerFn hu2)) ?_ + Β· refine (compβ‚‚ hstage hu1 (Cobham.proj 0)).of_eq fun v => ?_ + simp only [tail_consβ‚‚, cons_val_one, cons_val_zero', Matrix.cons_val_zero] + rw [outPairFn, huu] + Β· intro c v + simp only [cons_val_one, cons_val_zero'] + have hb : ((rewindFn (clockRuler (gu fun _ => v 0)))^[c.length] + (blockAt (clockRuler (gu fun _ => v 0)) (runFn tm (gu fun _ => v 0) (v 0)) 3 ++ + blockAt (clockRuler (gu fun _ => v 0)) + (runFn tm (gu fun _ => v 0) (v 0)) 4)).length + ≀ 2 * (clockRuler (gu fun _ => v 0)).length := by + refine iterate_rewindFn_length_le _ _ ?_ _ + rw [List.length_append, blockAt, blockAt, List.length_take, List.length_take] + omega + rw [List.length_append] + exact le_trans hb (by omega) + -- Stage three. + have hdrop : Cobham fun v : Fin 1 β†’ List Bool => + (outPairFn tm (gu v) (v 0)).drop (clockRuler (gu v)).length := + dropFn (clockRulerFn hu) hpair + exact (takeFn (runTrueFn (tailFn hu) (cellBitsFn 2 (tailFn hu) hdrop)) + (cellBitsFn 3 (tailFn hu) hdrop)).of_eq fun v => by rw [simFn] + +/-- **The simulation computes the machine's function.** Provided the clock +outlasts the run, covers the input and is wide enough for the state code, the +three stages reproduce exactly the string the machine leaves on its output +tape. -/ +theorem simFn_eq (tm : TM k) {T : β„• β†’ β„•} {f : List Bool β†’ List Bool} + (hcomp : tm.ComputesInTime f T) (u x : List Bool) + (hlen : T x.length + x.length + Fintype.card tm.Q + 2 ≀ u.length) : + simFn tm u x = f x := by + have hu1 : 1 ≀ u.length := by omega + have hR : clockRuler u = blockRuler (u.length - 1) := clockRuler_eq hu1 + have htail : u.tail.length = u.length - 1 := List.length_tail + have hq : Fintype.card tm.Q ≀ blockWidth (u.length - 1) := by rw [blockWidth]; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := hcomp x + have hylen : (f x).length ≀ t := TM.output_length_le_of_reachesIn hreach hout + have hrunW : TM.runCfg tm (tm.initCfg x) (u.length - 1) = c' := by + rw [show u.length - 1 = t + (u.length - 1 - t) from by omega, TM.runCfg_add, + TM.runCfg_of_reachesIn tm hreach, TM.runCfg_of_halted tm hhalt] + have hrun : runFn tm u x = cfgCode (u.length - 1) c' := by + rw [runFn, hR, htail, initFn_eq tm _ x (by omega), + iterate_stepFn tm _ x hq _ le_rfl, hrunW] + obtain ⟨hinv, hWh⟩ := cfgTapes_runCfg_inv tm x (u.length - 1) (u.length - 1) le_rfl + rw [hrunW] at hinv hWh + have hmem : c'.output ∈ cfgTapes c' := by simp [cfgTapes] + have hstart : c'.output.StartInvariant := hinv _ hmem + have hhead : c'.output.head ≀ u.length - 1 := hWh _ hmem + obtain ⟨hb3, hb4⟩ := + blockAt_cfgCode_tape (u.length - 1) c' 1 (by rw [cfgTapes_length]; omega) + have hidx : (cfgTapes c')[1]'(by rw [cfgTapes_length]; omega) = c'.output := rfl + rw [hidx, show 2 * 1 + 1 = 3 from rfl] at hb3 + rw [hidx, show 2 * 1 + 2 = 4 from rfl] at hb4 + have hpair : blockAt (clockRuler u) (runFn tm u x) 3 + ++ blockAt (clockRuler u) (runFn tm u x) 4 = pairCode (u.length - 1) c'.output := by + rw [hrun, hR, hb3, hb4, pairCode] + have hrew : outPairFn tm u x + = pairCode (u.length - 1) { head := 0, cells := c'.output.cells } := by + rw [outPairFn, hpair, hR, iterate_rewindFn c'.output hstart hhead u.length, + rewound c'.output (by omega)] + have hdropeq : (outPairFn tm u x).drop (clockRuler u).length + = cellsCode c'.output 0 (u.length - 1 + 1) := by + rw [hrew, hR, drop_pairCode_rewound] + rw [simFn, htail, hdropeq] + exact output_of_cellsCode c'.output (f x) hout (by omega) + +/-- **The completeness direction, for one machine.** -/ +theorem computes_mem_CobhamFP (tm : TM k) {T : β„• β†’ β„•} {S D : β„•} + (hSD : βˆ€ n, T n ≀ S * (n + 1) ^ D) {f : List Bool β†’ List Bool} + (hcomp : tm.ComputesInTime f T) : CobhamFP f := by + obtain ⟨C, E, hCE⟩ := exists_clock_bound tm hSD + obtain ⟨clk, hclk, hclklen⟩ := exists_pow_clock C E + have hclk1 : Cobham fun w : Fin 1 β†’ List Bool => clk (fun _ => w 0) := + (Cobham.comp hclk fun _ : Fin 1 => Cobham.proj 0).of_eq fun _ => rfl + refine ((simFn_mem tm hclk1).of_eq fun v => ?_ : Cobham fun v : Fin 1 β†’ List Bool => + f (v 0)) + refine simFn_eq tm hcomp _ (v 0) (le_trans (hCE (v 0).length) ?_) + exact hclklen (fun _ => v 0) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean new file mode 100644 index 0000000000..e88d800f78 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean @@ -0,0 +1,466 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# The block-suffix decoder β€” proof internals + +`Cobham.sndBlockTM` scans the doubled payload two bits at a time until the +`[false, true]` separator, then copies the rest of the input to the output. +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Cobham.sndBlock_mem_FP` β€” the suffix decoder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- The suffix decoder: scan doubled payload bits until the `[false, true]` +separator, then copy the remaining input (the suffix `y` of `pair x y`) to the +output. On malformed input it halts with empty output. Computes `sndBlock`. -/ +def sndBlockTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Ξ“.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Ξ“.one => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.zero => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Ξ“.one => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `sndBlockTM`: from `emit` with input cursor on suffix `y` +and output holding `acc`, the machine copies `y` after `acc` and halts. -/ +private theorem sndBlockTM_emit_loop : + βˆ€ (y acc : List Bool) (c : Cfg 0 sndBlockTM.Q), + c.state = ScanPhase.emit β†’ + c.input.HasBinarySuffix y β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ y.length + 1 ∧ sndBlockTM.reachesIn t c c' ∧ sndBlockTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y) := by + intro y + induction y with + | nil => + intro acc c hstate hsuf hpre + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have hout : c.output.read = Ξ“.blank := hpre.read_blank + have houtne : c.output.read β‰  Ξ“.start := by rw [hout]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, ite_eq_right houtne, Tape.move]] + simpa using! hpre + | cons bit y ih => + intro acc c hstate hsuf hpre + have hread : c.input.read = Ξ“.ofBool bit := hsuf.read_cons + have hne : c.input.read β‰  Ξ“.blank := by rw [hread]; cases bit <;> decide + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.emit + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hne, c1] + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [bit]) := by + have hco : (readBackWrite c.input.read).toΞ“ = Ξ“.ofBool bit := by + rw [hread]; cases bit <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΞ“) Dir3.right).HasBinaryPrefix + (acc ++ [bit]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit bit hpre + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih (acc ++ [bit]) c1 rfl hsuf.move_right_cons hpre1 + refine ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, ?_⟩ + rwa [List.append_assoc, List.cons_append, List.nil_append] at hout + +/-- An incomplete final payload bit halts the second-block scanner with empty output. -/ +private theorem sndBlockTM_scan_single + (b : Bool) (c : Cfg 0 sndBlockTM.Q) + (hstate : c.state = ScanPhase.scanA) + (hsuf : c.input.HasBinarySuffix [b]) + (hpre : c.output.HasBinaryPrefix []) : + βˆƒ c' t, t ≀ 2 * [b].length + 2 ∧ sndBlockTM.reachesIn t c c' ∧ + sndBlockTM.halted c' ∧ c'.output.HasOutput (sndBlock [b]) := by + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + cases b with + | false => + -- scanA reads false β†’ scanBfalse; next reads blank β†’ done. + have hread : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have hout1 : c1.output.read = Ξ“.blank := hpre1.read_blank + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, sndBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, ite_eq_right houtne1, Tape.move]] + simpa [sndBlock] using! hpre1.hasOutput + | true => + have hread : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hread, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Ξ“.blank := hsuf1.read_nil + have hout1 : c1.output.read = Ξ“.blank := hpre1.read_blank + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, sndBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, ite_eq_right houtne1, Tape.move]] + simpa [sndBlock] using! hpre1.hasOutput + +/-- The scan phase of `sndBlockTM`: from `scanA` with input cursor on `w`, the +machine parses doubled pairs to the separator and copies the suffix, halting with +output `sndBlock w`. `fuel` bounds the recursion by the input length. -/ +private theorem sndBlockTM_scan_loop : + βˆ€ (fuel : β„•) (w : List Bool), w.length ≀ fuel β†’ βˆ€ (c : Cfg 0 sndBlockTM.Q), + c.state = ScanPhase.scanA β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix [] β†’ + βˆƒ c' t, t ≀ 2 * w.length + 2 ∧ sndBlockTM.reachesIn t c c' ∧ sndBlockTM.halted c' ∧ + c'.output.HasOutput (sndBlock w) := by + intro fuel + induction fuel with + | zero => + intro w hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have hout : c.output.read = Ξ“.blank := hpre.read_blank + have houtne : c.output.read β‰  Ξ“.start := by rw [hout]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, ite_eq_right houtne, Tape.move]] + simpa [sndBlock] using! hpre.hasOutput + | succ fuel ih => + intro w hw c hstate hsuf hpre + -- Halting helper for the malformed / end-of-input branches. + have hout : c.output.read = Ξ“.blank := hpre.read_blank + have houtne : c.output.read β‰  Ξ“.start := by rw [hout]; decide + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, ite_eq_right houtne, Tape.move]] + simpa [sndBlock] using! hpre.hasOutput + | [false] => exact sndBlockTM_scan_single false c hstate hsuf hpre + | [true] => exact sndBlockTM_scan_single true c hstate hsuf hpre + | false :: true :: y => + -- separator: scanA false β†’ scanBfalse β†’ (reads true) β†’ emit; copy y. + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.emit + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read β‰  Ξ“.start := by + rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + sndBlockTM_emit_loop y [] c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (false :: true :: y) = y := by simp [sndBlock, unpair?] + rw [this] + simpa using! hcout.hasOutput + | false :: false :: z => + have hreadA : c.input.read = Ξ“.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (false :: false :: z) = sndBlock z := by + cases h : unpair? z <;> simp [sndBlock, unpair?, h] + rw [this]; exact hcout + | true :: true :: z => + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Ξ“.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read β‰  Ξ“.start := by rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + have hzfuel : z.length ≀ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (true :: true :: z) = sndBlock z := by + cases h : unpair? z <;> simp [sndBlock, unpair?, h] + rw [this]; exact hcout + | true :: false :: rest => + -- malformed: scanA true β†’ scanBtrue β†’ reads false β†’ done, empty output. + have hreadA : c.input.read = Ξ“.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Ξ“.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Ξ“.ofBool false := hsuf1.read_cons + have hout1 : c1.output.read = Ξ“.blank := hpre1.read_blank + have houtne1 : c1.output.read β‰  Ξ“.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, sndBlockTM, hreadB, Ξ“.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, + ite_eq_right houtne1, Tape.move]] + have : sndBlock (true :: false :: rest) = [] := by simp [sndBlock, unpair?] + rw [this]; simpa using! hpre1.hasOutput + +/-- `sndBlock` is polynomial-time, via the `sndBlockTM` scanner. -/ +theorem sndBlock_mem_FP : sndBlock ∈ FP := by + refine ⟨1, 0, sndBlockTM, (fun m => 2 * m + 3), ?_, ?_⟩ + Β· intro z + -- Step 1: skip past β–·, positioning both cursors. + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : sndBlockTM.step (sndBlockTM.initCfg z) = some c1 := by + simp [TM.step, sndBlockTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + sndBlockTM_scan_loop z.length z le_rfl c1 rfl hsuf hpre + exact ⟨c', t + 1, by show t + 1 ≀ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, hcout⟩ + Β· have hn : (fun m : β„• => 2 * m) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using! (BigO.refl (fun m : β„• => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean new file mode 100644 index 0000000000..24424d77da --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean @@ -0,0 +1,756 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Algebra +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Internal.Encoding +public import Mathlib.Data.Fintype.Prod + +/-! +# The encoded machine step, inside the algebra β€” proof internals + +`Complexitylib.Classes.P.Cobham.Internal.Encoding` shows that one machine step +acts on an encoded configuration blockwise, via `tapeStepBlocks`. This module +shows the other half: that `tapeStepBlocks` is *in Cobham's algebra* once the +written symbol and the direction are fixed constants β€” which they are inside one +branch of `Cobham.tableFn`, since the branch is selected by the (state, +read-symbols) key. + +Each half-block of the successor is a short composition of toolkit members: +`Cobham.takeFn` and `Cobham.dropFn` at width two, `Cobham.appendFn`, +`Cobham.const`, and one `Cobham.padFn` to restore the block width. + +## Main results + +- `Complexity.Cobham.tapeStepBlocksFst`, `Complexity.Cobham.tapeStepBlocksSnd` β€” + both half-blocks of a stepped tape are in the algebra +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The two-bit ruler: dropping or taking `2` is `dropFn`/`takeFn` against this +constant. -/ +private def twoRuler : List Bool := [false, false] + +/-- **The left half-block after a step is in the algebra.** For a fixed direction +and written symbol it is one of: the old left block unchanged (stay), the symbol +prepended (right), or two bits dropped (left). -/ +theorem tapeStepBlocksFst {n : β„•} (s : Ξ“) (d : Dir3) + {gR gL gRt : (Fin n β†’ List Bool) β†’ List Bool} + (hR : Cobham gR) (hL : Cobham gL) (_hRt : Cobham gRt) : + Cobham fun v : Fin n β†’ List Bool => + (tapeStepBlocks (gR v) s d (gL v) (gRt v)).1 := by + cases d + Β· exact (padFn hR (dropFn (Cobham.const twoRuler) hL)).of_eq fun _ => rfl + Β· exact (padFn hR (appendFn (Cobham.const (symCode s)) hL)).of_eq fun _ => rfl + Β· exact hL.of_eq fun _ => rfl + +/-- **The right half-block after a step is in the algebra.** For a fixed +direction and written symbol it is the old right block with its leading symbol +replaced (stay), consumed (right), or pushed back together with the nearest left +symbol (left). -/ +theorem tapeStepBlocksSnd {n : β„•} (s : Ξ“) (d : Dir3) + {gR gL gRt : (Fin n β†’ List Bool) β†’ List Bool} + (hR : Cobham gR) (hL : Cobham gL) (hRt : Cobham gRt) : + Cobham fun v : Fin n β†’ List Bool => + (tapeStepBlocks (gR v) s d (gL v) (gRt v)).2 := by + cases d + Β· exact (padFn hR (appendFn + (appendFn (takeFn (Cobham.const twoRuler) hL) (Cobham.const (symCode s))) + (dropFn (Cobham.const twoRuler) hRt))).of_eq fun _ => rfl + Β· exact (padFn hR (dropFn (Cobham.const twoRuler) hRt)).of_eq fun _ => rfl + Β· exact (padFn hR (appendFn (Cobham.const (symCode s)) + (dropFn (Cobham.const twoRuler) hRt))).of_eq fun _ => rfl + +/-- **Tape `j`'s two half-blocks, read out of an encoded configuration.** Block +`0` is the state, so tape `j` occupies blocks `2j+1` and `2j+2` β€” exactly the +indices `tapesStepFn` addresses with `Cobham.blockFn`. -/ +theorem blockAt_cfgCode_tape {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (j : β„•) (hj : j < (cfgTapes c).length) : + blockAt (blockRuler W) (cfgCode W c) (2 * j + 1) + = padTo (blockRuler W) (leftCode (cfgTapes c)[j]) ∧ + blockAt (blockRuler W) (cfgCode W c) (2 * j + 2) + = padTo (blockRuler W) (rightCode (cfgTapes c)[j] W) := by + have hj' : j < k + 2 := by rwa [cfgTapes_length] at hj + have hblocks : (tapesBlocks W (cfgTapes c)).length = 2 * (k + 2) := by + rw [tapesBlocks_length, cfgTapes_length] + obtain ⟨h1, h2⟩ := getElem?_tapesBlocks W (cfgTapes c) j + rw [List.getElem?_eq_getElem (by omega), List.getElem?_eq_getElem hj] at h1 h2 + simp only [Option.map_some] at h1 h2 + replace h1 := Option.some_inj.mp h1 + replace h2 := Option.some_inj.mp h2 + -- Work through `getElem?` so no dependent index proofs appear under a rewrite. + have key1 : (cfgBlocks W c)[2 * j + 1]? = (tapesBlocks W (cfgTapes c))[2 * j]? := by + rw [cfgBlocks_eq]; exact List.getElem?_cons_succ + have key2 : (cfgBlocks W c)[2 * j + 2]? = (tapesBlocks W (cfgTapes c))[2 * j + 1]? := by + rw [cfgBlocks_eq]; exact List.getElem?_cons_succ + rw [List.getElem?_eq_getElem (by rw [cfgBlocks_length]; omega), + List.getElem?_eq_getElem (by omega)] at key1 + rw [List.getElem?_eq_getElem (by rw [cfgBlocks_length]; omega), + List.getElem?_eq_getElem (by omega)] at key2 + exact ⟨by rw [blockAt_cfgCode W c (2 * j + 1) (by rw [cfgBlocks_length]; omega), + Option.some_inj.mp key1, h1], + by rw [blockAt_cfgCode W c (2 * j + 2) (by rw [cfgBlocks_length]; omega), + Option.some_inj.mp key2, h2]⟩ + +/-! ## The transition key + +The key is the state together with the symbol under every head. Reading it out of +an encoding is one `takeFn` per field: the state block truncated to `|Q|` bits, +then the first two bits of each tape's right half-block. -/ + +/-- The read symbols of the tapes from index `j` on, `m` of them. -/ +def readsFn (R : List Bool) (m j : β„•) (z : List Bool) : List Bool := + match m with + | 0 => [] + | m + 1 => (blockAt R z (2 * j + 2)).take 2 ++ readsFn R m (j + 1) z + +/-- The transition key, read out of an encoded configuration. -/ +def keyFn (R : List Bool) (q m : β„•) (z : List Bool) : List Bool := + (blockAt R z 0).take q ++ readsFn R m 0 z + +/-- **Reading the head symbols is in the algebra.** -/ +theorem readsFn_mem {n : β„•} (m j : β„•) + {gR gz : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => readsFn (gR v) m j (gz v) := by + induction m generalizing j with + | zero => exact Cobham.empty.of_eq fun _ => rfl + | succ m ih => + exact (appendFn (takeFn (Cobham.const twoRuler) (blockFn hR hz (2 * j + 2))) + (ih (j + 1))).of_eq fun _ => rfl + +/-- **Reading the transition key is in the algebra.** -/ +theorem keyFn_mem {n : β„•} (q m : β„•) + {gR gz : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => keyFn (gR v) q m (gz v) := + (appendFn (takeFn (Cobham.const (List.replicate q false)) (blockFn hR hz 0)) + (readsFn_mem m 0 hR hz)).of_eq fun _ => by rw [keyFn, List.length_replicate] + +/-- **The extracted key is the transition key.** -/ +theorem readsFn_eq {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) : + βˆ€ (m j : β„•), j + m = (cfgTapes c).length β†’ + readsFn (blockRuler W) m j (cfgCode W c) + = ((cfgTapes c).drop j).flatMap fun t => symCode t.read := by + intro m + induction m with + | zero => + intro j hj + have : (cfgTapes c).drop j = [] := by + rw [List.drop_eq_nil_iff]; omega + rw [readsFn, this, List.flatMap_nil] + | succ m ih => + intro j hj + have hjlt : j < (cfgTapes c).length := by omega + obtain ⟨_, hRt⟩ := blockAt_cfgCode_tape W c j hjlt + have hmem : (cfgTapes c)[j] ∈ cfgTapes c := List.getElem_mem hjlt + rw [readsFn, hRt, List.drop_eq_getElem_cons hjlt, List.flatMap_cons, + take_padTo _ _ 2 (by rw [rightCode_length]; have := hW _ hmem; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth] + have := hW _ hmem; omega), + take_rightCode _ (hW _ hmem), ih (j + 1) (by omega)] + +/-- The whole key, read out of an encoded configuration. -/ +theorem keyFn_eq {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) (hq : Fintype.card Q ≀ blockWidth W) + (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) : + keyFn (blockRuler W) (Fintype.card Q) (k + 2) (cfgCode W c) = keyCode c := by + rw [keyFn, state_of_cfgCode W c hq, + readsFn_eq W c hW (k + 2) 0 (by rw [cfgTapes_length]; omega), List.drop_zero, + keyCode] + +/-! ## Lifting across all the tapes + +A machine has a fixed number of tapes, so stepping all of them is a *finite* +composition β€” the recursion below is at the meta level, over the list of +per-tape actions, not inside the algebra. Tape `j` occupies blocks `2j+1` and +`2j+2` (block `0` is the state), which `Cobham.blockFn` addresses. -/ + +/-- The successor's tape blocks for one transition-table branch, as a function of +the predecessor's encoding: tape `j`'s two half-blocks, stepped, concatenated. -/ +def tapesStepFn (R : List Bool) (acts : List (Ξ“ Γ— Dir3)) (j : β„•) (z : List Bool) : + List Bool := + match acts with + | [] => [] + | a :: rest => + (tapeStepBlocks R a.1 a.2 (blockAt R z (2 * j + 1)) + (blockAt R z (2 * j + 2))).1 ++ + ((tapeStepBlocks R a.1 a.2 (blockAt R z (2 * j + 1)) + (blockAt R z (2 * j + 2))).2 ++ tapesStepFn R rest (j + 1) z) + +/-- **Stepping every tape is in the algebra.** -/ +theorem tapesStepFn_mem {n : β„•} (acts : List (Ξ“ Γ— Dir3)) (j : β„•) + {gR gz : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => tapesStepFn (gR v) acts j (gz v) := by + induction acts generalizing j with + | nil => exact Cobham.empty.of_eq fun _ => rfl + | cons a rest ih => + exact (appendFn + (tapeStepBlocksFst a.1 a.2 hR (blockFn hR hz (2 * j + 1)) + (blockFn hR hz (2 * j + 2))) + (appendFn + (tapeStepBlocksSnd a.1 a.2 hR (blockFn hR hz (2 * j + 1)) + (blockFn hR hz (2 * j + 2))) + (ih (j + 1)))).of_eq fun _ => rfl + +/-- **The algebra-side tape step computes the machine-side one.** Reading the +half-blocks out of the encoding (`blockAt`) gives exactly the tapes' own +half-blocks, so `tapesStepFn` reproduces the blockwise map of +`tapesBlocks_tapesStep`. -/ +theorem tapesStepFn_eq {k : β„•} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : β„•) (c : Cfg k Q) : + βˆ€ (acts : List (Ξ“ Γ— Dir3)) (j : β„•), j + acts.length ≀ (cfgTapes c).length β†’ + tapesStepFn (blockRuler W) acts j (cfgCode W c) + = ((List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) + acts ((cfgTapes c).drop j)).flatten).flatten := by + intro acts + induction acts with + | nil => intro j _; rfl + | cons a rest ih => + intro j hj + have hjlt : j < (cfgTapes c).length := by + simp only [List.length_cons] at hj; omega + obtain ⟨hL, hRt⟩ := blockAt_cfgCode_tape W c j hjlt + rw [List.drop_eq_getElem_cons hjlt, List.zipWith_cons_cons, List.flatten_cons, + List.flatten_append, tapesStepFn, hL, hRt, + ih (j + 1) (by simp only [List.length_cons] at hj; omega)] + simp [List.append_assoc] + +/-- One whole branch of the transition table: the new state block (a constant) +followed by every tape stepped. -/ +def branchFn (R q' : List Bool) (acts : List (Ξ“ Γ— Dir3)) (z : List Bool) : + List Bool := + padTo R q' ++ tapesStepFn R acts 0 z + +/-- **A transition-table branch is in the algebra.** With the branch fixed, the +new state code and every tape's write and direction are constants, so the whole +successor configuration is a finite composition of toolkit members. -/ +theorem branchFn_mem {n : β„•} (q' : List Bool) (acts : List (Ξ“ Γ— Dir3)) + {gR gz : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => branchFn (gR v) q' acts (gz v) := + (appendFn (padFn hR (Cobham.const q')) (tapesStepFn_mem acts 0 hR hz)).of_eq + fun _ => rfl + +/-- **The join.** For a fixed transition-table branch, the algebra-side successor +`branchFn` β€” built purely from `takeFn`/`dropFn`/`appendFn`/`padFn`/`const` β€” *is* +the encoding of the machine's successor configuration. + +This is the point where the two halves of the development meet: the machine side +(`cfgBlocks_step`, from the six write-and-move lemmas) and the algebra side +(`tapesStepFn`, in the class by `branchFn_mem`). -/ +theorem branchFn_eq {k : β„•} (tm : TM k) {c c' : Cfg k tm.Q} {W : β„•} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : βˆ€ i, (c.work i).StartInvariant) + (hgood : List.Forallβ‚‚ (fun (a : Ξ“ Γ— Dir3) (t : Tape) => + (t.head = 0 β†’ a.1 = t.cells t.head) ∧ + (a.2 β‰  Dir3.right β†’ t.head β‰  0) ∧ t.head ≀ W) (stepActs tm c) (cfgTapes c)) : + branchFn (blockRuler W) (stateCode c'.state) (stepActs tm c) (cfgCode W c) + = cfgCode W c' := by + rw [branchFn, tapesStepFn_eq W c (stepActs tm c) 0 (by simpa using hgood.length_eq.le)] + conv_rhs => rw [cfgCode, cfgBlocks_step tm h hout hwork hgood, List.flatten_cons] + simp + +/-! ## The whole transition table + +A machine has finitely many (state, read-symbols) keys, so the transition +function is a finite table: one `branchFn` per key, selected by matching the key +read out of the encoding against the key's constant pattern. -/ + +/-- The transition table's index set: every (state, read-symbols) pair. -/ +noncomputable def stepEntries {k : β„•} (tm : TM k) : + List (tm.Q Γ— (Fin (k + 2) β†’ Ξ“)) := + (Finset.univ : Finset (tm.Q Γ— (Fin (k + 2) β†’ Ξ“))).toList + +/-- Every key is in the table. -/ +theorem mem_stepEntries {k : β„•} (tm : TM k) (p : tm.Q Γ— (Fin (k + 2) β†’ Ξ“)) : + p ∈ stepEntries tm := Finset.mem_toList.mpr (Finset.mem_univ p) + +/-- The branch a transition key selects. A halting key stands still: the machine +has stopped, but the *simulation* runs for a fixed polynomial number of steps, so +the encoding has to be a fixed point from then on. -/ +noncomputable def stepBranch {k : β„•} (tm : TM k) (R : List Bool) + (p : tm.Q Γ— (Fin (k + 2) β†’ Ξ“)) (z : List Bool) : List Bool := + if p.1 = tm.qhalt then z + else branchFn R (stateCode (stepStateOf tm p.1 p.2)) (stepActsOf tm p.1 p.2) z + +theorem stepBranch_halt {k : β„•} (tm : TM k) (R : List Bool) + {p : tm.Q Γ— (Fin (k + 2) β†’ Ξ“)} (h : p.1 = tm.qhalt) (z : List Bool) : + stepBranch tm R p z = z := ite_eq_left h + +theorem stepBranch_step {k : β„•} (tm : TM k) (R : List Bool) + {p : tm.Q Γ— (Fin (k + 2) β†’ Ξ“)} (h : p.1 β‰  tm.qhalt) (z : List Bool) : + stepBranch tm R p z + = branchFn R (stateCode (stepStateOf tm p.1 p.2)) (stepActsOf tm p.1 p.2) z := + ite_eq_right h + +/-- **One machine step, on encodings.** The table dispatches on the key read out +of the encoding and applies that key's branch. -/ +noncomputable def stepFn {k : β„•} (tm : TM k) (R z : List Bool) : List Bool := + (stepEntries tm).foldr + (fun p acc => + caseBitβ‚€ (matchPrefix (keyPattern p) (keyFn R (Fintype.card tm.Q) (k + 2) z)) + (stepBranch tm R p z) acc) + [] + +/-- **The encoded step is in the algebra.** -/ +theorem stepFn_mem {n k : β„•} (tm : TM k) + {gR gz : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => stepFn tm (gR v) (gz v) := by + refine (tableFn (keyFn_mem (Fintype.card tm.Q) (k + 2) hR hz) Cobham.empty + ((stepEntries tm).map fun p => + (keyPattern p, fun v : Fin n β†’ List Bool => stepBranch tm (gR v) p (gz v))) + ?_).of_eq fun v => ?_ + Β· rintro p hp + obtain ⟨q, -, rfl⟩ := List.mem_map.mp hp + by_cases hh : q.1 = tm.qhalt + Β· exact hz.of_eq fun v => (stepBranch_halt tm (gR v) hh (gz v)).symm + Β· exact (branchFn_mem _ _ hR hz).of_eq fun v => + (stepBranch_step tm (gR v) hh (gz v)).symm + Β· rw [stepFn, List.foldr_map] + +/-- **The table selects the configuration's own branch.** The key read out of the +encoding is the configuration's key, and by `keyPattern_injective` no other +entry's pattern matches it. -/ +theorem stepFn_apply {k : β„•} (tm : TM k) (c : Cfg k tm.Q) {W : β„•} + (hq : Fintype.card tm.Q ≀ blockWidth W) (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) : + stepFn tm (blockRuler W) (cfgCode W c) + = stepBranch tm (blockRuler W) (c.state, cfgReads c) (cfgCode W c) := by + have hkey := foldr_table_eq (keyCode c) [] + (stepBranch tm (blockRuler W) (c.state, cfgReads c) (cfgCode W c)) + ((stepEntries tm).map fun p => + (keyPattern p, stepBranch tm (blockRuler W) p (cfgCode W c))) ?_ ?_ + Β· rw [List.foldr_map] at hkey + rw [stepFn, keyFn_eq W c hq hW] + exact hkey + Β· refine ⟨_, List.mem_map_of_mem (mem_stepEntries tm (c.state, cfgReads c)), ?_⟩ + show keyPattern (c.state, cfgReads c) <+: keyCode c + rw [← keyCode_eq] + Β· rintro q hq' hpre + obtain ⟨p, -, rfl⟩ := List.mem_map.mp hq' + replace hpre : keyPattern p <+: keyCode c := hpre + have hlen : (keyPattern p).length = (keyCode c).length := by simp + have hp : p = (c.state, cfgReads c) := + keyPattern_injective (by rw [hpre.eq_of_length hlen, keyCode_eq]) + rw [hp] + +/-- **The encoded step computes the machine step.** -/ +theorem stepFn_eq {k : β„•} (tm : TM k) {c c' : Cfg k tm.Q} {W : β„•} + (h : tm.step c = some c') (hq : Fintype.card tm.Q ≀ blockWidth W) + (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) + (hout : c.output.StartInvariant) (hwork : βˆ€ i, (c.work i).StartInvariant) + (hgood : List.Forallβ‚‚ (fun (a : Ξ“ Γ— Dir3) (t : Tape) => + (t.head = 0 β†’ a.1 = t.cells t.head) ∧ + (a.2 β‰  Dir3.right β†’ t.head β‰  0) ∧ t.head ≀ W) (stepActs tm c) (cfgTapes c)) : + stepFn tm (blockRuler W) (cfgCode W c) = cfgCode W c' := by + rw [stepFn_apply tm c hq hW, + stepBranch_step tm _ (TM.state_ne_qhalt_of_step h), ← step_state_eq tm h, + ← stepActs_eq_stepActsOf] + exact branchFn_eq tm h hout hwork hgood + +/-- **A halted encoding is a fixed point.** -/ +theorem stepFn_halted {k : β„•} (tm : TM k) {c : Cfg k tm.Q} {W : β„•} + (h : c.state = tm.qhalt) (hq : Fintype.card tm.Q ≀ blockWidth W) + (hW : βˆ€ t ∈ cfgTapes c, t.head ≀ W) : + stepFn tm (blockRuler W) (cfgCode W c) = cfgCode W c := by + rw [stepFn_apply tm c hq hW, stepBranch_halt tm _ h] + +/-! ## Length bounds + +`Cobham.iterFn` needs one polynomial bound covering *every* iterate, including +the ones reached from junk inputs. Both simulated steps keep an encoding inside a +fixed number of blocks, which is all the bound needs. -/ + +/-- Total dispatch returns one of its two branches. -/ +private theorem caseBitβ‚€_cases (s x y : List Bool) : + caseBitβ‚€ s x y = x ∨ caseBitβ‚€ s x y = y := by + cases s with + | nil => exact Or.inr rfl + | cons b s => cases b <;> simp + +/-- Both half-blocks of a stepped tape fit in one block each. -/ +private theorem tapeStepBlocks_length_le (R : List Bool) (s : Ξ“) (d : Dir3) + (L Rt : List Bool) (hL : L.length ≀ R.length) : + (tapeStepBlocks R s d L Rt).1.length ≀ R.length ∧ + (tapeStepBlocks R s d L Rt).2.length ≀ R.length := by + cases d <;> exact ⟨by simp [tapeStepBlocks, hL], by simp [tapeStepBlocks]⟩ + +theorem tapesStepFn_length_le (R : List Bool) : + βˆ€ (acts : List (Ξ“ Γ— Dir3)) (j : β„•) (z : List Bool), + (tapesStepFn R acts j z).length ≀ 2 * acts.length * R.length := by + intro acts + induction acts with + | nil => intro j z; simp [tapesStepFn] + | cons a rest ih => + intro j z + obtain ⟨h1, h2⟩ := tapeStepBlocks_length_le R a.1 a.2 + (blockAt R z (2 * j + 1)) (blockAt R z (2 * j + 2)) + (by rw [blockAt]; simp) + have := ih (j + 1) z + have hexp : 2 * (rest.length + 1) * R.length + = 2 * rest.length * R.length + (R.length + R.length) := by ring + rw [tapesStepFn, List.length_append, List.length_append, List.length_cons, hexp] + omega + +theorem branchFn_length_le (R q' : List Bool) (acts : List (Ξ“ Γ— Dir3)) (z : List Bool) : + (branchFn R q' acts z).length ≀ (2 * acts.length + 1) * R.length := by + have := tapesStepFn_length_le R acts 0 z + have hexp : (2 * acts.length + 1) * R.length + = 2 * acts.length * R.length + R.length := by ring + rw [branchFn, List.length_append, padTo_length, hexp] + omega + +@[simp] theorem stepActsOf_length {k : β„•} (tm : TM k) (q : tm.Q) + (syms : Fin (k + 2) β†’ Ξ“) : (stepActsOf tm q syms).length = k + 2 := by + rw [stepActsOf] + simp + +/-- **An encoded configuration stays within its blocks.** -/ +theorem stepFn_length_le {k : β„•} (tm : TM k) (R z : List Bool) + (hz : z.length ≀ (2 * (k + 2) + 1) * R.length) : + (stepFn tm R z).length ≀ (2 * (k + 2) + 1) * R.length := by + rw [stepFn] + induction stepEntries tm with + | nil => simp + | cons p rest ih => + rw [List.foldr_cons] + rcases caseBitβ‚€_cases (matchPrefix (keyPattern p) + (keyFn R (Fintype.card tm.Q) (k + 2) z)) + (stepBranch tm R p z) _ with h | h + Β· rw [h] + by_cases hh : p.1 = tm.qhalt + Β· rw [stepBranch_halt tm R hh]; exact hz + Β· rw [stepBranch_step tm R hh] + have := branchFn_length_le R (stateCode (stepStateOf tm p.1 p.2)) + (stepActsOf tm p.1 p.2) z + rwa [stepActsOf_length] at this + Β· rw [h]; exact ih + +/-! ## Rewinding the output head + +The encoding splits a tape at its head, so reading a tape off an encoding is +easy only when the head sits at cell `0` β€” then the left half is empty and the +right half is the whole tape, in order. Driving the head back to cell `0` is a +*separate* iteration, of a step that moves one cell left and writes nothing. + +It is stated on one tape's pair of half-blocks rather than on a whole +configuration: after the simulation only the output tape matters, and a pair of +blocks splits with one `takeFn`/`dropFn`. -/ + +/-- One tape as its two padded half-blocks, concatenated. -/ +def pairCode (W : β„•) (t : Tape) : List Bool := + padTo (blockRuler W) (leftCode t) ++ padTo (blockRuler W) (rightCode t W) + +theorem take_pairCode (W : β„•) (t : Tape) : + (pairCode W t).take (blockRuler W).length = padTo (blockRuler W) (leftCode t) := + List.take_left' (by simp) + +theorem drop_pairCode (W : β„•) (t : Tape) : + (pairCode W t).drop (blockRuler W).length = padTo (blockRuler W) (rightCode t W) := + List.drop_left' (by simp) + +/-- One left move on a pair of half-blocks, writing back the symbol `s`. -/ +def rewindStep (R : List Bool) (s : Ξ“) (z : List Bool) : List Bool := + (tapeStepBlocks R s Dir3.left (z.take R.length) (z.drop R.length)).1 ++ + (tapeStepBlocks R s Dir3.left (z.take R.length) (z.drop R.length)).2 + +/-- **One rewind step.** The head moves one cell left, except at cell `0` β€” where +it reads `β–·` and stays put, which is also what the machine model does. The symbol +written back is the one just read, so nothing changes but the head. -/ +def rewindFn (R z : List Bool) : List Bool := + caseBitβ‚€ (matchPrefix (symCode Ξ“.start) (z.drop R.length)) z + (caseBitβ‚€ (matchPrefix (symCode Ξ“.blank) (z.drop R.length)) (rewindStep R Ξ“.blank z) + (caseBitβ‚€ (matchPrefix (symCode Ξ“.zero) (z.drop R.length)) (rewindStep R Ξ“.zero z) + (rewindStep R Ξ“.one z))) + +/-- **The rewind step is in the algebra.** -/ +theorem rewindFn_mem {n : β„•} {gR gz : (Fin n β†’ List Bool) β†’ List Bool} + (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n β†’ List Bool => rewindFn (gR v) (gz v) := by + have hstep : βˆ€ s : Ξ“, Cobham fun v : Fin n β†’ List Bool => rewindStep (gR v) s (gz v) := + fun s => + (appendFn (tapeStepBlocksFst s Dir3.left hR (takeFn hR hz) (dropFn hR hz)) + (tapeStepBlocksSnd s Dir3.left hR (takeFn hR hz) (dropFn hR hz))).of_eq + fun _ => rfl + have hkey : Cobham fun v : Fin n β†’ List Bool => (gz v).drop (gR v).length := + dropFn hR hz + exact (iteFn (matchPrefixFn hkey _) hz + (iteFn (matchPrefixFn hkey _) (hstep _) + (iteFn (matchPrefixFn hkey _) (hstep _) (hstep _)))).of_eq fun _ => rfl + +/-- The first two bits of a tape's padded right half-block code its read symbol. -/ +theorem take_two_drop_pairCode {W : β„•} (t : Tape) (hW : t.head ≀ W) : + ((pairCode W t).drop (blockRuler W).length).take 2 = symCode t.read := by + rw [drop_pairCode, + take_padTo _ _ 2 (by rw [rightCode_length]; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth]; omega), + take_rightCode _ hW] + +/-- A two-bit symbol code prefixes a padded right half-block exactly when it is +*the* read symbol's code. -/ +private theorem matchPrefix_symCode {W : β„•} (t : Tape) (hW : t.head ≀ W) (s : Ξ“) : + matchPrefix (symCode s) ((pairCode W t).drop (blockRuler W).length) + = if s = t.read then [true] else [false] := by + have hlen : (symCode s).length = 2 := symCode_length s + split + Β· next h => + subst h + refine (matchPrefix_eq_true_iff _ _).mpr ?_ + rw [← take_two_drop_pairCode t hW, ← hlen] + exact List.take_prefix _ _ + Β· next h => + rcases matchPrefix_flag (symCode s) + ((pairCode W t).drop (blockRuler W).length) with hm | hm + Β· exfalso + have hpre := (matchPrefix_eq_true_iff _ _).mp hm + have : symCode s = symCode t.read := by + rw [← take_two_drop_pairCode t hW, ← hlen] + exact List.prefix_iff_eq_take.mp hpre + exact h (symCode_injective this) + Β· exact hm + +/-- At cell `0` a left move stands still β€” `Nat` subtraction saturates. -/ +private theorem move_left_of_head_zero {t : Tape} (h : t.head = 0) : + t.move Dir3.left = t := by + obtain ⟨hd, cs⟩ := t + simp only at h + subst h + rfl + +/-- **The rewind step computes a left move.** Away from cell `0` the symbol +written back is the one read, so `tapeStepBlocks_eq` applies with +`Tape.write_read_self`; at cell `0` the head reads `β–·` and both sides stand +still. -/ +theorem rewindFn_eq {W : β„•} (t : Tape) (hinv : t.StartInvariant) (hW : t.head ≀ W) : + rewindFn (blockRuler W) (pairCode W t) = pairCode W (t.move Dir3.left) := by + by_cases h0 : t.head = 0 + Β· have hread : t.read = Ξ“.start := by rw [Tape.read, h0]; exact hinv.1 + have hmove : t.move Dir3.left = t := move_left_of_head_zero h0 + rw [rewindFn, matchPrefix_symCode t hW, ite_eq_left hread.symm, caseBitβ‚€_cons, Bool.cond_true, + hmove] + Β· have hread : t.read β‰  Ξ“.start := hinv.read_ne_start (by omega) + have hstep : βˆ€ s : Ξ“, s = t.read β†’ + rewindStep (blockRuler W) s (pairCode W t) = pairCode W (t.move Dir3.left) := by + rintro s rfl + have := tapeStepBlocks_eq (W := W) t t.read Dir3.left (fun _ => rfl) + (fun _ => h0) hW + rw [rewindStep, take_pairCode, drop_pairCode, this, write_read_self, pairCode] + rw [rewindFn, matchPrefix_symCode t hW, matchPrefix_symCode t hW, + matchPrefix_symCode t hW] + cases hr : t.read with + | start => exact absurd hr hread + | blank | zero | one => + simp +decide only [caseBitβ‚€] + exact hstep _ hr.symm + +/-- **A rewound pair stays within its two blocks.** -/ +theorem rewindFn_length_le (R z : List Bool) (hz : z.length ≀ 2 * R.length) : + (rewindFn R z).length ≀ 2 * R.length := by + have hstep : βˆ€ s : Ξ“, (rewindStep R s z).length = 2 * R.length := fun s => by + rw [rewindStep, tapeStepBlocks, List.length_append, padTo_length, padTo_length] + omega + rw [rewindFn] + rcases caseBitβ‚€_cases (matchPrefix (symCode Ξ“.start) (z.drop R.length)) z _ with h | h + Β· rw [h]; exact hz + Β· rw [h] + rcases caseBitβ‚€_cases (matchPrefix (symCode Ξ“.blank) (z.drop R.length)) + (rewindStep R Ξ“.blank z) _ with h2 | h2 + Β· rw [h2]; exact (hstep _).le + Β· rw [h2] + rcases caseBitβ‚€_cases (matchPrefix (symCode Ξ“.zero) (z.drop R.length)) + (rewindStep R Ξ“.zero z) _ with h3 | h3 + Β· rw [h3]; exact (hstep _).le + Β· rw [h3]; exact (hstep _).le + +/-! ## The initial encoding + +At the start every tape but the input is blank and every head is at cell `0`, so +the encoding is a constant apart from the input tape's right half-block β€” which +is the input string at two bits per cell. Zero padding *is* blank padding, which +is why `symCode Ξ“.blank = [0,0]`. -/ + +/-- A bitstring as tape cells, two bits each. -/ +def encodeBits (x : List Bool) : List Bool := x.flatMap fun b => symCode (Ξ“.ofBool b) + +@[simp] theorem encodeBits_nil : encodeBits [] = [] := rfl + +@[simp] theorem encodeBits_cons (b : Bool) (x : List Bool) : + encodeBits (b :: x) = symCode (Ξ“.ofBool b) ++ encodeBits x := rfl + +@[simp] theorem encodeBits_length (x : List Bool) : + (encodeBits x).length = 2 * x.length := by + induction x with + | nil => rfl + | cons b x ih => + rw [encodeBits_cons, List.length_append, symCode_length, ih, List.length_cons] + omega + +/-- The step of `encodeBits`: prepend the peeled bit's two-bit code. -/ +private def encStep (b : Bool) (w : Fin 2 β†’ List Bool) : List Bool := + symCode (Ξ“.ofBool b) ++ w 1 + +private theorem encStep_cons (b : Bool) (x p : List Bool) (v : Fin 0 β†’ List Bool) : + encStep b (Fin.cons x (Fin.cons p v)) = symCode (Ξ“.ofBool b) ++ p := rfl + +/-- **Coding a string as tape cells is in the algebra.** -/ +theorem encodeBitsFn {n : β„•} {g : (Fin n β†’ List Bool) β†’ List Bool} (h : Cobham g) : + Cobham fun v : Fin n β†’ List Bool => encodeBits (g v) := by + have hrec : βˆ€ (x : List Bool) (v : Fin 0 β†’ List Bool), + recNotation (fun _ : Fin 0 β†’ List Bool => ([] : List Bool)) (encStep false) + (encStep true) x v = encodeBits x := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + cases b <;> + Β· rw [recNotation_cons] + simp only [Bool.cond_true, Bool.cond_false] + rw [encStep_cons, ih, encodeBits_cons] + have hs : βˆ€ b : Bool, Cobham (encStep b) := fun b => + (appendFn (Cobham.const (symCode (Ξ“.ofBool b))) (Cobham.proj 1)).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 1 β†’ List Bool => encodeBits (v 0) := by + refine (Cobham.boundedRec Cobham.empty (hs false) (hs true) + (appendFn (Cobham.proj 0) (Cobham.proj 0)) ?_).of_eq fun v => ?_ + Β· intro x v + rw [hrec, encodeBits_length, Fin.cons_zero, List.length_append] + omega + Β· rw [hrec] + exact (Cobham.comp hbase fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- **The initial encoding.** Everything but the input tape's right half-block is +a constant of the machine. -/ +noncomputable def initFn {k : β„•} (tm : TM k) (R x : List Bool) : List Bool := + padTo R (stateCode tm.qstart) ++ + (padTo R [] ++ (padTo R (symCode Ξ“.start ++ encodeBits x) ++ + (List.replicate (k + 1) (padTo R [] ++ padTo R (symCode Ξ“.start))).flatten)) + +/-- **The initial encoding is in the algebra.** -/ +theorem initFn_mem {n k : β„•} (tm : TM k) + {gR gx : (Fin n β†’ List Bool) β†’ List Bool} (hR : Cobham gR) (hx : Cobham gx) : + Cobham fun v : Fin n β†’ List Bool => initFn tm (gR v) (gx v) := + (appendFn (padFn hR (Cobham.const _)) + (appendFn (padFn hR Cobham.empty) + (appendFn (padFn hR (appendFn (Cobham.const _) (encodeBitsFn hx))) + (repeatFn (appendFn (padFn hR Cobham.empty) + (padFn hR (Cobham.const _))) (k + 1))))).of_eq fun _ => rfl + +/-! ### The initial tapes -/ + +private theorem flatten_tapesBlocks (W : β„•) : βˆ€ ts : List Tape, + (tapesBlocks W ts).flatten + = (ts.map fun t => padTo (blockRuler W) (leftCode t) + ++ padTo (blockRuler W) (rightCode t W)).flatten := by + intro ts + induction ts with + | nil => rfl + | cons t ts ih => + rw [tapesBlocks, List.flatMap_cons, List.flatten_append, ← tapesBlocks, ih, + List.map_cons, List.flatten_cons, tapeBlocks] + simp + +/-- Windows concatenate. -/ +theorem cellsCode_add (t : Tape) (i a b : β„•) : + cellsCode t i (a + b) = cellsCode t i a ++ cellsCode t (i + a) b := by + induction a generalizing i with + | zero => simp + | succ a ih => + rw [show a + 1 + b = (a + b) + 1 from by omega, cellsCode_succ_left, + cellsCode_succ_left, ih, List.append_assoc, + show i + 1 + a = i + (a + 1) from by omega] + +private theorem cellsCode_of_bits (x : List Bool) : + βˆ€ (t : Tape) (i : β„•), (βˆ€ j, βˆ€ hj : j < x.length, t.cells (i + j) = Ξ“.ofBool x[j]) β†’ + cellsCode t i x.length = encodeBits x := by + induction x with + | nil => intro t i _; rfl + | cons b x ih => + intro t i hcells + rw [List.length_cons, cellsCode_succ_left, encodeBits_cons, + show t.cells i = Ξ“.ofBool b from by simpa using! hcells 0 (by simp)] + congr 1 + exact ih t (i + 1) fun j hj => by + have := hcells (j + 1) (by rw [List.length_cons]; omega) + rw [show i + 1 + j = i + (j + 1) from by omega] + simpa using this + +private theorem cellsCode_of_blank (t : Tape) (i w : β„•) + (h : βˆ€ j < w, t.cells (i + j) = Ξ“.blank) : + cellsCode t i w = List.replicate (2 * w) false := by + induction w generalizing i with + | zero => rfl + | succ w ih => + rw [cellsCode_succ_left, show t.cells i = Ξ“.blank from by simpa using h 0 (by omega), + ih (i + 1) fun j hj => by + rw [show i + 1 + j = i + (j + 1) from by omega]; exact h (j + 1) (by omega), + show 2 * (w + 1) = 2 + 2 * w from by omega, List.replicate_add] + rfl + +/-- **The initial encoding is the initial configuration's.** -/ +theorem initFn_eq {k : β„•} (tm : TM k) (W : β„•) (x : List Bool) (hx : x.length ≀ W) : + initFn tm (blockRuler W) x = cfgCode W (tm.initCfg x) := by + set R := blockRuler W with hR + -- The input tape. + have hin : padTo R (rightCode (Tape.init (x.map Ξ“.ofBool)) W) + = padTo R (symCode Ξ“.start ++ encodeBits x) := by + have h0 : cellsCode (Tape.init (x.map Ξ“.ofBool)) 0 1 = symCode Ξ“.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h1 : cellsCode (Tape.init (x.map Ξ“.ofBool)) 1 x.length = encodeBits x := + cellsCode_of_bits x _ 1 fun j hj => by + rw [show 1 + j = j + 1 from by omega, Tape.init_cells_succ] + have hjm : j < (x.map Ξ“.ofBool).length := by simpa using hj + rw [List.getElem?_eq_getElem hjm] + simp + have h2 : cellsCode (Tape.init (x.map Ξ“.ofBool)) (1 + x.length) (W - x.length) + = List.replicate (2 * (W - x.length)) false := + cellsCode_of_blank _ _ _ fun j _ => by + rw [show 1 + x.length + j = (x.length + j) + 1 from by omega, + Tape.init_cells_succ, List.getElem?_eq_none (by simp)] + rfl + have hcells : cellsCode (Tape.init (x.map Ξ“.ofBool)) 0 (W + 1) + = symCode Ξ“.start ++ (encodeBits x + ++ List.replicate (2 * (W - x.length)) false) := by + rw [show W + 1 = 1 + (x.length + (W - x.length)) from by omega, + cellsCode_add _ 0 1 _, cellsCode_add _ (0 + 1) x.length _] + simp only [Nat.zero_add] + rw [h0, h1, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, ← List.append_assoc, + padTo_append_replicate] + have hblank : padTo R (rightCode (Tape.init []) W) = padTo R (symCode Ξ“.start) := by + have h0 : cellsCode (Tape.init ([] : List Ξ“)) 0 1 = symCode Ξ“.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h2 : cellsCode (Tape.init ([] : List Ξ“)) 1 W + = List.replicate (2 * W) false := + cellsCode_of_blank _ _ _ fun j _ => by + rw [show 1 + j = j + 1 from by omega, Tape.init_nil_cells_succ] + have hcells : cellsCode (Tape.init ([] : List Ξ“)) 0 (W + 1) + = symCode Ξ“.start ++ List.replicate (2 * W) false := by + rw [show W + 1 = 1 + W from by omega, cellsCode_add _ 0 1 W] + simp only [Nat.zero_add] + rw [h0, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, padTo_append_replicate] + have hleft : βˆ€ contents : List Ξ“, leftCode (Tape.init contents) = [] := fun _ => rfl + have hct : cfgTapes (tm.initCfg x) + = Tape.init (x.map Ξ“.ofBool) :: List.replicate (k + 1) (Tape.init []) := by + rw [cfgTapes] + congr 1 + show (Tape.init [] : Tape) :: List.ofFn (fun _ : Fin k => (Tape.init [] : Tape)) + = List.replicate (k + 1) (Tape.init []) + rw [List.replicate_succ, List.ofFn_const] + rw [cfgCode, cfgBlocks_eq, List.flatten_cons, flatten_tapesBlocks, hct, + List.map_cons, List.flatten_cons, List.map_replicate, hleft, hleft, hin, hblank, + initFn, List.append_assoc] + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean new file mode 100644 index 0000000000..e9af2cc5a2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean @@ -0,0 +1,616 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Truncating to the length of a leading block β€” proof internals + +`takeLen (pair c y) = y.take |c|`: the leading self-delimiting block acts as a +*ruler* and the verbatim suffix is truncated to its length. Carrying a width +bound as a string rather than as a number is what keeps an iterated `FP` step +function polynomial-time β€” each iteration truncates its state to the ruler, so no +intermediate value can grow beyond it. + +The transducer `takeLenTM` has one work tape: *scan* parses the leading block two +symbols at a time, writing one unary mark per payload bit; *rewind* returns the +work head to cell one; *copy* emits one input symbol per remaining mark. +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Complexity.takeLen_pair` β€” the defining equation on genuine pairs +- `Complexity.takeLen_mem_FP` β€” the truncation is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-! ## The function computed by the scanner -/ + +/-- The remaining output of the truncation scanner when `k` payload bits of the +leading block have already been counted and `w` is the unread part of the input: +the suffix truncated to the total ruler length, and nothing at all when the block +framing is broken. -/ +def takeLenAux (k : β„•) (w : List Bool) : List Bool := + match unpair? w with + | some (x, y) => y.take (k + x.length) + | none => [] + +/-- Truncate the verbatim suffix of a pair to the length of its leading block. -/ +def takeLen (p : List Bool) : List Bool := takeLenAux 0 p + +@[simp] theorem takeLenAux_nil (k : β„•) : takeLenAux k [] = [] := rfl + +@[simp] theorem takeLenAux_singleton (k : β„•) (b : Bool) : takeLenAux k [b] = [] := by + cases b <;> rfl + +/-- Reaching the separator ends the ruler: the suffix is truncated to `k`. -/ +@[simp] theorem takeLenAux_sep (k : β„•) (z : List Bool) : + takeLenAux k (false :: true :: z) = z.take k := by + simp [takeLenAux, unpair?] + +/-- A doubled payload bit lengthens the ruler by one. -/ +theorem takeLenAux_double (k : β„•) (b : Bool) (z : List Bool) : + takeLenAux k (b :: b :: z) = takeLenAux (k + 1) z := by + cases b <;> + Β· simp only [takeLenAux, unpair?] + cases h : unpair? z with + | none => simp + | some xy => + obtain ⟨x, y⟩ := xy + simp only [Option.map_some, List.length_cons] + rw [show k + (x.length + 1) = k + 1 + x.length from by omega] + +/-- A broken doubling halts the scan with no output. -/ +@[simp] theorem takeLenAux_broken (k : β„•) (z : List Bool) : + takeLenAux k (true :: false :: z) = [] := rfl + +/-- On a genuine pair the leading block is the ruler. -/ +theorem takeLen_pair (c y : List Bool) : takeLen (pair c y) = y.take c.length := by + simp [takeLen, takeLenAux] + +section TakeLenMachine + +/-- Control states of `takeLenTM`. -/ +inductive TakePhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Read the first symbol of a doubled payload bit. -/ + | scanA + /-- The first symbol of the pair was `0`. -/ + | scanB0 + /-- The first symbol of the pair was `1`. -/ + | scanB1 + /-- Rewind the work head to cell one. -/ + | rew + /-- Emit one input symbol per remaining mark. -/ + | copy + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype TakePhase where + elems := {.skip, .scanA, .scanB0, .scanB1, .rew, .copy, .done} + complete := fun x => by cases x <;> simp + +/-- **The truncation scanner.** Parses the leading self-delimiting block into +`|c|` unary marks on its work tape, then copies that many input symbols to the +output. Computes `takeLen`. -/ +def takeLenTM : TM 1 where + Q := TakePhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .scanA => + match iHead with + | Ξ“.zero => + (.scanB0, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.scanB1, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB0 => + match iHead with + | Ξ“.zero => + (.scanA, fun _ => Ξ“w.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Ξ“.one => + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB1 => + match iHead with + | Ξ“.one => + (.scanA, fun _ => Ξ“w.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rew => + if wHeads 0 = Ξ“.start then + (.copy, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun _ => Dir3.right, idleDir oHead) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .copy => + if wHeads 0 = Ξ“.one then + match iHead with + | Ξ“.zero => + (.copy, fun i => readBackWrite (wHeads i), Ξ“w.zero, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | Ξ“.one => + (.copy, fun i => readBackWrite (wHeads i), Ξ“w.one, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB0 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB1 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rew => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ _ => rfl, idleDir_right_of_start⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + idleDir_right_of_start⟩ + | .copy => + dsimp only [] + split + Β· cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-! ## Correctness of the scanner -/ + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem take_idle_eq {t : Tape} (h : t.read β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, ite_eq_right h, Tape.move] + +/-- The copy phase: with `r` marks left under and to the right of the work head, +the machine emits the first `r` symbols of the remaining input. -/ +private theorem takeLenTM_copy_loop : + βˆ€ (r h m : β„•), h + r = m + 1 β†’ 1 ≀ h β†’ + βˆ€ (y acc : List Bool) (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.copy β†’ + (c.work 0).cells = regCells m β†’ + (c.work 0).head = h β†’ + c.input.HasBinarySuffix y β†’ + c.output.HasBinaryPrefix acc β†’ + βˆƒ c' t, t ≀ r + 1 ∧ takeLenTM.reachesIn t c c' ∧ takeLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y.take r) := by + intro r + induction r with + | zero => + intro h m hsum hh y acc c hstate hcells hhead hsuf hpre + have hwread : (c.work 0).read = Ξ“.blank := by + rw [Tape.read, hcells, hhead]; exact regCells_blank (by omega) + have hwne : (c.work 0).read β‰  Ξ“.start := by rw [hwread]; decide + have hwne1 : Β¬ (c.work 0).read = Ξ“.one := by rw [hwread]; decide + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hsuf.read_ne_start, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwne1, hinp_eq, reduceCtorEq, ite_false] + rw [hwork, take_idle_eq houtne] + | succ r ih => + intro h m hsum hh y acc c hstate hcells hhead hsuf hpre + have hwread : (c.work 0).read = Ξ“.one := by + rw [Tape.read, hcells, hhead]; exact regCells_one (by omega) (by omega) + have hwne : (c.work 0).read β‰  Ξ“.start := by rw [hwread]; decide + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hsuf.read_ne_start, Tape.move] + have hworkIdle : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hworkR : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact writeAndMove_readBack _ hwne _ + have hidleB : βˆ€ t : Tape, t.move (idleDir Ξ“.blank) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + match y with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwread, hread, hidleB, reduceCtorEq, + ite_false, reduceIte] + rw [hworkIdle, take_idle_eq houtne] + | b :: y => + have hread : c.input.read = Ξ“.ofBool b := hsuf.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.copy + input := c.input.move Dir3.right + work := fun i => (c.work i).move Dir3.right + output := c.output.writeAndMove (Ξ“.ofBool b) Dir3.right } with hc1 + have hstep : takeLenTM.step c = some c1 := by + cases b <;> + Β· simp only [TM.step, hstate, takeLenTM, hwread, hread, hc1, Ξ“.ofBool, + reduceCtorEq, ite_false, reduceIte] + rw [hworkR] + rfl + obtain ⟨c', t, ht, hreach, hhalt, hfin⟩ := + ih (h + 1) m (by omega) (by omega) y (acc ++ [b]) c1 rfl + (by rw [hc1]; simpa using! hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; exact hsuf.move_right_cons) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit b hpre) + refine ⟨c', t + 1, by omega, .step hstep hreach, hhalt, ?_⟩ + simpa using hfin + +/-- The rewind phase: walk the work head back to the left-end marker and enter +`copy` with the work head at cell one. -/ +private theorem takeLenTM_rew_loop : + βˆ€ (h m : β„•) (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.rew β†’ + (c.work 0).cells = regCells m β†’ + (c.work 0).head = h β†’ + c.input.read β‰  Ξ“.start β†’ + c.output.read β‰  Ξ“.start β†’ + βˆƒ c', takeLenTM.reachesIn (h + 1) c c' ∧ + c'.state = TakePhase.copy ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = 1 ∧ + c'.input = c.input ∧ + c'.output = c.output := by + intro h + induction h with + | zero => + intro m c hstate hcells hhead hinp hout + have hwread : (c.work 0).read = Ξ“.start := by + rw [Tape.read, hcells, hhead]; rfl + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + show ((c.work 0).write _).move Dir3.right = (c.work 0).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + refine ⟨{ state := TakePhase.copy + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simp [Tape.move_cells, hcells], + by simp [Tape.move, hhead], rfl, rfl⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwread, hinp_eq, reduceIte, reduceCtorEq, + ite_false] + rw [hwork, take_idle_eq hout] + | succ h ih => + intro m c hstate hcells hhead hinp hout + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, ite_eq_right hinp, Tape.move] + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.rew + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, ite_eq_right hwne] + exact writeAndMove_readBack _ hwne _ + have hstep : takeLenTM.step c = some c1 := by + simp only [TM.step, hstate, takeLenTM, hinp_eq, hc1, ite_eq_right hwne, reduceCtorEq, + ite_false] + rw [hwork, take_idle_eq hout] + obtain ⟨c', hreach, hst, hcl, hhd, hin, hou⟩ := + ih m c1 rfl (by rw [hc1]; simpa [Tape.move_cells] using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) (by rw [hc1]; simpa using hout) + exact ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], by rw [hou, hc1]⟩ + +/-- The scan phase: from `scanA` with `k` ruler bits already counted and `w` +unread, the machine runs to a halt with `takeLenAux k w` on the output tape. -/ +private theorem takeLenTM_scan_loop : + βˆ€ (N : β„•) (w : List Bool) (k : β„•), k + w.length ≀ N β†’ + βˆ€ (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.scanA β†’ + (c.work 0).cells = regCells k β†’ + (c.work 0).head = k + 1 β†’ + c.input.HasBinarySuffix w β†’ + c.output.HasBinaryPrefix [] β†’ + βˆƒ c' t, t ≀ 3 * N + 5 ∧ takeLenTM.reachesIn t c c' ∧ + takeLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (takeLenAux k w) := by + intro N + induction N with + | zero => + intro w k hN c hstate hcells hhead hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (by omega) + subst hwnil + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + have hidleB : βˆ€ t : Tape, t.move (idleDir Ξ“.blank) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hread, hidleB, reduceCtorEq, ite_false] + rw [hwork, take_idle_eq houtne] + | succ N ih => + intro w k hN c hstate hcells hhead hsuf hpre + have hwne : (c.work 0).read β‰  Ξ“.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read β‰  Ξ“.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΞ“ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hidleB : βˆ€ t : Tape, t.move (idleDir Ξ“.blank) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + have hidleZ : βˆ€ t : Tape, t.move (idleDir Ξ“.zero) = t := by + intro t; rw [idleDir, ite_eq_right (by decide)]; rfl + have hstepA : βˆ€ b : Bool, + c.input.read = Ξ“.ofBool b β†’ + takeLenTM.step c = some + { state := (bif b then TakePhase.scanB1 else TakePhase.scanB0) + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + intro b hread + cases b <;> + Β· simp only [TM.step, hstate, takeLenTM, hread, Ξ“.ofBool, reduceCtorEq, ite_false, + Bool.cond_true, Bool.cond_false] + rw [hwork, take_idle_eq houtne] + match w with + | [] => + have hread : c.input.read = Ξ“.blank := hsuf.read_nil + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hread, hidleB, reduceCtorEq, ite_false] + rw [hwork, take_idle_eq houtne] + | [b] => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix [] := hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.blank := hsuf1.read_nil + refine ⟨{ state := TakePhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [takeLenAux_singleton] using hpre⟩ + refine .step (hstepA b hsuf.read_cons) (.step ?_ .zero) + cases b <;> + Β· simp only [TM.step, takeLenTM, hread1, hidleB, reduceCtorEq, ite_false, + Bool.cond_true, Bool.cond_false] + rw [hwork, take_idle_eq houtne] + | true :: false :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.zero := hsuf1.read_cons + refine ⟨{ state := TakePhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [takeLenAux_broken] using hpre⟩ + refine .step (hstepA true hsuf.read_cons) (.step ?_ .zero) + simp only [TM.step, takeLenTM, hread1, hidleZ, reduceCtorEq, ite_false, Bool.cond_true] + rw [hwork, take_idle_eq houtne] + | false :: true :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.one := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.rew + input := (c.input.move Dir3.right).move Dir3.right + work := c.work + output := c.output } with hc2 + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, ite_false] + rw [hwork, take_idle_eq houtne] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hou3⟩ := + takeLenTM_rew_loop (k + 1) k c2 rfl (by rw [hc2]; exact hcells) + (by rw [hc2]; exact hhead) hsuf2.read_ne_start (by rw [hc2]; exact houtne) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + takeLenTM_copy_loop k 1 k (by omega) (by omega) z [] c3 hst3 hcl3 hhd3 + (by rw [hin3]; exact hsuf2) (by rw [hou3]; exact hpre) + refine ⟨c', (k + 1 + 1 + t) + 1 + 1, ?_, ?_, hhalt', ?_⟩ + Β· simp only [List.length_cons] at hN + omega + Β· exact .step hstep1 (.step hstep2 (takeLenTM.reachesIn_trans hreach3 hreach')) + Β· rw [takeLenAux_sep] + simpa using hout' + | false :: false :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.zero := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Ξ“.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Ξ“w.one).toΞ“ Dir3.right) + = fun i => ((c.work i).write Ξ“.one).move Dir3.right := rfl + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, ite_false] + rw [hwmark, take_idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, ite_eq_right (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Ξ“.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 + hhead2 (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, by omega, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + rwa [takeLenAux_double] + | true :: true :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Ξ“.one := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB1 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA true hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Ξ“.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Ξ“w.one).toΞ“ Dir3.right) + = fun i => ((c.work i).write Ξ“.one).move Dir3.right := rfl + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, ite_false] + rw [hwmark, take_idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, ite_eq_right (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Ξ“.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Ξ“.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 + hhead2 (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, by omega, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + rwa [takeLenAux_double] + +/-- The blank work tape of the initial configuration is the zero register. -/ +private theorem take_init_nil_cells : + (Tape.init ([] : List Ξ“)).cells = regCells 0 := by + funext j + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rfl + Β· obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_ge _ _ (by simp), regCells_blank (by omega)] + +/-- `takeLenTM` computes `takeLen` in `3 Β· |p| + 6` steps. -/ +theorem takeLenTM_computesInTime : + takeLenTM.ComputesInTime takeLen (fun n => 3 * n + 6) := by + intro p + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (Tape.init (p.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : takeLenTM.step (takeLenTM.initCfg p) = some c1 := by + simp [TM.step, takeLenTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + takeLenTM_scan_loop p.length p 0 (by omega) c1 rfl + (by rw [hc1]; show ((Tape.init []).move Dir3.right).cells = _ + rw [Tape.move_cells, take_init_nil_cells]) + (by rw [hc1]; show ((Tape.init []).move Dir3.right).head = _ + simp [Tape.move]) + (by rw [hc1]; exact Tape.init_move_right_hasBinarySuffix p) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + exact ⟨c', t + 1, by simp; omega, .step hstep1 hreach, hhalt, hout.hasOutput⟩ + +end TakeLenMachine + +/-- Internal proof that ruler-truncation is in `FP`. -/ +theorem takeLen_mem_FP : takeLen ∈ FP := by + refine ⟨1, 1, takeLenTM, (fun n => 3 * n + 6), takeLenTM_computesInTime, ?_⟩ + have hn : (fun n : β„• => 3 * n) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa [pow_one] using (BigO.refl (fun n : β„• => n)).const_mul_left 3 + exact BigO.add hn (BigO.const_le_pow 6 1) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Vec.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Vec.lean new file mode 100644 index 0000000000..050b4f615b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Internal/Vec.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Vec +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput + +/-! +# The multi-arity bridge β€” proof internals + +The public tuple encoding and `FPn` predicate live in +`Complexitylib.Classes.P.Cobham.Vec`. This internal module supplies the concrete +`FP` building blocks used to connect their arity-one specialization to `FP`. + +## Main results + +- `Cobham.const_nil_mem_FP`, `Cobham.pairLeftNil_mem_FP` β€” the two `FP` maps the + arity-one glue needs +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## Foundational FP building blocks -/ + +/-- The constant empty-output function is in `FP` (the empty-support case of +`ite_mem_finset_mem_FP`). -/ +theorem const_nil_mem_FP : (fun _ : List Bool => ([] : List Bool)) ∈ FP := by + have h := ite_mem_finset_mem_FP (fun _ => []) (βˆ… : Finset (List Bool)) + simpa using h + +/-- The framing map `x ↦ pair [] x` (i.e. `false :: true :: x`) is +polynomial-time. This is the foundational map behind the arity-one encoding +`encodeVec ![x] = pair [] x`, and it is exactly `mem_FP_pairWithInput` applied to +the constant empty function. -/ +theorem pairLeftNil_mem_FP : (fun x : List Bool => pair [] x) ∈ FP := by + have h := mem_FP_pairWithInput const_nil_mem_FP + simpa using h + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Vec.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Vec.lean new file mode 100644 index 0000000000..32b1db3437 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Cobham/Vec.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey, Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham.Defs +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import Mathlib.Algebra.BigOperators.Group.Finset.Basic + +/-! +# Fixed-arity inputs for Cobham's characterization + +`FP` is defined for unary string functions, while Cobham's algebra is inherently +multi-arity. This module gives the public, auditable bridge: `encodeVec` packs a +fixed-arity argument vector into one string, `vectorLength` measures its unencoded +size, and `FPn` asks a unary `FP` function to agree on the encoded vectors. + +The nested pairing has an arity-dependent constant overhead. It is injective, and +for every fixed arity its encoded length is linear in `vectorLength`. + +## Main definitions and results + +- `Cobham.encodeVec` β€” nested-pairing tuple encoding, head component last +- `Cobham.vectorLength` β€” sum of the component lengths +- `Cobham.encodeVec_injective` β€” tuple encoding loses no information +- `Cobham.encodeVec_length_le` β€” fixed-arity linear length bound +- `Cobham.FPn` β€” polynomial time on encoded argument vectors +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- Encode an argument vector as a single bitstring by nested pairing, with the +head component placed in the verbatim suffix: +`encodeVec ![] = []` and `encodeVec (x ::α΅₯ v) = pair (encodeVec v) x`. -/ +def encodeVec : {n : β„•} β†’ (Fin n β†’ List Bool) β†’ List Bool + | 0, _ => [] + | _ + 1, v => pair (encodeVec (Fin.tail v)) (v 0) + +@[simp] theorem encodeVec_zero (v : Fin 0 β†’ List Bool) : encodeVec v = [] := rfl + +@[simp] theorem encodeVec_succ {n : β„•} (v : Fin (n + 1) β†’ List Bool) : + encodeVec v = pair (encodeVec (Fin.tail v)) (v 0) := rfl + +/-- The arity-one encoding is the single component placed in the verbatim suffix +of an empty block: `encodeVec ![x] = pair [] x`. -/ +theorem encodeVec_one (v : Fin 1 β†’ List Bool) : encodeVec v = pair [] (v 0) := by + simp [encodeVec] + +/-- The sum of the component lengths of a fixed-arity input vector. -/ +def vectorLength {n : β„•} (v : Fin n β†’ List Bool) : β„• := + βˆ‘ i, (v i).length + +@[simp] theorem vectorLength_zero (v : Fin 0 β†’ List Bool) : vectorLength v = 0 := by + simp [vectorLength] + +@[simp] theorem vectorLength_succ {n : β„•} (v : Fin (n + 1) β†’ List Bool) : + vectorLength v = (v 0).length + vectorLength (Fin.tail v) := by + rw [vectorLength, Fin.sum_univ_succ, vectorLength] + rfl + +/-- Exact recursive length law for the nested tuple encoding. -/ +theorem encodeVec_length_succ {n : β„•} (v : Fin (n + 1) β†’ List Bool) : + (encodeVec v).length = + 2 * (encodeVec (Fin.tail v)).length + 2 + (v 0).length := by + simp [encodeVec_succ] + +/-- `encodeVec` is injective at every arity. -/ +theorem encodeVec_injective {n : β„•} : Function.Injective (@encodeVec n) := by + induction n with + | zero => + intro v w _ + funext i + exact Fin.elim0 i + | succ n ih => + intro v w h + rw [encodeVec_succ, encodeVec_succ] at h + obtain ⟨htail, hhead⟩ := pair_inj h + have htail' : Fin.tail v = Fin.tail w := ih htail + funext i + refine Fin.cases ?_ (fun j => ?_) i + Β· exact hhead + Β· exact congrFun htail' j + +/-- For fixed arity `n`, the nested encoding has length linear in the sum of the +component lengths. The explicit coefficient also records that this is not a +uniform-in-arity linear bound. -/ +theorem encodeVec_length_le {n : β„•} (v : Fin n β†’ List Bool) : + (encodeVec v).length ≀ 2 ^ n * (vectorLength v + 2 * n) := by + induction n with + | zero => + simp [encodeVec, vectorLength] + | succ n ih => + rw [encodeVec_length_succ, vectorLength_succ] + have hp : 1 ≀ 2 ^ n := one_le_powβ‚€ (by omega) + have h2 := Nat.mul_le_mul_left 2 (ih (Fin.tail v)) + calc + 2 * (encodeVec (Fin.tail v)).length + 2 + (v 0).length + ≀ 2 * (2 ^ n * (vectorLength (Fin.tail v) + 2 * n)) + + 2 + (v 0).length := by omega + _ ≀ 2 ^ (n + 1) * + ((v 0).length + vectorLength (Fin.tail v) + 2 * (n + 1)) := by + rw [pow_succ] + nlinarith + +/-- **Multi-arity polynomial time.** A function of an argument vector is `FPn` +when some genuine unary `FP` function computes it on encoded vectors. -/ +def FPn {n : β„•} (f : (Fin n β†’ List Bool) β†’ List Bool) : Prop := + βˆƒ g, g ∈ FP ∧ βˆ€ v, g (encodeVec v) = f v + +end Cobham + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Composition.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Composition.lean new file mode 100644 index 0000000000..f1fb725d3b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Composition.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Composition + +/-! +# Closure of FP under composition + +## Main result + +- `mem_FP_comp` β€” polynomial-time string functions are closed under composition +-/ + + +@[expose] public section + +namespace Complexity + +/-- The composition of two polynomial-time string functions is polynomial-time. -/ +theorem mem_FP_comp {f g : List Bool β†’ List Bool} + (hf : f ∈ FP) (hg : g ∈ FP) : (g ∘ f) ∈ FP := by + exact mem_FP_comp_internal hf hg + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Defs.lean new file mode 100644 index 0000000000..4c5778b5e0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Defs.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time +public import LeanPool.BeyondBethe.Complexitylib.Classes.Space + +/-! +# P, FP, and PSPACE + +This file defines **P** (polynomial time), **FP** (polynomial-time functions), +and **PSPACE** (polynomial space) in terms of the base classes `DTIME` and +`DSPACE`. +-/ + + +@[expose] public section + +namespace Complexity + + +/-- **P** is the class of languages decidable by a deterministic TM in + polynomial time: `P = ⋃_k DTIME(n^k)`. -/ +def P : Set Language := + ⋃ k : β„•, DTIME (Β· ^ k) + +/-- **FP** is the class of functions computable by a deterministic TM in + polynomial time. -/ +def FP : Set (List Bool β†’ List Bool) := + {f | βˆƒ (d k : β„•) (tm : TM k) (T : β„• β†’ β„•), + tm.ComputesInTime f T ∧ T =O (Β· ^ d)} + +/-- **PSPACE** is the class of languages decidable by a deterministic TM using + polynomial auxiliary space: `PSPACE = ⋃_k DSPACE(n^k)`. -/ +def PSPACE : Set Language := + ⋃ k : β„•, DSPACE (Β· ^ k) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain.lean new file mode 100644 index 0000000000..92fe217222 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.FinsetDomain.Internal + +/-! +# Finite-deviation functions are polynomial-time + +A function that agrees with the constant empty-output function on all but +finitely many inputs is polynomial-time computable. Concretely, for any target +function `g` and finite set `S`, the function `fun s => if s ∈ S then g s else []` +belongs to `FP`: the finite lookup table can be hard-wired into the states of a +Turing machine that decides membership in `S` while scanning the input and then +emits the corresponding fixed output, all in linear time. + +This is the base case for building up polynomial-time functions β€” every function +with finite support (relative to the empty output) is trivially in `FP`, +regardless of how the values `g s` are chosen. + +## Main result + +- `ite_mem_finset_mem_FP` β€” `fun s => if s ∈ S then g s else []` belongs to `FP` +-/ + +@[expose] public section + +namespace Complexity + +/-- A function that agrees with the constant empty-output function except on a +finite set `S` β€” that is, `fun s => if s ∈ S then g s else []` β€” is computable in +polynomial (indeed linear) time. The finite table of exceptional values is +hard-wired into the lookup machine's states. -/ +theorem ite_mem_finset_mem_FP (g : List Bool β†’ List Bool) (S : Finset (List Bool)) : + (fun s => if s ∈ S then g s else []) ∈ FP := + ite_mem_finset_mem_FP_internal g S + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain/Internal.lean new file mode 100644 index 0000000000..98446552f5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/FinsetDomain/Internal.lean @@ -0,0 +1,485 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.Fintype.Sets +public import Mathlib.Data.Fintype.Option +public import Mathlib.Data.Finset.Lattice.Fold +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.FinsetPrefixes +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Finite-domain lookup machine (internal) + +Construction and correctness of a deterministic Turing machine computing a +function of the form `fun s => if s ∈ S then g s else []`, where `S` is a finite +set of "inputs of interest" and `g` an arbitrary target function. Such a +function differs from the constant empty-output function on only finitely many +inputs, so it can be computed by a table lookup that runs in linear time. + +The machine has no work tapes. It works in two phases: + +* **Read phase.** It scans the read-only input tape left to right, tracking in + its finite state the prefix read so far β€” as long as that prefix is still a + prefix of some element of `S`; otherwise it enters a "dead" state. The output + head bumps off the left marker on the first step and then idles at cell one. +* **Write phase.** On reaching the first input blank it knows exactly which + element of `S` (if any) the input was, hence which fixed output string to + produce. It writes that string onto the output tape, one symbol per step, + landing on the halting configuration. + +Since the read phase takes `|x|` steps and the write phase is bounded by the +longest possible output, the runtime is linear. + +The public statement (`ite_mem_finset_mem_FP`) lives in +`Complexitylib.Classes.P.FinsetDomain`. +-/ + +@[expose] public section + +namespace Complexity + +namespace TM.FinsetDomain + +variable (g : List Bool β†’ List Bool) (S : Finset (List Bool)) + +/-! ## Output finset + +The read phase tracks membership in `S.prefixes` and the write phase tracks +membership in `(outputsFinset g S).suffixes`; both finsets come from the +generic `Finset.prefixes`/`Finset.suffixes` API. -/ + +/-- The possible output strings: `g s` for `s ∈ S`, together with `[]`. -/ +def outputsFinset (g : List Bool β†’ List Bool) (S : Finset (List Bool)) : + Finset (List Bool) := + insert [] (S.image g) + +theorem nil_mem_suffixes_outputsFinset : + ([] : List Bool) ∈ (outputsFinset g S).suffixes := + Finset.nil_mem_suffixes ⟨[], Finset.mem_insert_self _ _⟩ + +theorem output_mem_suffixes_outputsFinset {input : List Bool} : + (if input ∈ S then g input else ([] : List Bool)) ∈ (outputsFinset g S).suffixes := by + refine Finset.mem_suffixes_self ?_ + unfold outputsFinset + split + Β· exact Finset.mem_insert_of_mem (Finset.mem_image_of_mem g β€Ή_β€Ί) + Β· exact Finset.mem_insert_self _ _ + +/-! ## The lookup machine -/ + +instance : Fintype {p : List Bool // p ∈ S.prefixes} := Finset.Subtype.fintype _ +instance : Fintype {w : List Bool // w ∈ (outputsFinset g S).suffixes} := + Finset.Subtype.fintype _ + +/-- States of the lookup machine. -/ +inductive LookupState (g : List Bool β†’ List Bool) (S : Finset (List Bool)) : Type where + /-- Read phase: the viable prefix consumed so far, carried together with the + proof that it is a prefix of some element of `S`, so that the transition + function can use the proof directly. -/ + | read (p : List Bool) (hp : p ∈ S.prefixes) : LookupState g S + /-- Read phase, dead state: the input read so far has diverged from every + element of `S`. -/ + | dead : LookupState g S + /-- Write phase: the output suffix still to be written. -/ + | write (w : List Bool) (hw : w ∈ (outputsFinset g S).suffixes) : LookupState g S + /-- The halt state. -/ + | halt : LookupState g S + +/-- `LookupState` as a sum of two finite subtypes and two extra states. This +equivalence supplies the `DecidableEq` and `Fintype` instances, which cannot be +derived because the `read`/`write` constructors have dependent fields. -/ +def lookupStateEquiv : + LookupState g S ≃ + (Option {p : List Bool // p ∈ S.prefixes} βŠ• + Option {w : List Bool // w ∈ (outputsFinset g S).suffixes}) where + toFun + | .read p hp => .inl (some ⟨p, hp⟩) + | .dead => .inl none + | .write w hw => .inr (some ⟨w, hw⟩) + | .halt => .inr none + invFun + | .inl (some ⟨p, hp⟩) => .read p hp + | .inl none => .dead + | .inr (some ⟨w, hw⟩) => .write w hw + | .inr none => .halt + left_inv s := by cases s <;> rfl + right_inv s := by rcases s with (_ | ⟨p, hp⟩) | (_ | ⟨w, hw⟩) <;> rfl + +instance : DecidableEq (LookupState g S) := (lookupStateEquiv g S).decidableEq +instance : Fintype (LookupState g S) := Fintype.ofEquiv _ (lookupStateEquiv g S).symm + +/-- The read-phase state after consuming prefix `p`: the viable prefix `p` if it +is still a prefix of some element of `S`, otherwise the dead state. -/ +def readState (p : List Bool) : LookupState g S := + if h : p ∈ S.prefixes then .read p h else .dead + +/-- The write-phase state carrying output suffix `c`. -/ +def writeState (c : List Bool) (hc : c ∈ (outputsFinset g S).suffixes) : LookupState g S := + .write c hc + +/-- The halt state. -/ +def haltState : LookupState g S := .halt + +theorem readState_ne_haltState (p : List Bool) : readState g S p β‰  haltState g S := by + rw [readState, haltState] + split <;> simp + +/-- The lookup machine for `g` and `S`. See the module docstring for the +construction. It has no work tapes. -/ +def lookupTM : TM 0 where + Q := LookupState g S + qstart := readState g S [] + qhalt := haltState g S + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .read p hp => + match iHead with + | Ξ“.blank => + -- end of input: hand off to the write phase + (writeState g S (if p ∈ S then g p else []) + (output_mem_suffixes_outputsFinset g S), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.start => + -- skip the left-end marker: move input right, keep the state + (.read p hp, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.zero => + (readState g S (p ++ [false]), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (readState g S (p ++ [true]), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | .dead => + match iHead with + | Ξ“.blank => + -- end of input: no element of `S` matched, write the empty output + (writeState g S [] (nil_mem_suffixes_outputsFinset g S), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.start => + (.dead, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.zero => + (.dead, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Ξ“.one => + (.dead, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | .write [] _ => + (haltState g S, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .write (a :: rest) hw => + (writeState g S rest (Finset.mem_suffixes_of_suffix (List.suffix_cons a rest) hw), + fun i => readBackWrite (wHeads i), Ξ“w.ofBool a, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.right) + | .halt => + (haltState g S, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .read p hp => + match iHead with + | Ξ“.blank => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | Ξ“.start => + exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + | Ξ“.zero => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | Ξ“.one => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .dead => + match iHead with + | Ξ“.blank => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | Ξ“.start => + exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + | Ξ“.zero => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | Ξ“.one => + exact ⟨fun h => absurd h (by decide), fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .write [] _ => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .write (a :: rest) hw => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .halt => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + +/-! ## Correctness -/ + +/-- Reading a Boolean symbol in the read phase advances the tracked prefix and +moves the input head right. -/ +private theorem lookup_read_bit_step (p : List Bool) (b : Bool) + (c : Cfg 0 (lookupTM g S).Q) + (hstate : c.state = readState g S p) + (hread : c.input.read = Ξ“.ofBool b) : + (lookupTM g S).step c = some + { state := readState g S (p ++ [b]) + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } := by + have hne : c.state β‰  (lookupTM g S).qhalt := by + rw [hstate]; exact readState_ne_haltState g S p + by_cases hp : p ∈ S.prefixes + Β· cases b <;> + simp [TM.step, lookupTM, hstate, hread, readState, haltState, dif_pos hp, Ξ“.ofBool] + Β· have hp' : p ++ [b] βˆ‰ S.prefixes := fun h => + hp (Finset.mem_prefixes_of_prefix (List.prefix_append p [b]) h) + cases b <;> + simp [TM.step, lookupTM, hstate, hread, readState, haltState, dite_eq_right hp, + dite_eq_right hp', + Ξ“.ofBool] + +/-- Writing back the (blank) symbol under an idle output head keeps the output +tape an empty binary prefix. -/ +private theorem hasBinaryPrefix_idle {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : + (t.writeAndMove (readBackWrite t.read) (idleDir t.read)).HasBinaryPrefix bits := by + have hread : t.read = Ξ“.blank := h.read_blank + have hne : t.read β‰  Ξ“.start := by rw [hread]; decide + rw [writeAndMove_readBack t hne] + have hstay : idleDir t.read = Dir3.stay := by rw [hread]; rfl + rw [hstay] + exact h + +/-- The read phase: from a config tracking prefix `x.take k` with the input head +at `k + 1`, the machine consumes the remaining input in `|x| - k` steps, reaching +the state that tracks the full input `x`. -/ +private theorem lookup_read_loop (x : List Bool) : + βˆ€ rem k (c : Cfg 0 (lookupTM g S).Q), + rem = x.length - k β†’ + c.state = readState g S (x.take k) β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + c.output.HasBinaryPrefix [] β†’ + k ≀ x.length β†’ + βˆƒ c', + (lookupTM g S).reachesIn rem c c' ∧ + c'.state = readState g S x ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = x.length + 1 ∧ + c'.output.HasBinaryPrefix [] := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead houtput hk + have hk_eq : k = x.length := by omega + subst hk_eq + rw [List.take_length] at hstate + exact ⟨c, .zero, hstate, hcells, hhead, houtput⟩ + | succ rem ih => + intro k c hrem hstate hcells hhead houtput hk + have hk_lt : k < x.length := by omega + have hread : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hstep := lookup_read_bit_step g S (x.take k) (x[k]'hk_lt) c hstate hread + set c1 : Cfg 0 (lookupTM g S).Q := + { state := readState g S (x.take k ++ [x[k]'hk_lt]) + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } with hc1 + have htake : x.take k ++ [x[k]'hk_lt] = x.take (k + 1) := List.take_concat_get' x k hk_lt + have hstate1 : c1.state = readState g S (x.take (k + 1)) := by rw [hc1, htake] + have hcells1 : c1.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simp [hc1, Tape.move_cells, hcells] + have hhead1 : c1.input.head = k + 1 + 1 := by simp [hc1, Tape.move, hhead] + have houtput1 : c1.output.HasBinaryPrefix [] := hasBinaryPrefix_idle houtput + obtain ⟨c', hreach, hstate', hcells', hhead', houtput'⟩ := + ih (k + 1) c1 (by omega) hstate1 hcells1 hhead1 houtput1 (by omega) + exact ⟨c', .step hstep hreach, hstate', hcells', hhead', houtput'⟩ + +/-- The first step skips the left-end markers: the input head advances to cell +one over the input contents and the output head bumps off its marker. -/ +private theorem lookup_initial_step (x : List Bool) : + βˆƒ c0, (lookupTM g S).step ((lookupTM g S).initCfg x) = some c0 ∧ + c0.state = readState g S [] ∧ + c0.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c0.input.head = 1 ∧ + c0.output.HasBinaryPrefix [] := by + set c0 : Cfg 0 (lookupTM g S).Q := + { state := readState g S [] + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init ([] : List Ξ“)).move Dir3.right } with hc0 + have hg : ((lookupTM g S).initCfg x).state β‰  (lookupTM g S).qhalt := + readState_ne_haltState g S [] + have hstep : (lookupTM g S).step ((lookupTM g S).initCfg x) = some c0 := by + by_cases h : ([] : List Bool) ∈ S.prefixes + Β· simp only [TM.step, hc0, lookupTM, readState, dif_pos h] + exact congrArg some (Cfg.ext rfl rfl (Subsingleton.elim _ _) rfl) + Β· simp only [TM.step, hc0, lookupTM, readState, dite_eq_right h] + exact congrArg some (Cfg.ext rfl rfl (Subsingleton.elim _ _) rfl) + refine ⟨c0, hstep, rfl, ?_, ?_, ?_⟩ + Β· rw [hc0]; simp [Tape.move_cells] + Β· rw [hc0]; simp [Tape.move] + Β· rw [hc0]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil + +/-- The handoff step from read phase to write phase: on reaching the input blank +the machine commits to writing the fixed output `if inp ∈ S then g inp else []`. -/ +private theorem lookup_handoff_step (inp : List Bool) (c : Cfg 0 (lookupTM g S).Q) + (hstate : c.state = readState g S inp) + (hread : c.input.read = Ξ“.blank) + (houtput : c.output.HasBinaryPrefix []) : + βˆƒ c', (lookupTM g S).step c = some c' ∧ + c'.state = writeState g S (if inp ∈ S then g inp else []) + (output_mem_suffixes_outputsFinset g S) ∧ + c'.output.HasBinaryPrefix [] := by + set c1 : Cfg 0 (lookupTM g S).Q := + { state := writeState g S (if inp ∈ S then g inp else []) + (output_mem_suffixes_outputsFinset g S) + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } with hc1 + have hstep : (lookupTM g S).step c = some c1 := by + by_cases hp : inp ∈ S.prefixes + Β· simp [TM.step, lookupTM, hstate, hread, readState, writeState, haltState, dif_pos hp, hc1] + Β· have hpS : inp βˆ‰ S := fun h => hp (Finset.mem_prefixes_self h) + simp [TM.step, lookupTM, hstate, hread, readState, writeState, haltState, dite_eq_right hp, + ite_eq_right hpS, hc1] + refine ⟨c1, hstep, by rw [hc1], ?_⟩ + rw [hc1] + exact hasBinaryPrefix_idle houtput + +/-- Writing one output symbol in the write phase extends the written prefix and +advances to the remaining suffix. -/ +private theorem lookup_write_cons_step (a : Bool) (rest : List Bool) + (hw : a :: rest ∈ (outputsFinset g S).suffixes) (c : Cfg 0 (lookupTM g S).Q) + (hstate : c.state = writeState g S (a :: rest) hw) : + (lookupTM g S).step c = some + { state := writeState g S rest (Finset.mem_suffixes_of_suffix (List.suffix_cons a rest) hw) + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (Ξ“.ofBool a) Dir3.right } := by + cases a <;> simp [TM.step, lookupTM, hstate, writeState, haltState, Ξ“.ofBool, Ξ“w.ofBool] + +/-- The write phase: from a config whose output already holds `written` and whose +state carries the remaining suffix `w`, the machine writes `w` and halts, in +`|w| + 1` steps, leaving `written ++ w` on the output tape. -/ +private theorem lookup_write_loop (written : List Bool) : + βˆ€ (w : List Bool) (hw : w ∈ (outputsFinset g S).suffixes) (c : Cfg 0 (lookupTM g S).Q), + c.state = writeState g S w hw β†’ + c.output.HasBinaryPrefix written β†’ + βˆƒ c', + (lookupTM g S).reachesIn (w.length + 1) c c' ∧ + (lookupTM g S).halted c' ∧ + c'.output.HasBinaryPrefix (written ++ w) := by + intro w + induction w generalizing written with + | nil => + intro hw c hstate houtput + have hne : c.state β‰  (lookupTM g S).qhalt := by + rw [hstate, writeState]; simp [lookupTM, haltState] + set c1 : Cfg 0 (lookupTM g S).Q := + { state := haltState g S + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } with hc1 + have hstep : (lookupTM g S).step c = some c1 := by + simp [TM.step, lookupTM, hstate, writeState, haltState, hc1] + refine ⟨c1, .step hstep .zero, ?_, ?_⟩ + Β· show c1.state = (lookupTM g S).qhalt + rw [hc1]; rfl + Β· rw [List.append_nil, hc1] + exact hasBinaryPrefix_idle houtput + | cons a rest ih => + intro hw c hstate houtput + have hstep := lookup_write_cons_step g S a rest hw c hstate + set c1 : Cfg 0 (lookupTM g S).Q := + { state := writeState g S rest (Finset.mem_suffixes_of_suffix (List.suffix_cons a rest) hw) + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (Ξ“.ofBool a) Dir3.right } with hc1 + have hout1 : c1.output.HasBinaryPrefix (written ++ [a]) := by + rw [hc1]; exact Tape.hasBinaryPrefix_write_bit a houtput + obtain ⟨c', hreach, hhalt, hout'⟩ := + ih (written ++ [a]) (Finset.mem_suffixes_of_suffix (List.suffix_cons a rest) hw) c1 rfl hout1 + refine ⟨c', ?_, hhalt, ?_⟩ + Β· have : rest.length + 1 + 1 = (a :: rest).length + 1 := by simp [List.length_cons] + rw [← this] + exact .step hstep hreach + Β· rwa [List.append_assoc, List.singleton_append] at hout' + +/-- The lookup machine computes `fun s => if s ∈ S then g s else []` within a +linear time bound. -/ +theorem lookupTM_computesInTime : + (lookupTM g S).ComputesInTime (fun s => if s ∈ S then g s else []) + (fun m => m + (S.sup fun s => (g s).length) + 3) := by + intro x + obtain ⟨c0, hstep0, hst0, hcells0, hhead0, hout0⟩ := lookup_initial_step g S x + obtain ⟨c1, hreadloop, hst1, hcells1, hhead1, hout1⟩ := + lookup_read_loop g S x x.length 0 c0 (by omega) hst0 hcells0 hhead0 hout0 (Nat.zero_le _) + have hread1_blank : c1.input.read = Ξ“.blank := by + rw [Tape.read, hhead1, hcells1, Tape.init_ofBool_cells_ge x x.length le_rfl] + obtain ⟨c2, hstep2, hst2, hout2⟩ := lookup_handoff_step g S x c1 hst1 hread1_blank hout1 + set cval : List Bool := if x ∈ S then g x else [] with hcval + obtain ⟨c3, hwriteloop, hhalt3, hout3⟩ := + lookup_write_loop g S [] cval (output_mem_suffixes_outputsFinset g S) c2 hst2 hout2 + have hlen : cval.length ≀ S.sup fun s => (g s).length := by + rw [hcval] + split + Β· exact Finset.le_sup (f := fun s => (g s).length) β€Ήx ∈ Sβ€Ί + Β· exact Nat.zero_le _ + refine ⟨c3, x.length + cval.length + 3, by dsimp only; omega, ?_, hhalt3, ?_⟩ + Β· have hreach := + reachesIn.step hstep0 + (reachesIn_trans (lookupTM g S) hreadloop + (reachesIn.step hstep2 hwriteloop)) + have heq : x.length + (cval.length + 1 + 1) + 1 = x.length + cval.length + 3 := by omega + rwa [heq] at hreach + Β· have hres : c3.output.HasOutput cval := by + have h := hout3 + rw [List.nil_append] at h + exact h.hasOutput + exact hres + +end TM.FinsetDomain + +open Polynomial in +/-- Internal proof that a function supported on a finite set belongs to `FP`: +the lookup machine's linear time bound is packaged as a degree-one polynomial. -/ +theorem ite_mem_finset_mem_FP_internal (g : List Bool β†’ List Bool) (S : Finset (List Bool)) : + (fun s => if s ∈ S then g s else []) ∈ FP := by + rw [mem_FP_iff_computesInTime_polynomial] + refine ⟨0, TM.FinsetDomain.lookupTM g S, X + C ((S.sup fun s => (g s).length) + 3), ?_⟩ + have heval : (X + C ((S.sup fun s => (g s).length) + 3)).eval + = fun m : β„• => m + (S.sup fun s => (g s).length) + 3 := by + funext m + simp only [eval_add, eval_X, eval_C] + omega + rw [heval] + exact TM.FinsetDomain.lookupTM_computesInTime g S + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal.lean new file mode 100644 index 0000000000..0432b4540b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Union + +/-! +# P closure properties β€” proof internals + +This file contains the proof helpers used by `DTIME_union` (stated in `P.lean`). +The key simulation theorem `unionTM_decidesInTime` establishes that the +composite machine from `TM.unionTM` correctly decides `L₁ βˆͺ Lβ‚‚`. +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity Asymptotics Filter + +variable {n₁ nβ‚‚ : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Core simulation theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- The union TM correctly decides `L₁ βˆͺ Lβ‚‚` with time bound `10Β·f₁ + fβ‚‚`. + + The factor 10 arises from Phase 1 (f₁ steps), transition (≀ 2Β·f₁ + 7 steps + absorbed into 9Β·f₁ since f₁ β‰₯ 1), and Phase 2 (fβ‚‚ steps). -/ +theorem unionTM_decidesInTime {tm₁ : TM n₁} {tmβ‚‚ : TM nβ‚‚} + {L₁ Lβ‚‚ : Language} {f₁ fβ‚‚ : β„• β†’ β„•} + (h₁ : tm₁.DecidesInTime L₁ f₁) (hβ‚‚ : tmβ‚‚.DecidesInTime Lβ‚‚ fβ‚‚) : + (unionTM tm₁ tmβ‚‚).DecidesInTime (L₁ βˆͺ Lβ‚‚) (fun n => 10 * f₁ n + fβ‚‚ n) := by + have hne₁ := qstart_ne_qhalt_of_decidesInTime _ h₁ + have hneβ‚‚ := qstart_ne_qhalt_of_decidesInTime _ hβ‚‚ + intro x + obtain ⟨c₁, t₁, ht₁, hreach₁, hhalt₁, hmem₁, hnmemβ‚βŸ© := h₁ x + obtain ⟨cβ‚‚, tβ‚‚, htβ‚‚, hreachβ‚‚, hhaltβ‚‚, hmemβ‚‚, hnmemβ‚‚βŸ© := hβ‚‚ x + -- t₁ β‰₯ 1 since qstart β‰  qhalt (halting at step 0 means qstart = qhalt) + have ht₁_pos : t₁ β‰₯ 1 := by + rcases t₁ with _ | t₁ + Β· cases hreach₁; exact absurd hhalt₁ hne₁ + Β· omega + have htβ‚‚_pos : tβ‚‚ β‰₯ 1 := by + rcases tβ‚‚ with _ | tβ‚‚ + Β· cases hreachβ‚‚; exact absurd hhaltβ‚‚ hneβ‚‚ + Β· omega + -- Head bounds: tape heads are ≀ t₁ after Phase 1 + have hbounds := head_le_of_reachesIn tm₁ hreach₁ + -- Phase 1: union machine simulates tm₁ for t₁ steps + have hphase1 := unionTM_phase1_simulation tm₁ tmβ‚‚ x hreach₁ ht₁_pos + -- Case split on whether tm₁ accepted + by_cases hx₁ : x ∈ L₁ + Β· -- tm₁ accepted: output cell 1 = Ξ“.one + have hcell := hmem₁ hx₁ + -- Derive output tape invariants from reachesIn + have hcell0_out := output_cells_zero_eq_start_of_reachesIn hreach₁ (Tape.init_cells_zero _) + have hnostart_out := output_cells_ne_start_of_reachesIn hreach₁ + (fun i hi => Tape.init_nil_cells_ne_start i hi) + -- Transition: rewind fake output, check, write Ξ“.one to real output, halt + obtain ⟨t_tr, c_final, htrans, hhalt_f, hout_f, htr_bound⟩ := + unionTM_transition_accept tm₁ tmβ‚‚ hhalt₁ hcell hcell0_out hnostart_out + -- Combine Phase 1 + transition + have hoh := hbounds.2.1 -- c₁.output.head ≀ t₁ + refine ⟨c_final, t₁ + t_tr, ?_, reachesIn_trans _ hphase1 htrans, hhalt_f, ?_, ?_⟩ + Β· show t₁ + t_tr ≀ 10 * f₁ x.length + fβ‚‚ x.length; omega + Β· exact fun _ => hout_f + Β· intro hx; exfalso; exact hx (Or.inl hx₁) + Β· -- tm₁ rejected: output cell 1 = Ξ“.zero + have hcell := hnmem₁ hx₁ + -- Derive output tape and input tape invariants from reachesIn + have hcell0_out := output_cells_zero_eq_start_of_reachesIn hreach₁ (Tape.init_cells_zero _) + have hnostart_out := output_cells_ne_start_of_reachesIn hreach₁ + (fun i hi => Tape.init_nil_cells_ne_start i hi) + have hinput_cells := input_cells_eq_of_reachesIn hreach₁ + -- Transition: full transition to Phase 2 + obtain ⟨t_tr, c_mid, htrans, hmid_state, hmid_input, hmid_work, hmid_output, htr_bound⟩ := + unionTM_transition_reject tm₁ tmβ‚‚ x hhalt₁ hcell hcell0_out hnostart_out hinput_cells + -- Phase 2: union machine simulates tmβ‚‚ for tβ‚‚ steps + obtain ⟨c_end, hphase2, hend_state, hend_output⟩ := + unionTM_phase2_simulation tm₁ tmβ‚‚ x hreachβ‚‚ hmid_state hmid_input hmid_work hmid_output + -- Combine Phase 1 + transition + Phase 2 + have hfull := reachesIn_trans _ (reachesIn_trans _ hphase1 htrans) hphase2 + -- The final config is halted + have hfinal_halted : (unionTM tm₁ tmβ‚‚).halted c_end := by + show c_end.state = Sum.inr (Sum.inr tmβ‚‚.qhalt) + rw [hend_state, hhaltβ‚‚] + have hih := hbounds.1 -- c₁.input.head ≀ t₁ + have hoh := hbounds.2.1 -- c₁.output.head ≀ t₁ + refine ⟨c_end, t₁ + t_tr + tβ‚‚, ?_, hfull, hfinal_halted, ?_, ?_⟩ + Β· show t₁ + t_tr + tβ‚‚ ≀ 10 * f₁ x.length + fβ‚‚ x.length; omega + Β· intro hx; rw [hend_output]; cases hx with + | inl h => exact absurd h hx₁ + | inr h => exact hmemβ‚‚ h + Β· intro hx; rw [hend_output] + have : x βˆ‰ Lβ‚‚ := fun h => hx (Set.mem_union_right _ h) + exact hnmemβ‚‚ this + +end TM + +-- ════════════════════════════════════════════════════════════════════════ +-- BigO arithmetic: 10Β·f₁ + fβ‚‚ =O (T₁ + Tβ‚‚) +-- ════════════════════════════════════════════════════════════════════════ + +/-- If `f₁ =O T₁` and `fβ‚‚ =O Tβ‚‚`, then `10Β·f₁ + fβ‚‚ =O (T₁ + Tβ‚‚)`. -/ +theorem bigO_union_bound {f₁ fβ‚‚ T₁ Tβ‚‚ : β„• β†’ β„•} + (ho₁ : f₁ =O T₁) (hoβ‚‚ : fβ‚‚ =O Tβ‚‚) : + (fun n => 10 * f₁ n + fβ‚‚ n) =O (fun n => T₁ n + Tβ‚‚ n) := + BigO.const_mul_add 10 ho₁ hoβ‚‚ + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Composition.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Composition.lean new file mode 100644 index 0000000000..e4deef5d61 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Composition.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolynomialComposition +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition + +/-! +# Closure of FP under composition β€” proof internals + +This module combines the sequential machine construction with polynomial +normal forms for its two component computations. The public theorem is in +`Complexitylib.Classes.P.Composition`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Internal proof that polynomial-time string functions are closed under +function composition. -/ +theorem mem_FP_comp_internal {f g : List Bool β†’ List Bool} + (hf : f ∈ FP) (hg : g ∈ FP) : (g ∘ f) ∈ FP := by + obtain ⟨nf, tmF, p, hfComp⟩ := + mem_FP_iff_computesInTime_polynomial_internal.mp hf + obtain ⟨ng, tmG, q, hgComp⟩ := + mem_FP_iff_computesInTime_polynomial_internal.mp hg + refine ⟨(Polynomial.C 4 * p + Polynomial.C 11 + q.comp p).natDegree, + TM.compositionTapeCount nf ng, TM.compositionTM tmF tmG, + (fun n => 4 * p.eval n + 11 + q.eval (p.eval n)), ?_, ?_⟩ + Β· exact TM.compositionTM_computesInTime hfComp hgComp + (polynomial_eval_mono_nat q) + Β· exact BigO.polynomial_composition_time p q + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/NormalForm.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/NormalForm.lean new file mode 100644 index 0000000000..b08dc8c3f0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/NormalForm.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs + +/-! +# Polynomial-time normal forms β€” proof internals + +The definitions of `P` and `FP` permit arbitrary time functions with Big-O +power bounds. This module replaces either witness by the evaluation of one +polynomial over the naturals, giving everywhere-valid monotone time bounds. + +The public theorem is in `Complexitylib.Classes.P.NormalForm`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Internal proof that `P` membership is equivalent to decision within the +evaluation of a natural-coefficient polynomial. -/ +theorem mem_P_iff_decidesInTime_polynomial_internal {L : Language} : + L ∈ P ↔ βˆƒ (k : β„•) (tm : TM k) (p : Polynomial β„•), + tm.DecidesInTime L p.eval := by + constructor + Β· intro hL + obtain ⟨d, k, tm, T, hdec, hbig⟩ := Set.mem_iUnion.mp hL + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hbig + exact ⟨k, tm, p, hdec.mono hp⟩ + Β· rintro ⟨k, tm, p, hdec⟩ + apply Set.mem_iUnion.mpr + refine ⟨p.natDegree, k, tm, p.eval, hdec, ?_⟩ + exact BigO.of_polynomial_bound p fun _ => le_rfl + +/-- Internal proof that `FP` membership is equivalent to computation within +the evaluation of a natural-coefficient polynomial. -/ +theorem mem_FP_iff_computesInTime_polynomial_internal + {f : List Bool β†’ List Bool} : + f ∈ FP ↔ βˆƒ (k : β„•) (tm : TM k) (p : Polynomial β„•), + tm.ComputesInTime f p.eval := by + constructor + Β· rintro ⟨d, k, tm, T, hcomp, hbig⟩ + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hbig + exact ⟨k, tm, p, hcomp.mono hp⟩ + Β· rintro ⟨k, tm, p, hcomp⟩ + refine ⟨p.natDegree, k, tm, p.eval, hcomp, ?_⟩ + exact BigO.of_polynomial_bound p fun _ => le_rfl + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Preimage.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Preimage.lean new file mode 100644 index 0000000000..f2a16277d4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Internal/Preimage.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition + +/-! +# Closure of P under FP preimages β€” proof internals + +The preprocessing function and target decider are first normalized to +natural-polynomial time bounds. Their executable sequential composition then +decides the preimage language within the polynomial obtained by composing +those bounds. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Internal proof that polynomial-time languages are closed under preimages +of polynomial-time string functions. -/ +theorem mem_P_preimage_internal {f : List Bool β†’ List Bool} {L : Language} + (hf : f ∈ FP) (hL : L ∈ P) : f ⁻¹' L ∈ P := by + obtain ⟨nf, tmF, p, hF⟩ := + mem_FP_iff_computesInTime_polynomial_internal.mp hf + obtain ⟨ng, tmG, q, hG⟩ := + mem_P_iff_decidesInTime_polynomial_internal.mp hL + let r := Polynomial.C 4 * p + Polynomial.C 11 + q.comp p + apply mem_P_iff_decidesInTime_polynomial_internal.mpr + refine ⟨TM.compositionTapeCount nf ng, TM.compositionTM tmF tmG, r, ?_⟩ + simpa [r, Polynomial.eval_comp] using + TM.compositionTM_decidesInTime hF hG (polynomial_eval_mono_nat q) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/NormalForm.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/NormalForm.lean new file mode 100644 index 0000000000..c8ee907613 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/NormalForm.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm + +/-! +# Polynomial-time normal forms + +`P` and `FP` membership can be witnessed by deterministic machines whose +running-time bounds are evaluations of polynomials with natural coefficients. +Unlike the arbitrary asymptotic witnesses in the class definitions, these +normalized bounds are valid on every input length and are monotone. + +## Main result + +- `mem_P_iff_decidesInTime_polynomial` β€” polynomial-evaluation normal form for `P` +- `mem_FP_iff_computesInTime_polynomial` β€” polynomial-evaluation normal form for `FP` +-/ + + +@[expose] public section + +namespace Complexity + +/-- A language belongs to `P` exactly when some deterministic machine decides +it within the evaluation of a natural-coefficient polynomial. -/ +theorem mem_P_iff_decidesInTime_polynomial {L : Language} : + L ∈ P ↔ βˆƒ (k : β„•) (tm : TM k) (p : Polynomial β„•), + tm.DecidesInTime L p.eval := by + exact mem_P_iff_decidesInTime_polynomial_internal + +/-- A function belongs to `FP` exactly when some deterministic machine +computes it within the evaluation of a natural-coefficient polynomial. -/ +theorem mem_FP_iff_computesInTime_polynomial {f : List Bool β†’ List Bool} : + f ∈ FP ↔ βˆƒ (k : β„•) (tm : TM k) (p : Polynomial β„•), + tm.ComputesInTime f p.eval := by + exact mem_FP_iff_computesInTime_polynomial_internal + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput.lean new file mode 100644 index 0000000000..760311da28 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.PairWithInput.Internal + +/-! +# Polynomial-time pairing with the original input + +## Main result + +- `mem_FP_pairWithInput` β€” if `f ∈ FP`, then `x ↦ pair (f x) x` is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +/-- A polynomial-time function can be evaluated and paired with its unchanged +original input in polynomial time. -/ +theorem mem_FP_pairWithInput {f : List Bool β†’ List Bool} + (hf : f ∈ FP) : (fun x => pair (f x) x) ∈ FP := + mem_FP_pairWithInput_internal hf + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput/Internal.lean new file mode 100644 index 0000000000..a7d2b18307 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/PairWithInput/Internal.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput + +/-! +# Polynomial-time pairing with the original input β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +/-- Internal closure of `FP` under `x ↦ pair (f x) x`. -/ +theorem mem_FP_pairWithInput_internal {f : List Bool β†’ List Bool} + (hf : f ∈ FP) : (fun x => pair (f x) x) ∈ FP := by + obtain ⟨k, tm, p, hcomp⟩ := + mem_FP_iff_computesInTime_polynomial_internal.mp hf + let q : Polynomial β„• := + Polynomial.C 5 * p + Polynomial.X + Polynomial.C 12 + apply mem_FP_iff_computesInTime_polynomial_internal.mpr + refine ⟨TM.pairWithInputTapeCount k, TM.pairWithInputTM tm, q, ?_⟩ + simpa [q, TM.pairWithInputTime] using! + TM.pairWithInputTM_computesInTime hcomp + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/Preimage.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Preimage.lean new file mode 100644 index 0000000000..6c6e9b9d38 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/Preimage.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Internal.Preimage + +/-! +# Closure of P under FP preimages + +## Main result + +- `mem_P_preimage` β€” polynomial-time preprocessing preserves membership in `P` +-/ + + +@[expose] public section + +namespace Complexity + +/-- If `f` is polynomial-time computable and `L` is polynomial-time +decidable, then the preimage language `{x | f x ∈ L}` is in `P`. -/ +theorem mem_P_preimage {f : List Bool β†’ List Bool} {L : Language} + (hf : f ∈ FP) (hL : L ∈ P) : f ⁻¹' L ∈ P := + mem_P_preimage_internal hf hL + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength.lean new file mode 100644 index 0000000000..ee5372039c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.UnaryLength.Internal + +/-! +# Polynomial-time unary input length + +## Main result + +- `unaryLength_mem_FP` β€” `x ↦ 1^|x|` is polynomial-time computable +-/ + + +@[expose] public section + +namespace Complexity + +/-- Writing one unary mark per input bit is a polynomial-time string +function. -/ +theorem unaryLength_mem_FP : + (fun x : List Bool => List.replicate x.length true) ∈ FP := + unaryLength_mem_FP_internal + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength/Internal.lean new file mode 100644 index 0000000000..ab9e459d51 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/P/UnaryLength/Internal.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength + +/-! +# Polynomial-time unary input length β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +/-- Internal proof that materializing unary input length is in `FP`. -/ +theorem unaryLength_mem_FP_internal : + (fun x : List Bool => List.replicate x.length true) ∈ FP := by + refine ⟨1, 0, TM.unaryLengthTM, + (fun n => n + 2), TM.unaryLengthTM_computesInTime 0, ?_⟩ + have hn : (fun n : β„• => n) =O ((Β· ^ 1) : β„• β†’ β„•) := by + simpa only [pow_one] using BigO.refl (fun n : β„• => n) + exact BigO.add hn (BigO.const_le_pow 2 1) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Pairing.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Pairing.lean new file mode 100644 index 0000000000..fde80e2c35 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Pairing.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import Mathlib.Algebra.Polynomial.Eval.Defs + +/-! +# Paired relation predicates + +This file adds the complexity-class predicates built on the neutral binary +pairing codec from `Complexitylib.Encoding.Pairing`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- A binary relation is **polynomially balanced** if witness length is bounded +by a polynomial in the input length. This is the standard short-witness +condition used in the definitions of NP, FNP, FNL, and related classes. -/ +def PolyBalanced (R : List Bool β†’ List Bool β†’ Prop) : Prop := + βˆƒ p : Polynomial β„•, βˆ€ x y, R x y β†’ y.length ≀ p.eval x.length + +/-- The pair language of `R` contains exactly the encodings `pair x y` for +which `R x y` holds. -/ +def pairLang (R : List Bool β†’ List Bool β†’ Prop) : Language := + {z | βˆƒ x y, z = pair x y ∧ R x y} + +/-- Membership of a canonically encoded pair reduces to the underlying +binary relation. -/ +@[simp] theorem mem_pairLang_pair (R : List Bool β†’ List Bool β†’ Prop) + (x y : List Bool) : + pair x y ∈ pairLang R ↔ R x y := by + constructor + Β· rintro ⟨x', y', hpair, hR⟩ + obtain ⟨hx, hy⟩ := pair_inj hpair + simpa [hx, hy] using hR + Β· intro hR + exact ⟨x, y, rfl, hR⟩ + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Randomized.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Randomized.lean new file mode 100644 index 0000000000..65f1c7b0be --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Randomized.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.Time + +/-! +# Randomized complexity classes + +This file defines the randomized complexity classes **BPP**, **RP**, **coRP**, +**ZPP**, and **PP**, along with the time-parameterized classes `BPTIME`, +`RTIME`, and `PPTIME`, and the predicate `NTM.IsPPT`. + +A PTM (probabilistic Turing machine) is an NTM where the two transition +functions are selected uniformly at random. Acceptance probability is defined +via `NTM.acceptProb`. + +## Helper predicates + +The acceptance-probability conditions shared across classes are factored into +`NTM.AcceptsWithProb` (lower-bounding acceptance on yes-instances) and +`NTM.RejectsWithProb` (upper-bounding acceptance on no-instances). +-/ + + +@[expose] public section + +namespace Complexity + + +namespace NTM + +variable {n : β„•} + +/-- The PTM accepts every `x ∈ L` with probability at least `c` within + `T(|x|)` steps. -/ +def AcceptsWithProb (tm : NTM n) (L : Language) (T : β„• β†’ β„•) (c : β„š) : Prop := + βˆ€ x, x ∈ L β†’ tm.acceptProb x (T x.length) β‰₯ c + +/-- The PTM accepts every `x βˆ‰ L` with probability at most `s` within + `T(|x|)` steps. -/ +def RejectsWithProb (tm : NTM n) (L : Language) (T : β„• β†’ β„•) (s : β„š) : Prop := + βˆ€ x, x βˆ‰ L β†’ tm.acceptProb x (T x.length) ≀ s + +/-- An NTM is **probabilistic polynomial-time (PPT)** if there exist a time + bound `f` and degree `d` such that every computation path halts within + `f(|x|)` steps and `f(n) = O(n^d)`. This is the central notion in + cryptographic security definitions. -/ +def IsPPT (tm : NTM n) : Prop := + βˆƒ (f : β„• β†’ β„•) (d : β„•), tm.AllPathsHaltIn f ∧ f =O (Β· ^ d) + +end NTM + +/-- `BPTIME(T)` is the class of languages decidable by a PTM in time `O(T(n))` + with two-sided bounded error (accept probability β‰₯ 2/3 on yes-instances, + ≀ 1/3 on no-instances). -/ +def BPTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.AllPathsHaltIn f ∧ + tm.AcceptsWithProb L f (2 / 3) ∧ + tm.RejectsWithProb L f (1 / 3) ∧ + f =O T} + +/-- **BPP** is the class of languages decidable by a PTM in polynomial time + with two-sided bounded error: `BPP = ⋃_k BPTIME(n^k)`. -/ +def BPP : Set Language := + ⋃ k : β„•, BPTIME (Β· ^ k) + +/-- `RTIME(T)` is the class of languages decidable by a PTM in time `O(T(n))` + with one-sided error: yes-instances accepted with probability β‰₯ 1/2, + no-instances never accepted (accept probability 0). -/ +def RTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.AllPathsHaltIn f ∧ + tm.AcceptsWithProb L f (1 / 2) ∧ + tm.RejectsWithProb L f 0 ∧ + f =O T} + +/-- **RP** is the class of languages decidable by a PTM in polynomial time + with one-sided error: `RP = ⋃_k RTIME(n^k)`. -/ +def RP : Set Language := + ⋃ k : β„•, RTIME (Β· ^ k) + +/-- **coRP** is the class of languages whose complements are in RP. + Equivalently: yes-instances always accepted (probability 1), no-instances + accepted with probability ≀ 1/2. -/ +def coRP : Set Language := complClass RP + +/-- **ZPP** (zero-error probabilistic polynomial time) is RP ∩ coRP. A language + is in ZPP iff it has a PTM with zero-error expected polynomial running + time. -/ +def ZPP : Set Language := RP ∩ coRP + +/-- `PPTIME(T)` is the class of languages decidable by a PTM in time `O(T(n))` + with unbounded error: `x ∈ L` iff the PTM accepts with probability + strictly greater than 1/2. -/ +def PPTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.AllPathsHaltIn f ∧ + (βˆ€ x, x ∈ L ↔ tm.acceptProb x (f x.length) > 1 / 2) ∧ + f =O T} + +/-- **PP** (probabilistic polynomial time) is the class of languages decidable + by a PTM in polynomial time with unbounded error: `PP = ⋃_k PPTIME(n^k)`. -/ +def PP : Set Language := + ⋃ k : β„•, PPTIME (Β· ^ k) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Space.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Space.lean new file mode 100644 index 0000000000..940f057c8f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Space.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics + +/-! +# Base space complexity classes + +This file defines the parametric space complexity classes `DSPACE(S)` and +`NSPACE(S)`, the building blocks from which polynomial and log-space classes +are derived. + +Work-tape head positions are bounded directly. The finite input region and its +first trailing blank are free, while farther input-head travel is charged. The +output verdict cell is free, while farther two-way output-head travel is also +charged. This prevents either infinite named tape from becoming hidden workspace. +-/ + + +@[expose] public section + +namespace Complexity + + +/-- `DSPACE(S)` is the class of languages decidable by a deterministic TM using + `O(S(n))` auxiliary space under `Cfg.WithinDecisionSpace`. -/ +def DSPACE (S : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : TM k) (f : β„• β†’ β„•), + tm.DecidesInSpace L f ∧ f =O S} + +/-- `NSPACE(S)` is the class of languages decidable by a nondeterministic TM + using `O(S(n))` auxiliary space under `Cfg.WithinDecisionSpace`. -/ +def NSPACE (S : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.DecidesInSpace L f ∧ f =O S} + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Classes/Time.lean b/LeanPool/BeyondBethe/Complexitylib/Classes/Time.lean new file mode 100644 index 0000000000..bb5ee8fc95 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Classes/Time.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics + +/-! +# Base time complexity classes + +This file defines the parametric time complexity classes `DTIME(T)` and +`NTIME(T)`, the building blocks from which polynomial, exponential, and +randomized time classes are derived. + +Both use `=O` (Mathlib's `IsBigO` lifted to `β„• β†’ β„•`) to express asymptotic +bounds. +-/ + + +@[expose] public section + +namespace Complexity + + +/-- `DTIME(T)` is the class of languages decidable by a deterministic TM in + time `O(T(n))` (AB Definition 1.6). The machine may have any number of + work tapes. -/ +def DTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : TM k) (f : β„• β†’ β„•), + tm.DecidesInTime L f ∧ f =O T} + +/-- `NTIME(T)` is the class of languages decidable by a nondeterministic TM in + time `O(T(n))` (AB Definition 2.1). The machine may have any number of + work tapes. -/ +def NTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (k : β„•) (tm : NTM k) (f : β„• β†’ β„•), + tm.DecidesInTime L f ∧ f =O T} + +/-- **Complement class** constructor: `complClass C = {L | Lᢜ ∈ C}`. + Used to uniformly define `coNP`, `coRP`, `coNL`, etc. -/ +def complClass (C : Set Language) : Set Language := + {L | Lᢜ ∈ C} + +/-- Membership in `complClass C` is exactly membership of the complement in `C`. -/ +@[simp] theorem mem_complClass {L : Language} {C : Set Language} : + L ∈ complClass C ↔ Lᢜ ∈ C := Iff.rfl + +/-- The complement class is involutive: `complClass (complClass C) = C`. -/ +theorem complClass_complClass (C : Set Language) : complClass (complClass C) = C := by + ext L; simp [complClass] + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Encoding.lean b/LeanPool/BeyondBethe/Complexitylib/Encoding.lean new file mode 100644 index 0000000000..b6c04fc0d8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Encoding.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Data +public import LeanPool.BeyondBethe.Complexitylib.Encoding.DataEncode +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Delimit +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Encoding/Data.lean b/LeanPool/BeyondBethe/Complexitylib/Encoding/Data.lean new file mode 100644 index 0000000000..17903fff90 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Encoding/Data.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module +public import Aesop.BuiltinRules +public import Mathlib.Data.Nat.Notation +public import Mathlib.Data.List.Basic +public import Mathlib.Tactic.Finiteness.Attr +public import Mathlib.Tactic.Push +public import Mathlib.Tactic.ToAdditive +public import Mathlib.Tactic.ToDual + +/-! +# Main internal data type for the rose tree machine (RTM) + +This file contains the main internal data structure for the RTM, `Data`, a rose tree. + +## Main definitions and notations + +- `Data` - the main data structure +- `Data.size` - the size of a `Data` object when encoded using parentheses, complexity results + use this size as the main measure. +- `Data.toBits` - a parenthesized (balanced-bracket) serialization into `List Bool`, with length + equal to `Data.size`, and injective (`Data.toBits_injective`). +- `Data.recL` - the main recursion principle for `Data` +- `Data.inductionL` - the main induction principle for `Data` + +-/ + + +@[expose] public section + +namespace Complexity + +/-- Rose-tree data structure, it allows us to encode most of Lean's data structures in a +"natural" manner -/ +inductive Data where + | l : List Data β†’ Data +deriving Repr + +mutual + /-- Decidable equality for `Data`, defined jointly with `Data.listDecEq`. -/ + def Data.decEq : βˆ€ (a b : Data), Decidable (a = b) + | .l xs, .l ys => + match Data.listDecEq xs ys with + | isTrue h => isTrue (congrArg Data.l h) + | isFalse h => isFalse fun heq => h (Data.l.inj heq) + /-- Decidable equality for `List Data`, defined jointly with `Data.decEq`. -/ + def Data.listDecEq : βˆ€ (xs ys : List Data), Decidable (xs = ys) + | [], [] => isTrue rfl + | [], _ :: _ => isFalse (by simp) + | _ :: _, [] => isFalse (by simp) + | x :: xs, y :: ys => + match Data.decEq x y, Data.listDecEq xs ys with + | isTrue hxy, isTrue hxys => isTrue (congrArgβ‚‚ List.cons hxy hxys) + | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1 + | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2 +end + +instance : DecidableEq Data := Data.decEq +instance : BEq Data := inferInstance +instance : LawfulBEq Data := inferInstance + +/-- The empty `Data` node, `Data.l []`. -/ +abbrev Data.empty := Data.l [] + + +/-- The list of children of a `Data` node. -/ +@[scoped grind =] +def Data.asList + | Data.l xs => xs + +@[scoped grind =] +lemma Data.asList_empty : Data.empty.asList = [] := by rfl + +@[simp, scoped grind =] +lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind + +@[simp, scoped grind =] +lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList] + +/-- The encoding length of `d`, relevant for complexity. +This is the encoded size assuming an encoding into parenthesized expressions. -/ +def Data.size : Data β†’ β„• + | Data.l xs => 2 + (xs.map Data.size |>.sum) + +@[simp] +lemma Data.size_le {d : Data} : 0 < d.size := by + obtain ⟨xs⟩ := d + grind [Data.size] + +@[simp, scoped grind =] +lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size] + +@[simp, scoped grind =] +lemma Data.cons_size {h : Data} {t : List Data} : + (Data.l (h :: t)).size = h.size + (Data.l t).size := by + simp [Data.size] + grind + +lemma Data.size_lt_of_mem {c : Data} {xs : List Data} (hc : c ∈ xs) : + c.size < (Data.l xs).size := by + induction xs with + | nil => simp at hc + | cons a as ih => + rw [Data.cons_size] + rcases List.mem_cons.1 hc with h | h + Β· subst h; have := @Data.size_le (Data.l as); omega + Β· have := ih h; omega + +/-- Recursion principle for `Data`. -/ +@[elab_as_elim] +def Data.recL {motive : Data β†’ Sort*} + (nil : motive (Data.l [])) + (cons : βˆ€ (x : Data) (xs : List Data), + motive x β†’ motive (Data.l xs) β†’ motive (Data.l (x :: xs))) : + βˆ€ d, motive d + | .l [] => nil + | .l (x :: xs) => + cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs)) + +/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/ +@[elab_as_elim] +theorem Data.inductionL {motive : Data β†’ Prop} + (nil : motive (Data.l [])) + (cons : βˆ€ (x : Data) (xs : List Data), + motive x β†’ motive (Data.l xs) β†’ motive (Data.l (x :: xs))) + (d : Data) : motive d := + Data.recL nil cons d + +/-! ## Bitstring serialization + +`Data.toBits` serializes a `Data` value into a `List Bool` using a parenthesized +(balanced-bracket) encoding: `false` opens a node, its children are serialized in order, and +`true` closes the node. This matches `Data.size` exactly (`Data.length_toBits`) and is injective +(`Data.toBits_injective`), so any `DataEncode` instance yields an injective bitstring encoding +(see `Complexitylib.Encoding.DataEncode`). -/ + +/-- Serialize `Data` into a bitstring with a parenthesized (balanced-bracket) encoding: `false` +opens a node, the children are serialized in order, and `true` closes the node. -/ +def Data.toBits : Data β†’ List Bool + | Data.l xs => false :: ((xs.map Data.toBits).flatten ++ [true]) + +lemma Data.toBits_l (xs : List Data) : + (Data.l xs).toBits = false :: ((xs.map Data.toBits).flatten ++ [true]) := by + rw [Data.toBits] + +@[simp] +lemma Data.length_toBits (d : Data) : d.toBits.length = d.size := by + induction d using Data.inductionL with + | nil => simp [Data.toBits] + | cons x xs ihx ihxs => + simp only [Data.toBits, Data.size, List.map_cons, List.flatten_cons, List.length_cons, + List.length_append, List.length_flatten, List.map_map] at * + grind + +/-- One step of the stack-based `Data.fromBits` parser. The state is a stack of frames, each a +list of the sibling nodes completed so far at that nesting depth (outermost frame at the bottom). +Reading `false` opens a new (empty) frame; reading `true` closes the top frame into a `Data.l` +node and appends it to its parent. `none` is a permanent failure state (an unmatched `true`). -/ +def Data.fromBitsStep : Option (List (List Data)) β†’ Bool β†’ Option (List (List Data)) + | none, _ => none + | some stack, false => some ([] :: stack) + | some stack, true => + match stack with + | kids :: parent :: rest => some ((parent ++ [Data.l kids]) :: rest) + | _ => none + +/-- Decode a bitstring produced by `Data.toBits` back into a `Data` value, or `none` if it is not +a valid single serialization. This is a left inverse of `Data.toBits` (`Data.fromBits_toBits`). -/ +def Data.fromBits (bits : List Bool) : Option Data := + match bits.foldl Data.fromBitsStep (some [[]]) with + | some [[d]] => some d + | _ => none + +/-- Running `Data.fromBitsStep` over `d.toBits` appends the decoded `d` to the top frame of the +stack, leaving the rest of the stack untouched. This is the key lemma behind +`Data.fromBits_toBits`. -/ +theorem Data.foldl_fromBitsStep_toBits : + βˆ€ (d : Data) (top : List Data) (rest : List (List Data)), + d.toBits.foldl Data.fromBitsStep (some (top :: rest)) = some ((top ++ [d]) :: rest) := by + -- Strong induction on the size of `d`, so that each child (strictly smaller) can appeal to the + -- inductive hypothesis while a plain list induction consumes the children in order. + have key : βˆ€ (n : β„•) (d : Data) (top : List Data) (rest : List (List Data)), + d.size ≀ n β†’ + d.toBits.foldl Data.fromBitsStep (some (top :: rest)) = some ((top ++ [d]) :: rest) := by + intro n + induction n using Nat.strongRecOn with + | ind n IH => + rintro ⟨xs⟩ top rest hsz + -- Consuming the flattened children appends them, in order, to the current frame. + have L : βˆ€ (xs : List Data) (cur : List Data) (rest : List (List Data)), + (βˆ€ c ∈ xs, c.size < n) β†’ + (xs.map Data.toBits).flatten.foldl Data.fromBitsStep (some (cur :: rest)) + = some ((cur ++ xs) :: rest) := by + intro xs + induction xs with + | nil => intro cur rest _; simp + | cons c cs ihcs => + intro cur rest hlt + have hc : c.size < n := hlt c (List.mem_cons_self ..) + simp only [List.map_cons, List.flatten_cons, List.foldl_append] + rw [IH c.size hc c cur rest (Nat.le_refl _), + ihcs (cur ++ [c]) rest (fun c' hc' => hlt c' (List.mem_cons_of_mem _ hc'))] + simp + rw [Data.toBits_l] + simp only [List.foldl_cons, List.foldl_append, Data.fromBitsStep] + rw [L xs [] (top :: rest) (fun c hc => Nat.lt_of_lt_of_le (Data.size_lt_of_mem hc) hsz)] + simp + intro d top rest + exact key d.size d top rest (Nat.le_refl _) + +/-- `Data.fromBits` recovers any value serialized by `Data.toBits`. -/ +@[simp] +theorem Data.fromBits_toBits (d : Data) : Data.fromBits d.toBits = some d := by + simp only [Data.fromBits, Data.foldl_fromBitsStep_toBits, List.nil_append] + +/-- `Data.toBits` is injective: the parenthesized serialization determines the value. This follows +from `Data.fromBits` being a left inverse. -/ +theorem Data.toBits_injective : Function.Injective Data.toBits := by + intro a b h + have := Data.fromBits_toBits a + rw [h, Data.fromBits_toBits b] at this + exact Option.some.inj this.symm + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Encoding/DataEncode.lean b/LeanPool/BeyondBethe/Complexitylib/Encoding/DataEncode.lean new file mode 100644 index 0000000000..22474af982 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Encoding/DataEncode.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Data +public import Mathlib.Data.Nat.Bits +public import Mathlib.Data.List.Basic + +/-! +# Encodings into `Data` + +This file defines the class that is used to encode arbitrary data structures into `Data`, +so that RTMs (rose tree machines) can operate on them. + +Instances are provided for convenience for `Data` itself, `Bool`, `List Ξ±`, `Option Ξ±`, `Ξ± Γ— Ξ²`, +and `β„•` (binary encoding via `List Bool`) + +Every `DataEncode` instance also yields a *bitstring* encoding `DataEncode.bitstringEncode`, by +serializing the target `Data` value with `Data.toBits`. Since both the `DataEncode` instance and +`Data.toBits` are injective, `bitstringEncode` is injective too +(`DataEncode.bitstringEncode_injective`). +-/ + + +@[expose] public section + +namespace Complexity + +/-- Encoding of types into `Data`. -/ +class DataEncode (Ξ± : Type) where + /-- Encode a value of `Ξ±` as `Data`. -/ + encode : Ξ± β†’ Data + /-- The encoding is injective, so distinct values never collide. -/ + h_inj : encode.Injective + +instance : DataEncode Data where + encode b := b + h_inj := by intros a b h_eq; grind + +@[simp, scoped grind =] +lemma DataEncode_encode_data (d : Data) : DataEncode.encode d = d := rfl + +instance : DataEncode Bool where + encode b := if b then Data.l [ Data.l [] ] else Data.l [] + h_inj := by intros a b h_eq; grind + +instance (Ξ± : Type) [DataEncode Ξ±] : DataEncode (List Ξ±) where + encode xs := Data.l (xs.map DataEncode.encode) + h_inj := by + intro a b h + exact List.map_injective_iff.mpr DataEncode.h_inj (Data.l.inj h) + +@[simp, scoped grind =] +lemma DataEncode_list_nil {Ξ± : Type} [DataEncode Ξ±] : + DataEncode.encode ([] : List Ξ±) = Data.l [] := by + simp [DataEncode.encode] + +@[simp, scoped grind =] +lemma DataEncode_list_eq_nil_iff_nil {Ξ± : Type} [DataEncode Ξ±] (xs : List Ξ±) : + DataEncode.encode xs = Data.empty ↔ xs = [] := by + simp [DataEncode.encode] + +@[simp, scoped grind =] +lemma DataEncode_list_tail {Ξ± : Type} [DataEncode Ξ±] (xs : List Ξ±) : + (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by + simp [DataEncode.encode] + +instance (Ξ± : Type) [DataEncode Ξ±] : DataEncode (Option Ξ±) where + encode := fun + | none => Data.l [] + | some x => Data.l [DataEncode.encode x] + h_inj := by + intro a b h + grind [DataEncode.h_inj] + +@[simp] +lemma DataEncode_Option_empty {Ξ± : Type} [DataEncode Ξ±] (x : Option Ξ±) : + (DataEncode.encode x == Data.empty) = x.isNone := by + cases x <;> simp [DataEncode.encode, Data.empty] + +instance (Ξ± Ξ² : Type) [DataEncode Ξ±] [DataEncode Ξ²] : DataEncode (Ξ± Γ— Ξ²) where + encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b] + h_inj := by + intro ⟨a₁, bβ‚βŸ© ⟨aβ‚‚, bβ‚‚βŸ© h + grind [DataEncode.h_inj] + +lemma DataEncode_pair {Ξ± Ξ² : Type} [DataEncode Ξ±] [DataEncode Ξ²] (a : Ξ±) (b : Ξ²) : + DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by + simp [DataEncode.encode] + +instance : DataEncode β„• where + encode x := DataEncode.encode (Nat.bits x) + h_inj := by + intro a b h + have hb : a.bits = b.bits := DataEncode.h_inj h + have hrec : βˆ€ n : β„•, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by + intro n + induction n using Nat.binaryRec' with + | zero => simp + | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih] + have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb + simpa [hrec] using this + +/-- Encode a value into a bitstring (`List Bool`) by first encoding it into `Data` and then +serializing that with the parenthesized `Data.toBits`. This is the class-inferrable bitstring +encoding available for any type with a `DataEncode` instance. -/ +def DataEncode.bitstringEncode {Ξ± : Type} [DataEncode Ξ±] (a : Ξ±) : List Bool := + (DataEncode.encode a).toBits + +lemma DataEncode.bitstringEncode_def {Ξ± : Type} [DataEncode Ξ±] (a : Ξ±) : + DataEncode.bitstringEncode a = (DataEncode.encode a).toBits := rfl + +/-- The bitstring encoding is injective: distinct values yield distinct bitstrings. This composes +the injectivity of the `DataEncode` instance with that of `Data.toBits`. -/ +theorem DataEncode.bitstringEncode_injective {Ξ± : Type} [DataEncode Ξ±] : + Function.Injective (DataEncode.bitstringEncode (Ξ± := Ξ±)) := + Data.toBits_injective.comp DataEncode.h_inj + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Encoding/Delimit.lean b/LeanPool/BeyondBethe/Complexitylib/Encoding/Delimit.lean new file mode 100644 index 0000000000..f18be139fc --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Encoding/Delimit.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.List.Basic +public import Mathlib.Data.Nat.Init +public import Aesop.BuiltinRules +public import Mathlib.Tactic.Attr.Core +public import Mathlib.Tactic.Basic +public import Mathlib.Tactic.Push +public import Mathlib.Tactic.Widget.Calc +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# Self-delimiting blocks + +To concatenate binary strings into a single binary string, each piece must announce its own +end. This file defines the library's single framing operation and its parsers: + +- `delimit` frames a payload: each payload bit is doubled (`false ↦ [false, false]`, + `true ↦ [true, true]`) and the block is terminated by the separator `[false, true]`, + which no run of doubled bits can produce. +- `unpair?` parses one block off the front of the input, returning the payload and the + remaining suffix (`none` on malformed input). It is named for its role in the pairing + codec `Complexity.pair` (see `Complexitylib.Encoding.Pairing`), which is + `pair x y = delimit x ++ y`. +- `undelimitBlock`, `takeFirstBlock`, `hasBlock`, `tagBlock`, and `undelimitBlocks` are the + total helper functions machines compute when working with framed data. + +This file deliberately has no dependency on the machine or complexity-class layers, so the +machine-input pairing codec (`Complexitylib.Encoding.Pairing`) can build on it without import +cycles. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Frame a binary string as a self-delimiting block: each payload bit is doubled + (`false ↦ [false, false]`, `true ↦ [true, true]`) and the block is terminated by the + separator `[false, true]`, which no run of doubled bits can produce. -/ +def delimit (x : List Bool) : List Bool := + (x.flatMap fun b => [b, b]) ++ [false, true] + +@[simp] theorem delimit_nil : delimit [] = [false, true] := rfl + +@[simp] theorem delimit_cons (b : Bool) (l : List Bool) : + delimit (b :: l) = b :: b :: delimit l := by + simp [delimit] + +@[simp] theorem delimit_length (l : List Bool) : (delimit l).length = 2 * l.length + 2 := by + induction l with + | nil => rfl + | cons b l ih => simp only [delimit_cons, List.length_cons, ih]; omega + +/-- Parse one self-delimiting block off the front of the input. It scans doubled bits until + the first separator `[false, true]`, returning the decoded payload together with the + remaining suffix. Invalid doubled prefixes return `none`. -/ +def unpair? : List Bool β†’ Option (List Bool Γ— List Bool) + | [] => none + | false :: true :: y => some ([], y) + | false :: false :: z => + Option.map (fun (xy : List Bool Γ— List Bool) => (false :: xy.1, xy.2)) (unpair? z) + | true :: true :: z => + Option.map (fun (xy : List Bool Γ— List Bool) => (true :: xy.1, xy.2)) (unpair? z) + | _ => none + +/-- `unpair?` reads back the framing written by `delimit`: parsing one block off the front + of any input recovers the payload and the remaining suffix. -/ +@[simp] theorem unpair?_delimit_append (x y : List Bool) : + unpair? (delimit x ++ y) = some (x, y) := by + induction x with + | nil => simp [unpair?] + | cons b x ih => cases b <;> simp [unpair?, ih] + +/-- Soundness of the parser: a successful parse decomposes the input as the parsed payload's + framing followed by the leftover suffix. -/ +theorem eq_delimit_append_of_unpair?_eq_some : + βˆ€ {z x y : List Bool}, unpair? z = some (x, y) β†’ z = delimit x ++ y + | [], _, _, h => by simp [unpair?] at h + | [b], _, _, h => by cases b <;> simp [unpair?] at h + | false :: true :: rest, x, y, h => by + simp only [unpair?, Option.some.injEq, Prod.mk.injEq] at h + obtain ⟨rfl, rfl⟩ := h + rfl + | false :: false :: rest, x, y, h => by + simp only [unpair?, Option.map_eq_some_iff] at h + obtain ⟨⟨p₁, pβ‚‚βŸ©, hp, heq⟩ := h + obtain ⟨rfl, rfl⟩ : false :: p₁ = x ∧ pβ‚‚ = y := by simpa [Prod.ext_iff] using heq + simp only [eq_delimit_append_of_unpair?_eq_some hp, delimit_cons, List.cons_append] + | true :: true :: rest, x, y, h => by + simp only [unpair?, Option.map_eq_some_iff] at h + obtain ⟨⟨p₁, pβ‚‚βŸ©, hp, heq⟩ := h + obtain ⟨rfl, rfl⟩ : true :: p₁ = x ∧ pβ‚‚ = y := by simpa [Prod.ext_iff] using heq + simp only [eq_delimit_append_of_unpair?_eq_some hp, delimit_cons, List.cons_append] + | true :: false :: rest, _, _, h => by simp [unpair?] at h + +/- ## Total block helpers -/ + +/-- Strip the framing of a single self-delimiting block, returning its payload. On `delimit P` +this returns `P`. Unlike `unpair?`, this is total: it ignores any data trailing the first block +and maps malformed input to `[]`. -/ +def undelimitBlock : List Bool β†’ List Bool + | false :: true :: _ => [] + | false :: false :: rest => false :: undelimitBlock rest + | true :: _ :: rest => true :: undelimitBlock rest + | _ => [] + +@[simp] +theorem undelimitBlock_delimit (P : List Bool) : + undelimitBlock (delimit P) = P := by + induction P with + | nil => rfl + | cons b P ih => cases b <;> simp [undelimitBlock, ih] + +/-- Keep the leading self-delimiting block of a bitstring, dropping everything after it. On a +pair encoding `delimit x ++ w` this returns `delimit x`. -/ +def takeFirstBlock : List Bool β†’ List Bool + | false :: true :: _ => [false, true] + | false :: false :: rest => false :: false :: takeFirstBlock rest + | true :: c :: rest => true :: c :: takeFirstBlock rest + | l => l + +@[simp] +theorem takeFirstBlock_delimit_append (P Q : List Bool) : + takeFirstBlock (delimit P ++ Q) = delimit P := by + induction P with + | nil => rfl + | cons b P ih => cases b <;> simp [takeFirstBlock, ih] + +/-- Does the bitstring begin with a well-formed self-delimiting block? -/ +def hasBlock : List Bool β†’ Bool + | false :: true :: _ => true + | false :: false :: rest => hasBlock rest + | true :: true :: rest => hasBlock rest + | _ => false + +theorem hasBlock_eq_isSome_unpair? : + βˆ€ l : List Bool, hasBlock l = (unpair? l).isSome + | [] => rfl + | [b] => by cases b <;> rfl + | false :: true :: _ => rfl + | false :: false :: rest => by + simp only [hasBlock, unpair?, hasBlock_eq_isSome_unpair? rest] + cases unpair? rest <;> rfl + | true :: true :: rest => by + simp only [hasBlock, unpair?, hasBlock_eq_isSome_unpair? rest] + cases unpair? rest <;> rfl + | true :: false :: _ => rfl + +/-- Tag a bitstring with a leading `true` if it begins with a well-formed self-delimiting +block, and return the empty bitstring otherwise. On pair encodings this computes +`encode ∘ decode`. -/ +def tagBlock (l : List Bool) : List Bool := + bif hasBlock l then true :: l else [] + +/- ## Parsing a sequence of blocks -/ + +/-- Parse a sequence of self-delimiting blocks, using `fuel` to bound the number of blocks. + +This is the auxiliary, fuel-carrying implementation of `undelimitBlocks`; since every block +is nonempty, `input.length` is always enough fuel. -/ +def undelimitBlocksAux : β„• β†’ List Bool β†’ Option (List (List Bool)) + | _, [] => some [] + | 0, _ :: _ => none + | fuel + 1, input => do + let (block, rest) ← unpair? input + let blocks ← undelimitBlocksAux fuel rest + return block :: blocks + +/-- Parse a sequence of self-delimiting blocks off the front of the input. + +Since every block is nonempty, `input.length` bounds the number of blocks, so it always +suffices as fuel for `undelimitBlocksAux`. -/ +def undelimitBlocks (input : List Bool) : Option (List (List Bool)) := + undelimitBlocksAux input.length input + +theorem length_le_length_flatten_delimit (l : List (List Bool)) : + l.length ≀ ((l.map delimit).flatten).length := by + induction l with + | nil => simp + | cons b t ih => + simp only [List.map_cons, List.flatten_cons, List.length_append, List.length_cons, + delimit_length] + omega + +private theorem undelimitBlocksAux_flatten_delimit (l : List (List Bool)) : + βˆ€ fuel, l.length ≀ fuel β†’ undelimitBlocksAux fuel ((l.map delimit).flatten) = some l := by + induction l with + | nil => intro fuel _; cases fuel <;> rfl + | cons b t ih => + intro fuel hfuel + rw [List.length_cons] at hfuel + obtain ⟨fuel, rfl⟩ : βˆƒ f, fuel = f + 1 := ⟨fuel - 1, by omega⟩ + obtain ⟨hd, tl, hcons⟩ : βˆƒ hd tl, delimit b ++ (t.map delimit).flatten = hd :: tl := by + cases b <;> exact ⟨_, _, rfl⟩ + simp only [List.map_cons, List.flatten_cons, hcons, undelimitBlocksAux] + rw [← hcons, unpair?_delimit_append] + simp [ih fuel (by omega)] + +theorem undelimitBlocks_flatten_delimit (l : List (List Bool)) : + undelimitBlocks ((l.map delimit).flatten) = some l := + undelimitBlocksAux_flatten_delimit l _ (length_le_length_flatten_delimit l) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Encoding/Pairing.lean b/LeanPool/BeyondBethe/Complexitylib/Encoding/Pairing.lean new file mode 100644 index 0000000000..ee2a71800a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Encoding/Pairing.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Delimit +public import Mathlib.Data.Nat.Init +public import Aesop.BuiltinRules +public import Mathlib.Tactic.Attr.Core +public import Mathlib.Tactic.Basic +public import Mathlib.Tactic.Push +public import Mathlib.Tactic.Widget.Calc +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# Pairing binary strings + +This file defines the low-level self-delimiting pairing codec used by machine +inputs throughout Complexitylib. It deliberately has no dependency on the +machine or complexity-class layers, so parsers and encoders can reuse it +without introducing an import cycle. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Encode a pair of binary strings as a single binary string. + Each bit of `x` is doubled (`false ↦ [false, false]`, `true ↦ [true, true]`), + followed by the separator `[false, true]`, followed by `y` verbatim. + This encoding is injective and computable in linear time. -/ +def pair (x y : List Bool) : List Bool := + delimit x ++ y + +private theorem pair_nil_eq (y : List Bool) : + pair [] y = false :: true :: y := by + simp [pair] + +/-- One step of the doubling encoder: `pair` on `b :: x` prepends the + doubled bit `b, b`. -/ +theorem pair_cons_eq (b : Bool) (x y : List Bool) : + pair (b :: x) y = b :: b :: pair x y := by + simp [pair] + +/-- `|pair x y| = 2Β·|x| + 2 + |y|`. The `2Β·|x|` comes from doubling every + bit of `x`; the `+2` is the separator `[false, true]`. -/ +@[simp] theorem pair_length (x y : List Bool) : + (pair x y).length = 2 * x.length + 2 + y.length := by + induction x with + | nil => simp [pair]; omega + | cons b xs ih => + rw [pair_cons_eq, List.length_cons, List.length_cons, List.length_cons, ih] + omega + +/-- `pair` is injective: if `pair x₁ y₁ = pair xβ‚‚ yβ‚‚` then `x₁ = xβ‚‚` and +`y₁ = yβ‚‚`. -/ +theorem pair_inj {x₁ xβ‚‚ : List Bool} {y₁ yβ‚‚ : List Bool} + (h : pair x₁ y₁ = pair xβ‚‚ yβ‚‚) : x₁ = xβ‚‚ ∧ y₁ = yβ‚‚ := by + induction x₁ generalizing xβ‚‚ with + | nil => + rw [pair_nil_eq] at h + cases xβ‚‚ with + | nil => + rw [pair_nil_eq] at h + exact ⟨rfl, (List.cons.inj (List.cons.inj h).2).2⟩ + | cons b xβ‚‚' => + rw [pair_cons_eq] at h + have h1 := (List.cons.inj h).1 -- false = b + have h2 := (List.cons.inj (List.cons.inj h).2).1 -- true = b + exact absurd (h1.trans h2.symm) Bool.false_ne_true + | cons b₁ x₁' ih => + rw [pair_cons_eq] at h + cases xβ‚‚ with + | nil => + rw [pair_nil_eq] at h + have h1 := (List.cons.inj h).1 -- b₁ = false + have h2 := (List.cons.inj (List.cons.inj h).2).1 -- b₁ = true + exact absurd (h1.symm.trans h2) Bool.false_ne_true + | cons bβ‚‚ xβ‚‚' => + rw [pair_cons_eq] at h + have hb := (List.cons.inj h).1 -- b₁ = bβ‚‚ + have htail := (List.cons.inj (List.cons.inj h).2).2 -- pair x₁' y₁ = pair xβ‚‚' yβ‚‚ + have ⟨hx, hy⟩ := ih htail + subst hb; subst hx + exact ⟨rfl, hy⟩ + +/-- `unpair?` is a left inverse of `pair`: decoding an encoded pair + recovers exactly its two components. -/ +@[simp] theorem unpair?_pair (x y : List Bool) : + unpair? (pair x y) = some (x, y) := + unpair?_delimit_append x y + +/-- Soundness of the decoder: if `unpair?` succeeds on `z`, producing `(x, y)`, + then `z` was exactly the encoding `pair x y`. -/ +theorem eq_pair_of_unpair?_eq_some {z x y : List Bool} (h : unpair? z = some (x, y)) : + z = pair x y := + eq_delimit_append_of_unpair?_eq_some h + +/-- `unpair? z` returns `some (x, y)` if and only if `z = pair x y`, + characterizing exactly which strings are valid pair encodings. -/ +theorem unpair?_eq_some_iff {z x y : List Bool} : + unpair? z = some (x, y) ↔ z = pair x y := by + constructor + Β· exact eq_pair_of_unpair?_eq_some + Β· intro hz + subst hz + exact unpair?_pair x y + +/-- In `pair x y`, the first duplicated copy of `x[i]` sits at position `2*i`. -/ +theorem pair_getElem_left_first (x y : List Bool) (i : β„•) (hi : i < x.length) : + (pair x y)[2 * i]'(by rw [pair_length]; omega) = x[i]'hi := by + induction x generalizing i with + | nil => + cases hi + | cons b xs ih => + cases i with + | zero => + simp [pair_cons_eq] + | succ i => + have hi' : i < xs.length := by simpa using hi + change (b :: b :: pair xs y)[2 * (i + 1)]'( + by simp [pair_length]; omega) = xs[i]'hi' + have hshift : + (b :: b :: pair xs y)[2 * (i + 1)]'(by simp [pair_length]; omega) = + (pair xs y)[2 * i]'(by rw [pair_length]; omega) := by + calc + (b :: b :: pair xs y)[2 * (i + 1)]'(by simp [pair_length]; omega) + = (b :: pair xs y)[2 * i + 1]'(by simp [pair_length]; omega) := by + exact List.getElem_cons_succ b (b :: pair xs y) (2 * i + 1) + (by simp [pair_length]; omega) + _ = (pair xs y)[2 * i]'(by rw [pair_length]; omega) := by + exact List.getElem_cons_succ b (pair xs y) (2 * i) + (by simp [pair_length]; omega) + rw [hshift] + exact ih i hi' + +/-- In `pair x y`, the second duplicated copy of `x[i]` sits at position `2*i+1`. -/ +theorem pair_getElem_left_second (x y : List Bool) (i : β„•) (hi : i < x.length) : + (pair x y)[2 * i + 1]'(by rw [pair_length]; omega) = x[i]'hi := by + induction x generalizing i with + | nil => + cases hi + | cons b xs ih => + cases i with + | zero => + simp [pair_cons_eq] + | succ i => + have hi' : i < xs.length := by simpa using hi + change (b :: b :: pair xs y)[2 * (i + 1) + 1]'( + by simp [pair_length]; omega) = xs[i]'hi' + have hshift : + (b :: b :: pair xs y)[2 * (i + 1) + 1]'(by simp [pair_length]; omega) = + (pair xs y)[2 * i + 1]'(by rw [pair_length]; omega) := by + calc + (b :: b :: pair xs y)[2 * (i + 1) + 1]'(by simp [pair_length]; omega) + = (b :: pair xs y)[2 * i + 2]'(by simp [pair_length]; omega) := by + exact List.getElem_cons_succ b (b :: pair xs y) (2 * i + 2) + (by simp [pair_length]; omega) + _ = (pair xs y)[2 * i + 1]'(by rw [pair_length]; omega) := by + exact List.getElem_cons_succ b (pair xs y) (2 * i + 1) + (by simp [pair_length]; omega) + rw [hshift] + exact ih i hi' + +/-- The first separator bit in `pair x y` is `false`. -/ +theorem pair_getElem_sep_zero (x y : List Bool) : + (pair x y)[2 * x.length]'(by rw [pair_length]; omega) = false := by + induction x with + | nil => + simp [pair] + | cons b xs ih => + change (b :: b :: pair xs y)[2 * (xs.length + 1)]'( + by simp [pair_length]; omega) = false + have hshift : + (b :: b :: pair xs y)[2 * (xs.length + 1)]'(by simp [pair_length]; omega) = + (pair xs y)[2 * xs.length]'(by rw [pair_length]; omega) := by + calc + (b :: b :: pair xs y)[2 * (xs.length + 1)]'(by simp [pair_length]; omega) + = (b :: pair xs y)[2 * xs.length + 1]'(by simp [pair_length]; omega) := by + exact List.getElem_cons_succ b (b :: pair xs y) (2 * xs.length + 1) + (by simp [pair_length]; omega) + _ = (pair xs y)[2 * xs.length]'(by rw [pair_length]; omega) := by + exact List.getElem_cons_succ b (pair xs y) (2 * xs.length) + (by simp [pair_length]; omega) + rw [hshift] + exact ih + +/-- The second separator bit in `pair x y` is `true`. -/ +theorem pair_getElem_sep_one (x y : List Bool) : + (pair x y)[2 * x.length + 1]'(by rw [pair_length]; omega) = true := by + induction x with + | nil => + simp [pair] + | cons b xs ih => + change (b :: b :: pair xs y)[2 * (xs.length + 1) + 1]'( + by simp [pair_length]; omega) = true + have hshift : + (b :: b :: pair xs y)[2 * (xs.length + 1) + 1] = + (pair xs y)[2 * xs.length + 1] := by + have h₁ : 2 * xs.length + 2 + 1 < (b :: b :: pair xs y).length := by + simp [pair_length] + omega + have hβ‚‚ : 2 * xs.length + 1 + 1 < (b :: pair xs y).length := by + simp [pair_length] + omega + calc + (b :: b :: pair xs y)[2 * (xs.length + 1) + 1] + = (b :: pair xs y)[2 * xs.length + 2] := by + simpa only [Nat.mul_add, Nat.mul_one, Nat.add_assoc] using + List.getElem_cons_succ b (b :: pair xs y) (2 * xs.length + 2) + (h := h₁) + _ = (pair xs y)[2 * xs.length + 1] := by + simpa only [Nat.add_assoc] using + List.getElem_cons_succ b (pair xs y) (2 * xs.length + 1) + (h := hβ‚‚) + rw [hshift] + exact ih + +/-- Length of the doubled prefix used in `pair x y`. -/ +private theorem pair_flatMap_doubled_length (x : List Bool) : + (x.flatMap fun b => [b, b]).length = 2 * x.length := by + induction x with + | nil => + simp + | cons b xs ih => + rw [List.flatMap_cons, List.length_append, ih] + simp + omega + +/-- In `pair x y`, the suffix after the separator is exactly `y`. -/ +theorem pair_getElem_right (x y : List Bool) (j : β„•) (hj : j < y.length) : + (pair x y)[2 * x.length + 2 + j]'(by rw [pair_length]; omega) = y[j]'hj := by + have hdecomp : pair x y = (x.flatMap fun b => [b, b]) ++ [false, true] ++ y := rfl + have hflat := pair_flatMap_doubled_length x + have hprefix : + ((x.flatMap fun b => [b, b]) ++ [false, true]).length = 2 * x.length + 2 := by + rw [List.length_append, hflat] + rfl + have hge : + ((x.flatMap fun b => [b, b]) ++ [false, true]).length ≀ 2 * x.length + 2 + j := by + rw [hprefix] + omega + have hj' : + (2 * x.length + 2 + j) - + ((x.flatMap fun b => [b, b]) ++ [false, true]).length < y.length := by + rw [hprefix] + omega + calc + (pair x y)[2 * x.length + 2 + j]'(by rw [pair_length]; omega) + = ((x.flatMap fun b => [b, b]) ++ [false, true] ++ y)[2 * x.length + 2 + j]' + (by rw [← hdecomp, pair_length]; omega) := by + exact List.getElem_of_eq hdecomp _ + _ = y[(2 * x.length + 2 + j) - ((x.flatMap fun b => [b, b]) ++ [false, true]).length]'hj' := + List.getElem_append_right hge + _ = y[j]'hj := by + congr 1 + rw [hprefix] + omega + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Languages.lean b/LeanPool/BeyondBethe/Complexitylib/Languages.lean new file mode 100644 index 0000000000..b09e3c6421 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Languages.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Languages.LastBit + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Languages/LastBit.lean b/LeanPool/BeyondBethe/Complexitylib/Languages/LastBit.lean new file mode 100644 index 0000000000..a49f8da383 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Languages/LastBit.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Classes.Containments + +/-! +# `lastBitOne` and `lastBitZero`: final-symbol languages + +Strings whose last bit is `1` (resp. `0`); the empty string is not in +either language. Decided by a 3-state `scannerTM` instance: the scan state +is the last bit seen so far, or `none` if no bit has been read. + +## Main definitions + +- `Language.lastBitOne`, `Language.lastBitZero`. +- `TM.lastBitTM target` β€” `scannerTM` specialized to `target : Bool`. + +## Main results + +- `lastBitOne_in_DTIME`, `lastBitZero_in_DTIME` β€” both in `DTIME(n + 2)`. +- `lastBitOne_mem_P`, `lastBitZero_mem_P`. +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity + +namespace TM + +/-- Scanner for "last input bit equals `target`". Scan state: the last bit + seen so far as an `Option Bool` (`none` initially). -/ +def lastBitTM (target : Bool) : TM 0 := + scannerTM (S := Option Bool) none + (fun _ b => some b) + (fun s => if decide (s = some target) = true then Ξ“w.one else Ξ“w.zero) + +end TM + +namespace Language + +/-- Strings whose last bit is `0` (empty string excluded). -/ +def lastBitZero : Language := {x | x.getLast? = some false} + +/-- Strings whose last bit is `1` (empty string excluded). -/ +def lastBitOne : Language := {x | x.getLast? = some true} + +end Language + +-- ════════════════════════════════════════════════════════════════════════ +-- Fold characterization +-- ════════════════════════════════════════════════════════════════════════ + +/-- Folding `(fun _ b => some b)` over a list with seed `s` yields + `x.getLast?` if `x` is nonempty, else `s`. -/ +private theorem lastBit_fold : + βˆ€ (x : List Bool) (s : Option Bool), + x.foldl (fun _ b => some b) s = + (x.getLast?.orElse (fun _ => s)) := by + intro x + induction x with + | nil => intro s; simp + | cons b xs ih => + intro s + rw [List.foldl_cons, ih] + cases hxs : xs with + | nil => simp + | cons c cs => + simp [List.getLast?_cons, ← hxs] + +/-- The last-bit scanner fold from `none` is exactly `List.getLast?`. -/ +theorem lastBit_fold_eq_getLast? (x : List Bool) : + x.foldl (fun _ b => some b) none = x.getLast? := by + rw [lastBit_fold] + cases x.getLast? <;> simp + +-- ════════════════════════════════════════════════════════════════════════ +-- DTIME memberships +-- ════════════════════════════════════════════════════════════════════════ + +/-- **`lastBitZero ∈ DTIME(n + 2)`**. -/ +theorem lastBitZero_in_DTIME : + Language.lastBitZero ∈ DTIME (fun n => n + 2) := by + refine ⟨0, TM.lastBitTM false, fun n => n + 2, ?_, BigO.refl _⟩ + exact TM.scannerTM_decidesInTime (S := Option Bool) none + (fun _ b => some b) (fun s => decide (s = some false)) + (L := Language.lastBitZero) + (fun x => by + show (x.getLast? = some false) ↔ (decide (x.foldl _ none = some false) = true) + rw [lastBit_fold_eq_getLast?, decide_eq_true_iff]) + +/-- **`lastBitOne ∈ DTIME(n + 2)`**. -/ +theorem lastBitOne_in_DTIME : + Language.lastBitOne ∈ DTIME (fun n => n + 2) := by + refine ⟨0, TM.lastBitTM true, fun n => n + 2, ?_, BigO.refl _⟩ + exact TM.scannerTM_decidesInTime (S := Option Bool) none + (fun _ b => some b) (fun s => decide (s = some true)) + (L := Language.lastBitOne) + (fun x => by + show (x.getLast? = some true) ↔ (decide (x.foldl _ none = some true) = true) + rw [lastBit_fold_eq_getLast?, decide_eq_true_iff]) + +-- ════════════════════════════════════════════════════════════════════════ +-- P memberships +-- ════════════════════════════════════════════════════════════════════════ + +/-- **`lastBitZero ∈ P`**. -/ +theorem lastBitZero_mem_P : Language.lastBitZero ∈ P := by + refine Set.mem_iUnion.mpr ⟨1, DTIME_mono ?_ lastBitZero_in_DTIME⟩ + refine BigO.add ?_ (BigO.const_le_pow 2 1) + simpa using BigO.refl (fun n : β„• => n) + +/-- **`lastBitOne ∈ P`**. -/ +theorem lastBitOne_mem_P : Language.lastBitOne ∈ P := by + refine Set.mem_iUnion.mpr ⟨1, DTIME_mono ?_ lastBitOne_in_DTIME⟩ + refine BigO.add ?_ (BigO.const_le_pow 2 1) + simpa using BigO.refl (fun n : β„• => n) + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Mathlib.lean b/LeanPool/BeyondBethe/Complexitylib/Mathlib.lean new file mode 100644 index 0000000000..692c245b83 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Mathlib.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.FinsetPrefixes +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Mathlib/FinsetPrefixes.lean b/LeanPool/BeyondBethe/Complexitylib/Mathlib/FinsetPrefixes.lean new file mode 100644 index 0000000000..fc5a301309 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Mathlib/FinsetPrefixes.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.Finset.Union +public import Mathlib.Data.List.Infix + +/-! +# Finsets of prefixes and suffixes + +For a finite set `S` of lists, `Finset.prefixes S` is the finite set of all +prefixes of elements of `S`, and `Finset.suffixes S` the finite set of all +suffixes of elements of `S`. The two operations have dual APIs: membership +characterizations (`mem_prefixes`/`mem_suffixes`), self-membership, and +closure under taking further prefixes/suffixes. + +This file lives in `Complexitylib/Mathlib/` because it extends a Mathlib +type in its home namespace β€” the sanctioned exception to the `Complexity` +root-namespace rule. Its contents are candidates for upstreaming to Mathlib. +-/ + +@[expose] public section + +namespace Finset + +variable {Ξ± : Type*} [DecidableEq Ξ±] {S : Finset (List Ξ±)} + +/-- The finite set of all prefixes of elements of `S`. -/ +def prefixes (S : Finset (List Ξ±)) : Finset (List Ξ±) := + S.biUnion fun s => s.inits.toFinset + +/-- The finite set of all suffixes of elements of `S`. -/ +def suffixes (S : Finset (List Ξ±)) : Finset (List Ξ±) := + S.biUnion fun s => s.tails.toFinset + +theorem mem_prefixes {p : List Ξ±} : p ∈ S.prefixes ↔ βˆƒ s ∈ S, p <+: s := by + simp [prefixes, List.mem_inits] + +theorem mem_suffixes {w : List Ξ±} : w ∈ S.suffixes ↔ βˆƒ s ∈ S, w <:+ s := by + simp [suffixes, List.mem_tails] + +theorem mem_prefixes_self {s : List Ξ±} (hs : s ∈ S) : s ∈ S.prefixes := + mem_prefixes.2 ⟨s, hs, List.prefix_rfl⟩ + +theorem mem_suffixes_self {s : List Ξ±} (hs : s ∈ S) : s ∈ S.suffixes := + mem_suffixes.2 ⟨s, hs, List.suffix_rfl⟩ + +theorem nil_mem_prefixes (hS : S.Nonempty) : ([] : List Ξ±) ∈ S.prefixes := + let ⟨s, hs⟩ := hS + mem_prefixes.2 ⟨s, hs, List.nil_prefix⟩ + +theorem nil_mem_suffixes (hS : S.Nonempty) : ([] : List Ξ±) ∈ S.suffixes := + let ⟨s, hs⟩ := hS + mem_suffixes.2 ⟨s, hs, List.nil_suffix⟩ + +/-- `S.prefixes` is downward closed under taking prefixes. -/ +theorem mem_prefixes_of_prefix {p q : List Ξ±} (hpq : p <+: q) (hq : q ∈ S.prefixes) : + p ∈ S.prefixes := by + obtain ⟨s, hs, hqs⟩ := mem_prefixes.1 hq + exact mem_prefixes.2 ⟨s, hs, hpq.trans hqs⟩ + +/-- `S.suffixes` is downward closed under taking suffixes. -/ +theorem mem_suffixes_of_suffix {w v : List Ξ±} (hwv : w <:+ v) (hv : v ∈ S.suffixes) : + w ∈ S.suffixes := by + obtain ⟨s, hs, hvs⟩ := mem_suffixes.1 hv + exact mem_suffixes.2 ⟨s, hs, hwv.trans hvs⟩ + +end Finset diff --git a/LeanPool/BeyondBethe/Complexitylib/Mathlib/NatBits.lean b/LeanPool/BeyondBethe/Complexitylib/Mathlib/NatBits.lean new file mode 100644 index 0000000000..3eed214104 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Mathlib/NatBits.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Nat.Log +public import Mathlib.Data.Nat.Size +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Fixed-width binary encodings of natural numbers + +Big-endian, fixed-width binary encoding `Nat.toBits` with its exact decoder +`Nat.fromBits`, plus the little-endian views `Nat.toBitsLE` and +`Nat.fromBitsLE` used by local Turing-machine arithmetic. Both conventions +have exact length, truncation, round-trip, and fixed-width injectivity lemmas. +Values wider than the target width are truncated modulo `2 ^ w`. + +This file lives in `Complexitylib/Mathlib/` because it extends a Mathlib +type in its home (root) namespace β€” the sanctioned exception to the +`Complexity` root-namespace rule. Its contents are candidates for +upstreaming to Mathlib. +-/ + + +@[expose] public section + +/-- Encode a natural number as a big-endian binary list of exactly `w` bits. + Numbers larger than `2^w - 1` are truncated (mod 2^w). -/ +def Nat.toBits : β„• β†’ β„• β†’ List Bool + | 0, _ => [] + | w + 1, val => (val / 2 ^ w % 2 == 1) :: Nat.toBits w val + +theorem Nat.length_toBits : βˆ€ (w val : β„•), (Nat.toBits w val).length = w + | 0, _ => rfl + | w + 1, val => by simp [Nat.toBits, Nat.length_toBits w] + +/-- Decode a big-endian binary list to a natural number. -/ +def Nat.fromBits : List Bool β†’ β„• + | [] => 0 + | b :: rest => (if b then 1 else 0) * 2 ^ rest.length + Nat.fromBits rest + +/-- Decoded values are bounded by `2 ^ length`. -/ +theorem Nat.fromBits_lt_pow_length : βˆ€ (l : List Bool), Nat.fromBits l < 2 ^ l.length + | [] => by simp [Nat.fromBits] + | b :: rest => by + have ih := Nat.fromBits_lt_pow_length rest + simp only [Nat.fromBits, List.length_cons, pow_succ] + rcases b with _ | _ <;> simp <;> omega + +/-- `fromBits ∘ toBits w` reduces any input modulo `2 ^ w`. -/ +theorem Nat.fromBits_toBits_mod : βˆ€ (w val : β„•), + Nat.fromBits (Nat.toBits w val) = val % 2 ^ w + | 0, val => by simp [Nat.toBits, Nat.fromBits, Nat.mod_one] + | w + 1, val => by + have ih := Nat.fromBits_toBits_mod w val + simp only [Nat.toBits, Nat.fromBits, Nat.length_toBits, ih] + have hbit : (val / 2 ^ w) % 2 = if (val / 2 ^ w % 2 == 1) then 1 else 0 := by + rcases Nat.mod_two_eq_zero_or_one (val / 2 ^ w) with h | h <;> simp [h] + have hpow : (2 : β„•) ^ (w + 1) = 2 ^ w * 2 := by rw [pow_succ] + have hkey : val % 2 ^ (w + 1) = (val / 2 ^ w) % 2 * 2 ^ w + val % 2 ^ w := by + rw [hpow, Nat.mod_mul, Nat.mul_comm (2^w) _, Nat.add_comm] + rw [hkey, ← hbit] + +/-- `Nat.fromBits` is a left inverse of `Nat.toBits` on values below `2 ^ w`. -/ +theorem Nat.fromBits_toBits {w val : β„•} (hv : val < 2 ^ w) : + Nat.fromBits (Nat.toBits w val) = val := by + rw [Nat.fromBits_toBits_mod, Nat.mod_eq_of_lt hv] + +/-- Adding a multiple of `2^w` does not change the low `w` encoded bits. -/ +theorem Nat.toBits_add_pow_mul : βˆ€ (w val c : β„•), + Nat.toBits w (val + c * 2 ^ w) = Nat.toBits w val + | 0, _, _ => rfl + | w + 1, val, c => by + have hrw : val + c * 2 ^ (w + 1) = val + c * 2 * 2 ^ w := by + rw [pow_succ] + simp [Nat.mul_comm, Nat.mul_assoc] + have hdiv : (val + c * 2 * 2 ^ w) / 2 ^ w = val / 2 ^ w + c * 2 := + Nat.add_mul_div_right _ _ (Nat.two_pow_pos w) + simp only [hrw, Nat.toBits, hdiv, List.cons.injEq] + constructor + Β· rw [Nat.add_mul_mod_self_right] + Β· exact Nat.toBits_add_pow_mul w val (c * 2) + +/-- Fixed-width encoding recovers every bit list from its decoded value. -/ +theorem Nat.toBits_fromBits : βˆ€ bits : List Bool, + Nat.toBits bits.length (Nat.fromBits bits) = bits + | [] => rfl + | bit :: rest => by + have hlt := Nat.fromBits_lt_pow_length rest + have hval : Nat.fromBits (bit :: rest) = + Nat.fromBits rest + (if bit then 1 else 0) * 2 ^ rest.length := by + exact Nat.add_comm _ _ + change (_ :: _) = (_ :: _) + congr 1 + Β· rw [hval, Nat.add_mul_div_right _ _ (Nat.two_pow_pos _), Nat.div_eq_of_lt hlt] + cases bit <;> simp + Β· rw [hval, Nat.toBits_add_pow_mul, Nat.toBits_fromBits rest] + +/-- Decoding is injective among bit lists of the same width. -/ +theorem Nat.fromBits_inj_of_length_eq {first second : List Bool} + (hlen : first.length = second.length) + (hvalue : Nat.fromBits first = Nat.fromBits second) : first = second := by + have hfirst := Nat.toBits_fromBits first + rw [hvalue, hlen] at hfirst + rw [← hfirst, Nat.toBits_fromBits second] + +/-- Little-endian fixed-width bits, with the least significant bit first. -/ +def Nat.toBitsLE (width value : β„•) : List Bool := + (Nat.toBits width value).reverse + +/-- Decode a little-endian bit list. -/ +def Nat.fromBitsLE (bits : List Bool) : β„• := + Nat.fromBits bits.reverse + +/-- Little-endian encoding has exactly the requested width. -/ +@[simp] theorem Nat.length_toBitsLE (width value : β„•) : + (Nat.toBitsLE width value).length = width := by + simp [Nat.toBitsLE, Nat.length_toBits] + +/-- Little-endian decoding of a fixed-width encoding truncates modulo `2^width`. -/ +theorem Nat.fromBitsLE_toBitsLE_mod (width value : β„•) : + Nat.fromBitsLE (Nat.toBitsLE width value) = value % 2 ^ width := by + simp [Nat.fromBitsLE, Nat.toBitsLE, Nat.fromBits_toBits_mod] + +/-- Little-endian encoding exactly round-trips values that fit the width. -/ +theorem Nat.fromBitsLE_toBitsLE {width value : β„•} (hvalue : value < 2 ^ width) : + Nat.fromBitsLE (Nat.toBitsLE width value) = value := by + rw [Nat.fromBitsLE_toBitsLE_mod, Nat.mod_eq_of_lt hvalue] + +/-- Every little-endian list is recovered at its own fixed width. -/ +theorem Nat.toBitsLE_fromBitsLE (bits : List Bool) : + Nat.toBitsLE bits.length (Nat.fromBitsLE bits) = bits := by + unfold Nat.toBitsLE Nat.fromBitsLE + rw [show bits.length = bits.reverse.length by simp, + Nat.toBits_fromBits, List.reverse_reverse] + +/-- A little-endian list decodes below `2` raised to its width. -/ +theorem Nat.fromBitsLE_lt_pow_length (bits : List Bool) : + Nat.fromBitsLE bits < 2 ^ bits.length := by + unfold Nat.fromBitsLE + simpa using Nat.fromBits_lt_pow_length bits.reverse + +/-- Little-endian decoding is injective at a fixed width. -/ +theorem Nat.fromBitsLE_inj_of_length_eq {first second : List Bool} + (hlen : first.length = second.length) + (hvalue : Nat.fromBitsLE first = Nat.fromBitsLE second) : first = second := by + have hfirst := Nat.toBitsLE_fromBitsLE first + rw [hvalue, hlen] at hfirst + rw [← hfirst, Nat.toBitsLE_fromBitsLE second] + +private theorem Nat.fromBits_append_singleton : + βˆ€ (bits : List Bool) (bit : Bool), + Nat.fromBits (bits ++ [bit]) = + 2 * Nat.fromBits bits + (if bit then 1 else 0) + | [], bit => by cases bit <;> simp [Nat.fromBits] + | first :: rest, bit => by + rw [List.cons_append, Nat.fromBits, + Nat.fromBits_append_singleton rest bit] + simp only [List.length_append, List.length_singleton, pow_succ] + cases first <;> simp [Nat.fromBits] + omega + +/-- Little-endian decoding exposes its least-significant head bit. -/ +theorem Nat.fromBitsLE_cons (bit : Bool) (bits : List Bool) : + Nat.fromBitsLE (bit :: bits) = + (if bit then 1 else 0) + 2 * Nat.fromBitsLE bits := by + simp only [Nat.fromBitsLE, List.reverse_cons] + rw [Nat.fromBits_append_singleton] + omega + +/-- Decoding the canonical variable-width little-endian bits recovers the +original natural number. -/ +theorem Nat.fromBitsLE_bits : βˆ€ value : β„•, + Nat.fromBitsLE value.bits = value := by + intro value + induction value using Nat.binaryRec' with + | zero => simp [Nat.fromBitsLE, Nat.fromBits] + | bit bit value hvalue ih => + rw [Nat.bits_append_bit value bit hvalue, + Nat.fromBitsLE_cons, ih] + cases bit <;> simp [Nat.bit] + omega + +/-- The minimal fixed-width little-endian encoding is exactly the canonical +variable-width bit list. -/ +theorem Nat.toBitsLE_size (value : β„•) : + Nat.toBitsLE value.size value = value.bits := by + calc + Nat.toBitsLE value.size value = + Nat.toBitsLE value.bits.length (Nat.fromBitsLE value.bits) := by + congr 1 + Β· exact (Nat.size_eq_bits_len value).symm + Β· exact (Nat.fromBitsLE_bits value).symm + _ = value.bits := Nat.toBitsLE_fromBitsLE value.bits + +/-- Binary digit width is at most floor-log base two plus one. -/ +theorem Nat.size_le_log_two_add_one (value : β„•) : + value.size ≀ Nat.log 2 value + 1 := by + rw [Nat.size_le] + simpa only [Nat.succ_eq_add_one] using + Nat.lt_pow_succ_log_self (b := 2) (by omega) value + +/-- Every positive natural has binary digit width exactly floor-log base two +plus one. -/ +theorem Nat.size_eq_log_two_add_one {value : β„•} (hvalue : value β‰  0) : + value.size = Nat.log 2 value + 1 := by + apply le_antisymm (Nat.size_le_log_two_add_one value) + have hlower : Nat.log 2 value < value.size := by + rw [Nat.lt_size] + exact Nat.pow_log_le_self 2 hvalue + omega diff --git a/LeanPool/BeyondBethe/Complexitylib/Models.lean b/LeanPool/BeyondBethe/Complexitylib/Models.lean new file mode 100644 index 0000000000..b3ff2b6ee8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine.lean new file mode 100644 index 0000000000..6d72b3dd6d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Soundness +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookupRestore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dense +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Initialization +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Compiled +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode + +/-! +# Random access machines (surface) + +This is the public entry point for the library's Random Access Machine (RAM) +model: a register machine with indirect addressing, executed under a +**logarithmic-cost** time measure and a matching space measure. The model, +its executable semantics, and both cost measures are defined in +`Complexitylib.Models.RandomAccessMachine.Defs`; the operational metatheory is +proved in `…/Internal`; the soundness of the cost convention is established in +`…/Soundness`. + +## Main definitions + +- `RAM.Instr`, `RAM.Program`, `RAM.Cfg`, `RAM.step`, `RAM.run` β€” the model +- `RAM.logTimeUpto`, `RAM.unitTimeUpto`, `RAM.spaceUpto` β€” the resource measures +- `RAM.Program.DecidesInTime`, `RAM.Program.DecidesInSpace` β€” deciding a language +- `RAM.DTIME`, `RAM.DSPACE`, `RAM.P` β€” the RAM time/space classes, over the same + `Language = Set (List Bool)` interface as the Turing-machine classes `DTIME`, + `DSPACE`, so the two families are directly comparable + +## Main results + +- `RAM.logGap_squaring` β€” the **soundness theorem**: the squaring program family + has unit time `k + 1` but logarithmic time at least `2 ^ k`, so unit cost is + super-polynomially stronger than logarithmic cost. This is the formal reason + the library measures RAM time logarithmically and only then compares it to + Turing time. +- `RAM.unitTimeUpto_le_logTimeUpto` β€” the step count is always at most the + logarithmic time (every step costs `β‰₯ 1`). +- `RAM.Program.DecidesInTime.mono` β€” deciding is monotone in the time bound. +- `RAM.run_initCfg_finiteSupport` β€” the register file keeps finite support + along any run, so the space measure `RAM.Cfg.space` is a genuine finite sum. +- `RAM.TMConfig.decode_encode` β€” the explicit bounded TM-configuration layout + in RAM registers decodes exactly; registers beyond the state/head/cell blocks + are zero. +- `RAM.TMConfig.Step.compiled_encode_decodes` β€” the complete bounded dense + transition block compiles to concrete RAM code and decodes to the exact TM + successor with explicit logarithmic-time and peak-space bounds. +- `RAM.TMConfig.Sparse.decode_encode` β€” the fixed interleaved layout represents + and decodes every tape cell without a bound baked into the representation. +- `RAM.TMConfig.Sparse.loadOps_correct` β€” the fixed uniform transition prelude + computes runtime cell addresses, preserves the complete representation, and + loads the state and all named head symbols exactly. +- `RAM.TMConfig.Sparse.compiledUntilHalt_correct` β€” one concrete RAM program, + determined solely by the TM, follows any exact halting TM run and decodes to + its halted configuration with exact compiled cost and space preservation. +- `RAM.TMConfig.Sparse.compiledDecision_correct` β€” the fixed sparse simulator + includes the public input/output ABI, follows any exact halting TM run, and + returns the Boolean verdict in `Rβ‚€` with exact compiled cost and space. +- `RAM.TMConfig.Sparse.compiledDecision_resourceBound` β€” the same fixed program + has a concrete end-to-end logarithmic-cost and sparse-store bound depending + only on the TM, public input length, and simulated halting-run length. +- `RAM.TMConfig.Sparse.P_subset_RAM_P` β€” every polynomial-time Turing language + is decided in polynomial logarithmic-cost RAM time by the fixed sparse + simulator. +- `RAM.RegisterStore.Snapshot.decode_run` β€” a finite sparse address/value + snapshot interpreter preserves canonicality and decodes exactly to the RAM + run; its self-delimiting binary tape codec round-trips with a concrete + quadratic-size envelope. +- `RAM.RegisterStore.Snapshot.encode_run_length_le_logTime` β€” every reachable + encoded snapshot has an explicit quadratic envelope in initial store size, + fixed program literals, and charged RAM logarithmic time. +- `RAM.RegisterStore.Snapshot.encode_initial_run_length_le_logTime` β€” the same + envelope starts from the public `RAM.initCfg` ABI with explicit input-length + dependence. +- `RAM.RegisterStore.Machine.wordWidthTM_reachesIn_frame` β€” the first concrete + reverse-simulation parser phase scans a self-delimiting word's unary width + prefix in exact time, stops on its separator, and produces the width on a + canonical binary work tape. +- `RAM.RegisterStore.Machine.payloadBitTM_reachesIn_frame` β€” the concrete + payload leaf consumes and appends one fixed-width payload bit while preserving + every unrelated tape. +- `RAM.RegisterStore.Machine.wordPayloadTM_reachesIn_frame` β€” a canonical + binary counter and preserved width drive that leaf for exactly the payload + length, leaving the source at the next encoded word with an exact runtime. +- `RAM.RegisterStore.Machine.wordDecodeTM_reachesIn_frame_encode` β€” the complete + decoder consumes one canonical `WordCode.encode` prefix, recovers its payload, + and leaves the following encoded stream untouched; the companion + `wordDecodeTM_prefix_withinAuxSpace` bounds every run prefix's auxiliary + space. +- `RAM.RegisterStore.Machine.wordTargetRewind_reachesIn_frame` β€” a decoded + append-position payload rewinds to the canonical cell-one read convention in + linear time while preserving every framed tape. +- `TM.binaryEqTM_reachesIn_frame` β€” two canonical binary work tapes are compared + in linear time, with the equality bit written to a dedicated work tape and + every framed tape preserved. +- `TM.binaryRippleAddTM_reachesIn_frame` β€” two canonical binary operands are + preserved while their sum is written to a fresh result tape in time linear in + their bit widths, with a literal external frame and all-prefix space bound. +- `RAM.RegisterStore.Machine.entryDecodeTM_reachesIn_frame` β€” one canonical + sparse address/value entry is decoded in exact time, leaving the following + entry stream untouched; `entryDecodeTM_prefix_withinAuxSpace` bounds every + run prefix's auxiliary space. +- `RAM.RegisterStore.Machine.decodedAddressEqTM_reachesIn_frame` β€” the decoded + address is rewound and compared with a canonical query in linear time, with + both left markers and every framed tape preserved. +- `RAM.RegisterStore.Machine.entryMatchTM_reachesIn_frame` β€” one concrete + decode-and-compare unit consumes an encoded sparse entry, exposes its value + and equality flag, preserves a parked frame, and has explicit time/space + bounds ready for bounded iteration. +- `RAM.RegisterStore.Machine.entryMatchReadTM_reachesIn_frame` β€” the match flag + is rewound to cell one for direct controller inspection while preserving all + decoded scratch contracts and an explicit per-tape head bound. +- `RAM.RegisterStore.Machine.entryScanTM_hoareTime_frame` β€” one fixed bounded + scanner uses a runtime binary entry count, returns the first matching decoded + value or certifies a miss, and preserves every tape outside its ten-tape + assignment with explicit time and all-prefix space envelopes. +- `RAM.RegisterStore.Machine.entryLookupTM_hoareTime_frame` β€” the same concrete + scan is packaged as a sparse lookup whose decoded-value tape equals the pure + `RegisterStore.read` result, including the default-zero miss case. +- `RAM.RegisterStore.Machine.entryUpdateTM_hoareTime_frame` β€” one fixed + runtime-counted controller realizes the pure sparse-store `write`, including + copy, replacement, deletion, absent-address append, exact frames, and an + explicit time/all-prefix space envelope. +- `RAM.RegisterStore.Machine.binaryInstructionUpdateTM_hoareTime_frame` β€” + width-efficient addition, truncated subtraction, or multiplication feeds its + canonical result directly into sparse update, with no hidden value-counted + copy between phases and with an exact framed runtime. +- `RAM.RegisterStore.Machine.binaryInstructionUpdateTM_retargetOutput_hoareTime_frame` + β€” the same arithmetic/update kernel can place the updated encoded store on a + fresh work tape while keeping the public output blank and parked. +- `RAM.RegisterStore.Machine.programInstructionTM_hoareTime_frame` β€” one fixed + finite-control dispatch machine selects the RAM instruction named by the + canonical program counter and realizes its exact sparse snapshot step in a + fresh next-store buffer. +- `RAM.RegisterStore.Machine.programDecisionTM_hoareTime_ramRun` β€” one fixed + twenty-work-tape machine marshals the public input, iterates exact sparse RAM + steps through the first halt, and writes the RAM verdict to the public output. +- `RAM.RegisterStore.Machine.programDecisionTime_le_envelope` β€” the complete + simulator has a checked fourth-degree runtime envelope in input length and + charged RAM logarithmic time. +- `RAM.RegisterStore.Machine.denseProgramDecisionTM_hoareTime_ramRun` β€” the + optimized fixed twenty-work-tape machine keeps the public input immutable and + stores only a sparse tagged mutable overlay while realizing the same RAM run. +- `RAM.RegisterStore.Machine.denseProgramDecisionTime_le_envelope` β€” the + optimized complete simulator has a checked quadratic envelope in input length + plus charged RAM logarithmic time. +- `RAM.RegisterStore.Machine.RAM_DTIME_subset_DTIME_sq` β€” whenever `T` + asymptotically dominates `n + 1`, logarithmic-cost `RAM.DTIME(T)` is contained + in multitape `DTIME(TΒ²)`. +- `RAM.RegisterStore.Machine.RAM_P_eq_P` β€” logarithmic-cost RAM polynomial time + and deterministic multitape Turing polynomial time define the same class. +- `RAM.RegisterStore.Machine.wordEncodeTM_hoareTime_frame` and + `rewindEntryEncodeTM_hoareTime_frame` β€” canonical or arbitrarily positioned + decoded words and entries are re-emitted in the exact self-delimiting store + codec, with explicit time, space, and external-frame contracts. +- `TM.resetBinaryWorkTM_hoareTime_frame` β€” an arbitrary cursor over canonical + binary contents is rewound and cleared to the standard blank tape with an + explicit time/space envelope and literal external frame. +- `RAM.Structured.Switch.select_compiled` β€” finite numeric case dispatch has an + exact selected-branch transition count and transfers explicit logarithmic + cost and space envelopes to concrete RAM code. +- `RAM.TMConfig.Step.loadOps_correct` β€” the fixed TM-transition block's loading + phase preserves the represented configuration while recovering the finite + state and all named head symbols exactly. +- `RAM.Structured.Exec.compile_correct` β€” structured source execution compiles + with exact register, logarithmic-time, and peak-space preservation. +- `RAM.Structured.Hamming.compiled_performance` β€” a verified imperative + Hamming-weight program with an exact transition count, explicit logarithmic + time and peak-space bounds, and end-to-end source-to-RAM resource transfer. +- `RAM.Structured.Hamming.timeBound_bigO_quasilinear` and + `spaceBound_bigO_quasilinear` β€” both explicit budgets are `O(n Β· bitlen n)`. +- `RAM.Structured.Scanner.compiled_performance` β€” a reusable verified compiler + from numeric finite-state scanners to concrete logarithmic-cost RAM programs. +- `RAM.Structured.PairValidate.compiled_performance` β€” a table-driven + reimplementation of `TM.pairValidateTM`, with exact steps, explicit + logarithmic time/space, and agreement with `validPairEncoding`. +- `RAM.Structured.LastBit.compiled_performance` β€” a second typed-scanner + instance, agreeing with the existing last-bit languages. +- `RAM.Structured.ThreeSATSyntax.compiled_performance` β€” the existing 27-state + exact-3-CNF syntax automaton compiled with exact steps and language agreement. +- `RAM.Structured.UnaryDecode.compiled_performance` β€” a non-regular cursor + decoder for terminated-unary circuit fields, including successful and + truncated-input exits, exact steps, and the decoded suffix position. +- `RAM.Structured.GateEval.compiled_performance` β€” a branch-free twenty-step + decoded-gate kernel with indirect memo reads and append, exact logarithmic + cost, explicit peak space, and preservation of all existing wire entries. +- `RAM.Structured.GateStep.compiled_performance` β€” one fixed serialized-gate + program composing two unary cursor calls with the decoded-gate kernel at a + runtime-discovered memo base, with exact transitions and concrete transferred + time/space bounds. +- `RAM.Structured.GateStreamStep.compiled_correct` β€” the bounded split-layout + admission test: one routine consumes a gate from an arbitrary unread stream, + advances a separate memo, preserves the tail, and transfers its exact source + execution and resource measurements to concrete RAM execution. + +## Relationship to the Turing-machine models + +The RAM shares the library's `Language` interface, so `RAM.DTIME`/`RAM.DSPACE` +and the Turing-machine classes `DTIME`/`DSPACE` speak about the same objects. +The classical two-way simulation bounds that make the models polynomially +equivalent are (Cook–Reckhow, *Time bounded random access machines*, JCSS 7 +(1973), 354–375; van Emde Boas, *Machine models and simulations*, Handbook of +Theoretical Computer Science A, 1990): + +* **Turing machine β†’ RAM.** A `T(n)`-time multi-tape Turing machine is + simulated by a RAM in logarithmic time `O(T(n) Β· log T(n))`. +* **RAM β†’ Turing machine.** A `T(n)`-time logarithmic-cost RAM is simulated by + a multi-tape Turing machine in time `O(T(n)Β²)`. + +Both overheads are polynomial, so `RAM.DTIME` and `DTIME` yield the *same* +polynomial-time class: `RAM-P = P`. Under the **unit-cost** measure the +RAM β†’ TM direction fails β€” `RAM.logGap_squaring` exhibits a program whose +unit-time is linear but whose output already needs exponentially many Turing +steps to write β€” which is precisely why the model is defined with logarithmic +cost. The bounded dense transition block is proved end to end, including +selected actions, nested dispatch, concrete compilation, and explicit resource +bounds. That block is a bounded program family: its register layout depends on +the tape window, so it cannot by itself witness `RAM.DTIME`, whose program must +be fixed. The uniform replacement now has a fixed sparse interleaved +representation, checked runtime address/loading and action/dispatch layers, a +fixed compiled loop that follows an arbitrary exact halting TM run, and a +checked public-ABI marshaller and verdict extractor. The remaining TM-to-RAM +work is now narrower: the repeated sparse core and complete public +marshaller/extractor share a concrete envelope, a linear-times-word-width cost +theorem, and a checked logarithmic word-width bound. The fixed compiled program +now transfers `TM.DecidesInTime` to `RAM.Program.DecidesInTime`, packages the +result in `RAM.DTIME` at its explicit transformed bound, and proves the class +theorem `P βŠ† RAM.P`. The sharper parametric `DTIME(T)` statement still +requires an explicit input-length domination hypothesis: the public marshaller +necessarily costs `O(n Β· log n)`, while an arbitrary stated time bound `T` need +not dominate `n`. The reverse simulation is now checked end to end. +Finite-support register functions have canonical sparse snapshots whose binary +tape codec round-trips with an explicit length bound. Fixed lookup, update, +binary-arithmetic, control, cleanup, initialization, iteration, and output +machines realize every RAM instruction and complete halting run on twenty work +tapes. The original sparse public-input ABI retains an explicit fourth-degree +envelope as a simple fallback. The optimized machine instead leaves the dense +public input on its read-only tape and maintains a positive-tagged sparse +mutable overlay. Selected-width step accounting and a decreasing square +potential give a checked `O((n + T(n))Β²)` public-ABI bound. Consequently, +`RAM_DTIME_subset_DTIME_sq` gives the textbook `RAM.DTIME(T) βŠ† DTIME(TΒ²)` under +the explicit hypothesis `n + 1 = O(T(n))`. Choosing the least halting fuel also +transfers every `RAM.P` decider to `P`; together with the fixed sparse forward +simulator this proves `RAM.RegisterStore.Machine.RAM_P_eq_P`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +/-! ### A worked decider + +The two-instruction program `⟨imm 0 1⟩` overwrites the verdict register with `1` +and then halts (its program counter runs off the end). It decides the universal +language in constant logarithmic time, exercising the full `DecidesInTime` API +end to end. -/ + +/-- The always-accept program: set the verdict register to `1`. -/ +def acceptProg : Program := [Instr.imm 0 1] + +/-- On any input, `acceptProg` halts after one step with verdict `1`. -/ +theorem acceptProg_run (x : List Bool) : + (run acceptProg 1 (initCfg x)).verdict = 1 := by + rfl + +/-- `acceptProg` decides the universal language in constant logarithmic time. -/ +theorem acceptProg_decides : acceptProg.DecidesInTime Set.univ (fun _ => 2) := by + intro x + refine ⟨1, ?_, ?_, ?_, ?_⟩ + Β· rfl + Β· rfl + Β· intro _; rfl + Β· intro hx; exact absurd (Set.mem_univ x) hx + +/-- The universal language is in `RAM.DTIME` at a constant bound: a witness that + the RAM time classes are inhabited over the shared `Language` interface. -/ +theorem univ_mem_DTIME : Set.univ ∈ DTIME (fun _ => 2) := + ⟨acceptProg, (fun _ => 2), acceptProg_decides, BigO.refl _⟩ + +/-- The always-reject program: set the verdict register to `0`. -/ +def rejectProg : Program := [Instr.imm 0 0] + +/-- On any input, `rejectProg` halts after one step with verdict `0`. -/ +theorem rejectProg_run (x : List Bool) : + (run rejectProg 1 (initCfg x)).verdict = 0 := by rfl + +/-- `rejectProg` decides the empty language in constant logarithmic time, + exercising the rejection side of the `DecidesInTime` API. -/ +theorem rejectProg_decides : rejectProg.DecidesInTime (βˆ… : Language) (fun _ => 2) := by + intro x + refine ⟨1, ?_, ?_, ?_, ?_⟩ + Β· rfl + Β· show (1 : β„•) ≀ 2; omega + Β· intro hx; simp at hx + Β· intro _; rfl + +/-- The empty language is in `RAM.DTIME` at a constant bound (the rejection + counterpart of `univ_mem_DTIME`). -/ +theorem empty_mem_DTIME : (βˆ… : Language) ∈ DTIME (fun _ => 2) := + ⟨rejectProg, (fun _ => 2), rejectProg_decides, BigO.refl _⟩ + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes.lean new file mode 100644 index 0000000000..dbecd7bbd7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes.Defs + +/-! +# Random-access-machine complexity classes + +This surface exposes the logarithmic-cost RAM time and space classes and their +elementary monotonicity properties. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + + +/-- Deciding in logarithmic time is monotone in the time bound. -/ +theorem Program.DecidesInTime.mono {P : Program} {L : Language} {T T' : β„• β†’ β„•} + (hle : βˆ€ m, T m ≀ T' m) (h : P.DecidesInTime L T) : P.DecidesInTime L T' := by + intro x + obtain ⟨fuel, hhalt, hcost, hyes, hno⟩ := h x + exact ⟨fuel, hhalt, hcost.trans (hle x.length), hyes, hno⟩ + +/-- Deciding in logarithmic space is monotone in the space bound. -/ +theorem Program.DecidesInSpace.mono {P : Program} {L : Language} {S S' : β„• β†’ β„•} + (hle : βˆ€ m, S m ≀ S' m) (h : P.DecidesInSpace L S) : + P.DecidesInSpace L S' := by + intro x + obtain ⟨fuel, hhalt, hspace, hyes, hno⟩ := h x + exact ⟨fuel, hhalt, hspace.trans (hle x.length), hyes, hno⟩ + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes/Defs.lean new file mode 100644 index 0000000000..d4e3bdaff4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Classes/Defs.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics + +/-! +# Random-access-machine complexity classes: definitions + +This definitions layer places the logarithmic-cost RAM classes over the same +`Language` interface as the Turing-machine classes. It is intentionally +independent of either simulation direction. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + + +/-- `RAM.DTIME(T)` is the class of languages decided by a RAM in logarithmic +time `O(T(n))`. -/ +def DTIME (T : β„• β†’ β„•) : Set Language := + {L | βˆƒ (P : Program) (f : β„• β†’ β„•), P.DecidesInTime L f ∧ f =O T} + +/-- `RAM.DSPACE(S)` is the class of languages decided by a RAM in logarithmic +space `O(S(n))`. -/ +def DSPACE (S : β„• β†’ β„•) : Set Language := + {L | βˆƒ (P : Program) (f : β„• β†’ β„•), P.DecidesInSpace L f ∧ f =O S} + +/-- `RAM.P` is polynomial logarithmic-cost RAM time. -/ +def P : Set Language := + ⋃ k : β„•, DTIME (Β· ^ k) + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Defs.lean new file mode 100644 index 0000000000..2f67a89d8c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Defs.lean @@ -0,0 +1,264 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Algebra.BigOperators.Finprod +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import Mathlib.Data.Nat.Bits + +/-! +# Random access machines: model and cost measures + +This file defines a Random Access Machine (RAM) β€” a register machine with +indirect addressing β€” together with **logarithmic-cost** time and space +measures. The design follows the standard successor/register RAM of +Cook–Reckhow, *Time bounded random access machines* (JCSS 7 (1973), 354–375) +and the textbook presentations of Papadimitriou (*Computational Complexity*, +Β§2.6) and van Emde Boas (*Machine models and simulations*, Handbook of +Theoretical Computer Science A, 1990). Conventions are adapted for a clean +formalization where a text is silent or divergent, but the *cost measure* is +kept faithful to the literature, because it is exactly the cost measure that +determines whether the model is a sound stand-in for a Turing machine. + +## Why logarithmic cost (the soundness point) + +A RAM stores natural numbers of unbounded magnitude in each register. Under the +naive **unit-cost** measure β€” one time unit per instruction regardless of +operand size β€” a RAM can square a register repeatedly to build the number +`2 ^ (2 ^ k)` in `O(k)` steps. That number needs `2 ^ k` bits to write down, so +no Turing machine can even emit it in fewer than `2 ^ k` steps: unit-cost RAM +time is **super-polynomially** stronger than Turing time, and the two models are +*not* polynomially equivalent. Adopting unit cost and then comparing to Turing +machines would be a category error β€” the exact "reward hacking" this model is +designed to avoid. `RAM.logGap_squaring` in the surface file turns this into a +theorem about this very model. + +The **logarithmic-cost** measure charges each instruction the total bit-length +of the numbers it manipulates (operand *contents* and, for indirect operands, +the runtime *addresses*), plus a base cost of `1` so every step costs at least +one time unit. Under this measure the RAM is polynomially equivalent to the +multi-tape Turing machine of `Complexitylib.Models.TuringMachine`; the precise +two-way simulation bounds are recorded in the surface module +`Complexitylib.Models.RandomAccessMachine`. + +## Main definitions + +- `RAM.Instr` β€” the instruction set (immediate, `add`/`sub`/`mul`, indirect + `load`/`store`, conditional/unconditional jump, `halt`) +- `RAM.Cfg` β€” a configuration: a program counter and a register file `β„• β†’ β„•` +- `RAM.step`, `RAM.run` β€” executable single step and fuel-bounded run +- `RAM.bitlen` β€” the length function `l(v) = Nat.size v` (number of bits) +- `RAM.Instr.logCost` β€” the logarithmic cost of one instruction in a state +- `RAM.logTimeUpto`, `RAM.unitTimeUpto` β€” accumulated log-cost / step count +- `RAM.Cfg.space`, `RAM.spaceUpto` β€” logarithmic-cost space +- `RAM.initCfg` β€” input convention (length in `Rβ‚€`, bits in `R₁ … Rβ‚™`) +- `RAM.Program.DecidesInTime`, `RAM.Program.DecidesInSpace` β€” deciding a + `Language` with the verdict read from `Rβ‚€`, mirroring `TM.DecidesInTime` + +## Design notes + +- **Register file `β„• β†’ β„•`**: total and computable, so programs are executable + witnesses (`#eval`-able). Only finitely many registers are ever nonzero along + a run; this finite-support invariant makes the space measure well defined. +- **`bitlen v = Nat.size v`**: the number of binary digits, with `bitlen 0 = 0`, + `bitlen 1 = 1`, `bitlen (2^k) = k + 1`. Instruction costs add `1` so that each + step costs `β‰₯ 1` regardless of operand sizes. +- **Direct vs. indirect addressing**: register *literals* named in an + instruction (`d`, `s`, `t`, `a`) are program constants, bounded by the program + size, so the cost does not separately charge for them; runtime addresses + (`R a` in `load`/`store`) *are* charged via `bitlen (c.regs a)`. This keeps the + cost within a constant factor of the Cook–Reckhow measure while remaining + sound: every value read, computed, or written is charged its bit-length. +- **Out-of-range `pc` halts**: `curInstr` reads `Instr.halt` when `pc` is past the + program, so a program need not end in `halt` and jumps may target the end. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +/-- The RAM instruction set. Register indices and jump targets are natural + numbers. `add`/`sub`/`mul` are three-address; `sub` is truncated + subtraction (`Nat` monus). `load`/`store` use *indirect* addressing β€” the + accessed register index is itself the content of a register β€” which is what + makes the machine "random access". -/ +inductive Instr where + /-- `imm d v`: set `R d := v` (load an immediate constant). -/ + | imm (d v : β„•) + /-- `add d s t`: set `R d := R s + R t`. -/ + | add (d s t : β„•) + /-- `sub d s t`: set `R d := R s ∸ R t` (truncated subtraction). -/ + | sub (d s t : β„•) + /-- `mul d s t`: set `R d := R s * R t`. -/ + | mul (d s t : β„•) + /-- `load d a`: indirect load `R d := R (R a)`. -/ + | load (d a : β„•) + /-- `store a s`: indirect store `R (R a) := R s`. -/ + | store (a s : β„•) + /-- `jz s tgt`: if `R s = 0` jump to `tgt`, else fall through. -/ + | jz (s tgt : β„•) + /-- `jmp tgt`: unconditional jump to `tgt`. -/ + | jmp (tgt : β„•) + /-- `halt`: stop the machine. -/ + | halt + deriving Repr, DecidableEq, Inhabited + +/-- A RAM program is a finite list of instructions, indexed by the program + counter. -/ +abbrev Program := List Instr + +/-- A RAM configuration: the program counter and the register file. Register `i` + currently holds `regs i`. -/ +@[ext] +structure Cfg where + /-- The program counter (index of the next instruction). -/ + pc : β„• + /-- The register file: `regs i` is the content of register `i`. -/ + regs : β„• β†’ β„• + +/-- The length function `l(v)`: the number of binary digits of `v`. + `bitlen 0 = 0`, `bitlen 1 = 1`, `bitlen (2 ^ k) = k + 1`. This is the + quantity charged (per operand) by the logarithmic cost measure. -/ +def bitlen (v : β„•) : β„• := Nat.size v + +/-- The instruction the machine is about to execute. A program counter past the + end of the program reads as `halt`, so programs need not end in `halt`. -/ +def curInstr (P : Program) (c : Cfg) : Instr := (P[c.pc]?).getD Instr.halt + +/-- A configuration is halted (for a given program) when the current instruction + is `halt` β€” including the case of a program counter past the program end. -/ +def Halted (P : Program) (c : Cfg) : Prop := curInstr P c = Instr.halt + +instance (P : Program) (c : Cfg) : Decidable (Halted P c) := by + unfold Halted; infer_instance + +/-- Execute one instruction, producing the successor configuration. `halt` is a + no-op here; `step` only applies this to a non-halted configuration. -/ +def stepInstr : Instr β†’ Cfg β†’ Cfg + | .imm d v, c => { pc := c.pc + 1, regs := Function.update c.regs d v } + | .add d s t, c => { pc := c.pc + 1, regs := Function.update c.regs d (c.regs s + c.regs t) } + | .sub d s t, c => { pc := c.pc + 1, regs := Function.update c.regs d (c.regs s - c.regs t) } + | .mul d s t, c => { pc := c.pc + 1, regs := Function.update c.regs d (c.regs s * c.regs t) } + | .load d a, c => { pc := c.pc + 1, regs := Function.update c.regs d (c.regs (c.regs a)) } + | .store a s, c => { pc := c.pc + 1, regs := Function.update c.regs (c.regs a) (c.regs s) } + | .jz s tgt, c => if c.regs s = 0 then { c with pc := tgt } else { c with pc := c.pc + 1 } + | .jmp tgt, c => { c with pc := tgt } + | .halt, c => c + +/-- Step a RAM by one instruction (a no-op on a halted configuration). -/ +def step (P : Program) (c : Cfg) : Cfg := stepInstr (curInstr P c) c + +/-- The logarithmic cost of executing instruction `i` in configuration `c`: the + base cost `1` plus the bit-length of every value the instruction reads, + computes, or writes (and, for indirect operands, the runtime address). + + This is the crux of the model's soundness: every number the instruction + touches is charged its bit-length, so a run of total log-cost `T` can only + manipulate numbers of bit-length at most `T`. See the module docstring. -/ +def Instr.logCost (i : Instr) (c : Cfg) : β„• := + match i with + | .imm _ v => bitlen v + 1 + | .add _ s t => bitlen (c.regs s) + bitlen (c.regs t) + bitlen (c.regs s + c.regs t) + 1 + | .sub _ s t => bitlen (c.regs s) + bitlen (c.regs t) + 1 + | .mul _ s t => bitlen (c.regs s) + bitlen (c.regs t) + bitlen (c.regs s * c.regs t) + 1 + | .load _ a => bitlen (c.regs a) + bitlen (c.regs (c.regs a)) + 1 + | .store a s => bitlen (c.regs a) + bitlen (c.regs s) + 1 + | .jz s _ => bitlen (c.regs s) + 1 + | .jmp _ => 1 + | .halt => 1 + +/-- The logarithmic cost of the machine's next step. -/ +def stepLogCost (P : Program) (c : Cfg) : β„• := (curInstr P c).logCost c + +/-- Fuel-bounded run: execute up to `fuel` steps, stopping early once halted. + Once halted, the configuration is stationary (`run_halted`), so the final + configuration is independent of any fuel large enough to reach a halt. -/ +def run (P : Program) : β„• β†’ Cfg β†’ Cfg + | 0, c => c + | fuel + 1, c => if Halted P c then c else run P fuel (step P c) + +/-- Accumulated **logarithmic time** over a fuel-bounded run: the sum of the + per-step logarithmic costs of the non-halted steps taken. -/ +def logTimeUpto (P : Program) : β„• β†’ Cfg β†’ β„• + | 0, _ => 0 + | fuel + 1, c => if Halted P c then 0 else stepLogCost P c + logTimeUpto P fuel (step P c) + +/-- Accumulated **unit time** over a fuel-bounded run: simply the number of + non-halted steps taken. Provided for contrast with `logTimeUpto`; the gap + between the two is exactly what makes unit cost unsound (see the surface + theorem `RAM.logGap_squaring`). -/ +def unitTimeUpto (P : Program) : β„• β†’ Cfg β†’ β„• + | 0, _ => 0 + | fuel + 1, c => if Halted P c then 0 else 1 + unitTimeUpto P fuel (step P c) + +/-- The logarithmic **space content** of a configuration: the total number of + bits needed to name and store every nonzero register β€” for each nonzero + register `i`, its address bits `bitlen i` plus its content bits + `bitlen (regs i)`. Registers holding `0` are free. The `finsum` is finite + exactly when the register file has finite support, which is an invariant of + every run started from `initCfg` (`run_finiteSupport`). -/ +noncomputable def Cfg.space (c : Cfg) : β„• := + βˆ‘αΆ  i, (if c.regs i = 0 then 0 else bitlen i + bitlen (c.regs i)) + +/-- Peak logarithmic space over a fuel-bounded run: the maximum space content of + any configuration visited (including the halted one). -/ +noncomputable def spaceUpto (P : Program) : β„• β†’ Cfg β†’ β„• + | 0, c => c.space + | fuel + 1, c => if Halted P c then c.space else max c.space (spaceUpto P fuel (step P c)) + +/-- The input convention. On input `x : List Bool`: + * register `0` holds the length `|x|`; + * register `i + 1` holds bit `x[i]` (as `0`/`1`) for `i < |x|`; + * all other registers hold `0`. + + Register `0` doubles as the accumulator/verdict register on output. -/ +def initRegs (x : List Bool) : β„• β†’ β„• := fun i => + if i = 0 then x.length + else match x[i - 1]? with + | some b => if b then 1 else 0 + | none => 0 + +/-- The initial configuration on input `x`: program counter `0`, registers set by + `initRegs`. -/ +def initCfg (x : List Bool) : Cfg := { pc := 0, regs := initRegs x } + +/-- A program *halts within `fuel` steps* on `c` when the fuel-bounded run + reaches a halted configuration. -/ +def HaltsIn (P : Program) (c : Cfg) (fuel : β„•) : Prop := Halted P (run P fuel c) + +/-- A program *halts* on `c` when it halts within some amount of fuel. -/ +def Halts (P : Program) (c : Cfg) : Prop := βˆƒ fuel, HaltsIn P c fuel + +/-- The **output** of a decider: register `0` at halt. `1` means accept, `0` + means reject. -/ +def Cfg.verdict (c : Cfg) : β„• := c.regs 0 + +/-- `P` decides `L` within logarithmic time `T(n)`: on every input `x`, the run + halts having spent log-time at most `T |x|`, with verdict `Rβ‚€ = 1` when + `x ∈ L` and `Rβ‚€ = 0` when `x βˆ‰ L`. Mirrors `TM.DecidesInTime`. -/ +def Program.DecidesInTime (P : Program) (L : Language) (T : β„• β†’ β„•) : Prop := + βˆ€ x, βˆƒ fuel, + Halted P (run P fuel (initCfg x)) ∧ + logTimeUpto P fuel (initCfg x) ≀ T x.length ∧ + (x ∈ L β†’ (run P fuel (initCfg x)).verdict = 1) ∧ + (x βˆ‰ L β†’ (run P fuel (initCfg x)).verdict = 0) + +/-- `P` decides `L` within logarithmic space `S(n)`: on every input `x`, the run + halts with the correct verdict and peak space at most `S |x|`. Mirrors + `TM.DecidesInSpace`. -/ +def Program.DecidesInSpace (P : Program) (L : Language) (S : β„• β†’ β„•) : Prop := + βˆ€ x, βˆƒ fuel, + Halted P (run P fuel (initCfg x)) ∧ + spaceUpto P fuel (initCfg x) ≀ S x.length ∧ + (x ∈ L β†’ (run P fuel (initCfg x)).verdict = 1) ∧ + (x βˆ‰ L β†’ (run P fuel (initCfg x)).verdict = 0) + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Internal.lean new file mode 100644 index 0000000000..8e3bf264a0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Internal.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import Mathlib.Tactic.Ring.RingNF + +/-! +# Random access machines: operational metatheory (proof internals) + +This module proves the structural facts about `RAM.run`, `RAM.logTimeUpto`, +`RAM.unitTimeUpto`, and register support that the surface theorems rely on: + +* **Unfolding lemmas** and the fixed-point behaviour of a halted configuration + (`step_halted`, `run_halted`, `logTimeUpto_halted`, `unitTimeUpto_halted`). +* **Run/cost algebra**: `run_one`, `run_succ_step`, and the additive + decompositions `run_add`, `logTimeUpto_add`, `unitTimeUpto_add`, giving + stationarity of the run and cost once halted, and monotonicity of the cost + in the fuel. +* **Cost lower bounds**: every executed step costs at least one time unit + (`Instr.one_le_logCost`), so the step count never exceeds the logarithmic + time (`unitTimeUpto_le_logTimeUpto`). +* **Finite support**: the register file has finite support along any run from + a finitely-supported start (`run_finiteSupport`), which is what makes the + `finsum`-based space measure `RAM.Cfg.space` a genuine finite sum. + +Not intended for human audit: the definitions in `Defs.lean` and the theorem +statements in the surface module carry the mathematical content. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +variable (P : Program) + +/-! ### Unfolding lemmas -/ + +@[simp] theorem run_zero (c : Cfg) : run P 0 c = c := rfl + +@[simp] theorem logTimeUpto_zero (c : Cfg) : logTimeUpto P 0 c = 0 := rfl + +@[simp] theorem unitTimeUpto_zero (c : Cfg) : unitTimeUpto P 0 c = 0 := rfl + +theorem run_succ (fuel : β„•) (c : Cfg) : + run P (fuel + 1) c = if Halted P c then c else run P fuel (step P c) := rfl + +theorem logTimeUpto_succ (fuel : β„•) (c : Cfg) : + logTimeUpto P (fuel + 1) c = + if Halted P c then 0 else stepLogCost P c + logTimeUpto P fuel (step P c) := rfl + +theorem unitTimeUpto_succ (fuel : β„•) (c : Cfg) : + unitTimeUpto P (fuel + 1) c = + if Halted P c then 0 else 1 + unitTimeUpto P fuel (step P c) := rfl + +/-! ### Halted configurations are fixed points -/ + +/-- Stepping a halted configuration is a no-op: `halt` leaves everything fixed. -/ +theorem step_halted {c : Cfg} (h : Halted P c) : step P c = c := by + unfold step + rw [show curInstr P c = Instr.halt from h] + rfl + +/-- Running a halted configuration for any amount of fuel leaves it fixed. -/ +theorem run_halted {c : Cfg} (h : Halted P c) (fuel : β„•) : run P fuel c = c := by + cases fuel with + | zero => rfl + | succ f => rw [run_succ, ite_eq_left h] + +/-- A halted configuration accumulates no logarithmic time. -/ +theorem logTimeUpto_halted {c : Cfg} (h : Halted P c) (fuel : β„•) : + logTimeUpto P fuel c = 0 := by + cases fuel with + | zero => rfl + | succ f => rw [logTimeUpto_succ, ite_eq_left h] + +/-- A halted configuration accumulates no unit time. -/ +theorem unitTimeUpto_halted {c : Cfg} (h : Halted P c) (fuel : β„•) : + unitTimeUpto P fuel c = 0 := by + cases fuel with + | zero => rfl + | succ f => rw [unitTimeUpto_succ, ite_eq_left h] + +/-! ### Run/cost algebra -/ + +/-- One unit of fuel performs exactly one step (a no-op if already halted). -/ +theorem run_one (c : Cfg) : run P 1 c = step P c := by + rw [show (1 : β„•) = 0 + 1 from rfl, run_succ] + by_cases h : Halted P c + Β· rw [ite_eq_left h, step_halted P h] + Β· rw [ite_eq_right h, run_zero] + +/-- The run decomposes additively: `a + b` steps is `b` steps after `a` steps. -/ +theorem run_add (a b : β„•) (c : Cfg) : run P (a + b) c = run P b (run P a c) := by + induction a generalizing c with + | zero => simp + | succ a ih => + rw [Nat.succ_add, run_succ, run_succ] + by_cases h : Halted P c + Β· rw [ite_eq_left h, ite_eq_left h] + exact (run_halted P h b).symm + Β· rw [ite_eq_right h, ite_eq_right h] + exact ih (step P c) + +/-- Running `n + 1` steps is one step after running `n` steps. -/ +theorem run_succ_step (n : β„•) (c : Cfg) : run P (n + 1) c = step P (run P n c) := by + rw [run_add P n 1, run_one] + +/-- Logarithmic time decomposes additively along the run. -/ +theorem logTimeUpto_add (a b : β„•) (c : Cfg) : + logTimeUpto P (a + b) c = + logTimeUpto P a c + logTimeUpto P b (run P a c) := by + induction a generalizing c with + | zero => simp + | succ a ih => + rw [Nat.succ_add, logTimeUpto_succ, logTimeUpto_succ, run_succ] + by_cases h : Halted P c + Β· rw [ite_eq_left h, ite_eq_left h, ite_eq_left h, logTimeUpto_halted P h b] + Β· rw [ite_eq_right h, ite_eq_right h, ite_eq_right h, ih (step P c)] + ring + +/-- Unit time decomposes additively along the run. -/ +theorem unitTimeUpto_add (a b : β„•) (c : Cfg) : + unitTimeUpto P (a + b) c = + unitTimeUpto P a c + unitTimeUpto P b (run P a c) := by + induction a generalizing c with + | zero => simp + | succ a ih => + rw [Nat.succ_add, unitTimeUpto_succ, unitTimeUpto_succ, run_succ] + by_cases h : Halted P c + Β· rw [ite_eq_left h, ite_eq_left h, ite_eq_left h, unitTimeUpto_halted P h b] + Β· rw [ite_eq_right h, ite_eq_right h, ite_eq_right h, ih (step P c)] + ring + +/-- Once halted after `f` steps, extra fuel does not change the configuration. -/ +theorem run_eq_of_halted_le {c : Cfg} {f f' : β„•} (hle : f ≀ f') + (h : Halted P (run P f c)) : run P f' c = run P f c := by + obtain ⟨g, rfl⟩ := Nat.le.dest hle + rw [run_add] + exact run_halted P h g + +/-- Once halted after `f` steps, extra fuel does not change the logarithmic time. -/ +theorem logTimeUpto_eq_of_halted_le {c : Cfg} {f f' : β„•} (hle : f ≀ f') + (h : Halted P (run P f c)) : logTimeUpto P f' c = logTimeUpto P f c := by + obtain ⟨g, rfl⟩ := Nat.le.dest hle + rw [logTimeUpto_add, logTimeUpto_halted P h g, Nat.add_zero] + +/-- Logarithmic time is monotone in the fuel. -/ +theorem logTimeUpto_mono {c : Cfg} {f f' : β„•} (hle : f ≀ f') : + logTimeUpto P f c ≀ logTimeUpto P f' c := by + obtain ⟨g, rfl⟩ := Nat.le.dest hle + rw [logTimeUpto_add] + exact Nat.le_add_right _ _ + +/-- Unit time is monotone in the fuel. -/ +theorem unitTimeUpto_mono {c : Cfg} {f f' : β„•} (hle : f ≀ f') : + unitTimeUpto P f c ≀ unitTimeUpto P f' c := by + obtain ⟨g, rfl⟩ := Nat.le.dest hle + rw [unitTimeUpto_add] + exact Nat.le_add_right _ _ + +/-! ### Cost lower bounds -/ + +/-- Every instruction costs at least one time unit under the logarithmic + measure (the base cost). -/ +theorem Instr.one_le_logCost (i : Instr) (c : Cfg) : 1 ≀ i.logCost c := by + cases i <;> simp only [Instr.logCost] <;> omega + +/-- Every executed step costs at least one time unit. -/ +theorem one_le_stepLogCost (c : Cfg) : 1 ≀ stepLogCost P c := + Instr.one_le_logCost _ _ + +/-- The number of steps taken never exceeds the logarithmic time: each step + costs at least one time unit, so log-time dominates the step count. -/ +theorem unitTimeUpto_le_logTimeUpto (fuel : β„•) (c : Cfg) : + unitTimeUpto P fuel c ≀ logTimeUpto P fuel c := by + induction fuel generalizing c with + | zero => simp + | succ f ih => + rw [unitTimeUpto_succ, logTimeUpto_succ] + by_cases h : Halted P c + Β· rw [ite_eq_left h, ite_eq_left h] + Β· rw [ite_eq_right h, ite_eq_right h] + have h1 : 1 ≀ stepLogCost P c := one_le_stepLogCost P c + have h2 := ih (step P c) + omega + +/-- If no halt occurs in the first `fuel` steps, the unit time is exactly the + fuel (every step is counted). -/ +theorem unitTimeUpto_eq_of_not_halted (c : Cfg) (fuel : β„•) + (h : βˆ€ j < fuel, Β¬ Halted P (run P j c)) : unitTimeUpto P fuel c = fuel := by + induction fuel generalizing c with + | zero => simp + | succ f ih => + have h0 : Β¬ Halted P c := h 0 (Nat.succ_pos f) + rw [unitTimeUpto_succ, ite_eq_right h0] + have hrec : unitTimeUpto P f (step P c) = f := by + apply ih + intro j hj + have hstep : run P j (step P c) = run P (j + 1) c := by + rw [run_succ, ite_eq_right h0] + rw [hstep] + exact h (j + 1) (by omega) + rw [hrec] + omega + +/-! ### Finite support of the register file -/ + +/-- The support of an updated function is contained in the support of the + original with the written index inserted. -/ +theorem support_update_subset (f : β„• β†’ β„•) (i v : β„•) : + Function.support (Function.update f i v) βŠ† insert i (Function.support f) := by + intro j hj + simp only [Function.mem_support] at hj + by_cases hji : j = i + Β· subst hji; exact Set.mem_insert _ _ + Β· rw [Function.update_of_ne hji] at hj + exact Set.mem_insert_of_mem _ hj + +/-- The initial register file has finite support: only registers `0 … |x|` can + be nonzero. -/ +theorem initRegs_finiteSupport (x : List Bool) : + (Function.support (initRegs x)).Finite := by + apply Set.Finite.subset (Finset.range (x.length + 1)).finite_toSet + intro i hi + simp only [Function.mem_support] at hi + simp only [Finset.coe_range, Set.mem_Iio] + by_contra hlt + rw [not_lt] at hlt + apply hi + have hi0 : i β‰  0 := by omega + simp only [initRegs, hi0, ite_false, List.getElem?_eq_none (show x.length ≀ i - 1 by omega)] + +/-- One instruction preserves finite support of the register file: each + instruction writes at most one register. -/ +theorem stepInstr_finiteSupport (i : Instr) (c : Cfg) + (h : (Function.support c.regs).Finite) : + (Function.support (stepInstr i c).regs).Finite := by + cases i with + | imm d v => exact (h.insert d).subset (support_update_subset c.regs d v) + | add d s t => exact (h.insert d).subset (support_update_subset c.regs d _) + | sub d s t => exact (h.insert d).subset (support_update_subset c.regs d _) + | mul d s t => exact (h.insert d).subset (support_update_subset c.regs d _) + | load d a => exact (h.insert d).subset (support_update_subset c.regs d _) + | store a s => exact (h.insert (c.regs a)).subset (support_update_subset c.regs (c.regs a) _) + | jz s tgt => dsimp only [stepInstr]; split <;> exact h + | jmp tgt => exact h + | halt => exact h + +/-- One step preserves finite support of the register file. -/ +theorem step_finiteSupport (c : Cfg) (h : (Function.support c.regs).Finite) : + (Function.support (step P c).regs).Finite := + stepInstr_finiteSupport _ c h + +/-- Finite support of the register file is a run invariant. -/ +theorem run_finiteSupport (fuel : β„•) (c : Cfg) + (h : (Function.support c.regs).Finite) : + (Function.support (run P fuel c).regs).Finite := by + induction fuel generalizing c with + | zero => simpa using h + | succ f ih => + rw [run_succ] + split + Β· exact h + Β· exact ih (step P c) (step_finiteSupport P c h) + +/-- Finite support along any run started from an initial configuration. This + guarantees `RAM.Cfg.space` is a genuine finite sum, not the `finsum` + fallback value `0`. -/ +theorem run_initCfg_finiteSupport (fuel : β„•) (x : List Bool) : + (Function.support (run P fuel (initCfg x)).regs).Finite := + run_finiteSupport P fuel (initCfg x) (initRegs_finiteSupport x) + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation.lean new file mode 100644 index 0000000000..6074efa7ab --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore.lean new file mode 100644 index 0000000000..7cac9d628b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Internal + +/-! +# Sparse RAM register stores on Turing tapes + +This module exposes the representation boundary used by the RAM-to-Turing- +machine simulation. A canonical finite list of nonzero address/value pairs +decodes to the RAM model's total register file. Functional reads and writes are +exact, every finite-support register file has a canonical representation, and +the self-delimiting binary snapshot codec round-trips. + +The concrete length theorem is the first resource bridge for the reverse +simulation: if the program counter, entry count, addresses, and values all have +bit-width at most `w`, a snapshot with `m` entries occupies at most +`(m + 1) * (4 * w + 2)` tape cells. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +/-- Sparse writing implements functional update exactly when addresses are +unique. -/ +theorem read_write (store : Store) (hstore : AddressesNodup store) + (address value target : β„•) : + read (write store address value) target = + Function.update (read store) address value target := + read_write_internal store hstore address value target + +/-- Sparse writing preserves unique addresses and omission of zero values. -/ +theorem write_canonical (store : Store) (hstore : Canonical store) + (address value : β„•) : + Canonical (write store address value) := + write_canonical_internal store hstore address value + +/-- Decoding after a sparse write is exactly functional update. -/ +theorem decode_write (store : Store) (hstore : AddressesNodup store) + (address value : β„•) : + decode (write store address value) = Function.update (decode store) address value := + decode_write_internal store hstore address value + +/-- Materializing any finite-support register file gives a canonical exact +representation. -/ +theorem ofRegs_represents (regs : β„• β†’ β„•) + (hfinite : (Function.support regs).Finite) : + Represents (ofRegs regs hfinite) regs := + ofRegs_represents_internal regs hfinite + +/-- The canonical public-input store has at most one entry per initialized +register. -/ +theorem initialStore_length_le (input : List Bool) : + (initialStore input).length ≀ input.length + 1 := + initialStore_length_le_internal input + +namespace WordCode + +/-- A canonical word code parses to its value and leaves any suffix untouched. -/ +theorem decodePrefix?_encode_append (value : β„•) (suffix : List Bool) : + decodePrefix? (encode value ++ suffix) = some (value, suffix) := + decodePrefix?_encode_append_internal value suffix + +/-- One self-delimiting word occupies twice its bit-width plus one cell. -/ +theorem encode_length (value : β„•) : + (encode value).length = 2 * bitlen value + 1 := + encode_length_internal value + +end WordCode + +namespace Entry + +/-- A canonical address/value code parses exactly and leaves its suffix. -/ +theorem decodePrefix?_encode_append (entry : Entry) (suffix : List Bool) : + decodePrefix? (encode entry ++ suffix) = some (entry, suffix) := + decodePrefix?_encode_append_internal entry suffix + +/-- An encoded entry charges twice the address width, twice the value width, +and two separators. -/ +theorem encode_length (entry : Entry) : + (encode entry).length = 2 * bitlen entry.1 + 2 * bitlen entry.2 + 2 := + encode_length_internal entry + +end Entry + +/-- One sparse write increases the actual encoded store by at most the code of +the address/value pair being written. Replacement and deletion can only make +this estimate smaller. -/ +theorem encodedStoreLength_write_le (store : Store) (address value : β„•) : + encodedStoreLength (write store address value) ≀ + encodedStoreLength store + (Entry.encode (address, value)).length := + encodedStoreLength_write_le_internal store address value + +namespace Snapshot + +/-- The explicit finite public-input snapshot decodes to `RAM.initCfg`. -/ +theorem initial_represents (input : List Bool) : + (initial input).Represents (RAM.initCfg input) := + initial_represents_internal input + +/-- The public-input snapshot's intrinsic width is at most the width of +`|input| + 1`. -/ +theorem initial_width_le (input : List Bool) : + (initial input).width ≀ bitlen (input.length + 1) := + initial_width_le_internal input + +/-- Materializing a finite-support RAM configuration gives a canonical exact +snapshot. -/ +theorem ofCfg_represents (cfg : Cfg) + (hfinite : (Function.support cfg.regs).Finite) : + (ofCfg cfg hfinite).Represents cfg := + ofCfg_represents_internal cfg hfinite + +/-- One sparse interpreter instruction preserves canonicality. -/ +theorem stepInstr_canonical (instruction : Instr) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + Canonical (stepInstr instruction snapshot).store := + stepInstr_canonical_internal instruction snapshot hcanonical + +/-- Decoding commutes exactly with one sparse interpreter instruction. -/ +theorem decode_stepInstr (instruction : Instr) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (stepInstr instruction snapshot).decode = + RAM.stepInstr instruction snapshot.decode := + decode_stepInstr_internal instruction snapshot hcanonical + +/-- The selected sparse step preserves canonicality. -/ +theorem step_canonical (program : Program) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + Canonical (snapshot.step program).store := + step_canonical_internal program snapshot hcanonical + +/-- Decoding commutes exactly with the selected RAM step. -/ +theorem decode_step (program : Program) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.step program).decode = RAM.step program snapshot.decode := + decode_step_internal program snapshot hcanonical + +/-- One sparse interpreter instruction grows the intrinsic width only to the +maximum of the old width plus one, its fixed literal width, and its charged +logarithmic runtime width. -/ +theorem width_stepInstr_le (instruction : Instr) (snapshot : Snapshot) : + (stepInstr instruction snapshot).width ≀ snapshot.stepWidthBound instruction := + width_stepInstr_le_internal instruction snapshot + +/-- A selected sparse step is bounded by the fixed program's literal width and +the RAM step's logarithmic charge. -/ +theorem width_step_le (program : Program) (snapshot : Snapshot) : + (snapshot.step program).width ≀ + max (snapshot.width + 1) + (max (programStaticWidth program) (RAM.stepLogCost program snapshot.decode)) := + width_step_le_internal program snapshot + +/-- Every finite sparse run preserves canonicality. -/ +theorem run_canonical (program : Program) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + Canonical (snapshot.run program fuel).store := + run_canonical_internal program fuel snapshot hcanonical + +/-- The complete sparse interpreter run decodes to the executable RAM run. -/ +theorem decode_run (program : Program) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).decode = RAM.run program fuel snapshot.decode := + decode_run_internal program fuel snapshot hcanonical + +/-- Each RAM instruction materializes at most one additional sparse entry. -/ +theorem length_run_le (program : Program) (fuel : β„•) (snapshot : Snapshot) : + Canonical snapshot.store β†’ + (snapshot.run program fuel).store.length ≀ + snapshot.store.length + RAM.unitTimeUpto program fuel snapshot.decode := + length_run_le_internal program fuel snapshot + +/-- Along a canonical sparse run, width grows linearly with executed fuel, the +fixed program literal width, and accumulated logarithmic RAM time. -/ +theorem width_run_le (program : Program) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).width ≀ + snapshot.width + RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode := + width_run_le_internal program fuel snapshot hcanonical + +/-- The live sparse-store code has amortized growth controlled by the resources actually +charged by the RAM run. In particular, this avoids the spurious product of the +number of entries and the maximum entry width: each executed instruction pays +once for its fixed destination width and for the operand/result bits in its +logarithmic cost. -/ +theorem encodedStoreLength_run_le (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + encodedStoreLength (snapshot.run program fuel).store ≀ + encodedStoreLength snapshot.store + + 4 * (RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) := + encodedStoreLength_run_le_internal program fuel snapshot hcanonical + +/-- Canonical snapshot serialization round-trips exactly. -/ +theorem decode?_encode (snapshot : Snapshot) : + decode? snapshot.encode = some snapshot := + decode?_encode_internal snapshot + +/-- A width-`w`, `m`-entry RAM snapshot occupies at most +`(m + 1) * (4 * w + 2)` Turing-tape cells. -/ +theorem encode_length_le (snapshot : Snapshot) (width : β„•) + (hpc : bitlen snapshot.pc ≀ width) + (hcount : bitlen snapshot.store.length ≀ width) + (hstore : βˆ€ entry ∈ snapshot.store, + bitlen entry.1 ≀ width ∧ bitlen entry.2 ≀ width) : + snapshot.encode.length ≀ (snapshot.store.length + 1) * (4 * width + 2) := + encode_length_le_internal snapshot width hpc hcount hstore + +/-- Every canonical snapshot code satisfies its intrinsic concrete tape-cell +envelope, without external side conditions. -/ +theorem encode_length_le_sizeBound (snapshot : Snapshot) : + snapshot.encode.length ≀ snapshot.sizeBound := + encode_length_le_sizeBound_internal snapshot + +/-- A snapshot code is bounded by its actual live-entry encoding plus the two +header words. This is the width-sensitive alternative to the product envelope +`Snapshot.sizeBound`. -/ +theorem encode_length_le_encodedStore (snapshot : Snapshot) : + snapshot.encode.length ≀ + encodedStoreLength snapshot.store + 4 * snapshot.width + 2 := + encode_length_le_encodedStore_internal snapshot + +/-- Combining the actual live-store charge with the width invariant gives a +linear-in-accumulated-cost representation bound for every canonical sparse +run, relative to the initial sparse encoding. -/ +theorem encode_run_length_le_amortized (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + encodedStoreLength snapshot.store + 4 * snapshot.width + + 8 * (RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2 := + encode_run_length_le_amortized_internal program fuel snapshot hcanonical + +/-- The materialized public-input store occupies at most one fixed-width entry +per initialized register. This records the current ABI's explicit +`O(n log n)` initialization term. -/ +theorem encodedStoreLength_initial_le (input : List Bool) : + encodedStoreLength (initialStore input) ≀ + (input.length + 1) * (4 * bitlen (input.length + 1) + 2) := + encodedStoreLength_initial_le_internal input + +/-- Public-input specialization of the amortized live-representation bound. +The accumulated part is linear in charged RAM time; the separate +`n * bitlen n` term comes from eagerly materializing all nonzero input +registers in the current snapshot ABI. -/ +theorem encode_initial_run_length_le_amortized + (program : Program) (fuel : β„•) (input : List Bool) : + ((initial input).run program fuel).encode.length ≀ + (input.length + 1) * (4 * bitlen (input.length + 1) + 2) + + 4 * bitlen (input.length + 1) + + 8 * (RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 2)) + 2 := + encode_initial_run_length_le_amortized_internal program fuel input + +/-- The canonical code of every reachable snapshot has an explicit product +bound: entry count grows by at most one per step, while width grows only with +fixed program literals and charged logarithmic RAM time. -/ +theorem encode_run_length_le (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + (snapshot.store.length + RAM.unitTimeUpto program fuel snapshot.decode + 1) * + (4 * (snapshot.width + RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2) := + encode_run_length_le_internal program fuel snapshot hcanonical + +/-- Eliminating actual step count via `unitTimeUpto ≀ logTimeUpto` gives a +pure logarithmic-time tape-size envelope. This is the quadratic representation +bound needed by the RAM-to-TM simulation. -/ +theorem encode_run_length_le_logTime (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + (snapshot.store.length + RAM.logTimeUpto program fuel snapshot.decode + 1) * + (4 * (snapshot.width + RAM.logTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2) := + encode_run_length_le_logTime_internal program fuel snapshot hcanonical + +/-- From the public RAM ABI, every reachable snapshot code has an explicit +quadratic envelope in input length, logarithmic RAM time, and one fixed program +constant. -/ +theorem encode_initial_run_length_le_logTime + (program : Program) (fuel : β„•) (input : List Bool) : + ((initial input).run program fuel).encode.length ≀ + (input.length + 1 + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) * + (4 * (bitlen (input.length + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input)) + 2) := + encode_initial_run_length_le_logTime_internal program fuel input + +end Snapshot + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment.lean new file mode 100644 index 0000000000..8986e9758d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment + +/-! +# RAM-to-TM time-class containment + +The fixed twenty-work-tape simulators transfer logarithmic-cost RAM deciders to +deterministic Turing deciders. The sparse fallback gives the original quartic +polynomial envelope; the dense-input overlay gives the sharp quadratic +parametric containment. Together with the sparse TM-to-RAM compiler, these +establish machine-model robustness of polynomial time. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Evaluating the packaged simulator polynomial gives its concrete runtime +envelope with the supplied polynomial RAM-time bound. -/ +theorem programDecisionPolynomial_eval (program : Program) + (p : Polynomial β„•) (inputLength : β„•) : + (programDecisionPolynomial program p).eval inputLength = + programDecisionEnvelope program inputLength (p.eval inputLength) := + programDecisionPolynomial_eval_internal program p inputLength + +/-- Every RAM decider transfers to the fixed sparse Turing simulator with the +explicit fourth-degree envelope around its logarithmic-time bound. -/ +theorem programDecision_decidesInTime + {L : Language} {T : β„• β†’ β„•} (program : Program) + (hdecides : program.DecidesInTime L T) : + (programDecisionTM standardControlInstructionTapes program).DecidesInTime L + (fun inputLength => + programDecisionEnvelope program inputLength (T inputLength)) := + programDecision_decidesInTime_internal program hdecides + +/-- Every RAM decider transfers to the optimized fixed dense-input simulator +with an explicit quadratic envelope in input length plus RAM time. -/ +theorem denseProgramDecision_decidesInTime + {L : Language} {T : β„• β†’ β„•} (program : Program) + (hdecides : program.DecidesInTime L T) : + (denseProgramDecisionTM standardControlInstructionTapes program).DecidesInTime L + (fun inputLength => + denseProgramDecisionEnvelope program inputLength (T inputLength)) := + denseProgramDecision_decidesInTime_internal program hdecides + +/-- Under the standard assumption that the RAM time bound dominates reading +the input, logarithmic-cost RAM time `T` is contained in deterministic Turing +time `TΒ²`. -/ +theorem RAM_DTIME_subset_DTIME_sq (T : β„• β†’ β„•) + (hinput : (fun inputLength => inputLength + 1) =O T) : + RAM.DTIME T βŠ† Complexity.DTIME (fun inputLength => (T inputLength) ^ 2) := + DTIME_subset_DTIME_sq_internal T hinput + +/-- Every polynomial logarithmic-cost RAM language is in deterministic +polynomial Turing time. -/ +theorem RAM_P_subset_P : RAM.P βŠ† Complexity.P := + P_subset_internal + +/-- Polynomial time is invariant between the concrete multitape TM and +logarithmic-cost RAM models formalized in the library. -/ +theorem RAM_P_eq_P : RAM.P = Complexity.P := + Set.Subset.antisymm RAM_P_subset_P + RAM.TMConfig.Sparse.P_subset_RAM_P + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Defs.lean new file mode 100644 index 0000000000..f018eb9130 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Defs.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import Mathlib.Analysis.SpecialFunctions.Pow.NNReal +public import Mathlib.Tactic.Measurability.Init +public import Mathlib.Tactic.NormNum.BigOperators +public import Mathlib.Tactic.NormNum.Irrational +public import Mathlib.Tactic.NormNum.IsCoprime +public import Mathlib.Tactic.NormNum.IsSquare +public import Mathlib.Tactic.NormNum.LegendreSymbol +public import Mathlib.Tactic.NormNum.ModEq +public import Mathlib.Tactic.NormNum.NatFactorial +public import Mathlib.Tactic.NormNum.NatFib +public import Mathlib.Tactic.NormNum.NatLog +public import Mathlib.Tactic.NormNum.NatSqrt +public import Mathlib.Tactic.NormNum.Ordinal +public import Mathlib.Tactic.NormNum.Parity +public import Mathlib.Tactic.NormNum.Prime +public import Mathlib.Tactic.NormNum.RealSqrt + +/-! +# RAM-to-TM time-class containment -- definitions + +This layer fixes the twenty-work-tape concrete simulator and packages its +fourth-degree resource envelope as a natural polynomial. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The canonical assignment of the eighteen data roles and one disjoint +program-counter role. The complete decision simulator adds one buffer tape, +so the resulting TM has twenty work tapes. -/ +def standardControlInstructionTapes : ControlInstructionTapes 19 where + data := + { idx := fun slot => ⟨slot.val, by omega⟩ + injective := by + intro i j h + apply Fin.ext + simpa using congrArg Fin.val h } + pc := ⟨18, by omega⟩ + pc_ne := by + intro slot h + have hval := congrArg Fin.val h + change 18 = slot.val at hval + omega + +/-- Polynomial obtained by substituting a polynomial RAM-time bound into the +checked concrete simulation envelope. -/ +noncomputable def programDecisionPolynomial (program : Program) + (p : Polynomial β„•) : + Polynomial β„• := + Polynomial.C (1000000000 * programResourceMagnitude program) * + (Polynomial.X + + Polynomial.C (programResourceMagnitude program + 2) * p + + Polynomial.C (programResourceMagnitude program + 4)) ^ 4 + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Internal.lean new file mode 100644 index 0000000000..2c373b1a80 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Containment/Internal.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Containment.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision +public import Mathlib.Tactic.ENatToNat +public import Mathlib.Tactic.ReduceModChar +public import Mathlib.Tactic.SetNotationForOrder + +/-! +# RAM-to-TM time-class containment -- proof internals + +The concrete sparse simulator is applied at the first halting fuel. Minimality +makes that fuel equal to unit-cost time, hence no larger than logarithmic RAM +time. This discharges the quantitative side condition of the checked runtime +envelope and lifts the simulation to deterministic polynomial time. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +theorem programDecisionPolynomial_eval_internal (program : Program) + (p : Polynomial β„•) (inputLength : β„•) : + (programDecisionPolynomial program p).eval inputLength = + programDecisionEnvelope program inputLength (p.eval inputLength) := by + simp [programDecisionPolynomial, programDecisionEnvelope, + programDecisionScale, Polynomial.eval_mul, Polynomial.eval_add, + Polynomial.eval_pow] + ring_nf + exact Or.inl trivial + +theorem programDecision_decidesInTime_internal + {L : Language} {T : β„• β†’ β„•} (program : Program) + (hdecides : program.DecidesInTime L T) : + (programDecisionTM standardControlInstructionTapes program).DecidesInTime L + (fun inputLength => + programDecisionEnvelope program inputLength (T inputLength)) := by + intro input + obtain ⟨fuel, hhalted, hcost, hyes, hno⟩ := hdecides input + let haltWitness : βˆƒ candidate, + RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := ⟨fuel, hhalted⟩ + let firstFuel := Nat.find haltWitness + have hfirstHalted : RAM.Halted program + (RAM.run program firstFuel (RAM.initCfg input)) := + Nat.find_spec haltWitness + have hfirstLe : firstFuel ≀ fuel := Nat.find_min' haltWitness hhalted + have hnotHalted : βˆ€ candidate < firstFuel, + Β¬ RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := by + intro candidate hcandidate + exact Nat.find_min haltWitness hcandidate + have hunit : RAM.unitTimeUpto program firstFuel (RAM.initCfg input) = + firstFuel := + RAM.unitTimeUpto_eq_of_not_halted program (RAM.initCfg input) firstFuel + hnotHalted + have hfuelCost : firstFuel ≀ + RAM.logTimeUpto program firstFuel (RAM.initCfg input) := by + calc + firstFuel = RAM.unitTimeUpto program firstFuel (RAM.initCfg input) := + hunit.symm + _ ≀ RAM.logTimeUpto program firstFuel (RAM.initCfg input) := + RAM.unitTimeUpto_le_logTimeUpto program firstFuel (RAM.initCfg input) + have hcostMono := RAM.logTimeUpto_mono program + (c := RAM.initCfg input) hfirstLe + have hfirstCost : RAM.logTimeUpto program firstFuel (RAM.initCfg input) ≀ + T input.length := le_trans hcostMono hcost + have hrunEq : RAM.run program fuel (RAM.initCfg input) = + RAM.run program firstFuel (RAM.initCfg input) := + RAM.run_eq_of_halted_le program hfirstLe hfirstHalted + have hmachine := programDecisionTM_hoareTime_ramRun + standardControlInstructionTapes program input firstFuel hfirstHalted + obtain ⟨final, time, htime, hreach, hfinalHalted, houtput⟩ := + hmachine (Tape.init (input.map Ξ“.ofBool)) + (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + have hresource := programDecisionTime_le_envelope + standardControlInstructionTapes program input firstFuel hfirstHalted hfuelCost + have henvelope := programDecisionEnvelope_mono_cost program input.length + (RAM.logTimeUpto program firstFuel (RAM.initCfg input)) (T input.length) + hfirstCost + refine ⟨final, time, le_trans htime (le_trans hresource henvelope), + hreach, hfinalHalted, ?_, ?_⟩ + Β· intro hmember + rw [houtput, registerVerdictOutput_cell_one] + have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 1 := by + rw [← hrunEq] + exact hyes hmember + rw [hverdict] + decide + Β· intro hnotMember + rw [houtput, registerVerdictOutput_cell_one] + have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 0 := by + rw [← hrunEq] + exact hno hnotMember + rw [hverdict] + decide + +theorem denseProgramDecision_decidesInTime_internal + {L : Language} {T : β„• β†’ β„•} (program : Program) + (hdecides : program.DecidesInTime L T) : + (denseProgramDecisionTM standardControlInstructionTapes program).DecidesInTime L + (fun inputLength => + denseProgramDecisionEnvelope program inputLength (T inputLength)) := by + intro input + obtain ⟨fuel, hhalted, hcost, hyes, hno⟩ := hdecides input + let haltWitness : βˆƒ candidate, + RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := ⟨fuel, hhalted⟩ + let firstFuel := Nat.find haltWitness + have hfirstHalted : RAM.Halted program + (RAM.run program firstFuel (RAM.initCfg input)) := + Nat.find_spec haltWitness + have hfirstLe : firstFuel ≀ fuel := Nat.find_min' haltWitness hhalted + have hnotHalted : βˆ€ candidate < firstFuel, + Β¬ RAM.Halted program + (RAM.run program candidate (RAM.initCfg input)) := by + intro candidate hcandidate + exact Nat.find_min haltWitness hcandidate + have hunit : RAM.unitTimeUpto program firstFuel (RAM.initCfg input) = + firstFuel := + RAM.unitTimeUpto_eq_of_not_halted program (RAM.initCfg input) firstFuel + hnotHalted + have hfuelCost : firstFuel ≀ + RAM.logTimeUpto program firstFuel (RAM.initCfg input) := by + calc + firstFuel = RAM.unitTimeUpto program firstFuel (RAM.initCfg input) := + hunit.symm + _ ≀ RAM.logTimeUpto program firstFuel (RAM.initCfg input) := + RAM.unitTimeUpto_le_logTimeUpto program firstFuel (RAM.initCfg input) + have hcostMono := RAM.logTimeUpto_mono program + (c := RAM.initCfg input) hfirstLe + have hfirstCost : RAM.logTimeUpto program firstFuel (RAM.initCfg input) ≀ + T input.length := le_trans hcostMono hcost + have hrunEq : RAM.run program fuel (RAM.initCfg input) = + RAM.run program firstFuel (RAM.initCfg input) := + RAM.run_eq_of_halted_le program hfirstLe hfirstHalted + have hmachine := denseProgramDecisionTM_hoareTime_ramRun + standardControlInstructionTapes program input firstFuel hfirstHalted + obtain ⟨final, time, htime, hreach, hfinalHalted, houtput⟩ := + hmachine (Tape.init (input.map Ξ“.ofBool)) + (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + have hresource := denseProgramDecisionTime_le_envelope + standardControlInstructionTapes program input firstFuel hfirstHalted hfuelCost + have henvelope := denseProgramDecisionEnvelope_mono_cost program input.length + (RAM.logTimeUpto program firstFuel (RAM.initCfg input)) (T input.length) + hfirstCost + refine ⟨final, time, le_trans htime (le_trans hresource henvelope), + hreach, hfinalHalted, ?_, ?_⟩ + Β· intro hmember + rw [houtput, registerVerdictOutput_cell_one] + have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 1 := by + rw [← hrunEq] + exact hyes hmember + rw [hverdict] + decide + Β· intro hnotMember + rw [houtput, registerVerdictOutput_cell_one] + have hverdict : + (RAM.run program firstFuel (RAM.initCfg input)).verdict = 0 := by + rw [← hrunEq] + exact hno hnotMember + rw [hverdict] + decide + +theorem DTIME_subset_DTIME_sq_internal (T : β„• β†’ β„•) + (hinput : (fun inputLength => inputLength + 1) =O T) : + RAM.DTIME T βŠ† Complexity.DTIME (fun inputLength => (T inputLength) ^ 2) := by + intro L hL + obtain ⟨program, timeBound, hdecides, htimeBound⟩ := hL + have htm := denseProgramDecision_decidesInTime_internal program hdecides + refine ⟨20, denseProgramDecisionTM standardControlInstructionTapes program, + (fun inputLength => denseProgramDecisionEnvelope program inputLength + (timeBound inputLength)), htm, ?_⟩ + have hsumRaw := BigO.add hinput htimeBound + have hsum : (fun inputLength => inputLength + timeBound inputLength + 1) =O T := by + convert hsumRaw using 1 + ext inputLength + omega + have hsquare := BigO.pow hsum 2 + have hconstant := BigO.const_mul_left + (500000000000 * (programResourceMagnitude program + 1) ^ 4) hsquare + simpa only [denseProgramDecisionEnvelope, Nat.mul_assoc] using hconstant + +theorem P_subset_internal : RAM.P βŠ† Complexity.P := by + intro L hL + obtain ⟨degree, program, timeBound, hdecides, hbigO⟩ := + Set.mem_iUnion.mp hL + obtain ⟨p, hp⟩ := BigO.pow_polynomial_bound hbigO + have hramPolynomial := RAM.Program.DecidesInTime.mono hp hdecides + have htm := programDecision_decidesInTime_internal program hramPolynomial + apply mem_P_iff_decidesInTime_polynomial.mpr + refine ⟨20, programDecisionTM standardControlInstructionTapes program, + programDecisionPolynomial program p, ?_⟩ + simpa only [programDecisionPolynomial_eval_internal] using htm + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Defs.lean new file mode 100644 index 0000000000..23d6def3a2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Defs.lean @@ -0,0 +1,311 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import Mathlib.Data.Finset.Sort + +/-! +# Sparse RAM register stores on Turing tapes: definitions + +This file defines the auditable representation boundary for simulating a RAM +with a Turing machine. A finite register file is represented by a list of +address/value pairs. Zero-valued registers are omitted. Words use a +self-delimiting binary code consisting of a unary width, a zero separator, and +exactly that many binary payload bits. Thus a word of bit-width `w` occupies +`2 * w + 1` tape cells. + +`Snapshot` adds the program counter to a finite store. Its bit encoding begins +with the program counter and entry count, followed by the address and value of +each entry. The corresponding decoders are total `Option`-valued functions. + +Proofs that the store operations implement functional register reads/writes +and that every codec round-trips live in the internal module. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Instr + +/-- Maximum bit-width of an instruction's hardwired register indices, +immediate, and jump target. These literals are fixed with the program and are +therefore not charged as runtime indirect addresses by `Instr.logCost`. -/ +def staticWidth : Instr β†’ β„• + | .imm destination value => max (bitlen destination) (bitlen value) + | .add destination sourceβ‚€ source₁ + | .sub destination sourceβ‚€ source₁ + | .mul destination sourceβ‚€ source₁ => + max (bitlen destination) (max (bitlen sourceβ‚€) (bitlen source₁)) + | .load destination addressRegister + | .store destination addressRegister => + max (bitlen destination) (bitlen addressRegister) + | .jz source target => max (bitlen source) (bitlen target) + | .jmp target => bitlen target + | .halt => 0 + +end Instr + +/-- Maximum hardwired literal width appearing in a fixed RAM program. -/ +def programStaticWidth : Program β†’ β„• + | [] => 0 + | instruction :: rest => + max (RegisterStore.Instr.staticWidth instruction) (programStaticWidth rest) + +/-- One sparse register entry: an address paired with its nonzero value. -/ +abbrev Entry := β„• Γ— β„• + +/-- A finite sparse register file. -/ +abbrev Store := List Entry + +/-- Read an address from a sparse store, defaulting to zero. -/ +def read : Store β†’ β„• β†’ β„• + | [], _ => 0 + | (storedAddress, value) :: rest, address => + if address = storedAddress then value else read rest address + +/-- Write one address in a sparse store. Writing zero removes the entry; +writing a nonzero value replaces the first matching entry or appends a fresh +entry when the address is absent. -/ +def write : Store β†’ β„• β†’ β„• β†’ Store + | [], address, value => if value = 0 then [] else [(address, value)] + | entry@(storedAddress, _) :: rest, address, value => + if address = storedAddress then + if value = 0 then rest else (address, value) :: rest + else entry :: write rest address value + +/-- No address occurs twice in a sparse store. -/ +def AddressesNodup (store : Store) : Prop := + (store.map Prod.fst).Nodup + +/-- Every materialized entry carries a nonzero value. -/ +def ValuesNonzero (store : Store) : Prop := + βˆ€ entry ∈ store, entry.2 β‰  0 + +/-- A canonical sparse store has unique addresses and omits zero values. -/ +def Canonical (store : Store) : Prop := + AddressesNodup store ∧ ValuesNonzero store + +/-- Decode a sparse store into the RAM model's total register file. -/ +def decode (store : Store) : β„• β†’ β„• := + read store + +/-- A finite sparse store represents a total RAM register file exactly. -/ +def Represents (store : Store) (regs : β„• β†’ β„•) : Prop := + Canonical store ∧ decode store = regs + +/-- Maximum address/value bit-width materialized in a sparse store. -/ +def maxWidth : Store β†’ β„• + | [] => 0 + | entry :: rest => + max (bitlen entry.1) (max (bitlen entry.2) (maxWidth rest)) + +/-- Materialize the finite support of a total register file as a sparse store. -/ +noncomputable def ofRegs (regs : β„• β†’ β„•) + (hfinite : (Function.support regs).Finite) : Store := + hfinite.toFinset.toList.map fun address => (address, regs address) + +/-- Nonzero public-input registers, selected from the known finite input range. -/ +def initialAddresses (input : List Bool) : Finset β„• := + (Finset.range (input.length + 1)).filter fun address => initRegs input address β‰  0 + +/-- Canonical sparse materialization of the RAM public-input register file. -/ +def initialStore (input : List Bool) : Store := + ((initialAddresses input).sort (Β· ≀ Β·)).map fun address => + (address, initRegs input address) + +/-! ## Self-delimiting binary words -/ + +namespace WordCode + +/-- Encode a natural as unary bit-width, a zero separator, and fixed-width +little-endian payload bits. The payload convention matches the library's +canonical binary-arithmetic work tapes. -/ +def encode (value : β„•) : List Bool := + List.replicate (bitlen value) true ++ + false :: Nat.toBitsLE (bitlen value) value + +/-- Parse the unary-width prefix, then consume exactly that many payload bits. -/ +def decodeAux? : List Bool β†’ β„• β†’ Option (β„• Γ— List Bool) + | [], _ => none + | true :: rest, width => decodeAux? rest (width + 1) + | false :: rest, width => + if width ≀ rest.length then + some (Nat.fromBitsLE (rest.take width), rest.drop width) + else + none + +/-- Parse one self-delimiting binary word and return the unconsumed suffix. -/ +def decodePrefix? (bits : List Bool) : Option (β„• Γ— List Bool) := + decodeAux? bits 0 + +end WordCode + +namespace Entry + +/-- Serialize an address/value entry as two self-delimiting words. -/ +def encode (entry : Entry) : List Bool := + WordCode.encode entry.1 ++ WordCode.encode entry.2 + +/-- Parse one address/value entry and return the unconsumed suffix. -/ +def decodePrefix? (bits : List Bool) : Option (Entry Γ— List Bool) := do + let (address, rest) ← WordCode.decodePrefix? bits + let (value, rest) ← WordCode.decodePrefix? rest + pure ((address, value), rest) + +end Entry + +/-- Number of tape cells occupied by the concatenated self-delimiting codes of +the live sparse-store entries. Unlike `Snapshot.sizeBound`, this charges the +actual width of every entry instead of multiplying the entry count by one +run-wide maximum width. -/ +def encodedStoreLength (store : Store) : β„• := + (store.flatMap Entry.encode).length + +/-- Parse exactly `count` sparse entries and return the unconsumed suffix. -/ +def decodeEntries? : β„• β†’ List Bool β†’ Option (Store Γ— List Bool) + | 0, bits => some ([], bits) + | count + 1, bits => do + let (entry, rest) ← Entry.decodePrefix? bits + let (entries, rest) ← decodeEntries? count rest + pure (entry :: entries, rest) + +/-- A finite RAM snapshot: program counter plus sparse register store. -/ +structure Snapshot where + /-- Program counter of the represented RAM configuration. -/ + pc : β„• + /-- Materialized nonzero register entries. -/ + store : Store + deriving DecidableEq + +namespace Snapshot + +/-- Decode a finite snapshot to a RAM configuration. -/ +def decode (snapshot : Snapshot) : Cfg where + pc := snapshot.pc + regs := RegisterStore.decode snapshot.store + +/-- Serialize a snapshot as program counter, entry count, and entries. -/ +def encode (snapshot : Snapshot) : List Bool := + WordCode.encode snapshot.pc ++ + WordCode.encode snapshot.store.length ++ + snapshot.store.flatMap Entry.encode + +/-- Parse one snapshot prefix and return the unconsumed suffix. -/ +def decodePrefix? (bits : List Bool) : Option (Snapshot Γ— List Bool) := do + let (pc, rest) ← WordCode.decodePrefix? bits + let (count, rest) ← WordCode.decodePrefix? rest + let (store, rest) ← decodeEntries? count rest + pure ({ pc, store }, rest) + +/-- Decode an exact snapshot code, rejecting trailing bits. -/ +def decode? (bits : List Bool) : Option Snapshot := do + let (snapshot, rest) ← decodePrefix? bits + if rest.isEmpty then pure snapshot else none + +/-- A canonical snapshot represents a RAM configuration exactly. -/ +def Represents (snapshot : Snapshot) (cfg : Cfg) : Prop := + RegisterStore.Canonical snapshot.store ∧ snapshot.decode = cfg + +/-- One width envelope for the program counter, entry count, addresses, and +values of a finite snapshot. -/ +def width (snapshot : Snapshot) : β„• := + max (bitlen snapshot.pc) + (max (bitlen snapshot.store.length) (RegisterStore.maxWidth snapshot.store)) + +/-- Concrete tape-cell envelope for the canonical snapshot encoding. -/ +def sizeBound (snapshot : Snapshot) : β„• := + (snapshot.store.length + 1) * (4 * snapshot.width + 2) + +/-- One-step width envelope: old width plus one, or a width explicitly exposed +by the instruction literal or its logarithmic runtime charge. -/ +def stepWidthBound (instruction : Instr) (snapshot : Snapshot) : β„• := + max (snapshot.width + 1) + (max (RegisterStore.Instr.staticWidth instruction) + (instruction.logCost snapshot.decode)) + +/-- Materialize a RAM configuration whose register support is finite. -/ +noncomputable def ofCfg (cfg : Cfg) + (hfinite : (Function.support cfg.regs).Finite) : Snapshot where + pc := cfg.pc + store := RegisterStore.ofRegs cfg.regs hfinite + +/-- Canonical finite snapshot of the RAM public-input configuration. -/ +def initial (input : List Bool) : Snapshot where + pc := 0 + store := RegisterStore.initialStore input + +/-- The instruction selected by a finite snapshot. -/ +def curInstr (program : Program) (snapshot : Snapshot) : Instr := + (program[snapshot.pc]?).getD Instr.halt + +/-- Execute one RAM instruction directly on the sparse finite store. -/ +def stepInstr : Instr β†’ Snapshot β†’ Snapshot + | .imm destination value, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store destination value } + | .add destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store destination + (read snapshot.store sourceβ‚€ + read snapshot.store source₁) } + | .sub destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store destination + (read snapshot.store sourceβ‚€ - read snapshot.store source₁) } + | .mul destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store destination + (read snapshot.store sourceβ‚€ * read snapshot.store source₁) } + | .load destination addressRegister, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store destination + (read snapshot.store (read snapshot.store addressRegister)) } + | .store addressRegister source, snapshot => + { pc := snapshot.pc + 1 + store := write snapshot.store (read snapshot.store addressRegister) + (read snapshot.store source) } + | .jz source target, snapshot => + if read snapshot.store source = 0 then + { snapshot with pc := target } + else + { snapshot with pc := snapshot.pc + 1 } + | .jmp target, snapshot => + { snapshot with pc := target } + | .halt, snapshot => snapshot + +/-- Execute the selected RAM instruction on a sparse snapshot. -/ +def step (program : Program) (snapshot : Snapshot) : Snapshot := + stepInstr (curInstr program snapshot) snapshot + +/-- A sparse snapshot is halted exactly when its selected instruction is halt. -/ +def Halted (program : Program) (snapshot : Snapshot) : Prop := + curInstr program snapshot = Instr.halt + +instance (program : Program) (snapshot : Snapshot) : Decidable (Halted program snapshot) := by + unfold Halted + infer_instance + +/-- Fuel-bounded sparse execution, stopping at the first halted snapshot. -/ +def run (program : Program) : β„• β†’ Snapshot β†’ Snapshot + | 0, snapshot => snapshot + | fuel + 1, snapshot => + if Halted program snapshot then snapshot + else run program fuel (step program snapshot) + +end Snapshot + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay.lean new file mode 100644 index 0000000000..00a17c9af5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Internal + +/-! +# Dense public input with a sparse mutable overlay + +This module exposes the semantic representation used by the optimized +RAM-to-Turing simulation. The immutable public input is not duplicated in the +mutable snapshot; positive tags make explicit writes of zero distinguishable +from an absent overlay entry. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace DenseOverlay + +/-- With no mutable entries, reads agree exactly with the public RAM input ABI. -/ +theorem read_empty (input : List Bool) (address : β„•) : + read input [] address = RAM.initRegs input address := + read_empty_internal input address + +/-- A positive-tag overlay write implements functional update, including an +explicit write of zero over a nonzero public-input bit. -/ +theorem read_write (input : List Bool) (overlay : Store) + (hcanonical : Canonical overlay) (address value : β„•) : + read input (write overlay address value) = + Function.update (read input overlay) address value := + read_write_internal input overlay hcanonical address value + +/-- Every overlay write preserves unique addresses and positive tags. -/ +theorem write_canonical (overlay : Store) (hcanonical : Canonical overlay) + (address value : β„•) : Canonical (write overlay address value) := + write_canonical_internal overlay hcanonical address value + +/-- Materializing a positive tag preserves the invariant that register zero +never falls through to the dense input bank. -/ +theorem write_coversZero (overlay : Store) (hcanonical : Canonical overlay) + (hcovers : CoversZero overlay) (address value : β„•) : + CoversZero (write overlay address value) := + write_coversZero_internal overlay hcanonical hcovers address value + +/-- The empty mutable overlay already decodes to the complete public RAM input +configuration. -/ +theorem Snapshot.initial_decode (input : List Bool) : + (Snapshot.initial input).decode input = RAM.initCfg input := + Snapshot.initial_decode_internal input + +/-- The initial one-entry overlay is canonical. -/ +theorem Snapshot.initial_canonical (input : List Bool) : + Canonical (Snapshot.initial input).overlay := + Snapshot.initial_canonical_internal input + +/-- The initial overlay materializes register zero. -/ +theorem Snapshot.initial_coversZero (input : List Bool) : + CoversZero (Snapshot.initial input).overlay := + Snapshot.initial_coversZero_internal input + +/-- The initial overlay satisfies the full representation invariant. -/ +theorem Snapshot.initial_valid (input : List Bool) : + Valid (Snapshot.initial input).overlay := + Snapshot.initial_valid_internal input + +/-- Decoding commutes exactly with one selected instruction. -/ +theorem Snapshot.decode_stepInstr (input : List Bool) (instruction : Instr) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.overlay) : + (snapshot.stepInstr input instruction).decode input = + RAM.stepInstr instruction (snapshot.decode input) := + Snapshot.decode_stepInstr_internal input instruction snapshot hcanonical + +/-- One selected instruction preserves overlay canonicality. -/ +theorem Snapshot.stepInstr_canonical (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.stepInstr input instruction).overlay := + Snapshot.stepInstr_canonical_internal input instruction snapshot hcanonical + +/-- One selected instruction preserves materialization of register zero. -/ +theorem Snapshot.stepInstr_coversZero (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + CoversZero (snapshot.stepInstr input instruction).overlay := + Snapshot.stepInstr_coversZero_internal input instruction snapshot hvalid + +/-- One selected instruction preserves the full overlay invariant. -/ +theorem Snapshot.stepInstr_valid (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + Valid (snapshot.stepInstr input instruction).overlay := + Snapshot.stepInstr_valid_internal input instruction snapshot hvalid + +/-- Decoding commutes exactly with one program-selected RAM step. -/ +theorem Snapshot.decode_step (program : Program) (input : List Bool) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.overlay) : + (snapshot.step program input).decode input = + RAM.step program (snapshot.decode input) := + Snapshot.decode_step_internal program input snapshot hcanonical + +/-- Every program-selected step preserves overlay canonicality. -/ +theorem Snapshot.step_canonical (program : Program) (input : List Bool) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.step program input).overlay := + Snapshot.step_canonical_internal program input snapshot hcanonical + +/-- One program-selected step preserves the full overlay invariant. -/ +theorem Snapshot.step_valid (program : Program) (input : List Bool) + (snapshot : Snapshot) (hvalid : Valid snapshot.overlay) : + Valid (snapshot.step program input).overlay := + Snapshot.step_valid_internal program input snapshot hvalid + +/-- A complete fuel-bounded dense-overlay execution decodes to the ordinary +RAM run. -/ +theorem Snapshot.decode_run (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + (snapshot.run program input fuel).decode input = + RAM.run program fuel (snapshot.decode input) := + Snapshot.decode_run_internal program input fuel snapshot hcanonical + +/-- Every fuel-bounded dense-overlay execution remains canonical. -/ +theorem Snapshot.run_canonical (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.run program input fuel).overlay := + Snapshot.run_canonical_internal program input fuel snapshot hcanonical + +/-- A complete dense-overlay run preserves the full representation invariant. -/ +theorem Snapshot.run_valid (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : Snapshot) (hvalid : Valid snapshot.overlay) : + Valid (snapshot.run program input fuel).overlay := + Snapshot.run_valid_internal program input fuel snapshot hvalid + +/-- One tagged write adds at most one mutable overlay entry. -/ +theorem write_length_le (overlay : Store) (address value : β„•) : + (write overlay address value).length ≀ overlay.length + 1 := + write_length_le_internal overlay address value + +/-- One selected instruction adds at most one mutable overlay entry. -/ +theorem Snapshot.length_stepInstr_le (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) : + (snapshot.stepInstr input instruction).overlay.length ≀ + snapshot.overlay.length + 1 := + Snapshot.length_stepInstr_le_internal input instruction snapshot + +/-- A dense-overlay run materializes at most one entry per executed RAM step. -/ +theorem Snapshot.length_run_le (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + (snapshot.run program input fuel).overlay.length ≀ + snapshot.overlay.length + + RAM.unitTimeUpto program fuel (snapshot.decode input) := + Snapshot.length_run_le_internal program input fuel snapshot hcanonical + +/-- A tagged write increases the live overlay code by at most the code of its +address and positive value tag. -/ +theorem encodedStoreLength_write_le (overlay : Store) + (address value : β„•) : + encodedStoreLength (write overlay address value) ≀ + encodedStoreLength overlay + (Entry.encode (address, value + 1)).length := + encodedStoreLength_write_le_internal overlay address value + +/-- One selected instruction grows the actual live overlay code linearly in +its fixed literal width and its logarithmic RAM charge. -/ +theorem Snapshot.encodedStoreLength_stepInstr_le (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) : + encodedStoreLength (snapshot.stepInstr input instruction).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (RegisterStore.Instr.staticWidth instruction + + instruction.logCost (snapshot.decode input) + 1) := + Snapshot.encodedStoreLength_stepInstr_le_internal input instruction snapshot + +/-- One program-selected step satisfies the same live-code bound using the +fixed program's maximum literal width. -/ +theorem Snapshot.encodedStoreLength_step_le (program : Program) + (input : List Bool) (snapshot : Snapshot) : + encodedStoreLength (snapshot.step program input).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (programStaticWidth program + + RAM.stepLogCost program (snapshot.decode input) + 1) := + Snapshot.encodedStoreLength_step_le_internal program input snapshot + +/-- The live mutable overlay has amortized encoded growth linear in the work +actually charged by the RAM run; the immutable public input contributes no +repeated sparse-store term. -/ +theorem Snapshot.encodedStoreLength_run_le (program : Program) + (input : List Bool) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + encodedStoreLength (snapshot.run program input fuel).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (RAM.unitTimeUpto program fuel (snapshot.decode input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (snapshot.decode input)) := + Snapshot.encodedStoreLength_run_le_internal program input fuel snapshot hcanonical + +/-- Starting from the public ABI, mutable entry count is bounded solely by the +executed step count. -/ +theorem Snapshot.initial_length_run_le (program : Program) + (input : List Bool) (fuel : β„•) : + ((Snapshot.initial input).run program input fuel).overlay.length ≀ + 1 + RAM.unitTimeUpto program fuel (RAM.initCfg input) := + Snapshot.initial_length_run_le_internal program input fuel + +/-- Starting from the public ABI, live mutable code is linear in accumulated +RAM cost and carries no eager `input.length * bitlen input.length` term. -/ +theorem Snapshot.initial_encodedStoreLength_run_le + (program : Program) (input : List Bool) (fuel : β„•) : + encodedStoreLength + ((Snapshot.initial input).run program input fuel).overlay ≀ + 2 * bitlen (input.length + 1) + 2 + + 2 * (RAM.unitTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input)) := + Snapshot.initial_encodedStoreLength_run_le_internal program input fuel + +/-- The initial snapshot contains only the two headers and the tagged `Rβ‚€` +length entry; public input bits remain in the immutable bank. -/ +theorem Snapshot.initial_encode_length (input : List Bool) : + (Snapshot.initial input).encode.length = + 2 * bitlen (input.length + 1) + 6 := + Snapshot.initial_encode_length_internal input + +end DenseOverlay +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Defs.lean new file mode 100644 index 0000000000..599931df34 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Defs.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs + +/-! +# Dense public input with a sparse mutable overlay -- definitions + +The ordinary sparse snapshot eagerly materializes every nonzero public-input +register. That representation is convenient but occupies `Theta(n log n)` +cells before the RAM executes a step. This module separates the immutable input +bank from the mutable register overlay. + +An overlay entry `(address, tag)` represents the actual value `tag - 1`. +Because every stored tag is positive, an absent address is distinguishable from +an explicit write of zero (`tag = 1`). Absent reads fall through to the dense +public-input ABI `RAM.initRegs input`. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace DenseOverlay + +/-- Mutable tagged entries layered over the immutable public-input bank. -/ +abbrev Store := RegisterStore.Store + +/-- Read through the sparse tagged overlay, falling back to the public input. -/ +def read (input : List Bool) (overlay : Store) (address : β„•) : β„• := + let tag := RegisterStore.read overlay address + if tag = 0 then RAM.initRegs input address else tag - 1 + +/-- Record an explicit mutable value. The positive tag preserves written zero. -/ +def write (overlay : Store) (address value : β„•) : Store := + RegisterStore.write overlay address (value + 1) + +/-- A valid overlay has unique addresses and positive tags. -/ +abbrev Canonical (overlay : Store) : Prop := RegisterStore.Canonical overlay + +/-- Register zero is materialized in every concrete overlay. This lets the +dense-input lookup specialize its fallback path to positive input addresses. -/ +def CoversZero (overlay : Store) : Prop := + RegisterStore.read overlay 0 β‰  0 + +/-- Full representation invariant for the mutable overlay. -/ +def Valid (overlay : Store) : Prop := + Canonical overlay ∧ CoversZero overlay + +/-- Decode the dense-input/overlay pair to a total RAM register file. -/ +def decode (input : List Bool) (overlay : Store) : β„• β†’ β„• := read input overlay + +/-- A finite mutable overlay plus program counter. The immutable input remains +on the Turing input tape and is not duplicated in this snapshot. -/ +structure Snapshot where + /-- Current RAM program counter. -/ + pc : β„• + /-- Sparse positive-tag overlay. -/ + overlay : Store + deriving DecidableEq + +namespace Snapshot + +/-- Decode one dense-overlay snapshot against its immutable public input. -/ +def decode (input : List Bool) (snapshot : Snapshot) : RAM.Cfg where + pc := snapshot.pc + regs := DenseOverlay.decode input snapshot.overlay + +/-- Reuse the checked sparse snapshot codec for the tagged mutable overlay. -/ +def encode (snapshot : Snapshot) : List Bool := + RegisterStore.Snapshot.encode { pc := snapshot.pc, store := snapshot.overlay } + +/-- The initial mutable overlay materializes only `Rβ‚€ = input.length`; all input +bits remain in the read-only dense bank. The stored positive tag is +`input.length + 1`. -/ +def initial (input : List Bool) : Snapshot := + { pc := 0, overlay := DenseOverlay.write [] 0 input.length } + +/-- Instruction selected by the current program counter. -/ +def curInstr (program : Program) (snapshot : Snapshot) : Instr := + (program[snapshot.pc]?).getD .halt + +/-- Whether the selected instruction is `halt`. -/ +def Halted (program : Program) (snapshot : Snapshot) : Prop := + snapshot.curInstr program = .halt + +instance (program : Program) (snapshot : Snapshot) : + Decidable (snapshot.Halted program) := by + unfold Halted + infer_instance + +/-- Execute one RAM instruction against the decoded input/overlay register +file, recording the result as a positive tag. -/ +def stepInstr (input : List Bool) : Instr β†’ Snapshot β†’ Snapshot + | .imm destination value, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay destination value } + | .add destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay destination + (DenseOverlay.read input snapshot.overlay sourceβ‚€ + + DenseOverlay.read input snapshot.overlay source₁) } + | .sub destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay destination + (DenseOverlay.read input snapshot.overlay sourceβ‚€ - + DenseOverlay.read input snapshot.overlay source₁) } + | .mul destination sourceβ‚€ source₁, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay destination + (DenseOverlay.read input snapshot.overlay sourceβ‚€ * + DenseOverlay.read input snapshot.overlay source₁) } + | .load destination addressRegister, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay destination + (DenseOverlay.read input snapshot.overlay + (DenseOverlay.read input snapshot.overlay addressRegister)) } + | .store addressRegister source, snapshot => + { pc := snapshot.pc + 1 + overlay := DenseOverlay.write snapshot.overlay + (DenseOverlay.read input snapshot.overlay addressRegister) + (DenseOverlay.read input snapshot.overlay source) } + | .jz source target, snapshot => + if DenseOverlay.read input snapshot.overlay source = 0 then + { snapshot with pc := target } + else + { snapshot with pc := snapshot.pc + 1 } + | .jmp target, snapshot => { snapshot with pc := target } + | .halt, snapshot => snapshot + +/-- Execute the instruction selected by the current program counter. -/ +def step (program : Program) (input : List Bool) (snapshot : Snapshot) : Snapshot := + snapshot.stepInstr input (snapshot.curInstr program) + +/-- Fuel-bounded dense-overlay execution, stopping once halted. -/ +def run (program : Program) (input : List Bool) : β„• β†’ Snapshot β†’ Snapshot + | 0, snapshot => snapshot + | fuel + 1, snapshot => + if snapshot.Halted program then snapshot + else run program input fuel (snapshot.step program input) + +end Snapshot +end DenseOverlay +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Internal.lean new file mode 100644 index 0000000000..f6a5782df2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/DenseOverlay/Internal.lean @@ -0,0 +1,509 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Internal + +/-! +# Dense public input with a sparse mutable overlay -- proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace DenseOverlay + +theorem read_empty_internal (input : List Bool) (address : β„•) : + read input [] address = RAM.initRegs input address := by + simp [read, RegisterStore.read] + +theorem read_write_internal (input : List Bool) (overlay : Store) + (hcanonical : Canonical overlay) (address value : β„•) : + read input (write overlay address value) = + Function.update (read input overlay) address value := by + funext target + have htag := RegisterStore.read_write_internal overlay hcanonical.1 + address (value + 1) target + unfold read write + rw [htag] + by_cases htarget : target = address + Β· subst target + simp + Β· simp [Function.update, htarget] + +theorem write_canonical_internal (overlay : Store) + (hcanonical : Canonical overlay) (address value : β„•) : + Canonical (write overlay address value) := by + exact RegisterStore.write_canonical_internal overlay hcanonical address + (value + 1) + +theorem write_coversZero_internal (overlay : Store) + (hcanonical : Canonical overlay) (hcovers : CoversZero overlay) + (address value : β„•) : CoversZero (write overlay address value) := by + have hread := RegisterStore.read_write_internal overlay hcanonical.1 + address (value + 1) 0 + unfold CoversZero write + rw [hread] + by_cases haddress : address = 0 + Β· subst address + simp + Β· simpa [Function.update, haddress, Ne.symm haddress] using! hcovers + +theorem Snapshot.initial_decode_internal (input : List Bool) : + (Snapshot.initial input).decode input = RAM.initCfg input := by + apply RAM.Cfg.ext + Β· rfl + Β· funext address + change read input (write [] 0 input.length) address = + RAM.initRegs input address + rw [read_write_internal input [] + (by simp [RegisterStore.Canonical, RegisterStore.AddressesNodup, + RegisterStore.ValuesNonzero])] + by_cases haddress : address = 0 + Β· subst address + simp [Function.update, RAM.initRegs] + Β· simp [Function.update, haddress, read_empty_internal, RAM.initRegs] + +theorem Snapshot.initial_canonical_internal (input : List Bool) : + Canonical (Snapshot.initial input).overlay := by + exact write_canonical_internal [] + (by simp [RegisterStore.Canonical, RegisterStore.AddressesNodup, + RegisterStore.ValuesNonzero]) 0 input.length + +theorem Snapshot.initial_coversZero_internal (input : List Bool) : + CoversZero (Snapshot.initial input).overlay := by + unfold Snapshot.initial CoversZero DenseOverlay.write + simp [RegisterStore.write, RegisterStore.read] + +theorem Snapshot.initial_valid_internal (input : List Bool) : + Valid (Snapshot.initial input).overlay := + ⟨Snapshot.initial_canonical_internal input, + Snapshot.initial_coversZero_internal input⟩ + +theorem Snapshot.decode_stepInstr_internal (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + (snapshot.stepInstr input instruction).decode input = + RAM.stepInstr instruction (snapshot.decode input) := by + cases instruction with + | imm destination value => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical + destination value + | add destination sourceβ‚€ source₁ => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical destination _ + | sub destination sourceβ‚€ source₁ => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical destination _ + | mul destination sourceβ‚€ source₁ => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical destination _ + | load destination addressRegister => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical destination _ + | store addressRegister source => + apply RAM.Cfg.ext + Β· rfl + Β· exact read_write_internal input snapshot.overlay hcanonical _ _ + | jz source target => + simp only [Snapshot.stepInstr, RAM.stepInstr, Snapshot.decode] + split <;> simp_all [DenseOverlay.decode] + | jmp target => rfl + | halt => rfl + +theorem Snapshot.stepInstr_canonical_internal (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.stepInstr input instruction).overlay := by + cases instruction <;> simp only [Snapshot.stepInstr] + all_goals first + | exact write_canonical_internal snapshot.overlay hcanonical _ _ + | split <;> exact hcanonical + | exact hcanonical + +theorem Snapshot.stepInstr_coversZero_internal (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + CoversZero (snapshot.stepInstr input instruction).overlay := by + cases instruction <;> simp only [Snapshot.stepInstr] + all_goals first + | exact write_coversZero_internal snapshot.overlay hvalid.1 hvalid.2 _ _ + | split <;> exact hvalid.2 + | exact hvalid.2 + +theorem Snapshot.stepInstr_valid_internal (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + Valid (snapshot.stepInstr input instruction).overlay := + ⟨Snapshot.stepInstr_canonical_internal input instruction snapshot hvalid.1, + Snapshot.stepInstr_coversZero_internal input instruction snapshot hvalid⟩ + +theorem Snapshot.decode_step_internal (program : Program) (input : List Bool) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.overlay) : + (snapshot.step program input).decode input = + RAM.step program (snapshot.decode input) := by + unfold Snapshot.step RAM.step Snapshot.curInstr RAM.curInstr + rw [Snapshot.decode_stepInstr_internal input _ snapshot hcanonical] + rfl + +theorem Snapshot.step_canonical_internal (program : Program) + (input : List Bool) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.step program input).overlay := by + exact Snapshot.stepInstr_canonical_internal input _ snapshot hcanonical + +theorem Snapshot.step_valid_internal (program : Program) + (input : List Bool) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + Valid (snapshot.step program input).overlay := by + exact Snapshot.stepInstr_valid_internal input _ snapshot hvalid + +theorem Snapshot.decode_run_internal (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + (snapshot.run program input fuel).decode input = + RAM.run program fuel (snapshot.decode input) := by + induction fuel generalizing snapshot with + | zero => rfl + | succ fuel ih => + simp only [Snapshot.run, RAM.run] + have hhalted : snapshot.Halted program ↔ + RAM.Halted program (snapshot.decode input) := by + unfold Snapshot.Halted RAM.Halted Snapshot.curInstr RAM.curInstr + rfl + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt, ite_eq_left (hhalted.mp hhalt)] + Β· rw [ite_eq_right hhalt, ite_eq_right (fun h => hhalt (hhalted.mpr h))] + rw [ih (snapshot.step program input) + (Snapshot.step_canonical_internal program input snapshot hcanonical)] + rw [Snapshot.decode_step_internal program input snapshot hcanonical] + +theorem Snapshot.run_canonical_internal (program : Program) + (input : List Bool) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + Canonical (snapshot.run program input fuel).overlay := by + induction fuel generalizing snapshot with + | zero => exact hcanonical + | succ fuel ih => + simp only [Snapshot.run] + split + Β· exact hcanonical + Β· exact ih (snapshot.step program input) + (Snapshot.step_canonical_internal program input snapshot hcanonical) + +theorem Snapshot.run_valid_internal (program : Program) + (input : List Bool) (fuel : β„•) (snapshot : Snapshot) + (hvalid : Valid snapshot.overlay) : + Valid (snapshot.run program input fuel).overlay := by + induction fuel generalizing snapshot with + | zero => exact hvalid + | succ fuel ih => + simp only [Snapshot.run] + split + Β· exact hvalid + Β· exact ih (snapshot.step program input) + (Snapshot.step_valid_internal program input snapshot hvalid) + +private theorem bitlen_succ_le (value : β„•) : + bitlen (value + 1) ≀ bitlen value + 1 := by + rw [bitlen, bitlen, Nat.size_le] + have hvalue := Nat.lt_size_self value + have hpowPos : 0 < 2 ^ value.size := pow_pos (by omega) _ + rw [pow_succ] + omega + +theorem write_length_le_internal (overlay : Store) (address value : β„•) : + (write overlay address value).length ≀ overlay.length + 1 := by + induction overlay with + | nil => simp [write, RegisterStore.write] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedTag⟩ + by_cases haddress : address = storedAddress + Β· subst address + simp [write, RegisterStore.write] + Β· have ih' : (RegisterStore.write rest address (value + 1)).length ≀ + rest.length + 1 := by + simpa only [write] using ih + simp only [write, RegisterStore.write, haddress, ite_false, + List.length_cons] + omega + +theorem Snapshot.length_stepInstr_le_internal (input : List Bool) + (instruction : Instr) (snapshot : Snapshot) : + (snapshot.stepInstr input instruction).overlay.length ≀ + snapshot.overlay.length + 1 := by + cases instruction with + | imm destination value => + exact write_length_le_internal snapshot.overlay destination value + | add destination sourceβ‚€ source₁ => + exact write_length_le_internal snapshot.overlay destination _ + | sub destination sourceβ‚€ source₁ => + exact write_length_le_internal snapshot.overlay destination _ + | mul destination sourceβ‚€ source₁ => + exact write_length_le_internal snapshot.overlay destination _ + | load destination addressRegister => + exact write_length_le_internal snapshot.overlay destination _ + | store addressRegister source => + exact write_length_le_internal snapshot.overlay _ _ + | jz source target => + simp only [Snapshot.stepInstr] + split <;> simp + | jmp target => simp [Snapshot.stepInstr] + | halt => simp [Snapshot.stepInstr] + +theorem Snapshot.length_run_le_internal (program : Program) + (input : List Bool) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + (snapshot.run program input fuel).overlay.length ≀ + snapshot.overlay.length + + RAM.unitTimeUpto program fuel (snapshot.decode input) := by + induction fuel generalizing snapshot with + | zero => simp [Snapshot.run, RAM.unitTimeUpto] + | succ fuel ih => + rw [Snapshot.run, RAM.unitTimeUpto] + have hhalted : snapshot.Halted program ↔ + RAM.Halted program (snapshot.decode input) := Iff.rfl + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt, ite_eq_left (hhalted.mp hhalt)] + omega + Β· rw [ite_eq_right hhalt, ite_eq_right (fun h => hhalt (hhalted.mpr h))] + have hstep := Snapshot.length_stepInstr_le_internal input + (snapshot.curInstr program) snapshot + have hstep' : (snapshot.step program input).overlay.length ≀ + snapshot.overlay.length + 1 := by + simpa only [Snapshot.step] using hstep + have hnextCanonical := Snapshot.step_canonical_internal + program input snapshot hcanonical + have hrun := ih (snapshot.step program input) hnextCanonical + rw [Snapshot.decode_step_internal program input snapshot hcanonical] at hrun + omega + +theorem encodedStoreLength_write_le_internal (overlay : Store) + (address value : β„•) : + encodedStoreLength (write overlay address value) ≀ + encodedStoreLength overlay + (Entry.encode (address, value + 1)).length := by + exact RegisterStore.encodedStoreLength_write_le_internal overlay address + (value + 1) + +theorem Snapshot.encodedStoreLength_stepInstr_le_internal + (input : List Bool) (instruction : Instr) (snapshot : Snapshot) : + encodedStoreLength (snapshot.stepInstr input instruction).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (RegisterStore.Instr.staticWidth instruction + + instruction.logCost (snapshot.decode input) + 1) := by + cases instruction with + | imm destination value => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + destination value + have hsucc := bitlen_succ_le value + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost] + omega + | add destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + destination + (read input snapshot.overlay sourceβ‚€ + read input snapshot.overlay source₁) + have hsucc := bitlen_succ_le + (read input snapshot.overlay sourceβ‚€ + read input snapshot.overlay source₁) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, DenseOverlay.decode] + omega + | sub destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + destination + (read input snapshot.overlay sourceβ‚€ - read input snapshot.overlay source₁) + have hsub : bitlen + (read input snapshot.overlay sourceβ‚€ - read input snapshot.overlay source₁) ≀ + bitlen (read input snapshot.overlay sourceβ‚€) := + Nat.size_le_size (Nat.sub_le _ _) + have hsucc := bitlen_succ_le + (read input snapshot.overlay sourceβ‚€ - read input snapshot.overlay source₁) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, DenseOverlay.decode] + omega + | mul destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + destination + (read input snapshot.overlay sourceβ‚€ * read input snapshot.overlay source₁) + have hsucc := bitlen_succ_le + (read input snapshot.overlay sourceβ‚€ * read input snapshot.overlay source₁) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, DenseOverlay.decode] + omega + | load destination addressRegister => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + destination + (read input snapshot.overlay (read input snapshot.overlay addressRegister)) + have hsucc := bitlen_succ_le + (read input snapshot.overlay (read input snapshot.overlay addressRegister)) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, DenseOverlay.decode] + omega + | store addressRegister source => + have hwrite := encodedStoreLength_write_le_internal snapshot.overlay + (read input snapshot.overlay addressRegister) + (read input snapshot.overlay source) + have hsucc := bitlen_succ_le (read input snapshot.overlay source) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, DenseOverlay.decode] + omega + | jz source target => + simp only [Snapshot.stepInstr] + split <;> simp + | jmp target => simp [Snapshot.stepInstr] + | halt => simp [Snapshot.stepInstr] + +private theorem staticWidth_curInstr_le (program : Program) (pc : β„•) : + RegisterStore.Instr.staticWidth ((program[pc]?).getD Instr.halt) ≀ + programStaticWidth program := by + induction program generalizing pc with + | nil => simp [programStaticWidth, RegisterStore.Instr.staticWidth] + | cons instruction rest ih => + cases pc with + | zero => simp [programStaticWidth] + | succ pc => + simp only [List.getElem?_cons_succ] + exact le_trans (ih pc) (le_max_right _ _) + +theorem Snapshot.encodedStoreLength_step_le_internal (program : Program) + (input : List Bool) (snapshot : Snapshot) : + encodedStoreLength (snapshot.step program input).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (programStaticWidth program + + RAM.stepLogCost program (snapshot.decode input) + 1) := by + have hstep := Snapshot.encodedStoreLength_stepInstr_le_internal input + (snapshot.curInstr program) snapshot + have hstatic := staticWidth_curInstr_le program snapshot.pc + apply le_trans hstep + apply Nat.add_le_add_left + have hcost : (snapshot.curInstr program).logCost (snapshot.decode input) = + RAM.stepLogCost program (snapshot.decode input) := rfl + rw [hcost] + exact Nat.mul_le_mul_left 2 + (Nat.add_le_add_right (Nat.add_le_add_right hstatic _) 1) + +theorem Snapshot.encodedStoreLength_run_le_internal (program : Program) + (input : List Bool) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.overlay) : + encodedStoreLength (snapshot.run program input fuel).overlay ≀ + encodedStoreLength snapshot.overlay + + 2 * (RAM.unitTimeUpto program fuel (snapshot.decode input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (snapshot.decode input)) := by + induction fuel generalizing snapshot with + | zero => simp [Snapshot.run, RAM.unitTimeUpto, RAM.logTimeUpto] + | succ fuel ih => + rw [Snapshot.run] + have hhalted : snapshot.Halted program ↔ + RAM.Halted program (snapshot.decode input) := Iff.rfl + by_cases hhalt : snapshot.Halted program + Β· have hramHalted := hhalted.mp hhalt + simp only [hhalt, hramHalted, if_true, RAM.unitTimeUpto, + RAM.logTimeUpto] + simp + Β· have hramNotHalted : Β¬RAM.Halted program (snapshot.decode input) := + fun h => hhalt (hhalted.mpr h) + rw [ite_eq_right hhalt] + simp only [RAM.unitTimeUpto, RAM.logTimeUpto, hramNotHalted, + ite_false] + have hstep := Snapshot.encodedStoreLength_step_le_internal + program input snapshot + have hnextCanonical := Snapshot.step_canonical_internal + program input snapshot hcanonical + have htail := ih (snapshot.step program input) hnextCanonical + have hdecode := Snapshot.decode_step_internal + program input snapshot hcanonical + rw [hdecode] at htail + calc + encodedStoreLength + (Snapshot.run program input fuel + (snapshot.step program input)).overlay ≀ + encodedStoreLength (snapshot.step program input).overlay + + 2 * (RAM.unitTimeUpto program fuel + (RAM.step program (snapshot.decode input)) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel + (RAM.step program (snapshot.decode input))) := htail + _ ≀ (encodedStoreLength snapshot.overlay + + 2 * (programStaticWidth program + + RAM.stepLogCost program (snapshot.decode input) + 1)) + + 2 * (RAM.unitTimeUpto program fuel + (RAM.step program (snapshot.decode input)) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel + (RAM.step program (snapshot.decode input))) := + Nat.add_le_add_right hstep _ + _ = encodedStoreLength snapshot.overlay + + 2 * ((1 + RAM.unitTimeUpto program fuel + (RAM.step program (snapshot.decode input))) * + (programStaticWidth program + 1) + + (RAM.stepLogCost program (snapshot.decode input) + + RAM.logTimeUpto program fuel + (RAM.step program (snapshot.decode input)))) := by ring + +theorem Snapshot.initial_length_run_le_internal (program : Program) + (input : List Bool) (fuel : β„•) : + ((Snapshot.initial input).run program input fuel).overlay.length ≀ + 1 + RAM.unitTimeUpto program fuel (RAM.initCfg input) := by + have hrun := Snapshot.length_run_le_internal program input fuel + (Snapshot.initial input) (Snapshot.initial_canonical_internal input) + rw [Snapshot.initial_decode_internal input] at hrun + simpa [Snapshot.initial, write, RegisterStore.write] using hrun + +theorem Snapshot.initial_encodedStoreLength_run_le_internal + (program : Program) (input : List Bool) (fuel : β„•) : + encodedStoreLength + ((Snapshot.initial input).run program input fuel).overlay ≀ + 2 * bitlen (input.length + 1) + 2 + + 2 * (RAM.unitTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input)) := by + have hrun := Snapshot.encodedStoreLength_run_le_internal program input fuel + (Snapshot.initial input) (Snapshot.initial_canonical_internal input) + rw [Snapshot.initial_decode_internal input] at hrun + have hentry : (Entry.encode (0, input.length + 1)).length = + 2 * bitlen (input.length + 1) + 2 := by + rw [Entry.encode_length_internal] + have hz : bitlen 0 = 0 := rfl + simp [hz] + simpa [Snapshot.initial, write, RegisterStore.write, encodedStoreLength, + hentry] using hrun + +theorem Snapshot.initial_encode_length_internal (input : List Bool) : + (Snapshot.initial input).encode.length = + 2 * bitlen (input.length + 1) + 6 := by + rw [Snapshot.encode, Snapshot.initial, RegisterStore.Snapshot.encode] + have hz : bitlen 0 = 0 := rfl + have hone : bitlen 1 = 1 := rfl + simp [write, RegisterStore.write, Entry.encode, WordCode.encode, + Nat.length_toBitsLE, hz, hone] + omega + +end DenseOverlay +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Internal.lean new file mode 100644 index 0000000000..fbc2c89734 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Internal.lean @@ -0,0 +1,1146 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import Mathlib.Algebra.Order.Ring.Nat + +/-! +# Sparse RAM register stores on Turing tapes: proof internals + +This module proves the finite-store semantics and codec round trips exposed by +the surface module. It is not part of the human-audited definitions layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +private theorem read_eq_zero_of_not_mem (store : Store) (address : β„•) + (haddress : address βˆ‰ store.map Prod.fst) : + read store address = 0 := by + induction store with + | nil => rfl + | cons entry rest ih => + rcases entry with ⟨storedAddress, value⟩ + simp only [List.map_cons, List.mem_cons, not_or] at haddress + simp only [read, haddress.1, ↓reduceIte] + exact ih haddress.2 + +theorem read_write_internal (store : Store) (hstore : AddressesNodup store) + (address value target : β„•) : + read (write store address value) target = + Function.update (read store) address value target := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> by_cases htarget : target = address + Β· simp [write, read, hvalue, htarget, Function.update] + Β· simp [write, read, hvalue, htarget, Function.update] + Β· simp [write, read, hvalue, htarget, Function.update] + Β· simp [write, read, hvalue, htarget, Function.update] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + simp only [AddressesNodup, List.map_cons, List.nodup_cons] at hstore + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· subst value + by_cases htarget : target = storedAddress + Β· subst target + simp only [write, ↓reduceIte, read, Function.update_self] + exact read_eq_zero_of_not_mem rest storedAddress hstore.1 + Β· simp [write, read, htarget] + Β· by_cases htarget : target = storedAddress + Β· subst target + simp [write, read, hvalue] + Β· simp [write, read, hvalue, htarget] + Β· by_cases htarget : target = storedAddress + Β· subst target + have hne : storedAddress β‰  address := Ne.symm haddress + simp [write, read, haddress, hne, Function.update] + Β· simpa [write, read, haddress, htarget, Function.update] using ih hstore.2 + +private theorem mem_addresses_write (store : Store) (address value target : β„•) + (htarget : target ∈ (write store address value).map Prod.fst) : + target = address ∨ target ∈ store.map Prod.fst := by + induction store with + | nil => + by_cases hvalue : value = 0 + Β· simp [write, hvalue] at htarget + Β· simp [write, hvalue] at htarget + exact Or.inl htarget + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simp [write, hvalue] at htarget ⊒ + exact Or.inr htarget + Β· simp [write, hvalue] at htarget ⊒ + rcases htarget with htarget | htarget + Β· exact Or.inl htarget + Β· exact Or.inr htarget + Β· simp only [write, haddress, ↓reduceIte, List.map_cons, + List.mem_cons] at htarget ⊒ + rcases htarget with htarget | htarget + Β· exact Or.inr (Or.inl htarget) + Β· rcases ih htarget with htarget | htarget + Β· exact Or.inl htarget + Β· exact Or.inr (Or.inr htarget) + +theorem write_addressesNodup_internal (store : Store) + (hstore : AddressesNodup store) (address value : β„•) : + AddressesNodup (write store address value) := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> + simp [AddressesNodup, write, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + simp only [AddressesNodup, List.map_cons, List.nodup_cons] at hstore + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simpa [AddressesNodup, write, hvalue] using hstore.2 + Β· simpa [AddressesNodup, write, hvalue] using hstore + Β· simp only [write, haddress, ↓reduceIte, AddressesNodup, + List.map_cons, List.nodup_cons] + refine ⟨?_, ih hstore.2⟩ + intro hmem + rcases mem_addresses_write rest address value storedAddress hmem with + heq | hmem + Β· exact haddress heq.symm + Β· exact hstore.1 hmem + +theorem write_valuesNonzero_internal (store : Store) + (hstore : ValuesNonzero store) (address value : β„•) : + ValuesNonzero (write store address value) := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> + simp [ValuesNonzero, write, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + have hstored : storedValue β‰  0 := hstore (storedAddress, storedValue) (by simp) + have hrest : ValuesNonzero rest := by + intro restEntry hmem + exact hstore restEntry (by simp [hmem]) + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simpa [write, hvalue] using hrest + Β· simp only [write, hvalue, ↓reduceIte] + intro current hmem + rcases List.mem_cons.mp hmem with heq | hmem + Β· subst current + exact hvalue + Β· exact hrest current hmem + Β· simp only [write, haddress, ↓reduceIte] + intro current hmem + rcases List.mem_cons.mp hmem with heq | hmem + Β· subst current + exact hstored + Β· exact ih hrest current hmem + +theorem write_canonical_internal (store : Store) (hstore : Canonical store) + (address value : β„•) : + Canonical (write store address value) := by + exact ⟨write_addressesNodup_internal store hstore.1 address value, + write_valuesNonzero_internal store hstore.2 address value⟩ + +theorem decode_write_internal (store : Store) (hstore : AddressesNodup store) + (address value : β„•) : + decode (write store address value) = Function.update (decode store) address value := by + funext target + exact read_write_internal store hstore address value target + +private theorem read_map_entries_of_mem (addresses : List β„•) (regs : β„• β†’ β„•) + (address : β„•) (haddress : address ∈ addresses) : + read (addresses.map fun current => (current, regs current)) address = regs address := by + induction addresses with + | nil => simp at haddress + | cons current rest ih => + simp only [List.mem_cons] at haddress + rcases haddress with haddress | haddress + Β· subst current + simp [read] + Β· by_cases heq : address = current + Β· subst current + simp [read] + Β· simp [read, heq, ih haddress] + +theorem ofRegs_canonical_internal (regs : β„• β†’ β„•) + (hfinite : (Function.support regs).Finite) : + Canonical (ofRegs regs hfinite) := by + constructor + Β· unfold AddressesNodup ofRegs + simpa [Function.comp_def] using + hfinite.toFinset.nodup_toList + Β· intro entry hentry + rcases entry with ⟨address, value⟩ + simp only [ofRegs, List.mem_map] at hentry + obtain ⟨storedAddress, hstored, heq⟩ := hentry + simp only [Prod.mk.injEq] at heq + rcases heq with ⟨rfl, rfl⟩ + exact Function.mem_support.mp + (hfinite.mem_toFinset.mp (Finset.mem_toList.mp hstored)) + +theorem decode_ofRegs_internal (regs : β„• β†’ β„•) + (hfinite : (Function.support regs).Finite) : + decode (ofRegs regs hfinite) = regs := by + funext address + by_cases haddress : address ∈ Function.support regs + Β· unfold ofRegs + apply read_map_entries_of_mem + rw [Finset.mem_toList, hfinite.mem_toFinset] + exact haddress + Β· have hnotmem : address βˆ‰ (ofRegs regs hfinite).map Prod.fst := by + unfold ofRegs + simpa [Function.comp_def, hfinite.mem_toFinset] using haddress + rw [decode, read_eq_zero_of_not_mem _ _ hnotmem] + have hzero : Β¬regs address β‰  0 := by + simpa only [Function.mem_support] using haddress + by_contra hne + exact hzero (Ne.symm hne) + +theorem ofRegs_represents_internal (regs : β„• β†’ β„•) + (hfinite : (Function.support regs).Finite) : + Represents (ofRegs regs hfinite) regs := + ⟨ofRegs_canonical_internal regs hfinite, decode_ofRegs_internal regs hfinite⟩ + +private theorem initRegs_ne_zero_address_lt (input : List Bool) (address : β„•) + (hvalue : initRegs input address β‰  0) : + address < input.length + 1 := by + by_contra hlt + rw [not_lt] at hlt + have haddress : address β‰  0 := by omega + apply hvalue + simp only [initRegs, haddress, ite_false] + rw [List.getElem?_eq_none (show input.length ≀ address - 1 by omega)] + +private theorem initRegs_le_length_add_one (input : List Bool) (address : β„•) : + initRegs input address ≀ input.length + 1 := by + simp only [initRegs] + split + Β· omega + Β· split + Β· split <;> omega + Β· omega + +theorem initialStore_canonical_internal (input : List Bool) : + Canonical (initialStore input) := by + constructor + Β· unfold AddressesNodup initialStore + simp [Function.comp_def] + Β· intro entry hentry + rcases entry with ⟨address, value⟩ + simp only [initialStore, List.mem_map] at hentry + obtain ⟨storedAddress, hstored, heq⟩ := hentry + simp only [Prod.mk.injEq] at heq + rcases heq with ⟨rfl, rfl⟩ + exact (Finset.mem_filter.mp + ((Finset.mem_sort (r := (Β· ≀ Β·))).mp hstored)).2 + +theorem decode_initialStore_internal (input : List Bool) : + decode (initialStore input) = initRegs input := by + funext address + by_cases hvalue : initRegs input address = 0 + Β· have hnotmem : address βˆ‰ (initialStore input).map Prod.fst := by + unfold initialStore + simp [Function.comp_def, initialAddresses, hvalue] + rw [decode, read_eq_zero_of_not_mem _ _ hnotmem, hvalue] + Β· apply read_map_entries_of_mem + rw [Finset.mem_sort (r := (Β· ≀ Β·)), initialAddresses, + Finset.mem_filter, Finset.mem_range] + exact ⟨initRegs_ne_zero_address_lt input address hvalue, hvalue⟩ + +theorem Snapshot.initial_represents_internal (input : List Bool) : + (Snapshot.initial input).Represents (RAM.initCfg input) := by + constructor + Β· exact initialStore_canonical_internal input + Β· apply Cfg.ext + Β· rfl + Β· exact decode_initialStore_internal input + +theorem initialStore_length_le_internal (input : List Bool) : + (initialStore input).length ≀ input.length + 1 := by + unfold initialStore initialAddresses + simp only [List.length_map, Finset.length_sort] + simpa using Finset.card_filter_le (Finset.range (input.length + 1)) + (fun address => initRegs input address β‰  0) + +private theorem maxWidth_le (store : Store) (width : β„•) + (hwidth : βˆ€ entry ∈ store, + bitlen entry.1 ≀ width ∧ bitlen entry.2 ≀ width) : + maxWidth store ≀ width := by + induction store with + | nil => simp [maxWidth] + | cons entry rest ih => + have hentry := hwidth entry (by simp) + have hrest : βˆ€ current ∈ rest, + bitlen current.1 ≀ width ∧ bitlen current.2 ≀ width := by + intro current hmem + exact hwidth current (by simp [hmem]) + simp only [maxWidth] + exact max_le hentry.1 (max_le hentry.2 (ih hrest)) + +theorem Snapshot.initial_width_le_internal (input : List Bool) : + (Snapshot.initial input).width ≀ bitlen (input.length + 1) := by + have hlength := initialStore_length_le_internal input + have hcount : bitlen (initialStore input).length ≀ bitlen (input.length + 1) := + Nat.size_le_size hlength + have hstore : maxWidth (initialStore input) ≀ bitlen (input.length + 1) := by + apply maxWidth_le + intro entry hentry + rcases entry with ⟨address, value⟩ + simp only [initialStore, List.mem_map] at hentry + obtain ⟨storedAddress, hstored, heq⟩ := hentry + simp only [Prod.mk.injEq] at heq + rcases heq with ⟨rfl, rfl⟩ + have hmember := Finset.mem_filter.mp + ((Finset.mem_sort (r := (Β· ≀ Β·))).mp hstored) + exact ⟨Nat.size_le_size (Nat.le_of_lt (Finset.mem_range.mp hmember.1)), + Nat.size_le_size (initRegs_le_length_add_one input storedAddress)⟩ + exact max_le (by simp [Snapshot.initial, bitlen]) (max_le hcount hstore) + +theorem Snapshot.ofCfg_represents_internal (cfg : Cfg) + (hfinite : (Function.support cfg.regs).Finite) : + (Snapshot.ofCfg cfg hfinite).Represents cfg := by + constructor + Β· exact ofRegs_canonical_internal cfg.regs hfinite + Β· apply Cfg.ext + Β· rfl + Β· exact decode_ofRegs_internal cfg.regs hfinite + +theorem Snapshot.stepInstr_canonical_internal (instruction : Instr) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + Canonical (Snapshot.stepInstr instruction snapshot).store := by + cases instruction with + | imm destination value => + exact write_canonical_internal snapshot.store hcanonical destination value + | add destination sourceβ‚€ source₁ => + exact write_canonical_internal snapshot.store hcanonical destination _ + | sub destination sourceβ‚€ source₁ => + exact write_canonical_internal snapshot.store hcanonical destination _ + | mul destination sourceβ‚€ source₁ => + exact write_canonical_internal snapshot.store hcanonical destination _ + | load destination addressRegister => + exact write_canonical_internal snapshot.store hcanonical destination _ + | store addressRegister source => + exact write_canonical_internal snapshot.store hcanonical _ _ + | jz source target => + simp only [Snapshot.stepInstr] + split <;> exact hcanonical + | jmp target => exact hcanonical + | halt => exact hcanonical + +theorem Snapshot.decode_stepInstr_internal (instruction : Instr) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (Snapshot.stepInstr instruction snapshot).decode = + RAM.stepInstr instruction snapshot.decode := by + cases instruction with + | imm destination value => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 destination value + | add destination sourceβ‚€ source₁ => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 destination _ + | sub destination sourceβ‚€ source₁ => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 destination _ + | mul destination sourceβ‚€ source₁ => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 destination _ + | load destination addressRegister => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 destination _ + | store addressRegister source => + apply Cfg.ext + Β· rfl + Β· exact decode_write_internal snapshot.store hcanonical.1 _ _ + | jz source target => + by_cases hzero : read snapshot.store source = 0 <;> + simp [Snapshot.stepInstr, RAM.stepInstr, Snapshot.decode, + RegisterStore.decode, hzero] + | jmp target => rfl + | halt => rfl + +theorem Snapshot.curInstr_decode_internal (program : Program) (snapshot : Snapshot) : + RAM.curInstr program snapshot.decode = snapshot.curInstr program := + rfl + +theorem Snapshot.halted_decode_iff_internal (program : Program) (snapshot : Snapshot) : + RAM.Halted program snapshot.decode ↔ snapshot.Halted program := + Iff.rfl + +theorem Snapshot.step_canonical_internal (program : Program) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + Canonical (snapshot.step program).store := + Snapshot.stepInstr_canonical_internal _ snapshot hcanonical + +theorem Snapshot.decode_step_internal (program : Program) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.step program).decode = RAM.step program snapshot.decode := by + exact Snapshot.decode_stepInstr_internal _ snapshot hcanonical + +theorem Snapshot.run_canonical_internal (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + Canonical (snapshot.run program fuel).store := by + induction fuel generalizing snapshot with + | zero => exact hcanonical + | succ fuel ih => + rw [Snapshot.run] + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt] + exact hcanonical + Β· rw [ite_eq_right hhalt] + exact ih (snapshot.step program) + (Snapshot.step_canonical_internal program snapshot hcanonical) + +theorem Snapshot.decode_run_internal (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).decode = RAM.run program fuel snapshot.decode := by + induction fuel generalizing snapshot with + | zero => rfl + | succ fuel ih => + rw [Snapshot.run, RAM.run] + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt, + ite_eq_left ((Snapshot.halted_decode_iff_internal program snapshot).mpr hhalt)] + Β· rw [ite_eq_right hhalt, + ite_eq_right (mt (Snapshot.halted_decode_iff_internal program snapshot).mp hhalt)] + rw [ih (snapshot.step program) + (Snapshot.step_canonical_internal program snapshot hcanonical)] + rw [Snapshot.decode_step_internal program snapshot hcanonical] + +private theorem bitlen_succ_le (value : β„•) : + bitlen (value + 1) ≀ bitlen value + 1 := by + rw [bitlen, bitlen, Nat.size_le] + have hvalue := Nat.lt_size_self value + have hpowPos : 0 < 2 ^ value.size := pow_pos (by omega) _ + rw [pow_succ] + omega + +private theorem length_write_le (store : Store) (address value : β„•) : + (write store address value).length ≀ store.length + 1 := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> simp [write, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simp [write, hvalue] + omega + Β· simp [write, hvalue] + Β· simp [write, haddress, ih] + +private theorem maxWidth_write_le (store : Store) (address value : β„•) : + maxWidth (write store address value) ≀ + max (maxWidth store) (max (bitlen address) (bitlen value)) := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> simp [write, maxWidth, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simp [write, maxWidth, hvalue] + Β· simp [write, maxWidth, hvalue] + omega + Β· simp only [write, haddress, ↓reduceIte, maxWidth] + omega + +private theorem Snapshot.width_write_le (snapshot : Snapshot) + (address value newPC bound : β„•) + (hbase : snapshot.width + 1 ≀ bound) + (hpc : bitlen newPC ≀ bound) + (haddress : bitlen address ≀ bound) + (hvalue : bitlen value ≀ bound) : + Snapshot.width { pc := newPC, store := write snapshot.store address value } ≀ bound := by + have holdCount : bitlen snapshot.store.length ≀ snapshot.width := + le_trans (le_max_left _ _) (le_max_right _ _) + have holdStore : maxWidth snapshot.store ≀ snapshot.width := + le_trans (le_max_right _ _) (le_max_right _ _) + have hlength := length_write_le snapshot.store address value + have hcountStep : bitlen (write snapshot.store address value).length ≀ + bitlen (snapshot.store.length + 1) := by + exact Nat.size_le_size hlength + have hcountSucc := bitlen_succ_le snapshot.store.length + have hcount : bitlen (write snapshot.store address value).length ≀ bound := by + omega + have hstoreStep := maxWidth_write_le snapshot.store address value + have hstore : maxWidth (write snapshot.store address value) ≀ bound := by + exact le_trans hstoreStep + (max_le (le_trans holdStore (by omega)) (max_le haddress hvalue)) + exact max_le hpc (max_le hcount hstore) + +private theorem Snapshot.width_pc_le (snapshot : Snapshot) (newPC bound : β„•) + (hbase : snapshot.width + 1 ≀ bound) + (hpc : bitlen newPC ≀ bound) : + Snapshot.width { snapshot with pc := newPC } ≀ bound := by + have hrest : max (bitlen snapshot.store.length) (maxWidth snapshot.store) ≀ + snapshot.width := le_max_right _ _ + exact max_le hpc (le_trans hrest (by omega)) + +theorem Snapshot.width_stepInstr_le_internal (instruction : Instr) + (snapshot : Snapshot) : + (Snapshot.stepInstr instruction snapshot).width ≀ + snapshot.stepWidthBound instruction := by + let bound := snapshot.stepWidthBound instruction + have hbase : snapshot.width + 1 ≀ bound := by + exact le_max_left _ _ + have hstatic : RegisterStore.Instr.staticWidth instruction ≀ bound := + le_trans (le_max_left _ _) (le_max_right _ _) + have hcost : instruction.logCost snapshot.decode ≀ bound := + le_trans (le_max_right _ _) (le_max_right _ _) + have holdPC : bitlen snapshot.pc ≀ snapshot.width := le_max_left _ _ + have hnextPC : bitlen (snapshot.pc + 1) ≀ bound := by + have := bitlen_succ_le snapshot.pc + omega + cases instruction with + | imm destination value => + apply Snapshot.width_write_le snapshot destination value + (snapshot.pc + 1) bound hbase hnextPC + Β· exact le_trans (le_max_left _ _) hstatic + Β· exact le_trans (le_max_right _ _) hstatic + | add destination sourceβ‚€ source₁ => + apply Snapshot.width_write_le snapshot destination + (read snapshot.store sourceβ‚€ + read snapshot.store source₁) + (snapshot.pc + 1) bound hbase hnextPC + Β· exact le_trans (le_max_left _ _) hstatic + Β· simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + | sub destination sourceβ‚€ source₁ => + apply Snapshot.width_write_le snapshot destination + (read snapshot.store sourceβ‚€ - read snapshot.store source₁) + (snapshot.pc + 1) bound hbase hnextPC + Β· exact le_trans (le_max_left _ _) hstatic + Β· have hsub : bitlen (read snapshot.store sourceβ‚€ - read snapshot.store source₁) ≀ + bitlen (read snapshot.store sourceβ‚€) := + Nat.size_le_size (Nat.sub_le _ _) + simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + | mul destination sourceβ‚€ source₁ => + apply Snapshot.width_write_le snapshot destination + (read snapshot.store sourceβ‚€ * read snapshot.store source₁) + (snapshot.pc + 1) bound hbase hnextPC + Β· exact le_trans (le_max_left _ _) hstatic + Β· simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + | load destination addressRegister => + apply Snapshot.width_write_le snapshot destination + (read snapshot.store (read snapshot.store addressRegister)) + (snapshot.pc + 1) bound hbase hnextPC + Β· exact le_trans (le_max_left _ _) hstatic + Β· simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + | store addressRegister source => + apply Snapshot.width_write_le snapshot + (read snapshot.store addressRegister) (read snapshot.store source) + (snapshot.pc + 1) bound hbase hnextPC + Β· simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + Β· simp only [Instr.logCost, Snapshot.decode, RegisterStore.decode] at hcost + omega + | jz source target => + by_cases hzero : read snapshot.store source = 0 + Β· simp only [Snapshot.stepInstr, hzero, ↓reduceIte] + apply Snapshot.width_pc_le snapshot target bound hbase + exact le_trans (le_max_right _ _) hstatic + Β· simp only [Snapshot.stepInstr, hzero, ↓reduceIte] + exact Snapshot.width_pc_le snapshot (snapshot.pc + 1) bound hbase hnextPC + | jmp target => + apply Snapshot.width_pc_le snapshot target bound hbase + exact hstatic + | halt => + exact le_trans (Nat.le_add_right snapshot.width 1) hbase + +private theorem staticWidth_curInstr_le (program : Program) (pc : β„•) : + RegisterStore.Instr.staticWidth ((program[pc]?).getD Instr.halt) ≀ + programStaticWidth program := by + induction program generalizing pc with + | nil => simp [programStaticWidth, RegisterStore.Instr.staticWidth] + | cons instruction rest ih => + cases pc with + | zero => simp [programStaticWidth] + | succ pc => + simp only [List.getElem?_cons_succ] + exact le_trans (ih pc) (le_max_right _ _) + +theorem Snapshot.width_step_le_internal (program : Program) (snapshot : Snapshot) : + (snapshot.step program).width ≀ + max (snapshot.width + 1) + (max (programStaticWidth program) (RAM.stepLogCost program snapshot.decode)) := by + have hstep := Snapshot.width_stepInstr_le_internal + (snapshot.curInstr program) snapshot + have hstatic := staticWidth_curInstr_le program snapshot.pc + apply le_trans hstep + apply max_le + Β· exact le_max_left _ _ + Β· apply max_le + Β· exact le_trans hstatic (le_trans (le_max_left _ _) (le_max_right _ _)) + Β· exact le_trans (le_max_right _ _) (le_max_right _ _) + +theorem Snapshot.length_stepInstr_le_internal (instruction : Instr) + (snapshot : Snapshot) : + (Snapshot.stepInstr instruction snapshot).store.length ≀ + snapshot.store.length + 1 := by + cases instruction with + | imm destination value => exact length_write_le snapshot.store destination value + | add destination sourceβ‚€ source₁ => exact length_write_le snapshot.store destination _ + | sub destination sourceβ‚€ source₁ => exact length_write_le snapshot.store destination _ + | mul destination sourceβ‚€ source₁ => exact length_write_le snapshot.store destination _ + | load destination addressRegister => exact length_write_le snapshot.store destination _ + | store addressRegister source => exact length_write_le snapshot.store _ _ + | jz source target => + simp only [Snapshot.stepInstr] + split <;> simp + | jmp target => simp [Snapshot.stepInstr] + | halt => simp [Snapshot.stepInstr] + +theorem Snapshot.length_run_le_internal (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).store.length ≀ + snapshot.store.length + RAM.unitTimeUpto program fuel snapshot.decode := by + induction fuel generalizing snapshot with + | zero => simp [Snapshot.run, RAM.unitTimeUpto] + | succ fuel ih => + rw [Snapshot.run, RAM.unitTimeUpto] + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt, + ite_eq_left ((Snapshot.halted_decode_iff_internal program snapshot).mpr hhalt)] + omega + Β· rw [ite_eq_right hhalt, + ite_eq_right (mt (Snapshot.halted_decode_iff_internal program snapshot).mp hhalt)] + have hstep := Snapshot.length_stepInstr_le_internal + (snapshot.curInstr program) snapshot + have hstep' : (snapshot.step program).store.length ≀ + snapshot.store.length + 1 := by + simpa only [Snapshot.step] using hstep + have hstepCanonical := Snapshot.step_canonical_internal + program snapshot hcanonical + have hrun := ih (snapshot.step program) hstepCanonical + rw [Snapshot.decode_step_internal program snapshot hcanonical] at hrun + omega + +theorem Snapshot.width_run_le_internal (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).width ≀ + snapshot.width + RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode := by + induction fuel generalizing snapshot with + | zero => simp [Snapshot.run] + | succ fuel ih => + rw [Snapshot.run, RAM.unitTimeUpto, RAM.logTimeUpto] + by_cases hhalt : snapshot.Halted program + Β· rw [ite_eq_left hhalt, + ite_eq_left ((Snapshot.halted_decode_iff_internal program snapshot).mpr hhalt), + ite_eq_left ((Snapshot.halted_decode_iff_internal program snapshot).mpr hhalt)] + omega + Β· rw [ite_eq_right hhalt, + ite_eq_right (mt (Snapshot.halted_decode_iff_internal program snapshot).mp hhalt), + ite_eq_right (mt (Snapshot.halted_decode_iff_internal program snapshot).mp hhalt)] + have hstepCanonical := Snapshot.step_canonical_internal + program snapshot hcanonical + have hrun := ih (snapshot.step program) hstepCanonical + rw [Snapshot.decode_step_internal program snapshot hcanonical] at hrun + have hstep := Snapshot.width_step_le_internal program snapshot + rw [Nat.add_mul] + omega + +private theorem WordCode.decodeAux?_replicate_true + (remaining consumed : β„•) (payload suffix : List Bool) + (hlength : payload.length = consumed + remaining) : + WordCode.decodeAux? + (List.replicate remaining true ++ false :: payload ++ suffix) consumed = + some (Nat.fromBitsLE payload, suffix) := by + induction remaining generalizing consumed with + | zero => + have hconsumed : consumed = payload.length := by omega + subst consumed + simp [WordCode.decodeAux?] + | succ remaining ih => + simp only [List.replicate_succ, List.cons_append, WordCode.decodeAux?] + apply ih (consumed + 1) + omega + +theorem WordCode.decodePrefix?_encode_append_internal (value : β„•) + (suffix : List Bool) : + WordCode.decodePrefix? (WordCode.encode value ++ suffix) = + some (value, suffix) := by + have hdecode := WordCode.decodeAux?_replicate_true + (bitlen value) 0 (Nat.toBitsLE (bitlen value) value) suffix + (by simp [bitlen, Nat.length_toBitsLE]) + have hround : Nat.fromBitsLE (Nat.toBitsLE (bitlen value) value) = value := by + apply Nat.fromBitsLE_toBitsLE + simpa [bitlen] using Nat.lt_size_self value + rw [hround] at hdecode + simpa [WordCode.decodePrefix?, WordCode.encode, List.append_assoc] using hdecode + +theorem WordCode.decodePrefix?_encode_internal (value : β„•) : + WordCode.decodePrefix? (WordCode.encode value) = some (value, []) := by + simpa using WordCode.decodePrefix?_encode_append_internal value [] + +theorem WordCode.encode_length_internal (value : β„•) : + (WordCode.encode value).length = 2 * bitlen value + 1 := by + simp [WordCode.encode, Nat.length_toBitsLE] + omega + +theorem Entry.decodePrefix?_encode_append_internal (entry : Entry) + (suffix : List Bool) : + Entry.decodePrefix? (Entry.encode entry ++ suffix) = some (entry, suffix) := by + rcases entry with ⟨address, value⟩ + simp [Entry.encode, Entry.decodePrefix?, List.append_assoc, + WordCode.decodePrefix?_encode_append_internal] + +theorem Entry.encode_length_internal (entry : Entry) : + (Entry.encode entry).length = + 2 * bitlen entry.1 + 2 * bitlen entry.2 + 2 := by + rw [Entry.encode, List.length_append, + WordCode.encode_length_internal, WordCode.encode_length_internal] + omega + +theorem encodedStoreLength_write_le_internal (store : Store) + (address value : β„•) : + encodedStoreLength (write store address value) ≀ + encodedStoreLength store + (Entry.encode (address, value)).length := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> + simp [encodedStoreLength, write, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· subst value + simp only [write, ↓reduceIte, encodedStoreLength, + List.flatMap_cons, List.length_append] + exact le_trans (Nat.le_add_left _ _) + (Nat.le_add_right _ _) + Β· simp only [write, hvalue, ↓reduceIte, encodedStoreLength, + List.flatMap_cons, List.length_append] + calc + (Entry.encode (storedAddress, value)).length + + (List.flatMap Entry.encode rest).length = + (List.flatMap Entry.encode rest).length + + (Entry.encode (storedAddress, value)).length := by omega + _ ≀ ((Entry.encode (storedAddress, storedValue)).length + + (List.flatMap Entry.encode rest).length) + + (Entry.encode (storedAddress, value)).length := + Nat.add_le_add_right (Nat.le_add_left _ _) _ + Β· unfold encodedStoreLength at ih + simp only [write, haddress, ↓reduceIte, encodedStoreLength, + List.flatMap_cons, List.length_append] + simpa only [Nat.add_assoc] using + Nat.add_le_add_left ih + (Entry.encode (storedAddress, storedValue)).length + +private theorem encodedStoreLength_stepInstr_le (instruction : Instr) + (snapshot : Snapshot) : + encodedStoreLength (Snapshot.stepInstr instruction snapshot).store ≀ + encodedStoreLength snapshot.store + + 4 * (RegisterStore.Instr.staticWidth instruction + + instruction.logCost snapshot.decode + 1) := by + cases instruction with + | imm destination value => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + destination value + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost] + omega + | add destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + destination + (read snapshot.store sourceβ‚€ + read snapshot.store source₁) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, RegisterStore.decode] + omega + | sub destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + destination + (read snapshot.store sourceβ‚€ - read snapshot.store source₁) + have hsub : bitlen + (read snapshot.store sourceβ‚€ - read snapshot.store source₁) ≀ + bitlen (read snapshot.store sourceβ‚€) := + Nat.size_le_size (Nat.sub_le _ _) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, RegisterStore.decode] + omega + | mul destination sourceβ‚€ source₁ => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + destination + (read snapshot.store sourceβ‚€ * read snapshot.store source₁) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, RegisterStore.decode] + omega + | load destination addressRegister => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + destination (read snapshot.store (read snapshot.store addressRegister)) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, RegisterStore.decode] + omega + | store addressRegister source => + have hwrite := encodedStoreLength_write_le_internal snapshot.store + (read snapshot.store addressRegister) (read snapshot.store source) + apply le_trans hwrite + rw [Entry.encode_length_internal] + simp only [RegisterStore.Instr.staticWidth, Instr.logCost, + Snapshot.decode, RegisterStore.decode] + omega + | jz source target => + simp only [Snapshot.stepInstr] + split <;> simp [encodedStoreLength] + | jmp target => simp [Snapshot.stepInstr] + | halt => simp [Snapshot.stepInstr] + +private theorem encodedStoreLength_step_le (program : Program) + (snapshot : Snapshot) : + encodedStoreLength (snapshot.step program).store ≀ + encodedStoreLength snapshot.store + + 4 * (programStaticWidth program + + RAM.stepLogCost program snapshot.decode + 1) := by + have hstep := encodedStoreLength_stepInstr_le + (snapshot.curInstr program) snapshot + have hstatic : RegisterStore.Instr.staticWidth + (snapshot.curInstr program) ≀ programStaticWidth program := by + simpa only [Snapshot.curInstr] using + staticWidth_curInstr_le program snapshot.pc + apply le_trans hstep + apply Nat.add_le_add_left + have hcost : (snapshot.curInstr program).logCost snapshot.decode = + RAM.stepLogCost program snapshot.decode := rfl + rw [hcost] + exact Nat.mul_le_mul_left 4 + (Nat.add_le_add_right + (Nat.add_le_add_right hstatic _) 1) + +theorem Snapshot.encodedStoreLength_run_le_internal (program : Program) + (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + encodedStoreLength (snapshot.run program fuel).store ≀ + encodedStoreLength snapshot.store + + 4 * (RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) := by + induction fuel generalizing snapshot with + | zero => simp [Snapshot.run, RAM.unitTimeUpto, RAM.logTimeUpto] + | succ fuel ih => + rw [Snapshot.run] + by_cases hhalt : snapshot.Halted program + Β· have hramHalted := + (Snapshot.halted_decode_iff_internal program snapshot).mpr hhalt + simp only [hhalt, hramHalted, if_true, RAM.unitTimeUpto, + RAM.logTimeUpto] + simp + Β· have hramNotHalted : Β¬RAM.Halted program snapshot.decode := + mt (Snapshot.halted_decode_iff_internal program snapshot).mp hhalt + rw [ite_eq_right hhalt] + simp only [RAM.unitTimeUpto, RAM.logTimeUpto, hramNotHalted, + ite_false] + have hstep := encodedStoreLength_step_le program snapshot + have hnextCanonical := + Snapshot.step_canonical_internal program snapshot hcanonical + have htail := ih (snapshot.step program) hnextCanonical + have hdecode := Snapshot.decode_step_internal program snapshot hcanonical + rw [hdecode] at htail + calc + encodedStoreLength + (Snapshot.run program fuel (snapshot.step program)).store ≀ + encodedStoreLength (snapshot.step program).store + + 4 * (RAM.unitTimeUpto program fuel + (RAM.step program snapshot.decode) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel + (RAM.step program snapshot.decode)) := htail + _ ≀ (encodedStoreLength snapshot.store + + 4 * (programStaticWidth program + + RAM.stepLogCost program snapshot.decode + 1)) + + 4 * (RAM.unitTimeUpto program fuel + (RAM.step program snapshot.decode) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel + (RAM.step program snapshot.decode)) := + Nat.add_le_add_right hstep _ + _ = encodedStoreLength snapshot.store + + 4 * ((1 + RAM.unitTimeUpto program fuel + (RAM.step program snapshot.decode)) * + (programStaticWidth program + 1) + + (RAM.stepLogCost program snapshot.decode + + RAM.logTimeUpto program fuel + (RAM.step program snapshot.decode))) := by ring + +private theorem entries_encode_length_le (store : Store) (width : β„•) + (hwidth : βˆ€ entry ∈ store, + bitlen entry.1 ≀ width ∧ bitlen entry.2 ≀ width) : + (store.flatMap Entry.encode).length ≀ store.length * (4 * width + 2) := by + induction store with + | nil => simp + | cons entry rest ih => + have hentry := hwidth entry (by simp) + have hrest : βˆ€ current ∈ rest, + bitlen current.1 ≀ width ∧ bitlen current.2 ≀ width := by + intro current hmem + exact hwidth current (by simp [hmem]) + have hhead : (Entry.encode entry).length ≀ 4 * width + 2 := by + rw [Entry.encode_length_internal] + omega + have htail := ih hrest + simp only [List.flatMap_cons, List.length_append, List.length_cons] + rw [Nat.succ_mul] + omega + +theorem decodeEntries?_encode_append_internal (store : Store) (suffix : List Bool) : + decodeEntries? store.length (store.flatMap Entry.encode ++ suffix) = + some (store, suffix) := by + induction store with + | nil => rfl + | cons entry rest ih => + simp [List.flatMap_cons, decodeEntries?, List.append_assoc, + Entry.decodePrefix?_encode_append_internal, ih] + +theorem Snapshot.decodePrefix?_encode_append_internal (snapshot : Snapshot) + (suffix : List Bool) : + Snapshot.decodePrefix? (snapshot.encode ++ suffix) = some (snapshot, suffix) := by + rcases snapshot with ⟨pc, store⟩ + simp [Snapshot.encode, Snapshot.decodePrefix?, List.append_assoc, + WordCode.decodePrefix?_encode_append_internal, + decodeEntries?_encode_append_internal] + +theorem Snapshot.decodePrefix?_encode_internal (snapshot : Snapshot) : + Snapshot.decodePrefix? snapshot.encode = some (snapshot, []) := by + simpa using Snapshot.decodePrefix?_encode_append_internal snapshot [] + +theorem Snapshot.decode?_encode_internal (snapshot : Snapshot) : + Snapshot.decode? snapshot.encode = some snapshot := by + rw [Snapshot.decode?, Snapshot.decodePrefix?_encode_internal] + rfl + +theorem Snapshot.encode_length_le_internal (snapshot : Snapshot) (width : β„•) + (hpc : bitlen snapshot.pc ≀ width) + (hcount : bitlen snapshot.store.length ≀ width) + (hstore : βˆ€ entry ∈ snapshot.store, + bitlen entry.1 ≀ width ∧ bitlen entry.2 ≀ width) : + snapshot.encode.length ≀ (snapshot.store.length + 1) * (4 * width + 2) := by + have hentries := entries_encode_length_le snapshot.store width hstore + have hpcCode : (WordCode.encode snapshot.pc).length ≀ 2 * width + 1 := by + rw [WordCode.encode_length_internal] + omega + have hcountCode : (WordCode.encode snapshot.store.length).length ≀ 2 * width + 1 := by + rw [WordCode.encode_length_internal] + omega + simp only [Snapshot.encode, List.length_append] + rw [Nat.add_mul] + omega + +private theorem bitlen_le_maxWidth (store : Store) (entry : Entry) + (hentry : entry ∈ store) : + bitlen entry.1 ≀ maxWidth store ∧ bitlen entry.2 ≀ maxWidth store := by + induction store with + | nil => simp at hentry + | cons head rest ih => + simp only [List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· simp [maxWidth] + Β· have hrest := ih hentry + simp only [maxWidth] + have htail : maxWidth rest ≀ + max (bitlen head.1) (max (bitlen head.2) (maxWidth rest)) := + le_trans (le_max_right _ _) (le_max_right _ _) + exact ⟨le_trans hrest.1 htail, le_trans hrest.2 htail⟩ + +theorem encodedStoreLength_initial_le_internal (input : List Bool) : + encodedStoreLength (initialStore input) ≀ + (input.length + 1) * (4 * bitlen (input.length + 1) + 2) := by + have hlength := initialStore_length_le_internal input + have hsnapshotWidth := Snapshot.initial_width_le_internal input + have hstoreWidth : βˆ€ entry ∈ initialStore input, + bitlen entry.1 ≀ bitlen (input.length + 1) ∧ + bitlen entry.2 ≀ bitlen (input.length + 1) := by + intro entry hentry + have hentryWidth := bitlen_le_maxWidth (initialStore input) entry hentry + have hmaxWidth : maxWidth (initialStore input) ≀ + (Snapshot.initial input).width := by + exact le_trans (le_max_right _ _) (le_max_right _ _) + exact ⟨le_trans hentryWidth.1 (le_trans hmaxWidth hsnapshotWidth), + le_trans hentryWidth.2 (le_trans hmaxWidth hsnapshotWidth)⟩ + have hentries := entries_encode_length_le (initialStore input) + (bitlen (input.length + 1)) hstoreWidth + unfold encodedStoreLength + exact le_trans hentries + (Nat.mul_le_mul_right (4 * bitlen (input.length + 1) + 2) hlength) + +theorem Snapshot.encode_length_le_sizeBound_internal (snapshot : Snapshot) : + snapshot.encode.length ≀ snapshot.sizeBound := by + apply Snapshot.encode_length_le_internal snapshot snapshot.width + Β· exact le_max_left _ _ + Β· exact le_trans (le_max_left _ _) (le_max_right _ _) + Β· intro entry hentry + have hwidth := bitlen_le_maxWidth snapshot.store entry hentry + exact ⟨le_trans hwidth.1 (le_trans (le_max_right _ _) (le_max_right _ _)), + le_trans hwidth.2 (le_trans (le_max_right _ _) (le_max_right _ _))⟩ + +theorem Snapshot.encode_length_le_encodedStore_internal (snapshot : Snapshot) : + snapshot.encode.length ≀ + encodedStoreLength snapshot.store + 4 * snapshot.width + 2 := by + have hpc : bitlen snapshot.pc ≀ snapshot.width := le_max_left _ _ + have hcount : bitlen snapshot.store.length ≀ snapshot.width := + le_trans (le_max_left _ _) (le_max_right _ _) + simp only [Snapshot.encode, List.length_append, encodedStoreLength] + rw [WordCode.encode_length_internal, WordCode.encode_length_internal] + omega + +theorem Snapshot.encode_run_length_le_amortized_internal + (program : Program) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + encodedStoreLength snapshot.store + 4 * snapshot.width + + 8 * (RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2 := by + let growth := RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode + have hcode := Snapshot.encode_length_le_encodedStore_internal + (snapshot.run program fuel) + have hentries := Snapshot.encodedStoreLength_run_le_internal + program fuel snapshot hcanonical + have hwidth := Snapshot.width_run_le_internal + program fuel snapshot hcanonical + calc + (snapshot.run program fuel).encode.length ≀ + encodedStoreLength (snapshot.run program fuel).store + + 4 * (snapshot.run program fuel).width + 2 := hcode + _ ≀ (encodedStoreLength snapshot.store + 4 * growth) + + 4 * (snapshot.width + growth) + 2 := by + simpa only [growth, Nat.add_assoc] using Nat.add_le_add_right + (Nat.add_le_add hentries (Nat.mul_le_mul_left 4 hwidth)) 2 + _ = encodedStoreLength snapshot.store + 4 * snapshot.width + + 8 * growth + 2 := by ring + +theorem Snapshot.encode_initial_run_length_le_amortized_internal + (program : Program) (fuel : β„•) (input : List Bool) : + ((Snapshot.initial input).run program fuel).encode.length ≀ + (input.length + 1) * (4 * bitlen (input.length + 1) + 2) + + 4 * bitlen (input.length + 1) + + 8 * (RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 2)) + 2 := by + have hinitial := Snapshot.initial_represents_internal input + have hrun := Snapshot.encode_run_length_le_amortized_internal + program fuel (Snapshot.initial input) hinitial.1 + rw [hinitial.2] at hrun + have hentries := encodedStoreLength_initial_le_internal input + have hentries' : encodedStoreLength (Snapshot.initial input).store ≀ + (input.length + 1) * (4 * bitlen (input.length + 1) + 2) := by + simpa only [Snapshot.initial] using hentries + have hwidth := Snapshot.initial_width_le_internal input + have hunit := RAM.unitTimeUpto_le_logTimeUpto program fuel + (RAM.initCfg input) + have hgrowth : + RAM.unitTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input) ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 2) := by + calc + RAM.unitTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input) ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input) := + Nat.add_le_add_right + (Nat.mul_le_mul_right (programStaticWidth program + 1) hunit) _ + _ = RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 2) := by ring + have hentriesWidth := Nat.add_le_add hentries' + (Nat.mul_le_mul_left 4 hwidth) + have hgrowth' := Nat.mul_le_mul_left 8 hgrowth + exact le_trans hrun + (Nat.add_le_add_right (Nat.add_le_add hentriesWidth hgrowth') 2) + +theorem Snapshot.encode_run_length_le_internal (program : Program) (fuel : β„•) + (snapshot : Snapshot) (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + (snapshot.store.length + RAM.unitTimeUpto program fuel snapshot.decode + 1) * + (4 * (snapshot.width + RAM.unitTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2) := by + have hcode := Snapshot.encode_length_le_sizeBound_internal + (snapshot.run program fuel) + have hlength := Snapshot.length_run_le_internal program fuel snapshot hcanonical + have hwidth := Snapshot.width_run_le_internal program fuel snapshot hcanonical + apply le_trans hcode + unfold Snapshot.sizeBound + apply Nat.mul_le_mul + Β· omega + Β· omega + +theorem Snapshot.encode_run_length_le_logTime_internal + (program : Program) (fuel : β„•) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + (snapshot.run program fuel).encode.length ≀ + (snapshot.store.length + RAM.logTimeUpto program fuel snapshot.decode + 1) * + (4 * (snapshot.width + RAM.logTimeUpto program fuel snapshot.decode * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel snapshot.decode) + 2) := by + have hcode := Snapshot.encode_run_length_le_internal + program fuel snapshot hcanonical + have hunit := RAM.unitTimeUpto_le_logTimeUpto program fuel snapshot.decode + apply le_trans hcode + apply Nat.mul_le_mul + Β· omega + Β· have hmul := Nat.mul_le_mul_right (programStaticWidth program + 1) hunit + omega + +theorem Snapshot.encode_initial_run_length_le_logTime_internal + (program : Program) (fuel : β„•) (input : List Bool) : + ((Snapshot.initial input).run program fuel).encode.length ≀ + (input.length + 1 + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) * + (4 * (bitlen (input.length + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) + + RAM.logTimeUpto program fuel (RAM.initCfg input)) + 2) := by + have hrepresents := Snapshot.initial_represents_internal input + have hcode := Snapshot.encode_run_length_le_logTime_internal program fuel + (Snapshot.initial input) hrepresents.1 + rw [hrepresents.2] at hcode + have hlength := initialStore_length_le_internal input + have hlength' : (Snapshot.initial input).store.length ≀ input.length + 1 := by + simpa only [Snapshot.initial] using hlength + have hwidth := Snapshot.initial_width_le_internal input + apply le_trans hcode + apply Nat.mul_le_mul <;> omega + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine.lean new file mode 100644 index 0000000000..470722e9d7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookupRestore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq.lean new file mode 100644 index 0000000000..8bc26260c7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork + +/-! +# Decoded sparse-address equality + +This module exposes the framed linear-time semantics of address rewind and +comparison used by the concrete sparse register-store scan. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Rewind one decoded address and compare it to a canonical query, preserving +both contents, both left markers, and every unrelated tape. -/ +theorem decodedAddressEqTM_reachesIn_frame {n : β„•} + (addressIdx queryIdx resultIdx : Fin n) + (hdistinct : TM.BinaryEqDistinct addressIdx queryIdx resultIdx) + (addressBits queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ addressIdx).HasBinaryPrefix addressBits) + (haddressStart : (workβ‚€ addressIdx).cells 0 = Ξ“.start) + (hquery : (workβ‚€ queryIdx).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ queryIdx).cells 0 = Ξ“.start) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  addressIdx β†’ i β‰  queryIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start ∧ 1 ≀ (workβ‚€ i).head) + (houtput : outβ‚€.read β‰  Ξ“.start) (houtputHead : 1 ≀ outβ‚€.head) : + βˆƒ c' t, + t ≀ decodedAddressEqTime addressBits queryBits ∧ + (decodedAddressEqTM addressIdx queryIdx resultIdx).reachesIn t + { state := (decodedAddressEqTM addressIdx queryIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (decodedAddressEqTM addressIdx queryIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix + [decide (addressBits = queryBits)] ∧ + (c'.work addressIdx).HasBinaryContent addressBits ∧ + 1 ≀ (c'.work addressIdx).head ∧ + (c'.work addressIdx).cells 0 = Ξ“.start ∧ + (c'.work queryIdx).HasBinaryContent queryBits ∧ + 1 ≀ (c'.work queryIdx).head ∧ + (c'.work queryIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  addressIdx β†’ i β‰  queryIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + decodedAddressEqTM_reachesIn_frame_internal addressIdx queryIdx resultIdx + hdistinct addressBits queryBits inpβ‚€ workβ‚€ outβ‚€ haddress haddressStart + hquery hqueryStart hresult hinput hother houtput houtputHead + +/-- Coarse all-prefix auxiliary-space envelope for decoded-address equality. -/ +theorem decodedAddressEqTM_prefix_withinAuxSpace {n : β„•} + (addressIdx queryIdx resultIdx : Fin n) (addressBits queryBits : List Bool) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (decodedAddressEqTM addressIdx queryIdx resultIdx).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (decodedAddressEqTM addressIdx queryIdx resultIdx).reachesIn + time start current) + (htime : time ≀ decodedAddressEqTime addressBits queryBits) : + current.WithinAuxSpace inputLength + (initialSpace + decodedAddressEqTime addressBits queryBits) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Decoded-address equality preserves one-way output safety. -/ +theorem decodedAddressEqTM_isTransducer {n : β„•} + (addressIdx queryIdx resultIdx : Fin n) : + (decodedAddressEqTM addressIdx queryIdx resultIdx).IsTransducer := by + unfold decodedAddressEqTM + exact (TM.rewindWorkTM_isTransducer addressIdx).seqTM + (TM.binaryEqTM_isTransducer addressIdx queryIdx resultIdx) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Defs.lean new file mode 100644 index 0000000000..f8dbfaec6a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Defs.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines + +/-! +# Decoded sparse-address equality β€” definitions + +The entry decoder leaves an address target at its append position. This stage +rewinds it and compares it against a canonical query address, writing the +Boolean result on a third work tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Rewind a decoded address and compare it with a canonical query address. -/ +def decodedAddressEqTM {n : β„•} + (addressIdx queryIdx resultIdx : Fin n) : TM n := + TM.seqTM (TM.rewindWorkTM addressIdx) + (TM.binaryEqTM addressIdx queryIdx resultIdx) + +/-- Linear time bound for decoded-address equality, including its composition +seam. -/ +def decodedAddressEqTime (addressBits queryBits : List Bool) : β„• := + addressBits.length + 3 + 1 + TM.binaryEqTime addressBits queryBits + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Internal.lean new file mode 100644 index 0000000000..1dbf721f2b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/AddressEq/Internal.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq + +/-! +# Decoded sparse-address equality β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +theorem decodedAddressEqTM_reachesIn_frame_internal {n : β„•} + (addressIdx queryIdx resultIdx : Fin n) + (hdistinct : TM.BinaryEqDistinct addressIdx queryIdx resultIdx) + (addressBits queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ addressIdx).HasBinaryPrefix addressBits) + (haddressStart : (workβ‚€ addressIdx).cells 0 = Ξ“.start) + (hquery : (workβ‚€ queryIdx).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ queryIdx).cells 0 = Ξ“.start) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  addressIdx β†’ i β‰  queryIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start ∧ 1 ≀ (workβ‚€ i).head) + (houtput : outβ‚€.read β‰  Ξ“.start) (houtputHead : 1 ≀ outβ‚€.head) : + βˆƒ c' t, + t ≀ decodedAddressEqTime addressBits queryBits ∧ + (decodedAddressEqTM addressIdx queryIdx resultIdx).reachesIn t + { state := (decodedAddressEqTM addressIdx queryIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (decodedAddressEqTM addressIdx queryIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix + [decide (addressBits = queryBits)] ∧ + (c'.work addressIdx).HasBinaryContent addressBits ∧ + 1 ≀ (c'.work addressIdx).head ∧ + (c'.work addressIdx).cells 0 = Ξ“.start ∧ + (c'.work queryIdx).HasBinaryContent queryBits ∧ + 1 ≀ (c'.work queryIdx).head ∧ + (c'.work queryIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  addressIdx β†’ i β‰  queryIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let rewindTM := TM.rewindWorkTM addressIdx + let compareTM := TM.binaryEqTM addressIdx queryIdx resultIdx + have hrewindOther : βˆ€ i, i β‰  addressIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start ∧ 1 ≀ (workβ‚€ i).head := by + intro i hia + by_cases hiq : i = queryIdx + Β· subst i + exact ⟨hquery.hasBinarySuffix.read_ne_start, by rw [hquery.1]⟩ + Β· by_cases hir : i = resultIdx + Β· subst i + exact ⟨by rw [hresult.read_blank]; decide, by rw [hresult.1]; simp⟩ + Β· exact hother i hia hiq hir + obtain ⟨rewindDone, rewindTime, hrewindTime, hrewindReach, hrewindHalt, + hrewindInput, hrewindAddress, hrewindFrame, hrewindOutput⟩ := + wordTargetRewind_reachesIn_frame addressIdx addressBits inpβ‚€ workβ‚€ outβ‚€ + haddress haddressStart hinput hrewindOther houtput houtputHead + have hrewindQuery : (rewindDone.work queryIdx).HasBinaryString queryBits := by + rw [hrewindFrame queryIdx (Ne.symm hdistinct.lhs_rhs)] + exact hquery + have hrewindResult : (rewindDone.work resultIdx).HasBinaryPrefix [] := by + rw [hrewindFrame resultIdx (Ne.symm hdistinct.lhs_result)] + exact hresult + have hrewindReads : βˆ€ i, (rewindDone.work i).read β‰  Ξ“.start := by + intro i + by_cases hia : i = addressIdx + Β· subst i + exact hrewindAddress.hasBinarySuffix.read_ne_start + Β· rw [hrewindFrame i hia] + exact (hrewindOther i hia).1 + obtain ⟨compareDone, compareTime, hcompareTime, hcompareReach, + hcompareHalt, hcompareInput, hcompareResult, hcompareAddress, + hcompareAddressHead, hcompareQuery, hcompareQueryHead, hcompareFrame, + hcompareOutput⟩ := + TM.binaryEqTM_reachesIn_frame addressIdx queryIdx resultIdx hdistinct + addressBits queryBits rewindDone.input rewindDone.work rewindDone.output + hrewindAddress hrewindQuery hrewindResult + (by rw [hrewindInput]; exact hinput) + (fun i _ _ _ => hrewindReads i) + (by rw [hrewindOutput]; exact houtput) + have htransitionInput : TM.transitionInput rewindDone.input = + rewindDone.input := + TM.transitionInput_eq_self (by rw [hrewindInput]; exact hinput) + have htransitionWork : + (fun i => TM.transitionTape (rewindDone.work i)) = rewindDone.work := by + funext i + exact TM.transitionTape_eq_self (hrewindReads i) + have htransitionOutput : TM.transitionTape rewindDone.output = + rewindDone.output := + TM.transitionTape_eq_self (by rw [hrewindOutput]; exact houtput) + have hcompareReach' : compareTM.reachesIn compareTime + { state := compareTM.qstart + input := TM.transitionInput rewindDone.input + work := fun i => TM.transitionTape (rewindDone.work i) + output := TM.transitionTape rewindDone.output } compareDone := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [compareTM] using hcompareReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn rewindTM compareTM + (by simpa [rewindTM] using hrewindReach) hrewindHalt hcompareReach' + let finalCfg := TM.phase2Wrap rewindTM compareTM compareDone + have hfullReach' : + (decodedAddressEqTM addressIdx queryIdx resultIdx).reachesIn + (rewindTime + 1 + compareTime) + { state := (decodedAddressEqTM addressIdx queryIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } finalCfg := by + simpa [decodedAddressEqTM, rewindTM, compareTM, finalCfg] using! hfullReach + have haddressStartFinal : (finalCfg.work addressIdx).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := decodedAddressEqTM addressIdx queryIdx resultIdx) addressIdx + hfullReach' haddressStart + have hqueryStartFinal : (finalCfg.work queryIdx).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := decodedAddressEqTM addressIdx queryIdx resultIdx) queryIdx + hfullReach' hqueryStart + refine ⟨finalCfg, rewindTime + 1 + compareTime, ?_, hfullReach', ?_, + hcompareInput.trans hrewindInput, hcompareResult, hcompareAddress, + hcompareAddressHead, haddressStartFinal, hcompareQuery, + hcompareQueryHead, hqueryStartFinal, ?_, + hcompareOutput.trans hrewindOutput⟩ + Β· simp only [decodedAddressEqTime] + omega + Β· exact (TM.phase2Wrap_halted_iff rewindTM compareTM compareDone).2 + hcompareHalt + Β· intro i hia hiq hir + change compareDone.work i = workβ‚€ i + rw [hcompareFrame i hia hiq hir, hrewindFrame i hia] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup.lean new file mode 100644 index 0000000000..5c0e72ee4f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Internal + +/-! +# Dense public-input lookup + +This module exposes the fixed leaves used to look through a sparse tagged +overlay into the immutable public-input bank. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- The direct-branch identity leaf preserves a fully parked frame exactly. -/ +theorem denseInputIdleTM_reachesIn_frame {n : β„•} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputIdleTM (n := n)).reachesIn 1 + { state := (denseInputIdleTM (n := n)).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputIdleTM (n := n)).halted c' ∧ + c'.input = inpβ‚€ ∧ c'.work = workβ‚€ ∧ c'.output = outβ‚€ := + denseInputIdleTM_reachesIn_frame_internal inpβ‚€ workβ‚€ outβ‚€ + hinput hwork houtput + +/-- Copy the preceding Boolean input symbol into one canonical work tape and +restore the read-only input head in exactly two transitions. -/ +theorem capturePreviousInputBitTM_reachesIn_frame {n : β„•} + (result : Fin n) (bit : Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.StartInvariant) (hhead : 2 ≀ inpβ‚€.head) + (hbit : inpβ‚€.cells (inpβ‚€.head - 1) = Ξ“.ofBool bit) + (hresult : workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (capturePreviousInputBitTM result).reachesIn 2 + { state := (capturePreviousInputBitTM result).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (capturePreviousInputBitTM result).halted c' ∧ + c'.input = inpβ‚€ ∧ + c'.work = Function.update workβ‚€ result (denseInputBitTape bit) ∧ + c'.output = outβ‚€ := + capturePreviousInputBitTM_reachesIn_frame_internal result bit inpβ‚€ + workβ‚€ outβ‚€ hinput hhead hbit hresult hwork houtput + +/-- The canonical captured-bit tape represents exactly zero or one. -/ +theorem denseInputBitTape_hasBinaryNat (bit : Bool) : + (denseInputBitTape bit).HasBinaryNat (if bit then 1 else 0) := + denseInputBitTape_hasBinaryNat_internal bit + +/-- Every captured-bit tape is parked at its first data cell. -/ +theorem denseInputBitTape_parked (bit : Bool) : + TM.Parked (denseInputBitTape bit) := + denseInputBitTape_parked_internal bit + +/-- One scan body step decrements a positive countdown, captures the preceding +input bit exactly when the countdown reaches zero, and preserves every frame. -/ +theorem denseInputStepTM_reachesIn_frame {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (remaining : β„•) (bit : Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.StartInvariant) (hhead : 2 ≀ inpβ‚€.head) + (hbit : inpβ‚€.cells (inpβ‚€.head - 1) = Ξ“.ofBool bit) + (hcounter : (workβ‚€ counter).HasBinaryNat remaining) + (hresult : remaining = 1 β†’ workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputStepTM counter result).reachesIn + (denseInputStepTime remaining) + { state := (denseInputStepTM counter result).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputStepTM counter result).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work counter).HasBinaryNat (remaining - 1) ∧ + c'.work result = denseInputStepResult remaining bit (workβ‚€ result) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + denseInputStepTM_reachesIn_frame_internal counter result hne remaining bit + inpβ‚€ workβ‚€ outβ‚€ hinput hhead hbit hcounter hresult hwork houtput + +/-- A positive RAM address can be looked up by one exact scan of the immutable +input bank. The scanner leaves the input contents unchanged, parks at the first +blank, decrements its counter once per bit, and returns `RAM.initRegs`. -/ +theorem denseInputScanTM_reachesIn_frame {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (input : List Bool) (address : β„•) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) (haddress : address β‰  0) + (hcounter : (workβ‚€ counter).HasBinaryNat address) + (hresult : workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputScanTM counter result).reachesIn + (denseInputScanTime input.length address) + { state := (denseInputScanTM counter result).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputScanTM counter result).halted c' ∧ + c'.input.head = input.length + 1 ∧ + c'.input.cells = (Tape.init (input.map Ξ“.ofBool)).cells ∧ + (c'.work counter).HasBinaryNat (address - input.length) ∧ + (c'.work result).HasBinaryNat (Complexity.RAM.initRegs input address) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + denseInputScanTM_reachesIn_frame_internal counter result hne input address + workβ‚€ outβ‚€ haddress hcounter hresult hwork houtput + +/-- Dense-bank lookup is linear in the public-input length and logarithmic in +the queried positive address. -/ +theorem denseInputScanTime_le_width (inputLength address : β„•) : + denseInputScanTime inputLength address ≀ + inputLength * (2 * address.size + 9) + 1 := + denseInputScanTime_le_width_internal inputLength address + +/-- Full dense-bank fallback preserves the query and scratch tapes, restores +the input head and countdown tape, and returns the standard RAM input value. -/ +theorem denseInputLookupTM_hoareTime {n : β„•} + (query counter result scratch : Fin n) + (hqc : query β‰  counter) (hqr : query β‰  result) + (hqs : query β‰  scratch) (hcr : counter β‰  result) + (hcs : counter β‰  scratch) (hrs : result β‰  scratch) + (input : List Bool) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (haddress : address β‰  0) + (hready : DenseInputLookupReady query counter result scratch address + initialWork) + (houtput : TM.Parked outβ‚€) : + (denseInputLookupTM query counter result scratch).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInputLookupResult query counter result scratch input address + initialWork work ∧ + out = outβ‚€) + (denseInputLookupTime input.length address) := + denseInputLookupTM_hoareTime_internal query counter result scratch + hqc hqr hqs hcr hcs hrs input address initialWork outβ‚€ haddress + hready houtput + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Defs.lean new file mode 100644 index 0000000000..eb04d0b80f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Defs.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs + +/-! +# Dense public-input lookup -- definitions + +These finite controllers are the concrete bridge from a sparse mutable RAM +overlay to the immutable public input on the Turing input tape. The scan keeps +a binary countdown on a work tape. When that countdown first reaches zero, +the preceding input symbol is copied to a canonical Boolean result tape. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Two-state framed identity used as a direct-branch leaf. -/ +inductive DenseInputIdlePhase where + | run + | done + deriving DecidableEq + +instance : Fintype DenseInputIdlePhase where + elems := {.run, .done} + complete := fun phase => by cases phase <;> simp + +/-- A one-step identity on every parked tape. -/ +def denseInputIdleTM {n : β„•} : TM n where + Q := DenseInputIdlePhase + qstart := .run + qhalt := .done + Ξ΄ := fun _ iHead wHeads oHead => + (.done, fun i => TM.readBackWrite (wHeads i), TM.readBackWrite oHead, + TM.idleDir iHead, fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + Ξ΄_right_of_start := fun _ _ _ _ => + ⟨TM.idleDir_right_of_start, fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + +/-- Two-step controller that moves left to the preceding input symbol, copies +that Boolean value to one work cell, and restores the input head. -/ +inductive DenseInputCapturePhase where + | moveLeft + | write + | done + deriving DecidableEq + +instance : Fintype DenseInputCapturePhase where + elems := {.moveLeft, .write, .done} + complete := fun phase => by cases phase <;> simp + +/-- Canonical binary work tape representing one public-input bit. -/ +def denseInputBitTape (bit : Bool) : Tape := + TM.resetBinaryBlank.writeAndMove + (if bit then Ξ“w.one.toΞ“ else Ξ“w.blank.toΞ“) Dir3.stay + +/-- Copy the Boolean input symbol immediately to the left of the current head +onto a blank canonical result tape, restoring the input head in two steps. -/ +def capturePreviousInputBitTM {n : β„•} (result : Fin n) : TM n where + Q := DenseInputCapturePhase + qstart := .moveLeft + qhalt := .done + Ξ΄ := fun phase iHead wHeads oHead => + match phase with + | .moveLeft => + (.write, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.moveLeftDir iHead, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + | .write => + (.done, + fun i => + if i = result then + if iHead = Ξ“.one then Ξ“w.one else Ξ“w.blank + else TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, Dir3.right, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro phase iHead wHeads oHead + cases phase with + | moveLeft => + exact ⟨TM.moveLeftDir_right_of_start, + fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + | write => + exact ⟨fun _ => rfl, fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- One input-scan body step. A zero countdown is stationary. A positive +countdown is decremented; when it becomes zero, the preceding input bit is +captured exactly once. -/ +def denseInputStepTM {n : β„•} (counter result : Fin n) : TM n := + TM.branchWorkBlankTM counter denseInputIdleTM + (TM.seqTM (TM.binaryPredTM counter) + (TM.branchWorkBlankTM counter + (capturePreviousInputBitTM result) denseInputIdleTM)) + +/-- Exact body time as a function of the positive-or-zero countdown. -/ +def denseInputStepTime (remaining : β„•) : β„• := + if remaining = 0 then 2 + else if remaining = 1 then TM.binaryPredTime 0 + 5 + else TM.binaryPredTime (remaining - 1) + 4 + +/-- Result tape after one scan iteration. Only the transition from countdown +one to zero captures the current input bit. -/ +def denseInputStepResult (remaining : β„•) (bit : Bool) + (current : Tape) : Tape := + if remaining = 1 then denseInputBitTape bit else current + +/-- Scan the entire immutable Boolean input while decrementing a canonical +binary address counter and capturing the addressed bit. -/ +def denseInputScanTM {n : β„•} (counter result : Fin n) : TM n := + TM.forInputTM (denseInputStepTM counter result) + +/-- Exact complete input-scan time from a positive address. -/ +def denseInputScanTime (inputLength address : β„•) : β„• := + TM.forInputLoopTime + (fun processed => denseInputStepTime (address - processed)) + 0 inputLength + +/-- Full positive-address dense-bank fallback: copy the query into a private +countdown, scan the immutable input, rewind the input head, and clear the +countdown back to the reusable blank boundary. -/ +def denseInputLookupTM {n : β„•} + (query counter result scratch : Fin n) : TM n := + TM.seqTM (TM.binaryCopyIntoTM query counter scratch) + (TM.seqTM (denseInputScanTM counter result) + (TM.seqTM TM.rewindInputTM (TM.resetBinaryWorkTM counter))) + +/-- Complete fallback budget, including all three sequencing seams. -/ +def denseInputLookupTime (inputLength address : β„•) : β„• := + TM.binaryCopyTime address 0 + 1 + + (denseInputScanTime inputLength address + 1 + + (inputLength + 3 + 1 + + TM.resetBinaryWorkTime 1 (address - inputLength).bits.length)) + +/-- Reusable work-tape boundary before a positive-address dense-bank lookup. -/ +structure DenseInputLookupReady {n : β„•} + (query counter result scratch : Fin n) (address : β„•) + (work : Fin n β†’ Tape) : Prop where + query : (work query).HasBinaryNat address + counter : (work counter).HasBinaryNat 0 + result : (work result).HasBinaryNat 0 + scratch : (work scratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + +/-- Reusable work-tape endpoint after dense-bank fallback. -/ +structure DenseInputLookupResult {n : β„•} + (query counter result scratch : Fin n) (input : List Bool) + (address : β„•) (initialWork finalWork : Fin n β†’ Tape) : Prop where + query_eq : finalWork query = initialWork query + counter_zero : (finalWork counter).HasBinaryNat 0 + result_value : (finalWork result).HasBinaryNat + (Complexity.RAM.initRegs input address) + scratch_eq : finalWork scratch = initialWork scratch + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, i β‰  query β†’ i β‰  counter β†’ i β‰  result β†’ i β‰  scratch β†’ + finalWork i = initialWork i + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Internal.lean new file mode 100644 index 0000000000..659640581c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/DenseInputLookup/Internal.lean @@ -0,0 +1,1117 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary + +/-! +# Dense public-input lookup -- proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +theorem denseInputIdleTM_reachesIn_frame_internal {n : β„•} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputIdleTM (n := n)).reachesIn 1 + { state := (denseInputIdleTM (n := n)).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputIdleTM (n := n)).halted c' ∧ + c'.input = inpβ‚€ ∧ c'.work = workβ‚€ ∧ c'.output = outβ‚€ := by + let c' : Complexity.Cfg n (denseInputIdleTM (n := n)).Q := + { state := (denseInputIdleTM (n := n)).qhalt + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hstep : (denseInputIdleTM (n := n)).step + { state := (denseInputIdleTM (n := n)).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = some c' := by + simp only [TM.step, denseInputIdleTM, reduceCtorEq, ↓reduceIte, c'] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + exact ⟨c', .step hstep .zero, rfl, rfl, rfl, rfl⟩ + +theorem capturePreviousInputBitTM_reachesIn_frame_internal {n : β„•} + (result : Fin n) (bit : Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.StartInvariant) (hhead : 2 ≀ inpβ‚€.head) + (hbit : inpβ‚€.cells (inpβ‚€.head - 1) = Ξ“.ofBool bit) + (hresult : workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (capturePreviousInputBitTM result).reachesIn 2 + { state := (capturePreviousInputBitTM result).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (capturePreviousInputBitTM result).halted c' ∧ + c'.input = inpβ‚€ ∧ + c'.work = Function.update workβ‚€ result (denseInputBitTape bit) ∧ + c'.output = outβ‚€ := by + have hinputRead : inpβ‚€.read β‰  Ξ“.start := + hinput.read_ne_start (by omega) + let inp₁ := inpβ‚€.move Dir3.left + have hinp₁Head : inp₁.head = inpβ‚€.head - 1 := by + simp [inp₁, Tape.move] + have hinp₁Cells : inp₁.cells = inpβ‚€.cells := Tape.move_cells _ _ + have hinp₁Read : inp₁.read = Ξ“.ofBool bit := by + simp only [Tape.read, hinp₁Head, hinp₁Cells, hbit] + let c₁ : Complexity.Cfg n (capturePreviousInputBitTM result).Q := + { state := .write, input := inp₁, work := workβ‚€, output := outβ‚€ } + have hstep₁ : (capturePreviousInputBitTM result).step + { state := (capturePreviousInputBitTM result).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = some c₁ := by + simp only [TM.step, capturePreviousInputBitTM, reduceCtorEq, + ↓reduceIte, c₁] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [inp₁, TM.moveLeftDir, hinputRead] + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + let finalWork := Function.update workβ‚€ result (denseInputBitTape bit) + let cβ‚‚ : Complexity.Cfg n (capturePreviousInputBitTM result).Q := + { state := .done, input := inpβ‚€, work := finalWork, output := outβ‚€ } + have hstepβ‚‚ : (capturePreviousInputBitTM result).step c₁ = some cβ‚‚ := by + simp only [TM.step, capturePreviousInputBitTM, reduceCtorEq, + ↓reduceIte, c₁, cβ‚‚] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· apply Tape.ext + Β· simp [inp₁, Tape.move] + omega + Β· simp [inp₁, Tape.move_cells] + Β· funext i + by_cases hi : i = result + Β· subst i + simp only [finalWork, Function.update_self, hinp₁Read] + rw [hresult] + cases bit <;> + simp [denseInputBitTape, TM.resetBinaryBlank, Tape.writeAndMove, + Tape.write, Tape.move, TM.idleDir, Tape.read, Tape.init, + Ξ“.ofBool] + Β· simp only [finalWork, Function.update_of_ne hi, hi, ite_false] + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + exact ⟨cβ‚‚, .step hstep₁ (.step hstepβ‚‚ .zero), rfl, rfl, rfl, rfl⟩ + +theorem denseInputBitTape_hasBinaryNat_internal (bit : Bool) : + (denseInputBitTape bit).HasBinaryNat (if bit then 1 else 0) := by + have heq : denseInputBitTape bit = + (Tape.init ((if bit then 1 else 0).bits.map Ξ“.ofBool)).move + Dir3.right := by + cases bit with + | false => + apply Tape.ext + Β· simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, Nat.bits] + Β· funext i + by_cases hi0 : i = 0 + Β· subst i + simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, Nat.bits] + Β· by_cases hi1 : i = 1 + Β· subst i + simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, + Nat.bits] + Β· simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, + Nat.bits, hi0, hi1] + | true => + apply Tape.ext + Β· simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, Nat.bits] + Β· funext i + by_cases hi0 : i = 0 + Β· subst i + simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, Nat.bits] + Β· by_cases hi1 : i = 1 + Β· subst i + simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, + Nat.bits, Ξ“.ofBool] + Β· have hnone : [Ξ“.one][i - 1]? = none := by + apply List.getElem?_eq_none + simp + omega + simp [denseInputBitTape, TM.resetBinaryBlank, + Tape.writeAndMove, Tape.write, Tape.move, Tape.init, + Nat.bits, hi0, hi1, hnone, Ξ“.ofBool] + rw [heq] + exact Tape.init_move_right_hasBinaryNat _ + +theorem denseInputBitTape_parked_internal (bit : Bool) : + TM.Parked (denseInputBitTape bit) := by + have h := denseInputBitTape_hasBinaryNat_internal bit + exact ⟨by simp [Tape.HasBinaryNat, Tape.HasBinaryString] at h; omega, + h.2.hasBinaryContent.cells_ne_start⟩ + +private def denseInputNatTape (value : β„•) : Tape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + +private def denseInputTape (input : List Bool) (head : β„•) : Tape := + { head := head + cells := (Tape.init (input.map Ξ“.ofBool)).cells } + +private def denseInputResultTape (input : List Bool) (address processed : β„•) : + Tape := + if address = 0 then TM.resetBinaryBlank + else if address ≀ processed then + denseInputBitTape (input[address - 1]?.getD false) + else TM.resetBinaryBlank + +private def denseInputWork {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (input : List Bool) (address processed : β„•) : + Fin n β†’ Tape := + Function.update + (Function.update workβ‚€ counter (denseInputNatTape (address - processed))) + result (denseInputResultTape input address processed) + +private theorem denseInputNatTape_hasBinaryNat (value : β„•) : + (denseInputNatTape value).HasBinaryNat value := + Tape.init_move_right_hasBinaryNat value + +private theorem denseInputNatTape_parked (value : β„•) : + TM.Parked (denseInputNatTape value) := by + have h := denseInputNatTape_hasBinaryNat value + exact ⟨by simp [Tape.HasBinaryNat, Tape.HasBinaryString] at h; omega, + h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem denseInputResultTape_parked (input : List Bool) + (address processed : β„•) : + TM.Parked (denseInputResultTape input address processed) := by + unfold denseInputResultTape + split + Β· exact ⟨by simp [TM.resetBinaryBlank, Tape.move], + by simpa [TM.resetBinaryBlank] using + Tape.init_ofBool_move_right_cells_ne_start []⟩ + Β· split + Β· exact denseInputBitTape_parked_internal _ + Β· exact ⟨by simp [TM.resetBinaryBlank, Tape.move], + by simpa [TM.resetBinaryBlank] using + Tape.init_ofBool_move_right_cells_ne_start []⟩ + +private theorem denseInputWork_counter {n : β„•} (counter result : Fin n) + (hne : counter β‰  result) (workβ‚€ : Fin n β†’ Tape) + (input : List Bool) (address processed : β„•) : + denseInputWork counter result workβ‚€ input address processed counter = + denseInputNatTape (address - processed) := by + simp [denseInputWork, hne] + +private theorem denseInputWork_result {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (input : List Bool) + (address processed : β„•) : + denseInputWork counter result workβ‚€ input address processed result = + denseInputResultTape input address processed := by + simp [denseInputWork] + +private theorem denseInputWork_other {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (input : List Bool) (address processed : β„•) + (i : Fin n) (hic : i β‰  counter) (hir : i β‰  result) : + denseInputWork counter result workβ‚€ input address processed i = workβ‚€ i := by + simp [denseInputWork, hic, hir] + +private theorem denseInputWork_parked {n : β„•} (counter result : Fin n) + (hne : counter β‰  result) (workβ‚€ : Fin n β†’ Tape) + (input : List Bool) (address processed : β„•) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) : + βˆ€ i, TM.Parked + (denseInputWork counter result workβ‚€ input address processed i) := by + intro i + by_cases hic : i = counter + Β· subst i + rw [denseInputWork_counter counter result hne] + exact denseInputNatTape_parked _ + Β· by_cases hir : i = result + Β· subst i + rw [denseInputWork_result] + exact denseInputResultTape_parked input address processed + Β· rw [denseInputWork_other counter result workβ‚€ input address processed + i hic hir] + exact hwork i + +private theorem denseInputTape_startInvariant (input : List Bool) + (head : β„•) : (denseInputTape input head).StartInvariant := by + constructor + Β· simp [denseInputTape] + Β· intro j hj + simpa [denseInputTape] using Tape.init_ofBool_cells_ne_start input j hj + +private theorem denseInputTape_read_bit (input : List Bool) (processed : β„•) + (hprocessed : processed < input.length) : + (denseInputTape input (processed + 1)).read = + Ξ“.ofBool (input[processed]'hprocessed) := by + exact Tape.init_ofBool_cells_lt input processed hprocessed + +private theorem denseInputTape_read_blank (input : List Bool) : + (denseInputTape input (input.length + 1)).read = Ξ“.blank := by + exact Tape.init_ofBool_cells_ge input input.length le_rfl + +private theorem denseInputStepResult_eq (input : List Bool) + (address processed : β„•) (haddress : address β‰  0) + (hprocessed : processed < input.length) : + denseInputStepResult (address - processed) + (input[processed]'hprocessed) + (denseInputResultTape input address processed) = + denseInputResultTape input address (processed + 1) := by + by_cases hbefore : address ≀ processed + Β· rw [denseInputStepResult, ite_eq_right (by omega)] + unfold denseInputResultTape + rw [ite_eq_right haddress, ite_eq_left hbefore, ite_eq_right haddress, + ite_eq_left (le_trans hbefore (by omega))] + Β· by_cases hcurrent : address = processed + 1 + Β· subst address + have hremaining : processed + 1 - processed = 1 := by omega + rw [denseInputStepResult, ite_eq_left hremaining] + unfold denseInputResultTape + rw [ite_eq_right haddress, ite_eq_left (le_refl (processed + 1))] + congr 1 + have hindex : processed + 1 - 1 = processed := by omega + rw [hindex] + rw [List.getElem?_eq_getElem hprocessed] + rfl + Β· have hafter : processed + 1 < address := by omega + have hremaining : address - processed β‰  1 := by omega + rw [denseInputStepResult, ite_eq_right hremaining] + unfold denseInputResultTape + rw [ite_eq_right haddress, ite_eq_right (by omega), ite_eq_right haddress, + ite_eq_right (Nat.not_le_of_lt hafter)] + +private def denseInputScanCfg {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) : + Complexity.Cfg n (denseInputScanTM counter result).Q := + { state := .inl .scan + input := denseInputTape input (processed + 1) + work := denseInputWork counter result workβ‚€ input address processed + output := outβ‚€ } + +private def denseInputBodyStartCfg {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) : + Complexity.Cfg n (denseInputStepTM counter result).Q := + { state := (denseInputStepTM counter result).qstart + input := denseInputTape input (processed + 2) + work := denseInputWork counter result workβ‚€ input address processed + output := outβ‚€ } + +private def denseInputBodyDoneCfg {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) : + Complexity.Cfg n (denseInputStepTM counter result).Q := + { state := (denseInputStepTM counter result).qhalt + input := denseInputTape input (processed + 2) + work := denseInputWork counter result workβ‚€ input address (processed + 1) + output := outβ‚€ } + +private def denseInputDoneCfg {n : β„•} (counter result : Fin n) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address : β„•) : Complexity.Cfg n (denseInputScanTM counter result).Q := + { state := .inl .done + input := denseInputTape input (input.length + 1) + work := denseInputWork counter result workβ‚€ input address input.length + output := outβ‚€ } + +private theorem denseInputScanTM_scan_bit_step {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) (hprocessed : processed < input.length) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + (denseInputScanTM counter result).step + (denseInputScanCfg counter result workβ‚€ outβ‚€ input address processed) = + some (TM.forInputBodyWrap (denseInputStepTM counter result) + (denseInputBodyStartCfg counter result workβ‚€ outβ‚€ input address + processed)) := by + have hread := denseInputTape_read_bit input processed hprocessed + have hstep := TM.forInputTM_step_scan_bit_internal + (denseInputStepTM counter result) + (denseInputScanCfg counter result workβ‚€ outβ‚€ input address processed) + rfl + (by + change (denseInputTape input (processed + 1)).read β‰  Ξ“.start + rw [hread] + exact Ξ“.ofBool_ne_start _) + (by + change (denseInputTape input (processed + 1)).read β‰  Ξ“.blank + rw [hread] + exact Ξ“.ofBool_ne_blank _) + (fun i => (denseInputWork_parked counter result hne workβ‚€ input + address processed hwork i).read_ne_start) + houtput.read_ne_start + simpa [denseInputScanTM, denseInputScanCfg, denseInputBodyStartCfg, + TM.forInputBodyWrap, denseInputTape, Tape.move] using hstep + +private theorem denseInputScanTM_scan_blank_step {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address : β„•) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (denseInputScanTM counter result).step + (denseInputScanCfg counter result workβ‚€ outβ‚€ input address input.length) = + some (denseInputDoneCfg counter result workβ‚€ outβ‚€ input address) := by + have hstep := TM.forInputTM_step_scan_blank_internal + (denseInputStepTM counter result) + (denseInputScanCfg counter result workβ‚€ outβ‚€ input address input.length) + rfl (denseInputTape_read_blank input) + (fun i => (denseInputWork_parked counter result hne workβ‚€ input + address input.length hwork i).read_ne_start) + houtput.read_ne_start + simpa [denseInputScanTM, denseInputScanCfg, denseInputDoneCfg] using hstep + +theorem denseInputStepTM_reachesIn_frame_internal {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (remaining : β„•) (bit : Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.StartInvariant) (hhead : 2 ≀ inpβ‚€.head) + (hbit : inpβ‚€.cells (inpβ‚€.head - 1) = Ξ“.ofBool bit) + (hcounter : (workβ‚€ counter).HasBinaryNat remaining) + (hresult : remaining = 1 β†’ workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputStepTM counter result).reachesIn + (denseInputStepTime remaining) + { state := (denseInputStepTM counter result).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputStepTM counter result).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work counter).HasBinaryNat (remaining - 1) ∧ + c'.work result = denseInputStepResult remaining bit (workβ‚€ result) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + by_cases hzero : remaining = 0 + Β· subst remaining + have hblank : (workβ‚€ counter).read = Ξ“.blank := + hcounter.read_eq_blank_iff.mpr rfl + obtain ⟨idleDone, hidleReach, hidleHalt, hidleInput, + hidleWork, hidleOutput⟩ := + denseInputIdleTM_reachesIn_frame_internal inpβ‚€ workβ‚€ outβ‚€ + ⟨by omega, hinput.2⟩ hwork houtput + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneWork, hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_blank_frame counter + (denseInputIdleTM (n := n)) + (TM.seqTM (TM.binaryPredTM counter) + (TM.branchWorkBlankTM counter + (capturePreviousInputBitTM result) denseInputIdleTM)) + inpβ‚€ workβ‚€ outβ‚€ hblank + (hinput.read_ne_start (by omega)) + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + hidleReach hidleHalt + refine ⟨done, ?_, hhalt, ?_, ?_, ?_, ?_, ?_⟩ + Β· simpa [denseInputStepTM, denseInputStepTime] + Β· exact hdoneInput.trans hidleInput + Β· rw [hdoneWork, hidleWork] + simpa using hcounter + Β· rw [hdoneWork, hidleWork] + simp [denseInputStepResult] + Β· intro i _ _ + rw [hdoneWork, hidleWork] + Β· exact hdoneOutput.trans hidleOutput + Β· obtain ⟨predecessor, rfl⟩ : βˆƒ predecessor, remaining = predecessor + 1 := + ⟨remaining - 1, by omega⟩ + have hcounterPos : (workβ‚€ counter).HasBinaryNat (predecessor + 1) := + hcounter + have hnonblank : (workβ‚€ counter).read β‰  Ξ“.blank := by + exact fun h => by + have := hcounterPos.read_eq_blank_iff.mp h + omega + obtain ⟨predDone, hpredReach, hpredHalt, hpredInput, + hpredOther, hpredCounter, hpredOutput⟩ := + TM.binaryPredTM_reachesIn_frame counter predecessor inpβ‚€ workβ‚€ outβ‚€ + hcounterPos (hinput.read_ne_start (by omega)) + (fun i _ => (hwork i).read_ne_start) houtput.read_ne_start + have hpredResult : predDone.work result = workβ‚€ result := + hpredOther result (Ne.symm hne) + have hpredWorkParked : βˆ€ i, TM.Parked (predDone.work i) := by + intro i + by_cases hi : i = counter + Β· subst i + exact ⟨by + simp [Tape.HasBinaryNat, Tape.HasBinaryString] at hpredCounter + omega, + hpredCounter.2.hasBinaryContent.cells_ne_start⟩ + Β· rw [hpredOther i hi] + exact hwork i + let inner := TM.branchWorkBlankTM counter + (capturePreviousInputBitTM result) (denseInputIdleTM (n := n)) + by_cases hpredZero : predecessor = 0 + Β· subst predecessor + have hinnerBlank : (predDone.work counter).read = Ξ“.blank := + hpredCounter.read_eq_blank_iff.mpr rfl + have hresultBlank : predDone.work result = TM.resetBinaryBlank := by + rw [hpredResult] + exact hresult rfl + obtain ⟨captureDone, hcaptureReach, hcaptureHalt, + hcaptureInput, hcaptureWork, hcaptureOutput⟩ := + capturePreviousInputBitTM_reachesIn_frame_internal result bit + predDone.input predDone.work predDone.output + (by simpa [hpredInput] using hinput) + (by simpa [hpredInput] using hhead) + (by simpa [hpredInput] using hbit) + hresultBlank hpredWorkParked (by simpa [hpredOutput] using houtput) + obtain ⟨innerDone, hinnerReach, hinnerHalt, hinnerInput, + hinnerWork, hinnerOutput⟩ := + TM.branchWorkBlankTM_reachesIn_blank_frame counter + (capturePreviousInputBitTM result) (denseInputIdleTM (n := n)) + predDone.input predDone.work predDone.output hinnerBlank + (by simpa [hpredInput] using hinput.read_ne_start (by omega)) + (fun i => (hpredWorkParked i).read_ne_start) + (by simpa [hpredOutput] using houtput.read_ne_start) + hcaptureReach hcaptureHalt + have hpredInputRead : predDone.input.read β‰  Ξ“.start := by + rw [hpredInput] + exact hinput.read_ne_start (by omega) + have hpredOutputRead : predDone.output.read β‰  Ξ“.start := by + rw [hpredOutput] + exact houtput.read_ne_start + have htransition := TM.phaseTransition_eq_self_of_reads_ne_start + hpredInputRead (fun i => (hpredWorkParked i).read_ne_start) + hpredOutputRead + have hinnerReach' : inner.reachesIn 3 + { state := inner.qstart + input := TM.transitionInput predDone.input + work := fun i => TM.transitionTape (predDone.work i) + output := TM.transitionTape predDone.output } innerDone := by + simpa [inner, htransition.1, htransition.2.1, htransition.2.2] using + hinnerReach + have hseqReach := TM.seqTM_reachesIn_of_reachesIn + (TM.binaryPredTM counter) inner hpredReach hpredHalt hinnerReach' + have hseqHalt : + (TM.seqTM (TM.binaryPredTM counter) inner).halted + (TM.phase2Wrap (TM.binaryPredTM counter) inner innerDone) := + (TM.phase2Wrap_halted_iff _ _ _).mpr hinnerHalt + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneWork, hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_nonblank_frame counter + (denseInputIdleTM (n := n)) + (TM.seqTM (TM.binaryPredTM counter) inner) + inpβ‚€ workβ‚€ outβ‚€ hnonblank + (hinput.read_ne_start (by omega)) + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + hseqReach hseqHalt + simp only [TM.phase2Wrap] at hdoneInput hdoneWork hdoneOutput + refine ⟨done, ?_, hhalt, ?_, ?_, ?_, ?_, ?_⟩ + Β· simpa [denseInputStepTM, denseInputStepTime, inner] + Β· exact hdoneInput.trans + (hinnerInput.trans (hcaptureInput.trans hpredInput)) + Β· rw [hdoneWork, hinnerWork, hcaptureWork, + Function.update_of_ne hne] + simpa using hpredCounter + Β· rw [hdoneWork, hinnerWork, hcaptureWork, Function.update_self] + simp [denseInputStepResult] + Β· intro i hic hir + rw [hdoneWork, hinnerWork, hcaptureWork, + Function.update_of_ne hir] + exact hpredOther i hic + Β· exact hdoneOutput.trans + (hinnerOutput.trans (hcaptureOutput.trans hpredOutput)) + Β· have hinnerNonblank : (predDone.work counter).read β‰  Ξ“.blank := by + exact fun h => hpredZero (hpredCounter.read_eq_blank_iff.mp h) + obtain ⟨idleDone, hidleReach, hidleHalt, hidleInput, + hidleWork, hidleOutput⟩ := + denseInputIdleTM_reachesIn_frame_internal predDone.input + predDone.work predDone.output + (by + rw [hpredInput] + exact (⟨by omega, hinput.2⟩ : TM.Parked inpβ‚€)) + hpredWorkParked (by simpa [hpredOutput] using houtput) + obtain ⟨innerDone, hinnerReach, hinnerHalt, hinnerInput, + hinnerWork, hinnerOutput⟩ := + TM.branchWorkBlankTM_reachesIn_nonblank_frame counter + (capturePreviousInputBitTM result) (denseInputIdleTM (n := n)) + predDone.input predDone.work predDone.output hinnerNonblank + (by simpa [hpredInput] using hinput.read_ne_start (by omega)) + (fun i => (hpredWorkParked i).read_ne_start) + (by simpa [hpredOutput] using houtput.read_ne_start) + hidleReach hidleHalt + have hpredInputRead : predDone.input.read β‰  Ξ“.start := by + rw [hpredInput] + exact hinput.read_ne_start (by omega) + have hpredOutputRead : predDone.output.read β‰  Ξ“.start := by + rw [hpredOutput] + exact houtput.read_ne_start + have htransition := TM.phaseTransition_eq_self_of_reads_ne_start + hpredInputRead (fun i => (hpredWorkParked i).read_ne_start) + hpredOutputRead + have hinnerReach' : inner.reachesIn 2 + { state := inner.qstart + input := TM.transitionInput predDone.input + work := fun i => TM.transitionTape (predDone.work i) + output := TM.transitionTape predDone.output } innerDone := by + simpa [inner, htransition.1, htransition.2.1, htransition.2.2] using + hinnerReach + have hseqReach := TM.seqTM_reachesIn_of_reachesIn + (TM.binaryPredTM counter) inner hpredReach hpredHalt hinnerReach' + have hseqHalt : + (TM.seqTM (TM.binaryPredTM counter) inner).halted + (TM.phase2Wrap (TM.binaryPredTM counter) inner innerDone) := + (TM.phase2Wrap_halted_iff _ _ _).mpr hinnerHalt + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneWork, hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_nonblank_frame counter + (denseInputIdleTM (n := n)) + (TM.seqTM (TM.binaryPredTM counter) inner) + inpβ‚€ workβ‚€ outβ‚€ hnonblank + (hinput.read_ne_start (by omega)) + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + hseqReach hseqHalt + simp only [TM.phase2Wrap] at hdoneInput hdoneWork hdoneOutput + refine ⟨done, ?_, hhalt, ?_, ?_, ?_, ?_, ?_⟩ + Β· have hnotOne : predecessor + 1 β‰  1 := by omega + simpa [denseInputStepTM, denseInputStepTime, inner, hnotOne, + hpredZero] + Β· exact hdoneInput.trans + (hinnerInput.trans (hidleInput.trans hpredInput)) + Β· rw [hdoneWork, hinnerWork, hidleWork] + simpa using hpredCounter + Β· rw [hdoneWork, hinnerWork, hidleWork] + simpa [denseInputStepResult, hpredZero] using hpredResult + Β· intro i hic _ + rw [hdoneWork, hinnerWork, hidleWork] + exact hpredOther i hic + Β· exact hdoneOutput.trans + (hinnerOutput.trans (hidleOutput.trans hpredOutput)) + +private theorem denseInputScanTM_body_run {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) (haddress : address β‰  0) + (hprocessed : processed < input.length) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + (denseInputStepTM counter result).reachesIn + (denseInputStepTime (address - processed)) + (denseInputBodyStartCfg counter result workβ‚€ outβ‚€ input address + processed) + (denseInputBodyDoneCfg counter result workβ‚€ outβ‚€ input address + processed) := by + let initialWork := denseInputWork counter result workβ‚€ input address processed + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneCounter, + hdoneResult, hdoneOther, hdoneOutput⟩ := + denseInputStepTM_reachesIn_frame_internal counter result hne + (address - processed) (input[processed]'hprocessed) + (denseInputTape input (processed + 2)) initialWork outβ‚€ + (denseInputTape_startInvariant input (processed + 2)) + (by simp [denseInputTape]) + (by + change (Tape.init (input.map Ξ“.ofBool)).cells + (processed + 2 - 1) = Ξ“.ofBool input[processed] + have hindex : processed + 2 - 1 = processed + 1 := by omega + rw [hindex] + exact Tape.init_ofBool_cells_lt input processed hprocessed) + (by + change (denseInputWork counter result workβ‚€ input address processed + counter).HasBinaryNat (address - processed) + rw [denseInputWork_counter counter result hne] + exact denseInputNatTape_hasBinaryNat _) + (by + intro hremaining + change denseInputWork counter result workβ‚€ input address processed + result = TM.resetBinaryBlank + rw [denseInputWork_result] + unfold denseInputResultTape + rw [ite_eq_right haddress, ite_eq_right (by omega)]) + (denseInputWork_parked counter result hne workβ‚€ input address + processed hwork) houtput + have hdone : done = + denseInputBodyDoneCfg counter result workβ‚€ outβ‚€ input address processed := by + apply Complexity.Cfg.ext hhalt + Β· exact hdoneInput + Β· funext i + change done.work i = denseInputWork counter result workβ‚€ input address + (processed + 1) i + by_cases hic : i = counter + Β· subst i + rw [denseInputWork_counter counter result hne] + have hcanonical := hdoneCounter.eq_init_move_right + have hsub : address - processed - 1 = address - (processed + 1) := by + omega + simpa [denseInputNatTape, hsub] using hcanonical + Β· by_cases hir : i = result + Β· subst i + rw [denseInputWork_result] + rw [hdoneResult] + change denseInputStepResult (address - processed) + (input[processed]'hprocessed) + (denseInputWork counter result workβ‚€ input address processed + result) = denseInputResultTape input address (processed + 1) + rw [denseInputWork_result] + exact denseInputStepResult_eq input address processed haddress hprocessed + Β· rw [denseInputWork_other counter result workβ‚€ input address + (processed + 1) i hic hir] + rw [hdoneOther i hic hir] + exact denseInputWork_other counter result workβ‚€ input address + processed i hic hir + Β· exact hdoneOutput + rw [← hdone] + exact hreach + +private theorem denseInputScanTM_loopback_step {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (input : List Bool) + (address processed : β„•) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (denseInputScanTM counter result).step + (TM.forInputBodyWrap (denseInputStepTM counter result) + (denseInputBodyDoneCfg counter result workβ‚€ outβ‚€ input address + processed)) = + some (denseInputScanCfg counter result workβ‚€ outβ‚€ input address + (processed + 1)) := by + have hstep := TM.forInputTM_step_body_halt_internal + (denseInputStepTM counter result) + (denseInputBodyDoneCfg counter result workβ‚€ outβ‚€ input address processed) + rfl + ((denseInputTape_startInvariant input (processed + 2)).read_ne_start + (by simp [denseInputTape])) + (fun i => (denseInputWork_parked counter result hne workβ‚€ input + address (processed + 1) hwork i).read_ne_start) + houtput.read_ne_start + simpa [denseInputScanTM, denseInputBodyDoneCfg, denseInputScanCfg, + TM.forInputBodyWrap, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using + hstep + +private def denseInputLoopSpec {n : β„•} (counter result : Fin n) + (hne : counter β‰  result) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (input : List Bool) (address : β„•) (haddress : address β‰  0) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + TM.ForInputLoopSpec (denseInputStepTM counter result) + (fun processed => denseInputStepTime (address - processed)) + input.length where + scanCfg := denseInputScanCfg counter result workβ‚€ outβ‚€ input address + bodyStartCfg := fun processed => + TM.forInputBodyWrap (denseInputStepTM counter result) + (denseInputBodyStartCfg counter result workβ‚€ outβ‚€ input address processed) + bodyDoneCfg := fun processed => + TM.forInputBodyWrap (denseInputStepTM counter result) + (denseInputBodyDoneCfg counter result workβ‚€ outβ‚€ input address processed) + doneCfg := denseInputDoneCfg counter result workβ‚€ outβ‚€ input address + scanStep := fun processed hprocessed => + denseInputScanTM_scan_bit_step counter result hne workβ‚€ outβ‚€ input + address processed hprocessed hwork houtput + bodyRun := fun processed hprocessed => by + simpa [denseInputScanTM] using + TM.forInputTM_body_reachesIn_internal (denseInputStepTM counter result) + (denseInputScanTM_body_run counter result hne workβ‚€ outβ‚€ input + address processed haddress hprocessed hwork houtput) + loopbackStep := fun processed _ => + denseInputScanTM_loopback_step counter result hne workβ‚€ outβ‚€ input + address processed hwork houtput + blankStep := denseInputScanTM_scan_blank_step counter result hne workβ‚€ outβ‚€ + input address hwork houtput + +private theorem denseInputResultTape_final_hasBinaryNat + (input : List Bool) (address : β„•) (haddress : address β‰  0) : + (denseInputResultTape input address input.length).HasBinaryNat + (Complexity.RAM.initRegs input address) := by + by_cases hindex : address ≀ input.length + Β· have hlt : address - 1 < input.length := by omega + rw [denseInputResultTape, ite_eq_right haddress, ite_eq_left hindex] + rw [Complexity.RAM.initRegs, ite_eq_right haddress, + List.getElem?_eq_getElem hlt] + simpa using denseInputBitTape_hasBinaryNat_internal + (input[address - 1]'hlt) + Β· have hnone : input[address - 1]? = none := + List.getElem?_eq_none (by omega) + rw [denseInputResultTape, ite_eq_right haddress, ite_eq_right hindex] + simpa [Complexity.RAM.initRegs, haddress, hnone, + TM.resetBinaryBlank] using + Tape.init_move_right_hasBinaryNat 0 + +theorem denseInputScanTM_reachesIn_frame_internal {n : β„•} + (counter result : Fin n) (hne : counter β‰  result) + (input : List Bool) (address : β„•) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) (haddress : address β‰  0) + (hcounter : (workβ‚€ counter).HasBinaryNat address) + (hresult : workβ‚€ result = TM.resetBinaryBlank) + (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) (houtput : TM.Parked outβ‚€) : + βˆƒ c', + (denseInputScanTM counter result).reachesIn + (denseInputScanTime input.length address) + { state := (denseInputScanTM counter result).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := workβ‚€ + output := outβ‚€ } c' ∧ + (denseInputScanTM counter result).halted c' ∧ + c'.input.head = input.length + 1 ∧ + c'.input.cells = (Tape.init (input.map Ξ“.ofBool)).cells ∧ + (c'.work counter).HasBinaryNat (address - input.length) ∧ + (c'.work result).HasBinaryNat (Complexity.RAM.initRegs input address) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let spec := denseInputLoopSpec counter result hne workβ‚€ outβ‚€ input address + haddress hwork houtput + have hstart : + { state := (denseInputScanTM counter result).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := workβ‚€ + output := outβ‚€ } = spec.scanCfg 0 := by + change + { state := (denseInputScanTM counter result).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := workβ‚€ + output := outβ‚€ } = + denseInputScanCfg counter result workβ‚€ outβ‚€ input address 0 + apply Complexity.Cfg.ext + (c := + { state := (denseInputScanTM counter result).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := workβ‚€ + output := outβ‚€ }) + (c' := denseInputScanCfg counter result workβ‚€ outβ‚€ input address 0) + rfl + Β· apply Tape.ext + Β· simp [denseInputScanCfg, denseInputTape, Tape.move] + Β· simp [denseInputScanCfg, denseInputTape, Tape.move] + Β· funext i + change workβ‚€ i = denseInputWork counter result workβ‚€ input address 0 i + by_cases hic : i = counter + Β· subst i + rw [denseInputWork_counter counter result hne] + simpa [denseInputNatTape] using hcounter.eq_init_move_right + Β· by_cases hir : i = result + Β· subst i + rw [denseInputWork_result, hresult] + unfold denseInputResultTape + rw [ite_eq_right haddress, ite_eq_right (by omega)] + Β· rw [denseInputWork_other counter result workβ‚€ input address 0 + i hic hir] + Β· rfl + have hrun := spec.reachesIn_internal input.length 0 (by omega) + rw [← hstart] at hrun + let done := denseInputDoneCfg counter result workβ‚€ outβ‚€ input address + refine ⟨done, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· simpa [denseInputScanTime, spec, denseInputLoopSpec, done] using! hrun + Β· rfl + Β· rfl + Β· rfl + Β· change (denseInputWork counter result workβ‚€ input address input.length + counter).HasBinaryNat (address - input.length) + rw [denseInputWork_counter counter result hne] + exact denseInputNatTape_hasBinaryNat _ + Β· change (denseInputWork counter result workβ‚€ input address input.length + result).HasBinaryNat (Complexity.RAM.initRegs input address) + rw [denseInputWork_result] + exact denseInputResultTape_final_hasBinaryNat input address haddress + Β· intro i hic hir + change denseInputWork counter result workβ‚€ input address input.length i = + workβ‚€ i + exact denseInputWork_other counter result workβ‚€ input address input.length + i hic hir + Β· rfl + +private theorem denseInputStepTime_le_width (address processed : β„•) : + denseInputStepTime (address - processed) ≀ 2 * address.size + 7 := by + by_cases hzero : address - processed = 0 + Β· simp [denseInputStepTime, hzero] + Β· by_cases hone : address - processed = 1 + Β· have hpred := TM.binaryPredTime_le_internal 0 + have hsize : 1 ≀ address.size := + Nat.size_pos.mpr (by omega) + simp [denseInputStepTime, hone] at hpred ⊒ + omega + Β· have hpred := + TM.binaryPredTime_le_internal (address - processed - 1) + have hwidth : (address - processed).size ≀ address.size := + Nat.size_le_size (Nat.sub_le address processed) + rw [denseInputStepTime, ite_eq_right hzero, ite_eq_right hone] + have hsucc : address - processed - 1 + 1 = address - processed := by + omega + rw [hsucc] at hpred + omega + +private theorem denseInputLoopTime_le_width (inputLength address processed : β„•) : + TM.forInputLoopTime + (fun current => denseInputStepTime (address - current)) + processed inputLength ≀ + inputLength * (2 * address.size + 9) + 1 := by + induction inputLength generalizing processed with + | zero => simp [TM.forInputLoopTime] + | succ count ih => + rw [TM.forInputLoopTime] + have hbody := denseInputStepTime_le_width address processed + have htail := ih (processed + 1) + rw [Nat.add_mul, one_mul] + omega + +theorem denseInputScanTime_le_width_internal (inputLength address : β„•) : + denseInputScanTime inputLength address ≀ + inputLength * (2 * address.size + 9) + 1 := by + exact denseInputLoopTime_le_width inputLength address 0 + +private theorem parked_of_hasBinaryNat {tape : Tape} {value : β„•} + (hvalue : tape.HasBinaryNat value) : TM.Parked tape := + ⟨by rw [hvalue.2.1], hvalue.2.hasBinaryContent.cells_ne_start⟩ + +/-- Resetting the scan counter preserves the lookup result and its untouched tape frame. -/ +private theorem denseInputLookupResult_of_reset_counter {n : β„•} + (query counter result scratch : Fin n) + (hqc : query β‰  counter) (hqr : query β‰  result) (hcr : counter β‰  result) + (hcs : counter β‰  scratch) (hrs : result β‰  scratch) + (input : List Bool) (address : β„•) (initialWork work : Fin n β†’ Tape) + (hresult : (work result).HasBinaryNat (Complexity.RAM.initRegs input address)) + (hother : βˆ€ i, i β‰  counter β†’ i β‰  result β†’ + work i = Function.update initialWork counter (denseInputNatTape address) i) + (hparked : βˆ€ i, TM.Parked (work i)) : + DenseInputLookupResult query counter result scratch input address initialWork + (Function.update work counter ((Tape.init []).move Dir3.right)) := by + let copiedWork := Function.update initialWork counter (denseInputNatTape address) + have hblankNat : ((Tape.init []).move Dir3.right).HasBinaryNat 0 := by + simpa using Tape.init_move_right_hasBinaryNat 0 + constructor + Β· rw [Function.update_of_ne hqc] + rw [hother query hqc hqr] + simp [copiedWork, Function.update_of_ne hqc] + Β· rw [Function.update_self] + exact hblankNat + Β· rw [Function.update_of_ne hcr.symm] + exact hresult + Β· rw [Function.update_of_ne hcs.symm] + rw [hother scratch hcs.symm hrs.symm] + simp [copiedWork, Function.update_of_ne hcs.symm] + Β· intro i + by_cases hi : i = counter + Β· subst i + rw [Function.update_self] + exact parked_of_hasBinaryNat hblankNat + Β· rw [Function.update_of_ne hi] + exact hparked i + Β· intro i _ hic hir _ + rw [Function.update_of_ne hic] + rw [hother i hic hir] + simp [copiedWork, Function.update_of_ne hic] + +theorem denseInputLookupTM_hoareTime_internal {n : β„•} + (query counter result scratch : Fin n) + (hqc : query β‰  counter) (hqr : query β‰  result) + (hqs : query β‰  scratch) (hcr : counter β‰  result) + (hcs : counter β‰  scratch) (hrs : result β‰  scratch) + (input : List Bool) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (haddress : address β‰  0) + (hready : DenseInputLookupReady query counter result scratch address + initialWork) + (houtput : TM.Parked outβ‚€) : + (denseInputLookupTM query counter result scratch).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInputLookupResult query counter result scratch input address + initialWork work ∧ + out = outβ‚€) + (denseInputLookupTime input.length address) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let copiedWork := Function.update initialWork counter + (denseInputNatTape address) + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using Tape.init_ofBool_move_right_cells_ne_start input + have hcopiedCounter : (copiedWork counter).HasBinaryNat address := by + simp only [copiedWork, Function.update_self] + exact denseInputNatTape_hasBinaryNat address + have hcopiedResult : copiedWork result = TM.resetBinaryBlank := by + simp only [copiedWork, Function.update_of_ne hcr.symm] + simpa [TM.resetBinaryBlank] using hready.result.eq_init_move_right + have hcopiedParked : βˆ€ i, TM.Parked (copiedWork i) := by + intro i + by_cases hi : i = counter + Β· subst i + exact parked_of_hasBinaryNat hcopiedCounter + Β· simp only [copiedWork, Function.update_of_ne hi] + exact hready.parked i + have hcopyRaw := TM.binaryCopyIntoTM_hoareTime_frame + query counter scratch hqc hqs hcs address 0 inpβ‚€ initialWork outβ‚€ + hready.query hready.counter hready.scratch hinput + (fun i _ _ _ => hready.parked i) houtput + have hcopy : (TM.binaryCopyIntoTM query counter scratch).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (TM.binaryCopyTime address 0) := by + simpa [copiedWork, denseInputNatTape] using hcopyRaw + let scannedPost : TM.TapePred n := fun inp work out => + inp.head = input.length + 1 ∧ inp.cells = inpβ‚€.cells ∧ + (work counter).HasBinaryNat (address - input.length) ∧ + (work result).HasBinaryNat (Complexity.RAM.initRegs input address) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ work i = copiedWork i) ∧ + (βˆ€ i, TM.Parked (work i)) ∧ out = outβ‚€ + have hscan : (denseInputScanTM counter result).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + scannedPost (denseInputScanTime input.length address) := by + intro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + obtain ⟨done, hreach, hhalt, hdoneHead, hdoneCells, + hdoneCounter, hdoneResult, hdoneOther, hdoneOutput⟩ := + denseInputScanTM_reachesIn_frame_internal counter result hcr input + address copiedWork outβ‚€ haddress hcopiedCounter hcopiedResult + hcopiedParked houtput + have hdoneParked : βˆ€ i, TM.Parked (done.work i) := by + intro i + by_cases hic : i = counter + Β· subst i + exact parked_of_hasBinaryNat hdoneCounter + Β· by_cases hir : i = result + Β· subst i + exact parked_of_hasBinaryNat hdoneResult + Β· rw [hdoneOther i hic hir] + exact hcopiedParked i + exact ⟨done, denseInputScanTime input.length address, le_rfl, + hreach, hhalt, hdoneHead, by simpa [inpβ‚€] using! hdoneCells, + hdoneCounter, hdoneResult, hdoneOther, hdoneParked, hdoneOutput⟩ + let stablePost : TM.TapePred n := fun inp work out => + inp.cells = inpβ‚€.cells ∧ + (work counter).HasBinaryNat (address - input.length) ∧ + (work result).HasBinaryNat (Complexity.RAM.initRegs input address) ∧ + (βˆ€ i, i β‰  counter β†’ i β‰  result β†’ work i = copiedWork i) ∧ + (βˆ€ i, TM.Parked (work i)) ∧ out = outβ‚€ + let rewoundPost : TM.TapePred n := fun inp work out => + inp.head = 1 ∧ stablePost inp work out + have hrewind : (TM.rewindInputTM (n := n)).HoareTime + scannedPost rewoundPost (input.length + 3) := by + have hraw := TM.rewindInputTM_hoareTime_frame (n := n) + (input.length + 1) (P := stablePost) + (by + intro inp work out inp' work' out' hstable hcells hhead + hwork hout + subst work' + subst out' + exact ⟨hcells.trans hstable.1, hstable.2⟩) + intro inp work out hscanned + rcases hscanned with ⟨hhead, hcells, hcounter, hresult, + hother, hparked, hout⟩ + have hstart : inp.cells 0 = Ξ“.start := by + rw [hcells] + simp [inpβ‚€, Tape.move] + have hnostart : βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start := by + intro j hj + rw [hcells] + simpa [inpβ‚€] using + Tape.init_ofBool_move_right_cells_ne_start input j hj + exact hraw inp work out + ⟨hstart, hnostart, by omega, hout β–Έ houtput.read_ne_start, + hout β–Έ houtput.1, + fun i => ⟨(hparked i).read_ne_start, (hparked i).1⟩, + hcells, hcounter, hresult, hother, hparked, hout⟩ + have hscanTransition : βˆ€ inp work out, scannedPost inp work out β†’ + scannedPost (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + intro inp work out hscanned + rcases hscanned with ⟨hhead, hcells, hcounter, hresult, + hother, hparked, hout⟩ + have hinpParked : TM.Parked inp := by + refine ⟨by omega, ?_⟩ + intro j hj + rw [hcells] + simpa [inpβ‚€] using + Tape.init_ofBool_move_right_cells_ne_start input j hj + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinpParked.read_ne_start (fun i => (hparked i).read_ne_start) + (hout β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hhead, hcells, hcounter, hresult, hother, hparked, hout⟩ + let finalPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + DenseInputLookupResult query counter result scratch input address + initialWork work ∧ + out = outβ‚€ + have hreset : (TM.resetBinaryWorkTM counter).HoareTime + rewoundPost finalPost + (TM.resetBinaryWorkTime 1 + (address - input.length).bits.length) := by + intro inp work out hrewound + rcases hrewound with ⟨hhead, hcells, hcounter, hresult, + hother, hparked, hout⟩ + have hinp : inp = inpβ‚€ := by + apply Tape.ext + Β· simpa [inpβ‚€, Tape.move] using hhead + Β· exact hcells + have hrun := TM.resetBinaryWorkTM_hoareTime_frame counter + (address - input.length).bits 1 inp work out + hcounter.2.hasBinaryContent hcounter.1 + ⟨by rw [hcounter.2.1], by rw [hcounter.2.1]⟩ + (by simpa [hinp] using hinput) + (fun i _ => hparked i) (by simpa [hout] using houtput) + obtain ⟨done, time, htime, hreach, hhalt, hdoneInput, + hdoneWork, hdoneOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + have hdoneResult : DenseInputLookupResult query counter result scratch + input address initialWork done.work := by + rw [hdoneWork] + exact denseInputLookupResult_of_reset_counter query counter result scratch + hqc hqr hcr hcs hrs input address initialWork work hresult hother hparked + exact ⟨done, time, htime, hreach, hhalt, + hdoneInput.trans hinp, hdoneResult, hdoneOutput.trans hout⟩ + have hrewindTransition : βˆ€ inp work out, rewoundPost inp work out β†’ + rewoundPost (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + intro inp work out hrewound + rcases hrewound with ⟨hhead, hcells, hcounter, hresult, + hother, hparked, hout⟩ + have hinpParked : TM.Parked inp := by + refine ⟨by omega, ?_⟩ + intro j hj + rw [hcells] + simpa [inpβ‚€] using + Tape.init_ofBool_move_right_cells_ne_start input j hj + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinpParked.read_ne_start (fun i => (hparked i).read_ne_start) + (hout β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hhead, hcells, hcounter, hresult, hother, hparked, hout⟩ + have hrewindReset := TM.seqTM_hoareTime + (TM.rewindInputTM (n := n)) (TM.resetBinaryWorkTM counter) + hrewind hrewindTransition hreset + have hscanTail := TM.seqTM_hoareTime + (denseInputScanTM counter result) + (TM.seqTM (TM.rewindInputTM (n := n)) + (TM.resetBinaryWorkTM counter)) + hscan hscanTransition hrewindReset + have hcopyTransition : βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) β†’ + (TM.transitionInput inp = inpβ‚€ ∧ + (fun i => TM.transitionTape (work i)) = copiedWork ∧ + TM.transitionTape out = outβ‚€) := by + intro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinput.read_ne_start (fun i => (hcopiedParked i).read_ne_start) + houtput.read_ne_start + exact ⟨hi, hw, ho⟩ + have hall := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM query counter scratch) + (TM.seqTM (denseInputScanTM counter result) + (TM.seqTM (TM.rewindInputTM (n := n)) + (TM.resetBinaryWorkTM counter))) + hcopy hcopyTransition hscanTail + simpa [denseInputLookupTM, denseInputLookupTime, inpβ‚€, finalPost] using hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend.lean new file mode 100644 index 0000000000..8ed2442bee --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Internal + +/-! +# Sparse-entry final append +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Append one absent query/nonzero-value entry and restore both canonical +source tapes exactly, retaining the caller's complete work family. -/ +theorem entryAppendRestoreTM_hoareTime_frame {n : β„•} + (tapes : EntryReplaceTapes n) (address newValue : β„•) + (emitted : List Bool) (initialWork readyWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry [] address.bits initialWork readyWork) + (hreplacement : (readyWork tapes.replacement).HasBinaryNat newValue) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryAppendRestoreTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = readyWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = readyWork ∧ + out.HasBinaryPrefix + (emitted ++ Entry.encode (address, newValue))) + (entryAppendRestoreTime address newValue) := + entryAppendRestoreTM_hoareTime_frame_internal tapes address newValue + emitted initialWork readyWork inpβ‚€ outβ‚€ hready hreplacement hinput houtput + +/-- Final append and restoration are append-only on the output tape. -/ +theorem entryAppendRestoreTM_isTransducer {n : β„•} + (tapes : EntryReplaceTapes n) : + (entryAppendRestoreTM tapes).IsTransducer := + (rewindEntryEncodeTM_isTransducer tapes.appendEncodeTapes).seqTM + ((TM.rewindWorkTM_isTransducer tapes.entry.query).seqTM + (TM.rewindWorkTM_isTransducer tapes.replacement)) + +/-- Coarse all-prefix auxiliary-space envelope for final append/restoration. -/ +theorem entryAppendRestoreTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryReplaceTapes n) (address newValue : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryAppendRestoreTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryAppendRestoreTM tapes).reachesIn time start current) + (htime : time ≀ entryAppendRestoreTime address newValue) : + current.WithinAuxSpace inputLength + (initialSpace + entryAppendRestoreTime address newValue) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Defs.lean new file mode 100644 index 0000000000..89e3db8a07 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Defs.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Defs + +/-! +# Sparse-entry final append β€” definitions + +When an update exhausts the old store without a match, a nonzero new value is +appended using the preserved query and replacement tapes. Both sources are then +restored exactly so the caller retains its canonical work frame. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +namespace EntryReplaceTapes + +/-- View the preserved query and replacement tapes as a fresh-entry encoder. -/ +def appendEncodeTapes {n : β„•} + (tapes : EntryReplaceTapes n) : EntryEncodeTapes n where + address := tapes.entry.query + value := tapes.replacement + ne := Ne.symm (tapes.replacement_ne 7) + +@[simp] theorem appendEncodeTapes_address {n : β„•} + (tapes : EntryReplaceTapes n) : + tapes.appendEncodeTapes.address = tapes.entry.query := rfl + +@[simp] theorem appendEncodeTapes_value {n : β„•} + (tapes : EntryReplaceTapes n) : + tapes.appendEncodeTapes.value = tapes.replacement := rfl + +end EntryReplaceTapes + +/-- Emit a fresh query/value entry and restore both canonical source cursors. -/ +def entryAppendRestoreTM {n : β„•} (tapes : EntryReplaceTapes n) : TM n := + TM.seqTM (rewindEntryEncodeTM tapes.appendEncodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)) + +/-- Exact compositional bound for final append and two-source restoration. -/ +def entryAppendRestoreTime (address newValue : β„•) : β„• := + rewindEntryEncodeTime (address, newValue) 1 1 + 1 + + (address.bits.length + 1 + 2 + 1 + + (newValue.bits.length + 1 + 2)) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Internal.lean new file mode 100644 index 0000000000..f24730fe45 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryAppend/Internal.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Sparse-entry final append β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +/-- Two parked modified tapes and a parked unchanged frame give a parked work family. -/ +private theorem parked_work_of_frame + (query replacement : Fin n) (initial current : Fin n β†’ Tape) + (hinitial : βˆ€ i, TM.Parked (initial i)) + (hquery : TM.Parked (current query)) (hreplacement : TM.Parked (current replacement)) + (hframe : βˆ€ i, i β‰  query β†’ i β‰  replacement β†’ current i = initial i) : + βˆ€ i, TM.Parked (current i) := by + intro i + by_cases hiq : i = query + Β· subst i + exact hquery + Β· by_cases hir : i = replacement + Β· subst i + exact hreplacement + Β· rw [hframe i hiq hir] + exact hinitial i + +/-- Rewinding the two modified tapes restores the entire framed work-tape family. -/ +private theorem work_eq_of_two_rewinds + (query replacement : Fin n) (initial encoded queryRewound restored : Fin n β†’ Tape) + (hreplacementRestored : restored replacement = initial replacement) + (hreplacementFrame : βˆ€ i, i β‰  replacement β†’ restored i = queryRewound i) + (hqueryRestored : queryRewound query = initial query) + (hqueryFrame : βˆ€ i, i β‰  query β†’ queryRewound i = encoded i) + (hencodedFrame : βˆ€ i, i β‰  query β†’ i β‰  replacement β†’ encoded i = initial i) : + restored = initial := by + funext i + by_cases hir : i = replacement + Β· subst i + exact hreplacementRestored + Β· rw [hreplacementFrame i hir] + by_cases hiq : i = query + Β· subst i + exact hqueryRestored + Β· exact (hqueryFrame i hiq).trans (hencodedFrame i hiq hir) + +theorem entryAppendRestoreTM_hoareTime_frame_internal + (tapes : EntryReplaceTapes n) (address newValue : β„•) + (emitted : List Bool) (initialWork readyWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry [] address.bits initialWork readyWork) + (hreplacement : (readyWork tapes.replacement).HasBinaryNat newValue) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryAppendRestoreTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = readyWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = readyWork ∧ + out.HasBinaryPrefix + (emitted ++ Entry.encode (address, newValue))) + (entryAppendRestoreTime address newValue) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hqueryHead : 1 ≀ (readyWork tapes.entry.query).head ∧ + (readyWork tapes.entry.query).head ≀ 1 := by + rw [hready.query.1] + exact ⟨le_rfl, le_rfl⟩ + have hreplacementHead : 1 ≀ (readyWork tapes.replacement).head ∧ + (readyWork tapes.replacement).head ≀ 1 := by + rw [hreplacement.2.1] + exact ⟨le_rfl, le_rfl⟩ + have hencode := rewindEntryEncodeTM_hoareTime_frame + tapes.appendEncodeTapes (address, newValue) 1 1 emitted + inpβ‚€ readyWork outβ‚€ hready.query.2 hready.queryStart hqueryHead + hreplacement.2.hasBinaryContent hreplacement.1 hreplacementHead + hinput (fun i _ _ => hready.parked i) houtput + obtain ⟨encoded, encodeTime, hencodeTime, hencodeReach, hencodeHalt, + hencodedInput, hquerySuffix, hqueryCells, hqueryEncodedHead, + hreplacementSuffix, hreplacementCells, hreplacementEncodedHead, + hencodedFrame, hencodedOutput⟩ := + hencode inpβ‚€ readyWork outβ‚€ ⟨rfl, rfl, rfl⟩ + have hqueryCells' : (encoded.work tapes.entry.query).cells = + (readyWork tapes.entry.query).cells := by + simpa using! hqueryCells + have hqueryEncodedHead' : (encoded.work tapes.entry.query).head = + address.bits.length + 1 := by + simpa using! hqueryEncodedHead + have hreplacementCells' : (encoded.work tapes.replacement).cells = + (readyWork tapes.replacement).cells := by + simpa using! hreplacementCells + have hreplacementEncodedHead' : + (encoded.work tapes.replacement).head = newValue.bits.length + 1 := by + simpa using! hreplacementEncodedHead + have hencodedInputParked : TM.Parked encoded.input := by + rw [hencodedInput] + exact hinput + have hencodedOutputParked : TM.Parked encoded.output := + parked_of_binaryPrefix hencodedOutput + have hencodedWorkParked : βˆ€ i, TM.Parked (encoded.work i) := + parked_work_of_frame tapes.entry.query tapes.replacement readyWork encoded.work + hready.parked (parked_of_binarySuffix (by simpa using! hquerySuffix)) + (parked_of_binarySuffix (by simpa using! hreplacementSuffix)) hencodedFrame + have hqueryContent : + (encoded.work tapes.entry.query).HasBinaryContent address.bits := by + simpa only [Tape.HasBinaryContent, hqueryCells'] using! hready.query.2 + have hqueryStart : + (encoded.work tapes.entry.query).cells 0 = Ξ“.start := by + rw [hqueryCells'] + exact hready.queryStart + have hqueryRewind := TM.rewindBinaryWorkTM_hoareTime_frame + tapes.entry.query address.bits (address.bits.length + 1) + encoded.input encoded.work encoded.output hqueryContent hqueryStart + ⟨by rw [hqueryEncodedHead']; omega, by rw [hqueryEncodedHead']⟩ + hencodedInputParked (fun i _ => hencodedWorkParked i) + hencodedOutputParked + obtain ⟨queryRewound, queryTime, hqueryTime, hqueryReach, hqueryHalt, + hqueryInput, hqueryRestoredCanonical, hqueryFrame, + hqueryOutput⟩ := + hqueryRewind encoded.input encoded.work encoded.output ⟨rfl, rfl, rfl⟩ + have hqueryCanonical : readyWork tapes.entry.query = + (Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString hready.query hready.queryStart + have hqueryRestored : queryRewound.work tapes.entry.query = + readyWork tapes.entry.query := + hqueryRestoredCanonical.trans hqueryCanonical.symm + have hreplacementContent : + (queryRewound.work tapes.replacement).HasBinaryContent newValue.bits := by + rw [hqueryFrame tapes.replacement + (tapes.replacement_ne 7)] + simpa only [Tape.HasBinaryContent, hreplacementCells'] using! + hreplacement.2.hasBinaryContent + have hreplacementStart : + (queryRewound.work tapes.replacement).cells 0 = Ξ“.start := by + rw [hqueryFrame tapes.replacement + (tapes.replacement_ne 7), hreplacementCells'] + exact hreplacement.1 + have hreplacementHead' : + (queryRewound.work tapes.replacement).head = + newValue.bits.length + 1 := by + rw [hqueryFrame tapes.replacement + (tapes.replacement_ne 7)] + exact hreplacementEncodedHead' + have hqueryInputParked : TM.Parked queryRewound.input := by + rw [hqueryInput] + exact hencodedInputParked + have hqueryOutputParked : TM.Parked queryRewound.output := by + rw [hqueryOutput] + exact hencodedOutputParked + have hqueryWorkParked : βˆ€ i, TM.Parked (queryRewound.work i) := by + intro i + by_cases hiq : i = tapes.entry.query + Β· subst i + rw [hqueryRestored] + exact hready.parked tapes.entry.query + Β· rw [hqueryFrame i hiq] + exact hencodedWorkParked i + have hreplacementRewind := TM.rewindBinaryWorkTM_hoareTime_frame + tapes.replacement newValue.bits (newValue.bits.length + 1) + queryRewound.input queryRewound.work queryRewound.output + hreplacementContent hreplacementStart + ⟨by rw [hreplacementHead']; omega, by rw [hreplacementHead']⟩ + hqueryInputParked (fun i _ => hqueryWorkParked i) hqueryOutputParked + obtain ⟨restored, replacementTime, hreplacementTime, + hreplacementReach, hreplacementHalt, hreplacementInput, + hreplacementRestoredCanonical, hreplacementFrame, + hreplacementOutput⟩ := + hreplacementRewind queryRewound.input queryRewound.work + queryRewound.output ⟨rfl, rfl, rfl⟩ + have hreplacementCanonical : readyWork tapes.replacement = + (Tape.init (newValue.bits.map Ξ“.ofBool)).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString hreplacement.2 hreplacement.1 + have hreplacementRestored : restored.work tapes.replacement = + readyWork tapes.replacement := + hreplacementRestoredCanonical.trans hreplacementCanonical.symm + have hrestoredWork : restored.work = readyWork := + work_eq_of_two_rewinds tapes.entry.query tapes.replacement readyWork encoded.work + queryRewound.work restored.work hreplacementRestored hreplacementFrame + hqueryRestored hqueryFrame hencodedFrame + obtain ⟨hqueryInputTransition, hqueryWorkTransition, + hqueryOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hqueryInputParked.read_ne_start + (fun i => (hqueryWorkParked i).read_ne_start) + hqueryOutputParked.read_ne_start + have hreplacementReach' : + (TM.rewindWorkTM tapes.replacement).reachesIn replacementTime + { state := (TM.rewindWorkTM tapes.replacement).qstart + input := TM.transitionInput queryRewound.input + work := fun i => TM.transitionTape (queryRewound.work i) + output := TM.transitionTape queryRewound.output } + restored := by + simpa only [hqueryInputTransition, hqueryWorkTransition, + hqueryOutputTransition] using! hreplacementReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (TM.rewindWorkTM tapes.entry.query) (TM.rewindWorkTM tapes.replacement) + hqueryReach hqueryHalt hreplacementReach' + let tailFinal := TM.phase2Wrap (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement) restored + have htailHalt : + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)).halted tailFinal := by + rw [TM.phase2Wrap_halted_iff] + exact hreplacementHalt + obtain ⟨hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hencodedInputParked.read_ne_start + (fun i => (hencodedWorkParked i).read_ne_start) + hencodedOutputParked.read_ne_start + have htailReach' : + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)).reachesIn + (queryTime + 1 + replacementTime) + { state := (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)).qstart + input := TM.transitionInput encoded.input + work := fun i => TM.transitionTape (encoded.work i) + output := TM.transitionTape encoded.output } + tailFinal := by + simpa only [hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeTM tapes.appendEncodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)) + hencodeReach hencodeHalt htailReach' + let finalCfg := TM.phase2Wrap + (rewindEntryEncodeTM tapes.appendEncodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)) tailFinal + refine ⟨finalCfg, encodeTime + 1 + (queryTime + 1 + replacementTime), + ?_, hreach, ?_, ?_⟩ + Β· unfold entryAppendRestoreTime + omega + Β· change (entryAppendRestoreTM tapes).halted finalCfg + unfold entryAppendRestoreTM + exact (TM.phase2Wrap_halted_iff (rewindEntryEncodeTM tapes.appendEncodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.entry.query) + (TM.rewindWorkTM tapes.replacement)) tailFinal).mpr htailHalt + Β· refine ⟨?_, ?_, ?_⟩ + Β· change restored.input = inpβ‚€ + exact hreplacementInput.trans (hqueryInput.trans hencodedInput) + Β· change restored.work = readyWork + exact hrestoredWork + Β· change restored.output.HasBinaryPrefix + (emitted ++ Entry.encode (address, newValue)) + rw [hreplacementOutput, hqueryOutput] + exact hencodedOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup.lean new file mode 100644 index 0000000000..5129401483 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Internal + +/-! +# Sparse-entry miss cleanup + +This module exposes the exact invariant-restoring miss branch used by the +bounded sparse register-store scan. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- After a failed readable entry match, rewind the preserved query and reset +all seven decoder/result scratch tapes, restoring the next-iteration frame. -/ +theorem entryMissCleanupTM_hoareTime_frame {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryMissCleanupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes rest queryBits initialWork work ∧ + out = outβ‚€) + (entryMissCleanupTime tapes entry queryBits initialWork) := + entryMissCleanupTM_hoareTime_frame_internal tapes entry rest queryBits + initialWork matchedWork inpβ‚€ outβ‚€ hmatch hinput houtput + +/-- Miss cleanup preserves one-way output safety. -/ +theorem entryMissCleanupTM_isTransducer {n : β„•} (tapes : EntryMatchTapes n) : + (entryMissCleanupTM tapes).IsTransducer := by + unfold entryMissCleanupTM + exact (TM.rewindWorkTM_isTransducer tapes.query).seqTM + (TM.resetBinaryWorkManyTM_isTransducer (entryMissTargets tapes)) + +/-- Coarse all-prefix auxiliary-space envelope for miss cleanup. -/ +theorem entryMissCleanupTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (queryBits : List Bool) + (initialWork : Fin n β†’ Tape) (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryMissCleanupTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryMissCleanupTM tapes).reachesIn time start current) + (htime : time ≀ entryMissCleanupTime tapes entry queryBits initialWork) : + current.WithinAuxSpace inputLength + (initialSpace + entryMissCleanupTime tapes entry queryBits initialWork) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Defs.lean new file mode 100644 index 0000000000..d6e956cb23 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Defs.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs + +/-! +# Sparse-entry miss cleanup β€” definitions + +The miss branch after `entryMatchReadTM` resets the seven decoder/result +scratch tapes while preserving the consumed source cursor and query address. +This restores the exact invariant needed to inspect the next encoded entry. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +namespace EntryMatchTapes + +/-- Embed the seven cleanup slots into the nine entry-match tapes. Slots zero +through five select decoder scratch `1..6`; slot six selects result tape `8`, +skipping the preserved query tape `7`. -/ +def cleanupIdx {n : β„•} (tapes : EntryMatchTapes n) (i : Fin 7) : Fin n := + tapes.idx ⟨if i.val = 6 then 8 else i.val + 1, by split <;> omega⟩ + +/-- The cleanup-slot embedding is injective. -/ +theorem cleanupIdx_injective {n : β„•} (tapes : EntryMatchTapes n) : + Function.Injective tapes.cleanupIdx := by + intro i j hij + have hslot := tapes.injective hij + apply Fin.ext + have hval := congrArg Fin.val hslot + change (if i.val = 6 then 8 else i.val + 1) = + (if j.val = 6 then 8 else j.val + 1) at hval + split at hval <;> split at hval <;> omega + +@[simp] theorem cleanupIdx_zero {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 0 = tapes.address := rfl + +@[simp] theorem cleanupIdx_one {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 1 = tapes.value := rfl + +@[simp] theorem cleanupIdx_two {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 2 = tapes.addressCounter := rfl + +@[simp] theorem cleanupIdx_three {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 3 = tapes.addressWidth := rfl + +@[simp] theorem cleanupIdx_four {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 4 = tapes.valueCounter := rfl + +@[simp] theorem cleanupIdx_five {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 5 = tapes.valueWidth := rfl + +@[simp] theorem cleanupIdx_six {n : β„•} (tapes : EntryMatchTapes n) : + tapes.cleanupIdx 6 = tapes.result := rfl + +end EntryMatchTapes + +/-- Fixed, machine-level list of the seven scratch tapes reset on a miss. -/ +def entryMissTargets {n : β„•} (tapes : EntryMatchTapes n) : List (Fin n) := + List.ofFn tapes.cleanupIdx + +/-- Canonical represented contents occupying each scratch tape at the readable +match endpoint. Values away from the seven scratch tapes are irrelevant. -/ +def entryMissBits {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (queryBits : List Bool) (i : Fin n) : List Bool := + if i = tapes.address then entry.1.bits + else if i = tapes.value then entry.2.bits + else if i = tapes.addressCounter then List.replicate (bitlen entry.1) true + else if i = tapes.addressWidth then [] + else if i = tapes.valueCounter then List.replicate (bitlen entry.2) true + else if i = tapes.valueWidth then [] + else if i = tapes.result then [decide (entry.1.bits = queryBits)] + else [] + +/-- Per-tape cursor bound inherited from the readable match contract. -/ +def entryMissHeadBound {n : β„•} (entry : Entry) (queryBits : List Bool) + (initialWork : Fin n β†’ Tape) (i : Fin n) : β„• := + (initialWork i).head + entryMatchReadTime entry queryBits + +/-- Rewind the preserved query, then reset all decoder/result scratch after a +failed entry comparison. -/ +def entryMissCleanupTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.seqTM (TM.rewindWorkTM tapes.query) + (TM.resetBinaryWorkManyTM (entryMissTargets tapes)) + +/-- Compositional miss-cleanup bound specialized to the readable endpoint. -/ +def entryMissCleanupTime {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (queryBits : List Bool) (initialWork : Fin n β†’ Tape) : β„• := + entryMissHeadBound entry queryBits initialWork tapes.query + 2 + 1 + + TM.resetBinaryWorkManyTime (entryMissBits tapes entry queryBits) + (entryMissHeadBound entry queryBits initialWork) (entryMissTargets tapes) + +/-- Loop invariant restored after a failed match: the source points at the +next entry, query is preserved, and all seven scratch tapes are canonical +blank/zero tapes ready for another decode. -/ +structure EntryScanReady {n : β„•} (tapes : EntryMatchTapes n) + (remaining queryBits : List Bool) (initialWork finalWork : Fin n β†’ Tape) : + Prop where + source : (finalWork tapes.source).HasBinarySuffix remaining + address : (finalWork tapes.address).HasBinaryPrefix [] + addressStart : (finalWork tapes.address).cells 0 = Ξ“.start + value : (finalWork tapes.value).HasBinaryPrefix [] + valueStart : (finalWork tapes.value).cells 0 = Ξ“.start + addressCounter : (finalWork tapes.addressCounter).HasBinaryNat 0 + addressWidth : (finalWork tapes.addressWidth).HasBinaryNat 0 + valueCounter : (finalWork tapes.valueCounter).HasBinaryNat 0 + valueWidth : (finalWork tapes.valueWidth).HasBinaryNat 0 + query : (finalWork tapes.query).HasBinaryString queryBits + queryStart : (finalWork tapes.query).cells 0 = Ξ“.start + result : (finalWork tapes.result).HasBinaryPrefix [] + resultStart : (finalWork tapes.result).cells 0 = Ξ“.start + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ + i β‰  tapes.value β†’ i β‰  tapes.addressCounter β†’ + i β‰  tapes.addressWidth β†’ i β‰  tapes.valueCounter β†’ + i β‰  tapes.valueWidth β†’ i β‰  tapes.query β†’ i β‰  tapes.result β†’ + finalWork i = initialWork i + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Internal.lean new file mode 100644 index 0000000000..e36804219e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryCleanup/Internal.lean @@ -0,0 +1,351 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import Mathlib.Tactic.FinCases +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Sparse-entry miss cleanup β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem entryMissTargets_nodup (tapes : EntryMatchTapes n) : + (entryMissTargets tapes).Nodup := by + exact List.nodup_ofFn_ofInjective tapes.cleanupIdx_injective + +private theorem cleanupIdx_mem (tapes : EntryMatchTapes n) (slot : Fin 7) : + tapes.cleanupIdx slot ∈ entryMissTargets tapes := by + exact List.mem_ofFn.mpr ⟨slot, rfl⟩ + +private theorem source_not_mem_entryMissTargets (tapes : EntryMatchTapes n) : + tapes.source βˆ‰ entryMissTargets tapes := by + intro hmem + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hmem + have hidx := tapes.injective hslot + have hval := congrArg Fin.val hidx + change (if slot.val = 6 then 8 else slot.val + 1) = 0 at hval + split at hval <;> omega + +private theorem query_not_mem_entryMissTargets (tapes : EntryMatchTapes n) : + tapes.query βˆ‰ entryMissTargets tapes := by + intro hmem + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hmem + have hidx := tapes.injective hslot + have hval := congrArg Fin.val hidx + change (if slot.val = 6 then 8 else slot.val + 1) = 7 at hval + split at hval <;> omega + +private theorem cleanupIdx_ne_query (tapes : EntryMatchTapes n) + (slot : Fin 7) : tapes.cleanupIdx slot β‰  tapes.query := by + intro heq + exact query_not_mem_entryMissTargets tapes + (heq β–Έ cleanupIdx_mem tapes slot) + +private theorem readable_target_content + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) : + βˆ€ i, i ∈ entryMissTargets tapes β†’ + (matchedWork i).HasBinaryContent (entryMissBits tapes entry queryBits i) := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· simpa [entryMissBits, EntryMatchTapes.address, EntryMatchTapes.value, + EntryMatchTapes.addressCounter, EntryMatchTapes.addressWidth, + EntryMatchTapes.valueCounter, EntryMatchTapes.valueWidth, + EntryMatchTapes.result, tapes.injective.eq_iff] using hmatch.address + Β· simpa [entryMissBits, EntryMatchTapes.address, EntryMatchTapes.value, + EntryMatchTapes.addressCounter, EntryMatchTapes.addressWidth, + EntryMatchTapes.valueCounter, EntryMatchTapes.valueWidth, + EntryMatchTapes.result, tapes.injective.eq_iff] using! hmatch.value.2 + Β· dsimp only [EntryMatchTapes.cleanupIdx] + change (matchedWork tapes.addressCounter).HasBinaryContent + (entryMissBits tapes entry queryBits tapes.addressCounter) + unfold entryMissBits + have haddress : tapes.addressCounter β‰  tapes.address := + tapes.ne (show (3 : Fin 9) β‰  1 by decide) + have hvalue : tapes.addressCounter β‰  tapes.value := + tapes.ne (show (3 : Fin 9) β‰  2 by decide) + rw [ite_eq_right haddress, ite_eq_right hvalue, ite_eq_left rfl] + exact hmatch.addressCounter.2 + Β· simpa [entryMissBits, EntryMatchTapes.address, EntryMatchTapes.value, + EntryMatchTapes.addressCounter, EntryMatchTapes.addressWidth, + EntryMatchTapes.valueCounter, EntryMatchTapes.valueWidth, + EntryMatchTapes.result, tapes.injective.eq_iff] using + hmatch.addressWidth.2.hasBinaryContent + Β· dsimp only [EntryMatchTapes.cleanupIdx] + change (matchedWork tapes.valueCounter).HasBinaryContent + (entryMissBits tapes entry queryBits tapes.valueCounter) + unfold entryMissBits + have haddress : tapes.valueCounter β‰  tapes.address := + tapes.ne (show (5 : Fin 9) β‰  1 by decide) + have hvalue : tapes.valueCounter β‰  tapes.value := + tapes.ne (show (5 : Fin 9) β‰  2 by decide) + have haddressCounter : tapes.valueCounter β‰  tapes.addressCounter := + tapes.ne (show (5 : Fin 9) β‰  3 by decide) + have haddressWidth : tapes.valueCounter β‰  tapes.addressWidth := + tapes.ne (show (5 : Fin 9) β‰  4 by decide) + rw [ite_eq_right haddress, ite_eq_right hvalue, ite_eq_right haddressCounter, + ite_eq_right haddressWidth, ite_eq_left rfl] + exact hmatch.valueCounter.2 + Β· simpa [entryMissBits, EntryMatchTapes.address, EntryMatchTapes.value, + EntryMatchTapes.addressCounter, EntryMatchTapes.addressWidth, + EntryMatchTapes.valueCounter, EntryMatchTapes.valueWidth, + EntryMatchTapes.result, tapes.injective.eq_iff] using + hmatch.valueWidth.2.hasBinaryContent + Β· simpa [entryMissBits, EntryMatchTapes.address, EntryMatchTapes.value, + EntryMatchTapes.addressCounter, EntryMatchTapes.addressWidth, + EntryMatchTapes.valueCounter, EntryMatchTapes.valueWidth, + EntryMatchTapes.result, tapes.injective.eq_iff] using + hmatch.result.hasBinaryContent + +private theorem readable_target_start + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) : + βˆ€ i, i ∈ entryMissTargets tapes β†’ (matchedWork i).cells 0 = Ξ“.start := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· exact hmatch.addressStart + Β· exact hmatch.valueStart + Β· exact hmatch.addressCounterStart + Β· exact hmatch.addressWidth.1 + Β· exact hmatch.valueCounterStart + Β· exact hmatch.valueWidth.1 + Β· exact hmatch.resultStart + +private theorem readable_target_head + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) : + βˆ€ i, i ∈ entryMissTargets tapes β†’ + (matchedWork i).head ≀ entryMissHeadBound entry queryBits initialWork i := by + intro i _ + exact hmatch.headBound i + +private theorem resetBinaryBlank_hasBinaryNat_zero : + TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + +private theorem resetBinaryBlank_start : + TM.resetBinaryBlank.cells 0 = Ξ“.start := by + simp [TM.resetBinaryBlank, Tape.init, Tape.move] + +private theorem hasBinaryString_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : TM.Parked t := + ⟨by rw [h.1], Tape.cells_ne_start_of_hasBinaryString h⟩ + +private theorem entryMissCleanup_post + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork rewoundWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) + (hrewoundQuery : rewoundWork tapes.query = + (Tape.init (queryBits.map Ξ“.ofBool)).move Dir3.right) + (hrewoundOther : βˆ€ i, i β‰  tapes.query β†’ rewoundWork i = matchedWork i) + (hrewoundParked : βˆ€ i, TM.Parked (rewoundWork i)) : + EntryScanReady tapes rest queryBits initialWork + (TM.resetBinaryWorkManyResult rewoundWork (entryMissTargets tapes)) := by + let finalWork := TM.resetBinaryWorkManyResult rewoundWork (entryMissTargets tapes) + have hsource : finalWork tapes.source = rewoundWork tapes.source := + TM.resetBinaryWorkManyResult_eq_of_not_mem rewoundWork _ tapes.source + (source_not_mem_entryMissTargets tapes) + have hquery : finalWork tapes.query = rewoundWork tapes.query := + TM.resetBinaryWorkManyResult_eq_of_not_mem rewoundWork _ tapes.query + (query_not_mem_entryMissTargets tapes) + have hblank : βˆ€ slot : Fin 7, + finalWork (tapes.cleanupIdx slot) = TM.resetBinaryBlank := by + intro slot + exact TM.resetBinaryWorkManyResult_eq_blank_of_mem rewoundWork _ _ + (cleanupIdx_mem tapes slot) + have hblankPrefix : βˆ€ slot : Fin 7, + (finalWork (tapes.cleanupIdx slot)).HasBinaryPrefix [] := by + intro slot + rw [hblank] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hblankStart : βˆ€ slot : Fin 7, + (finalWork (tapes.cleanupIdx slot)).cells 0 = Ξ“.start := by + intro slot + rw [hblank] + exact resetBinaryBlank_start + have hblankNat : βˆ€ slot : Fin 7, + (finalWork (tapes.cleanupIdx slot)).HasBinaryNat 0 := by + intro slot + rw [hblank] + exact resetBinaryBlank_hasBinaryNat_zero + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· have hsourceOther : rewoundWork tapes.source = matchedWork tapes.source := + hrewoundOther tapes.source (tapes.ne (by decide)) + have h := hmatch.source + rw [← hsourceOther, ← hsource] at h + simpa [finalWork] using h + Β· simpa [finalWork] using hblankPrefix 0 + Β· simpa [finalWork] using hblankStart 0 + Β· simpa [finalWork] using hblankPrefix 1 + Β· simpa [finalWork] using hblankStart 1 + Β· simpa [finalWork] using hblankNat 2 + Β· simpa [finalWork] using hblankNat 3 + Β· simpa [finalWork] using hblankNat 4 + Β· simpa [finalWork] using hblankNat 5 + Β· have h := Tape.init_move_right_hasBinaryString queryBits + rw [← hrewoundQuery, ← hquery] at h + simpa [finalWork] using h + Β· have hfinalQuery : + TM.resetBinaryWorkManyResult rewoundWork (entryMissTargets tapes) + tapes.query = + (Tape.init (queryBits.map Ξ“.ofBool)).move Dir3.right := by + simpa [finalWork] using hquery.trans hrewoundQuery + rw [hfinalQuery] + simp [Tape.init, Tape.move] + Β· simpa [finalWork] using hblankPrefix 6 + Β· simpa [finalWork] using hblankStart 6 + Β· exact TM.resetBinaryWorkManyResult_parked rewoundWork _ hrewoundParked + Β· intro i hsourceNe haddressNe hvalueNe haddressCounterNe + haddressWidthNe hvalueCounterNe hvalueWidthNe hqueryNe hresultNe + have hnotmem : i βˆ‰ entryMissTargets tapes := by + intro hmem + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hmem + fin_cases slot <;> simp_all + have hframe := hmatch.frame i hsourceNe haddressNe hvalueNe + haddressCounterNe haddressWidthNe hvalueCounterNe hvalueWidthNe + hqueryNe hresultNe + have hrewound := hrewoundOther i hqueryNe + simpa [finalWork, + TM.resetBinaryWorkManyResult_eq_of_not_mem rewoundWork _ i hnotmem] + using hrewound.trans hframe + +theorem entryMissCleanupTM_hoareTime_frame_internal + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryMissCleanupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes rest queryBits initialWork work ∧ + out = outβ‚€) + (entryMissCleanupTime tapes entry queryBits initialWork) := by + let queryTape := (Tape.init (queryBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update matchedWork tapes.query queryTape + have hrewindBase := TM.rewindBinaryWorkTM_hoareTime_frame tapes.query + queryBits (entryMissHeadBound entry queryBits initialWork tapes.query) + inpβ‚€ matchedWork outβ‚€ hmatch.query hmatch.queryStart + ⟨(hmatch.parked tapes.query).1, hmatch.headBound tapes.query⟩ hinput + (fun i _ => hmatch.parked i) houtput + have hrewind : (TM.rewindWorkTM tapes.query).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (entryMissHeadBound entry queryBits initialWork tapes.query + 2) := by + exact hrewindBase.strengthen_post (by + intro inp work out hpost + rcases hpost with ⟨hinp, hquery, hother, hout⟩ + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hi : i = tapes.query + Β· subst i + simpa [rewoundWork, queryTape] using hquery + Β· simpa [rewoundWork, Function.update_of_ne hi] using hother i hi) + have hrewoundOther : βˆ€ i, i β‰  tapes.query β†’ + rewoundWork i = matchedWork i := by + intro i hi + simp [rewoundWork, Function.update_of_ne hi] + have hrewoundParked : βˆ€ i, TM.Parked (rewoundWork i) := by + intro i + by_cases hi : i = tapes.query + Β· subst i + rw [show rewoundWork tapes.query = queryTape by + simp [rewoundWork, Function.update_self]] + exact hasBinaryString_parked (by + simpa [queryTape] using Tape.init_move_right_hasBinaryString queryBits) + Β· rw [hrewoundOther i hi] + exact hmatch.parked i + have htargetContent : βˆ€ i, i ∈ entryMissTargets tapes β†’ + (rewoundWork i).HasBinaryContent (entryMissBits tapes entry queryBits i) := by + intro i hi + have hne : i β‰  tapes.query := by + intro heq + exact query_not_mem_entryMissTargets tapes (heq β–Έ hi) + rw [hrewoundOther i hne] + exact readable_target_content tapes entry rest queryBits initialWork + matchedWork hmatch i hi + have htargetStart : βˆ€ i, i ∈ entryMissTargets tapes β†’ + (rewoundWork i).cells 0 = Ξ“.start := by + intro i hi + have hne : i β‰  tapes.query := by + intro heq + exact query_not_mem_entryMissTargets tapes (heq β–Έ hi) + rw [hrewoundOther i hne] + exact readable_target_start tapes entry rest queryBits initialWork + matchedWork hmatch i hi + have htargetHead : βˆ€ i, i ∈ entryMissTargets tapes β†’ + (rewoundWork i).head ≀ entryMissHeadBound entry queryBits initialWork i := by + intro i hi + have hne : i β‰  tapes.query := by + intro heq + exact query_not_mem_entryMissTargets tapes (heq β–Έ hi) + rw [hrewoundOther i hne] + exact hmatch.headBound i + have hreset := TM.resetBinaryWorkManyTM_hoareTime_frame + (entryMissTargets tapes) (entryMissBits tapes entry queryBits) + (entryMissHeadBound entry queryBits initialWork) inpβ‚€ rewoundWork outβ‚€ + (entryMissTargets_nodup tapes) htargetContent htargetStart htargetHead + hinput hrewoundParked houtput + have hseq := TM.seqTM_hoareTime (TM.rewindWorkTM tapes.query) + (TM.resetBinaryWorkManyTM (entryMissTargets tapes)) hrewind + (by + intro inp work out hmid + rcases hmid with ⟨hinp, hwork, hout⟩ + subst work + obtain ⟨hinpTransition, hworkTransition, houtTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + (hinp β–Έ hinput.read_ne_start) + (fun i => (hrewoundParked i).read_ne_start) + (hout β–Έ houtput.read_ne_start) + rw [hinpTransition, hworkTransition, houtTransition] + exact ⟨hinp, rfl, hout⟩) + hreset + have hfinal := hseq.strengthen_post + (post' := fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes rest queryBits initialWork work ∧ + out = outβ‚€) (by + intro inp work out hpost + rcases hpost with ⟨hinp, hwork, hout⟩ + subst work + exact ⟨hinp, + entryMissCleanup_post tapes entry rest queryBits initialWork matchedWork + rewoundWork hmatch (by simp [rewoundWork, queryTape]) hrewoundOther + hrewoundParked, + hout⟩) + simpa [entryMissCleanupTM, entryMissCleanupTime] using hfinal + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode.lean new file mode 100644 index 0000000000..27cdd63d91 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.LinearInternal + +/-! +# RAM sparse-entry decoder + +This module exposes the exact framed semantics of the concrete two-word sparse +address/value decoder. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Decode one canonical sparse address/value entry exactly, leaving the next +encoded entry under the source head and preserving every unrelated tape. -/ +theorem entryDecodeTM_reachesIn_frame {n : β„•} + (tapes : EntryDecodeTapes n) (entry : Entry) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (entryDecodeTM tapes).reachesIn (entryDecodeTime entry.1 entry.2) + { state := (entryDecodeTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryDecodeTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryPrefix entry.1.bits ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryNat (bitlen entry.1) ∧ + (c'.work tapes.addressWidth).HasBinaryNat (bitlen entry.1) ∧ + (c'.work tapes.valueCounter).HasBinaryNat (bitlen entry.2) ∧ + (c'.work tapes.valueWidth).HasBinaryNat (bitlen entry.2) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.addressWidth β†’ + i β‰  tapes.valueCounter β†’ i β‰  tapes.valueWidth β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + entryDecodeTM_reachesIn_frame_internal tapes entry rest inpβ‚€ workβ‚€ outβ‚€ + hsource haddress hvalue haddressStart hvalueStart haddressCounter + haddressWidth hvalueCounter hvalueWidth hinput hreads houtput + +/-- Coarse all-prefix auxiliary-space envelope for entry decoding. -/ +theorem entryDecodeTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryDecodeTapes n) (address value : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryDecodeTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryDecodeTM tapes).reachesIn time start current) + (htime : time ≀ entryDecodeTime address value) : + current.WithinAuxSpace inputLength + (initialSpace + entryDecodeTime address value) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Entry decoding preserves one-way output safety. -/ +theorem entryDecodeTM_isTransducer {n : β„•} (tapes : EntryDecodeTapes n) : + (entryDecodeTM tapes).IsTransducer := by + unfold entryDecodeTM + exact (wordDecodeTM_isTransducer tapes.source tapes.address + tapes.addressCounter tapes.addressWidth).seqTM + (wordDecodeTM_isTransducer tapes.source tapes.value tapes.valueCounter + tapes.valueWidth) + +/-! ## Linear unary-marker decoder -/ + +/-- Decode one canonical sparse entry using unary markers, leaving the next +entry under the source head and preserving the two unused width tapes. -/ +theorem entryDecodeLinearTM_reachesIn_frame {n : β„•} + (tapes : EntryDecodeTapes n) (entry : Entry) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressMarker : (workβ‚€ tapes.addressCounter).HasBinaryPrefix []) + (haddressMarkerStart : (workβ‚€ tapes.addressCounter).cells 0 = Ξ“.start) + (hvalueMarker : (workβ‚€ tapes.valueCounter).HasBinaryPrefix []) + (hvalueMarkerStart : (workβ‚€ tapes.valueCounter).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (entryDecodeLinearTM tapes).reachesIn + (entryDecodeLinearTime entry.1 entry.2) + { state := (entryDecodeLinearTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryDecodeLinearTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryPrefix entry.1.bits ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) ∧ + (c'.work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.valueCounter β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + entryDecodeLinearTM_reachesIn_frame_internal tapes entry rest inpβ‚€ workβ‚€ outβ‚€ + hsource haddress hvalue haddressStart hvalueStart haddressMarker + haddressMarkerStart hvalueMarker hvalueMarkerStart hinput hreads houtput + +/-- The exact optimized entry-decoding time is linear in the two word widths. -/ +theorem entryDecodeLinearTime_eq (address value : β„•) : + entryDecodeLinearTime address value = + 3 * (bitlen address + bitlen value) + 7 := by + unfold entryDecodeLinearTime wordDecodeLinearTime + omega + +/-- Coarse all-prefix auxiliary-space envelope for optimized entry decoding. -/ +theorem entryDecodeLinearTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryDecodeTapes n) (address value : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryDecodeLinearTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryDecodeLinearTM tapes).reachesIn time start current) + (htime : time ≀ entryDecodeLinearTime address value) : + current.WithinAuxSpace inputLength + (initialSpace + entryDecodeLinearTime address value) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Optimized entry decoding preserves one-way output safety. -/ +theorem entryDecodeLinearTM_isTransducer {n : β„•} + (tapes : EntryDecodeTapes n) : + (entryDecodeLinearTM tapes).IsTransducer := by + unfold entryDecodeLinearTM + exact (wordDecodeLinearTM_isTransducer tapes.source tapes.address + tapes.addressCounter).seqTM + (wordDecodeLinearTM_isTransducer tapes.source tapes.value + tapes.valueCounter) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Defs.lean new file mode 100644 index 0000000000..3bc1567e58 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Defs.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# RAM sparse-entry decoder β€” definitions + +One sparse register entry contains two consecutive self-delimiting words: its +address and value. `entryDecodeTM` gives each word its own target, counter, and +width tapes so the two checked word decoders compose without a clearing phase. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Seven pairwise-distinct work tapes used by one sparse-entry decoder. -/ +structure EntryDecodeTapes (n : β„•) where + /-- Tape assignment in the order source, address, value, address counter, + address width, value counter, value width. -/ + idx : Fin 7 β†’ Fin n + injective : Function.Injective idx + +namespace EntryDecodeTapes + +/-- Encoded entry-stream source tape. -/ +def source {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 0 +/-- Decoded address target tape. -/ +def address {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 1 +/-- Decoded value target tape. -/ +def value {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 2 +/-- Binary loop counter used while decoding the address. -/ +def addressCounter {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 3 +/-- Preserved address payload-width tape. -/ +def addressWidth {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 4 +/-- Binary loop counter used while decoding the value. -/ +def valueCounter {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 5 +/-- Preserved value payload-width tape. -/ +def valueWidth {n : β„•} (tapes : EntryDecodeTapes n) : Fin n := tapes.idx 6 + +theorem ne {n : β„•} (tapes : EntryDecodeTapes n) {i j : Fin 7} (h : i β‰  j) : + tapes.idx i β‰  tapes.idx j := + fun hij => h (tapes.injective hij) + +theorem addressDistinct {n : β„•} (tapes : EntryDecodeTapes n) : + PayloadLoopDistinct tapes.source tapes.address tapes.addressCounter + tapes.addressWidth := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide), + tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide)⟩ + +theorem valueDistinct {n : β„•} (tapes : EntryDecodeTapes n) : + PayloadLoopDistinct tapes.source tapes.value tapes.valueCounter + tapes.valueWidth := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide), + tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide)⟩ + +/-- Source, address target, and address marker are pairwise distinct. -/ +theorem addressLinearDistinct {n : β„•} (tapes : EntryDecodeTapes n) : + LinearWordDistinct tapes.source tapes.address tapes.addressCounter := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide)⟩ + +/-- Source, value target, and value marker are pairwise distinct. -/ +theorem valueLinearDistinct {n : β„•} (tapes : EntryDecodeTapes n) : + LinearWordDistinct tapes.source tapes.value tapes.valueCounter := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide)⟩ + +end EntryDecodeTapes + +/-- Decode the address word and then the value word of one sparse entry. -/ +def entryDecodeTM {n : β„•} (tapes : EntryDecodeTapes n) : TM n := + TM.seqTM + (wordDecodeTM tapes.source tapes.address tapes.addressCounter + tapes.addressWidth) + (wordDecodeTM tapes.source tapes.value tapes.valueCounter tapes.valueWidth) + +/-- Exact runtime for decoding both words, including the composition seam. -/ +def entryDecodeTime (address value : β„•) : β„• := + wordDecodeTime (bitlen address) + 1 + wordDecodeTime (bitlen value) + +/-- Decode both entry words with unary markers. The former counter tapes serve +as address and value markers; the two width tapes are left untouched so this +machine can replace `entryDecodeTM` inside the established seven-tape ABI. -/ +def entryDecodeLinearTM {n : β„•} (tapes : EntryDecodeTapes n) : TM n := + TM.seqTM + (wordDecodeLinearTM tapes.source tapes.address tapes.addressCounter) + (wordDecodeLinearTM tapes.source tapes.value tapes.valueCounter) + +/-- Exact runtime of the optimized two-word decoder, including its composition +seam. -/ +def entryDecodeLinearTime (address value : β„•) : β„• := + wordDecodeLinearTime (bitlen address) + 1 + + wordDecodeLinearTime (bitlen value) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Internal.lean new file mode 100644 index 0000000000..ff4207023c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/Internal.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode + +/-! +# RAM sparse-entry decoder β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +theorem entryDecodeTM_reachesIn_frame_internal {n : β„•} + (tapes : EntryDecodeTapes n) (entry : Entry) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (entryDecodeTM tapes).reachesIn (entryDecodeTime entry.1 entry.2) + { state := (entryDecodeTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryDecodeTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryPrefix entry.1.bits ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryNat (bitlen entry.1) ∧ + (c'.work tapes.addressWidth).HasBinaryNat (bitlen entry.1) ∧ + (c'.work tapes.valueCounter).HasBinaryNat (bitlen entry.2) ∧ + (c'.work tapes.valueWidth).HasBinaryNat (bitlen entry.2) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.addressWidth β†’ + i β‰  tapes.valueCounter β†’ i β‰  tapes.valueWidth β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let addressTM := wordDecodeTM tapes.source tapes.address + tapes.addressCounter tapes.addressWidth + let valueTM := wordDecodeTM tapes.source tapes.value + tapes.valueCounter tapes.valueWidth + have hsourceAddress : (workβ‚€ tapes.source).HasBinarySuffix + (WordCode.encode entry.1 ++ (WordCode.encode entry.2 ++ rest)) := by + simpa [Entry.encode, List.append_assoc] using hsource + obtain ⟨addressDone, haddressReach, haddressHalt, haddressInput, + haddressSource, haddressTarget, haddressCounterFinal, + haddressWidthFinal, haddressFrame, haddressOutput⟩ := + wordDecodeTM_reachesIn_frame_encode tapes.source tapes.address + tapes.addressCounter tapes.addressWidth tapes.addressDistinct entry.1 + (WordCode.encode entry.2 ++ rest) inpβ‚€ workβ‚€ outβ‚€ hsourceAddress haddress + haddressCounter haddressWidth hinput (fun i _ _ _ _ => hreads i) houtput + have haddressStartFinal : + (addressDone.work tapes.address).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.address haddressReach + haddressStart + have haddressReads : βˆ€ i, (addressDone.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = tapes.source + Β· subst i + exact haddressSource.read_ne_start + Β· by_cases hit : i = tapes.address + Β· subst i + rw [haddressTarget.read_blank] + decide + Β· by_cases hic : i = tapes.addressCounter + Β· subst i + rw [haddressCounterFinal.eq_init_move_right] + exact Tape.init_ofBool_move_right_read_ne_start (bitlen entry.1).bits + Β· by_cases hiw : i = tapes.addressWidth + Β· subst i + rw [haddressWidthFinal.eq_init_move_right] + exact Tape.init_ofBool_move_right_read_ne_start (bitlen entry.1).bits + Β· rw [haddressFrame i his hit hic hiw] + exact hreads i + have hvalueInitial : (addressDone.work tapes.value).HasBinaryPrefix [] := by + rw [haddressFrame tapes.value (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalue + have hvalueStartInitial : + (addressDone.work tapes.value).cells 0 = Ξ“.start := by + rw [haddressFrame tapes.value (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueStart + have hvalueCounterInitial : + (addressDone.work tapes.valueCounter).HasBinaryNat 0 := by + rw [haddressFrame tapes.valueCounter (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueCounter + have hvalueWidthInitial : + (addressDone.work tapes.valueWidth).HasBinaryNat 0 := by + rw [haddressFrame tapes.valueWidth (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueWidth + obtain ⟨valueDone, hvalueReach, hvalueHalt, hvalueInput, hvalueSource, + hvalueTarget, hvalueCounterFinal, hvalueWidthFinal, hvalueFrame, + hvalueOutput⟩ := + wordDecodeTM_reachesIn_frame_encode tapes.source tapes.value + tapes.valueCounter tapes.valueWidth tapes.valueDistinct entry.2 rest + addressDone.input addressDone.work addressDone.output haddressSource + hvalueInitial hvalueCounterInitial hvalueWidthInitial + (by rw [haddressInput]; exact hinput) + (fun i _ _ _ _ => haddressReads i) + (by rw [haddressOutput]; exact houtput) + have hvalueStartFinal : (valueDone.work tapes.value).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.value hvalueReach + hvalueStartInitial + have htransitionInput : TM.transitionInput addressDone.input = + addressDone.input := + TM.transitionInput_eq_self (by rw [haddressInput]; exact hinput) + have htransitionWork : + (fun i => TM.transitionTape (addressDone.work i)) = addressDone.work := by + funext i + exact TM.transitionTape_eq_self (haddressReads i) + have htransitionOutput : TM.transitionTape addressDone.output = + addressDone.output := + TM.transitionTape_eq_self (by rw [haddressOutput]; exact houtput) + have hvalueReach' : valueTM.reachesIn (wordDecodeTime (bitlen entry.2)) + { state := valueTM.qstart + input := TM.transitionInput addressDone.input + work := fun i => TM.transitionTape (addressDone.work i) + output := TM.transitionTape addressDone.output } valueDone := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [valueTM] using hvalueReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn addressTM valueTM + (by simpa [addressTM] using haddressReach) haddressHalt hvalueReach' + let finalCfg := TM.phase2Wrap addressTM valueTM valueDone + refine ⟨finalCfg, ?_, ?_, hvalueInput.trans haddressInput, hvalueSource, ?_, + ?_, hvalueTarget, hvalueStartFinal, ?_, ?_, hvalueCounterFinal, + hvalueWidthFinal, ?_, hvalueOutput.trans haddressOutput⟩ + Β· simpa [entryDecodeTM, entryDecodeTime, addressTM, valueTM, finalCfg] using! + hfullReach + Β· exact (TM.phase2Wrap_halted_iff addressTM valueTM valueDone).2 hvalueHalt + Β· change (valueDone.work tapes.address).HasBinaryPrefix entry.1.bits + rw [hvalueFrame tapes.address (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressTarget + Β· change (valueDone.work tapes.address).cells 0 = Ξ“.start + rw [hvalueFrame tapes.address (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressStartFinal + Β· change (valueDone.work tapes.addressCounter).HasBinaryNat (bitlen entry.1) + rw [hvalueFrame tapes.addressCounter (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressCounterFinal + Β· change (valueDone.work tapes.addressWidth).HasBinaryNat (bitlen entry.1) + rw [hvalueFrame tapes.addressWidth (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressWidthFinal + Β· intro i his hia hiv hiac hiaw hivc hivw + change valueDone.work i = workβ‚€ i + rw [hvalueFrame i his hiv hivc hivw, + haddressFrame i his hia hiac hiaw] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/LinearInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/LinearInternal.lean new file mode 100644 index 0000000000..47c3ba8221 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryDecode/LinearInternal.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode + +/-! +# Linear RAM sparse-entry decoder -- proof internals + +The address and value words are decoded by the linear unary-marker decoder. +The established counter tapes become markers, while the width tapes remain +framed for compatibility with the existing sparse-store work-tape layout. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +theorem entryDecodeLinearTM_reachesIn_frame_internal {n : β„•} + (tapes : EntryDecodeTapes n) (entry : Entry) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressMarker : (workβ‚€ tapes.addressCounter).HasBinaryPrefix []) + (haddressMarkerStart : (workβ‚€ tapes.addressCounter).cells 0 = Ξ“.start) + (hvalueMarker : (workβ‚€ tapes.valueCounter).HasBinaryPrefix []) + (hvalueMarkerStart : (workβ‚€ tapes.valueCounter).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (entryDecodeLinearTM tapes).reachesIn + (entryDecodeLinearTime entry.1 entry.2) + { state := (entryDecodeLinearTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryDecodeLinearTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryPrefix entry.1.bits ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) ∧ + (c'.work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.valueCounter β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let addressTM := wordDecodeLinearTM tapes.source tapes.address + tapes.addressCounter + let valueTM := wordDecodeLinearTM tapes.source tapes.value + tapes.valueCounter + have hsourceAddress : (workβ‚€ tapes.source).HasBinarySuffix + (WordCode.encode entry.1 ++ (WordCode.encode entry.2 ++ rest)) := by + simpa [Entry.encode, List.append_assoc] using hsource + obtain ⟨addressDone, haddressReach, haddressHalt, haddressInput, + haddressSource, haddressTarget, haddressMarkerFinal, haddressFrame, + haddressOutput⟩ := + wordDecodeLinearTM_reachesIn_frame_encode tapes.source tapes.address + tapes.addressCounter tapes.addressLinearDistinct entry.1 + (WordCode.encode entry.2 ++ rest) inpβ‚€ workβ‚€ outβ‚€ hsourceAddress + haddress haddressMarker haddressMarkerStart hinput hreads houtput + have haddressStartFinal : + (addressDone.work tapes.address).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.address haddressReach + haddressStart + have haddressReads : βˆ€ i, (addressDone.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = tapes.source + Β· subst i + exact haddressSource.read_ne_start + Β· by_cases hia : i = tapes.address + Β· subst i + rw [haddressTarget.read_blank] + decide + Β· by_cases him : i = tapes.addressCounter + Β· subst i + rw [haddressMarkerFinal.read_blank] + decide + Β· rw [haddressFrame i his hia him] + exact hreads i + have hvalueInitial : + (addressDone.work tapes.value).HasBinaryPrefix [] := by + rw [haddressFrame tapes.value (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalue + have hvalueStartInitial : + (addressDone.work tapes.value).cells 0 = Ξ“.start := by + rw [haddressFrame tapes.value (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueStart + have hvalueMarkerInitial : + (addressDone.work tapes.valueCounter).HasBinaryPrefix [] := by + rw [haddressFrame tapes.valueCounter (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueMarker + have hvalueMarkerStartInitial : + (addressDone.work tapes.valueCounter).cells 0 = Ξ“.start := by + rw [haddressFrame tapes.valueCounter (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact hvalueMarkerStart + obtain ⟨valueDone, hvalueReach, hvalueHalt, hvalueInput, hvalueSource, + hvalueTarget, hvalueMarkerFinal, hvalueFrame, hvalueOutput⟩ := + wordDecodeLinearTM_reachesIn_frame_encode tapes.source tapes.value + tapes.valueCounter tapes.valueLinearDistinct entry.2 rest + addressDone.input addressDone.work addressDone.output haddressSource + hvalueInitial hvalueMarkerInitial hvalueMarkerStartInitial + (by rw [haddressInput]; exact hinput) haddressReads + (by rw [haddressOutput]; exact houtput) + have hvalueStartFinal : + (valueDone.work tapes.value).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.value hvalueReach + hvalueStartInitial + have htransitionInput : TM.transitionInput addressDone.input = + addressDone.input := + TM.transitionInput_eq_self (by rw [haddressInput]; exact hinput) + have htransitionWork : + (fun i => TM.transitionTape (addressDone.work i)) = addressDone.work := by + funext i + exact TM.transitionTape_eq_self (haddressReads i) + have htransitionOutput : TM.transitionTape addressDone.output = + addressDone.output := + TM.transitionTape_eq_self (by rw [haddressOutput]; exact houtput) + have hvalueReach' : valueTM.reachesIn + (wordDecodeLinearTime (bitlen entry.2)) + { state := valueTM.qstart + input := TM.transitionInput addressDone.input + work := fun i => TM.transitionTape (addressDone.work i) + output := TM.transitionTape addressDone.output } valueDone := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [valueTM] using hvalueReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn addressTM valueTM + (by simpa [addressTM] using haddressReach) haddressHalt hvalueReach' + let finalCfg := TM.phase2Wrap addressTM valueTM valueDone + refine ⟨finalCfg, ?_, ?_, hvalueInput.trans haddressInput, hvalueSource, + ?_, ?_, hvalueTarget, hvalueStartFinal, ?_, hvalueMarkerFinal, ?_, + hvalueOutput.trans haddressOutput⟩ + Β· simpa [entryDecodeLinearTM, entryDecodeLinearTime, addressTM, valueTM, + finalCfg] using! hfullReach + Β· exact (TM.phase2Wrap_halted_iff addressTM valueTM valueDone).2 hvalueHalt + Β· change (valueDone.work tapes.address).HasBinaryPrefix entry.1.bits + rw [hvalueFrame tapes.address (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressTarget + Β· change (valueDone.work tapes.address).cells 0 = Ξ“.start + rw [hvalueFrame tapes.address (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressStartFinal + Β· change (valueDone.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) + rw [hvalueFrame tapes.addressCounter (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.ne (by decide))] + exact haddressMarkerFinal + Β· intro i his hia hiv hiac hivc + change valueDone.work i = workβ‚€ i + rw [hvalueFrame i his hiv hivc, haddressFrame i his hia hiac] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode.lean new file mode 100644 index 0000000000..f3410eb902 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.RetargetOutput + +/-! +# Sparse entry emission +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Emit exactly `Entry.encode entry` from distinct canonical address and value +work tapes, with a literal frame around those sources. -/ +theorem entryEncodeTM_hoareTime_frame {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryNat entry.1) + (hvalue : (workβ‚€ tapes.value).HasBinaryNat entry.2) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryEncodeTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.address).HasBinarySuffix [] ∧ + (work tapes.address).cells = (workβ‚€ tapes.address).cells ∧ + (work tapes.address).head = entry.1.bits.length + 1 ∧ + (work tapes.value).HasBinarySuffix [] ∧ + (work tapes.value).cells = (workβ‚€ tapes.value).cells ∧ + (work tapes.value).head = entry.2.bits.length + 1 ∧ + (βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (entryEncodeTime entry) := + entryEncodeTM_hoareTime_frame_internal tapes entry emitted inpβ‚€ workβ‚€ outβ‚€ + haddress hvalue hinput hother houtput + +/-- Rewind arbitrary bounded decoded address/value cursors and emit exactly +`Entry.encode entry`, retaining a literal frame around both sources. -/ +theorem rewindEntryEncodeTM_hoareTime_frame {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) + (addressHeadBound valueHeadBound : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryContent entry.1.bits) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (haddressHead : 1 ≀ (workβ‚€ tapes.address).head ∧ + (workβ‚€ tapes.address).head ≀ addressHeadBound) + (hvalue : (workβ‚€ tapes.value).HasBinaryContent entry.2.bits) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (hvalueHead : 1 ≀ (workβ‚€ tapes.value).head ∧ + (workβ‚€ tapes.value).head ≀ valueHeadBound) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindEntryEncodeTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.address).HasBinarySuffix [] ∧ + (work tapes.address).cells = (workβ‚€ tapes.address).cells ∧ + (work tapes.address).head = entry.1.bits.length + 1 ∧ + (work tapes.value).HasBinarySuffix [] ∧ + (work tapes.value).cells = (workβ‚€ tapes.value).cells ∧ + (work tapes.value).head = entry.2.bits.length + 1 ∧ + (βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (rewindEntryEncodeTime entry addressHeadBound valueHeadBound) := + rewindEntryEncodeTM_hoareTime_frame_internal tapes entry addressHeadBound + valueHeadBound emitted inpβ‚€ workβ‚€ outβ‚€ haddress haddressStart + haddressHead hvalue hvalueStart hvalueHead hinput hother houtput + +/-- Emit one entry from canonical address/value sources, then restore the +entire work family exactly. -/ +theorem rewindEntryEncodeRestoreTM_hoareTime_frame {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryNat entry.1) + (hvalue : (workβ‚€ tapes.value).HasBinaryNat entry.2) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindEntryEncodeRestoreTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (rewindEntryEncodeRestoreTime entry) := + rewindEntryEncodeRestoreTM_hoareTime_frame_internal tapes entry emitted + inpβ‚€ workβ‚€ outβ‚€ haddress hvalue hinput hother houtput + +/-- Redirect restored entry emission into the fresh last work tape. All base +work tapes are restored exactly and the real output remains standard blank. -/ +theorem rewindEntryEncodeRestoreTM_retargetOutput_hoareTime_frame {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (haddress : (workβ‚€ (Fin.castSucc tapes.address)).HasBinaryNat entry.1) + (hvalue : (workβ‚€ (Fin.castSucc tapes.value)).HasBinaryNat entry.2) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ (Fin.castSucc i))) + (hbuffer : (workβ‚€ (Fin.last n)).HasBinaryPrefix emitted) : + (rewindEntryEncodeRestoreTM tapes).retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  Fin.last n β†’ work i = workβ‚€ i) ∧ + (work (Fin.last n)).HasBinaryPrefix + (emitted ++ Entry.encode entry) ∧ + out = (Tape.init []).move Dir3.right) + (rewindEntryEncodeRestoreTime entry) := by + let baseWork : Fin n β†’ Tape := fun i => workβ‚€ (Fin.castSucc i) + have hbase := rewindEntryEncodeRestoreTM_hoareTime_frame tapes entry emitted + inpβ‚€ baseWork (workβ‚€ (Fin.last n)) haddress hvalue hinput hother hbuffer + have hlift := TM.retargetOutput_hoareTime + (rewindEntryEncodeRestoreTM tapes) hbase + apply hlift.consequence + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + exact ⟨⟨rfl, rfl, rfl⟩, hout⟩ + Β· intro inp work out hpost + rcases hpost with ⟨⟨hinp, hbaseWork, hbuffer'⟩, hout⟩ + refine ⟨hinp, ?_, hbuffer', hout⟩ + intro i hi + have hil : i.val < n := by + have hle : i.val ≀ n := by omega + have hne : i.val β‰  n := by + intro hval + apply hi + apply Fin.ext + simpa using hval + omega + let j : Fin n := ⟨i.val, hil⟩ + have hij : i = Fin.castSucc j := by + apply Fin.ext + rfl + rw [hij] + exact congrFun hbaseWork j + Β· exact le_rfl + +/-- Entry emission is append-only on the output tape. -/ +theorem entryEncodeTM_isTransducer {n : β„•} (tapes : EntryEncodeTapes n) : + (entryEncodeTM tapes).IsTransducer := + (wordEncodeTM_isTransducer tapes.address).seqTM + (wordEncodeTM_isTransducer tapes.value) + +/-- Rewind-and-emit entry encoding is append-only on the output tape. -/ +theorem rewindEntryEncodeTM_isTransducer {n : β„•} + (tapes : EntryEncodeTapes n) : + (rewindEntryEncodeTM tapes).IsTransducer := + (rewindWordEncodeTM_isTransducer tapes.address).seqTM + (rewindWordEncodeTM_isTransducer tapes.value) + +/-- Coarse all-prefix auxiliary-space envelope for entry emission. -/ +theorem entryEncodeTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryEncodeTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryEncodeTM tapes).reachesIn time start current) + (htime : time ≀ entryEncodeTime entry) : + current.WithinAuxSpace inputLength + (initialSpace + entryEncodeTime entry) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Coarse all-prefix envelope for rewind-and-emit entry encoding. -/ +theorem rewindEntryEncodeTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryEncodeTapes n) (entry : Entry) + (addressHeadBound valueHeadBound inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (rewindEntryEncodeTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (rewindEntryEncodeTM tapes).reachesIn time start current) + (htime : time ≀ + rewindEntryEncodeTime entry addressHeadBound valueHeadBound) : + current.WithinAuxSpace inputLength + (initialSpace + + rewindEntryEncodeTime entry addressHeadBound valueHeadBound) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Defs.lean new file mode 100644 index 0000000000..60670afeeb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Defs.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs + +/-! +# Sparse entry emission β€” definitions +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Distinct decoded address and value tapes used to emit one sparse entry. -/ +structure EntryEncodeTapes (n : β„•) where + /-- Decoded address source. -/ + address : Fin n + /-- Decoded value source. -/ + value : Fin n + /-- The address and value sources are distinct. -/ + ne : address β‰  value + +/-- Emit one address/value entry as two consecutive self-delimiting words. -/ +def entryEncodeTM {n : β„•} (tapes : EntryEncodeTapes n) : TM n := + TM.seqTM (wordEncodeTM tapes.address) (wordEncodeTM tapes.value) + +/-- Compositional time bound for one encoded entry. -/ +def entryEncodeTime (entry : Entry) : β„• := + wordEncodeTime entry.1 + 1 + wordEncodeTime entry.2 + +/-- Rewind arbitrary decoded address/value cursors and emit the entry. -/ +def rewindEntryEncodeTM {n : β„•} (tapes : EntryEncodeTapes n) : TM n := + TM.seqTM (rewindWordEncodeTM tapes.address) + (rewindWordEncodeTM tapes.value) + +/-- Composition bound for emitting an entry from arbitrary bounded cursors. -/ +def rewindEntryEncodeTime (entry : Entry) + (addressHeadBound valueHeadBound : β„•) : β„• := + rewindWordEncodeTime entry.1 addressHeadBound + 1 + + rewindWordEncodeTime entry.2 valueHeadBound + +/-- Emit an entry from canonical sources and restore both source heads to +cell one. -/ +def rewindEntryEncodeRestoreTM {n : β„•} (tapes : EntryEncodeTapes n) : TM n := + TM.seqTM (rewindEntryEncodeTM tapes) + (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)) + +/-- Compositional bound for entry emission followed by two-source restore. -/ +def rewindEntryEncodeRestoreTime (entry : Entry) : β„• := + rewindEntryEncodeTime entry 1 1 + 1 + + (entry.1.bits.length + 3 + 1 + entry.2.bits.length + 3) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Internal.lean new file mode 100644 index 0000000000..b87a41a801 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryEncode/Internal.lean @@ -0,0 +1,490 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode + +/-! +# Sparse entry emission β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem parked_of_binaryNat {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +theorem entryEncodeTM_hoareTime_frame_internal + (tapes : EntryEncodeTapes n) (entry : Entry) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryNat entry.1) + (hvalue : (workβ‚€ tapes.value).HasBinaryNat entry.2) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryEncodeTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.address).HasBinarySuffix [] ∧ + (work tapes.address).cells = (workβ‚€ tapes.address).cells ∧ + (work tapes.address).head = entry.1.bits.length + 1 ∧ + (work tapes.value).HasBinarySuffix [] ∧ + (work tapes.value).cells = (workβ‚€ tapes.value).cells ∧ + (work tapes.value).head = entry.2.bits.length + 1 ∧ + (βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (entryEncodeTime entry) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hinitialParked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + by_cases hia : i = tapes.address + Β· subst i + exact parked_of_binaryNat haddress + Β· by_cases hiv : i = tapes.value + Β· subst i + exact parked_of_binaryNat hvalue + Β· exact hother i hia hiv + have haddressContract := wordEncodeTM_hoareTime_frame tapes.address + entry.1 emitted inpβ‚€ workβ‚€ outβ‚€ haddress hinput + (fun i _ => hinitialParked i) houtput + obtain ⟨addressDone, addressTime, haddressTime, haddressReach, + haddressHalt, haddressInput, haddressSuffix, haddressCells, + haddressHeadDone, haddressFrame, haddressOutput⟩ := + haddressContract inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have haddressParked : TM.Parked (addressDone.work tapes.address) := + parked_of_binarySuffix haddressSuffix + have haddressWorkParked : βˆ€ i, TM.Parked (addressDone.work i) := by + intro i + by_cases hi : i = tapes.address + Β· subst i + exact haddressParked + Β· rw [haddressFrame i hi] + exact hinitialParked i + have haddressOutputParked : TM.Parked addressDone.output := + parked_of_binaryPrefix haddressOutput + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + (haddressInput β–Έ hinput.read_ne_start) + (fun i => (haddressWorkParked i).read_ne_start) + haddressOutputParked.read_ne_start + have hvalueDone : (addressDone.work tapes.value).HasBinaryNat entry.2 := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + exact hvalue + have hvalueContract := wordEncodeTM_hoareTime_frame tapes.value entry.2 + (emitted ++ WordCode.encode entry.1) addressDone.input addressDone.work + addressDone.output hvalueDone (haddressInput β–Έ hinput) + (fun i _ => haddressWorkParked i) haddressOutput + obtain ⟨valueDone, valueTime, hvalueTime, hvalueReach, hvalueHalt, + hvalueInput, hvalueSuffix, hvalueCells, hvalueHeadFinal, + hvalueFrame, hvalueOutput⟩ := + hvalueContract addressDone.input addressDone.work addressDone.output + ⟨rfl, rfl, rfl⟩ + have hvalueReach' : (wordEncodeTM tapes.value).reachesIn valueTime + { state := (wordEncodeTM tapes.value).qstart + input := TM.transitionInput addressDone.input + work := fun i => TM.transitionTape (addressDone.work i) + output := TM.transitionTape addressDone.output } + valueDone := by + simpa [hinputTransition, hworkTransition, houtputTransition] using + hvalueReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (wordEncodeTM tapes.address) (wordEncodeTM tapes.value) + haddressReach haddressHalt hvalueReach' + let finalCfg := TM.phase2Wrap (wordEncodeTM tapes.address) + (wordEncodeTM tapes.value) valueDone + refine ⟨finalCfg, addressTime + 1 + valueTime, ?_, hreach, ?_, ?_⟩ + Β· unfold entryEncodeTime + omega + Β· change (entryEncodeTM tapes).halted finalCfg + unfold entryEncodeTM + rw [TM.phase2Wrap_halted_iff] + exact hvalueHalt + Β· refine ⟨?_, ?_, ?_, ?_, hvalueSuffix, ?_, hvalueHeadFinal, ?_, ?_⟩ + Β· simpa [finalCfg] using! hvalueInput.trans haddressInput + Β· change (valueDone.work tapes.address).HasBinarySuffix [] + rw [hvalueFrame tapes.address tapes.ne] + exact haddressSuffix + Β· change (valueDone.work tapes.address).cells = + (workβ‚€ tapes.address).cells + rw [hvalueFrame tapes.address tapes.ne] + exact haddressCells + Β· change (valueDone.work tapes.address).head = entry.1.bits.length + 1 + rw [hvalueFrame tapes.address tapes.ne] + exact haddressHeadDone + Β· change (valueDone.work tapes.value).cells = (workβ‚€ tapes.value).cells + rw [hvalueCells, haddressFrame tapes.value (Ne.symm tapes.ne)] + Β· intro i hia hiv + change valueDone.work i = workβ‚€ i + exact (hvalueFrame i hiv).trans (haddressFrame i hia) + Β· simpa [finalCfg, Entry.encode, List.append_assoc] using! hvalueOutput + +theorem rewindEntryEncodeTM_hoareTime_frame_internal + (tapes : EntryEncodeTapes n) (entry : Entry) + (addressHeadBound valueHeadBound : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryContent entry.1.bits) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (haddressHead : 1 ≀ (workβ‚€ tapes.address).head ∧ + (workβ‚€ tapes.address).head ≀ addressHeadBound) + (hvalue : (workβ‚€ tapes.value).HasBinaryContent entry.2.bits) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (hvalueHead : 1 ≀ (workβ‚€ tapes.value).head ∧ + (workβ‚€ tapes.value).head ≀ valueHeadBound) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindEntryEncodeTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.address).HasBinarySuffix [] ∧ + (work tapes.address).cells = (workβ‚€ tapes.address).cells ∧ + (work tapes.address).head = entry.1.bits.length + 1 ∧ + (work tapes.value).HasBinarySuffix [] ∧ + (work tapes.value).cells = (workβ‚€ tapes.value).cells ∧ + (work tapes.value).head = entry.2.bits.length + 1 ∧ + (βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (rewindEntryEncodeTime entry addressHeadBound valueHeadBound) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hinitialParked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + by_cases hia : i = tapes.address + Β· subst i + exact ⟨haddressHead.1, haddress.cells_ne_start⟩ + Β· by_cases hiv : i = tapes.value + Β· subst i + exact ⟨hvalueHead.1, hvalue.cells_ne_start⟩ + Β· exact hother i hia hiv + have haddressContract := rewindWordEncodeTM_hoareTime_frame tapes.address + entry.1 addressHeadBound emitted inpβ‚€ workβ‚€ outβ‚€ haddress haddressStart + haddressHead hinput (fun i _ => hinitialParked i) houtput + obtain ⟨addressDone, addressTime, haddressTime, haddressReach, + haddressHalt, haddressInput, haddressSuffix, haddressCells, + haddressHeadDone, haddressFrame, haddressOutput⟩ := + haddressContract inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have haddressWorkParked : βˆ€ i, TM.Parked (addressDone.work i) := by + intro i + by_cases hi : i = tapes.address + Β· subst i + exact parked_of_binarySuffix haddressSuffix + Β· rw [haddressFrame i hi] + exact hinitialParked i + have haddressOutputParked : TM.Parked addressDone.output := + parked_of_binaryPrefix haddressOutput + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + (haddressInput β–Έ hinput.read_ne_start) + (fun i => (haddressWorkParked i).read_ne_start) + haddressOutputParked.read_ne_start + have hvalueDone : + (addressDone.work tapes.value).HasBinaryContent entry.2.bits := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + exact hvalue + have hvalueStartDone : + (addressDone.work tapes.value).cells 0 = Ξ“.start := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + exact hvalueStart + have hvalueHeadDone : + 1 ≀ (addressDone.work tapes.value).head ∧ + (addressDone.work tapes.value).head ≀ valueHeadBound := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + exact hvalueHead + have hvalueContract := rewindWordEncodeTM_hoareTime_frame tapes.value + entry.2 valueHeadBound (emitted ++ WordCode.encode entry.1) + addressDone.input addressDone.work addressDone.output hvalueDone + hvalueStartDone hvalueHeadDone (haddressInput β–Έ hinput) + (fun i _ => haddressWorkParked i) haddressOutput + obtain ⟨valueDone, valueTime, hvalueTime, hvalueReach, hvalueHalt, + hvalueInput, hvalueSuffix, hvalueCells, hvalueHeadFinal, + hvalueFrame, hvalueOutput⟩ := + hvalueContract addressDone.input addressDone.work addressDone.output + ⟨rfl, rfl, rfl⟩ + have hvalueReach' : (rewindWordEncodeTM tapes.value).reachesIn valueTime + { state := (rewindWordEncodeTM tapes.value).qstart + input := TM.transitionInput addressDone.input + work := fun i => TM.transitionTape (addressDone.work i) + output := TM.transitionTape addressDone.output } + valueDone := by + simpa [hinputTransition, hworkTransition, houtputTransition] using + hvalueReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindWordEncodeTM tapes.address) (rewindWordEncodeTM tapes.value) + haddressReach haddressHalt hvalueReach' + let finalCfg := TM.phase2Wrap (rewindWordEncodeTM tapes.address) + (rewindWordEncodeTM tapes.value) valueDone + refine ⟨finalCfg, addressTime + 1 + valueTime, ?_, hreach, ?_, ?_⟩ + Β· unfold rewindEntryEncodeTime + omega + Β· change (rewindEntryEncodeTM tapes).halted finalCfg + unfold rewindEntryEncodeTM + rw [TM.phase2Wrap_halted_iff] + exact hvalueHalt + Β· refine ⟨?_, ?_, ?_, ?_, hvalueSuffix, ?_, hvalueHeadFinal, ?_, ?_⟩ + Β· simpa [finalCfg] using! hvalueInput.trans haddressInput + Β· change (valueDone.work tapes.address).HasBinarySuffix [] + rw [hvalueFrame tapes.address tapes.ne] + exact haddressSuffix + Β· change (valueDone.work tapes.address).cells = + (workβ‚€ tapes.address).cells + rw [hvalueFrame tapes.address tapes.ne] + exact haddressCells + Β· change (valueDone.work tapes.address).head = entry.1.bits.length + 1 + rw [hvalueFrame tapes.address tapes.ne] + exact haddressHeadDone + Β· change (valueDone.work tapes.value).cells = (workβ‚€ tapes.value).cells + rw [hvalueCells, haddressFrame tapes.value (Ne.symm tapes.ne)] + Β· intro i hia hiv + change valueDone.work i = workβ‚€ i + exact (hvalueFrame i hiv).trans (haddressFrame i hia) + Β· simpa [finalCfg, Entry.encode, List.append_assoc] using! hvalueOutput + +theorem rewindEntryEncodeRestoreTM_hoareTime_frame_internal + (tapes : EntryEncodeTapes n) (entry : Entry) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (haddress : (workβ‚€ tapes.address).HasBinaryNat entry.1) + (hvalue : (workβ‚€ tapes.value).HasBinaryNat entry.2) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindEntryEncodeRestoreTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (rewindEntryEncodeRestoreTime entry) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have haddressHead : 1 ≀ (workβ‚€ tapes.address).head ∧ + (workβ‚€ tapes.address).head ≀ 1 := by + rw [haddress.2.1] + exact ⟨le_rfl, le_rfl⟩ + have hvalueHead : 1 ≀ (workβ‚€ tapes.value).head ∧ + (workβ‚€ tapes.value).head ≀ 1 := by + rw [hvalue.2.1] + exact ⟨le_rfl, le_rfl⟩ + have hencode := rewindEntryEncodeTM_hoareTime_frame_internal tapes entry + 1 1 emitted inpβ‚€ workβ‚€ outβ‚€ haddress.2.hasBinaryContent haddress.1 + haddressHead hvalue.2.hasBinaryContent hvalue.1 hvalueHead hinput + hother houtput + obtain ⟨encoded, encodeTime, hencodeTime, hencodeReach, hencodeHalt, + hencodedInput, haddressSuffix, haddressCells, haddressEncodedHead, + hvalueSuffix, hvalueCells, hvalueEncodedHead, hencodedFrame, + hencodedOutput⟩ := hencode inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have haddressCells' : (encoded.work tapes.address).cells = + (workβ‚€ tapes.address).cells := by + simpa using haddressCells + have haddressEncodedHead' : (encoded.work tapes.address).head = + entry.1.bits.length + 1 := by + simpa using haddressEncodedHead + have hvalueCells' : (encoded.work tapes.value).cells = + (workβ‚€ tapes.value).cells := by + simpa using hvalueCells + have hvalueEncodedHead' : (encoded.work tapes.value).head = + entry.2.bits.length + 1 := by + simpa using hvalueEncodedHead + have hencodedInputParked : TM.Parked encoded.input := by + rw [hencodedInput] + exact hinput + have hencodedOutputParked : TM.Parked encoded.output := + parked_of_binaryPrefix hencodedOutput + have hencodedWorkParked : βˆ€ i, TM.Parked (encoded.work i) := by + intro i + by_cases hia : i = tapes.address + Β· subst i + exact parked_of_binarySuffix haddressSuffix + Β· by_cases hiv : i = tapes.value + Β· subst i + exact parked_of_binarySuffix hvalueSuffix + Β· rw [hencodedFrame i hia hiv] + exact hother i hia hiv + have haddressContent : + (encoded.work tapes.address).HasBinaryContent entry.1.bits := by + simpa only [Tape.HasBinaryContent, haddressCells'] using + haddress.2.hasBinaryContent + have haddressStart : + (encoded.work tapes.address).cells 0 = Ξ“.start := by + rw [haddressCells'] + exact haddress.1 + have haddressRewind := TM.rewindBinaryWorkTM_hoareTime_frame + tapes.address entry.1.bits (entry.1.bits.length + 1) + encoded.input encoded.work encoded.output haddressContent haddressStart + ⟨by rw [haddressEncodedHead']; omega, + by rw [haddressEncodedHead']⟩ + hencodedInputParked (fun i _ => hencodedWorkParked i) + hencodedOutputParked + obtain ⟨addressRewound, addressTime, haddressTime, haddressReach, + haddressHalt, haddressInput, haddressRestoredCanonical, + haddressFrame, haddressOutput⟩ := + haddressRewind encoded.input encoded.work encoded.output ⟨rfl, rfl, rfl⟩ + have haddressCanonical : workβ‚€ tapes.address = + (Tape.init (entry.1.bits.map Ξ“.ofBool)).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString haddress.2 haddress.1 + have haddressRestored : addressRewound.work tapes.address = + workβ‚€ tapes.address := + haddressRestoredCanonical.trans haddressCanonical.symm + have hvalueContent : + (addressRewound.work tapes.value).HasBinaryContent entry.2.bits := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + simpa only [Tape.HasBinaryContent, hvalueCells'] using + hvalue.2.hasBinaryContent + have hvalueStart : + (addressRewound.work tapes.value).cells 0 = Ξ“.start := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne), hvalueCells'] + exact hvalue.1 + have hvalueHead' : (addressRewound.work tapes.value).head = + entry.2.bits.length + 1 := by + rw [haddressFrame tapes.value (Ne.symm tapes.ne)] + exact hvalueEncodedHead' + have haddressInputParked : TM.Parked addressRewound.input := by + rw [haddressInput] + exact hencodedInputParked + have haddressOutputParked : TM.Parked addressRewound.output := by + rw [haddressOutput] + exact hencodedOutputParked + have haddressWorkParked : βˆ€ i, TM.Parked (addressRewound.work i) := by + intro i + by_cases hia : i = tapes.address + Β· subst i + rw [haddressRestored] + exact parked_of_binaryNat haddress + Β· rw [haddressFrame i hia] + exact hencodedWorkParked i + have hvalueRewind := TM.rewindBinaryWorkTM_hoareTime_frame + tapes.value entry.2.bits (entry.2.bits.length + 1) + addressRewound.input addressRewound.work addressRewound.output + hvalueContent hvalueStart + ⟨by rw [hvalueHead']; omega, by rw [hvalueHead']⟩ + haddressInputParked (fun i _ => haddressWorkParked i) + haddressOutputParked + obtain ⟨restored, valueTime, hvalueTime, hvalueReach, hvalueHalt, + hvalueInput, hvalueRestoredCanonical, hvalueFrame, + hvalueOutput⟩ := + hvalueRewind addressRewound.input addressRewound.work + addressRewound.output ⟨rfl, rfl, rfl⟩ + have hvalueCanonical : workβ‚€ tapes.value = + (Tape.init (entry.2.bits.map Ξ“.ofBool)).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString hvalue.2 hvalue.1 + have hvalueRestored : restored.work tapes.value = workβ‚€ tapes.value := + hvalueRestoredCanonical.trans hvalueCanonical.symm + have hrestoredWork : restored.work = workβ‚€ := by + funext i + by_cases hiv : i = tapes.value + Β· subst i + exact hvalueRestored + Β· rw [hvalueFrame i hiv] + by_cases hia : i = tapes.address + Β· subst i + exact haddressRestored + Β· exact (haddressFrame i hia).trans (hencodedFrame i hia hiv) + obtain ⟨haddressInputTransition, haddressWorkTransition, + haddressOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + haddressInputParked.read_ne_start + (fun i => (haddressWorkParked i).read_ne_start) + haddressOutputParked.read_ne_start + have hvalueReach' : (TM.rewindWorkTM tapes.value).reachesIn valueTime + { state := (TM.rewindWorkTM tapes.value).qstart + input := TM.transitionInput addressRewound.input + work := fun i => TM.transitionTape (addressRewound.work i) + output := TM.transitionTape addressRewound.output } + restored := by + simpa only [haddressInputTransition, haddressWorkTransition, + haddressOutputTransition] using hvalueReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (TM.rewindWorkTM tapes.address) (TM.rewindWorkTM tapes.value) + haddressReach haddressHalt hvalueReach' + let tailFinal := TM.phase2Wrap (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value) restored + have htailHalt : + (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)).halted tailFinal := by + rw [TM.phase2Wrap_halted_iff] + exact hvalueHalt + obtain ⟨hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hencodedInputParked.read_ne_start + (fun i => (hencodedWorkParked i).read_ne_start) + hencodedOutputParked.read_ne_start + have htailReach' : + (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)).reachesIn + (addressTime + 1 + valueTime) + { state := (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)).qstart + input := TM.transitionInput encoded.input + work := fun i => TM.transitionTape (encoded.work i) + output := TM.transitionTape encoded.output } + tailFinal := by + simpa only [hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeTM tapes) + (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)) + hencodeReach hencodeHalt htailReach' + let finalCfg := TM.phase2Wrap (rewindEntryEncodeTM tapes) + (TM.seqTM (TM.rewindWorkTM tapes.address) + (TM.rewindWorkTM tapes.value)) tailFinal + refine ⟨finalCfg, encodeTime + 1 + (addressTime + 1 + valueTime), + ?_, hreach, ?_, ?_⟩ + Β· unfold rewindEntryEncodeRestoreTime + omega + Β· exact (TM.phase2Wrap_halted_iff (rewindEntryEncodeTM tapes) + (TM.seqTM (TM.rewindWorkTM tapes.address) (TM.rewindWorkTM tapes.value)) + tailFinal).mpr htailHalt + Β· refine ⟨?_, hrestoredWork, ?_⟩ + Β· change restored.input = inpβ‚€ + exact hvalueInput.trans (haddressInput.trans hencodedInput) + Β· change restored.output.HasBinaryPrefix + (emitted ++ Entry.encode entry) + rw [hvalueOutput, haddressOutput] + exact hencodedOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup.lean new file mode 100644 index 0000000000..21f3693944 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Source + +/-! +# Sparse register lookup +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- A bounded lookup advances the encoded source cursor without modifying its +cells. -/ +theorem entryLookupTM_source_readOnly {n : β„•} (tapes : EntryScanTapes n) : + (entryLookupTM tapes).WorkReadOnly tapes.entry.source := + entryScanTM_source_readOnly_internal tapes + +/-- Scan a runtime-sized encoded sparse store and leave exactly +`RegisterStore.read store address` on the decoded-value tape. -/ +theorem entryLookupTM_hoareTime_frame {n : β„•} + (tapes : EntryScanTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits initialWork initialWork) + (hcount : (initialWork tapes.count).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupTime tapes address store) := + entryLookupTM_hoareTime_frame_internal tapes store address initialWork + inpβ‚€ outβ‚€ hready hcount hinput houtput + +/-- Framed lookup with explicit preservation of the complete encoded source +cell function. -/ +theorem entryLookupTM_hoareTime_frame_source {n : β„•} + (tapes : EntryScanTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits initialWork initialWork) + (hcount : (initialWork tapes.count).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupResult tapes store address initialWork work ∧ + (work tapes.entry.source).cells = + (initialWork tapes.entry.source).cells ∧ + (βˆ€ i, (work i).head ≀ (initialWork i).head + + entryLookupTime tapes address store) ∧ + out = outβ‚€) + (entryLookupTime tapes address store) := by + have hlookup := entryLookupTM_hoareTime_frame tapes store address + initialWork inpβ‚€ outβ‚€ hready hcount hinput houtput + intro inp work out hpre + obtain ⟨final, time, htime, hreach, hhalt, hinp, hresult, hout⟩ := + hlookup inp work out hpre + have hstartWork : work = initialWork := hpre.2.1 + have hnostart : βˆ€ j, 1 ≀ j β†’ + (work tapes.entry.source).cells j β‰  Ξ“.start := by + rw [hstartWork] + exact hready.source.2.2.2 + have hcells := (entryLookupTM_source_readOnly tapes).cells_eq_of_reachesIn + hreach hnostart + have hheads := TM.head_le_start_add_of_reachesIn + (entryLookupTM tapes) hreach + have hworkHeads : βˆ€ i, (final.work i).head ≀ + (initialWork i).head + entryLookupTime tapes address store := by + intro i + have hi := hheads.2.2 i + rw [hstartWork] at hi + dsimp only at hi + omega + exact ⟨final, time, htime, hreach, hhalt, hinp, hresult, + hcells.trans (congrArg (fun w => (w tapes.entry.source).cells) + hstartWork), hworkHeads, hout⟩ + +/-- Sparse lookup preserves one-way output safety. -/ +theorem entryLookupTM_isTransducer {n : β„•} (tapes : EntryScanTapes n) : + (entryLookupTM tapes).IsTransducer := + entryScanTM_isTransducer tapes + +/-- Sparse lookup inherits the scanner's all-prefix auxiliary-space envelope. -/ +theorem entryLookupTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryScanTapes n) (store : Store) (address : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryLookupTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryLookupTM tapes).reachesIn time start current) + (htime : time ≀ entryLookupTime tapes address store) : + current.WithinAuxSpace inputLength + (initialSpace + entryLookupTime tapes address store) := + entryScanTM_prefix_withinAuxSpace tapes store address.bits inputLength + initialSpace time start current hinitial hreach htime + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Defs.lean new file mode 100644 index 0000000000..48c2290bbe --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Defs.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs + +/-! +# Sparse register lookup β€” definitions + +The bounded scanner is already the concrete lookup machine. This module names +its semantic endpoint in terms of the pure sparse-store `read` operation. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- A completed lookup leaves the pure sparse-store value on the decoded-value +tape and preserves the scanner's complete external frame. -/ +structure EntryLookupResult {n : β„•} (tapes : EntryScanTapes n) + (store : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + value : (finalWork tapes.entry.value).HasBinaryPrefix + (RegisterStore.read store address).bits + valueStart : (finalWork tapes.entry.value).cells 0 = Ξ“.start + /-- The runtime counter records the unscanned suffix beginning at a hit, or + zero after an unsuccessful scan. -/ + count : βˆƒ remaining, remaining ≀ store.length ∧ + (finalWork tapes.count).HasBinaryNat remaining + parked : βˆ€ i, TM.Parked (finalWork i) + frame : EntryScanFrame tapes initialWork finalWork + /-- The complete scanner endpoint is retained so a caller can restore every + owned cursor and scratch tape without re-proving the scan decomposition. -/ + outcome : EntryScanOutcome tapes store address.bits initialWork finalWork + +/-- The concrete sparse lookup is the fixed runtime-count entry scanner. -/ +abbrev entryLookupTM {n : β„•} (tapes : EntryScanTapes n) : TM n := + entryScanTM tapes + +/-- Lookup inherits the scanner's explicit runtime bound. -/ +abbrev entryLookupTime {n : β„•} (tapes : EntryScanTapes n) + (address : β„•) (store : Store) : β„• := + entryScanTime tapes address.bits store + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Internal.lean new file mode 100644 index 0000000000..bc8b50a3a4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookup/Internal.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan +public import Mathlib.Data.Nat.Bitwise + +/-! +# Sparse register lookup β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem nat_eq_of_bits_eq {a b : β„•} (h : a.bits = b.bits) : a = b := by + apply Nat.eq_of_testBit_eq + intro i + rw [Nat.testBit_eq_inth, Nat.testBit_eq_inth, h] + +private theorem read_eq_matched + (scanned : Store) (matched : Entry) (rest : Store) (address : β„•) + (hmiss : βˆ€ prior ∈ scanned, prior.1.bits β‰  address.bits) + (hmatch : matched.1.bits = address.bits) : + RegisterStore.read (scanned ++ matched :: rest) address = matched.2 := by + induction scanned with + | nil => + simp [RegisterStore.read, nat_eq_of_bits_eq hmatch] + | cons prior scanned ih => + have hprior : prior.1 β‰  address := by + intro heq + exact hmiss prior (by simp) (congrArg Nat.bits heq) + simp only [List.cons_append, RegisterStore.read] + rw [ite_eq_right (Ne.symm hprior)] + apply ih + intro candidate hcandidate + exact hmiss candidate (by simp [hcandidate]) + +private theorem read_eq_zero + (store : Store) (address : β„•) + (hmiss : βˆ€ entry ∈ store, entry.1.bits β‰  address.bits) : + RegisterStore.read store address = 0 := by + induction store with + | nil => rfl + | cons entry rest ih => + have hentry : entry.1 β‰  address := by + intro heq + exact hmiss entry (by simp) (congrArg Nat.bits heq) + simp only [RegisterStore.read] + rw [ite_eq_right (Ne.symm hentry)] + exact ih (fun candidate hcandidate => + hmiss candidate (by simp [hcandidate])) + +private theorem outcome_to_lookup + (tapes : EntryScanTapes n) (store : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (houtcome : + EntryScanOutcome tapes store address.bits initialWork finalWork) : + EntryLookupResult tapes store address initialWork finalWork := by + have houtcome' := houtcome + rcases houtcome with hfound | hmiss + Β· rcases hfound with ⟨scanned, matched, rest, _, hfound⟩ + have hread : RegisterStore.read store address = matched.2 := by + rw [hfound.store_eq] + exact read_eq_matched scanned matched rest address hfound.prefixMiss + hfound.hit.addressEq + exact ⟨by simpa [hread] using hfound.hit.value, + hfound.hit.valueStart, ⟨rest.length + 1, by + rw [hfound.store_eq] + simp, hfound.count⟩, hfound.hit.parked, hfound.frame, houtcome'⟩ + Β· rcases hmiss with ⟨_, hmiss⟩ + have hread : RegisterStore.read store address = 0 := + read_eq_zero store address hmiss.notFound + exact ⟨by simpa [hread] using hmiss.ready.value, + hmiss.ready.valueStart, ⟨0, Nat.zero_le _, hmiss.count⟩, + hmiss.ready.parked, hmiss.frame, houtcome'⟩ + +theorem entryLookupTM_hoareTime_frame_internal + (tapes : EntryScanTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits initialWork initialWork) + (hcount : (initialWork tapes.count).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupTime tapes address store) := by + exact (entryScanTM_hoareTime_frame tapes store address.bits initialWork + inpβ‚€ outβ‚€ hready hcount hinput houtput).consequence + (fun _ _ _ h => h) + (fun _ _ _ h => ⟨h.1, outcome_to_lookup tapes store address + initialWork _ h.2.1, h.2.2⟩) + le_rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookupRestore.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookupRestore.lean new file mode 100644 index 0000000000..115405e43c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryLookupRestore.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal + +/-! +# Reusable sparse-register operand lookup + +This module exposes one complete sparse-register read as a reusable TM +subroutine. It loads a canonical query, scans the encoded store, copies the +semantic value out, resets every scanner-owned tape, rewinds the read-only +source, restores the runtime entry count, and returns to the same scanner ABI. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- One loaded lookup returns the scanner to its blank-query boundary, places +exactly `RegisterStore.read store address` on the destination tape, and +preserves the complete external frame. -/ +theorem entryLookupLoadedTM_hoareTime_frame {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupRestoreReady tapes store address initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupLoadedTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupLoadedTime tapes store address) := + entryLookupLoaded_hoareTime_internal tapes store address initialWork + inpβ‚€ outβ‚€ hready hinput houtput + +/-- A reusable lookup through a positive-tag mutable overlay returns either +the decoded tag or the corresponding immutable public-input register. -/ +theorem denseOverlayLookupTM_hoareTime_frame {n : β„•} + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (hvalid : DenseOverlay.Valid overlay) + (hready : EntryLookupRestoreReady tapes overlay address initialWork) + (houtput : TM.Parked outβ‚€) : + (denseOverlayLookupTM tapes).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseOverlayLookupResult tapes input overlay address initialWork work ∧ + out = outβ‚€) + (denseOverlayLookupTime tapes input.length overlay address) := + denseOverlayLookupTM_hoareTime_internal tapes input overlay address + initialWork outβ‚€ hvalid hready houtput + +/-- A fixed-address dense-overlay lookup synthesizes and clears its query, +while returning the decoded register value at the reusable scanner boundary. -/ +theorem denseOverlayLookupStaticTM_hoareTime_frame {n : β„•} + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (hvalid : DenseOverlay.Valid overlay) + (hready : EntryLookupStaticReady tapes overlay initialWork) + (houtput : TM.Parked outβ‚€) : + (denseOverlayLookupStaticTM tapes address).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseOverlayLookupStaticResult tapes input overlay address initialWork + work ∧ out = outβ‚€) + (denseOverlayLookupStaticTime tapes input.length overlay address) := + denseOverlayLookupStaticTM_hoareTime_internal tapes input overlay address + initialWork outβ‚€ hvalid hready houtput + +/-- Reusable sparse-register lookup never moves the output head left. -/ +theorem entryLookupLoadedTM_isTransducer {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + (entryLookupLoadedTM tapes).IsTransducer := by + exact + (TM.binaryCopyIntoTM_isTransducer tapes.querySource + tapes.scan.entry.query tapes.copyScratch).seqTM + ((entryLookupTM_isTransducer tapes.scan).seqTM + ((TM.rewindWorkTM_isTransducer tapes.scan.entry.value).seqTM + ((TM.binaryCopyIntoTM_isTransducer tapes.scan.entry.value + tapes.destination tapes.copyScratch).seqTM + ((TM.resetBinaryWorkManyTM_isTransducer + (entryLookupResetTargets tapes)).seqTM + ((TM.rewindWorkTM_isTransducer tapes.scan.entry.source).seqTM + (TM.binaryCopyIntoTM_isTransducer tapes.countSource + tapes.scan.count tapes.copyScratch)))))) + +/-- Every prefix of a loaded lookup stays within its initial auxiliary space +plus the advertised total running-time bound. -/ +theorem entryLookupLoadedTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryLookupLoadedTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryLookupLoadedTM tapes).reachesIn time start current) + (htime : time ≀ entryLookupLoadedTime tapes store address) : + current.WithinAuxSpace inputLength + (initialSpace + entryLookupLoadedTime tapes store address) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- A fixed-address lookup synthesizes its query from zero, returns the +scanner to its reusable boundary, places the semantic register value in the +destination, and clears the temporary query source. -/ +theorem entryLookupStaticTM_hoareTime_frame {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupStaticReady tapes store initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupStaticTM tapes address).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupStaticTime tapes store address) := + entryLookupStatic_hoareTime_internal tapes store address initialWork + inpβ‚€ outβ‚€ hready hinput houtput + +/-- Fixed-address lookup never moves the output head left. -/ +theorem entryLookupStaticTM_isTransducer {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + (entryLookupStaticTM tapes address).IsTransducer := by + exact + (TM.binaryAddConstTM_isTransducer tapes.querySource address).seqTM + ((entryLookupLoadedTM_isTransducer tapes).seqTM + (TM.resetBinaryWorkTM_isTransducer tapes.querySource)) + +/-- Every fixed-address lookup prefix stays within its initial auxiliary space +plus the advertised total running-time bound. -/ +theorem entryLookupStaticTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryLookupStaticTM tapes address).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryLookupStaticTM tapes address).reachesIn time start current) + (htime : time ≀ entryLookupStaticTime tapes store address) : + current.WithinAuxSpace inputLength + (initialSpace + entryLookupStaticTime tapes store address) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch.lean new file mode 100644 index 0000000000..9a29ab0a7e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Internal + +/-! +# RAM sparse-entry matching + +This module exposes the exact framed semantics of the concrete decode-and-match +unit used by a bounded sparse register-store scan. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Decode one canonical sparse entry and compare its address with a preserved +canonical query, leaving the next entry under the source head. -/ +theorem entryMatchTM_reachesIn_frame {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hquery : (workβ‚€ tapes.query).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ tapes.query).cells 0 = Ξ“.start) + (hresult : (workβ‚€ tapes.result).HasBinaryPrefix []) + (hresultStart : (workβ‚€ tapes.result).cells 0 = Ξ“.start) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c' t, + t ≀ entryMatchTime entry queryBits ∧ + (entryMatchTM tapes).reachesIn t + { state := (entryMatchTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryMatchTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryContent entry.1.bits ∧ + 1 ≀ (c'.work tapes.address).head ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) ∧ + (c'.work tapes.addressCounter).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressWidth).HasBinaryNat 0 ∧ + (c'.work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) ∧ + (c'.work tapes.valueCounter).cells 0 = Ξ“.start ∧ + (c'.work tapes.valueWidth).HasBinaryNat 0 ∧ + (c'.work tapes.query).HasBinaryContent queryBits ∧ + 1 ≀ (c'.work tapes.query).head ∧ + (c'.work tapes.query).cells 0 = Ξ“.start ∧ + (c'.work tapes.result).HasBinaryPrefix + [decide (entry.1.bits = queryBits)] ∧ + (c'.work tapes.result).cells 0 = Ξ“.start ∧ + (βˆ€ i, TM.Parked (c'.work i)) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.addressWidth β†’ + i β‰  tapes.valueCounter β†’ i β‰  tapes.valueWidth β†’ + i β‰  tapes.query β†’ i β‰  tapes.result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + entryMatchTM_reachesIn_frame_internal tapes entry rest queryBits inpβ‚€ + workβ‚€ outβ‚€ hsource haddress hvalue haddressStart hvalueStart + haddressCounter haddressWidth hvalueCounter hvalueWidth hquery + hqueryStart hresult hresultStart hinput hwork houtput + +/-- Decode and compare one canonical sparse entry, then rewind the one-bit +result to cell one so that the enclosing bounded scan can branch on it. -/ +theorem entryMatchReadTM_reachesIn_frame {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hquery : (workβ‚€ tapes.query).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ tapes.query).cells 0 = Ξ“.start) + (hresult : (workβ‚€ tapes.result).HasBinaryPrefix []) + (hresultStart : (workβ‚€ tapes.result).cells 0 = Ξ“.start) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c' t, + t ≀ entryMatchReadTime entry queryBits ∧ + (entryMatchReadTM tapes).reachesIn t + { state := (entryMatchReadTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryMatchReadTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + ReadableEntryMatch tapes entry rest queryBits workβ‚€ c'.work ∧ + c'.output = outβ‚€ := + entryMatchReadTM_reachesIn_frame_internal tapes entry rest queryBits inpβ‚€ + workβ‚€ outβ‚€ hsource haddress hvalue haddressStart hvalueStart + haddressCounter haddressWidth hvalueCounter hvalueWidth hquery + hqueryStart hresult hresultStart hinput hwork houtput + +/-- A readable entry-match endpoint exposes its Boolean answer directly under +the result-tape head. -/ +theorem ReadableEntryMatch.result_read {n : β„•} {tapes : EntryMatchTapes n} + {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : ReadableEntryMatch tapes entry rest queryBits initialWork finalWork) : + (finalWork tapes.result).read = + Ξ“.ofBool (decide (entry.1.bits = queryBits)) := + h.result.hasBinarySuffix.read_cons + +/-- The result head reads one exactly when the decoded address equals the +query. -/ +theorem ReadableEntryMatch.result_read_eq_one_iff {n : β„•} + {tapes : EntryMatchTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : ReadableEntryMatch tapes entry rest queryBits initialWork finalWork) : + (finalWork tapes.result).read = Ξ“.one ↔ entry.1.bits = queryBits := by + by_cases heq : entry.1.bits = queryBits <;> + simp [h.result_read, heq, Ξ“.ofBool] + +/-- Exact closed form for the readable unary-marker entry-match runtime. -/ +theorem entryMatchReadTime_eq (entry : Entry) (queryBits : List Bool) : + entryMatchReadTime entry queryBits = + 4 * entry.1.bits.length + 3 * entry.2.bits.length + + max entry.1.bits.length queryBits.length + 18 := + entryMatchReadTime_eq_internal entry queryBits + +/-- One readable entry match is linear in the serialized entry and query +widths. -/ +theorem entryMatchReadTime_le_linear (entry : Entry) + (queryBits : List Bool) : + entryMatchReadTime entry queryBits ≀ + 5 * entry.1.bits.length + 3 * entry.2.bits.length + + queryBits.length + 18 := + entryMatchReadTime_le_linear_internal entry queryBits + +/-- Coarse all-prefix auxiliary-space envelope for one entry match. -/ +theorem entryMatchTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (queryBits : List Bool) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryMatchTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryMatchTM tapes).reachesIn time start current) + (htime : time ≀ entryMatchTime entry queryBits) : + current.WithinAuxSpace inputLength + (initialSpace + entryMatchTime entry queryBits) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Entry matching preserves one-way output safety. -/ +theorem entryMatchTM_isTransducer {n : β„•} (tapes : EntryMatchTapes n) : + (entryMatchTM tapes).IsTransducer := by + unfold entryMatchTM + exact (entryDecodeLinearTM_isTransducer tapes.decode).seqTM + (decodedAddressEqTM_isTransducer tapes.address tapes.query tapes.result) + +/-- Readable entry matching preserves one-way output safety. -/ +theorem entryMatchReadTM_isTransducer {n : β„•} (tapes : EntryMatchTapes n) : + (entryMatchReadTM tapes).IsTransducer := by + unfold entryMatchReadTM + exact (entryMatchTM_isTransducer tapes).seqTM + (TM.rewindWorkTM_isTransducer tapes.result) + +/-- Coarse all-prefix auxiliary-space envelope for readable entry matching. -/ +theorem entryMatchReadTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (queryBits : List Bool) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryMatchReadTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryMatchReadTM tapes).reachesIn time start current) + (htime : time ≀ entryMatchReadTime entry queryBits) : + current.WithinAuxSpace inputLength + (initialSpace + entryMatchReadTime entry queryBits) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Defs.lean new file mode 100644 index 0000000000..112e14e795 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Defs.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs + +/-! +# RAM sparse-entry matching β€” definitions + +`entryMatchTM` is the concrete unit consumed by a bounded sparse-store scan. +It decodes one address/value entry and compares the decoded address with a +preserved canonical query. The result is appended to a dedicated work tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Nine pairwise-distinct work tapes used to decode and match one sparse +register-store entry. -/ +structure EntryMatchTapes (n : β„•) where + /-- Tape assignment in the order source, address, value, address counter, + address width, value counter, value width, query, and result. -/ + idx : Fin 9 β†’ Fin n + injective : Function.Injective idx + +namespace EntryMatchTapes + +/-- The seven decoder tapes contained in an entry-matching assignment. -/ +def decode {n : β„•} (tapes : EntryMatchTapes n) : EntryDecodeTapes n where + idx := fun i => tapes.idx ⟨i, by omega⟩ + injective := by + intro i j h + have h' : (⟨i, by omega⟩ : Fin 9) = ⟨j, by omega⟩ := + tapes.injective h + apply Fin.ext + exact congrArg (fun k : Fin 9 => k.val) h' + +/-- Encoded entry-stream source tape. -/ +def source {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 0 +/-- Decoded address scratch tape. -/ +def address {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 1 +/-- Decoded value scratch tape. -/ +def value {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 2 +/-- Binary loop counter used while decoding the address. -/ +def addressCounter {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 3 +/-- Preserved address payload-width tape. -/ +def addressWidth {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 4 +/-- Binary loop counter used while decoding the value. -/ +def valueCounter {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 5 +/-- Preserved value payload-width tape. -/ +def valueWidth {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 6 +/-- Canonical query-address tape. -/ +def query {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 7 +/-- Boolean match-result tape. -/ +def result {n : β„•} (tapes : EntryMatchTapes n) : Fin n := tapes.idx 8 + +theorem ne {n : β„•} (tapes : EntryMatchTapes n) {i j : Fin 9} (h : i β‰  j) : + tapes.idx i β‰  tapes.idx j := + fun hij => h (tapes.injective hij) + +theorem binaryEqDistinct {n : β„•} (tapes : EntryMatchTapes n) : + TM.BinaryEqDistinct tapes.address tapes.query tapes.result := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), tapes.ne (by decide)⟩ + +@[simp] theorem decode_source {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.source = tapes.source := rfl + +@[simp] theorem decode_address {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.address = tapes.address := rfl + +@[simp] theorem decode_value {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.value = tapes.value := rfl + +@[simp] theorem decode_addressCounter {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.addressCounter = tapes.addressCounter := rfl + +@[simp] theorem decode_addressWidth {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.addressWidth = tapes.addressWidth := rfl + +@[simp] theorem decode_valueCounter {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.valueCounter = tapes.valueCounter := rfl + +@[simp] theorem decode_valueWidth {n : β„•} (tapes : EntryMatchTapes n) : + tapes.decode.valueWidth = tapes.valueWidth := rfl + +end EntryMatchTapes + +/-- Decode one sparse entry with unary markers and compare its address with the +preserved query. -/ +def entryMatchTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.seqTM (entryDecodeLinearTM tapes.decode) + (decodedAddressEqTM tapes.address tapes.query tapes.result) + +/-- Runtime bound for decoding and matching one sparse entry, including the +composition seam. -/ +def entryMatchTime (entry : Entry) (queryBits : List Bool) : β„• := + entryDecodeLinearTime entry.1 entry.2 + 1 + + decodedAddressEqTime entry.1.bits queryBits + +/-- Decode and compare one sparse entry, then rewind the one-bit result to its +canonical cell-one read position. -/ +def entryMatchReadTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.seqTM (entryMatchTM tapes) (TM.rewindWorkTM tapes.result) + +/-- Runtime bound for a readable one-entry match, including both composition +seams and the at-most-four-step rewind of the one-bit result. -/ +def entryMatchReadTime (entry : Entry) (queryBits : List Bool) : β„• := + entryMatchTime entry queryBits + 1 + 4 + +/-- Auditable endpoint contract for one readable sparse-entry match. The +decoded scratch remains available to a hit branch or can be cleared by a miss +branch; the result is parked at cell one for direct controller inspection. -/ +structure ReadableEntryMatch {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (rest queryBits : List Bool) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + source : (finalWork tapes.source).HasBinarySuffix rest + address : (finalWork tapes.address).HasBinaryContent entry.1.bits + addressStart : (finalWork tapes.address).cells 0 = Ξ“.start + value : (finalWork tapes.value).HasBinaryPrefix entry.2.bits + valueStart : (finalWork tapes.value).cells 0 = Ξ“.start + addressCounter : (finalWork tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) + addressCounterStart : + (finalWork tapes.addressCounter).cells 0 = Ξ“.start + addressWidth : (finalWork tapes.addressWidth).HasBinaryNat 0 + valueCounter : (finalWork tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) + valueCounterStart : (finalWork tapes.valueCounter).cells 0 = Ξ“.start + valueWidth : (finalWork tapes.valueWidth).HasBinaryNat 0 + query : (finalWork tapes.query).HasBinaryContent queryBits + queryStart : (finalWork tapes.query).cells 0 = Ξ“.start + result : (finalWork tapes.result).HasBinaryString + [decide (entry.1.bits = queryBits)] + resultStart : (finalWork tapes.result).cells 0 = Ξ“.start + parked : βˆ€ i, TM.Parked (finalWork i) + headBound : βˆ€ i, (finalWork i).head ≀ + (initialWork i).head + entryMatchReadTime entry queryBits + frame : βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ + i β‰  tapes.value β†’ i β‰  tapes.addressCounter β†’ + i β‰  tapes.addressWidth β†’ i β‰  tapes.valueCounter β†’ + i β‰  tapes.valueWidth β†’ i β‰  tapes.query β†’ i β‰  tapes.result β†’ + finalWork i = initialWork i + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Internal.lean new file mode 100644 index 0000000000..3d88a699dd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMatch/Internal.lean @@ -0,0 +1,533 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.AddressEq +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryDecode +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Defs + +/-! +# RAM sparse-entry matching β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +private theorem parked_of_hasBinaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + Tape.HasBinaryContent.cells_ne_start + (show t.HasBinaryContent bits from h.2)⟩ + +private theorem parked_of_hasBinarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_hasBinaryNat {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +/-- Decoding leaves every tape parked: its five modified roles have binary encodings. -/ +private theorem entryDecode_work_parked {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest : List Bool) + (initial work : Fin n β†’ Tape) + (hsource : (work tapes.source).HasBinarySuffix rest) + (haddress : (work tapes.address).HasBinaryPrefix entry.1.bits) + (hvalue : (work tapes.value).HasBinaryPrefix entry.2.bits) + (haddressCounter : (work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true)) + (hvalueCounter : (work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true)) + (hframe : βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.valueCounter β†’ work i = initial i) + (hinitial : βˆ€ i, TM.Parked (initial i)) : βˆ€ i, TM.Parked (work i) := by + intro i + by_cases his : i = tapes.source + Β· subst i + exact parked_of_hasBinarySuffix hsource + by_cases hia : i = tapes.address + Β· subst i + exact parked_of_hasBinaryPrefix haddress + by_cases hiv : i = tapes.value + Β· subst i + exact parked_of_hasBinaryPrefix hvalue + by_cases hiac : i = tapes.addressCounter + Β· subst i + exact parked_of_hasBinaryPrefix haddressCounter + by_cases hivc : i = tapes.valueCounter + Β· subst i + exact parked_of_hasBinaryPrefix hvalueCounter + rw [hframe i his hia hiv hiac hivc] + exact hinitial i + +/-- Comparing two binary tapes preserves parking of them, its result, and the outside frame. -/ +private theorem binaryComparison_work_parked {n : β„•} + (address query result : Fin n) (addressBits queryBits resultBits : List Bool) + (initial work : Fin n β†’ Tape) + (haddress : (work address).HasBinaryContent addressBits) + (haddressHead : 1 ≀ (work address).head) + (hquery : (work query).HasBinaryContent queryBits) + (hqueryHead : 1 ≀ (work query).head) + (hresult : (work result).HasBinaryPrefix resultBits) + (hframe : βˆ€ i, i β‰  address β†’ i β‰  query β†’ i β‰  result β†’ work i = initial i) + (hinitial : βˆ€ i, TM.Parked (initial i)) : βˆ€ i, TM.Parked (work i) := by + intro i + by_cases hia : i = address + Β· subst i + exact ⟨haddressHead, haddress.cells_ne_start⟩ + by_cases hiq : i = query + Β· subst i + exact ⟨hqueryHead, hquery.cells_ne_start⟩ + by_cases hir : i = result + Β· subst i + exact parked_of_hasBinaryPrefix hresult + rw [hframe i hia hiq hir] + exact hinitial i + +/-- Linear entry decoding preserves both width tapes, the query tape, and the result tape. -/ +private theorem entryDecode_preserved_roles {n : β„•} (tapes : EntryMatchTapes n) + (initial work : Fin n β†’ Tape) + (hframe : βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.valueCounter β†’ work i = initial i) : + work tapes.addressWidth = initial tapes.addressWidth ∧ + work tapes.valueWidth = initial tapes.valueWidth ∧ + work tapes.query = initial tapes.query ∧ work tapes.result = initial tapes.result := by + refine ⟨?_, ?_, ?_, ?_⟩ + Β· exact hframe tapes.addressWidth + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  0 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  2 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  3 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  5 by decide)) + Β· exact hframe tapes.valueWidth + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  0 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  2 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  3 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  5 by decide)) + Β· exact hframe tapes.query + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  0 by decide)) + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  2 by decide)) + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  3 by decide)) + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  5 by decide)) + Β· exact hframe tapes.result + (by simpa using! tapes.ne (show (8 : Fin 9) β‰  0 by decide)) + (by simpa using! tapes.ne (show (8 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (8 : Fin 9) β‰  2 by decide)) + (by simpa using! tapes.ne (show (8 : Fin 9) β‰  3 by decide)) + (by simpa using! tapes.ne (show (8 : Fin 9) β‰  5 by decide)) + +theorem entryMatchTM_reachesIn_frame_internal {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hquery : (workβ‚€ tapes.query).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ tapes.query).cells 0 = Ξ“.start) + (hresult : (workβ‚€ tapes.result).HasBinaryPrefix []) + (hresultStart : (workβ‚€ tapes.result).cells 0 = Ξ“.start) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c' t, + t ≀ entryMatchTime entry queryBits ∧ + (entryMatchTM tapes).reachesIn t + { state := (entryMatchTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryMatchTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work tapes.source).HasBinarySuffix rest ∧ + (c'.work tapes.address).HasBinaryContent entry.1.bits ∧ + 1 ≀ (c'.work tapes.address).head ∧ + (c'.work tapes.address).cells 0 = Ξ“.start ∧ + (c'.work tapes.value).HasBinaryPrefix entry.2.bits ∧ + (c'.work tapes.value).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) ∧ + (c'.work tapes.addressCounter).cells 0 = Ξ“.start ∧ + (c'.work tapes.addressWidth).HasBinaryNat 0 ∧ + (c'.work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) ∧ + (c'.work tapes.valueCounter).cells 0 = Ξ“.start ∧ + (c'.work tapes.valueWidth).HasBinaryNat 0 ∧ + (c'.work tapes.query).HasBinaryContent queryBits ∧ + 1 ≀ (c'.work tapes.query).head ∧ + (c'.work tapes.query).cells 0 = Ξ“.start ∧ + (c'.work tapes.result).HasBinaryPrefix + [decide (entry.1.bits = queryBits)] ∧ + (c'.work tapes.result).cells 0 = Ξ“.start ∧ + (βˆ€ i, TM.Parked (c'.work i)) ∧ + (βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ i β‰  tapes.value β†’ + i β‰  tapes.addressCounter β†’ i β‰  tapes.addressWidth β†’ + i β‰  tapes.valueCounter β†’ i β‰  tapes.valueWidth β†’ + i β‰  tapes.query β†’ i β‰  tapes.result β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let decodeTM := entryDecodeLinearTM tapes.decode + let compareTM := decodedAddressEqTM tapes.address tapes.query tapes.result + obtain ⟨decodeDone, hdecodeReach, hdecodeHalt, hdecodeInput, + hdecodeSource, hdecodeAddress, hdecodeAddressStart, hdecodeValue, + hdecodeValueStart, hdecodeAddressCounter, hdecodeValueCounter, + hdecodeFrame, hdecodeOutput⟩ := + entryDecodeLinearTM_reachesIn_frame tapes.decode entry rest inpβ‚€ workβ‚€ outβ‚€ + (by simpa using! hsource) (by simpa using! haddress) + (by simpa using! hvalue) (by simpa using! haddressStart) + (by simpa using! hvalueStart) + (by + simpa [Tape.HasBinaryPrefix, Tape.HasBinaryString] using! + haddressCounter.2) + haddressCounter.1 + (by + simpa [Tape.HasBinaryPrefix, Tape.HasBinaryString] using! + hvalueCounter.2) + hvalueCounter.1 hinput.read_ne_start + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + obtain ⟨hpreservedAddressWidth, hpreservedValueWidth, hpreservedQuery, hpreservedResult⟩ := + entryDecode_preserved_roles tapes workβ‚€ decodeDone.work (by simpa using! hdecodeFrame) + have hdecodeAddressWidth : + (decodeDone.work tapes.addressWidth).HasBinaryNat 0 := by + rw [hpreservedAddressWidth] + exact haddressWidth + have hdecodeValueWidth : + (decodeDone.work tapes.valueWidth).HasBinaryNat 0 := by + rw [hpreservedValueWidth] + exact hvalueWidth + have hdecodeQuery : + (decodeDone.work tapes.query).HasBinaryString queryBits := by + rw [hpreservedQuery] + exact hquery + have hdecodeResult : + (decodeDone.work tapes.result).HasBinaryPrefix [] := by + rw [hpreservedResult] + exact hresult + have hdecodeParked : βˆ€ i, TM.Parked (decodeDone.work i) := + entryDecode_work_parked tapes entry rest workβ‚€ decodeDone.work + (by simpa using! hdecodeSource) (by simpa using! hdecodeAddress) + (by simpa using! hdecodeValue) (by simpa using! hdecodeAddressCounter) + (by simpa using! hdecodeValueCounter) (by simpa using! hdecodeFrame) hwork + have hdecodeQueryStart : + (decodeDone.work tapes.query).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.query hdecodeReach + hqueryStart + obtain ⟨compareDone, compareTime, hcompareTime, hcompareReach, + hcompareHalt, hcompareInput, hcompareResult, hcompareAddress, + hcompareAddressHead, hcompareAddressStart, hcompareQuery, + hcompareQueryHead, hcompareQueryStart, hcompareFrame, hcompareOutput⟩ := + decodedAddressEqTM_reachesIn_frame tapes.address tapes.query tapes.result + tapes.binaryEqDistinct entry.1.bits queryBits decodeDone.input + decodeDone.work decodeDone.output (by simpa using! hdecodeAddress) + (by simpa using! hdecodeAddressStart) hdecodeQuery hdecodeQueryStart + hdecodeResult (by rw [hdecodeInput]; exact hinput.read_ne_start) + (fun i _ _ _ => ⟨(hdecodeParked i).read_ne_start, + (hdecodeParked i).1⟩) + (by rw [hdecodeOutput]; exact houtput.read_ne_start) + (by rw [hdecodeOutput]; exact houtput.1) + have htransitionInput : TM.transitionInput decodeDone.input = + decodeDone.input := + TM.transitionInput_eq_self (by rw [hdecodeInput]; exact hinput.read_ne_start) + have htransitionWork : + (fun i => TM.transitionTape (decodeDone.work i)) = decodeDone.work := by + funext i + exact TM.transitionTape_eq_self (hdecodeParked i).read_ne_start + have htransitionOutput : TM.transitionTape decodeDone.output = + decodeDone.output := + TM.transitionTape_eq_self + (by rw [hdecodeOutput]; exact houtput.read_ne_start) + have hcompareReach' : compareTM.reachesIn compareTime + { state := compareTM.qstart + input := TM.transitionInput decodeDone.input + work := fun i => TM.transitionTape (decodeDone.work i) + output := TM.transitionTape decodeDone.output } compareDone := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [compareTM] using! hcompareReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn decodeTM compareTM + (by simpa [decodeTM] using! hdecodeReach) hdecodeHalt hcompareReach' + let finalCfg := TM.phase2Wrap decodeTM compareTM compareDone + have hresultStartFinal : (finalCfg.work tapes.result).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := TM.seqTM decodeTM compareTM) tapes.result hfullReach hresultStart + have haddressCounterStartFinal : + (finalCfg.work tapes.addressCounter).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := TM.seqTM decodeTM compareTM) tapes.addressCounter hfullReach + haddressCounter.1 + have hvalueCounterStartFinal : + (finalCfg.work tapes.valueCounter).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := TM.seqTM decodeTM compareTM) tapes.valueCounter hfullReach + hvalueCounter.1 + have hfinalParked : βˆ€ i, TM.Parked (finalCfg.work i) := + binaryComparison_work_parked tapes.address tapes.query tapes.result + entry.1.bits queryBits [decide (entry.1.bits = queryBits)] + decodeDone.work compareDone.work hcompareAddress hcompareAddressHead + hcompareQuery hcompareQueryHead hcompareResult hcompareFrame hdecodeParked + refine ⟨finalCfg, entryDecodeLinearTime entry.1 entry.2 + 1 + compareTime, + ?_, ?_, ?_, hcompareInput.trans hdecodeInput, ?_, hcompareAddress, + hcompareAddressHead, hcompareAddressStart, ?_, ?_, ?_, + haddressCounterStartFinal, ?_, ?_, hvalueCounterStartFinal, ?_, + hcompareQuery, hcompareQueryHead, hcompareQueryStart, hcompareResult, + hresultStartFinal, hfinalParked, ?_, + hcompareOutput.trans hdecodeOutput⟩ + Β· simp only [entryMatchTime] + omega + Β· simpa [entryMatchTM, decodeTM, compareTM, finalCfg] using! hfullReach + Β· exact (TM.phase2Wrap_halted_iff decodeTM compareTM compareDone).2 + hcompareHalt + Β· change (compareDone.work tapes.source).HasBinarySuffix rest + rw [hcompareFrame tapes.source + (by simpa using! tapes.ne (show (0 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (0 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (0 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeSource + Β· change (compareDone.work tapes.value).HasBinaryPrefix entry.2.bits + rw [hcompareFrame tapes.value + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeValue + Β· change (compareDone.work tapes.value).cells 0 = Ξ“.start + rw [hcompareFrame tapes.value + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeValueStart + Β· change (compareDone.work tapes.addressCounter).HasBinaryPrefix + (List.replicate (bitlen entry.1) true) + rw [hcompareFrame tapes.addressCounter + (by simpa using! tapes.ne (show (3 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (3 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (3 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeAddressCounter + Β· change (compareDone.work tapes.addressWidth).HasBinaryNat 0 + rw [hcompareFrame tapes.addressWidth + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeAddressWidth + Β· change (compareDone.work tapes.valueCounter).HasBinaryPrefix + (List.replicate (bitlen entry.2) true) + rw [hcompareFrame tapes.valueCounter + (by simpa using! tapes.ne (show (5 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (5 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (5 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeValueCounter + Β· change (compareDone.work tapes.valueWidth).HasBinaryNat 0 + rw [hcompareFrame tapes.valueWidth + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  1 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  7 by decide)) + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  8 by decide))] + simpa using! hdecodeValueWidth + Β· intro i his hia hiv hiac hiaw hivc hivw hiq hir + change compareDone.work i = workβ‚€ i + rw [hcompareFrame i hia hiq hir, + hdecodeFrame i (by simpa using! his) (by simpa using! hia) + (by simpa using! hiv) (by simpa using! hiac) (by simpa using! hivc)] + +theorem entryMatchReadTM_reachesIn_frame_internal {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ tapes.source).HasBinarySuffix (Entry.encode entry ++ rest)) + (haddress : (workβ‚€ tapes.address).HasBinaryPrefix []) + (hvalue : (workβ‚€ tapes.value).HasBinaryPrefix []) + (haddressStart : (workβ‚€ tapes.address).cells 0 = Ξ“.start) + (hvalueStart : (workβ‚€ tapes.value).cells 0 = Ξ“.start) + (haddressCounter : (workβ‚€ tapes.addressCounter).HasBinaryNat 0) + (haddressWidth : (workβ‚€ tapes.addressWidth).HasBinaryNat 0) + (hvalueCounter : (workβ‚€ tapes.valueCounter).HasBinaryNat 0) + (hvalueWidth : (workβ‚€ tapes.valueWidth).HasBinaryNat 0) + (hquery : (workβ‚€ tapes.query).HasBinaryString queryBits) + (hqueryStart : (workβ‚€ tapes.query).cells 0 = Ξ“.start) + (hresult : (workβ‚€ tapes.result).HasBinaryPrefix []) + (hresultStart : (workβ‚€ tapes.result).cells 0 = Ξ“.start) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆƒ c' t, + t ≀ entryMatchReadTime entry queryBits ∧ + (entryMatchReadTM tapes).reachesIn t + { state := (entryMatchReadTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (entryMatchReadTM tapes).halted c' ∧ + c'.input = inpβ‚€ ∧ + ReadableEntryMatch tapes entry rest queryBits workβ‚€ c'.work ∧ + c'.output = outβ‚€ := by + let matchTM := entryMatchTM tapes + let rewindTM := TM.rewindWorkTM tapes.result + obtain ⟨matchDone, matchTime, hmatchTime, hmatchReach, hmatchHalt, + hmatchInput, hmatchSource, hmatchAddress, hmatchAddressHead, + hmatchAddressStart, hmatchValue, hmatchValueStart, hmatchAddressCounter, + hmatchAddressCounterStart, hmatchAddressWidth, hmatchValueCounter, + hmatchValueCounterStart, hmatchValueWidth, hmatchQuery, hmatchQueryHead, + hmatchQueryStart, hmatchResult, hmatchResultStart, hmatchParked, + hmatchFrame, hmatchOutput⟩ := + entryMatchTM_reachesIn_frame_internal tapes entry rest queryBits inpβ‚€ + workβ‚€ outβ‚€ hsource haddress hvalue haddressStart hvalueStart + haddressCounter haddressWidth hvalueCounter hvalueWidth hquery + hqueryStart hresult hresultStart hinput hwork houtput + let resultBits : List Bool := [decide (entry.1.bits = queryBits)] + obtain ⟨rewindDone, rewindTime, hrewindTime, hrewindReach, hrewindHalt, + hrewindInput, hrewindResult, hrewindFrame, hrewindOutput⟩ := + wordTargetRewind_reachesIn_frame tapes.result resultBits matchDone.input + matchDone.work matchDone.output (by simpa [resultBits] using! hmatchResult) + hmatchResultStart + (by rw [hmatchInput]; exact hinput.read_ne_start) + (fun i _ => ⟨(hmatchParked i).read_ne_start, (hmatchParked i).1⟩) + (by rw [hmatchOutput]; exact houtput.read_ne_start) + (by rw [hmatchOutput]; exact houtput.1) + have htransitionInput : TM.transitionInput matchDone.input = + matchDone.input := + TM.transitionInput_eq_self + (by rw [hmatchInput]; exact hinput.read_ne_start) + have htransitionWork : + (fun i => TM.transitionTape (matchDone.work i)) = matchDone.work := by + funext i + exact TM.transitionTape_eq_self (hmatchParked i).read_ne_start + have htransitionOutput : TM.transitionTape matchDone.output = + matchDone.output := + TM.transitionTape_eq_self + (by rw [hmatchOutput]; exact houtput.read_ne_start) + have hrewindReach' : rewindTM.reachesIn rewindTime + { state := rewindTM.qstart + input := TM.transitionInput matchDone.input + work := fun i => TM.transitionTape (matchDone.work i) + output := TM.transitionTape matchDone.output } rewindDone := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [rewindTM] using! hrewindReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn matchTM rewindTM + (by simpa [matchTM] using! hmatchReach) hmatchHalt hrewindReach' + let finalCfg := TM.phase2Wrap matchTM rewindTM rewindDone + have hresultStartFinal : (finalCfg.work tapes.result).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn + (tm := TM.seqTM matchTM rewindTM) tapes.result hfullReach hresultStart + have hfinalParked : βˆ€ i, TM.Parked (finalCfg.work i) := by + intro i + change TM.Parked (rewindDone.work i) + by_cases hir : i = tapes.result + Β· subst i + exact ⟨by rw [hrewindResult.1], + hrewindResult.hasBinaryContent.cells_ne_start⟩ + Β· rw [hrewindFrame i hir] + exact hmatchParked i + have hrewindTimeFour : rewindTime ≀ 4 := by + simpa [resultBits] using! hrewindTime + have hfullTime : matchTime + 1 + rewindTime ≀ + entryMatchReadTime entry queryBits := by + simp only [entryMatchReadTime] + omega + have hpreserve (i : Fin n) (hir : i β‰  tapes.result) : + finalCfg.work i = matchDone.work i := by + change rewindDone.work i = matchDone.work i + exact hrewindFrame i hir + have hreadable : + ReadableEntryMatch tapes entry rest queryBits workβ‚€ finalCfg.work := by + constructor + Β· rw [hpreserve tapes.source + (by simpa using! tapes.ne (show (0 : Fin 9) β‰  8 by decide))] + exact hmatchSource + Β· rw [hpreserve tapes.address + (by simpa using! tapes.ne (show (1 : Fin 9) β‰  8 by decide))] + exact hmatchAddress + Β· rw [hpreserve tapes.address + (by simpa using! tapes.ne (show (1 : Fin 9) β‰  8 by decide))] + exact hmatchAddressStart + Β· rw [hpreserve tapes.value + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  8 by decide))] + exact hmatchValue + Β· rw [hpreserve tapes.value + (by simpa using! tapes.ne (show (2 : Fin 9) β‰  8 by decide))] + exact hmatchValueStart + Β· rw [hpreserve tapes.addressCounter + (by simpa using! tapes.ne (show (3 : Fin 9) β‰  8 by decide))] + exact hmatchAddressCounter + Β· rw [hpreserve tapes.addressCounter + (by simpa using! tapes.ne (show (3 : Fin 9) β‰  8 by decide))] + exact hmatchAddressCounterStart + Β· rw [hpreserve tapes.addressWidth + (by simpa using! tapes.ne (show (4 : Fin 9) β‰  8 by decide))] + exact hmatchAddressWidth + Β· rw [hpreserve tapes.valueCounter + (by simpa using! tapes.ne (show (5 : Fin 9) β‰  8 by decide))] + exact hmatchValueCounter + Β· rw [hpreserve tapes.valueCounter + (by simpa using! tapes.ne (show (5 : Fin 9) β‰  8 by decide))] + exact hmatchValueCounterStart + Β· rw [hpreserve tapes.valueWidth + (by simpa using! tapes.ne (show (6 : Fin 9) β‰  8 by decide))] + exact hmatchValueWidth + Β· rw [hpreserve tapes.query + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  8 by decide))] + exact hmatchQuery + Β· rw [hpreserve tapes.query + (by simpa using! tapes.ne (show (7 : Fin 9) β‰  8 by decide))] + exact hmatchQueryStart + Β· simpa [resultBits] using! hrewindResult + Β· exact hresultStartFinal + Β· exact hfinalParked + Β· intro i + have hhead := (TM.seqTM matchTM rewindTM).work_head_reachesIn_bound + hfullReach i + have hhead' := le_trans hhead + (Nat.add_le_add_left hfullTime (workβ‚€ i).head) + simpa [finalCfg] using! hhead' + Β· intro i his hia hiv hiac hiaw hivc hivw hiq hir + rw [hpreserve i hir] + exact hmatchFrame i his hia hiv hiac hiaw hivc hivw hiq hir + refine ⟨finalCfg, matchTime + 1 + rewindTime, ?_, ?_, ?_, + hrewindInput.trans hmatchInput, hreadable, + hrewindOutput.trans hmatchOutput⟩ + Β· exact hfullTime + Β· simpa [entryMatchReadTM, matchTM, rewindTM, finalCfg] using! hfullReach + Β· exact (TM.phase2Wrap_halted_iff matchTM rewindTM rewindDone).2 + hrewindHalt + +/-- Closed form for the optimized unary-marker decode-and-match runtime. -/ +theorem entryMatchReadTime_eq_internal (entry : Entry) + (queryBits : List Bool) : + entryMatchReadTime entry queryBits = + 4 * entry.1.bits.length + 3 * entry.2.bits.length + + max entry.1.bits.length queryBits.length + 18 := by + unfold entryMatchReadTime entryMatchTime entryDecodeLinearTime + wordDecodeLinearTime decodedAddressEqTime TM.binaryEqTime + simp only [bitlen, Nat.size_eq_bits_len] + omega + +/-- One optimized readable match is linear in the two encoded word widths and +the preserved query width. -/ +theorem entryMatchReadTime_le_linear_internal (entry : Entry) + (queryBits : List Bool) : + entryMatchReadTime entry queryBits ≀ + 5 * entry.1.bits.length + 3 * entry.2.bits.length + + queryBits.length + 18 := by + rw [entryMatchReadTime_eq_internal] + have hmax : max entry.1.bits.length queryBits.length ≀ + entry.1.bits.length + queryBits.length := + max_le (Nat.le_add_right _ _) (Nat.le_add_left _ _) + omega + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy.lean new file mode 100644 index 0000000000..199f3ab1c3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Internal + +/-! +# Sparse-entry miss copy + +This module exposes the update-scan branch that appends one unmatched entry to +the new store and restores the exact invariant needed to inspect the next one. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Copy one decoded unmatched entry to the output stream and restore the +ordinary next-entry scan invariant, with an explicit intermediate work frame. -/ +theorem entryMissCopyTM_hoareTime_frame {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits emitted : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryMissCopyTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes rest queryBits initialWork work ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (entryMissCopyTime tapes entry queryBits initialWork matchedWork) := + entryMissCopyTM_hoareTime_frame_internal tapes entry rest queryBits emitted + initialWork matchedWork inpβ‚€ outβ‚€ hmatch hinput houtput + +/-- Miss-copy is append-only on the output tape. -/ +theorem entryMissCopyTM_isTransducer {n : β„•} (tapes : EntryMatchTapes n) : + (entryMissCopyTM tapes).IsTransducer := + (rewindEntryEncodeTM_isTransducer tapes.encodeTapes).seqTM + (entryMissCleanupTM_isTransducer tapes) + +/-- Coarse all-prefix auxiliary-space envelope for one miss-copy branch. -/ +theorem entryMissCopyTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryMissCopyTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryMissCopyTM tapes).reachesIn time start current) + (htime : time ≀ + entryMissCopyTime tapes entry queryBits initialWork matchedWork) : + current.WithinAuxSpace inputLength + (initialSpace + + entryMissCopyTime tapes entry queryBits initialWork matchedWork) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Defs.lean new file mode 100644 index 0000000000..3386d9077b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Defs.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs + +/-! +# Sparse-entry miss copy β€” definitions + +An update scan must preserve every unmatched sparse entry. This module first +emits the decoded address/value pair to the output stream and then restores the +ordinary next-entry scan invariant. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +namespace EntryMatchTapes + +/-- View the decoded address and value tapes as entry-emission sources. -/ +def encodeTapes {n : β„•} (tapes : EntryMatchTapes n) : EntryEncodeTapes n where + address := tapes.address + value := tapes.value + ne := tapes.ne (by decide) + +@[simp] theorem encodeTapes_address {n : β„•} (tapes : EntryMatchTapes n) : + tapes.encodeTapes.address = tapes.address := rfl + +@[simp] theorem encodeTapes_value {n : β„•} (tapes : EntryMatchTapes n) : + tapes.encodeTapes.value = tapes.value := rfl + +end EntryMatchTapes + +/-- Exact work family after the decoded address and value have been emitted. +Only their heads change; their canonical contents and every other tape remain +literal copies of the readable-match endpoint. -/ +def entryMissCopiedWork {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (work : Fin n β†’ Tape) (i : Fin n) : Tape := + if i = tapes.address then + { head := entry.1.bits.length + 1, cells := (work i).cells } + else if i = tapes.value then + { head := entry.2.bits.length + 1, cells := (work i).cells } + else work i + +/-- Emit the decoded unmatched entry and restore the next-iteration scratch +invariant. -/ +def entryMissCopyTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.seqTM (rewindEntryEncodeTM tapes.encodeTapes) + (entryMissCleanupTM tapes) + +/-- Compositional runtime bound for copying and cleaning one unmatched entry. -/ +def entryMissCopyTime {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) : β„• := + rewindEntryEncodeTime entry + (entryMissHeadBound entry queryBits initialWork tapes.address) + (entryMissHeadBound entry queryBits initialWork tapes.value) + + 1 + + entryMissCleanupTime tapes entry queryBits + (entryMissCopiedWork tapes entry matchedWork) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Internal.lean new file mode 100644 index 0000000000..faa184a4a3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryMissCopy/Internal.lean @@ -0,0 +1,268 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode + +/-! +# Sparse-entry miss copy β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +private theorem entryMissCopiedWork_eq + (tapes : EntryMatchTapes n) (entry : Entry) + (matchedWork copiedWork : Fin n β†’ Tape) + (haddressCells : (copiedWork tapes.address).cells = + (matchedWork tapes.address).cells) + (haddressHead : (copiedWork tapes.address).head = + entry.1.bits.length + 1) + (hvalueCells : (copiedWork tapes.value).cells = + (matchedWork tapes.value).cells) + (hvalueHead : (copiedWork tapes.value).head = + entry.2.bits.length + 1) + (hframe : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + copiedWork i = matchedWork i) : + copiedWork = entryMissCopiedWork tapes entry matchedWork := by + funext i + by_cases hia : i = tapes.address + Β· subst i + simp only [entryMissCopiedWork, ite_eq_left] + exact Tape.ext haddressHead haddressCells + Β· by_cases hiv : i = tapes.value + Β· subst i + simp only [entryMissCopiedWork, hia, ite_false, ite_eq_left] + exact Tape.ext hvalueHead hvalueCells + Β· simp only [entryMissCopiedWork, hia, hiv, ite_false] + exact hframe i hia hiv + +private theorem readableEntryMatch_rebase_after_copy + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (baseWork initialWork copiedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits baseWork initialWork) + (haddressSuffix : (copiedWork tapes.address).HasBinarySuffix []) + (haddressCells : (copiedWork tapes.address).cells = + (initialWork tapes.address).cells) + (hvalueSuffix : (copiedWork tapes.value).HasBinarySuffix []) + (hvalueCells : (copiedWork tapes.value).cells = + (initialWork tapes.value).cells) + (hvalueHead : (copiedWork tapes.value).head = + entry.2.bits.length + 1) + (hframe : βˆ€ i, i β‰  tapes.address β†’ i β‰  tapes.value β†’ + copiedWork i = initialWork i) : + ReadableEntryMatch tapes entry rest queryBits copiedWork copiedWork := by + have hsourceNeAddress : tapes.source β‰  tapes.address := tapes.ne (by decide) + have hsourceNeValue : tapes.source β‰  tapes.value := tapes.ne (by decide) + have haddressContent : + (copiedWork tapes.address).HasBinaryContent entry.1.bits := by + simpa only [Tape.HasBinaryContent, haddressCells] using! hmatch.address + have hvalueContent : + (copiedWork tapes.value).HasBinaryContent entry.2.bits := by + simpa only [Tape.HasBinaryContent, hvalueCells] using! hmatch.value.2 + constructor + Β· rw [hframe tapes.source hsourceNeAddress hsourceNeValue] + exact hmatch.source + Β· exact haddressContent + Β· rw [haddressCells] + exact hmatch.addressStart + Β· exact ⟨hvalueHead, hvalueContent⟩ + Β· rw [hvalueCells] + exact hmatch.valueStart + Β· rw [hframe tapes.addressCounter (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.addressCounter + Β· rw [hframe tapes.addressCounter (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.addressCounterStart + Β· rw [hframe tapes.addressWidth (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.addressWidth + Β· rw [hframe tapes.valueCounter (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.valueCounter + Β· rw [hframe tapes.valueCounter (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.valueCounterStart + Β· rw [hframe tapes.valueWidth (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.valueWidth + Β· rw [hframe tapes.query (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.query + Β· rw [hframe tapes.query (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.queryStart + Β· rw [hframe tapes.result (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.result + Β· rw [hframe tapes.result (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hmatch.resultStart + Β· intro i + by_cases hia : i = tapes.address + Β· subst i + exact parked_of_binarySuffix haddressSuffix + Β· by_cases hiv : i = tapes.value + Β· subst i + exact parked_of_binarySuffix hvalueSuffix + Β· rw [hframe i hia hiv] + exact hmatch.parked i + Β· intro i + exact Nat.le_add_right _ _ + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + +theorem entryMissCopyTM_hoareTime_frame_internal + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits emitted : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes entry rest queryBits initialWork matchedWork) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryMissCopyTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes rest queryBits initialWork work ∧ + out.HasBinaryPrefix (emitted ++ Entry.encode entry)) + (entryMissCopyTime tapes entry queryBits initialWork matchedWork) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let copiedWork := entryMissCopiedWork tapes entry matchedWork + have hencode := rewindEntryEncodeTM_hoareTime_frame tapes.encodeTapes entry + (entryMissHeadBound entry queryBits initialWork tapes.address) + (entryMissHeadBound entry queryBits initialWork tapes.value) + emitted inpβ‚€ matchedWork outβ‚€ hmatch.address hmatch.addressStart + ⟨(hmatch.parked tapes.address).1, hmatch.headBound tapes.address⟩ + hmatch.value.2 hmatch.valueStart + ⟨(hmatch.parked tapes.value).1, hmatch.headBound tapes.value⟩ + hinput (fun i _ _ => hmatch.parked i) houtput + obtain ⟨encoded, encodeTime, hencodeTime, hencodeReach, hencodeHalt, + hencodedInput, haddressSuffix, haddressCells, haddressHead, + hvalueSuffix, hvalueCells, hvalueHead, hencodedFrame, + hencodedOutput⟩ := + hencode inpβ‚€ matchedWork outβ‚€ ⟨rfl, rfl, rfl⟩ + have hencodedWork : encoded.work = copiedWork := by + apply entryMissCopiedWork_eq tapes entry matchedWork encoded.work + Β· simpa using! haddressCells + Β· simpa using! haddressHead + Β· simpa using! hvalueCells + Β· simpa using! hvalueHead + Β· intro i hia hiv + exact hencodedFrame i hia hiv + have hmatchSelf : + ReadableEntryMatch tapes entry rest queryBits copiedWork copiedWork := by + have hmatchCopied : + ReadableEntryMatch tapes entry rest queryBits encoded.work encoded.work := + readableEntryMatch_rebase_after_copy tapes entry rest queryBits + initialWork matchedWork encoded.work hmatch + (by simpa using! haddressSuffix) (by simpa using! haddressCells) + (by simpa using! hvalueSuffix) + (by simpa using! hvalueCells) (by simpa using! hvalueHead) + (by + intro i hia hiv + exact hencodedFrame i hia hiv) + simpa [hencodedWork] using! hmatchCopied + have hencodedInputParked : TM.Parked encoded.input := by + rw [hencodedInput] + exact hinput + have hencodedWorkParked : βˆ€ i, TM.Parked (encoded.work i) := by + intro i + rw [hencodedWork] + exact hmatchSelf.parked i + have hencodedOutputParked : TM.Parked encoded.output := + parked_of_binaryPrefix hencodedOutput + have hcleanup := entryMissCleanupTM_hoareTime_frame tapes entry rest queryBits + copiedWork copiedWork encoded.input encoded.output hmatchSelf + (by simpa [hencodedInput] using! hinput) hencodedOutputParked + obtain ⟨cleaned, cleanupTime, hcleanupTime, hcleanupReach, hcleanupHalt, + hcleanedInput, hready, hcleanedOutput⟩ := + hcleanup encoded.input copiedWork encoded.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hencodedInputParked.read_ne_start + (fun i => (hencodedWorkParked i).read_ne_start) + hencodedOutputParked.read_ne_start + have hworkTransition' : + (fun i => TM.transitionTape (encoded.work i)) = copiedWork := + hworkTransition.trans hencodedWork + have hcleanupReach' : (entryMissCleanupTM tapes).reachesIn cleanupTime + { state := (entryMissCleanupTM tapes).qstart + input := TM.transitionInput encoded.input + work := fun i => TM.transitionTape (encoded.work i) + output := TM.transitionTape encoded.output } + cleaned := by + simpa only [hinputTransition, hworkTransition', houtputTransition] + using! hcleanupReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeTM tapes.encodeTapes) (entryMissCleanupTM tapes) + hencodeReach hencodeHalt hcleanupReach' + let finalCfg := TM.phase2Wrap (rewindEntryEncodeTM tapes.encodeTapes) + (entryMissCleanupTM tapes) cleaned + refine ⟨finalCfg, encodeTime + 1 + cleanupTime, ?_, hreach, ?_, ?_⟩ + Β· unfold entryMissCopyTime + change encodeTime + 1 + cleanupTime ≀ + rewindEntryEncodeTime entry + (entryMissHeadBound entry queryBits initialWork tapes.address) + (entryMissHeadBound entry queryBits initialWork tapes.value) + + 1 + entryMissCleanupTime tapes entry queryBits copiedWork + omega + Β· change (entryMissCopyTM tapes).halted finalCfg + unfold entryMissCopyTM + exact (TM.phase2Wrap_halted_iff (rewindEntryEncodeTM tapes.encodeTapes) + (entryMissCleanupTM tapes) cleaned).mpr hcleanupHalt + Β· have hreadyGlobal : + EntryScanReady tapes rest queryBits initialWork cleaned.work := by + refine ⟨hready.source, hready.address, hready.addressStart, + hready.value, hready.valueStart, hready.addressCounter, + hready.addressWidth, hready.valueCounter, hready.valueWidth, + hready.query, hready.queryStart, hready.result, hready.resultStart, + hready.parked, ?_⟩ + intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + have hcopied : copiedWork i = matchedWork i := by + simp [copiedWork, entryMissCopiedWork, haddress, hvalue] + exact (hready.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult).trans + (hcopied.trans (hmatch.frame i hsource haddress hvalue + haddressCounter haddressWidth hvalueCounter hvalueWidth hquery + hresult)) + refine ⟨?_, hreadyGlobal, ?_⟩ + Β· simpa [finalCfg] using! hcleanedInput.trans hencodedInput + Β· change cleaned.output.HasBinaryPrefix (emitted ++ Entry.encode entry) + rw [hcleanedOutput] + exact hencodedOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace.lean new file mode 100644 index 0000000000..8dd9dfba5e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Internal + +/-! +# Sparse-entry replacement +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Emit a matched address with a canonical replacement value, restore that +external value source, and clear all entry scratch for the next iteration. -/ +theorem entryReplaceCleanupTM_hoareTime_frame {n : β„•} + (tapes : EntryReplaceTapes n) (entry : Entry) (newValue : β„•) + (rest queryBits emitted : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits + initialWork matchedWork) + (hreplacement : (matchedWork tapes.replacement).HasBinaryNat newValue) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryReplaceCleanupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes.entry rest queryBits initialWork work ∧ + work tapes.replacement = matchedWork tapes.replacement ∧ + out.HasBinaryPrefix + (emitted ++ Entry.encode (entry.1, newValue))) + (entryReplaceCleanupTime tapes entry newValue queryBits + initialWork matchedWork) := + entryReplaceCleanupTM_hoareTime_frame_internal tapes entry newValue rest + queryBits emitted initialWork matchedWork inpβ‚€ outβ‚€ hmatch hreplacement + hinput houtput + +/-- Replacement emission and cleanup are append-only on the output tape. -/ +theorem entryReplaceCleanupTM_isTransducer {n : β„•} + (tapes : EntryReplaceTapes n) : + (entryReplaceCleanupTM tapes).IsTransducer := + (rewindEntryEncodeTM_isTransducer tapes.encodeTapes).seqTM + ((TM.rewindWorkTM_isTransducer tapes.replacement).seqTM + (entryMissCleanupTM_isTransducer tapes.entry)) + +/-- Coarse all-prefix auxiliary-space envelope for replacement and cleanup. -/ +theorem entryReplaceCleanupTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryReplaceTapes n) (entry : Entry) (newValue : β„•) + (queryBits : List Bool) (initialWork matchedWork : Fin n β†’ Tape) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryReplaceCleanupTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryReplaceCleanupTM tapes).reachesIn time start current) + (htime : time ≀ entryReplaceCleanupTime tapes entry newValue queryBits + initialWork matchedWork) : + current.WithinAuxSpace inputLength + (initialSpace + entryReplaceCleanupTime tapes entry newValue queryBits + initialWork matchedWork) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Defs.lean new file mode 100644 index 0000000000..5ca1547bb1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Defs.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode.Defs + +/-! +# Sparse-entry replacement β€” definitions + +The replacement branch emits the matched address paired with a distinct +canonical new-value tape, rewinds that external value source, and restores the +ordinary next-entry scan invariant. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Entry-match tapes plus a distinct source containing the replacement value. -/ +structure EntryReplaceTapes (n : β„•) where + /-- The nine tapes used to decode and match the old entry. -/ + entry : EntryMatchTapes n + /-- Canonical new-value source. -/ + replacement : Fin n + /-- The replacement source is outside the complete entry-match assignment. -/ + replacement_ne : βˆ€ i, replacement β‰  entry.idx i + +namespace EntryReplaceTapes + +/-- Emit the matched decoded address paired with the replacement source. -/ +def encodeTapes {n : β„•} (tapes : EntryReplaceTapes n) : EntryEncodeTapes n where + address := tapes.entry.address + value := tapes.replacement + ne := Ne.symm (tapes.replacement_ne 1) + +@[simp] theorem encodeTapes_address {n : β„•} (tapes : EntryReplaceTapes n) : + tapes.encodeTapes.address = tapes.entry.address := rfl + +@[simp] theorem encodeTapes_value {n : β„•} (tapes : EntryReplaceTapes n) : + tapes.encodeTapes.value = tapes.replacement := rfl + +end EntryReplaceTapes + +/-- Exact work family after replacement emission and restoration of the +external replacement cursor. Only the decoded address head remains changed. -/ +def entryReplaceReadyWork {n : β„•} (tapes : EntryReplaceTapes n) + (entry : Entry) (work : Fin n β†’ Tape) (i : Fin n) : Tape := + if i = tapes.entry.address then + { head := entry.1.bits.length + 1, cells := (work i).cells } + else work i + +/-- Emit the replacement entry, restore the replacement cursor, and clear all +entry decoder/result scratch. -/ +def entryReplaceCleanupTM {n : β„•} (tapes : EntryReplaceTapes n) : TM n := + TM.seqTM (rewindEntryEncodeTM tapes.encodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)) + +/-- Compositional runtime bound for replacement emission and cleanup. -/ +def entryReplaceCleanupTime {n : β„•} (tapes : EntryReplaceTapes n) + (entry : Entry) (newValue : β„•) (queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) : β„• := + rewindEntryEncodeTime (entry.1, newValue) + (entryMissHeadBound entry queryBits initialWork tapes.entry.address) 1 + + 1 + (newValue.bits.length + 1 + 2 + 1 + + entryMissCleanupTime tapes.entry entry queryBits + (entryReplaceReadyWork tapes entry matchedWork)) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Internal.lean new file mode 100644 index 0000000000..c1f5da27f2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryReplace/Internal.lean @@ -0,0 +1,385 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode + +/-! +# Sparse-entry replacement β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +private theorem readableEntryMatch_rebase_after_address_emit + (tapes : EntryReplaceTapes n) (entry : Entry) + (rest queryBits : List Bool) (baseWork matchedWork readyWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits + baseWork matchedWork) + (haddressSuffix : (readyWork tapes.entry.address).HasBinarySuffix []) + (haddressCells : (readyWork tapes.entry.address).cells = + (matchedWork tapes.entry.address).cells) + (hframe : βˆ€ i, i β‰  tapes.entry.address β†’ readyWork i = matchedWork i) : + ReadableEntryMatch tapes.entry entry rest queryBits readyWork readyWork := by + have haddressContent : + (readyWork tapes.entry.address).HasBinaryContent entry.1.bits := by + simpa only [Tape.HasBinaryContent, haddressCells] using! hmatch.address + constructor + Β· rw [hframe tapes.entry.source (tapes.entry.ne (by decide))] + exact hmatch.source + Β· exact haddressContent + Β· rw [haddressCells] + exact hmatch.addressStart + Β· rw [hframe tapes.entry.value (tapes.entry.ne (by decide))] + exact hmatch.value + Β· rw [hframe tapes.entry.value (tapes.entry.ne (by decide))] + exact hmatch.valueStart + Β· rw [hframe tapes.entry.addressCounter (tapes.entry.ne (by decide))] + exact hmatch.addressCounter + Β· rw [hframe tapes.entry.addressCounter (tapes.entry.ne (by decide))] + exact hmatch.addressCounterStart + Β· rw [hframe tapes.entry.addressWidth (tapes.entry.ne (by decide))] + exact hmatch.addressWidth + Β· rw [hframe tapes.entry.valueCounter (tapes.entry.ne (by decide))] + exact hmatch.valueCounter + Β· rw [hframe tapes.entry.valueCounter (tapes.entry.ne (by decide))] + exact hmatch.valueCounterStart + Β· rw [hframe tapes.entry.valueWidth (tapes.entry.ne (by decide))] + exact hmatch.valueWidth + Β· rw [hframe tapes.entry.query (tapes.entry.ne (by decide))] + exact hmatch.query + Β· rw [hframe tapes.entry.query (tapes.entry.ne (by decide))] + exact hmatch.queryStart + Β· rw [hframe tapes.entry.result (tapes.entry.ne (by decide))] + exact hmatch.result + Β· rw [hframe tapes.entry.result (tapes.entry.ne (by decide))] + exact hmatch.resultStart + Β· intro i + by_cases hia : i = tapes.entry.address + Β· subst i + exact parked_of_binarySuffix haddressSuffix + Β· rw [hframe i hia] + exact hmatch.parked i + Β· intro i + exact Nat.le_add_right _ _ + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + +private theorem entryReplaceReadyWork_eq + (tapes : EntryReplaceTapes n) (entry : Entry) + (matchedWork readyWork : Fin n β†’ Tape) + (haddressCells : (readyWork tapes.entry.address).cells = + (matchedWork tapes.entry.address).cells) + (haddressHead : (readyWork tapes.entry.address).head = + entry.1.bits.length + 1) + (hframe : βˆ€ i, i β‰  tapes.entry.address β†’ readyWork i = matchedWork i) : + readyWork = entryReplaceReadyWork tapes entry matchedWork := by + funext i + by_cases hia : i = tapes.entry.address + Β· subst i + simp only [entryReplaceReadyWork, ite_eq_left] + exact Tape.ext haddressHead haddressCells + Β· simp only [entryReplaceReadyWork, hia, ite_false] + exact hframe i hia + +/-- Cleanup restores the original scan frame and leaves the replacement tape unchanged. -/ +private theorem entryReplaceCleanup_preserves_frame + (tapes : EntryReplaceTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork finalWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits initialWork matchedWork) + (hready : EntryScanReady tapes.entry rest queryBits + (entryReplaceReadyWork tapes entry matchedWork) finalWork) : + EntryScanReady tapes.entry rest queryBits initialWork finalWork ∧ + finalWork tapes.replacement = matchedWork tapes.replacement := by + let readyWork := entryReplaceReadyWork tapes entry matchedWork + have hreadyGlobal : + EntryScanReady tapes.entry rest queryBits initialWork finalWork := by + refine ⟨hready.source, hready.address, hready.addressStart, + hready.value, hready.valueStart, hready.addressCounter, + hready.addressWidth, hready.valueCounter, hready.valueWidth, + hready.query, hready.queryStart, hready.result, hready.resultStart, + hready.parked, ?_⟩ + intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + have hbase : readyWork i = matchedWork i := by + simp [readyWork, entryReplaceReadyWork, haddress] + exact (hready.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult).trans + (hbase.trans (hmatch.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult)) + refine ⟨hreadyGlobal, ?_⟩ + have hreplacementReady : readyWork tapes.replacement = + matchedWork tapes.replacement := by + have hne : tapes.replacement β‰  tapes.entry.address := + tapes.replacement_ne 1 + change (if tapes.replacement = tapes.entry.address then + { head := entry.1.bits.length + 1, + cells := (matchedWork tapes.replacement).cells } + else matchedWork tapes.replacement) = matchedWork tapes.replacement + rw [ite_eq_right hne] + exact (hready.frame tapes.replacement + (tapes.replacement_ne 0) (tapes.replacement_ne 1) + (tapes.replacement_ne 2) (tapes.replacement_ne 3) + (tapes.replacement_ne 4) (tapes.replacement_ne 5) + (tapes.replacement_ne 6) (tapes.replacement_ne 7) + (tapes.replacement_ne 8)).trans hreplacementReady + +/-- A framed work family is parked when both modified tapes have binary suffixes. -/ +private theorem parked_of_two_binary_suffixes + (first second : Fin n) (base work : Fin n β†’ Tape) (firstBits secondBits : List Bool) + (hfirst : (work first).HasBinarySuffix firstBits) + (hsecond : (work second).HasBinarySuffix secondBits) + (hframe : βˆ€ i, i β‰  first β†’ i β‰  second β†’ work i = base i) + (hbase : βˆ€ i, TM.Parked (base i)) : βˆ€ i, TM.Parked (work i) := by + intro i + by_cases hia : i = first + Β· subst i + exact parked_of_binarySuffix hfirst + Β· by_cases hir : i = second + Β· subst i + exact parked_of_binarySuffix hsecond + Β· rw [hframe i hia hir] + exact hbase i + +theorem entryReplaceCleanupTM_hoareTime_frame_internal + (tapes : EntryReplaceTapes n) (entry : Entry) (newValue : β„•) + (rest queryBits emitted : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits + initialWork matchedWork) + (hreplacement : (matchedWork tapes.replacement).HasBinaryNat newValue) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emitted) : + (entryReplaceCleanupTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = matchedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanReady tapes.entry rest queryBits initialWork work ∧ + work tapes.replacement = matchedWork tapes.replacement ∧ + out.HasBinaryPrefix + (emitted ++ Entry.encode (entry.1, newValue))) + (entryReplaceCleanupTime tapes entry newValue queryBits + initialWork matchedWork) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let readyWork := entryReplaceReadyWork tapes entry matchedWork + have hencode := rewindEntryEncodeTM_hoareTime_frame tapes.encodeTapes + (entry.1, newValue) + (entryMissHeadBound entry queryBits initialWork tapes.entry.address) 1 + emitted inpβ‚€ matchedWork outβ‚€ hmatch.address hmatch.addressStart + ⟨(hmatch.parked tapes.entry.address).1, + hmatch.headBound tapes.entry.address⟩ + hreplacement.2.hasBinaryContent hreplacement.1 + (by + have hhead : 1 ≀ (matchedWork tapes.replacement).head ∧ + (matchedWork tapes.replacement).head ≀ 1 := by + rw [hreplacement.2.1] + exact ⟨le_rfl, le_rfl⟩ + simpa using! hhead) + hinput (fun i _ _ => hmatch.parked i) houtput + obtain ⟨encoded, encodeTime, hencodeTime, hencodeReach, hencodeHalt, + hencodedInput, haddressSuffix, haddressCells, haddressHead, + hreplacementSuffix, hreplacementCells, hreplacementHead, + hencodedFrame, hencodedOutput⟩ := + hencode inpβ‚€ matchedWork outβ‚€ ⟨rfl, rfl, rfl⟩ + have hencodedInputParked : TM.Parked encoded.input := by + rw [hencodedInput] + exact hinput + have hencodedOutputParked : TM.Parked encoded.output := + parked_of_binaryPrefix hencodedOutput + have hencodedWorkParked : βˆ€ i, TM.Parked (encoded.work i) := + parked_of_two_binary_suffixes tapes.entry.address tapes.replacement + matchedWork encoded.work _ _ haddressSuffix hreplacementSuffix + hencodedFrame hmatch.parked + have hreplacementContent : + (encoded.work tapes.replacement).HasBinaryContent newValue.bits := by + have hcells : (encoded.work tapes.replacement).cells = + (matchedWork tapes.replacement).cells := by + simpa using! hreplacementCells + simpa only [Tape.HasBinaryContent, hcells] using! + hreplacement.2.hasBinaryContent + have hreplacementStart : + (encoded.work tapes.replacement).cells 0 = Ξ“.start := by + have hcells : (encoded.work tapes.replacement).cells = + (matchedWork tapes.replacement).cells := by + simpa using! hreplacementCells + rw [hcells] + exact hreplacement.1 + have hreplacementHead' : (encoded.work tapes.replacement).head = + newValue.bits.length + 1 := by + simpa using! hreplacementHead + have hrewind := TM.rewindBinaryWorkTM_hoareTime_frame tapes.replacement + newValue.bits (newValue.bits.length + 1) encoded.input encoded.work + encoded.output hreplacementContent hreplacementStart + ⟨by rw [hreplacementHead']; omega, by rw [hreplacementHead']⟩ + hencodedInputParked + (fun i _ => hencodedWorkParked i) hencodedOutputParked + obtain ⟨rewound, rewindTime, hrewindTime, hrewindReach, hrewindHalt, + hrewoundInput, hrewoundReplacement, hrewoundFrame, + hrewoundOutput⟩ := + hrewind encoded.input encoded.work encoded.output ⟨rfl, rfl, rfl⟩ + have hmatchedReplacement : matchedWork tapes.replacement = + (Tape.init (newValue.bits.map Ξ“.ofBool)).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString hreplacement.2 hreplacement.1 + have hreplacementRestored : + rewound.work tapes.replacement = matchedWork tapes.replacement := + hrewoundReplacement.trans hmatchedReplacement.symm + have hreadyWorkEq : rewound.work = readyWork := by + apply entryReplaceReadyWork_eq tapes entry matchedWork rewound.work + Β· rw [hrewoundFrame tapes.entry.address + (Ne.symm (tapes.replacement_ne 1))] + simpa using! haddressCells + Β· rw [hrewoundFrame tapes.entry.address + (Ne.symm (tapes.replacement_ne 1))] + simpa using! haddressHead + Β· intro i hia + by_cases hir : i = tapes.replacement + Β· subst i + exact hreplacementRestored + Β· exact (hrewoundFrame i hir).trans (hencodedFrame i hia hir) + have hmatchSelf : ReadableEntryMatch tapes.entry entry rest queryBits + readyWork readyWork := by + have hmatchReady := readableEntryMatch_rebase_after_address_emit tapes + entry rest queryBits initialWork matchedWork rewound.work hmatch + (by + rw [hrewoundFrame tapes.entry.address + (Ne.symm (tapes.replacement_ne 1))] + simpa using! haddressSuffix) + (by + rw [hrewoundFrame tapes.entry.address + (Ne.symm (tapes.replacement_ne 1))] + simpa using! haddressCells) + (by + intro i hia + by_cases hir : i = tapes.replacement + Β· subst i + exact hreplacementRestored + Β· exact (hrewoundFrame i hir).trans (hencodedFrame i hia hir)) + simpa [hreadyWorkEq] using! hmatchReady + have hrewoundInputParked : TM.Parked rewound.input := by + rw [hrewoundInput, hencodedInput] + exact hinput + have hrewoundOutputParked : TM.Parked rewound.output := by + rw [hrewoundOutput] + exact hencodedOutputParked + have hrewoundWorkParked : βˆ€ i, TM.Parked (rewound.work i) := by + intro i + rw [hreadyWorkEq] + exact hmatchSelf.parked i + have hcleanup := entryMissCleanupTM_hoareTime_frame tapes.entry entry rest + queryBits readyWork readyWork rewound.input rewound.output hmatchSelf + hrewoundInputParked hrewoundOutputParked + obtain ⟨cleaned, cleanupTime, hcleanupTime, hcleanupReach, hcleanupHalt, + hcleanedInput, hready, hcleanedOutput⟩ := + hcleanup rewound.input readyWork rewound.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hrewindInputTransition, hrewindWorkTransition, + hrewindOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hrewoundInputParked.read_ne_start + (fun i => (hrewoundWorkParked i).read_ne_start) + hrewoundOutputParked.read_ne_start + have hrewindWorkTransition' : + (fun i => TM.transitionTape (rewound.work i)) = readyWork := + hrewindWorkTransition.trans hreadyWorkEq + have hcleanupReach' : (entryMissCleanupTM tapes.entry).reachesIn cleanupTime + { state := (entryMissCleanupTM tapes.entry).qstart + input := TM.transitionInput rewound.input + work := fun i => TM.transitionTape (rewound.work i) + output := TM.transitionTape rewound.output } + cleaned := by + simpa only [hrewindInputTransition, hrewindWorkTransition', + hrewindOutputTransition] using! hcleanupReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (TM.rewindWorkTM tapes.replacement) (entryMissCleanupTM tapes.entry) + hrewindReach hrewindHalt hcleanupReach' + let tailFinal := TM.phase2Wrap (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry) cleaned + have htailHalt : + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)).halted tailFinal := by + rw [TM.phase2Wrap_halted_iff] + exact hcleanupHalt + obtain ⟨hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hencodedInputParked.read_ne_start + (fun i => (hencodedWorkParked i).read_ne_start) + hencodedOutputParked.read_ne_start + have htailReach' : + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)).reachesIn + (rewindTime + 1 + cleanupTime) + { state := (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)).qstart + input := TM.transitionInput encoded.input + work := fun i => TM.transitionTape (encoded.work i) + output := TM.transitionTape encoded.output } + tailFinal := by + simpa only [hencodedInputTransition, hencodedWorkTransition, + hencodedOutputTransition] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeTM tapes.encodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)) + hencodeReach hencodeHalt htailReach' + let finalCfg := TM.phase2Wrap (rewindEntryEncodeTM tapes.encodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)) tailFinal + refine ⟨finalCfg, encodeTime + 1 + (rewindTime + 1 + cleanupTime), + ?_, hreach, ?_, ?_⟩ + Β· unfold entryReplaceCleanupTime + change encodeTime + 1 + (rewindTime + 1 + cleanupTime) ≀ + rewindEntryEncodeTime (entry.1, newValue) + (entryMissHeadBound entry queryBits initialWork tapes.entry.address) 1 + + 1 + (newValue.bits.length + 1 + 2 + 1 + + entryMissCleanupTime tapes.entry entry queryBits readyWork) + omega + Β· change (entryReplaceCleanupTM tapes).halted finalCfg + unfold entryReplaceCleanupTM + exact (TM.phase2Wrap_halted_iff (rewindEntryEncodeTM tapes.encodeTapes) + (TM.seqTM (TM.rewindWorkTM tapes.replacement) + (entryMissCleanupTM tapes.entry)) tailFinal).mpr htailHalt + Β· obtain ⟨hreadyGlobal, hreplacementFinal⟩ := + entryReplaceCleanup_preserves_frame tapes entry rest queryBits + initialWork matchedWork cleaned.work hmatch hready + refine ⟨?_, hreadyGlobal, hreplacementFinal, ?_⟩ + Β· change cleaned.input = inpβ‚€ + exact hcleanedInput.trans (hrewoundInput.trans hencodedInput) + Β· change cleaned.output.HasBinaryPrefix + (emitted ++ Entry.encode (entry.1, newValue)) + rw [hcleanedOutput, hrewoundOutput] + exact hencodedOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan.lean new file mode 100644 index 0000000000..e5dae4c8e7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Bounds + +/-! +# Bounded sparse-entry scan + +This module exposes the complete time-bounded contract for the fixed sparse +store scanner. The runtime entry count is read from a canonical binary tape; +it is not hardwired into the finite controller. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Scan a runtime-sized sparse store. A successful endpoint contains the +first matching entry's decoded value; a miss certifies that every address was +different. Input, output, and every work tape outside the ten-tape assignment +are preserved exactly. -/ +theorem entryScanTM_hoareTime_frame {n : β„•} + (tapes : EntryScanTapes n) (store : Store) (queryBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + queryBits initialWork initialWork) + (hcount : (initialWork tapes.count).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryScanTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanOutcome tapes store queryBits initialWork work ∧ + out = outβ‚€) + (entryScanTime tapes queryBits store) := + entryScanTM_hoareTime_frame_internal tapes store queryBits initialWork + inpβ‚€ outβ‚€ hready hcount hinput houtput + +/-- The bounded scanner preserves one-way output safety. -/ +theorem entryScanTM_isTransducer {n : β„•} (tapes : EntryScanTapes n) : + (entryScanTM tapes).IsTransducer := by + intro state iHead wHeads oHead + rcases state with phase | nested + Β· cases phase <;> cases oHead <;> + simp [entryScanTM, TM.allReadBack, TM.allIdle, TM.idleDir] <;> + split <;> simp + Β· rcases nested with body | pred + Β· simp only [entryScanTM] + split + Β· split <;> cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryScanStepTM_isTransducer tapes.entry body iHead wHeads oHead + Β· simp only [entryScanTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact TM.binaryPredTM_isTransducer tapes.count pred iHead wHeads oHead + +/-- Coarse all-prefix auxiliary-space envelope for the bounded scan. -/ +theorem entryScanTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryScanTapes n) (store : Store) (queryBits : List Bool) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryScanTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryScanTM tapes).reachesIn time start current) + (htime : time ≀ entryScanTime tapes queryBits store) : + current.WithinAuxSpace inputLength + (initialSpace + entryScanTime tapes queryBits store) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- One invariant-preserving entry iteration is linear in the two serialized +words and the query width. -/ +theorem entryScanOneTime_le_linear {n : β„•} + (tapes : EntryScanTapes n) (entry : Entry) + (queryBits : List Bool) : + entryScanOneTime tapes entry queryBits ≀ + 400 * (entry.1.bits.length + entry.2.bits.length + + queryBits.length + 1) := + entryScanOneTime_le_linear_internal tapes entry queryBits + +/-- A complete sparse scan is charged by the serialized entries actually +traversed, the repeated query width, and the binary remaining-count overhead. +In particular, it no longer multiplies every entry by a run-wide square-width +envelope. -/ +theorem entryScanTime_le_encoded {n : β„•} + (tapes : EntryScanTapes n) (queryBits : List Bool) (store : Store) : + entryScanTime tapes queryBits store ≀ + 1000 * (encodedStoreLength store + + store.length * (queryBits.length + bitlen store.length + 2) + 1) := + entryScanTime_le_encoded_internal tapes queryBits store + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Defs.lean new file mode 100644 index 0000000000..90d9210ddd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Defs.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs + +/-! +# Bounded sparse-entry scan β€” definitions + +`entryScanTM` is a fixed machine, independent of the runtime store size. A +canonical binary remaining-count tape bounds the scan. Each iteration runs the +checked entry step; a hit leaves its readable result at `1` and halts, while a +miss restores scratch, decrements the count, and loops. Count zero halts with +the blank miss result. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Entry-match tapes plus a distinct canonical binary remaining-count tape. -/ +structure EntryScanTapes (n : β„•) where + /-- The nine tapes used by one decode/compare iteration. -/ + entry : EntryMatchTapes n + /-- Runtime remaining-entry count. -/ + count : Fin n + /-- The count tape is distinct from every entry-step tape. -/ + count_ne : βˆ€ i, count β‰  entry.idx i + +namespace EntryScanTapes + +/-- The count tape is distinct from the encoded entry source. -/ +theorem count_ne_source {n : β„•} (tapes : EntryScanTapes n) : + tapes.count β‰  tapes.entry.source := tapes.count_ne 0 + +/-- The count tape is distinct from the readable match-result tape. -/ +theorem count_ne_result {n : β„•} (tapes : EntryScanTapes n) : + tapes.count β‰  tapes.entry.result := tapes.count_ne 8 + +end EntryScanTapes + +/-- Finite controller phases outside the nested entry-step and predecessor +machines. -/ +inductive EntryScanPhase where + | test + | done + deriving DecidableEq + +/-- `EntryScanPhase` has exactly two states. -/ +instance instFintypeEntryScanPhase : Fintype EntryScanPhase where + elems := {.test, .done} + complete := fun phase => by cases phase <;> simp + +/-- State type of the bounded sparse-entry controller. -/ +abbrev EntryScanQ {n : β„•} (tapes : EntryScanTapes n) := + EntryScanPhase βŠ• ((entryScanStepTM tapes.entry).Q βŠ• (TM.binaryPredTM tapes.count).Q) + +/-- Fixed bounded scan controlled by a runtime canonical binary count. + +The test phase halts on the empty encoding of zero. At positive count it runs +one entry step. A readable `1` result exits immediately with the decoded value; +the blank miss result enters binary predecessor and then loops. -/ +def entryScanTM {n : β„•} (tapes : EntryScanTapes n) : TM n where + Q := EntryScanQ tapes + qstart := .inl .test + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .test => + if wHeads tapes.count = Ξ“.blank then + TM.allReadBack (.inl .done) iHead wHeads oHead + else + TM.allReadBack (.inr (.inl (entryScanStepTM tapes.entry).qstart)) + iHead wHeads oHead + | .inl .done => TM.allIdle (.inl .done) iHead wHeads oHead + | .inr (.inl q) => + if q = (entryScanStepTM tapes.entry).qhalt then + if wHeads tapes.entry.result = Ξ“.one then + TM.allReadBack (.inl .done) iHead wHeads oHead + else + TM.allReadBack (.inr (.inr (TM.binaryPredTM tapes.count).qstart)) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryScanStepTM tapes.entry).Ξ΄ q iHead wHeads oHead + (.inr (.inl q'), workWrites, outputWrite, inputDir, workDirs, outputDir) + | .inr (.inr q) => + if q = (TM.binaryPredTM tapes.count).qhalt then + TM.allReadBack (.inl .test) iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (TM.binaryPredTM tapes.count).Ξ΄ q iHead wHeads oHead + (.inr (.inr q'), workWrites, outputWrite, inputDir, workDirs, outputDir) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .test => + dsimp only + split <;> exact TM.rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact TM.rightOfStart_allIdle iHead wHeads oHead + | .inr (.inl q) => + dsimp only + split + Β· split <;> exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryScanStepTM tapes.entry).Ξ΄_right_of_start q iHead wHeads oHead + | .inr (.inr q) => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (TM.binaryPredTM tapes.count).Ξ΄_right_of_start q iHead wHeads oHead + +/-- Canonical all-blank work family used only to state the iteration bound; +every tape head is at cell one. -/ +def entryScanCanonicalWork {n : β„•} : Fin n β†’ Tape := + Function.const (Fin n) TM.resetBinaryBlank + +/-- Work-value-independent bound for one invariant-preserving entry step. -/ +def entryScanOneTime {n : β„•} (tapes : EntryScanTapes n) + (entry : Entry) (queryBits : List Bool) : β„• := + entryScanStepTime tapes.entry entry queryBits entryScanCanonicalWork + +/-- Recursive bound for scanning a whole finite store. It reserves the miss +path at every entry, so it also bounds an earlier successful exit. -/ +def entryScanTime {n : β„•} (tapes : EntryScanTapes n) + (queryBits : List Bool) : Store β†’ β„• + | [] => 1 + | entry :: rest => + 1 + entryScanOneTime tapes entry queryBits + 1 + + TM.binaryPredTime rest.length + 1 + entryScanTime tapes queryBits rest + +/-- Exact preservation predicate outside the ten tapes owned by the bounded +entry scanner. -/ +def EntryScanFrame {n : β„•} (tapes : EntryScanTapes n) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆ€ i, i β‰  tapes.count β†’ i β‰  tapes.entry.source β†’ + i β‰  tapes.entry.address β†’ i β‰  tapes.entry.value β†’ + i β‰  tapes.entry.addressCounter β†’ i β‰  tapes.entry.addressWidth β†’ + i β‰  tapes.entry.valueCounter β†’ i β‰  tapes.entry.valueWidth β†’ + i β‰  tapes.entry.query β†’ i β‰  tapes.entry.result β†’ + finalWork i = initialWork i + +/-- Successful bounded scan result. The decomposition records the first +matching entry, the decoded value remains readable, and the runtime count is +the number of entries beginning at that hit. -/ +structure EntryScanFound {n : β„•} (tapes : EntryScanTapes n) + (store scanned : Store) (matched : Entry) (rest : Store) + (queryBits : List Bool) (initialWork hitBase finalWork : Fin n β†’ Tape) : + Prop where + store_eq : store = scanned ++ matched :: rest + prefixMiss : βˆ€ prior ∈ scanned, prior.1.bits β‰  queryBits + hit : EntryScanHit tapes.entry matched (rest.flatMap Entry.encode) queryBits + hitBase finalWork + count : (finalWork tapes.count).HasBinaryNat (rest.length + 1) + frame : EntryScanFrame tapes initialWork finalWork + +/-- Unsuccessful bounded scan result. Every address is certified different, +the source and scratch invariant is exhausted, and the runtime count is zero. -/ +structure EntryScanMiss {n : β„•} (tapes : EntryScanTapes n) + (store : Store) (queryBits : List Bool) + (initialWork readyBase finalWork : Fin n β†’ Tape) : Prop where + notFound : βˆ€ entry ∈ store, entry.1.bits β‰  queryBits + ready : EntryScanReady tapes.entry [] queryBits readyBase finalWork + count : (finalWork tapes.count).HasBinaryNat 0 + frame : EntryScanFrame tapes initialWork finalWork + +/-- Complete semantic outcome of a bounded sparse-entry scan. -/ +def EntryScanOutcome {n : β„•} (tapes : EntryScanTapes n) + (store : Store) (queryBits : List Bool) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + (βˆƒ scanned matched rest hitBase, + EntryScanFound tapes store scanned matched rest queryBits initialWork + hitBase finalWork) ∨ + βˆƒ readyBase, + EntryScanMiss tapes store queryBits initialWork readyBase finalWork + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal.lean new file mode 100644 index 0000000000..bc452810ed --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Sem + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Bounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Bounds.lean new file mode 100644 index 0000000000..66beba536e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Bounds.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany + +/-! +# Encoded-length bounds for sparse-entry scans -- proof internals + +The optimized word decoder leaves unary width markers. This makes decoding, +matching, and cleanup linear in the two words actually traversed. The final +scan theorem retains only the separate binary remaining-count charge. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +private theorem entryMissBits_length_le_sum {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) + (queryBits : List Bool) (i : Fin n) : + (entryMissBits tapes entry queryBits i).length ≀ + bitlen entry.1 + bitlen entry.2 + 1 := by + unfold entryMissBits + split_ifs <;> + (try simp only [List.length_nil, List.length_replicate, + List.length_singleton, bitlen, Nat.size_eq_bits_len]) <;> omega + +private theorem entryMissCleanupTime_canonical_le_linear {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) + (queryBits : List Bool) : + entryMissCleanupTime tapes entry queryBits + (entryScanCanonicalWork (n := n)) ≀ + 300 * (entry.1.bits.length + entry.2.bits.length + + queryBits.length + 1) := by + let matchTime := entryMatchReadTime entry queryBits + have hmatch : matchTime ≀ + 5 * entry.1.bits.length + 3 * entry.2.bits.length + + queryBits.length + 18 := + entryMatchReadTime_le_linear_internal entry queryBits + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes) (entryMissBits tapes entry queryBits) + (entryMissHeadBound entry queryBits (entryScanCanonicalWork (n := n))) + (1 + matchTime) (bitlen entry.1 + bitlen entry.2 + 1) + (fun i _ => by + unfold entryMissHeadBound entryScanCanonicalWork + simp [TM.resetBinaryBlank, Tape.move, Tape.init] + dsimp only [matchTime] + exact le_rfl) + (fun i _ => entryMissBits_length_le_sum tapes entry queryBits i) + have htargets : (entryMissTargets tapes).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + have hreset' : + TM.resetBinaryWorkManyTime (entryMissBits tapes entry queryBits) + (fun _ => 1 + matchTime) (entryMissTargets tapes) ≀ + 7 * (1 + matchTime + + 2 * (bitlen entry.1 + bitlen entry.2 + 1) + 9) + 1 := by + simpa [entryMissHeadBound, entryScanCanonicalWork, + TM.resetBinaryBlank, Tape.move, Tape.init] using! hreset + unfold entryMissCleanupTime entryMissHeadBound entryScanCanonicalWork + simp only [Function.const_apply, TM.resetBinaryBlank, Tape.move, Tape.init, + Nat.zero_add] + dsimp only [matchTime] at hmatch hreset' + have haddressWidth : bitlen entry.1 = entry.1.bits.length := by + exact (Nat.size_eq_bits_len entry.1).symm + have hvalueWidth : bitlen entry.2 = entry.2.bits.length := by + exact (Nat.size_eq_bits_len entry.2).symm + rw [haddressWidth, hvalueWidth] at hreset' + omega + +theorem entryScanOneTime_le_linear_internal {n : β„•} + (tapes : EntryScanTapes n) (entry : Entry) + (queryBits : List Bool) : + entryScanOneTime tapes entry queryBits ≀ + 400 * (entry.1.bits.length + entry.2.bits.length + + queryBits.length + 1) := by + have hmatch := entryMatchReadTime_le_linear_internal entry queryBits + have hcleanup := entryMissCleanupTime_canonical_le_linear tapes.entry entry + queryBits + unfold entryScanOneTime entryScanStepTime entryScanBranchTime + TM.branchWorkSymbolTime + have hmax : max 1 + (entryMissCleanupTime tapes.entry entry queryBits + (entryScanCanonicalWork (n := n))) ≀ + 300 * (entry.1.bits.length + entry.2.bits.length + + queryBits.length + 1) := by + apply max_le + Β· nlinarith + Β· exact hcleanup + omega + +theorem entryScanTime_le_encoded_internal {n : β„•} + (tapes : EntryScanTapes n) (queryBits : List Bool) (store : Store) : + entryScanTime tapes queryBits store ≀ + 1000 * (encodedStoreLength store + + store.length * (queryBits.length + bitlen store.length + 2) + 1) := by + induction store with + | nil => simp [entryScanTime, encodedStoreLength] + | cons entry rest ih => + have hone := entryScanOneTime_le_linear_internal tapes entry queryBits + have hpred := TM.binaryPredTime_le rest.length + have hsize : bitlen rest.length ≀ bitlen (rest.length + 1) := by + unfold bitlen + exact Nat.size_le_size (by omega) + have hfactor : queryBits.length + bitlen rest.length + 2 ≀ + queryBits.length + bitlen (rest.length + 1) + 2 := by omega + have hinside : encodedStoreLength rest + + rest.length * (queryBits.length + bitlen rest.length + 2) + 1 ≀ + encodedStoreLength rest + + rest.length * + (queryBits.length + bitlen (rest.length + 1) + 2) + 1 := by + exact Nat.add_le_add_right + (Nat.add_le_add_left (Nat.mul_le_mul_left rest.length hfactor) _) + 1 + have htail : entryScanTime tapes queryBits rest ≀ + 1000 * (encodedStoreLength rest + + rest.length * + (queryBits.length + bitlen (rest.length + 1) + 2) + 1) := + le_trans ih (Nat.mul_le_mul_left 1000 hinside) + have hentryLength : (Entry.encode entry).length = + 2 * entry.1.bits.length + 2 * entry.2.bits.length + 2 := by + rw [Entry.encode_length] + simp only [bitlen, Nat.size_eq_bits_len] + simp only [entryScanTime, List.length_cons] + have hencoded : encodedStoreLength (entry :: rest) = + (Entry.encode entry).length + encodedStoreLength rest := by + simp [encodedStoreLength] + rw [hencoded, hentryLength] + simp only [bitlen] at hsize ⊒ + have hmul : (rest.length + 1) * + (queryBits.length + (rest.length + 1).size + 2) = + rest.length * + (queryBits.length + (rest.length + 1).size + 2) + + (queryBits.length + (rest.length + 1).size + 2) := by ring + rw [hmul] + simp only [bitlen] at htail + omega + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Ctrl.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Ctrl.lean new file mode 100644 index 0000000000..29faf867cb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Ctrl.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs + +/-! +# Bounded sparse-entry scan β€” controller internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Embed an entry-step configuration in the bounded scan controller. -/ +def entryScanBodyWrap (tapes : EntryScanTapes n) + (cfg : Complexity.Cfg n (entryScanStepTM tapes.entry).Q) : + Complexity.Cfg n (entryScanTM tapes).Q where + state := .inr (.inl cfg.state) + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed a binary-predecessor configuration in the bounded scan controller. -/ +def entryScanPredWrap (tapes : EntryScanTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.count).Q) : + Complexity.Cfg n (entryScanTM tapes).Q where + state := .inr (.inr cfg.state) + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Canonical halted controller configuration with the supplied tapes. -/ +def entryScanDoneCfg (tapes : EntryScanTapes n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Complexity.Cfg n (entryScanTM tapes).Q where + state := .inl .done + input := inp + work := work + output := out + +/-- Canonical loop-test controller configuration with the supplied tapes. -/ +def entryScanTestCfg (tapes : EntryScanTapes n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Complexity.Cfg n (entryScanTM tapes).Q where + state := .inl .test + input := inp + work := work + output := out + +private theorem entryScanTM_body_step + (tapes : EntryScanTapes n) + {cfg next : Complexity.Cfg n (entryScanStepTM tapes.entry).Q} + (hstep : (entryScanStepTM tapes.entry).step cfg = some next) : + (entryScanTM tapes).step (entryScanBodyWrap tapes cfg) = + some (entryScanBodyWrap tapes next) := by + have hne : cfg.state β‰  (entryScanStepTM tapes.entry).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [entryScanBodyWrap, entryScanTM])] + simp only [entryScanBodyWrap, entryScanTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryScanStepTM tapes.entry).Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryScanTM_pred_step + (tapes : EntryScanTapes n) + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.count).Q} + (hstep : (TM.binaryPredTM tapes.count).step cfg = some next) : + (entryScanTM tapes).step (entryScanPredWrap tapes cfg) = + some (entryScanPredWrap tapes next) := by + have hne : cfg.state β‰  (TM.binaryPredTM tapes.count).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [entryScanPredWrap, entryScanTM])] + simp only [entryScanPredWrap, entryScanTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (TM.binaryPredTM tapes.count).Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +theorem entryScanTM_body_reachesIn_internal + (tapes : EntryScanTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryScanStepTM tapes.entry).Q} + (hreach : (entryScanStepTM tapes.entry).reachesIn time cfg next) : + (entryScanTM tapes).reachesIn time + (entryScanBodyWrap tapes cfg) (entryScanBodyWrap tapes next) := + TM.reachesIn_map (entryScanBodyWrap tapes) + (fun _ _ => entryScanTM_body_step tapes) hreach + +theorem entryScanTM_pred_reachesIn_internal + (tapes : EntryScanTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.count).Q} + (hreach : (TM.binaryPredTM tapes.count).reachesIn time cfg next) : + (entryScanTM tapes).reachesIn time + (entryScanPredWrap tapes cfg) (entryScanPredWrap tapes next) := + TM.reachesIn_map (entryScanPredWrap tapes) + (fun _ _ => entryScanTM_pred_step tapes) hreach + +theorem entryScanTM_step_test_zero_internal + (tapes : EntryScanTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hcount : (work tapes.count).read = Ξ“.blank) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryScanTM tapes).step + { state := .inl .test, input := inp, work := work, output := out } = + some { state := .inl .done, input := inp, work := work, output := out } := by + rw [TM.step, ite_eq_right (by simp [entryScanTM])] + simp only [entryScanTM, hcount, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryScanTM_step_test_positive_internal + (tapes : EntryScanTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hcount : (work tapes.count).read β‰  Ξ“.blank) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryScanTM tapes).step + { state := .inl .test, input := inp, work := work, output := out } = + some (entryScanBodyWrap tapes + { state := (entryScanStepTM tapes.entry).qstart + input := inp, work := work, output := out }) := by + rw [TM.step, ite_eq_right (by simp [entryScanTM])] + simp only [entryScanTM, hcount, ↓reduceIte, entryScanBodyWrap] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryScanTM_step_body_hit_internal + (tapes : EntryScanTapes n) + (cfg : Complexity.Cfg n (entryScanStepTM tapes.entry).Q) + (hhalt : (entryScanStepTM tapes.entry).halted cfg) + (hresult : (cfg.work tapes.entry.result).read = Ξ“.one) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryScanTM tapes).step (entryScanBodyWrap tapes cfg) = + some (entryScanDoneCfg tapes cfg.input cfg.work cfg.output) := by + rw [TM.step, ite_eq_right (by simp [entryScanBodyWrap, entryScanTM])] + simp only [entryScanBodyWrap, entryScanDoneCfg, entryScanTM, hhalt, + hresult, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryScanTM_step_body_miss_internal + (tapes : EntryScanTapes n) + (cfg : Complexity.Cfg n (entryScanStepTM tapes.entry).Q) + (hhalt : (entryScanStepTM tapes.entry).halted cfg) + (hresult : (cfg.work tapes.entry.result).read β‰  Ξ“.one) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryScanTM tapes).step (entryScanBodyWrap tapes cfg) = + some (entryScanPredWrap tapes + { state := (TM.binaryPredTM tapes.count).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryScanBodyWrap, entryScanTM])] + simp only [entryScanBodyWrap, entryScanTM, hhalt, hresult, ↓reduceIte, + entryScanPredWrap] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryScanTM_step_pred_halt_internal + (tapes : EntryScanTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.count).Q) + (hhalt : (TM.binaryPredTM tapes.count).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryScanTM tapes).step (entryScanPredWrap tapes cfg) = + some (entryScanTestCfg tapes cfg.input cfg.work cfg.output) := by + rw [TM.step, ite_eq_right (by simp [entryScanPredWrap, entryScanTM])] + simp only [entryScanPredWrap, entryScanTestCfg, entryScanTM, hhalt, + ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Inv.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Inv.lean new file mode 100644 index 0000000000..9646ffc320 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Inv.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import Mathlib.Tactic.FinCases +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Bounded sparse-entry scan β€” invariant internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem resetBinaryBlank_head : TM.resetBinaryBlank.head = 1 := by + simp [TM.resetBinaryBlank, Tape.init, Tape.move] + +private theorem parked_of_hasBinaryNat {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + exact ⟨by simp [Tape.HasBinaryNat, Tape.HasBinaryString] at h; omega, + h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem EntryScanReady.target_head + {tapes : EntryMatchTapes n} {remaining queryBits : List Bool} + {initialWork work : Fin n β†’ Tape} + (h : EntryScanReady tapes remaining queryBits initialWork work) : + βˆ€ i, i ∈ entryMissTargets tapes β†’ (work i).head = 1 := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· simpa using h.address.1 + Β· simpa using h.value.1 + Β· exact h.addressCounter.2.1 + Β· exact h.addressWidth.2.1 + Β· exact h.valueCounter.2.1 + Β· exact h.valueWidth.2.1 + Β· simpa using h.result.1 + +theorem EntryScanReady.stepTime_eq_oneTime_internal + {tapes : EntryScanTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork work : Fin n β†’ Tape} + (h : EntryScanReady tapes.entry (Entry.encode entry ++ rest) queryBits + initialWork work) : + entryScanStepTime tapes.entry entry queryBits work = + entryScanOneTime tapes entry queryBits := by + have hquery : + entryMissHeadBound entry queryBits work tapes.entry.query = + entryMissHeadBound entry queryBits entryScanCanonicalWork + tapes.entry.query := by + simp [entryMissHeadBound, entryScanCanonicalWork, h.query.1, + resetBinaryBlank_head] + have htargets : βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + entryMissHeadBound entry queryBits work i = + entryMissHeadBound entry queryBits entryScanCanonicalWork i := by + intro i hi + simp [entryMissHeadBound, entryScanCanonicalWork, h.target_head i hi, + resetBinaryBlank_head] + have hreset := TM.resetBinaryWorkManyTime_congr_headBound + (entryMissTargets tapes.entry) (entryMissBits tapes.entry entry queryBits) + (entryMissHeadBound entry queryBits work) + (entryMissHeadBound entry queryBits entryScanCanonicalWork) htargets + unfold entryScanOneTime entryScanStepTime entryScanBranchTime + entryMissCleanupTime TM.branchWorkSymbolTime + rw [hquery, hreset] + +/-- Forget an older frame base and use the current work family as the exact +base for the next loop iteration. -/ +theorem EntryScanReady.rebase_self_internal + {tapes : EntryMatchTapes n} {remaining queryBits : List Bool} + {initialWork work : Fin n β†’ Tape} + (h : EntryScanReady tapes remaining queryBits initialWork work) : + EntryScanReady tapes remaining queryBits work work := by + refine ⟨h.source, h.address, h.addressStart, h.value, h.valueStart, + h.addressCounter, h.addressWidth, h.valueCounter, h.valueWidth, + h.query, h.queryStart, h.result, h.resultStart, h.parked, ?_⟩ + intro i _ _ _ _ _ _ _ _ _ + rfl + +/-- Changing only the distinct count tape preserves the entry-loop invariant; +the new count representation supplies parkedness for that tape. -/ +theorem EntryScanReady.change_count_internal + {tapes : EntryScanTapes n} {remaining queryBits : List Bool} + {initialWork work finalWork : Fin n β†’ Tape} {count : β„•} + (h : EntryScanReady tapes.entry remaining queryBits initialWork work) + (hother : βˆ€ i, i β‰  tapes.count β†’ finalWork i = work i) + (hcount : (finalWork tapes.count).HasBinaryNat count) : + EntryScanReady tapes.entry remaining queryBits finalWork finalWork := by + have hsource := hother tapes.entry.source (Ne.symm (tapes.count_ne 0)) + have haddress := hother tapes.entry.address (Ne.symm (tapes.count_ne 1)) + have hvalue := hother tapes.entry.value (Ne.symm (tapes.count_ne 2)) + have haddressCounter := + hother tapes.entry.addressCounter (Ne.symm (tapes.count_ne 3)) + have haddressWidth := + hother tapes.entry.addressWidth (Ne.symm (tapes.count_ne 4)) + have hvalueCounter := + hother tapes.entry.valueCounter (Ne.symm (tapes.count_ne 5)) + have hvalueWidth := + hother tapes.entry.valueWidth (Ne.symm (tapes.count_ne 6)) + have hquery := hother tapes.entry.query (Ne.symm (tapes.count_ne 7)) + have hresult := hother tapes.entry.result (Ne.symm (tapes.count_ne 8)) + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [hsource] + exact h.source + Β· rw [haddress] + exact h.address + Β· rw [haddress] + exact h.addressStart + Β· rw [hvalue] + exact h.value + Β· rw [hvalue] + exact h.valueStart + Β· rw [haddressCounter] + exact h.addressCounter + Β· rw [haddressWidth] + exact h.addressWidth + Β· rw [hvalueCounter] + exact h.valueCounter + Β· rw [hvalueWidth] + exact h.valueWidth + Β· rw [hquery] + exact h.query + Β· rw [hquery] + exact h.queryStart + Β· rw [hresult] + exact h.result + Β· rw [hresult] + exact h.resultStart + Β· intro i + by_cases hi : i = tapes.count + Β· subst i + exact parked_of_hasBinaryNat hcount + Β· rw [hother i hi] + exact h.parked i + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + +/-- An entry-ready frame implies the scanner's weaker ten-tape frame. -/ +theorem EntryScanReady.scanFrame_internal + {tapes : EntryScanTapes n} {remaining queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanReady tapes.entry remaining queryBits initialWork finalWork) : + EntryScanFrame tapes initialWork finalWork := by + intro i _ hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact h.frame i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + +/-- A successful entry endpoint implies the scanner's ten-tape frame. -/ +theorem EntryScanHit.scanFrame_internal + {tapes : EntryScanTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanHit tapes.entry entry rest queryBits initialWork finalWork) : + EntryScanFrame tapes initialWork finalWork := by + intro i _ hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact h.frame i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + +/-- Scanner frames compose across loop iterations. -/ +theorem EntryScanFrame.trans_internal + {tapes : EntryScanTapes n} {workβ‚€ work₁ workβ‚‚ : Fin n β†’ Tape} + (h₁ : EntryScanFrame tapes workβ‚€ work₁) + (hβ‚‚ : EntryScanFrame tapes work₁ workβ‚‚) : + EntryScanFrame tapes workβ‚€ workβ‚‚ := by + intro i hcount hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact (hβ‚‚ i hcount hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult).trans + (h₁ i hcount hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult) + +/-- The count tape is in the frame of every entry-ready endpoint. -/ +theorem EntryScanReady.count_eq_internal + {tapes : EntryScanTapes n} {remaining queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanReady tapes.entry remaining queryBits initialWork finalWork) : + finalWork tapes.count = initialWork tapes.count := + h.frame tapes.count (tapes.count_ne 0) (tapes.count_ne 1) + (tapes.count_ne 2) (tapes.count_ne 3) (tapes.count_ne 4) + (tapes.count_ne 5) (tapes.count_ne 6) (tapes.count_ne 7) + (tapes.count_ne 8) + +/-- The count tape is in the frame of every successful entry endpoint. -/ +theorem EntryScanHit.count_eq_internal + {tapes : EntryScanTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanHit tapes.entry entry rest queryBits initialWork finalWork) : + finalWork tapes.count = initialWork tapes.count := + h.frame tapes.count (tapes.count_ne 0) (tapes.count_ne 1) + (tapes.count_ne 2) (tapes.count_ne 3) (tapes.count_ne 4) + (tapes.count_ne 5) (tapes.count_ne 6) (tapes.count_ne 7) + (tapes.count_ne 8) + +/-- A restored miss invariant exposes a blank readable result. -/ +theorem EntryScanReady.result_read_blank_internal + {tapes : EntryMatchTapes n} {remaining queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanReady tapes remaining queryBits initialWork finalWork) : + (finalWork tapes.result).read = Ξ“.blank := + h.result.read_blank + +/-- A successful hit exposes the readable one flag. -/ +theorem EntryScanHit.result_read_one_internal + {tapes : EntryMatchTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanHit tapes entry rest queryBits initialWork finalWork) : + (finalWork tapes.result).read = Ξ“.one := by + rw [Tape.read, h.result.1] + simpa [Ξ“.ofBool] using h.result.2.1 0 (by simp) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Sem.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Sem.lean new file mode 100644 index 0000000000..8e3f81ac19 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScan/Internal/Sem.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep + +/-! +# Bounded sparse-entry scan β€” semantic internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +theorem entryScanTM_hoareTime_frame_internal + (tapes : EntryScanTapes n) (store : Store) (queryBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + queryBits initialWork initialWork) + (hcount : (initialWork tapes.count).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryScanTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryScanOutcome tapes store queryBits initialWork work ∧ + out = outβ‚€) + (entryScanTime tapes queryBits store) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + induction store generalizing initialWork with + | nil => + have hblank : (initialWork tapes.count).read = Ξ“.blank := + hcount.read_eq_blank_iff.mpr rfl + have hstep := entryScanTM_step_test_zero_internal tapes inpβ‚€ initialWork + outβ‚€ hblank hinput hready.parked houtput + refine ⟨entryScanDoneCfg tapes inpβ‚€ initialWork outβ‚€, 1, ?_, + .step hstep .zero, ?_, rfl, ?_, rfl⟩ + Β· simp [entryScanTime] + Β· rfl + Β· exact Or.inr ⟨initialWork, ⟨by simp, hready, hcount, by + intro i _ _ _ _ _ _ _ _ _ _ + simp [entryScanDoneCfg]⟩⟩ + | cons entry rest ih => + have hreadyStep : + EntryScanReady tapes.entry + (Entry.encode entry ++ rest.flatMap Entry.encode) queryBits + initialWork initialWork := by + simpa using hready + have hcountPositive : + (initialWork tapes.count).HasBinaryNat (rest.length + 1) := by + simpa using hcount + have hnonblank : (initialWork tapes.count).read β‰  Ξ“.blank := by + intro hblank + have hzero := hcountPositive.read_eq_blank_iff.mp hblank + omega + have htest := entryScanTM_step_test_positive_internal tapes inpβ‚€ + initialWork outβ‚€ hnonblank hinput hready.parked houtput + have hstepContract := entryScanStepTM_hoareTime_frame tapes.entry entry + (rest.flatMap Entry.encode) queryBits initialWork initialWork inpβ‚€ outβ‚€ + hreadyStep hinput houtput + obtain ⟨bodyDone, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hstepOutcome, hbodyOutput⟩ := + hstepContract inpβ‚€ initialWork outβ‚€ ⟨rfl, rfl, rfl⟩ + have hbodyTime' : + bodyTime ≀ entryScanOneTime tapes entry queryBits := by + simpa [hreadyStep.stepTime_eq_oneTime_internal] using hbodyTime + have hbodyReach' := + entryScanTM_body_reachesIn_internal tapes hbodyReach + rcases hstepOutcome with hhitTagged | hmissTagged + Β· rcases hhitTagged with ⟨_, hhit⟩ + have hfinish := entryScanTM_step_body_hit_internal tapes bodyDone + hbodyHalt hhit.result_read_one_internal + (hbodyInput β–Έ hinput) hhit.parked (hbodyOutput β–Έ houtput) + have hprefix : (entryScanTM tapes).reachesIn (bodyTime + 1) + (entryScanTestCfg tapes inpβ‚€ initialWork outβ‚€) + (entryScanBodyWrap tapes bodyDone) := + .step htest hbodyReach' + have hreach : (entryScanTM tapes).reachesIn + (bodyTime + 1 + 1) + (entryScanTestCfg tapes inpβ‚€ initialWork outβ‚€) + (entryScanDoneCfg tapes bodyDone.input bodyDone.work + bodyDone.output) := + TM.reachesIn_trans _ hprefix (.step hfinish .zero) + refine ⟨entryScanDoneCfg tapes bodyDone.input bodyDone.work + bodyDone.output, bodyTime + 1 + 1, ?_, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp only [entryScanTime] + omega + Β· simpa [entryScanTestCfg, entryScanTM] using hreach + Β· simpa [entryScanDoneCfg] using hbodyInput + Β· exact Or.inl ⟨[], entry, rest, initialWork, ⟨by simp, by simp, + hhit, by + simpa [entryScanDoneCfg, hhit.count_eq_internal] using + hcountPositive, + hhit.scanFrame_internal⟩⟩ + Β· simpa [entryScanDoneCfg] using hbodyOutput + Β· rcases hmissTagged with ⟨hneq, hmiss⟩ + have hdispatch := entryScanTM_step_body_miss_internal tapes bodyDone + hbodyHalt (by + rw [hmiss.result_read_blank_internal] + decide) + (hbodyInput β–Έ hinput) hmiss.parked (hbodyOutput β–Έ houtput) + have hcountBody : + (bodyDone.work tapes.count).HasBinaryNat (rest.length + 1) := by + rw [hmiss.count_eq_internal] + exact hcountPositive + obtain ⟨predDone, hpredReach, hpredHalt, hpredInput, + hpredOther, hpredCount, hpredOutput⟩ := + TM.binaryPredTM_reachesIn_frame tapes.count rest.length + bodyDone.input bodyDone.work bodyDone.output hcountBody + (hbodyInput β–Έ hinput.read_ne_start) + (fun i _ => (hmiss.parked i).read_ne_start) + (hbodyOutput β–Έ houtput.read_ne_start) + have hpredReach' := + entryScanTM_pred_reachesIn_internal tapes hpredReach + have hreadyPred := hmiss.change_count_internal hpredOther hpredCount + have hloop := entryScanTM_step_pred_halt_internal tapes predDone + hpredHalt (by + rw [hpredInput, hbodyInput] + exact hinput) + hreadyPred.parked (by + rw [hpredOutput, hbodyOutput] + exact houtput) + have hpredInput0 : predDone.input = inpβ‚€ := + hpredInput.trans hbodyInput + have hpredOutput0 : predDone.output = outβ‚€ := + hpredOutput.trans hbodyOutput + have hloop' : (entryScanTM tapes).step + (entryScanPredWrap tapes predDone) = + some (entryScanTestCfg tapes inpβ‚€ predDone.work outβ‚€) := by + simpa [hpredInput0, hpredOutput0] using hloop + obtain ⟨final, recTime, hrecTime, hrecReach, hrecHalt, + hrecInput, hrecOutcome, hrecOutput⟩ := + ih predDone.work hreadyPred hpredCount + have hentryFrame : + EntryScanFrame tapes initialWork bodyDone.work := + hmiss.scanFrame_internal + have hpredFrame : + EntryScanFrame tapes bodyDone.work predDone.work := by + intro i hcountIdx _ _ _ _ _ _ _ _ _ + exact hpredOther i hcountIdx + have hphaseFrame : + EntryScanFrame tapes initialWork predDone.work := + hentryFrame.trans_internal hpredFrame + have hprefix : (entryScanTM tapes).reachesIn + (bodyTime + 1 + 1 + TM.binaryPredTime rest.length + 1) + (entryScanTestCfg tapes inpβ‚€ initialWork outβ‚€) + (entryScanTestCfg tapes inpβ‚€ predDone.work outβ‚€) := by + have htestBody : (entryScanTM tapes).reachesIn (bodyTime + 1) + (entryScanTestCfg tapes inpβ‚€ initialWork outβ‚€) + (entryScanBodyWrap tapes bodyDone) := + .step htest hbodyReach' + have htoPred : (entryScanTM tapes).reachesIn + (bodyTime + 1 + 1) + (entryScanTestCfg tapes inpβ‚€ initialWork outβ‚€) + (entryScanPredWrap tapes + { state := (TM.binaryPredTM tapes.count).qstart + input := bodyDone.input + work := bodyDone.work + output := bodyDone.output }) := + TM.reachesIn_trans _ htestBody (.step hdispatch .zero) + have hthroughPred := + TM.reachesIn_trans (entryScanTM tapes) htoPred hpredReach' + have hthroughLoop := TM.reachesIn_trans (entryScanTM tapes) + hthroughPred (.step hloop' .zero) + simpa [Nat.add_assoc] using hthroughLoop + have hreach := + TM.reachesIn_trans (entryScanTM tapes) hprefix hrecReach + refine ⟨final, + bodyTime + 1 + 1 + TM.binaryPredTime rest.length + 1 + recTime, + ?_, ?_, hrecHalt, hrecInput, ?_, hrecOutput⟩ + Β· simp only [entryScanTime] + omega + Β· simpa [entryScanTestCfg, entryScanTM, Nat.add_assoc] using hreach + Β· rcases hrecOutcome with hfound | hnone + Β· rcases hfound with ⟨scanned, matched, suffix, hitBase, hfound⟩ + exact Or.inl ⟨entry :: scanned, matched, suffix, hitBase, + ⟨by simp [hfound.store_eq], by + intro prior hprior + simp only [List.mem_cons] at hprior + rcases hprior with rfl | hprior + Β· exact hneq + Β· exact hfound.prefixMiss prior hprior, + hfound.hit, hfound.count, + hphaseFrame.trans_internal hfound.frame⟩⟩ + Β· rcases hnone with ⟨readyBase, hnone⟩ + exact Or.inr ⟨readyBase, + ⟨by + intro candidate hcand + simp only [List.mem_cons] at hcand + rcases hcand with rfl | hcand + Β· exact hneq + Β· exact hnone.notFound candidate hcand, + hnone.ready, hnone.count, + hphaseFrame.trans_internal hnone.frame⟩⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep.lean new file mode 100644 index 0000000000..a6cfa6a848 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Internal + +/-! +# One bounded sparse-entry scan iteration + +This module exposes the compositional hit-or-next-iteration contract for one +encoded sparse register-store entry. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Decode and compare one entry, then either expose its decoded value on a +hit or restore the exact invariant for the remaining encoded stream. -/ +theorem entryScanStepTM_hoareTime_frame {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork iterationWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes (Entry.encode entry ++ rest) queryBits + initialWork iterationWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryScanStepTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = iterationWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ((entry.1.bits = queryBits ∧ + EntryScanHit tapes entry rest queryBits initialWork work) ∨ + (entry.1.bits β‰  queryBits ∧ + EntryScanReady tapes rest queryBits initialWork work)) ∧ + out = outβ‚€) + (entryScanStepTime tapes entry queryBits iterationWork) := + entryScanStepTM_hoareTime_frame_internal tapes entry rest queryBits + initialWork iterationWork inpβ‚€ outβ‚€ hready hinput houtput + +/-- One scan iteration preserves one-way output safety. -/ +theorem entryScanStepTM_isTransducer {n : β„•} (tapes : EntryMatchTapes n) : + (entryScanStepTM tapes).IsTransducer := by + have hskip : (TM.skipTM (n := n)).IsTransducer := by + intro state iHead wHeads oHead + cases state <;> cases oHead <;> simp [TM.skipTM, TM.idleDir] + unfold entryScanStepTM entryScanBranchTM + exact (entryMatchReadTM_isTransducer tapes).seqTM + (hskip.branchWorkSymbolTM (entryMissCleanupTM_isTransducer tapes)) + +/-- Coarse all-prefix auxiliary-space envelope for one scan iteration. -/ +theorem entryScanStepTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) (queryBits : List Bool) + (initialWork : Fin n β†’ Tape) (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryScanStepTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryScanStepTM tapes).reachesIn time start current) + (htime : time ≀ entryScanStepTime tapes entry queryBits initialWork) : + current.WithinAuxSpace inputLength + (initialSpace + entryScanStepTime tapes entry queryBits initialWork) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Defs.lean new file mode 100644 index 0000000000..27863760cb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Defs.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs + +/-! +# One bounded sparse-entry scan iteration β€” definitions + +One iteration decodes and compares the next entry, branches directly on the +readable equality flag, preserves the decoded value on a hit, and restores the +next-iteration scratch invariant on a miss. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Direct hit/miss branch selected by the readable equality-result tape. -/ +def entryScanBranchTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.branchWorkSymbolTM tapes.result Ξ“.one TM.skipTM (entryMissCleanupTM tapes) + +/-- Decode, compare, and dispatch one encoded sparse entry. -/ +def entryScanStepTM {n : β„•} (tapes : EntryMatchTapes n) : TM n := + TM.seqTM (entryMatchReadTM tapes) (entryScanBranchTM tapes) + +/-- Coarse branch bound covering both the one-step hit and miss cleanup. -/ +def entryScanBranchTime {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (queryBits : List Bool) (initialWork : Fin n β†’ Tape) : β„• := + TM.branchWorkSymbolTime 1 + (entryMissCleanupTime tapes entry queryBits initialWork) + +/-- Compositional time bound for one complete scan iteration. -/ +def entryScanStepTime {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (queryBits : List Bool) (initialWork : Fin n β†’ Tape) : β„• := + entryMatchReadTime entry queryBits + 1 + + entryScanBranchTime tapes entry queryBits initialWork + +/-- Successful scan endpoint exposing the decoded value and the global +external frame. -/ +structure EntryScanHit {n : β„•} (tapes : EntryMatchTapes n) + (entry : Entry) (rest queryBits : List Bool) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + addressEq : entry.1.bits = queryBits + source : (finalWork tapes.source).HasBinarySuffix rest + value : (finalWork tapes.value).HasBinaryPrefix entry.2.bits + valueStart : (finalWork tapes.value).cells 0 = Ξ“.start + query : (finalWork tapes.query).HasBinaryContent queryBits + queryStart : (finalWork tapes.query).cells 0 = Ξ“.start + result : (finalWork tapes.result).HasBinaryString [true] + resultStart : (finalWork tapes.result).cells 0 = Ξ“.start + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, i β‰  tapes.source β†’ i β‰  tapes.address β†’ + i β‰  tapes.value β†’ i β‰  tapes.addressCounter β†’ + i β‰  tapes.addressWidth β†’ i β‰  tapes.valueCounter β†’ + i β‰  tapes.valueWidth β†’ i β‰  tapes.query β†’ i β‰  tapes.result β†’ + finalWork i = initialWork i + /-- The complete readable-match endpoint is retained for downstream + consumers that must reset every decoder scratch tape after a hit. -/ + readable : βˆƒ iterationWork, + ReadableEntryMatch tapes entry rest queryBits iterationWork finalWork + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Internal.lean new file mode 100644 index 0000000000..ca30b41bb7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryScanStep/Internal.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryCleanup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScanStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch + +/-! +# One bounded sparse-entry scan iteration β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem readableEntryMatch_to_hit + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork iterationWork matchedWork : Fin n β†’ Tape) + (hready : EntryScanReady tapes (Entry.encode entry ++ rest) queryBits + initialWork iterationWork) + (hmatch : ReadableEntryMatch tapes entry rest queryBits iterationWork matchedWork) + (heq : entry.1.bits = queryBits) : + EntryScanHit tapes entry rest queryBits initialWork matchedWork := by + refine ⟨heq, hmatch.source, hmatch.value, hmatch.valueStart, + hmatch.query, hmatch.queryStart, ?_, hmatch.resultStart, + hmatch.parked, ?_, ⟨iterationWork, hmatch⟩⟩ + Β· simpa [heq] using hmatch.result + Β· intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact (hmatch.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult).trans + (hready.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult) + +private theorem entryScanReady_reframe + (tapes : EntryMatchTapes n) (consumed rest queryBits : List Bool) + (initialWork iterationWork finalWork : Fin n β†’ Tape) + (hready : EntryScanReady tapes consumed queryBits initialWork iterationWork) + (hfinal : EntryScanReady tapes rest queryBits iterationWork finalWork) : + EntryScanReady tapes rest queryBits initialWork finalWork := by + refine ⟨hfinal.source, hfinal.address, hfinal.addressStart, + hfinal.value, hfinal.valueStart, hfinal.addressCounter, + hfinal.addressWidth, hfinal.valueCounter, hfinal.valueWidth, + hfinal.query, hfinal.queryStart, hfinal.result, hfinal.resultStart, + hfinal.parked, ?_⟩ + intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact (hfinal.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult).trans + (hready.frame i hsource haddress hvalue haddressCounter + haddressWidth hvalueCounter hvalueWidth hquery hresult) + +theorem entryScanStepTM_hoareTime_frame_internal + (tapes : EntryMatchTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork iterationWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryScanReady tapes (Entry.encode entry ++ rest) queryBits + initialWork iterationWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryScanStepTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = iterationWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ((entry.1.bits = queryBits ∧ + EntryScanHit tapes entry rest queryBits initialWork work) ∨ + (entry.1.bits β‰  queryBits ∧ + EntryScanReady tapes rest queryBits initialWork work)) ∧ + out = outβ‚€) + (entryScanStepTime tapes entry queryBits iterationWork) := by + have hmatchRun : (entryMatchReadTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = iterationWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ReadableEntryMatch tapes entry rest queryBits iterationWork work ∧ + out = outβ‚€) + (entryMatchReadTime entry queryBits) := by + intro inp work out hpre + rcases hpre with ⟨hinpEq, hworkEq, houtEq⟩ + subst inp + subst work + subst out + obtain ⟨c', t, ht, hreach, hhalt, hinp, hmatch, hout⟩ := + entryMatchReadTM_reachesIn_frame tapes entry rest queryBits inpβ‚€ + iterationWork outβ‚€ hready.source hready.address hready.value + hready.addressStart hready.valueStart hready.addressCounter + hready.addressWidth hready.valueCounter hready.valueWidth hready.query + hready.queryStart hready.result hready.resultStart hinput hready.parked + houtput + exact ⟨c', t, ht, hreach, hhalt, hinp, hmatch, hout⟩ + have hbranch : (entryScanBranchTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + ReadableEntryMatch tapes entry rest queryBits iterationWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ((entry.1.bits = queryBits ∧ + EntryScanHit tapes entry rest queryBits initialWork work) ∨ + (entry.1.bits β‰  queryBits ∧ + EntryScanReady tapes rest queryBits initialWork work)) ∧ + out = outβ‚€) + (entryScanBranchTime tapes entry queryBits iterationWork) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hmatch, hout⟩ + subst inp + subst out + by_cases heq : entry.1.bits = queryBits + Β· have hread : (work tapes.result).read = Ξ“.one := + hmatch.result_read_eq_one_iff.mpr heq + have hskip := TM.skipTM_hoareTime_frame inpβ‚€ work outβ‚€ hinput + hmatch.parked houtput + obtain ⟨c', t, ht, hreach, hhalt, hinp', hwork', hout'⟩ := + hskip inpβ‚€ work outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨C, hbranchReach, hbranchHalt, hCinput, hCwork, hCoutput⟩ := + TM.branchWorkSymbolTM_reachesIn_equal_frame tapes.result Ξ“.one + TM.skipTM (entryMissCleanupTM tapes) inpβ‚€ work outβ‚€ hread + hinput.read_ne_start (fun i => (hmatch.parked i).read_ne_start) + houtput.read_ne_start hreach hhalt + have hhit := readableEntryMatch_to_hit tapes entry rest queryBits + initialWork iterationWork work hready hmatch heq + refine ⟨C, t + 1, ?_, hbranchReach, hbranchHalt, ?_⟩ + Β· unfold entryScanBranchTime TM.branchWorkSymbolTime + omega + Β· refine ⟨hCinput.trans hinp', Or.inl ⟨heq, ?_⟩, + hCoutput.trans hout'⟩ + rw [hCwork, hwork'] + exact hhit + Β· have hread : (work tapes.result).read β‰  Ξ“.one := by + exact fun h => heq (hmatch.result_read_eq_one_iff.mp h) + have hcleanup := entryMissCleanupTM_hoareTime_frame tapes entry rest + queryBits iterationWork work inpβ‚€ outβ‚€ hmatch hinput houtput + obtain ⟨c', t, ht, hreach, hhalt, hinp', hready', hout'⟩ := + hcleanup inpβ‚€ work outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨C, hbranchReach, hbranchHalt, hCinput, hCwork, hCoutput⟩ := + TM.branchWorkSymbolTM_reachesIn_different_frame tapes.result Ξ“.one + TM.skipTM (entryMissCleanupTM tapes) inpβ‚€ work outβ‚€ hread + hinput.read_ne_start (fun i => (hmatch.parked i).read_ne_start) + houtput.read_ne_start hreach hhalt + have hreadyGlobal := entryScanReady_reframe tapes + (Entry.encode entry ++ rest) rest queryBits initialWork iterationWork + c'.work hready hready' + refine ⟨C, t + 1, ?_, hbranchReach, hbranchHalt, ?_⟩ + Β· unfold entryScanBranchTime TM.branchWorkSymbolTime + omega + Β· refine ⟨hCinput.trans hinp', Or.inr ⟨heq, ?_⟩, + hCoutput.trans hout'⟩ + rw [hCwork] + exact hreadyGlobal + have hseq := TM.seqTM_hoareTime (entryMatchReadTM tapes) + (entryScanBranchTM tapes) hmatchRun + (by + intro inp work out hmid + rcases hmid with ⟨hinp, hmatch, hout⟩ + obtain ⟨hinpTransition, hworkTransition, houtTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + (hinp β–Έ hinput.read_ne_start) + (fun i => (hmatch.parked i).read_ne_start) + (hout β–Έ houtput.read_ne_start) + rw [hinpTransition, hworkTransition, houtTransition] + exact ⟨hinp, hmatch, hout⟩) + hbranch + simpa [entryScanStepTM, entryScanStepTime] using hseq + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate.lean new file mode 100644 index 0000000000..429b68faca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.BoundsInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Source + +/-! +# Bounded encoded sparse-store update + +This module exposes the complete fixed-controller implementation of one +canonical sparse-store write. The machine scans a runtime-counted old store, +copies misses, replaces or deletes the unique hit, and appends a fresh nonzero +entry exactly when the address was absent. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The encoded source cursor may move during an update, but its complete cell +contents are read-only. -/ +theorem entryUpdateTM_source_readOnly {n : β„•} (tapes : EntryUpdateTapes n) : + (entryUpdateTM tapes).WorkReadOnly tapes.entry.source := + entryUpdateTM_source_readOnly_internal tapes + +/-- Update one runtime-sized canonical sparse store. The output appends exactly +the encoding of `RegisterStore.write`; input, the replacement source, and every +work tape outside the thirteen-tape assignment retain their checked frames. -/ +theorem entryUpdateTM_hoareTime_frame {n : β„•} + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits initialWork initialWork) + (hreplacement : + (initialWork tapes.replacement).HasBinaryNat newValue) + (hremaining : + (initialWork tapes.remaining).HasBinaryNat store.length) + (hfound : (initialWork tapes.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.resultCount).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (entryUpdateTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryUpdateOutcome tapes store address newValue initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address newValue).flatMap + Entry.encode) ∧ + (work tapes.entry.source).cells = + (initialWork tapes.entry.source).cells) + (entryUpdateTime tapes store address newValue) := by + have hupdate := entryUpdateTM_hoareTime_frame_internal tapes store address newValue + emittedBits initialWork inpβ‚€ outβ‚€ hcanonical hready hreplacement + hremaining hfound hresultCount hinput houtput + intro inp work out hpre + obtain ⟨final, time, htime, hreach, hhalt, hinp, houtcome, hout⟩ := + hupdate inp work out hpre + have hsourceCells : + (final.work tapes.entry.source).cells = + (initialWork tapes.entry.source).cells := by + have hstartWork : work = initialWork := hpre.2.1 + have hnostart : βˆ€ j, 1 ≀ j β†’ + (work tapes.entry.source).cells j β‰  Ξ“.start := by + rw [hstartWork] + exact hready.source.2.2.2 + exact ((entryUpdateTM_source_readOnly tapes).cells_eq_of_reachesIn + hreach hnostart).trans (congrArg (fun w => (w tapes.entry.source).cells) + hstartWork) + exact ⟨final, time, htime, hreach, hhalt, hinp, houtcome, hout, + hsourceCells⟩ + +/-- Redirect an encoded sparse-store update into a fresh last work tape. This +is the stable seam used by the multi-step RAM interpreter: the real output is +left blank while the updated store becomes an ordinary work-tape buffer. -/ +theorem entryUpdateTM_retargetOutput_hoareTime_frame {n : β„•} + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (emittedBits : List Bool) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits (fun i => initialWork (Fin.castSucc i)) + (fun i => initialWork (Fin.castSucc i))) + (hreplacement : + (initialWork (Fin.castSucc tapes.replacement)).HasBinaryNat newValue) + (hremaining : + (initialWork (Fin.castSucc tapes.remaining)).HasBinaryNat store.length) + (hfound : + (initialWork (Fin.castSucc tapes.found)).HasBinaryNat 0) + (hresultCount : + (initialWork (Fin.castSucc tapes.resultCount)).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) + (hbuffer : (initialWork (Fin.last n)).HasBinaryPrefix emittedBits) : + (entryUpdateTM tapes).retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryUpdateOutcome tapes store address newValue + (fun i => initialWork (Fin.castSucc i)) + (fun i => work (Fin.castSucc i)) ∧ + (work (Fin.last n)).HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address newValue).flatMap Entry.encode) ∧ + (work (Fin.castSucc tapes.entry.source)).cells = + (initialWork (Fin.castSucc tapes.entry.source)).cells ∧ + out = (Tape.init []).move Dir3.right) + (entryUpdateTime tapes store address newValue) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let buffer := initialWork (Fin.last n) + have hupdate := entryUpdateTM_hoareTime_frame tapes store address newValue + emittedBits baseWork inpβ‚€ buffer hcanonical hready hreplacement hremaining + hfound hresultCount hinput hbuffer + have hlift := TM.retargetOutput_hoareTime (entryUpdateTM tapes) hupdate + apply hlift.consequence + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + exact ⟨⟨rfl, rfl, rfl⟩, hout⟩ + Β· intro inp work out hpost + rcases hpost with ⟨⟨hinp, houtcome, hstore, hsource⟩, hout⟩ + exact ⟨hinp, houtcome, hstore, hsource, hout⟩ + Β· exact le_rfl + +/-- The sparse-store update controller is append-only on its output tape. -/ +theorem entryUpdateTM_isTransducer {n : β„•} (tapes : EntryUpdateTapes n) : + (entryUpdateTM tapes).IsTransducer := + entryUpdateTM_isTransducer_internal tapes + +/-- Coarse all-prefix auxiliary-space envelope for one complete update. -/ +theorem entryUpdateTM_prefix_withinAuxSpace {n : β„•} + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (entryUpdateTM tapes).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (entryUpdateTM tapes).reachesIn time start current) + (htime : time ≀ entryUpdateTime tapes store address newValue) : + current.WithinAuxSpace inputLength + (initialSpace + entryUpdateTime tapes store address newValue) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- A complete sparse update is charged by the entries actually traversed and +the query, replacement, and remaining-count widths reserved at each iteration. +This avoids the former product of entry count with a squared run-wide width. -/ +theorem entryUpdateTime_le_encoded {n : β„•} + (tapes : EntryUpdateTapes n) (store : Store) + (address newValue : β„•) : + entryUpdateTime tapes store address newValue ≀ + 1000 * (encodedStoreLength store + + (store.length + 1) * + (bitlen address + bitlen newValue + bitlen store.length + 1) + 1) := + entryUpdateTime_le_encoded_internal tapes store address newValue + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/BoundsInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/BoundsInternal.lean new file mode 100644 index 0000000000..7d20a7ad3d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/BoundsInternal.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany + +/-! +# Encoded-length sparse-update bounds -- proof internals + +The update controller reserves the slower of copy, replacement, and deletion +at each iteration. With unary-marker decoding, each such reservation is still +linear in the current entry and the instruction's query/replacement widths. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +private theorem entryMatchReadTime_le_bitlen (entry : Entry) + (queryBits : List Bool) : + entryMatchReadTime entry queryBits ≀ + 5 * bitlen entry.1 + 3 * bitlen entry.2 + queryBits.length + 18 := by + have h := entryMatchReadTime_le_linear_internal entry queryBits + simpa only [bitlen, Nat.size_eq_bits_len] using h + +private theorem entryMissBits_length_le_bitlen {n : β„•} + (tapes : EntryMatchTapes n) (entry : Entry) + (queryBits : List Bool) (i : Fin n) : + (entryMissBits tapes entry queryBits i).length ≀ + bitlen entry.1 + bitlen entry.2 + 1 := by + unfold entryMissBits + split_ifs <;> + (try simp only [List.length_nil, List.length_replicate, + List.length_singleton, bitlen, Nat.size_eq_bits_len]) <;> omega + +private theorem entryUpdatePostEmitHead_le_bitlen {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) (i : Fin n) : + entryUpdatePostEmitHead tapes entry i ≀ + bitlen entry.1 + bitlen entry.2 + 1 := by + unfold entryUpdatePostEmitHead + split_ifs <;> + simp only [bitlen, Nat.size_eq_bits_len] <;> omega + +private theorem entryUpdateReadyCleanupTime_le_linear {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) : + entryUpdateReadyCleanupTime tapes entry address ≀ + 300 * (bitlen entry.1 + bitlen entry.2 + bitlen address + 1) := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ + 5 * bitlen entry.1 + 3 * bitlen entry.2 + bitlen address + 18 := by + dsimp only [matchTime] + simpa only [bitlen, Nat.size_eq_bits_len] using + entryMatchReadTime_le_bitlen entry address.bits + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes.entry) + (entryMissBits tapes.entry entry address.bits) + (fun _ => 1 + matchTime) (1 + matchTime) + (bitlen entry.1 + bitlen entry.2 + 1) + (fun _ _ => le_rfl) + (fun i _ => entryMissBits_length_le_bitlen tapes.entry entry address.bits i) + have htargets : (entryMissTargets tapes.entry).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + unfold entryUpdateReadyCleanupTime + dsimp only [matchTime] at hmatch hreset ⊒ + omega + +private theorem entryUpdatePostEmitCleanupTime_le_linear {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) : + entryUpdatePostEmitCleanupTime tapes entry address ≀ + 300 * (bitlen entry.1 + bitlen entry.2 + bitlen address + 1) := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ + 5 * bitlen entry.1 + 3 * bitlen entry.2 + bitlen address + 18 := by + dsimp only [matchTime] + simpa only [bitlen, Nat.size_eq_bits_len] using + entryMatchReadTime_le_bitlen entry address.bits + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes.entry) + (entryMissBits tapes.entry entry address.bits) + (fun i => entryUpdatePostEmitHead tapes entry i + matchTime) + (bitlen entry.1 + bitlen entry.2 + 1 + matchTime) + (bitlen entry.1 + bitlen entry.2 + 1) + (fun i _ => Nat.add_le_add_right + (entryUpdatePostEmitHead_le_bitlen tapes entry i) matchTime) + (fun i _ => entryMissBits_length_le_bitlen tapes.entry entry address.bits i) + have htargets : (entryMissTargets tapes.entry).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + unfold entryUpdatePostEmitCleanupTime + dsimp only [matchTime] at hmatch hreset ⊒ + omega + +private theorem rewindEntryEncodeTime_le_linear (entry : Entry) + (addressHead valueHead : β„•) : + rewindEntryEncodeTime entry addressHead valueHead ≀ + addressHead + valueHead + 3 * bitlen entry.1 + + 3 * bitlen entry.2 + 21 := by + unfold rewindEntryEncodeTime rewindWordEncodeTime wordEncodeTime + simp only [bitlen, Nat.size_eq_bits_len] + omega +private theorem entryUpdateBranchTime_le_linear {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) + (address newValue total : β„•) : + entryUpdateBranchTime tapes entry address newValue total ≀ + 500 * (bitlen entry.1 + bitlen entry.2 + bitlen address + + bitlen newValue + bitlen total + 1) := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ + 5 * bitlen entry.1 + 3 * bitlen entry.2 + bitlen address + 18 := by + dsimp only [matchTime] + simpa only [bitlen, Nat.size_eq_bits_len] using + entryMatchReadTime_le_bitlen entry address.bits + have hready := entryUpdateReadyCleanupTime_le_linear tapes entry address + have hpost := entryUpdatePostEmitCleanupTime_le_linear tapes entry address + have hmiss := rewindEntryEncodeTime_le_linear entry + (1 + matchTime) (1 + matchTime) + have hreplace := rewindEntryEncodeTime_le_linear (entry.1, newValue) + (1 + matchTime) 1 + have hcount : entryUpdateCountTime total ≀ 2 * bitlen total + 2 := by + unfold entryUpdateCountTime bitlen + omega + have hnewValue : newValue.bits.length = bitlen newValue := by + exact Nat.size_eq_bits_len newValue + unfold entryUpdateBranchTime entryUpdateMissTime entryUpdateReplaceTime + dsimp only [matchTime] at hmatch hmiss hreplace ⊒ + rw [hnewValue] + apply max_le + Β· omega + Β· apply max_le <;> omega + +private theorem entryUpdateIterationTime_le_linear {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) (rest : Store) + (address newValue total : β„•) (hrest : rest.length + 1 ≀ total) : + entryUpdateIterationTime tapes entry rest address newValue total ≀ + 600 * (bitlen entry.1 + bitlen entry.2 + bitlen address + + bitlen newValue + bitlen total + 1) := by + have hmatch := entryMatchReadTime_le_bitlen entry address.bits + have hbranch := entryUpdateBranchTime_le_linear tapes entry address + newValue total + have hpred := TM.binaryPredTime_le rest.length + have hrestWidth : (rest.length + 1).size ≀ bitlen total := by + unfold bitlen + exact Nat.size_le_size hrest + unfold entryUpdateIterationTime + have haddressBits : address.bits.length = bitlen address := + Nat.size_eq_bits_len address + rw [haddressBits] at hmatch + omega + +private theorem entryUpdateNilTime_le_linear {n : β„•} + (tapes : EntryUpdateTapes n) (address newValue total : β„•) : + entryUpdateLoopTime tapes address newValue total [] ≀ + 100 * (bitlen address + bitlen newValue + bitlen total + 1) := by + have hrewind := rewindEntryEncodeTime_le_linear (address, newValue) 1 1 + change rewindEntryEncodeTime (address, newValue) 1 1 ≀ + 1 + 1 + 3 * bitlen address + 3 * bitlen newValue + 21 at hrewind + have hcount : entryUpdateCountTime total ≀ 2 * bitlen total + 2 := by + unfold entryUpdateCountTime bitlen + omega + unfold entryUpdateLoopTime entryAppendRestoreTime + have haddress : address.bits.length = bitlen address := + Nat.size_eq_bits_len address + have hnewValue : newValue.bits.length = bitlen newValue := + Nat.size_eq_bits_len newValue + rw [haddress, hnewValue] + omega + +theorem entryUpdateTime_le_encoded_internal {n : β„•} + (tapes : EntryUpdateTapes n) (store : Store) + (address newValue : β„•) : + entryUpdateTime tapes store address newValue ≀ + 1000 * (encodedStoreLength store + + (store.length + 1) * + (bitlen address + bitlen newValue + bitlen store.length + 1) + 1) := by + have hloop : βˆ€ remaining : Store, remaining.length ≀ store.length β†’ + entryUpdateLoopTime tapes address newValue store.length remaining ≀ + 1000 * (encodedStoreLength remaining + + (remaining.length + 1) * + (bitlen address + bitlen newValue + bitlen store.length + 1) + 1) := by + intro remaining hremaining + induction remaining with + | nil => + have hnil := entryUpdateNilTime_le_linear tapes address newValue + store.length + simp only [encodedStoreLength, List.flatMap_nil, List.length_nil, + Nat.zero_add, Nat.one_mul] + omega + | cons entry rest ih => + have hrestLength : rest.length + 1 ≀ store.length := by + simpa only [List.length_cons] using hremaining + have hiteration := entryUpdateIterationTime_le_linear tapes entry rest + address newValue store.length hrestLength + have htail := ih (by omega) + have hentryLength : (Entry.encode entry).length = + 2 * bitlen entry.1 + 2 * bitlen entry.2 + 2 := + Entry.encode_length entry + unfold entryUpdateLoopTime + have hencoded : encodedStoreLength (entry :: rest) = + (Entry.encode entry).length + encodedStoreLength rest := by + simp [encodedStoreLength] + rw [hencoded, hentryLength] + simp only [List.length_cons] + have hmul : (rest.length + 1 + 1) * + (bitlen address + bitlen newValue + bitlen store.length + 1) = + (rest.length + 1) * + (bitlen address + bitlen newValue + bitlen store.length + 1) + + (bitlen address + bitlen newValue + bitlen store.length + 1) := by + ring + rw [hmul] + omega + unfold entryUpdateTime + exact hloop store le_rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Defs.lean new file mode 100644 index 0000000000..84f32e4ff3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Defs.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Types + +/-! +# Bounded encoded sparse-store update β€” controller definitions + +The fixed controller owns thirteen pairwise-distinct work tapes. It scans a +runtime-counted entry stream, copying misses, replacing or deleting a hit, and +appending a fresh nonzero entry only when the old count is exhausted without a +match. A second count tape tracks the output-store cardinality. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Canonical head profile after an old decoded entry has been emitted. -/ +def entryUpdatePostEmitHead {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (i : Fin n) : β„• := + if i = tapes.entry.address then entry.1.bits.length + 1 + else if i = tapes.entry.value then entry.2.bits.length + 1 + else if i = tapes.entry.addressCounter then bitlen entry.1 + 1 + else if i = tapes.entry.valueCounter then bitlen entry.2 + 1 + else 1 + +/-- Work-independent cleanup bound when deletion emits no entry. -/ +def entryUpdateReadyCleanupTime {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (address : β„•) : β„• := + let matchTime := entryMatchReadTime entry address.bits + 1 + matchTime + 2 + 1 + + TM.resetBinaryWorkManyTime + (entryMissBits tapes.entry entry address.bits) + (fun _ => 1 + matchTime) (entryMissTargets tapes.entry) + +/-- Work-independent cleanup bound after miss-copy or replacement emission. -/ +def entryUpdatePostEmitCleanupTime {n : β„•} + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) : β„• := + let matchTime := entryMatchReadTime entry address.bits + 1 + 2 * matchTime + 2 + 1 + + TM.resetBinaryWorkManyTime + (entryMissBits tapes.entry entry address.bits) + (fun i => entryUpdatePostEmitHead tapes entry i + matchTime) + (entryMissTargets tapes.entry) + +/-- Fixed bound for copying one unmatched entry and restoring scratch. -/ +def entryUpdateMissTime {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (address : β„•) : β„• := + let matchTime := entryMatchReadTime entry address.bits + rewindEntryEncodeTime entry (1 + matchTime) (1 + matchTime) + 1 + + entryUpdatePostEmitCleanupTime tapes entry address + +/-- Fixed bound for emitting a replacement and restoring scratch. -/ +def entryUpdateReplaceTime {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (address newValue : β„•) : β„• := + let matchTime := entryMatchReadTime entry address.bits + rewindEntryEncodeTime (entry.1, newValue) (1 + matchTime) 1 + 1 + + (newValue.bits.length + 1 + 2 + 1 + + entryUpdatePostEmitCleanupTime tapes entry address) + +/-- Uniform binary counter-update budget below the initial store size. -/ +def entryUpdateCountTime (total : β„•) : β„• := + 2 * total.size + 2 + +/-- Maximum controller branch cost after one readable comparison. -/ +def entryUpdateBranchTime {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (address newValue total : β„•) : β„• := + max (entryUpdateMissTime tapes entry address + 1) + (max (entryUpdateReplaceTime tapes entry address newValue + 1) + (entryUpdateReadyCleanupTime tapes entry address + 1 + + entryUpdateCountTime total + 1)) + +/-- Fixed cost of one positive-count iteration, excluding the recursive tail. -/ +def entryUpdateIterationTime {n : β„•} (tapes : EntryUpdateTapes n) + (entry : Entry) (rest : Store) (address newValue total : β„•) : β„• := + 1 + entryMatchReadTime entry address.bits + 1 + + entryUpdateBranchTime tapes entry address newValue total + + TM.binaryPredTime rest.length + 1 + +/-- Recursive fixed bound for updating a remaining sparse-store suffix. -/ +def entryUpdateLoopTime {n : β„•} (tapes : EntryUpdateTapes n) + (address newValue total : β„•) : Store β†’ β„• + | [] => + 1 + entryAppendRestoreTime address newValue + 1 + + entryUpdateCountTime total + 1 + | entry :: rest => + entryUpdateIterationTime tapes entry rest address newValue total + + entryUpdateLoopTime tapes address newValue total rest + +/-- Public runtime bound for one complete encoded sparse-store update. -/ +def entryUpdateTime {n : β„•} (tapes : EntryUpdateTapes n) + (store : Store) (address newValue : β„•) : β„• := + entryUpdateLoopTime tapes address newValue store.length store + +/-- Controller states, including each checked nested machine. -/ +inductive EntryUpdateQ {n : β„•} (tapes : EntryUpdateTapes n) where + | test + | matching : (entryMatchReadTM tapes.entry).Q β†’ EntryUpdateQ tapes + | miss : (entryMissCopyTM tapes.entry).Q β†’ EntryUpdateQ tapes + | delete : (entryMissCleanupTM tapes.entry).Q β†’ EntryUpdateQ tapes + | replace : (entryReplaceCleanupTM tapes.replace).Q β†’ EntryUpdateQ tapes + | append : (entryAppendRestoreTM tapes.replace).Q β†’ EntryUpdateQ tapes + | remaining : (TM.binaryPredTM tapes.remaining).Q β†’ EntryUpdateQ tapes + | deleteCount : (TM.binaryPredTM tapes.resultCount).Q β†’ EntryUpdateQ tapes + | appendCount : (TM.binarySuccTM tapes.resultCount).Q β†’ EntryUpdateQ tapes + | done + deriving DecidableEq + +/-- The update controller has finitely many states because every nested +machine state type is finite. -/ +instance instFintypeEntryUpdateQ {n : β„•} + (tapes : EntryUpdateTapes n) : Fintype (EntryUpdateQ tapes) where + elems := + {.test, .done} βˆͺ + (Finset.univ.image EntryUpdateQ.matching) βˆͺ + (Finset.univ.image EntryUpdateQ.miss) βˆͺ + (Finset.univ.image EntryUpdateQ.delete) βˆͺ + (Finset.univ.image EntryUpdateQ.replace) βˆͺ + (Finset.univ.image EntryUpdateQ.append) βˆͺ + (Finset.univ.image EntryUpdateQ.remaining) βˆͺ + (Finset.univ.image EntryUpdateQ.deleteCount) βˆͺ + (Finset.univ.image EntryUpdateQ.appendCount) + complete := by + intro q + cases q <;> simp + +/-- Fixed runtime-counted update controller. The old remaining count reaches +zero on every complete scan; the result count is decremented only for deletion +and incremented only for absent-address append. -/ +def entryUpdateTM {n : β„•} (tapes : EntryUpdateTapes n) : TM n where + Q := EntryUpdateQ tapes + qstart := .test + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .test => + if wHeads tapes.remaining = Ξ“.blank then + if wHeads tapes.found = Ξ“.one then + TM.allReadBack .done iHead wHeads oHead + else if wHeads tapes.replacement = Ξ“.blank then + TM.allReadBack .done iHead wHeads oHead + else + TM.allReadBack + (.append (entryAppendRestoreTM tapes.replace).qstart) + iHead wHeads oHead + else + TM.allReadBack (.matching (entryMatchReadTM tapes.entry).qstart) + iHead wHeads oHead + | .matching q => + if q = (entryMatchReadTM tapes.entry).qhalt then + if wHeads tapes.entry.result = Ξ“.one then + let next := + if wHeads tapes.replacement = Ξ“.blank then + .delete (entryMissCleanupTM tapes.entry).qstart + else + .replace (entryReplaceCleanupTM tapes.replace).qstart + (next, + fun i => if i = tapes.found then Ξ“w.one + else TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + else + TM.allReadBack (.miss (entryMissCopyTM tapes.entry).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryMatchReadTM tapes.entry).Ξ΄ q iHead wHeads oHead + (.matching q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .miss q => + if q = (entryMissCopyTM tapes.entry).qhalt then + TM.allReadBack (.remaining (TM.binaryPredTM tapes.remaining).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryMissCopyTM tapes.entry).Ξ΄ q iHead wHeads oHead + (.miss q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .delete q => + if q = (entryMissCleanupTM tapes.entry).qhalt then + TM.allReadBack + (.deleteCount (TM.binaryPredTM tapes.resultCount).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryMissCleanupTM tapes.entry).Ξ΄ q iHead wHeads oHead + (.delete q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .replace q => + if q = (entryReplaceCleanupTM tapes.replace).qhalt then + TM.allReadBack (.remaining (TM.binaryPredTM tapes.remaining).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryReplaceCleanupTM tapes.replace).Ξ΄ q iHead wHeads oHead + (.replace q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .append q => + if q = (entryAppendRestoreTM tapes.replace).qhalt then + TM.allReadBack + (.appendCount (TM.binarySuccTM tapes.resultCount).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (entryAppendRestoreTM tapes.replace).Ξ΄ q iHead wHeads oHead + (.append q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .remaining q => + if q = (TM.binaryPredTM tapes.remaining).qhalt then + TM.allReadBack .test iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (TM.binaryPredTM tapes.remaining).Ξ΄ q iHead wHeads oHead + (.remaining q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .deleteCount q => + if q = (TM.binaryPredTM tapes.resultCount).qhalt then + TM.allReadBack (.remaining (TM.binaryPredTM tapes.remaining).qstart) + iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (TM.binaryPredTM tapes.resultCount).Ξ΄ q iHead wHeads oHead + (.deleteCount q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .appendCount q => + if q = (TM.binarySuccTM tapes.resultCount).qhalt then + TM.allReadBack .done iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + (TM.binarySuccTM tapes.resultCount).Ξ΄ q iHead wHeads oHead + (.appendCount q', workWrites, outputWrite, inputDir, workDirs, outputDir) + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | test => + dsimp only + split + Β· split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· split <;> exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + | matching q => + dsimp only + split + Β· split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryMatchReadTM tapes.entry).Ξ΄_right_of_start + q iHead wHeads oHead + | miss q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryMissCopyTM tapes.entry).Ξ΄_right_of_start + q iHead wHeads oHead + | delete q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryMissCleanupTM tapes.entry).Ξ΄_right_of_start + q iHead wHeads oHead + | replace q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryReplaceCleanupTM tapes.replace).Ξ΄_right_of_start + q iHead wHeads oHead + | append q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (entryAppendRestoreTM tapes.replace).Ξ΄_right_of_start + q iHead wHeads oHead + | remaining q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (TM.binaryPredTM tapes.remaining).Ξ΄_right_of_start + q iHead wHeads oHead + | deleteCount q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (TM.binaryPredTM tapes.resultCount).Ξ΄_right_of_start + q iHead wHeads oHead + | appendCount q => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact (TM.binarySuccTM tapes.resultCount).Ξ΄_right_of_start + q iHead wHeads oHead + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal.lean new file mode 100644 index 0000000000..1a4620fc52 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.End +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Hit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Miss +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Ctrl.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Ctrl.lean new file mode 100644 index 0000000000..3c5b38cccc --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Ctrl.lean @@ -0,0 +1,665 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs + +/-! +# Bounded encoded sparse-store update β€” controller internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Embed a match configuration in the update controller. -/ +def entryUpdateMatchWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .matching cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed a miss-copy configuration in the update controller. -/ +def entryUpdateMissWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMissCopyTM tapes.entry).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .miss cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed a deletion-cleanup configuration in the update controller. -/ +def entryUpdateDeleteWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMissCleanupTM tapes.entry).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .delete cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed a replacement configuration in the update controller. -/ +def entryUpdateReplaceWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryReplaceCleanupTM tapes.replace).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .replace cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed a final-append configuration in the update controller. -/ +def entryUpdateAppendWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryAppendRestoreTM tapes.replace).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .append cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed the remaining-count predecessor in the update controller. -/ +def entryUpdateRemainingWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.remaining).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .remaining cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed the deletion result-count predecessor in the update controller. -/ +def entryUpdateDeleteCountWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.resultCount).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .deleteCount cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Embed the append result-count successor in the update controller. -/ +def entryUpdateAppendCountWrap (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binarySuccTM tapes.resultCount).Q) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .appendCount cfg.state + input := cfg.input + work := cfg.work + output := cfg.output + +/-- Canonical loop-test controller configuration. -/ +def entryUpdateTestCfg (tapes : EntryUpdateTapes n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .test + input := inp + work := work + output := out + +/-- Canonical halted update-controller configuration. -/ +def entryUpdateDoneCfg (tapes : EntryUpdateTapes n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Complexity.Cfg n (entryUpdateTM tapes).Q where + state := .done + input := inp + work := work + output := out + +/-- Work family after the hit-dispatch transition records a match. -/ +def entryUpdateMarkFoundWork (tapes : EntryUpdateTapes n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := + Function.update work tapes.found + ((work tapes.found).writeAndMove Ξ“.one + (TM.idleDir (work tapes.found).read)) + +private theorem entryUpdateTM_match_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q} + (hstep : (entryMatchReadTM tapes.entry).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateMatchWrap tapes cfg) = + some (entryUpdateMatchWrap tapes next) := by + have hne : cfg.state β‰  (entryMatchReadTM tapes.entry).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateMatchWrap, entryUpdateTM])] + simp only [entryUpdateMatchWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryMatchReadTM tapes.entry).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_miss_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (entryMissCopyTM tapes.entry).Q} + (hstep : (entryMissCopyTM tapes.entry).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateMissWrap tapes cfg) = + some (entryUpdateMissWrap tapes next) := by + have hne : cfg.state β‰  (entryMissCopyTM tapes.entry).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateMissWrap, entryUpdateTM])] + simp only [entryUpdateMissWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryMissCopyTM tapes.entry).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_delete_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (entryMissCleanupTM tapes.entry).Q} + (hstep : (entryMissCleanupTM tapes.entry).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateDeleteWrap tapes cfg) = + some (entryUpdateDeleteWrap tapes next) := by + have hne : cfg.state β‰  (entryMissCleanupTM tapes.entry).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateDeleteWrap, entryUpdateTM])] + simp only [entryUpdateDeleteWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryMissCleanupTM tapes.entry).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_replace_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (entryReplaceCleanupTM tapes.replace).Q} + (hstep : (entryReplaceCleanupTM tapes.replace).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateReplaceWrap tapes cfg) = + some (entryUpdateReplaceWrap tapes next) := by + have hne : cfg.state β‰  (entryReplaceCleanupTM tapes.replace).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateReplaceWrap, entryUpdateTM])] + simp only [entryUpdateReplaceWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryReplaceCleanupTM tapes.replace).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_append_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (entryAppendRestoreTM tapes.replace).Q} + (hstep : (entryAppendRestoreTM tapes.replace).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateAppendWrap tapes cfg) = + some (entryUpdateAppendWrap tapes next) := by + have hne : cfg.state β‰  (entryAppendRestoreTM tapes.replace).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateAppendWrap, entryUpdateTM])] + simp only [entryUpdateAppendWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (entryAppendRestoreTM tapes.replace).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_remaining_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.remaining).Q} + (hstep : (TM.binaryPredTM tapes.remaining).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateRemainingWrap tapes cfg) = + some (entryUpdateRemainingWrap tapes next) := by + have hne : cfg.state β‰  (TM.binaryPredTM tapes.remaining).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateRemainingWrap, entryUpdateTM])] + simp only [entryUpdateRemainingWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (TM.binaryPredTM tapes.remaining).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_deleteCount_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.resultCount).Q} + (hstep : (TM.binaryPredTM tapes.resultCount).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateDeleteCountWrap tapes cfg) = + some (entryUpdateDeleteCountWrap tapes next) := by + have hne : cfg.state β‰  (TM.binaryPredTM tapes.resultCount).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateDeleteCountWrap, entryUpdateTM])] + simp only [entryUpdateDeleteCountWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (TM.binaryPredTM tapes.resultCount).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem entryUpdateTM_appendCount_step + (tapes : EntryUpdateTapes n) + {cfg next : Complexity.Cfg n (TM.binarySuccTM tapes.resultCount).Q} + (hstep : (TM.binarySuccTM tapes.resultCount).step cfg = some next) : + (entryUpdateTM tapes).step (entryUpdateAppendCountWrap tapes cfg) = + some (entryUpdateAppendCountWrap tapes next) := by + have hne : cfg.state β‰  (TM.binarySuccTM tapes.resultCount).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [entryUpdateAppendCountWrap, entryUpdateTM])] + simp only [entryUpdateAppendCountWrap, entryUpdateTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : (TM.binarySuccTM tapes.resultCount).Ξ΄ cfg.state + cfg.input.read (fun i => (cfg.work i).read) cfg.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +theorem entryUpdateTM_match_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q} + (hreach : (entryMatchReadTM tapes.entry).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateMatchWrap tapes cfg) (entryUpdateMatchWrap tapes next) := + TM.reachesIn_map (entryUpdateMatchWrap tapes) + (fun _ _ => entryUpdateTM_match_step tapes) hreach + +theorem entryUpdateTM_miss_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryMissCopyTM tapes.entry).Q} + (hreach : (entryMissCopyTM tapes.entry).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateMissWrap tapes cfg) (entryUpdateMissWrap tapes next) := + TM.reachesIn_map (entryUpdateMissWrap tapes) + (fun _ _ => entryUpdateTM_miss_step tapes) hreach + +theorem entryUpdateTM_delete_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryMissCleanupTM tapes.entry).Q} + (hreach : (entryMissCleanupTM tapes.entry).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateDeleteWrap tapes cfg) (entryUpdateDeleteWrap tapes next) := + TM.reachesIn_map (entryUpdateDeleteWrap tapes) + (fun _ _ => entryUpdateTM_delete_step tapes) hreach + +theorem entryUpdateTM_replace_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryReplaceCleanupTM tapes.replace).Q} + (hreach : (entryReplaceCleanupTM tapes.replace).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateReplaceWrap tapes cfg) (entryUpdateReplaceWrap tapes next) := + TM.reachesIn_map (entryUpdateReplaceWrap tapes) + (fun _ _ => entryUpdateTM_replace_step tapes) hreach + +theorem entryUpdateTM_append_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (entryAppendRestoreTM tapes.replace).Q} + (hreach : (entryAppendRestoreTM tapes.replace).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateAppendWrap tapes cfg) (entryUpdateAppendWrap tapes next) := + TM.reachesIn_map (entryUpdateAppendWrap tapes) + (fun _ _ => entryUpdateTM_append_step tapes) hreach + +theorem entryUpdateTM_remaining_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.remaining).Q} + (hreach : (TM.binaryPredTM tapes.remaining).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateRemainingWrap tapes cfg) (entryUpdateRemainingWrap tapes next) := + TM.reachesIn_map (entryUpdateRemainingWrap tapes) + (fun _ _ => entryUpdateTM_remaining_step tapes) hreach + +theorem entryUpdateTM_deleteCount_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (TM.binaryPredTM tapes.resultCount).Q} + (hreach : (TM.binaryPredTM tapes.resultCount).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateDeleteCountWrap tapes cfg) + (entryUpdateDeleteCountWrap tapes next) := + TM.reachesIn_map (entryUpdateDeleteCountWrap tapes) + (fun _ _ => entryUpdateTM_deleteCount_step tapes) hreach + +theorem entryUpdateTM_appendCount_reachesIn_internal + (tapes : EntryUpdateTapes n) {time : β„•} + {cfg next : Complexity.Cfg n (TM.binarySuccTM tapes.resultCount).Q} + (hreach : (TM.binarySuccTM tapes.resultCount).reachesIn time cfg next) : + (entryUpdateTM tapes).reachesIn time + (entryUpdateAppendCountWrap tapes cfg) + (entryUpdateAppendCountWrap tapes next) := + TM.reachesIn_map (entryUpdateAppendCountWrap tapes) + (fun _ _ => entryUpdateTM_appendCount_step tapes) hreach + +theorem entryUpdateTM_step_test_continue_internal + (tapes : EntryUpdateTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hremaining : (work tapes.remaining).read β‰  Ξ“.blank) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryUpdateTM tapes).step (entryUpdateTestCfg tapes inp work out) = + some (entryUpdateMatchWrap tapes + { state := (entryMatchReadTM tapes.entry).qstart + input := inp, work := work, output := out }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateTestCfg, entryUpdateTM])] + simp only [entryUpdateTestCfg, entryUpdateTM, hremaining, ↓reduceIte, + entryUpdateMatchWrap] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_test_found_internal + (tapes : EntryUpdateTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hremaining : (work tapes.remaining).read = Ξ“.blank) + (hfound : (work tapes.found).read = Ξ“.one) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryUpdateTM tapes).step (entryUpdateTestCfg tapes inp work out) = + some (entryUpdateDoneCfg tapes inp work out) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateTestCfg, entryUpdateTM])] + simp only [entryUpdateTestCfg, entryUpdateDoneCfg, entryUpdateTM, + hremaining, hfound, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_test_zero_internal + (tapes : EntryUpdateTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hremaining : (work tapes.remaining).read = Ξ“.blank) + (hfound : (work tapes.found).read β‰  Ξ“.one) + (hreplacement : (work tapes.replacement).read = Ξ“.blank) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryUpdateTM tapes).step (entryUpdateTestCfg tapes inp work out) = + some (entryUpdateDoneCfg tapes inp work out) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateTestCfg, entryUpdateTM])] + simp only [entryUpdateTestCfg, entryUpdateDoneCfg, entryUpdateTM, + hremaining, hfound, hreplacement, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_test_append_internal + (tapes : EntryUpdateTapes n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hremaining : (work tapes.remaining).read = Ξ“.blank) + (hfound : (work tapes.found).read β‰  Ξ“.one) + (hreplacement : (work tapes.replacement).read β‰  Ξ“.blank) + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + (entryUpdateTM tapes).step (entryUpdateTestCfg tapes inp work out) = + some (entryUpdateAppendWrap tapes + { state := (entryAppendRestoreTM tapes.replace).qstart + input := inp, work := work, output := out }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateTestCfg, entryUpdateTM])] + simp only [entryUpdateTestCfg, entryUpdateTM, hremaining, hfound, + hreplacement, ↓reduceIte, entryUpdateAppendWrap] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +private theorem entryUpdateMarkFoundWork_apply_eq + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) : + entryUpdateMarkFoundWork tapes work tapes.found = + (work tapes.found).writeAndMove Ξ“.one + (TM.idleDir (work tapes.found).read) := by + simp [entryUpdateMarkFoundWork] + +private theorem entryUpdateMarkFoundWork_apply_ne + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) + (i : Fin n) (hi : i β‰  tapes.found) : + entryUpdateMarkFoundWork tapes work i = work i := by + simp [entryUpdateMarkFoundWork, Function.update_of_ne hi] + +theorem entryUpdateTM_step_match_delete_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q) + (hhalt : (entryMatchReadTM tapes.entry).halted cfg) + (hresult : (cfg.work tapes.entry.result).read = Ξ“.one) + (hreplacement : (cfg.work tapes.replacement).read = Ξ“.blank) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateMatchWrap tapes cfg) = + some (entryUpdateDeleteWrap tapes + { state := (entryMissCleanupTM tapes.entry).qstart + input := cfg.input + work := entryUpdateMarkFoundWork tapes cfg.work + output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateMatchWrap, entryUpdateTM])] + simp only [entryUpdateMatchWrap, entryUpdateDeleteWrap, entryUpdateTM, + hhalt, hresult, hreplacement, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + change (cfg.work i).writeAndMove + (if i = tapes.found then Ξ“w.one + else TM.readBackWrite (cfg.work i).read).toΞ“ + (TM.idleDir (cfg.work i).read) = + entryUpdateMarkFoundWork tapes cfg.work i + by_cases hi : i = tapes.found + Β· subst i + simp [entryUpdateMarkFoundWork] + Β· simp only [hi, ite_false, + entryUpdateMarkFoundWork_apply_ne tapes cfg.work i hi] + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_match_replace_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q) + (hhalt : (entryMatchReadTM tapes.entry).halted cfg) + (hresult : (cfg.work tapes.entry.result).read = Ξ“.one) + (hreplacement : (cfg.work tapes.replacement).read β‰  Ξ“.blank) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateMatchWrap tapes cfg) = + some (entryUpdateReplaceWrap tapes + { state := (entryReplaceCleanupTM tapes.replace).qstart + input := cfg.input + work := entryUpdateMarkFoundWork tapes cfg.work + output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateMatchWrap, entryUpdateTM])] + simp only [entryUpdateMatchWrap, entryUpdateReplaceWrap, entryUpdateTM, + hhalt, hresult, hreplacement, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + change (cfg.work i).writeAndMove + (if i = tapes.found then Ξ“w.one + else TM.readBackWrite (cfg.work i).read).toΞ“ + (TM.idleDir (cfg.work i).read) = + entryUpdateMarkFoundWork tapes cfg.work i + by_cases hi : i = tapes.found + Β· subst i + simp [entryUpdateMarkFoundWork] + Β· simp only [hi, ite_false, + entryUpdateMarkFoundWork_apply_ne tapes cfg.work i hi] + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_match_miss_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMatchReadTM tapes.entry).Q) + (hhalt : (entryMatchReadTM tapes.entry).halted cfg) + (hresult : (cfg.work tapes.entry.result).read β‰  Ξ“.one) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateMatchWrap tapes cfg) = + some (entryUpdateMissWrap tapes + { state := (entryMissCopyTM tapes.entry).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateMatchWrap, entryUpdateTM])] + simp only [entryUpdateMatchWrap, entryUpdateMissWrap, entryUpdateTM, + hhalt, hresult, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_miss_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMissCopyTM tapes.entry).Q) + (hhalt : (entryMissCopyTM tapes.entry).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateMissWrap tapes cfg) = + some (entryUpdateRemainingWrap tapes + { state := (TM.binaryPredTM tapes.remaining).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateMissWrap, entryUpdateTM])] + simp only [entryUpdateMissWrap, entryUpdateRemainingWrap, entryUpdateTM, + hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_delete_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryMissCleanupTM tapes.entry).Q) + (hhalt : (entryMissCleanupTM tapes.entry).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateDeleteWrap tapes cfg) = + some (entryUpdateDeleteCountWrap tapes + { state := (TM.binaryPredTM tapes.resultCount).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateDeleteWrap, entryUpdateTM])] + simp only [entryUpdateDeleteWrap, entryUpdateDeleteCountWrap, + entryUpdateTM, hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_replace_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryReplaceCleanupTM tapes.replace).Q) + (hhalt : (entryReplaceCleanupTM tapes.replace).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateReplaceWrap tapes cfg) = + some (entryUpdateRemainingWrap tapes + { state := (TM.binaryPredTM tapes.remaining).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateReplaceWrap, entryUpdateTM])] + simp only [entryUpdateReplaceWrap, entryUpdateRemainingWrap, entryUpdateTM, + hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_append_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (entryAppendRestoreTM tapes.replace).Q) + (hhalt : (entryAppendRestoreTM tapes.replace).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateAppendWrap tapes cfg) = + some (entryUpdateAppendCountWrap tapes + { state := (TM.binarySuccTM tapes.resultCount).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateAppendWrap, entryUpdateTM])] + simp only [entryUpdateAppendWrap, entryUpdateAppendCountWrap, entryUpdateTM, + hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_remaining_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.remaining).Q) + (hhalt : (TM.binaryPredTM tapes.remaining).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateRemainingWrap tapes cfg) = + some (entryUpdateTestCfg tapes cfg.input cfg.work cfg.output) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateRemainingWrap, entryUpdateTM])] + simp only [entryUpdateRemainingWrap, entryUpdateTestCfg, entryUpdateTM, + hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_deleteCount_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binaryPredTM tapes.resultCount).Q) + (hhalt : (TM.binaryPredTM tapes.resultCount).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateDeleteCountWrap tapes cfg) = + some (entryUpdateRemainingWrap tapes + { state := (TM.binaryPredTM tapes.remaining).qstart + input := cfg.input, work := cfg.work, output := cfg.output }) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateDeleteCountWrap, entryUpdateTM])] + simp only [entryUpdateDeleteCountWrap, entryUpdateRemainingWrap, + entryUpdateTM, hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +theorem entryUpdateTM_step_appendCount_halt_internal + (tapes : EntryUpdateTapes n) + (cfg : Complexity.Cfg n (TM.binarySuccTM tapes.resultCount).Q) + (hhalt : (TM.binarySuccTM tapes.resultCount).halted cfg) + (hinput : TM.Parked cfg.input) (hwork : βˆ€ i, TM.Parked (cfg.work i)) + (houtput : TM.Parked cfg.output) : + (entryUpdateTM tapes).step (entryUpdateAppendCountWrap tapes cfg) = + some (entryUpdateDoneCfg tapes cfg.input cfg.work cfg.output) := by + rw [TM.step, ite_eq_right (by simp [entryUpdateAppendCountWrap, entryUpdateTM])] + simp only [entryUpdateAppendCountWrap, entryUpdateDoneCfg, entryUpdateTM, + hhalt, ↓reduceIte] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/End.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/End.lean new file mode 100644 index 0000000000..469dd2aa66 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/End.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch + +/-! +# Bounded encoded sparse-store update -- terminal loop case + +This file closes the update loop once the old-entry counter is exhausted. A +previous hit and an absent zero write halt immediately; an absent nonzero write +runs the checked append and result-count successor subroutines. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Once no old entries remain, the controller realizes the pure sparse-store +write and establishes the complete final tape contract. -/ +theorem entryUpdateTerminal_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (processed emitted : Store) (found : Bool) (resultCount : β„•) + (initialWork work : Fin n β†’ Tape) (outPrefix : List Bool) + (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed [] + emitted found resultCount initialWork work) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ final time, + time ≀ entryUpdateLoopTime tapes address newValue store.length [] ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) final ∧ + (entryUpdateTM tapes).halted final ∧ + final.input = inp ∧ + EntryUpdateOutcome tapes store address newValue initialWork final.work ∧ + final.output.HasBinaryPrefix + (outPrefix ++ (RegisterStore.write store address newValue).flatMap + Entry.encode) := by + have hremainingRead : (work tapes.remaining).read = Ξ“.blank := + hinv.remainingCount.read_eq_blank_iff.mpr rfl + have houtputParked : TM.Parked out := + parked_of_binaryPrefix_internal houtput + cases found with + | false => + have hfoundZero : (work tapes.found).HasBinaryNat 0 := by + simpa using! hinv.foundCount + have hfoundRead : (work tapes.found).read β‰  Ξ“.one := by + rw [hfoundZero.read_eq_blank_iff.mpr rfl] + decide + have hnotmemProcessed : address βˆ‰ processed.map Prod.fst := by + intro hmem + exact Bool.false_ne_true (hinv.progress.found_iff.mpr hmem) + have hnotmemStore : address βˆ‰ store.map Prod.fst := by + rw [hinv.progress.store_eq] + simpa using! hnotmemProcessed + by_cases hvalue : newValue = 0 + Β· subst newValue + have hreplacementRead : (work tapes.replacement).read = Ξ“.blank := + hinv.replacement.read_eq_blank_iff.mpr rfl + have hstep := entryUpdateTM_step_test_zero_internal tapes inp work out + hremainingRead hfoundRead hreplacementRead hinput hinv.ready.parked + houtputParked + obtain ⟨houtputEq, hcountEq⟩ := + hinv.progress.terminal_zero_internal + refine ⟨entryUpdateDoneCfg tapes inp work out, 1, ?_, + .step hstep .zero, rfl, rfl, ?_, ?_⟩ + Β· simp [entryUpdateLoopTime] + Β· exact + { ready := hinv.ready + replacement := hinv.replacement_eq + remaining := hinv.remainingCount + found := by simpa [hnotmemStore] using! hfoundZero + resultCount := by + simpa [hcountEq] using! hinv.resultCountTape + frame := hinv.frame } + Β· simpa [houtputEq] using! houtput + Β· have hreplacementRead : + (work tapes.replacement).read β‰  Ξ“.blank := by + intro hblank + exact hvalue (hinv.replacement.read_eq_blank_iff.mp hblank) + have htest := entryUpdateTM_step_test_append_internal tapes inp work out + hremainingRead hfoundRead hreplacementRead hinput hinv.ready.parked + houtputParked + have happendContract := entryAppendRestoreTM_hoareTime_frame + tapes.replace address newValue + (outPrefix ++ emitted.flatMap Entry.encode) work work inp out + hinv.ready hinv.replacement hinput houtput + obtain ⟨appendDone, appendTime, happendTime, happendReach, + happendHalt, happendInput, happendWork, happendOutput⟩ := + happendContract inp work out ⟨rfl, rfl, rfl⟩ + have happendReach' := + entryUpdateTM_append_reachesIn_internal tapes happendReach + have happendInputParked : TM.Parked appendDone.input := by + rw [happendInput] + exact hinput + have happendWorkParked : βˆ€ i, TM.Parked (appendDone.work i) := by + intro i + rw [happendWork] + exact hinv.ready.parked i + have happendOutputParked : TM.Parked appendDone.output := + parked_of_binaryPrefix_internal happendOutput + have happendSeam := entryUpdateTM_step_append_halt_internal tapes + appendDone happendHalt happendInputParked happendWorkParked + happendOutputParked + have hresultCount : + (appendDone.work tapes.resultCount).HasBinaryNat resultCount := by + rw [happendWork] + exact hinv.resultCountTape + obtain ⟨succDone, hsuccReach, hsuccHalt, hsuccInput, hsuccOther, + hsuccCount, hsuccOutput⟩ := + TM.binarySuccTM_reachesIn_frame tapes.resultCount resultCount + appendDone.input appendDone.work appendDone.output hresultCount + happendInputParked.read_ne_start + (fun i _ => (happendWorkParked i).read_ne_start) + happendOutputParked.read_ne_start + have hsuccReach' := + entryUpdateTM_appendCount_reachesIn_internal tapes hsuccReach + have hsuccInputParked : TM.Parked succDone.input := by + rw [hsuccInput] + exact happendInputParked + have hsuccWorkParked : βˆ€ i, TM.Parked (succDone.work i) := by + intro i + by_cases hi : i = tapes.resultCount + Β· subst i + exact entryUpdateParked_of_hasBinaryNat_internal hsuccCount + Β· rw [hsuccOther i hi] + exact happendWorkParked i + have hsuccOutputParked : TM.Parked succDone.output := by + rw [hsuccOutput] + exact happendOutputParked + have hfinish := entryUpdateTM_step_appendCount_halt_internal tapes + succDone hsuccHalt hsuccInputParked hsuccWorkParked + hsuccOutputParked + have hprefixReach : (entryUpdateTM tapes).reachesIn + (appendTime + 1) (entryUpdateTestCfg tapes inp work out) + (entryUpdateAppendWrap tapes appendDone) := + .step htest happendReach' + have hsuccPrefix : (entryUpdateTM tapes).reachesIn + (TM.binarySuccTime resultCount + 1) + (entryUpdateAppendWrap tapes appendDone) + (entryUpdateAppendCountWrap tapes succDone) := + .step happendSeam hsuccReach' + have htotalReach : (entryUpdateTM tapes).reachesIn + ((appendTime + 1) + (TM.binarySuccTime resultCount + 1) + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateDoneCfg tapes succDone.input succDone.work + succDone.output) := + TM.reachesIn_trans _ + (TM.reachesIn_trans _ hprefixReach hsuccPrefix) + (.step hfinish .zero) + have hotherWork : βˆ€ i, i β‰  tapes.resultCount β†’ + succDone.work i = work i := by + intro i hi + exact (hsuccOther i hi).trans (congrFun happendWork i) + have hreadyFinal := hinv.ready.change_resultCount_internal + hotherWork hsuccCount + obtain ⟨houtputEq, hcountEq⟩ := + hinv.progress.terminal_append_internal hvalue + have hfinalOutput : succDone.output.HasBinaryPrefix + (outPrefix ++ (RegisterStore.write store address newValue).flatMap + Entry.encode) := by + rw [hsuccOutput] + rw [← houtputEq] + simpa [List.flatMap_append, List.append_assoc] using! + happendOutput + have hfinalFrame : EntryUpdateFrame tapes initialWork succDone.work := + EntryUpdateFrame.trans_single_internal hinv.frame (12 : Fin 13) + (by + intro i hi + exact hotherWork i (by + simpa [EntryUpdateTapes.resultCount] using! hi)) + have hsuccTimeBound := + binarySuccTime_le_entryUpdateCountTime_internal hinv.resultCount_le + refine ⟨entryUpdateDoneCfg tapes succDone.input succDone.work + succDone.output, + (appendTime + 1) + (TM.binarySuccTime resultCount + 1) + 1, + ?_, htotalReach, rfl, ?_, ?_, ?_⟩ + Β· simp only [entryUpdateLoopTime] + omega + Β· simpa [entryUpdateDoneCfg] using! hsuccInput.trans happendInput + Β· exact + { ready := hreadyFinal + replacement := by + exact (hotherWork tapes.replacement + tapes.replacement_ne_resultCount).trans + hinv.replacement_eq + remaining := by + change (succDone.work tapes.remaining).HasBinaryNat 0 + rw [hotherWork tapes.remaining + tapes.remaining_ne_resultCount] + exact hinv.remainingCount + found := by + change (succDone.work tapes.found).HasBinaryNat + (if address ∈ store.map Prod.fst then 1 else 0) + rw [hotherWork tapes.found tapes.found_ne_resultCount] + simpa [hnotmemStore] using! hfoundZero + resultCount := by simpa [hcountEq] using! hsuccCount + frame := hfinalFrame } + Β· simpa [entryUpdateDoneCfg] using! hfinalOutput + | true => + have hfoundOne : (work tapes.found).HasBinaryNat 1 := by + simpa using! hinv.foundCount + have hfoundRead : (work tapes.found).read = Ξ“.one := by + simpa [Nat.bits, Ξ“.ofBool] using! + hfoundOne.2.hasBinarySuffix.read_cons + have hmemProcessed : address ∈ processed.map Prod.fst := + hinv.progress.found_iff.mp rfl + have hmemStore : address ∈ store.map Prod.fst := by + rw [hinv.progress.store_eq] + simpa using! hmemProcessed + have hstep := entryUpdateTM_step_test_found_internal tapes inp work out + hremainingRead hfoundRead hinput hinv.ready.parked houtputParked + obtain ⟨houtputEq, hcountEq⟩ := + hinv.progress.terminal_found_internal + refine ⟨entryUpdateDoneCfg tapes inp work out, 1, ?_, + .step hstep .zero, rfl, rfl, ?_, ?_⟩ + Β· simp [entryUpdateLoopTime] + Β· exact + { ready := hinv.ready + replacement := hinv.replacement_eq + remaining := hinv.remainingCount + found := by simpa [hmemStore] using! hfoundOne + resultCount := by simpa [hcountEq] using! hinv.resultCountTape + frame := hinv.frame } + Β· simpa [houtputEq] using! houtput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Hit.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Hit.lean new file mode 100644 index 0000000000..efa033b3da --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Hit.lean @@ -0,0 +1,654 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch + +/-! +# Bounded encoded sparse-store update -- matching iterations + +This file composes the checked match, deletion or replacement, and counter +subroutines for the two branches in which the current old entry has the +requested address. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Deletion and both counter decrements restore the complete next-iteration invariant. -/ +private theorem entryUpdateDelete_finalInvariant + (tapes : EntryUpdateTapes n) (store : Store) (address : β„•) + (processed emitted : Store) (entry : Entry) (rest : Store) (resultCount : β„•) + (initialWork work deleteWork countWork remainingWork : Fin n β†’ Tape) + (hinv : EntryUpdateLoopInv tapes store address 0 processed + (entry :: rest) emitted false resultCount initialWork work) + (haddress : address = entry.1) + (hfoundZero : (work tapes.found).HasBinaryNat 0) + (hdeleteReady : EntryScanReady tapes.entry (rest.flatMap Entry.encode) address.bits + (entryUpdateMarkFoundWork tapes work) deleteWork) + (hcountOther : βˆ€ i, i β‰  tapes.resultCount β†’ countWork i = deleteWork i) + (hcountValue : (countWork tapes.resultCount).HasBinaryNat (resultCount - 1)) + (hremainingOther : βˆ€ i, i β‰  tapes.remaining β†’ remainingWork i = countWork i) + (hremainingValue : (remainingWork tapes.remaining).HasBinaryNat rest.length) : + EntryUpdateLoopInv tapes store address 0 (processed ++ [entry]) rest + emitted true (resultCount - 1) initialWork remainingWork := by + have hreadyCount := hdeleteReady.change_resultCount_internal hcountOther hcountValue + have hreadyFinal := hreadyCount.change_remaining_internal hremainingOther hremainingValue + have hreplacementEq : + remainingWork tapes.replacement = + initialWork tapes.replacement := by + rw [hremainingOther tapes.replacement + (Ne.symm tapes.remaining_ne_replacement)] + rw [hcountOther tapes.replacement tapes.replacement_ne_resultCount] + rw [hdeleteReady.frame_outside_entry_internal tapes.replacement + tapes.replacement_ne_entry] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work + tapes.replacement tapes.replacement_ne_found] + exact hinv.replacement_eq + have hreplacementFinal : + (remainingWork tapes.replacement).HasBinaryNat 0 := by + rw [hreplacementEq] + rw [← hinv.replacement_eq] + exact hinv.replacement + have hfoundFinal : + (remainingWork tapes.found).HasBinaryNat 1 := by + rw [hremainingOther tapes.found + (Ne.symm tapes.remaining_ne_found)] + rw [hcountOther tapes.found tapes.found_ne_resultCount] + rw [hdeleteReady.frame_outside_entry_internal tapes.found + tapes.found_ne_entry] + exact entryUpdateMarkFoundWork_found_one_internal tapes work hfoundZero + have hresultFinal : + (remainingWork tapes.resultCount).HasBinaryNat + (resultCount - 1) := by + rw [hremainingOther tapes.resultCount + (Ne.symm tapes.remaining_ne_resultCount)] + exact hcountValue + have hframeMarked := hinv.frame.markFound_internal + have hframeDelete := + EntryUpdateFrame.trans_ready_internal hframeMarked hdeleteReady + have hframeCount := EntryUpdateFrame.trans_single_internal hframeDelete + (12 : Fin 13) (by + intro i hi + exact hcountOther i (by + simpa [EntryUpdateTapes.resultCount] using hi)) + have hframeFinal := EntryUpdateFrame.trans_single_internal hframeCount + (9 : Fin 13) (by + intro i hi + exact hremainingOther i (by + simpa [EntryUpdateTapes.remaining] using hi)) + have hprogress := hinv.progress.delete_internal haddress + have hinvFinal : EntryUpdateLoopInv tapes store address 0 + (processed ++ [entry]) rest emitted true (resultCount - 1) + initialWork remainingWork := + { progress := hprogress + ready := hreadyFinal + replacement := hreplacementFinal + replacement_eq := hreplacementEq + remainingCount := hremainingValue + foundCount := by simpa using hfoundFinal + resultCountTape := hresultFinal + resultCount_le := (Nat.sub_le resultCount 1).trans hinv.resultCount_le + frame := hframeFinal } + exact hinvFinal + +/-- A bounded positive result counter and ready cleanup fit the controller's deletion budget. -/ +private theorem entryUpdateDelete_branchBudget + (tapes : EntryUpdateTapes n) (entry : Entry) (rest : Store) + (address resultCount total deleteTime : β„•) (readyWork : Fin n β†’ Tape) + (hreadyMarked : EntryScanReady tapes.entry + (Entry.encode entry ++ rest.flatMap Entry.encode) address.bits readyWork readyWork) + (hdeleteTime : deleteTime ≀ entryMissCleanupTime tapes.entry entry address.bits readyWork) + (hresultPositive : 0 < resultCount) (hresultCountLe : resultCount ≀ total) : + deleteTime + 1 + TM.binaryPredTime (resultCount - 1) + 1 ≀ + entryUpdateBranchTime tapes entry address 0 total := by + have hcleanupBound : deleteTime ≀ + entryUpdateReadyCleanupTime tapes entry address := by + rw [← entryMissCleanupTime_eq_entryUpdateReadyCleanupTime_internal + tapes entry address hreadyMarked] + exact hdeleteTime + have hcountBound : TM.binaryPredTime (resultCount - 1) ≀ + entryUpdateCountTime total := by + apply binaryPredTime_le_entryUpdateCountTime_internal + calc + resultCount - 1 + 1 = resultCount := by omega + _ ≀ total := hresultCountLe + have hdeleteBranchBound : + deleteTime + 1 + TM.binaryPredTime (resultCount - 1) + 1 ≀ + entryUpdateBranchTime tapes entry address 0 total := by + have hthird : entryUpdateReadyCleanupTime tapes entry address + 1 + + entryUpdateCountTime total + 1 ≀ + entryUpdateBranchTime tapes entry address 0 total := by + unfold entryUpdateBranchTime + exact (le_max_right _ _).trans (le_max_right _ _) + omega + exact hdeleteBranchBound + +/-- A matching zero write deletes the current entry, decrements both runtime +counters, and returns to the loop test with no output contribution. -/ +theorem entryUpdateDeleteIteration_internal + (tapes : EntryUpdateTapes n) (store : Store) (address : β„•) + (processed emitted : Store) (entry : Entry) (rest : Store) + (resultCount : β„•) (initialWork work : Fin n β†’ Tape) + (outPrefix : List Bool) (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address 0 processed + (entry :: rest) emitted false resultCount initialWork work) + (haddress : address = entry.1) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ nextWork nextOut time, + time ≀ entryUpdateIterationTime tapes entry rest address 0 + store.length ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) + (entryUpdateTestCfg tapes inp nextWork nextOut) ∧ + EntryUpdateLoopInv tapes store address 0 (processed ++ [entry]) rest + emitted true (resultCount - 1) initialWork nextWork ∧ + nextOut.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode) := by + have hready : EntryScanReady tapes.entry + (Entry.encode entry ++ rest.flatMap Entry.encode) address.bits work work := by + simpa using hinv.ready + have hremainingPositive : + (work tapes.remaining).HasBinaryNat (rest.length + 1) := by + simpa using hinv.remainingCount + have hremainingRead : (work tapes.remaining).read β‰  Ξ“.blank := by + intro hblank + have hzero := hremainingPositive.read_eq_blank_iff.mp hblank + omega + have houtputParked : TM.Parked out := + parked_of_binaryPrefix_internal houtput + have htest := entryUpdateTM_step_test_continue_internal tapes inp work out + hremainingRead hinput hready.parked houtputParked + have hmatchContract := entryMatchReadTM_reachesIn_frame tapes.entry entry + (rest.flatMap Entry.encode) address.bits inp work out hready.source + hready.address hready.value hready.addressStart hready.valueStart + hready.addressCounter hready.addressWidth hready.valueCounter + hready.valueWidth hready.query hready.queryStart hready.result + hready.resultStart hinput hready.parked houtputParked + obtain ⟨matchDone, matchTime, hmatchTime, hmatchReach, hmatchHalt, + hmatchInput, hmatchInv, hmatchOutput⟩ := hmatchContract + have hmatchReach' := + entryUpdateTM_match_reachesIn_internal tapes hmatchReach + have hmatchInputParked : TM.Parked matchDone.input := by + rw [hmatchInput] + exact hinput + have hmatchOutputParked : TM.Parked matchDone.output := by + rw [hmatchOutput] + exact houtputParked + have hmatchFound : matchDone.work tapes.found = work tapes.found := + hmatchInv.frame_outside_entry_internal tapes.found + tapes.found_ne_entry + have hfoundZero : (work tapes.found).HasBinaryNat 0 := by + simpa using hinv.foundCount + have hmatchFoundZero : + (matchDone.work tapes.found).HasBinaryNat 0 := by + rw [hmatchFound] + exact hfoundZero + have hresultOne : (matchDone.work tapes.entry.result).read = Ξ“.one := + hmatchInv.result_read_eq_one_iff.mpr (congrArg Nat.bits haddress.symm) + have hmatchReplacement : + matchDone.work tapes.replacement = work tapes.replacement := + hmatchInv.frame_outside_entry_internal tapes.replacement + tapes.replacement_ne_entry + have hreplacementBlank : + (matchDone.work tapes.replacement).read = Ξ“.blank := by + rw [hmatchReplacement] + exact hinv.replacement.read_eq_blank_iff.mpr rfl + have hdispatch := entryUpdateTM_step_match_delete_internal tapes matchDone + hmatchHalt hresultOne hreplacementBlank hmatchInputParked hmatchInv.parked + hmatchOutputParked + have hmatchMarked := hmatchInv.markFound_internal hmatchFoundZero + have hreadyMarked := hready.markFound_internal hfoundZero + have hcleanupContract := entryMissCleanupTM_hoareTime_frame tapes.entry entry + (rest.flatMap Entry.encode) address.bits + (entryUpdateMarkFoundWork tapes work) + (entryUpdateMarkFoundWork tapes matchDone.work) + matchDone.input matchDone.output hmatchMarked hmatchInputParked + hmatchOutputParked + obtain ⟨deleteDone, deleteTime, hdeleteTime, hdeleteReach, hdeleteHalt, + hdeleteInput, hdeleteReady, hdeleteOutput⟩ := + hcleanupContract matchDone.input + (entryUpdateMarkFoundWork tapes matchDone.work) matchDone.output + ⟨rfl, rfl, rfl⟩ + have hdeleteReach' := + entryUpdateTM_delete_reachesIn_internal tapes hdeleteReach + have hdeleteInputParked : TM.Parked deleteDone.input := by + rw [hdeleteInput] + exact hmatchInputParked + have hdeleteOutputParked : TM.Parked deleteDone.output := by + rw [hdeleteOutput] + exact hmatchOutputParked + have hdeleteSeam := entryUpdateTM_step_delete_halt_internal tapes + deleteDone hdeleteHalt hdeleteInputParked hdeleteReady.parked + hdeleteOutputParked + have hdeleteResultCount : + (deleteDone.work tapes.resultCount).HasBinaryNat resultCount := by + rw [hdeleteReady.frame_outside_entry_internal tapes.resultCount + tapes.resultCount_ne_entry] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work + tapes.resultCount (Ne.symm tapes.found_ne_resultCount)] + exact hinv.resultCountTape + have hresultPositive : 0 < resultCount := by + rw [hinv.progress.resultCount_eq] + simp + have hdeleteResultCountPositive : + (deleteDone.work tapes.resultCount).HasBinaryNat + ((resultCount - 1) + 1) := by + convert hdeleteResultCount using 1 + omega + obtain ⟨countDone, hcountReach, hcountHalt, hcountInput, + hcountOther, hcountValue, hcountOutput⟩ := + TM.binaryPredTM_reachesIn_frame tapes.resultCount (resultCount - 1) + deleteDone.input deleteDone.work deleteDone.output + hdeleteResultCountPositive hdeleteInputParked.read_ne_start + (fun i _ => (hdeleteReady.parked i).read_ne_start) + hdeleteOutputParked.read_ne_start + have hcountReach' := + entryUpdateTM_deleteCount_reachesIn_internal tapes hcountReach + have hcountInputParked : TM.Parked countDone.input := by + rw [hcountInput] + exact hdeleteInputParked + have hcountWorkParked : βˆ€ i, TM.Parked (countDone.work i) := by + intro i + by_cases hi : i = tapes.resultCount + Β· subst i + exact entryUpdateParked_of_hasBinaryNat_internal hcountValue + Β· rw [hcountOther i hi] + exact hdeleteReady.parked i + have hcountOutputParked : TM.Parked countDone.output := by + rw [hcountOutput] + exact hdeleteOutputParked + have hcountSeam := entryUpdateTM_step_deleteCount_halt_internal tapes + countDone hcountHalt hcountInputParked hcountWorkParked + hcountOutputParked + have hcountRemaining : + (countDone.work tapes.remaining).HasBinaryNat (rest.length + 1) := by + rw [hcountOther tapes.remaining tapes.remaining_ne_resultCount] + rw [hdeleteReady.frame_outside_entry_internal tapes.remaining + tapes.remaining_ne_entry] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work + tapes.remaining tapes.remaining_ne_found] + exact hremainingPositive + obtain ⟨remainingDone, hremainingReach, hremainingHalt, + hremainingInput, hremainingOther, hremainingValue, + hremainingOutput⟩ := + TM.binaryPredTM_reachesIn_frame tapes.remaining rest.length + countDone.input countDone.work countDone.output hcountRemaining + hcountInputParked.read_ne_start + (fun i _ => (hcountWorkParked i).read_ne_start) + hcountOutputParked.read_ne_start + have hremainingReach' := + entryUpdateTM_remaining_reachesIn_internal tapes hremainingReach + have hremainingInputParked : TM.Parked remainingDone.input := by + rw [hremainingInput] + exact hcountInputParked + have hremainingWorkParked : βˆ€ i, TM.Parked (remainingDone.work i) := by + intro i + by_cases hi : i = tapes.remaining + Β· subst i + exact entryUpdateParked_of_hasBinaryNat_internal hremainingValue + Β· rw [hremainingOther i hi] + exact hcountWorkParked i + have hremainingOutputParked : TM.Parked remainingDone.output := by + rw [hremainingOutput] + exact hcountOutputParked + have hloop := entryUpdateTM_step_remaining_halt_internal tapes + remainingDone hremainingHalt hremainingInputParked hremainingWorkParked + hremainingOutputParked + have hprefix : (entryUpdateTM tapes).reachesIn (matchTime + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateMatchWrap tapes matchDone) := + .step htest hmatchReach' + have htoDelete : (entryUpdateTM tapes).reachesIn + (matchTime + 1 + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateDeleteWrap tapes + { state := (entryMissCleanupTM tapes.entry).qstart + input := matchDone.input + work := entryUpdateMarkFoundWork tapes matchDone.work + output := matchDone.output }) := + TM.reachesIn_trans _ hprefix (.step hdispatch .zero) + have hthroughDelete := TM.reachesIn_trans (entryUpdateTM tapes) + htoDelete hdeleteReach' + have htoCount := TM.reachesIn_trans (entryUpdateTM tapes) + hthroughDelete (.step hdeleteSeam .zero) + have hthroughCount := TM.reachesIn_trans (entryUpdateTM tapes) + htoCount hcountReach' + have htoRemaining := TM.reachesIn_trans (entryUpdateTM tapes) + hthroughCount (.step hcountSeam .zero) + have hthroughRemaining := TM.reachesIn_trans (entryUpdateTM tapes) + htoRemaining hremainingReach' + have htotalReach := TM.reachesIn_trans (entryUpdateTM tapes) + hthroughRemaining (.step hloop .zero) + have hinputEq : remainingDone.input = inp := + hremainingInput.trans (hcountInput.trans + (hdeleteInput.trans hmatchInput)) + have houtputEq : remainingDone.output = out := + hremainingOutput.trans (hcountOutput.trans + (hdeleteOutput.trans hmatchOutput)) + have hinvFinal := entryUpdateDelete_finalInvariant tapes store address processed emitted + entry rest resultCount initialWork work deleteDone.work countDone.work remainingDone.work + hinv haddress hfoundZero hdeleteReady hcountOther hcountValue + hremainingOther hremainingValue + have hdeleteBranchBound := entryUpdateDelete_branchBudget tapes entry rest address + resultCount store.length deleteTime (entryUpdateMarkFoundWork tapes work) + hreadyMarked hdeleteTime hresultPositive hinv.resultCount_le + refine ⟨remainingDone.work, remainingDone.output, + matchTime + 1 + 1 + deleteTime + 1 + + TM.binaryPredTime (resultCount - 1) + 1 + + TM.binaryPredTime rest.length + 1, + ?_, ?_, hinvFinal, ?_⟩ + Β· unfold entryUpdateIterationTime + omega + Β· simpa [hinputEq, Nat.add_assoc] using htotalReach + Β· rw [houtputEq] + exact houtput + +/-- Replacement and the remaining-count decrement restore the next-iteration invariant. -/ +private theorem entryUpdateReplace_finalInvariant + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (processed emitted : Store) (entry : Entry) (rest : Store) (resultCount : β„•) + (initialWork work matchedWork replaceWork remainingWork : Fin n β†’ Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed + (entry :: rest) emitted false resultCount initialWork work) + (haddress : address = entry.1) (hvalue : newValue β‰  0) + (hfoundZero : (work tapes.found).HasBinaryNat 0) + (hmatchReplacement : matchedWork tapes.replacement = work tapes.replacement) + (hreplaceReady : EntryScanReady tapes.entry (rest.flatMap Entry.encode) address.bits + (entryUpdateMarkFoundWork tapes work) replaceWork) + (hreplaceReplacement : replaceWork tapes.replace.replacement = + entryUpdateMarkFoundWork tapes matchedWork tapes.replace.replacement) + (hremainingOther : βˆ€ i, i β‰  tapes.remaining β†’ remainingWork i = replaceWork i) + (hremainingValue : (remainingWork tapes.remaining).HasBinaryNat rest.length) : + EntryUpdateLoopInv tapes store address newValue (processed ++ [entry]) rest + (emitted ++ [(address, newValue)]) true resultCount initialWork remainingWork := by + have hreadyFinal := hreplaceReady.change_remaining_internal hremainingOther hremainingValue + have hreplacementWorkEq : + remainingWork tapes.replacement = work tapes.replacement := by + rw [hremainingOther tapes.replacement + (Ne.symm tapes.remaining_ne_replacement)] + have hreplaceReplacement' : + replaceWork tapes.replacement = + entryUpdateMarkFoundWork tapes matchedWork + tapes.replacement := by + simpa only [EntryUpdateTapes.replace_replacement] using + hreplaceReplacement + rw [hreplaceReplacement'] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes matchedWork + tapes.replacement tapes.replacement_ne_found] + exact hmatchReplacement + have hreplacementEq : + remainingWork tapes.replacement = + initialWork tapes.replacement := + hreplacementWorkEq.trans hinv.replacement_eq + have hreplacementFinal : + (remainingWork tapes.replacement).HasBinaryNat newValue := by + rw [hreplacementWorkEq] + exact hinv.replacement + have hfoundFinal : + (remainingWork tapes.found).HasBinaryNat 1 := by + rw [hremainingOther tapes.found + (Ne.symm tapes.remaining_ne_found)] + rw [hreplaceReady.frame_outside_entry_internal tapes.found + tapes.found_ne_entry] + exact entryUpdateMarkFoundWork_found_one_internal tapes work hfoundZero + have hresultFinal : + (remainingWork tapes.resultCount).HasBinaryNat resultCount := by + rw [hremainingOther tapes.resultCount + (Ne.symm tapes.remaining_ne_resultCount)] + rw [hreplaceReady.frame_outside_entry_internal tapes.resultCount + tapes.resultCount_ne_entry] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work + tapes.resultCount (Ne.symm tapes.found_ne_resultCount)] + exact hinv.resultCountTape + have hframeMarked := hinv.frame.markFound_internal + have hframeReplace := + EntryUpdateFrame.trans_ready_internal hframeMarked hreplaceReady + have hframeFinal := EntryUpdateFrame.trans_single_internal hframeReplace + (9 : Fin 13) (by + intro i hi + exact hremainingOther i (by + simpa [EntryUpdateTapes.remaining] using hi)) + have hprogress := hinv.progress.replace_internal haddress hvalue + have hinvFinal : EntryUpdateLoopInv tapes store address newValue + (processed ++ [entry]) rest (emitted ++ [(address, newValue)]) true + resultCount initialWork remainingWork := + { progress := hprogress + ready := hreadyFinal + replacement := hreplacementFinal + replacement_eq := hreplacementEq + remainingCount := hremainingValue + foundCount := by simpa using hfoundFinal + resultCountTape := hresultFinal + resultCount_le := hinv.resultCount_le + frame := hframeFinal } + exact hinvFinal + +/-- A matching nonzero write emits the replacement entry, records the hit, +decrements the remaining-entry counter, and returns to the loop test. -/ +theorem entryUpdateReplaceIteration_internal + (tapes : EntryUpdateTapes n) (store : Store) + (address newValue : β„•) (processed emitted : Store) + (entry : Entry) (rest : Store) (resultCount : β„•) + (initialWork work : Fin n β†’ Tape) (outPrefix : List Bool) + (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed + (entry :: rest) emitted false resultCount initialWork work) + (haddress : address = entry.1) (hvalue : newValue β‰  0) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ nextWork nextOut time, + time ≀ entryUpdateIterationTime tapes entry rest address newValue + store.length ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) + (entryUpdateTestCfg tapes inp nextWork nextOut) ∧ + EntryUpdateLoopInv tapes store address newValue + (processed ++ [entry]) rest (emitted ++ [(address, newValue)]) true + resultCount initialWork nextWork ∧ + nextOut.HasBinaryPrefix + (outPrefix ++ (emitted ++ [(address, newValue)]).flatMap + Entry.encode) := by + have hready : EntryScanReady tapes.entry + (Entry.encode entry ++ rest.flatMap Entry.encode) address.bits work work := by + simpa using hinv.ready + have hremainingPositive : + (work tapes.remaining).HasBinaryNat (rest.length + 1) := by + simpa using hinv.remainingCount + have hremainingRead : (work tapes.remaining).read β‰  Ξ“.blank := by + intro hblank + have hzero := hremainingPositive.read_eq_blank_iff.mp hblank + omega + have houtputParked : TM.Parked out := + parked_of_binaryPrefix_internal houtput + have htest := entryUpdateTM_step_test_continue_internal tapes inp work out + hremainingRead hinput hready.parked houtputParked + have hmatchContract := entryMatchReadTM_reachesIn_frame tapes.entry entry + (rest.flatMap Entry.encode) address.bits inp work out hready.source + hready.address hready.value hready.addressStart hready.valueStart + hready.addressCounter hready.addressWidth hready.valueCounter + hready.valueWidth hready.query hready.queryStart hready.result + hready.resultStart hinput hready.parked houtputParked + obtain ⟨matchDone, matchTime, hmatchTime, hmatchReach, hmatchHalt, + hmatchInput, hmatchInv, hmatchOutput⟩ := hmatchContract + have hmatchReach' := + entryUpdateTM_match_reachesIn_internal tapes hmatchReach + have hmatchInputParked : TM.Parked matchDone.input := by + rw [hmatchInput] + exact hinput + have hmatchOutputParked : TM.Parked matchDone.output := by + rw [hmatchOutput] + exact houtputParked + have hmatchFound : matchDone.work tapes.found = work tapes.found := + hmatchInv.frame_outside_entry_internal tapes.found + tapes.found_ne_entry + have hfoundZero : (work tapes.found).HasBinaryNat 0 := by + simpa using hinv.foundCount + have hmatchFoundZero : + (matchDone.work tapes.found).HasBinaryNat 0 := by + rw [hmatchFound] + exact hfoundZero + have hresultOne : (matchDone.work tapes.entry.result).read = Ξ“.one := + hmatchInv.result_read_eq_one_iff.mpr (congrArg Nat.bits haddress.symm) + have hmatchReplacement : + matchDone.work tapes.replacement = work tapes.replacement := + hmatchInv.frame_outside_entry_internal tapes.replacement + tapes.replacement_ne_entry + have hmatchReplacementValue : + (matchDone.work tapes.replacement).HasBinaryNat newValue := by + rw [hmatchReplacement] + exact hinv.replacement + have hreplacementNonblank : + (matchDone.work tapes.replacement).read β‰  Ξ“.blank := by + intro hblank + exact hvalue (hmatchReplacementValue.read_eq_blank_iff.mp hblank) + have hdispatch := entryUpdateTM_step_match_replace_internal tapes matchDone + hmatchHalt hresultOne hreplacementNonblank hmatchInputParked + hmatchInv.parked hmatchOutputParked + have hmatchMarked := hmatchInv.markFound_internal hmatchFoundZero + have hreadyMarked := hready.markFound_internal hfoundZero + have hmarkedReplacement : + (entryUpdateMarkFoundWork tapes matchDone.work + tapes.replacement).HasBinaryNat newValue := by + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes matchDone.work + tapes.replacement tapes.replacement_ne_found] + exact hmatchReplacementValue + have hmatchOutputPrefix : matchDone.output.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode) := by + rw [hmatchOutput] + exact houtput + have hreplaceContract := entryReplaceCleanupTM_hoareTime_frame + tapes.replace entry newValue (rest.flatMap Entry.encode) address.bits + (outPrefix ++ emitted.flatMap Entry.encode) + (entryUpdateMarkFoundWork tapes work) + (entryUpdateMarkFoundWork tapes matchDone.work) + matchDone.input matchDone.output hmatchMarked hmarkedReplacement + hmatchInputParked hmatchOutputPrefix + obtain ⟨replaceDone, replaceTime, hreplaceTime, hreplaceReach, + hreplaceHalt, hreplaceInput, hreplaceReady, hreplaceReplacement, + hreplaceOutput⟩ := + hreplaceContract matchDone.input + (entryUpdateMarkFoundWork tapes matchDone.work) matchDone.output + ⟨rfl, rfl, rfl⟩ + have hreplaceReach' := + entryUpdateTM_replace_reachesIn_internal tapes hreplaceReach + have hreplaceInputParked : TM.Parked replaceDone.input := by + rw [hreplaceInput] + exact hmatchInputParked + have hreplaceOutputParked : TM.Parked replaceDone.output := + parked_of_binaryPrefix_internal hreplaceOutput + have hreplaceSeam := entryUpdateTM_step_replace_halt_internal tapes + replaceDone hreplaceHalt hreplaceInputParked hreplaceReady.parked + hreplaceOutputParked + have hreplaceRemaining : + (replaceDone.work tapes.remaining).HasBinaryNat (rest.length + 1) := by + rw [hreplaceReady.frame_outside_entry_internal tapes.remaining + tapes.remaining_ne_entry] + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work + tapes.remaining tapes.remaining_ne_found] + exact hremainingPositive + obtain ⟨remainingDone, hremainingReach, hremainingHalt, + hremainingInput, hremainingOther, hremainingValue, + hremainingOutput⟩ := + TM.binaryPredTM_reachesIn_frame tapes.remaining rest.length + replaceDone.input replaceDone.work replaceDone.output hreplaceRemaining + hreplaceInputParked.read_ne_start + (fun i _ => (hreplaceReady.parked i).read_ne_start) + hreplaceOutputParked.read_ne_start + have hremainingReach' := + entryUpdateTM_remaining_reachesIn_internal tapes hremainingReach + have hremainingInputParked : TM.Parked remainingDone.input := by + rw [hremainingInput] + exact hreplaceInputParked + have hremainingWorkParked : βˆ€ i, TM.Parked (remainingDone.work i) := by + intro i + by_cases hi : i = tapes.remaining + Β· subst i + exact entryUpdateParked_of_hasBinaryNat_internal hremainingValue + Β· rw [hremainingOther i hi] + exact hreplaceReady.parked i + have hremainingOutputParked : TM.Parked remainingDone.output := by + rw [hremainingOutput] + exact hreplaceOutputParked + have hloop := entryUpdateTM_step_remaining_halt_internal tapes + remainingDone hremainingHalt hremainingInputParked hremainingWorkParked + hremainingOutputParked + have hprefix : (entryUpdateTM tapes).reachesIn (matchTime + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateMatchWrap tapes matchDone) := + .step htest hmatchReach' + have htoReplace : (entryUpdateTM tapes).reachesIn + (matchTime + 1 + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateReplaceWrap tapes + { state := (entryReplaceCleanupTM tapes.replace).qstart + input := matchDone.input + work := entryUpdateMarkFoundWork tapes matchDone.work + output := matchDone.output }) := + TM.reachesIn_trans _ hprefix (.step hdispatch .zero) + have hthroughReplace := TM.reachesIn_trans (entryUpdateTM tapes) + htoReplace hreplaceReach' + have htoRemaining := TM.reachesIn_trans (entryUpdateTM tapes) + hthroughReplace (.step hreplaceSeam .zero) + have hthroughRemaining := TM.reachesIn_trans (entryUpdateTM tapes) + htoRemaining hremainingReach' + have htotalReach := TM.reachesIn_trans (entryUpdateTM tapes) + hthroughRemaining (.step hloop .zero) + have hinputEq : remainingDone.input = inp := + hremainingInput.trans (hreplaceInput.trans hmatchInput) + have hinvFinal := entryUpdateReplace_finalInvariant tapes store address newValue + processed emitted entry rest resultCount initialWork work matchDone.work replaceDone.work + remainingDone.work hinv haddress hvalue hfoundZero hmatchReplacement + hreplaceReady hreplaceReplacement hremainingOther hremainingValue + have hreplaceBound : replaceTime ≀ + entryUpdateReplaceTime tapes entry address newValue := by + exact hreplaceTime.trans + (entryReplaceCleanupTime_le_entryUpdateReplaceTime_internal tapes entry + address newValue (rest.flatMap Entry.encode) + (entryUpdateMarkFoundWork tapes work) + (entryUpdateMarkFoundWork tapes work) + (entryUpdateMarkFoundWork tapes matchDone.work) + hreadyMarked hmatchMarked) + have hreplaceBranchBound : replaceTime + 1 ≀ + entryUpdateBranchTime tapes entry address newValue store.length := by + have hfixed : entryUpdateReplaceTime tapes entry address newValue + 1 ≀ + entryUpdateBranchTime tapes entry address newValue store.length := by + unfold entryUpdateBranchTime + exact (le_max_left _ _).trans (le_max_right _ _) + omega + refine ⟨remainingDone.work, remainingDone.output, + matchTime + 1 + 1 + replaceTime + 1 + + TM.binaryPredTime rest.length + 1, + ?_, ?_, hinvFinal, ?_⟩ + Β· unfold entryUpdateIterationTime entryUpdateBranchTime + omega + Β· simpa [hinputEq, Nat.add_assoc] using htotalReach + Β· simpa [List.flatMap_append, haddress, List.append_assoc, + hremainingOutput] using hreplaceOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Inv.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Inv.lean new file mode 100644 index 0000000000..15bd9e47da --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Inv.lean @@ -0,0 +1,412 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Ctrl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Internal.Inv +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc + +/-! +# Bounded encoded sparse-store update β€” invariant internals + +Tape-layout views and frame lemmas used by the semantic update loop. In +particular, this file isolates the only controller-local mutation: changing +the canonical zero-valued `found` tape to canonical one after a hit. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +namespace EntryUpdateTapes + +/-- View the update layout as an entry scanner whose count is `remaining`. -/ +def remainingScan (tapes : EntryUpdateTapes n) : EntryScanTapes n where + entry := tapes.entry + count := tapes.remaining + count_ne := by + intro i h + change tapes.idx 9 = tapes.idx ⟨i.val, by omega⟩ at h + have h' : (9 : Fin 13) = ⟨i.val, by omega⟩ := tapes.injective h + have hv := congrArg (fun k : Fin 13 => k.val) h' + change 9 = i.val at hv + omega + +/-- View the update layout as an entry scanner whose count is `resultCount`. -/ +def resultScan (tapes : EntryUpdateTapes n) : EntryScanTapes n where + entry := tapes.entry + count := tapes.resultCount + count_ne := by + intro i h + change tapes.idx 12 = tapes.idx ⟨i.val, by omega⟩ at h + have h' : (12 : Fin 13) = ⟨i.val, by omega⟩ := tapes.injective h + have hv := congrArg (fun k : Fin 13 => k.val) h' + change 12 = i.val at hv + omega + +@[simp] theorem remainingScan_entry (tapes : EntryUpdateTapes n) : + tapes.remainingScan.entry = tapes.entry := rfl + +@[simp] theorem remainingScan_count (tapes : EntryUpdateTapes n) : + tapes.remainingScan.count = tapes.remaining := rfl + +@[simp] theorem resultScan_entry (tapes : EntryUpdateTapes n) : + tapes.resultScan.entry = tapes.entry := rfl + +@[simp] theorem resultScan_count (tapes : EntryUpdateTapes n) : + tapes.resultScan.count = tapes.resultCount := rfl + +/-- The remaining count is outside every entry-machine tape. -/ +theorem remaining_ne_entry (tapes : EntryUpdateTapes n) (i : Fin 9) : + tapes.remaining β‰  tapes.entry.idx i := + tapes.remainingScan.count_ne i + +/-- The replacement source is outside every entry-machine tape. -/ +theorem replacement_ne_entry (tapes : EntryUpdateTapes n) (i : Fin 9) : + tapes.replacement β‰  tapes.entry.idx i := by + change tapes.idx 10 β‰  tapes.idx ⟨i.val, by omega⟩ + apply tapes.ne + intro h + have hv := congrArg (fun k : Fin 13 => k.val) h + change 10 = i.val at hv + omega + +/-- The found flag is outside every entry-machine tape. -/ +theorem found_ne_entry (tapes : EntryUpdateTapes n) (i : Fin 9) : + tapes.found β‰  tapes.entry.idx i := by + change tapes.idx 11 β‰  tapes.idx ⟨i.val, by omega⟩ + apply tapes.ne + intro h + have hv := congrArg (fun k : Fin 13 => k.val) h + change 11 = i.val at hv + omega + +/-- The result count is outside every entry-machine tape. -/ +theorem resultCount_ne_entry (tapes : EntryUpdateTapes n) (i : Fin 9) : + tapes.resultCount β‰  tapes.entry.idx i := + tapes.resultScan.count_ne i + +/-- The remaining count and replacement source are distinct. -/ +theorem remaining_ne_replacement (tapes : EntryUpdateTapes n) : + tapes.remaining β‰  tapes.replacement := + tapes.ne (by decide) + +/-- The remaining count and found flag are distinct. -/ +theorem remaining_ne_found (tapes : EntryUpdateTapes n) : + tapes.remaining β‰  tapes.found := + tapes.ne (by decide) + +/-- The remaining and result counts are distinct. -/ +theorem remaining_ne_resultCount (tapes : EntryUpdateTapes n) : + tapes.remaining β‰  tapes.resultCount := + tapes.ne (by decide) + +/-- The replacement source and found flag are distinct. -/ +theorem replacement_ne_found (tapes : EntryUpdateTapes n) : + tapes.replacement β‰  tapes.found := + tapes.ne (by decide) + +/-- The replacement source and result count are distinct. -/ +theorem replacement_ne_resultCount (tapes : EntryUpdateTapes n) : + tapes.replacement β‰  tapes.resultCount := + tapes.ne (by decide) + +/-- The found flag and result count are distinct. -/ +theorem found_ne_resultCount (tapes : EntryUpdateTapes n) : + tapes.found β‰  tapes.resultCount := + tapes.ne (by decide) + +end EntryUpdateTapes + +/-- The hit-marking update changes exactly the found tape. -/ +theorem entryUpdateMarkFoundWork_apply_eq_internal + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) : + entryUpdateMarkFoundWork tapes work tapes.found = + (work tapes.found).writeAndMove Ξ“.one + (TM.idleDir (work tapes.found).read) := by + simp [entryUpdateMarkFoundWork] + +/-- The hit-marking update preserves every tape other than the found tape. -/ +theorem entryUpdateMarkFoundWork_apply_ne_internal + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) + (i : Fin n) (hi : i β‰  tapes.found) : + entryUpdateMarkFoundWork tapes work i = work i := by + simp [entryUpdateMarkFoundWork, Function.update_of_ne hi] + +/-- Writing `1` over the parked canonical zero flag produces canonical one. -/ +theorem entryUpdateMarkFoundWork_found_one_internal + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) + (hfound : (work tapes.found).HasBinaryNat 0) : + (entryUpdateMarkFoundWork tapes work tapes.found).HasBinaryNat 1 := by + rw [entryUpdateMarkFoundWork_apply_eq_internal] + rw [hfound.eq_init_move_right] + have heq : + (((Tape.init ((0 : β„•).bits.map Ξ“.ofBool)).move Dir3.right).writeAndMove + Ξ“.one + (TM.idleDir + ((Tape.init ((0 : β„•).bits.map Ξ“.ofBool)).move Dir3.right).read)) = + (Tape.init ((1 : β„•).bits.map Ξ“.ofBool)).move Dir3.right := by + apply Tape.ext + Β· simp [TM.idleDir, Tape.read, Tape.write, Tape.move, Tape.init, + Nat.bits] + Β· funext i + cases i with + | zero => + simp [TM.idleDir, Tape.read, Tape.write, Tape.move, Tape.init, + Nat.bits] + | succ i => + cases i with + | zero => + simp [TM.idleDir, Tape.read, Tape.write, Tape.move, Tape.init, + Nat.bits, Ξ“.ofBool] + | succ i => + simp [TM.idleDir, Tape.read, Tape.write, Tape.move, Tape.init, + Nat.bits] + rw [heq] + exact Tape.init_move_right_hasBinaryNat 1 + +/-- Canonical natural-number tapes are parked away from the left marker. -/ +theorem entryUpdateParked_of_hasBinaryNat_internal {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + exact ⟨by simp [Tape.HasBinaryNat, Tape.HasBinaryString] at h; omega, + h.2.hasBinaryContent.cells_ne_start⟩ + +/-- Marking a canonical zero found flag preserves parkedness of the complete +work family. -/ +theorem entryUpdateMarkFoundWork_parked_internal + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) + (hfound : (work tapes.found).HasBinaryNat 0) + (hparked : βˆ€ i, TM.Parked (work i)) : + βˆ€ i, TM.Parked (entryUpdateMarkFoundWork tapes work i) := by + intro i + by_cases hi : i = tapes.found + Β· subst i + exact entryUpdateParked_of_hasBinaryNat_internal + (entryUpdateMarkFoundWork_found_one_internal tapes work hfound) + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work i hi] + exact hparked i + +/-- The marked found flag exposes `1` directly under its parked head. -/ +theorem entryUpdateMarkFoundWork_found_read_one_internal + (tapes : EntryUpdateTapes n) (work : Fin n β†’ Tape) + (hfound : (work tapes.found).HasBinaryNat 0) : + (entryUpdateMarkFoundWork tapes work tapes.found).read = Ξ“.one := by + have h := entryUpdateMarkFoundWork_found_one_internal tapes work hfound + simpa [Nat.bits, Ξ“.ofBool] using h.2.hasBinarySuffix.read_cons + +/-- The frame component of an entry-ready endpoint can be queried with one +uniform proof that an index lies outside the nine entry-machine tapes. -/ +theorem EntryScanReady.frame_outside_entry_internal + {tapes : EntryUpdateTapes n} {remaining queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanReady tapes.entry remaining queryBits initialWork finalWork) + (i : Fin n) (houtside : βˆ€ j : Fin 9, i β‰  tapes.entry.idx j) : + finalWork i = initialWork i := + h.frame i (houtside 0) (houtside 1) (houtside 2) (houtside 3) + (houtside 4) (houtside 5) (houtside 6) (houtside 7) (houtside 8) + +/-- The frame component of a readable match can be queried uniformly outside +the nine entry-machine tapes. -/ +theorem ReadableEntryMatch.frame_outside_entry_internal + {tapes : EntryUpdateTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : ReadableEntryMatch tapes.entry entry rest queryBits + initialWork finalWork) + (i : Fin n) (houtside : βˆ€ j : Fin 9, i β‰  tapes.entry.idx j) : + finalWork i = initialWork i := + h.frame i (houtside 0) (houtside 1) (houtside 2) (houtside 3) + (houtside 4) (houtside 5) (houtside 6) (houtside 7) (houtside 8) + +/-- Marking the external found flag preserves an entry-ready invariant while +updating both sides of its exact frame. -/ +theorem EntryScanReady.markFound_internal + {tapes : EntryUpdateTapes n} {remaining queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : EntryScanReady tapes.entry remaining queryBits initialWork finalWork) + (hfound : (finalWork tapes.found).HasBinaryNat 0) : + EntryScanReady tapes.entry remaining queryBits + (entryUpdateMarkFoundWork tapes initialWork) + (entryUpdateMarkFoundWork tapes finalWork) := by + have hfoundFrame : finalWork tapes.found = initialWork tapes.found := + h.frame_outside_entry_internal tapes.found tapes.found_ne_entry + have hsource : tapes.entry.source β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 0) + have haddress : tapes.entry.address β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 1) + have hvalue : tapes.entry.value β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 2) + have haddressCounter : tapes.entry.addressCounter β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 3) + have haddressWidth : tapes.entry.addressWidth β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 4) + have hvalueCounter : tapes.entry.valueCounter β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 5) + have hvalueWidth : tapes.entry.valueWidth β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 6) + have hquery : tapes.entry.query β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 7) + have hresult : tapes.entry.result β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 8) + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hsource] + exact h.source + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddress] + exact h.address + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddress] + exact h.addressStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalue] + exact h.value + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalue] + exact h.valueStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddressCounter] + exact h.addressCounter + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddressWidth] + exact h.addressWidth + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalueCounter] + exact h.valueCounter + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalueWidth] + exact h.valueWidth + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hquery] + exact h.query + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hquery] + exact h.queryStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hresult] + exact h.result + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hresult] + exact h.resultStart + Β· exact entryUpdateMarkFoundWork_parked_internal tapes finalWork hfound h.parked + Β· intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + by_cases hi : i = tapes.found + Β· subst i + rw [entryUpdateMarkFoundWork_apply_eq_internal, + entryUpdateMarkFoundWork_apply_eq_internal, hfoundFrame] + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi, + entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi] + exact h.frame i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + +/-- Marking the external found flag preserves a readable matched-entry +endpoint while updating both sides of its exact frame. -/ +theorem ReadableEntryMatch.markFound_internal + {tapes : EntryUpdateTapes n} {entry : Entry} {rest queryBits : List Bool} + {initialWork finalWork : Fin n β†’ Tape} + (h : ReadableEntryMatch tapes.entry entry rest queryBits + initialWork finalWork) + (hfound : (finalWork tapes.found).HasBinaryNat 0) : + ReadableEntryMatch tapes.entry entry rest queryBits + (entryUpdateMarkFoundWork tapes initialWork) + (entryUpdateMarkFoundWork tapes finalWork) := by + have hfoundFrame : finalWork tapes.found = initialWork tapes.found := + h.frame_outside_entry_internal tapes.found tapes.found_ne_entry + have hsource : tapes.entry.source β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 0) + have haddress : tapes.entry.address β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 1) + have hvalue : tapes.entry.value β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 2) + have haddressCounter : tapes.entry.addressCounter β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 3) + have haddressWidth : tapes.entry.addressWidth β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 4) + have hvalueCounter : tapes.entry.valueCounter β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 5) + have hvalueWidth : tapes.entry.valueWidth β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 6) + have hquery : tapes.entry.query β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 7) + have hresult : tapes.entry.result β‰  tapes.found := + Ne.symm (tapes.found_ne_entry 8) + constructor + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hsource] + exact h.source + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddress] + exact h.address + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddress] + exact h.addressStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalue] + exact h.value + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalue] + exact h.valueStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddressCounter] + exact h.addressCounter + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddressCounter] + exact h.addressCounterStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ haddressWidth] + exact h.addressWidth + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalueCounter] + exact h.valueCounter + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalueCounter] + exact h.valueCounterStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hvalueWidth] + exact h.valueWidth + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hquery] + exact h.query + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hquery] + exact h.queryStart + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hresult] + exact h.result + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hresult] + exact h.resultStart + Β· exact entryUpdateMarkFoundWork_parked_internal tapes finalWork hfound h.parked + Β· intro i + by_cases hi : i = tapes.found + Β· subst i + rw [entryUpdateMarkFoundWork_apply_eq_internal, + entryUpdateMarkFoundWork_apply_eq_internal, hfoundFrame] + exact Nat.le_add_right _ _ + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi, + entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi] + exact h.headBound i + Β· intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + by_cases hi : i = tapes.found + Β· subst i + rw [entryUpdateMarkFoundWork_apply_eq_internal, + entryUpdateMarkFoundWork_apply_eq_internal, hfoundFrame] + Β· rw [entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi, + entryUpdateMarkFoundWork_apply_ne_internal _ _ _ hi] + exact h.frame i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + +/-- A frame-rich binary operation on the remaining-count tape preserves and +rebases the entry-ready invariant. -/ +theorem EntryScanReady.change_remaining_internal + {tapes : EntryUpdateTapes n} {remaining queryBits : List Bool} + {initialWork work finalWork : Fin n β†’ Tape} {count : β„•} + (h : EntryScanReady tapes.entry remaining queryBits initialWork work) + (hother : βˆ€ i, i β‰  tapes.remaining β†’ finalWork i = work i) + (hcount : (finalWork tapes.remaining).HasBinaryNat count) : + EntryScanReady tapes.entry remaining queryBits finalWork finalWork := by + exact h.change_count_internal (tapes := tapes.remainingScan) hother hcount + +/-- A frame-rich binary operation on the result-count tape preserves and +rebases the entry-ready invariant. -/ +theorem EntryScanReady.change_resultCount_internal + {tapes : EntryUpdateTapes n} {remaining queryBits : List Bool} + {initialWork work finalWork : Fin n β†’ Tape} {count : β„•} + (h : EntryScanReady tapes.entry remaining queryBits initialWork work) + (hother : βˆ€ i, i β‰  tapes.resultCount β†’ finalWork i = work i) + (hcount : (finalWork tapes.resultCount).HasBinaryNat count) : + EntryScanReady tapes.entry remaining queryBits finalWork finalWork := by + exact h.change_count_internal (tapes := tapes.resultScan) hother hcount + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Loop.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Loop.lean new file mode 100644 index 0000000000..5136e6bf8e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Loop.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Progress +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Inv + +/-! +# Bounded encoded sparse-store update β€” loop invariant internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Tape and list semantics carried between controller iterations. -/ +structure EntryUpdateLoopInv (tapes : EntryUpdateTapes n) + (store : Store) (address newValue : β„•) + (processed remaining emitted : Store) (found : Bool) + (resultCount : β„•) (initialWork work : Fin n β†’ Tape) : Prop where + progress : EntryUpdateProgress store address newValue processed remaining + emitted found resultCount + ready : EntryScanReady tapes.entry (remaining.flatMap Entry.encode) + address.bits work work + replacement : (work tapes.replacement).HasBinaryNat newValue + replacement_eq : work tapes.replacement = initialWork tapes.replacement + remainingCount : (work tapes.remaining).HasBinaryNat remaining.length + foundCount : (work tapes.found).HasBinaryNat + (if found = true then 1 else 0) + resultCountTape : (work tapes.resultCount).HasBinaryNat resultCount + resultCount_le : resultCount ≀ store.length + frame : EntryUpdateFrame tapes initialWork work + +/-- The controller frame is reflexive. -/ +theorem entryUpdateFrame_refl_internal (tapes : EntryUpdateTapes n) + (work : Fin n β†’ Tape) : EntryUpdateFrame tapes work work := by + intro _ _ + rfl + +/-- Controller frames compose. -/ +theorem EntryUpdateFrame.trans_internal + {tapes : EntryUpdateTapes n} {workβ‚€ work₁ workβ‚‚ : Fin n β†’ Tape} + (h₁ : EntryUpdateFrame tapes workβ‚€ work₁) + (hβ‚‚ : EntryUpdateFrame tapes work₁ workβ‚‚) : + EntryUpdateFrame tapes workβ‚€ workβ‚‚ := by + intro i hi + exact (hβ‚‚ i hi).trans (h₁ i hi) + +/-- Changing the found flag preserves the frame outside all controller tapes. -/ +theorem EntryUpdateFrame.markFound_internal + {tapes : EntryUpdateTapes n} {initialWork work : Fin n β†’ Tape} + (h : EntryUpdateFrame tapes initialWork work) : + EntryUpdateFrame tapes initialWork (entryUpdateMarkFoundWork tapes work) := by + intro i hi + have hfound : i β‰  tapes.found := by + simpa [EntryUpdateTapes.found] using hi (11 : Fin 13) + rw [entryUpdateMarkFoundWork_apply_ne_internal tapes work i hfound] + exact h i hi + +/-- An entry-machine frame extends an existing controller frame. -/ +theorem EntryUpdateFrame.trans_ready_internal + {tapes : EntryUpdateTapes n} {remaining queryBits : List Bool} + {initialWork work finalWork : Fin n β†’ Tape} + (hframe : EntryUpdateFrame tapes initialWork work) + (hready : EntryScanReady tapes.entry remaining queryBits work finalWork) : + EntryUpdateFrame tapes initialWork finalWork := by + intro i hi + have hslot (slot : Fin 9) : i β‰  tapes.entry.idx slot := by + simpa [EntryUpdateTapes.entry] using hi ⟨slot, by omega⟩ + exact (hready.frame i + (by simpa [EntryMatchTapes.source] using hslot 0) + (by simpa [EntryMatchTapes.address] using hslot 1) + (by simpa [EntryMatchTapes.value] using hslot 2) + (by simpa [EntryMatchTapes.addressCounter] using hslot 3) + (by simpa [EntryMatchTapes.addressWidth] using hslot 4) + (by simpa [EntryMatchTapes.valueCounter] using hslot 5) + (by simpa [EntryMatchTapes.valueWidth] using hslot 6) + (by simpa [EntryMatchTapes.query] using hslot 7) + (by simpa [EntryMatchTapes.result] using hslot 8)).trans + (hframe i hi) + +/-- A one-tape arithmetic frame extends an existing controller frame. -/ +theorem EntryUpdateFrame.trans_single_internal + {tapes : EntryUpdateTapes n} {initialWork work finalWork : Fin n β†’ Tape} + (hframe : EntryUpdateFrame tapes initialWork work) (slot : Fin 13) + (hother : βˆ€ i, i β‰  tapes.idx slot β†’ finalWork i = work i) : + EntryUpdateFrame tapes initialWork finalWork := by + intro i hi + exact (hother i (hi slot)).trans (hframe i hi) + +/-- The public initial tape contract establishes the first loop invariant. -/ +theorem entryUpdateLoopInv_initial_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (work : Fin n β†’ Tape) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits work work) + (hreplacement : (work tapes.replacement).HasBinaryNat newValue) + (hremaining : (work tapes.remaining).HasBinaryNat store.length) + (hfound : (work tapes.found).HasBinaryNat 0) + (hresultCount : (work tapes.resultCount).HasBinaryNat store.length) : + EntryUpdateLoopInv tapes store address newValue [] store [] false + store.length work work := by + exact ⟨entryUpdateProgress_initial_internal store address newValue, + hready, hreplacement, rfl, hremaining, by simpa using hfound, + hresultCount, le_rfl, entryUpdateFrame_refl_internal tapes work⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Miss.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Miss.lean new file mode 100644 index 0000000000..c980b73785 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Miss.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Time +public import Mathlib.Data.Nat.Bitwise +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch + +/-! +# Bounded encoded sparse-store update -- unmatched entry iteration +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem nat_eq_of_bits_eq {a b : β„•} (h : a.bits = b.bits) : a = b := by + apply Nat.eq_of_testBit_eq + intro i + rw [Nat.testBit_eq_inth, Nat.testBit_eq_inth, h] + +/-- One unmatched old entry is copied to the output, its remaining-count unit +is consumed, and the update controller returns to its loop-test state. -/ +theorem entryUpdateIteration_miss_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (processed emitted : Store) (entry : Entry) (rest : Store) + (found : Bool) (resultCount : β„•) + (initialWork work : Fin n β†’ Tape) (outPrefix : List Bool) + (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed + (entry :: rest) emitted found resultCount initialWork work) + (hne : entry.1 β‰  address) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ nextWork nextOut time, + time ≀ entryUpdateIterationTime tapes entry rest address newValue + store.length ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) + (entryUpdateTestCfg tapes inp nextWork nextOut) ∧ + EntryUpdateLoopInv tapes store address newValue + (processed ++ [entry]) rest (emitted ++ [entry]) found resultCount + initialWork nextWork ∧ + nextOut.HasBinaryPrefix + (outPrefix ++ (emitted ++ [entry]).flatMap Entry.encode) := by + have hready : EntryScanReady tapes.entry + (Entry.encode entry ++ rest.flatMap Entry.encode) address.bits work work := by + simpa using hinv.ready + have hremainingPositive : + (work tapes.remaining).HasBinaryNat (rest.length + 1) := by + simpa using hinv.remainingCount + have hremainingRead : (work tapes.remaining).read β‰  Ξ“.blank := by + intro hblank + have hzero := hremainingPositive.read_eq_blank_iff.mp hblank + omega + have houtputParked : TM.Parked out := + parked_of_binaryPrefix_internal houtput + have htest := entryUpdateTM_step_test_continue_internal tapes inp work out + hremainingRead hinput hready.parked houtputParked + have hmatchContract := entryMatchReadTM_reachesIn_frame tapes.entry entry + (rest.flatMap Entry.encode) address.bits inp work out hready.source + hready.address hready.value hready.addressStart hready.valueStart + hready.addressCounter hready.addressWidth hready.valueCounter + hready.valueWidth hready.query hready.queryStart hready.result + hready.resultStart hinput hready.parked houtputParked + obtain ⟨matchDone, matchTime, hmatchTime, hmatchReach, hmatchHalt, + hmatchInput, hmatchInv, hmatchOutput⟩ := hmatchContract + have hmatchReach' := + entryUpdateTM_match_reachesIn_internal tapes hmatchReach + have hmatchInputParked : TM.Parked matchDone.input := by + rw [hmatchInput] + exact hinput + have hmatchOutputPrefix : matchDone.output.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode) := by + rw [hmatchOutput] + exact houtput + have hmatchOutputParked : TM.Parked matchDone.output := + parked_of_binaryPrefix_internal hmatchOutputPrefix + have hresultNotOne : + (matchDone.work tapes.entry.result).read β‰  Ξ“.one := by + intro hone + apply hne + exact nat_eq_of_bits_eq (hmatchInv.result_read_eq_one_iff.mp hone) + have hdispatch := entryUpdateTM_step_match_miss_internal tapes matchDone + hmatchHalt hresultNotOne hmatchInputParked hmatchInv.parked + hmatchOutputParked + have hmissContract := entryMissCopyTM_hoareTime_frame tapes.entry entry + (rest.flatMap Entry.encode) address.bits + (outPrefix ++ emitted.flatMap Entry.encode) work matchDone.work + matchDone.input matchDone.output hmatchInv hmatchInputParked + hmatchOutputPrefix + obtain ⟨missDone, missTime, hmissTime, hmissReach, hmissHalt, + hmissInput, hmissReady, hmissOutput⟩ := + hmissContract matchDone.input matchDone.work matchDone.output + ⟨rfl, rfl, rfl⟩ + have hmissReach' := entryUpdateTM_miss_reachesIn_internal tapes hmissReach + have hmissInputParked : TM.Parked missDone.input := by + rw [hmissInput, hmatchInput] + exact hinput + have hmissOutputParked : TM.Parked missDone.output := + parked_of_binaryPrefix_internal hmissOutput + have hmissExit := entryUpdateTM_step_miss_halt_internal tapes missDone + hmissHalt hmissInputParked hmissReady.parked hmissOutputParked + have hremainingMiss : + (missDone.work tapes.remaining).HasBinaryNat (rest.length + 1) := by + rw [hmissReady.frame_outside_entry_internal tapes.remaining + tapes.remaining_ne_entry] + exact hremainingPositive + obtain ⟨predDone, hpredReach, hpredHalt, hpredInput, hpredOther, + hpredCount, hpredOutput⟩ := + TM.binaryPredTM_reachesIn_frame tapes.remaining rest.length + missDone.input missDone.work missDone.output hremainingMiss + hmissInputParked.read_ne_start + (fun i _ => (hmissReady.parked i).read_ne_start) + hmissOutputParked.read_ne_start + have hpredReach' := + entryUpdateTM_remaining_reachesIn_internal tapes hpredReach + have hreadyPred := hmissReady.change_remaining_internal hpredOther hpredCount + have hpredInputParked : TM.Parked predDone.input := by + rw [hpredInput] + exact hmissInputParked + have hpredOutputParked : TM.Parked predDone.output := by + rw [hpredOutput] + exact hmissOutputParked + have hloop := entryUpdateTM_step_remaining_halt_internal tapes predDone + hpredHalt hpredInputParked hreadyPred.parked hpredOutputParked + have hinputFinal : predDone.input = inp := + hpredInput.trans (hmissInput.trans hmatchInput) + have hloop' : (entryUpdateTM tapes).step + (entryUpdateRemainingWrap tapes predDone) = + some (entryUpdateTestCfg tapes inp predDone.work predDone.output) := by + simpa [hinputFinal] using hloop + have hmatchPrefix : (entryUpdateTM tapes).reachesIn (matchTime + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateMatchWrap tapes matchDone) := + .step htest hmatchReach' + have htoMiss : (entryUpdateTM tapes).reachesIn (matchTime + 1 + 1) + (entryUpdateTestCfg tapes inp work out) + (entryUpdateMissWrap tapes + { state := (entryMissCopyTM tapes.entry).qstart + input := matchDone.input + work := matchDone.work + output := matchDone.output }) := + TM.reachesIn_trans _ hmatchPrefix (.step hdispatch .zero) + have hthroughMiss := + TM.reachesIn_trans (entryUpdateTM tapes) htoMiss hmissReach' + have htoPred := TM.reachesIn_trans (entryUpdateTM tapes) hthroughMiss + (.step hmissExit .zero) + have hthroughPred := + TM.reachesIn_trans (entryUpdateTM tapes) htoPred hpredReach' + have hreach := TM.reachesIn_trans (entryUpdateTM tapes) hthroughPred + (.step hloop' .zero) + have hmissStatic : + missTime ≀ entryUpdateMissTime tapes entry address := + le_trans hmissTime + (entryMissCopyTime_le_entryUpdateMissTime_internal tapes entry address + (rest.flatMap Entry.encode) work work matchDone.work hready hmatchInv) + have htime : + 1 + matchTime + 1 + missTime + 1 + + TM.binaryPredTime rest.length + 1 ≀ + entryUpdateIterationTime tapes entry rest address newValue + store.length := by + have hbranch : entryUpdateMissTime tapes entry address + 1 ≀ + entryUpdateBranchTime tapes entry address newValue store.length := + le_max_left _ _ + unfold entryUpdateIterationTime + omega + have hreplacementMiss : + missDone.work tapes.replacement = work tapes.replacement := + hmissReady.frame_outside_entry_internal tapes.replacement + tapes.replacement_ne_entry + have hfoundMiss : missDone.work tapes.found = work tapes.found := + hmissReady.frame_outside_entry_internal tapes.found tapes.found_ne_entry + have hresultCountMiss : + missDone.work tapes.resultCount = work tapes.resultCount := + hmissReady.frame_outside_entry_internal tapes.resultCount + tapes.resultCount_ne_entry + have hreplacementPred : + predDone.work tapes.replacement = missDone.work tapes.replacement := + hpredOther tapes.replacement + (Ne.symm tapes.remaining_ne_replacement) + have hfoundPred : predDone.work tapes.found = missDone.work tapes.found := + hpredOther tapes.found (Ne.symm tapes.remaining_ne_found) + have hresultCountPred : + predDone.work tapes.resultCount = missDone.work tapes.resultCount := + hpredOther tapes.resultCount (Ne.symm tapes.remaining_ne_resultCount) + have hframeMiss : EntryUpdateFrame tapes initialWork missDone.work := + hinv.frame.trans_ready_internal hmissReady + have hframePred : EntryUpdateFrame tapes initialWork predDone.work := + EntryUpdateFrame.trans_single_internal hframeMiss (9 : Fin 13) (by + intro i hi + apply hpredOther i + simpa [EntryUpdateTapes.remaining] using hi) + have hnextInv : EntryUpdateLoopInv tapes store address newValue + (processed ++ [entry]) rest (emitted ++ [entry]) found resultCount + initialWork predDone.work := by + refine ⟨hinv.progress.miss_internal hne, hreadyPred, ?_, ?_, hpredCount, + ?_, ?_, hinv.resultCount_le, hframePred⟩ + Β· rw [hreplacementPred, hreplacementMiss] + exact hinv.replacement + Β· exact hreplacementPred.trans + (hreplacementMiss.trans hinv.replacement_eq) + Β· rw [hfoundPred, hfoundMiss] + exact hinv.foundCount + Β· rw [hresultCountPred, hresultCountMiss] + exact hinv.resultCountTape + have hnextOutput : predDone.output.HasBinaryPrefix + (outPrefix ++ (emitted ++ [entry]).flatMap Entry.encode) := by + rw [hpredOutput] + simpa [List.flatMap_append, List.append_assoc] using hmissOutput + refine ⟨predDone.work, predDone.output, + 1 + matchTime + 1 + missTime + 1 + + TM.binaryPredTime rest.length + 1, htime, ?_, hnextInv, hnextOutput⟩ + convert hreach using 1 + omega + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Out.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Out.lean new file mode 100644 index 0000000000..7efa05990b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Out.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryReplace +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMatch + +/-! +# Bounded encoded sparse-store update β€” output safety internals + +The update controller delegates every nested phase to an independently checked +one-way-output machine. Its own dispatch transitions either read back or leave +the output head idle, so the complete controller remains a transducer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- A canonical binary prefix parks its tape head away from the left endmarker +and contains no spurious left endmarkers. -/ +theorem parked_of_binaryPrefix_internal {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +/-- The fixed sparse-store update controller never moves its output head left. -/ +theorem entryUpdateTM_isTransducer_internal {n : β„•} + (tapes : EntryUpdateTapes n) : + (entryUpdateTM tapes).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | test => + simp only [entryUpdateTM] + split + Β· split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· split <;> cases oHead <;> + simp [TM.allReadBack, TM.idleDir] + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + | matching q => + simp only [entryUpdateTM] + split + Β· split + Β· cases oHead <;> simp [TM.idleDir] + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryMatchReadTM_isTransducer tapes.entry q iHead wHeads oHead + | miss q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryMissCopyTM_isTransducer tapes.entry q iHead wHeads oHead + | delete q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryMissCleanupTM_isTransducer tapes.entry q iHead wHeads oHead + | replace q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryReplaceCleanupTM_isTransducer tapes.replace q iHead wHeads oHead + | append q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact entryAppendRestoreTM_isTransducer tapes.replace q iHead wHeads oHead + | remaining q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact TM.binaryPredTM_isTransducer tapes.remaining q iHead wHeads oHead + | deleteCount q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact TM.binaryPredTM_isTransducer tapes.resultCount q iHead wHeads oHead + | appendCount q => + simp only [entryUpdateTM] + split + Β· cases oHead <;> simp [TM.allReadBack, TM.idleDir] + Β· exact TM.binarySuccTM_isTransducer tapes.resultCount q iHead wHeads oHead + | done => cases oHead <;> simp [entryUpdateTM, TM.allIdle, TM.idleDir] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Sem.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Sem.lean new file mode 100644 index 0000000000..6bd2fa464b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Sem.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Step +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.End + +/-! +# Bounded encoded sparse-store update -- semantic composition + +This file composes the checked one-entry and terminal contracts into the +complete update loop. The induction is over the runtime-counted remaining +store, while the loop invariant carries the processed prefix and emitted +output needed to connect the concrete controller to `RegisterStore.write`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Starting from any valid loop boundary, the update controller finishes the +remaining suffix within its recursive static budget. -/ +theorem entryUpdateLoop_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (processed remaining emitted : Store) (found : Bool) + (resultCount : β„•) (initialWork work : Fin n β†’ Tape) + (outPrefix : List Bool) (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed + remaining emitted found resultCount initialWork work) + (hnodup : AddressesNodup store) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ final time, + time ≀ entryUpdateLoopTime tapes address newValue store.length + remaining ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) final ∧ + (entryUpdateTM tapes).halted final ∧ + final.input = inp ∧ + EntryUpdateOutcome tapes store address newValue initialWork final.work ∧ + final.output.HasBinaryPrefix + (outPrefix ++ (RegisterStore.write store address newValue).flatMap + Entry.encode) := by + induction remaining generalizing processed emitted found resultCount work out with + | nil => + exact entryUpdateTerminal_internal tapes store address newValue + processed emitted found resultCount initialWork work outPrefix inp out + hinv hinput houtput + | cons entry rest ih => + obtain ⟨processed', emitted', found', resultCount', nextWork, + nextOut, iterationTime, hiterationTime, hiterationReach, + hnextInv, hnextOutput⟩ := + entryUpdateIteration_internal tapes store address newValue processed + emitted entry rest found resultCount initialWork work outPrefix inp + out hinv hnodup hinput houtput + obtain ⟨final, recursiveTime, hrecursiveTime, hrecursiveReach, + hhalt, hfinalInput, houtcome, hfinalOutput⟩ := + ih processed' emitted' found' resultCount' nextWork nextOut hnextInv + hnextOutput + refine ⟨final, iterationTime + recursiveTime, ?_, ?_, hhalt, + hfinalInput, houtcome, hfinalOutput⟩ + Β· simp only [entryUpdateLoopTime] + omega + Β· exact TM.reachesIn_trans (entryUpdateTM tapes) hiterationReach + hrecursiveReach + +/-- A complete encoded sparse-store update realizes `RegisterStore.write`, +preserves input and the external work frame exactly, and appends precisely the +new store encoding to the caller's existing output prefix. -/ +theorem entryUpdateTM_hoareTime_frame_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.entry (store.flatMap Entry.encode) + address.bits initialWork initialWork) + (hreplacement : + (initialWork tapes.replacement).HasBinaryNat newValue) + (hremaining : + (initialWork tapes.remaining).HasBinaryNat store.length) + (hfound : (initialWork tapes.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.resultCount).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (entryUpdateTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryUpdateOutcome tapes store address newValue initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address newValue).flatMap + Entry.encode)) + (entryUpdateTime tapes store address newValue) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hinv := entryUpdateLoopInv_initial_internal tapes store address + newValue initialWork hready hreplacement hremaining hfound hresultCount + have houtput' : outβ‚€.HasBinaryPrefix + (emittedBits ++ ([] : Store).flatMap Entry.encode) := by + simpa using houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, houtcome, + hfinalOutput⟩ := + entryUpdateLoop_internal tapes store address newValue [] store [] false + store.length initialWork initialWork emittedBits inpβ‚€ outβ‚€ hinv + hcanonical.1 hinput houtput' + refine ⟨final, time, ?_, ?_, hhalt, hfinalInput, houtcome, + hfinalOutput⟩ + Β· simpa [entryUpdateTime] using htime + Β· simpa [entryUpdateTestCfg, entryUpdateTM] using hreach + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Step.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Step.lean new file mode 100644 index 0000000000..769931812e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Step.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Hit +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Internal.Miss + +/-! +# Bounded encoded sparse-store update -- one positive iteration +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem found_eq_false_of_current_eq + {tapes : EntryUpdateTapes n} {store : Store} {address newValue : β„•} + {processed emitted : Store} {entry : Entry} {rest : Store} + {found : Bool} {resultCount : β„•} + {initialWork work : Fin n β†’ Tape} + (hinv : EntryUpdateLoopInv tapes store address newValue processed + (entry :: rest) emitted found resultCount initialWork work) + (hnodup : AddressesNodup store) (haddress : entry.1 = address) : + found = false := by + cases found with + | false => rfl + | true => + exfalso + have hnot := hinv.progress.not_mem_remaining_of_found_internal + hnodup rfl + apply hnot + simp [haddress] + +/-- One positive old-entry iteration advances the semantic and tape loop +invariant, returning to the controller's test state. -/ +theorem entryUpdateIteration_internal + (tapes : EntryUpdateTapes n) (store : Store) (address newValue : β„•) + (processed emitted : Store) (entry : Entry) (rest : Store) + (found : Bool) (resultCount : β„•) + (initialWork work : Fin n β†’ Tape) (outPrefix : List Bool) + (inp out : Tape) + (hinv : EntryUpdateLoopInv tapes store address newValue processed + (entry :: rest) emitted found resultCount initialWork work) + (hnodup : AddressesNodup store) + (hinput : TM.Parked inp) + (houtput : out.HasBinaryPrefix + (outPrefix ++ emitted.flatMap Entry.encode)) : + βˆƒ processed' emitted' found' resultCount' nextWork nextOut time, + time ≀ entryUpdateIterationTime tapes entry rest address newValue + store.length ∧ + (entryUpdateTM tapes).reachesIn time + (entryUpdateTestCfg tapes inp work out) + (entryUpdateTestCfg tapes inp nextWork nextOut) ∧ + EntryUpdateLoopInv tapes store address newValue processed' rest emitted' + found' resultCount' initialWork nextWork ∧ + nextOut.HasBinaryPrefix + (outPrefix ++ emitted'.flatMap Entry.encode) := by + by_cases haddress : entry.1 = address + Β· have hfoundFalse := + found_eq_false_of_current_eq hinv hnodup haddress + have hinvFalse : EntryUpdateLoopInv tapes store address newValue + processed (entry :: rest) emitted false resultCount initialWork work := by + simpa [hfoundFalse] using hinv + by_cases hvalue : newValue = 0 + Β· subst newValue + obtain ⟨nextWork, nextOut, time, htime, hreach, hnextInv, + hnextOutput⟩ := + entryUpdateDeleteIteration_internal tapes store address processed + emitted entry rest resultCount initialWork work outPrefix inp out + hinvFalse haddress.symm hinput houtput + exact ⟨processed ++ [entry], emitted, true, resultCount - 1, + nextWork, nextOut, time, htime, hreach, hnextInv, hnextOutput⟩ + Β· obtain ⟨nextWork, nextOut, time, htime, hreach, hnextInv, + hnextOutput⟩ := + entryUpdateReplaceIteration_internal tapes store address newValue + processed emitted entry rest resultCount initialWork work outPrefix + inp out hinvFalse haddress.symm hvalue hinput houtput + exact ⟨processed ++ [entry], emitted ++ [(address, newValue)], true, + resultCount, nextWork, nextOut, time, htime, hreach, hnextInv, + hnextOutput⟩ + Β· + obtain ⟨nextWork, nextOut, time, htime, hreach, hnextInv, + hnextOutput⟩ := + entryUpdateIteration_miss_internal tapes store address newValue + processed emitted entry rest found resultCount initialWork work + outPrefix inp out hinv haddress hinput houtput + exact ⟨processed ++ [entry], emitted ++ [entry], found, resultCount, + nextWork, nextOut, time, htime, hreach, hnextInv, hnextOutput⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Time.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Time.lean new file mode 100644 index 0000000000..5c84ebdeda --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Internal/Time.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.FinCases +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Bounded encoded sparse-store update β€” static runtime bounds + +The entry subroutines expose exact compositional times parameterized by the +current work family. This file discharges that dependency at the update-loop +boundary: a ready loop invariant fixes every owned starting head, while a +readable match bounds the one cursor whose endpoint is intentionally in-place. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- The preserved query is rewound at every update-loop boundary. -/ +theorem EntryScanReady.query_head_eq_one_internal + {tapes : EntryMatchTapes n} {remaining queryBits : List Bool} + {initialWork work : Fin n β†’ Tape} + (h : EntryScanReady tapes remaining queryBits initialWork work) : + (work tapes.query).head = 1 := + h.query.1 + +/-- Every scratch target cleared by an update branch starts at cell one at a +ready loop boundary. -/ +theorem EntryScanReady.cleanup_target_head_eq_one_internal + {tapes : EntryMatchTapes n} {remaining queryBits : List Bool} + {initialWork work : Fin n β†’ Tape} + (h : EntryScanReady tapes remaining queryBits initialWork work) : + βˆ€ i, i ∈ entryMissTargets tapes β†’ (work i).head = 1 := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· simpa using h.address.1 + Β· simpa using h.value.1 + Β· exact h.addressCounter.2.1 + Β· exact h.addressWidth.2.1 + Β· exact h.valueCounter.2.1 + Β· exact h.valueWidth.2.1 + Β· simpa using h.result.1 + +/-- On a ready loop boundary, the exact deletion-cleanup time is the static +controller bound. -/ +theorem entryMissCleanupTime_eq_entryUpdateReadyCleanupTime_internal + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) + {remaining : List Bool} {initialWork work : Fin n β†’ Tape} + (hready : EntryScanReady tapes.entry remaining address.bits + initialWork work) : + entryMissCleanupTime tapes.entry entry address.bits work = + entryUpdateReadyCleanupTime tapes entry address := by + let matchTime := entryMatchReadTime entry address.bits + have hquery : + entryMissHeadBound entry address.bits work tapes.entry.query = + 1 + matchTime := by + simp [entryMissHeadBound, matchTime, hready.query_head_eq_one_internal] + have htargets : βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + entryMissHeadBound entry address.bits work i = 1 + matchTime := by + intro i hi + simp [entryMissHeadBound, matchTime, + hready.cleanup_target_head_eq_one_internal i hi] + have hreset := TM.resetBinaryWorkManyTime_congr_headBound + (entryMissTargets tapes.entry) + (entryMissBits tapes.entry entry address.bits) + (entryMissHeadBound entry address.bits work) + (fun _ => 1 + matchTime) htargets + unfold entryMissCleanupTime entryUpdateReadyCleanupTime + rw [hquery, hreset] + +private theorem readable_other_cleanup_target_head + (tapes : EntryUpdateTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits initialWork + matchedWork) (i : Fin n) (hi : i ∈ entryMissTargets tapes.entry) + (haddress : i β‰  tapes.entry.address) + (hvalue : i β‰  tapes.entry.value) : + (matchedWork i).head = entryUpdatePostEmitHead tapes entry i := by + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· simp at haddress + Β· simp at hvalue + Β· simpa [entryUpdatePostEmitHead, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.result, + tapes.entry.injective.eq_iff] using + hmatch.addressCounter.1 + Β· simpa [entryUpdatePostEmitHead, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.result, + tapes.entry.injective.eq_iff] using + hmatch.addressWidth.2.1 + Β· simpa [entryUpdatePostEmitHead, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.result, + tapes.entry.injective.eq_iff] using + hmatch.valueCounter.1 + Β· simpa [entryUpdatePostEmitHead, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.result, + tapes.entry.injective.eq_iff] using + hmatch.valueWidth.2.1 + Β· simpa [entryUpdatePostEmitHead, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.result, + tapes.entry.injective.eq_iff] using + hmatch.result.1 + +private theorem entryMissCopiedWork_target_head + (tapes : EntryUpdateTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits initialWork + matchedWork) : + βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + (entryMissCopiedWork tapes.entry entry matchedWork i).head = + entryUpdatePostEmitHead tapes entry i := by + intro i hi + by_cases haddress : i = tapes.entry.address + Β· subst i + simp [entryMissCopiedWork, entryUpdatePostEmitHead] + Β· by_cases hvalue : i = tapes.entry.value + Β· subst i + simp [entryMissCopiedWork, entryUpdatePostEmitHead, haddress] + Β· simp only [entryMissCopiedWork, haddress, hvalue, ite_false] + exact readable_other_cleanup_target_head tapes entry rest queryBits + initialWork matchedWork hmatch i hi haddress hvalue + +private theorem entryReplaceReadyWork_target_head + (tapes : EntryUpdateTapes n) (entry : Entry) (rest queryBits : List Bool) + (initialWork matchedWork : Fin n β†’ Tape) + (hmatch : ReadableEntryMatch tapes.entry entry rest queryBits initialWork + matchedWork) : + βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + (entryReplaceReadyWork tapes.replace entry matchedWork i).head = + entryUpdatePostEmitHead tapes entry i := by + intro i hi + by_cases haddress : i = tapes.entry.address + Β· subst i + simp [entryReplaceReadyWork, entryUpdatePostEmitHead] + Β· by_cases hvalue : i = tapes.entry.value + Β· subst i + simpa [entryReplaceReadyWork, entryUpdatePostEmitHead, haddress] using + hmatch.value.1 + Β· have haddress' : i β‰  tapes.replace.entry.address := by + simpa using haddress + rw [entryReplaceReadyWork, ite_eq_right haddress'] + exact readable_other_cleanup_target_head tapes entry rest queryBits + initialWork matchedWork hmatch i hi haddress hvalue + +private theorem entryMissCleanupTime_postEmit_le + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) + (rest : List Bool) + (initialWork readyWork matchedWork postEmitWork : Fin n β†’ Tape) + (hready : EntryScanReady tapes.entry (Entry.encode entry ++ rest) + address.bits initialWork readyWork) + (hmatch : ReadableEntryMatch tapes.entry entry rest address.bits readyWork + matchedWork) + (hqueryEq : postEmitWork tapes.entry.query = + matchedWork tapes.entry.query) + (htargets : βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + (postEmitWork i).head = entryUpdatePostEmitHead tapes entry i) : + entryMissCleanupTime tapes.entry entry address.bits postEmitWork ≀ + entryUpdatePostEmitCleanupTime tapes entry address := by + let matchTime := entryMatchReadTime entry address.bits + have hqueryMatched : (matchedWork tapes.entry.query).head ≀ + 1 + matchTime := by + simpa [matchTime, hready.query_head_eq_one_internal] using + hmatch.headBound tapes.entry.query + have hqueryPost : (postEmitWork tapes.entry.query).head ≀ + 1 + matchTime := by + rw [hqueryEq] + exact hqueryMatched + have hquery : + entryMissHeadBound entry address.bits postEmitWork tapes.entry.query ≀ + 1 + 2 * matchTime := by + simp only [entryMissHeadBound] + omega + have htargets' : βˆ€ i, i ∈ entryMissTargets tapes.entry β†’ + entryMissHeadBound entry address.bits postEmitWork i = + entryUpdatePostEmitHead tapes entry i + matchTime := by + intro i hi + simp [entryMissHeadBound, matchTime, htargets i hi] + have hreset := TM.resetBinaryWorkManyTime_congr_headBound + (entryMissTargets tapes.entry) + (entryMissBits tapes.entry entry address.bits) + (entryMissHeadBound entry address.bits postEmitWork) + (fun i => entryUpdatePostEmitHead tapes entry i + matchTime) htargets' + simp only [matchTime] at hreset + dsimp only [entryMissCleanupTime, entryUpdatePostEmitCleanupTime] + rw [hreset] + omega + +/-- A ready comparison followed by miss emission has a work-independent +runtime bounded by the controller's static miss budget. -/ +theorem entryMissCopyTime_le_entryUpdateMissTime_internal + (tapes : EntryUpdateTapes n) (entry : Entry) (address : β„•) + (rest : List Bool) (initialWork readyWork matchedWork : Fin n β†’ Tape) + (hready : EntryScanReady tapes.entry (Entry.encode entry ++ rest) + address.bits initialWork readyWork) + (hmatch : ReadableEntryMatch tapes.entry entry rest address.bits readyWork + matchedWork) : + entryMissCopyTime tapes.entry entry address.bits readyWork matchedWork ≀ + entryUpdateMissTime tapes entry address := by + let matchTime := entryMatchReadTime entry address.bits + have haddress : + entryMissHeadBound entry address.bits readyWork tapes.entry.address = + 1 + matchTime := by + simp [entryMissHeadBound, matchTime, hready.address.1] + have hvalue : + entryMissHeadBound entry address.bits readyWork tapes.entry.value = + 1 + matchTime := by + simp [entryMissHeadBound, matchTime, hready.value.1] + have hqueryNeAddress : tapes.entry.query β‰  tapes.entry.address := + tapes.entry.ne (by decide) + have hqueryNeValue : tapes.entry.query β‰  tapes.entry.value := + tapes.entry.ne (by decide) + have hquery : + entryMissCopiedWork tapes.entry entry matchedWork tapes.entry.query = + matchedWork tapes.entry.query := by + simp [entryMissCopiedWork, hqueryNeAddress, hqueryNeValue] + have hcleanup := entryMissCleanupTime_postEmit_le tapes entry address rest + initialWork readyWork matchedWork + (entryMissCopiedWork tapes.entry entry matchedWork) hready hmatch hquery + (entryMissCopiedWork_target_head tapes entry rest address.bits readyWork + matchedWork hmatch) + dsimp only [entryMissCopyTime, entryUpdateMissTime] + rw [haddress, hvalue] + exact Nat.add_le_add_left hcleanup _ + +/-- A ready comparison followed by replacement emission has a work-independent +runtime bounded by the controller's static replacement budget. -/ +theorem entryReplaceCleanupTime_le_entryUpdateReplaceTime_internal + (tapes : EntryUpdateTapes n) (entry : Entry) (address newValue : β„•) + (rest : List Bool) (initialWork readyWork matchedWork : Fin n β†’ Tape) + (hready : EntryScanReady tapes.entry (Entry.encode entry ++ rest) + address.bits initialWork readyWork) + (hmatch : ReadableEntryMatch tapes.entry entry rest address.bits readyWork + matchedWork) : + entryReplaceCleanupTime tapes.replace entry newValue address.bits readyWork + matchedWork ≀ + entryUpdateReplaceTime tapes entry address newValue := by + let matchTime := entryMatchReadTime entry address.bits + have haddress : + entryMissHeadBound entry address.bits readyWork tapes.entry.address = + 1 + matchTime := by + simp [entryMissHeadBound, matchTime, hready.address.1] + have hqueryNeAddress : tapes.entry.query β‰  tapes.entry.address := + tapes.entry.ne (by decide) + have hquery : + entryReplaceReadyWork tapes.replace entry matchedWork tapes.entry.query = + matchedWork tapes.entry.query := by + simp [entryReplaceReadyWork, hqueryNeAddress] + have hcleanup := entryMissCleanupTime_postEmit_le tapes entry address rest + initialWork readyWork matchedWork + (entryReplaceReadyWork tapes.replace entry matchedWork) hready hmatch hquery + (entryReplaceReadyWork_target_head tapes entry rest address.bits readyWork + matchedWork hmatch) + have haddress' : + entryMissHeadBound entry address.bits readyWork + tapes.replace.entry.address = + 1 + matchTime := by + simpa only [EntryUpdateTapes.replace_entry] using haddress + have hcleanup' : + entryMissCleanupTime tapes.replace.entry entry address.bits + (entryReplaceReadyWork tapes.replace entry matchedWork) ≀ + entryUpdatePostEmitCleanupTime tapes entry address := by + simpa only [EntryUpdateTapes.replace_entry] using hcleanup + dsimp only [entryReplaceCleanupTime, entryUpdateReplaceTime] + rw [haddress'] + simp only [matchTime] + exact Nat.add_le_add_left + (Nat.add_le_add_left hcleanup' (newValue.bits.length + 1 + 2 + 1)) + (rewindEntryEncodeTime (entry.1, newValue) + (1 + entryMatchReadTime entry address.bits) 1 + 1) + +/-- A positive counter no larger than the initial store size can be +decremented within the update controller's uniform counter budget. -/ +theorem binaryPredTime_le_entryUpdateCountTime_internal + {value total : β„•} (hvalue : value + 1 ≀ total) : + TM.binaryPredTime value ≀ entryUpdateCountTime total := by + have htime := TM.binaryPredTime_le value + have hsize := Nat.size_le_size hvalue + unfold entryUpdateCountTime + omega + +/-- A counter no larger than the initial store size can be incremented within +the update controller's uniform counter budget. -/ +theorem binarySuccTime_le_entryUpdateCountTime_internal + {value total : β„•} (hvalue : value ≀ total) : + TM.binarySuccTime value ≀ entryUpdateCountTime total := by + have htime := TM.binarySuccTime_le value + have hsize := Nat.size_le_size hvalue + unfold entryUpdateCountTime + omega + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Progress.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Progress.lean new file mode 100644 index 0000000000..7acd1fb61e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Progress.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs + +/-! +# Bounded encoded sparse-store update β€” progress invariant internals + +This file isolates the pure list semantics of the entry-update loop. The +invariant relates the processed and remaining portions of the old store to the +entries already emitted by the machine, independently of the tape-level +simulation proof. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Pure semantic progress of a left-to-right sparse-store update. + +The output equation is deliberately phrased as a completion equation. Before +the target address is found, completing the emitted prefix requires updating +the remaining suffix. Afterwards, the untouched remaining suffix is copied +verbatim. -/ +structure EntryUpdateProgress + (store : Store) (address newValue : β„•) + (processed remaining emitted : Store) + (found : Bool) (resultCount : β„•) : Prop where + /-- The scan decomposition still covers the original store. -/ + store_eq : store = processed ++ remaining + /-- The flag records exactly whether the processed prefix contains the + requested address. -/ + found_iff : found = true ↔ address ∈ processed.map Prod.fst + /-- Completing the emitted prefix produces the abstract sparse-store write. -/ + output_eq : + emitted ++ (if found = true then remaining + else RegisterStore.write remaining address newValue) = + RegisterStore.write store address newValue + /-- Until the optional final append, the runtime result count equals emitted + entries plus old entries still remaining. -/ + resultCount_eq : resultCount = emitted.length + remaining.length + +/-- Before scanning any entries, the empty emitted prefix satisfies the +progress invariant. -/ +theorem entryUpdateProgress_initial_internal + (store : Store) (address newValue : β„•) : + EntryUpdateProgress store address newValue [] store [] false store.length := by + constructor <;> simp + +/-- Copying a nonmatching entry advances all three list frontiers without +changing either the found flag or the result count. -/ +theorem EntryUpdateProgress.miss_internal + {store : Store} {address newValue : β„•} + {processed remaining emitted : Store} {entry : Entry} + {found : Bool} {resultCount : β„•} + (h : EntryUpdateProgress store address newValue processed + (entry :: remaining) emitted found resultCount) + (hne : entry.1 β‰  address) : + EntryUpdateProgress store address newValue (processed ++ [entry]) + remaining (emitted ++ [entry]) found resultCount := by + constructor + Β· simpa [List.append_assoc] using h.store_eq + Β· simpa [List.map_append, hne, Ne.symm hne] using h.found_iff + Β· by_cases hfound : found = true + Β· simpa [hfound, List.append_assoc] using h.output_eq + Β· simpa [hfound, RegisterStore.write, Ne.symm hne, + List.append_assoc] using h.output_eq + Β· have hcount := h.resultCount_eq + simp only [List.length_cons] at hcount + simp only [List.length_append, List.length_singleton] + omega + +/-- Replacing the first matching entry emits the new nonzero pair and records +that the target address has been found. -/ +theorem EntryUpdateProgress.replace_internal + {store : Store} {address newValue : β„•} + {processed remaining emitted : Store} {entry : Entry} + {resultCount : β„•} + (h : EntryUpdateProgress store address newValue processed + (entry :: remaining) emitted false resultCount) + (haddress : address = entry.1) (hvalue : newValue β‰  0) : + EntryUpdateProgress store address newValue (processed ++ [entry]) + remaining (emitted ++ [(address, newValue)]) true resultCount := by + constructor + Β· simpa [List.append_assoc] using h.store_eq + Β· simp [List.map_append, haddress] + Β· simpa [RegisterStore.write, haddress, hvalue, List.append_assoc] + using h.output_eq + Β· have hcount := h.resultCount_eq + simp only [List.length_cons] at hcount + simp only [List.length_append, List.length_singleton] + omega + +/-- Deleting the first matching entry emits nothing for it, records the hit, +and decrements the result count. -/ +theorem EntryUpdateProgress.delete_internal + {store : Store} {address : β„•} + {processed remaining emitted : Store} {entry : Entry} + {resultCount : β„•} + (h : EntryUpdateProgress store address 0 processed + (entry :: remaining) emitted false resultCount) + (haddress : address = entry.1) : + EntryUpdateProgress store address 0 (processed ++ [entry]) remaining + emitted true (resultCount - 1) := by + constructor + Β· simpa [List.append_assoc] using h.store_eq + Β· simp [List.map_append, haddress] + Β· simpa [RegisterStore.write, haddress] using h.output_eq + Β· have hcount := h.resultCount_eq + simp only [List.length_cons] at hcount + omega + +/-- Once the scan is exhausted after a hit, the emitted store and result count +are already the abstract write result. -/ +theorem EntryUpdateProgress.terminal_found_internal + {store : Store} {address newValue : β„•} + {processed emitted : Store} {resultCount : β„•} + (h : EntryUpdateProgress store address newValue processed [] emitted true + resultCount) : + emitted = RegisterStore.write store address newValue ∧ + resultCount = (RegisterStore.write store address newValue).length := by + have houtput : emitted = RegisterStore.write store address newValue := by + simpa using h.output_eq + exact ⟨houtput, by simpa [houtput] using h.resultCount_eq⟩ + +/-- An absent address written with zero requires no append; exhaustion already +produces the abstract empty write contribution. -/ +theorem EntryUpdateProgress.terminal_zero_internal + {store : Store} {address : β„•} + {processed emitted : Store} {resultCount : β„•} + (h : EntryUpdateProgress store address 0 processed [] emitted false + resultCount) : + emitted = RegisterStore.write store address 0 ∧ + resultCount = (RegisterStore.write store address 0).length := by + have houtput : emitted = RegisterStore.write store address 0 := by + simpa [RegisterStore.write] using h.output_eq + exact ⟨houtput, by simpa [houtput] using h.resultCount_eq⟩ + +/-- An absent address written with a nonzero value is completed by one final +append and one result-count increment. -/ +theorem EntryUpdateProgress.terminal_append_internal + {store : Store} {address newValue : β„•} + {processed emitted : Store} {resultCount : β„•} + (h : EntryUpdateProgress store address newValue processed [] emitted false + resultCount) + (hvalue : newValue β‰  0) : + emitted ++ [(address, newValue)] = + RegisterStore.write store address newValue ∧ + resultCount + 1 = + (RegisterStore.write store address newValue).length := by + have houtput : emitted ++ [(address, newValue)] = + RegisterStore.write store address newValue := by + simpa [RegisterStore.write, hvalue] using h.output_eq + constructor + Β· exact houtput + Β· rw [← houtput] + have hcount := h.resultCount_eq + simp only [List.length_nil, Nat.add_zero] at hcount + simp only [List.length_append, List.length_singleton] + omega + +/-- In a store with unique addresses, finding the target in the processed +prefix excludes it from the unprocessed suffix. -/ +theorem EntryUpdateProgress.not_mem_remaining_of_found_internal + {store : Store} {address newValue : β„•} + {processed remaining emitted : Store} {found : Bool} + {resultCount : β„•} + (h : EntryUpdateProgress store address newValue processed remaining + emitted found resultCount) + (hnodup : AddressesNodup store) (hfound : found = true) : + address βˆ‰ remaining.map Prod.fst := by + rw [h.store_eq] at hnodup + simp only [AddressesNodup, List.map_append] at hnodup + exact fun hremaining => + (List.nodup_append.mp hnodup).2.2 address + (h.found_iff.mp hfound) address hremaining rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Source.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Source.lean new file mode 100644 index 0000000000..44bb554137 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Source.lean @@ -0,0 +1,519 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryScan.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.WorkReadOnly +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Sparse-store update source preservation + +The update controller advances its encoded source cursor but never changes the +source cells. This file packages that local transition fact as a reusable +read-only certificate. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem binarySuccTM_readOnly_of_ne (target other : Fin n) + (hne : other β‰  target) : + (TM.binarySuccTM target).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | carry => + cases hread : workHeads target <;> + simp [TM.binarySuccTM, hread, hne] + | rewind => + by_cases hread : workHeads target = Ξ“.start <;> + simp [TM.binarySuccTM, hread] + | done => exact (hstate rfl).elim + +private theorem binaryPredTM_readOnly_of_ne (target other : Fin n) + (hne : other β‰  target) : + (TM.binaryPredTM target).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | borrow | check => + cases hread : workHeads target <;> + simp [TM.binaryPredTM, hread, hne] + | erase | rewind => + by_cases hread : workHeads target = Ξ“.start <;> + simp [TM.binaryPredTM, hread, hne] + | done => exact (hstate rfl).elim + +private theorem rewindWorkTM_readOnly (target other : Fin n) : + (TM.rewindWorkTM target).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | moveLeft => + by_cases hread : workHeads target = Ξ“.start <;> + simp [TM.rewindWorkTM, hread] + | moveRight => rfl + | done => exact (hstate rfl).elim + +private theorem blankWorkTM_readOnly_of_ne (target other : Fin n) + (hne : other β‰  target) : + (TM.blankWorkTM target).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | scanning => + by_cases hread : workHeads target = Ξ“.blank <;> + simp [TM.blankWorkTM, hread, hne] + | done => exact (hstate rfl).elim + +private theorem clearWorkTM_readOnly_of_ne (target other : Fin n) + (hne : other β‰  target) : + (TM.clearWorkTM target).WorkReadOnly other := by + exact (blankWorkTM_readOnly_of_ne target other hne).seqTM + (rewindWorkTM_readOnly target other) + +private theorem resetBinaryWorkTM_readOnly_of_ne (target other : Fin n) + (hne : other β‰  target) : + (TM.resetBinaryWorkTM target).WorkReadOnly other := by + unfold TM.resetBinaryWorkTM + exact (rewindWorkTM_readOnly target other).seqTM + (clearWorkTM_readOnly_of_ne target other hne) + +private theorem skipTM_readOnly (other : Fin n) : + (TM.skipTM (n := n)).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + rfl + +private theorem resetBinaryWorkManyTM_readOnly_of_not_mem + (targets : List (Fin n)) (other : Fin n) (hnotmem : other βˆ‰ targets) : + (TM.resetBinaryWorkManyTM targets).WorkReadOnly other := by + induction targets with + | nil => exact skipTM_readOnly other + | cons target targets ih => + simp only [List.mem_cons, not_or] at hnotmem + exact (resetBinaryWorkTM_readOnly_of_ne target other hnotmem.1).seqTM + (ih hnotmem.2) + +private theorem forWorkOnesTM_readOnly (driver other : Fin n) (body : TM n) + (hbody : body.WorkReadOnly other) : + (TM.forWorkOnesTM driver body).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | inl phase => + cases phase with + | scan => + by_cases hstart : workHeads driver = Ξ“.start + Β· simp [TM.forWorkOnesTM, hstart] + Β· by_cases hone : workHeads driver = Ξ“.one + Β· simp [TM.forWorkOnesTM, hone] + Β· simp only [TM.forWorkOnesTM, hstart, hone, ↓reduceIte] + rfl + | done => exact (hstate rfl).elim + | inr state => + by_cases hhalt : state = body.qhalt + Β· simp only [TM.forWorkOnesTM, hhalt, ↓reduceIte] + rfl + Β· simpa [TM.forWorkOnesTM, hhalt] using + hbody state inputHead workHeads outputHead hhalt + +private theorem binaryForTM_readOnly (body : TM n) + (counter limit other : Fin n) (hbody : body.WorkReadOnly other) + (hne : other β‰  counter) : + (TM.binaryForTM body counter limit).WorkReadOnly other := by + have hiteration : + (TM.binaryForIterationTM body counter).WorkReadOnly other := by + exact hbody.seqTM (binarySuccTM_readOnly_of_ne counter other hne) + intro state inputHead workHeads outputHead hstate + cases state with + | inl phase => + cases phase with + | scan equalSoFar => + by_cases hblank : + workHeads counter = Ξ“.blank ∧ workHeads limit = Ξ“.blank <;> + simp [TM.binaryForTM, hblank] + | rewind equalSoFar => + by_cases hstart : + workHeads counter = Ξ“.start ∧ workHeads limit = Ξ“.start <;> + simp [TM.binaryForTM, hstart] + | done => exact (hstate rfl).elim + | inr state => + by_cases hhalt : state = (TM.binaryForIterationTM body counter).qhalt + Β· simp only [TM.binaryForTM, hhalt, ↓reduceIte] + rfl + Β· simpa [TM.binaryForTM, hhalt] using + hiteration state inputHead workHeads outputHead hhalt + +private theorem workEmitTM_readOnly (target other : Fin n) + (mode : WorkEmitMode) : + (workEmitTM target mode).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | scan => + cases hread : workHeads target with + | zero | one => simp [workEmitTM, hread] + | start => + simp only [workEmitTM, hread] + rfl + | blank => + by_cases hmode : mode = .width + Β· simp [workEmitTM, hread, hmode] + Β· simp only [workEmitTM, hread, hmode, ↓reduceIte] + rfl + | done => exact (hstate rfl).elim + +private theorem wordEncodeTM_readOnly (target other : Fin n) : + (wordEncodeTM target).WorkReadOnly other := by + unfold wordEncodeTM + exact (workEmitTM_readOnly target other .width).seqTM + ((rewindWorkTM_readOnly target other).seqTM + (workEmitTM_readOnly target other .payload)) + +private theorem rewindWordEncodeTM_readOnly (target other : Fin n) : + (rewindWordEncodeTM target).WorkReadOnly other := by + unfold rewindWordEncodeTM + exact (rewindWorkTM_readOnly target other).seqTM + (wordEncodeTM_readOnly target other) + +private theorem rewindEntryEncodeTM_readOnly + (tapes : EntryEncodeTapes n) (other : Fin n) : + (rewindEntryEncodeTM tapes).WorkReadOnly other := by + unfold rewindEntryEncodeTM + exact (rewindWordEncodeTM_readOnly tapes.address other).seqTM + (rewindWordEncodeTM_readOnly tapes.value other) + +private theorem payloadBitTM_source_readOnly (source target : Fin n) + (hne : source β‰  target) : + (payloadBitTM source target).WorkReadOnly source := by + intro state inputHead workHeads outputHead hstate + cases state with + | copy => + cases hread : workHeads source with + | zero | one => simp [payloadBitTM, hread, hne] + | blank => + simp [payloadBitTM, hread, TM.allReadBack] + | start => simp [payloadBitTM, hread, TM.allIdle, TM.readBackWrite] + | done => exact (hstate rfl).elim + +private theorem wordSeparatorTM_source_readOnly (source : Fin n) : + (wordSeparatorTM source).WorkReadOnly source := by + intro state inputHead workHeads outputHead hstate + cases state with + | skip => + by_cases hzero : workHeads source = Ξ“.zero + Β· simp [wordSeparatorTM, hzero] + Β· by_cases hstart : workHeads source = Ξ“.start + Β· simp [wordSeparatorTM, hstart, TM.allIdle, TM.readBackWrite] + Β· simp only [wordSeparatorTM, hzero, hstart, ↓reduceIte] + simp [TM.allReadBack] + | done => exact (hstate rfl).elim + +private theorem binaryEqTM_readOnly_of_ne_result + (lhs rhs result other : Fin n) (hne : other β‰  result) : + (TM.binaryEqTM lhs rhs result).WorkReadOnly other := by + intro state inputHead workHeads outputHead hstate + cases state with + | scan => + by_cases hblank : + workHeads lhs = Ξ“.blank ∧ workHeads rhs = Ξ“.blank + Β· simp [TM.binaryEqTM, hblank, hne] + Β· by_cases heq : workHeads lhs = workHeads rhs + Β· have hrhs : workHeads rhs β‰  Ξ“.blank := by + intro hrhs + apply hblank + exact ⟨heq.trans hrhs, hrhs⟩ + simp [TM.binaryEqTM, heq, hrhs] + Β· simp [TM.binaryEqTM, hblank, heq, hne] + | done => exact (hstate rfl).elim + +private theorem wordDecodeTM_source_readOnly + (source target counter width : Fin n) + (hsourceTarget : source β‰  target) + (hsourceCounter : source β‰  counter) + (hsourceWidth : source β‰  width) : + (wordDecodeTM source target counter width).WorkReadOnly source := by + have hwidth : (wordWidthTM source width).WorkReadOnly source := by + unfold wordWidthTM + exact forWorkOnesTM_readOnly source source (TM.binarySuccTM width) + (binarySuccTM_readOnly_of_ne width source hsourceWidth) + have hpayload : + (wordPayloadTM source target counter width).WorkReadOnly source := by + unfold wordPayloadTM + exact binaryForTM_readOnly (payloadBitTM source target) counter width source + (payloadBitTM_source_readOnly source target hsourceTarget) hsourceCounter + unfold wordDecodeTM + exact hwidth.seqTM + ((wordSeparatorTM_source_readOnly source).seqTM hpayload) + +private theorem entryDecodeTM_source_readOnly (tapes : EntryDecodeTapes n) : + (entryDecodeTM tapes).WorkReadOnly tapes.source := by + unfold entryDecodeTM + exact + (wordDecodeTM_source_readOnly tapes.source tapes.address + tapes.addressCounter tapes.addressWidth + (tapes.ne (by decide)) (tapes.ne (by decide)) + (tapes.ne (by decide))).seqTM + (wordDecodeTM_source_readOnly tapes.source tapes.value + tapes.valueCounter tapes.valueWidth + (tapes.ne (by decide)) (tapes.ne (by decide)) + (tapes.ne (by decide))) + +private theorem wordDecodeLinearTM_source_readOnly + (source target marker : Fin n) (hsourceTarget : source β‰  target) + (hsourceMarker : source β‰  marker) : + (wordDecodeLinearTM source target marker).WorkReadOnly source := by + intro phase inputHead workHeads outputHead hphase + cases phase with + | mark => + cases hsource : workHeads source <;> + simp [wordDecodeLinearTM, hsource, hsourceMarker, TM.allReadBack, + TM.allIdle, TM.readBackWrite] + | rewind => + by_cases hmarker : workHeads marker = Ξ“.start <;> + simp [wordDecodeLinearTM, hmarker] + | copy => + cases hmarker : workHeads marker with + | one => + cases hsource : workHeads source <;> + simp [wordDecodeLinearTM, hmarker, hsource, hsourceTarget, + TM.allReadBack] + | zero | blank => + simp [wordDecodeLinearTM, hmarker, TM.allReadBack] + | start => + simp [wordDecodeLinearTM, hmarker] + | done => exact (hphase rfl).elim + +private theorem entryDecodeLinearTM_source_readOnly + (tapes : EntryDecodeTapes n) : + (entryDecodeLinearTM tapes).WorkReadOnly tapes.source := by + unfold entryDecodeLinearTM + exact + (wordDecodeLinearTM_source_readOnly tapes.source tapes.address + tapes.addressCounter (tapes.ne (by decide)) + (tapes.ne (by decide))).seqTM + (wordDecodeLinearTM_source_readOnly tapes.source tapes.value + tapes.valueCounter (tapes.ne (by decide)) (tapes.ne (by decide))) + +private theorem decodedAddressEqTM_readOnly_of_ne_result + (address query result other : Fin n) (hne : other β‰  result) : + (decodedAddressEqTM address query result).WorkReadOnly other := by + unfold decodedAddressEqTM + exact (rewindWorkTM_readOnly address other).seqTM + (binaryEqTM_readOnly_of_ne_result address query result other hne) + +private theorem entryMatchReadTM_source_readOnly (tapes : EntryMatchTapes n) : + (entryMatchReadTM tapes).WorkReadOnly tapes.source := by + have hdecode : + (entryDecodeLinearTM tapes.decode).WorkReadOnly tapes.source := + entryDecodeLinearTM_source_readOnly tapes.decode + have heq : + (decodedAddressEqTM tapes.address tapes.query tapes.result).WorkReadOnly + tapes.source := + decodedAddressEqTM_readOnly_of_ne_result tapes.address tapes.query + tapes.result tapes.source (tapes.ne (by decide)) + unfold entryMatchReadTM entryMatchTM + exact (hdecode.seqTM heq).seqTM + (rewindWorkTM_readOnly tapes.result tapes.source) + +private theorem source_not_mem_entryMissTargets (tapes : EntryMatchTapes n) : + tapes.source βˆ‰ entryMissTargets tapes := by + intro hmem + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hmem + have hidx := tapes.injective hslot + have hval := congrArg Fin.val hidx + change (if slot.val = 6 then 8 else slot.val + 1) = 0 at hval + split at hval <;> omega + +private theorem entryMissCleanupTM_source_readOnly + (tapes : EntryMatchTapes n) : + (entryMissCleanupTM tapes).WorkReadOnly tapes.source := by + unfold entryMissCleanupTM + exact (rewindWorkTM_readOnly tapes.query tapes.source).seqTM + (resetBinaryWorkManyTM_readOnly_of_not_mem + (entryMissTargets tapes) tapes.source + (source_not_mem_entryMissTargets tapes)) + +private theorem entryMissCopyTM_source_readOnly (tapes : EntryMatchTapes n) : + (entryMissCopyTM tapes).WorkReadOnly tapes.source := by + unfold entryMissCopyTM + exact (rewindEntryEncodeTM_readOnly tapes.encodeTapes tapes.source).seqTM + (entryMissCleanupTM_source_readOnly tapes) + +private theorem entryReplaceCleanupTM_source_readOnly + (tapes : EntryReplaceTapes n) : + (entryReplaceCleanupTM tapes).WorkReadOnly tapes.entry.source := by + unfold entryReplaceCleanupTM + exact + (rewindEntryEncodeTM_readOnly tapes.encodeTapes tapes.entry.source).seqTM + ((rewindWorkTM_readOnly tapes.replacement tapes.entry.source).seqTM + (entryMissCleanupTM_source_readOnly tapes.entry)) + +private theorem entryAppendRestoreTM_source_readOnly + (tapes : EntryReplaceTapes n) : + (entryAppendRestoreTM tapes).WorkReadOnly tapes.entry.source := by + unfold entryAppendRestoreTM + exact + (rewindEntryEncodeTM_readOnly tapes.appendEncodeTapes + tapes.entry.source).seqTM + ((rewindWorkTM_readOnly tapes.entry.query tapes.entry.source).seqTM + (rewindWorkTM_readOnly tapes.replacement tapes.entry.source)) + +private theorem branchWorkSymbolTM_readOnly + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (other : Fin n) (hequal : onEqual.WorkReadOnly other) + (hdifferent : onDifferent.WorkReadOnly other) : + (TM.branchWorkSymbolTM idx symbol onEqual onDifferent).WorkReadOnly + other := by + intro state inputHead workHeads outputHead hstate + cases state with + | inl phase => + cases phase with + | dispatch => + by_cases hread : workHeads idx = symbol <;> + simp [TM.branchWorkSymbolTM, hread, TM.allReadBack] + | done => exact (hstate rfl).elim + | inr branch => + cases branch with + | inl state => + by_cases hhalt : state = onEqual.qhalt + Β· simp [TM.branchWorkSymbolTM, hhalt, TM.allReadBack] + Β· simpa [TM.branchWorkSymbolTM, hhalt] using + hequal state inputHead workHeads outputHead hhalt + | inr state => + by_cases hhalt : state = onDifferent.qhalt + Β· simp [TM.branchWorkSymbolTM, hhalt, TM.allReadBack] + Β· simpa [TM.branchWorkSymbolTM, hhalt] using + hdifferent state inputHead workHeads outputHead hhalt + +private theorem entryScanStepTM_source_readOnly (tapes : EntryMatchTapes n) : + (entryScanStepTM tapes).WorkReadOnly tapes.source := by + have hbranch : + (entryScanBranchTM tapes).WorkReadOnly tapes.source := by + unfold entryScanBranchTM + exact branchWorkSymbolTM_readOnly tapes.result Ξ“.one TM.skipTM + (entryMissCleanupTM tapes) tapes.source + (skipTM_readOnly tapes.source) + (entryMissCleanupTM_source_readOnly tapes) + unfold entryScanStepTM + exact (entryMatchReadTM_source_readOnly tapes).seqTM hbranch + +/-- The bounded lookup scanner advances but never changes its encoded source +cells. -/ +theorem entryScanTM_source_readOnly_internal (tapes : EntryScanTapes n) : + (entryScanTM tapes).WorkReadOnly tapes.entry.source := by + have hstep := entryScanStepTM_source_readOnly tapes.entry + have hcount := binaryPredTM_readOnly_of_ne tapes.count tapes.entry.source + tapes.count_ne_source.symm + intro state inputHead workHeads outputHead hstate + cases state with + | inl phase => + cases phase with + | test => + by_cases hblank : workHeads tapes.count = Ξ“.blank <;> + simp [entryScanTM, hblank, TM.allReadBack] + | done => exact (hstate rfl).elim + | inr nested => + cases nested with + | inl state => + by_cases hhalt : state = (entryScanStepTM tapes.entry).qhalt + Β· by_cases hresult : workHeads tapes.entry.result = Ξ“.one <;> + simp [entryScanTM, hhalt, hresult, TM.allReadBack] + Β· simpa [entryScanTM, hhalt] using + hstep state inputHead workHeads outputHead hhalt + | inr state => + by_cases hhalt : state = (TM.binaryPredTM tapes.count).qhalt + Β· simp [entryScanTM, hhalt, TM.allReadBack] + Β· simpa [entryScanTM, hhalt] using + hcount state inputHead workHeads outputHead hhalt + +theorem entryUpdateTM_source_readOnly_internal + (tapes : EntryUpdateTapes n) : + (entryUpdateTM tapes).WorkReadOnly tapes.entry.source := by + have hmatching := entryMatchReadTM_source_readOnly tapes.entry + have hmiss := entryMissCopyTM_source_readOnly tapes.entry + have hdelete := entryMissCleanupTM_source_readOnly tapes.entry + have hreplace := entryReplaceCleanupTM_source_readOnly tapes.replace + have happend := entryAppendRestoreTM_source_readOnly tapes.replace + have hsourceRemaining : tapes.entry.source β‰  tapes.remaining := + tapes.ne (by decide) + have hsourceFound : tapes.entry.source β‰  tapes.found := + tapes.ne (by decide) + have hsourceResultCount : tapes.entry.source β‰  tapes.resultCount := + tapes.ne (by decide) + have hremaining := binaryPredTM_readOnly_of_ne tapes.remaining + tapes.entry.source hsourceRemaining + have hdeleteCount := binaryPredTM_readOnly_of_ne tapes.resultCount + tapes.entry.source hsourceResultCount + have happendCount := binarySuccTM_readOnly_of_ne tapes.resultCount + tapes.entry.source hsourceResultCount + intro state inputHead workHeads outputHead hstate + cases state with + | test => + by_cases hremainingBlank : workHeads tapes.remaining = Ξ“.blank + Β· by_cases hfoundOne : workHeads tapes.found = Ξ“.one + Β· simp [entryUpdateTM, hremainingBlank, hfoundOne, TM.allReadBack] + Β· by_cases hreplBlank : workHeads tapes.replacement = Ξ“.blank <;> + simp [entryUpdateTM, hremainingBlank, hfoundOne, hreplBlank, + TM.allReadBack] + Β· simp [entryUpdateTM, hremainingBlank, TM.allReadBack] + | matching state => + by_cases hhalt : state = (entryMatchReadTM tapes.entry).qhalt + Β· by_cases hresult : workHeads tapes.entry.result = Ξ“.one + Β· simp [entryUpdateTM, hhalt, hresult, hsourceFound] + Β· simp [entryUpdateTM, hhalt, hresult, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hmatching state inputHead workHeads outputHead hhalt + | miss state => + by_cases hhalt : state = (entryMissCopyTM tapes.entry).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hmiss state inputHead workHeads outputHead hhalt + | delete state => + by_cases hhalt : state = (entryMissCleanupTM tapes.entry).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hdelete state inputHead workHeads outputHead hhalt + | replace state => + by_cases hhalt : state = (entryReplaceCleanupTM tapes.replace).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hreplace state inputHead workHeads outputHead hhalt + | append state => + by_cases hhalt : state = (entryAppendRestoreTM tapes.replace).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + happend state inputHead workHeads outputHead hhalt + | remaining state => + by_cases hhalt : state = (TM.binaryPredTM tapes.remaining).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hremaining state inputHead workHeads outputHead hhalt + | deleteCount state => + by_cases hhalt : state = (TM.binaryPredTM tapes.resultCount).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + hdeleteCount state inputHead workHeads outputHead hhalt + | appendCount state => + by_cases hhalt : state = (TM.binarySuccTM tapes.resultCount).qhalt + Β· simp [entryUpdateTM, hhalt, TM.allReadBack] + Β· simpa [entryUpdateTM, hhalt] using + happendCount state inputHead workHeads outputHead hhalt + | done => exact (hstate rfl).elim + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Tagged.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Tagged.lean new file mode 100644 index 0000000000..91360d8e1b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Tagged.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedProof + +/-! +# Positive-tag sparse updates +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Successor tagging followed by sparse update implements one dense-overlay +write and preserves the complete encoded-source frame. -/ +theorem taggedEntryUpdateTM_hoareTime_frame {n : β„•} + (tapes : EntryUpdateTapes n) (overlay : Store) (address value : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) (hcanonical : Canonical overlay) + (hready : EntryScanReady tapes.entry (overlay.flatMap Entry.encode) + address.bits initialWork initialWork) + (hreplacement : (initialWork tapes.replacement).HasBinaryNat value) + (hremaining : + (initialWork tapes.remaining).HasBinaryNat overlay.length) + (hfound : (initialWork tapes.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.resultCount).HasBinaryNat overlay.length) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (taggedEntryUpdateTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + TaggedEntryUpdateResult tapes overlay address value initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address value).flatMap Entry.encode)) + (taggedEntryUpdateTime tapes overlay address value) := + taggedEntryUpdateTM_hoareTime_frame_internal tapes overlay address value + emittedBits initialWork inpβ‚€ outβ‚€ hcanonical hready hreplacement + hremaining hfound hresultCount hinput houtput + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedDefs.lean new file mode 100644 index 0000000000..a704db6aba --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedDefs.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs + +/-! +# Positive-tag sparse updates + +Dense overlays encode an actual register value `v` by the positive sparse +value `v + 1`. This module packages successor followed by the existing sparse +update controller as one reusable write-side kernel. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Convert an actual register value to its positive overlay tag, then update +the encoded sparse overlay. -/ +def taggedEntryUpdateTM {n : β„•} (tapes : EntryUpdateTapes n) : TM n := + TM.seqTM (TM.binarySuccTM tapes.replacement) (entryUpdateTM tapes) + +/-- Exact compositional time budget for one positive-tag overlay write. -/ +def taggedEntryUpdateTime {n : β„•} (tapes : EntryUpdateTapes n) + (overlay : Store) (address value : β„•) : β„• := + TM.binarySuccTime value + 1 + + entryUpdateTime tapes overlay address (value + 1) + +/-- Semantic boundary for successor tagging followed by sparse update. -/ +def TaggedEntryUpdateResult {n : β„•} (tapes : EntryUpdateTapes n) + (overlay : Store) (address value : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ taggedWork : Fin n β†’ Tape, + (taggedWork tapes.replacement).HasBinaryNat (value + 1) ∧ + (βˆ€ i, i β‰  tapes.replacement β†’ taggedWork i = initialWork i) ∧ + EntryUpdateOutcome tapes overlay address (value + 1) taggedWork finalWork ∧ + (finalWork tapes.entry.source).cells = + (initialWork tapes.entry.source).cells + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedProof.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedProof.lean new file mode 100644 index 0000000000..c4d24af397 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/TaggedProof.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs + +/-! +# Positive-tag sparse updates -- proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +theorem taggedEntryUpdateTM_hoareTime_frame_internal + (tapes : EntryUpdateTapes n) (overlay : Store) (address value : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) (hcanonical : Canonical overlay) + (hready : EntryScanReady tapes.entry (overlay.flatMap Entry.encode) + address.bits initialWork initialWork) + (hreplacement : (initialWork tapes.replacement).HasBinaryNat value) + (hremaining : + (initialWork tapes.remaining).HasBinaryNat overlay.length) + (hfound : (initialWork tapes.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.resultCount).HasBinaryNat overlay.length) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (taggedEntryUpdateTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + TaggedEntryUpdateResult tapes overlay address value initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address value).flatMap Entry.encode)) + (taggedEntryUpdateTime tapes overlay address value) := by + have houtputParked := hasBinaryPrefix_parked houtput + have hsucc := TM.binarySuccTM_hoareTime_frame tapes.replacement value + inpβ‚€ initialWork outβ‚€ hreplacement hinput.read_ne_start + (fun i _ => (hready.parked i).read_ne_start) + houtputParked.read_ne_start + let taggedPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  tapes.replacement β†’ work i = initialWork i) ∧ + (work tapes.replacement).HasBinaryNat (value + 1) ∧ out = outβ‚€ + let finalPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + TaggedEntryUpdateResult tapes overlay address value initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address value).flatMap Entry.encode) + have hupdate : (entryUpdateTM tapes).HoareTime taggedPost finalPost + (entryUpdateTime tapes overlay address (value + 1)) := by + rintro inp work out ⟨hinp, hother, htag, hout⟩ + have hslotEq (slot : Fin 13) (hne : slot β‰  10) : + work (tapes.idx slot) = initialWork (tapes.idx slot) := + hother _ (tapes.ne hne) + have hready' : EntryScanReady tapes.entry + (overlay.flatMap Entry.encode) address.bits work work := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· change (work (tapes.idx 0)).HasBinarySuffix _ + rw [hslotEq 0 (by decide)] + exact hready.source + Β· change (work (tapes.idx 1)).HasBinaryPrefix [] + rw [hslotEq 1 (by decide)] + exact hready.address + Β· change (work (tapes.idx 1)).cells 0 = Ξ“.start + rw [hslotEq 1 (by decide)] + exact hready.addressStart + Β· change (work (tapes.idx 2)).HasBinaryPrefix [] + rw [hslotEq 2 (by decide)] + exact hready.value + Β· change (work (tapes.idx 2)).cells 0 = Ξ“.start + rw [hslotEq 2 (by decide)] + exact hready.valueStart + Β· change (work (tapes.idx 3)).HasBinaryNat 0 + rw [hslotEq 3 (by decide)] + exact hready.addressCounter + Β· change (work (tapes.idx 4)).HasBinaryNat 0 + rw [hslotEq 4 (by decide)] + exact hready.addressWidth + Β· change (work (tapes.idx 5)).HasBinaryNat 0 + rw [hslotEq 5 (by decide)] + exact hready.valueCounter + Β· change (work (tapes.idx 6)).HasBinaryNat 0 + rw [hslotEq 6 (by decide)] + exact hready.valueWidth + Β· change (work (tapes.idx 7)).HasBinaryString address.bits + rw [hslotEq 7 (by decide)] + exact hready.query + Β· change (work (tapes.idx 7)).cells 0 = Ξ“.start + rw [hslotEq 7 (by decide)] + exact hready.queryStart + Β· change (work (tapes.idx 8)).HasBinaryPrefix [] + rw [hslotEq 8 (by decide)] + exact hready.result + Β· change (work (tapes.idx 8)).cells 0 = Ξ“.start + rw [hslotEq 8 (by decide)] + exact hready.resultStart + Β· intro i + by_cases hi : i = tapes.replacement + Β· subst i + exact ⟨by rw [htag.2.1], + htag.2.hasBinaryContent.cells_ne_start⟩ + Β· rw [hother i hi] + exact hready.parked i + have hremaining' : (work tapes.remaining).HasBinaryNat overlay.length := by + change (work (tapes.idx 9)).HasBinaryNat _ + rw [hslotEq 9 (by decide)] + exact hremaining + have hfound' : (work tapes.found).HasBinaryNat 0 := by + change (work (tapes.idx 11)).HasBinaryNat 0 + rw [hslotEq 11 (by decide)] + exact hfound + have hresultCount' : + (work tapes.resultCount).HasBinaryNat overlay.length := by + change (work (tapes.idx 12)).HasBinaryNat _ + rw [hslotEq 12 (by decide)] + exact hresultCount + have hrun := entryUpdateTM_hoareTime_frame tapes overlay address + (value + 1) emittedBits work inpβ‚€ outβ‚€ hcanonical hready' htag + hremaining' hfound' hresultCount' hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + houtcome, hfinalOutput, hsource⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + have hsourceInitial : + work tapes.entry.source = initialWork tapes.entry.source := + hother _ (tapes.ne (by decide)) + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, htag, hother, houtcome, + hsource.trans (congrArg Tape.cells hsourceInitial)⟩, + by simpa only [DenseOverlay.write] using hfinalOutput⟩ + have htransition : βˆ€ inp work out, taggedPost inp work out β†’ + taggedPost (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + rintro inp work out ⟨hinp, hother, htag, hout⟩ + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + by_cases hi : i = tapes.replacement + Β· subst i + exact ⟨by rw [htag.2.1], + htag.2.hasBinaryContent.cells_ne_start⟩ + Β· rw [hother i hi] + exact hready.parked i + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput.read_ne_start) + (fun i => (hworkParked i).read_ne_start) + (by simpa [hout] using houtputParked.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hother, htag, hout⟩ + have hall := TM.seqTM_hoareTime (TM.binarySuccTM tapes.replacement) + (entryUpdateTM tapes) hsucc htransition hupdate + simpa [taggedEntryUpdateTM, taggedEntryUpdateTime, taggedPost, finalPost] + using hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Types.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Types.lean new file mode 100644 index 0000000000..4a7f5c3f4b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/EntryUpdate/Types.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryAppend.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryMissCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs + +/-! +# Tape assignment and endpoint contracts for sparse-store updates + +The thirteen distinct tape roles, their replacement view, and the complete final +frame and scanner contract used by the update controller. +-/ + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Thirteen pairwise-distinct tapes used by encoded sparse-store update. -/ +structure EntryUpdateTapes (n : β„•) where + /-- Assignment order: nine entry-match tapes, remaining count, replacement + value, found flag, and output count. -/ + idx : Fin 13 β†’ Fin n + /-- The complete assignment is injective. -/ + injective : Function.Injective idx + +namespace EntryUpdateTapes + +/-- The nine-tape decode-and-match assignment. -/ +def entry {n : β„•} (tapes : EntryUpdateTapes n) : EntryMatchTapes n where + idx := fun i => tapes.idx ⟨i, by omega⟩ + injective := by + intro i j hij + have h : (⟨i, by omega⟩ : Fin 13) = ⟨j, by omega⟩ := + tapes.injective hij + apply Fin.ext + exact congrArg (fun k : Fin 13 => k.val) h + +/-- Runtime number of old entries still unread. -/ +def remaining {n : β„•} (tapes : EntryUpdateTapes n) : Fin n := tapes.idx 9 + +/-- Canonical source containing the requested new value. -/ +def replacement {n : β„•} (tapes : EntryUpdateTapes n) : Fin n := tapes.idx 10 + +/-- One-bit flag recording whether a matching old address has been seen. -/ +def found {n : β„•} (tapes : EntryUpdateTapes n) : Fin n := tapes.idx 11 + +/-- Canonical count of entries emitted by the completed update. -/ +def resultCount {n : β„•} (tapes : EntryUpdateTapes n) : Fin n := tapes.idx 12 + +/-- Distinct indices in the thirteen-tape assignment remain distinct. -/ +theorem ne {n : β„•} (tapes : EntryUpdateTapes n) {i j : Fin 13} (h : i β‰  j) : + tapes.idx i β‰  tapes.idx j := + fun hij => h (tapes.injective hij) + +/-- Replacement-emission view of the update assignment. -/ +def replace {n : β„•} (tapes : EntryUpdateTapes n) : EntryReplaceTapes n where + entry := tapes.entry + replacement := tapes.replacement + replacement_ne := by + intro i h + change tapes.idx 10 = tapes.idx ⟨i.val, by omega⟩ at h + have h' : (10 : Fin 13) = ⟨i.val, by omega⟩ := tapes.injective h + have hv : (10 : β„•) = i.val := + congrArg (fun k : Fin 13 => k.val) h' + omega + +@[simp] theorem replace_entry {n : β„•} (tapes : EntryUpdateTapes n) : + tapes.replace.entry = tapes.entry := rfl + +@[simp] theorem replace_replacement {n : β„•} (tapes : EntryUpdateTapes n) : + tapes.replace.replacement = tapes.replacement := rfl + +end EntryUpdateTapes + +/-- Exact preservation predicate outside the thirteen tapes owned by update. -/ +def EntryUpdateFrame {n : β„•} (tapes : EntryUpdateTapes n) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ finalWork i = initialWork i + +/-- Auditable final work-tape contract for one encoded sparse-store update. -/ +structure EntryUpdateOutcome {n : β„•} (tapes : EntryUpdateTapes n) + (store : Store) (address newValue : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + /-- The encoded old store has been consumed and all entry scratch is reset. -/ + ready : EntryScanReady tapes.entry [] address.bits finalWork finalWork + /-- The external replacement source is restored literally. -/ + replacement : finalWork tapes.replacement = initialWork tapes.replacement + /-- The runtime old-entry counter is exhausted. -/ + remaining : (finalWork tapes.remaining).HasBinaryNat 0 + /-- The flag records whether the old store contained the updated address. -/ + found : (finalWork tapes.found).HasBinaryNat + (if address ∈ store.map Prod.fst then 1 else 0) + /-- The result counter is the exact cardinality of the pure sparse write. -/ + resultCount : (finalWork tapes.resultCount).HasBinaryNat + (RegisterStore.write store address newValue).length + /-- Every work tape outside the fixed assignment is unchanged. -/ + frame : EntryUpdateFrame tapes initialWork finalWork + + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction.lean new file mode 100644 index 0000000000..864ea0361c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction.lean @@ -0,0 +1,550 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Direct +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Immediate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Store +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Control + +/-! +# Concrete sparse-store arithmetic instruction kernel + +This surface exposes the first complete instruction-level composition in the +RAM-to-TM direction: two canonical operands are combined by a width-efficient +binary machine and the result is committed by the fixed encoded-store update +controller. A redirected form writes the new store to a fresh work buffer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Uniform framed contract for the selected arithmetic operation. -/ +theorem binaryInstructionArithmeticTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ tapes.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ tapes.rhs).HasBinaryNat rhs) + (hresult : (workβ‚€ tapes.update.replacement).HasBinaryNat 0) + (hshift : (workβ‚€ tapes.shift).HasBinaryNat 0) + (htmp : (workβ‚€ tapes.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ tapes.dbl).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (binaryInstructionArithmeticTM tapes op).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs workβ‚€ work ∧ + out = outβ‚€) + (binaryInstructionArithmeticTime op lhs rhs) := + binaryInstructionArithmeticTM_hoareTime_frame_internal tapes op lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hshift htmp hdbl hinput hwork + houtput + +/-- Width-efficient arithmetic followed by a semantics-exact sparse write. -/ +theorem binaryInstructionUpdateTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (address lhs rhs : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) address.bits initialWork initialWork) + (hlhs : (initialWork tapes.lhs).HasBinaryNat lhs) + (hrhs : (initialWork tapes.rhs).HasBinaryNat rhs) + (hresult : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hshift : (initialWork tapes.shift).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (hremaining : + (initialWork tapes.update.remaining).HasBinaryNat store.length) + (hfound : (initialWork tapes.update.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.update.resultCount).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (initialWork i)) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (binaryInstructionUpdateTM tapes op).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionUpdateResult tapes op store address lhs rhs + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address (op.eval lhs rhs)).flatMap + Entry.encode)) + (binaryInstructionUpdateTime tapes op store address lhs rhs) := + binaryInstructionUpdateTM_hoareTime_frame_internal tapes op store address + lhs rhs emittedBits initialWork inpβ‚€ outβ‚€ hcanonical hready hlhs hrhs + hresult hshift htmp hdbl hremaining hfound hresultCount hinput hwork + houtput + +/-- Redirect the updated encoded store into a fresh last work tape while the +real output remains the standard blank parked tape. -/ +theorem binaryInstructionUpdateTM_retargetOutput_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (address lhs rhs : β„•) + (emittedBits : List Bool) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) address.bits + (fun i => initialWork (Fin.castSucc i)) + (fun i => initialWork (Fin.castSucc i))) + (hlhs : (initialWork (Fin.castSucc tapes.lhs)).HasBinaryNat lhs) + (hrhs : (initialWork (Fin.castSucc tapes.rhs)).HasBinaryNat rhs) + (hresult : + (initialWork (Fin.castSucc tapes.update.replacement)).HasBinaryNat 0) + (hshift : (initialWork (Fin.castSucc tapes.shift)).HasBinaryNat 0) + (htmp : (initialWork (Fin.castSucc tapes.tmp)).HasBinaryNat 0) + (hdbl : (initialWork (Fin.castSucc tapes.dbl)).HasBinaryNat 0) + (hremaining : + (initialWork (Fin.castSucc tapes.update.remaining)).HasBinaryNat + store.length) + (hfound : + (initialWork (Fin.castSucc tapes.update.found)).HasBinaryNat 0) + (hresultCount : + (initialWork (Fin.castSucc tapes.update.resultCount)).HasBinaryNat + store.length) + (hinput : TM.Parked inpβ‚€) + (hwork : βˆ€ i : Fin n, TM.Parked (initialWork (Fin.castSucc i))) + (hbuffer : + (initialWork (Fin.last n)).HasBinaryPrefix emittedBits) : + (binaryInstructionUpdateTM tapes op).retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionUpdateResult tapes op store address lhs rhs + (fun i => initialWork (Fin.castSucc i)) + (fun i => work (Fin.castSucc i)) ∧ + (work (Fin.last n)).HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address (op.eval lhs rhs)).flatMap + Entry.encode) ∧ + out = (Tape.init []).move Dir3.right) + (binaryInstructionUpdateTime tapes op store address lhs rhs) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let buffer := initialWork (Fin.last n) + have hbase := binaryInstructionUpdateTM_hoareTime_frame tapes op store + address lhs rhs emittedBits baseWork inpβ‚€ buffer hcanonical hready hlhs + hrhs hresult hshift htmp hdbl hremaining hfound hresultCount hinput hwork + hbuffer + have hlift := TM.retargetOutput_hoareTime + (binaryInstructionUpdateTM tapes op) hbase + apply hlift.consequence + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + exact ⟨⟨rfl, rfl, rfl⟩, hout⟩ + Β· rintro inp work out ⟨⟨hinp, hresult, hbuffer'⟩, hout⟩ + exact ⟨hinp, hresult, hbuffer', hout⟩ + Β· exact le_rfl + +/-- Arithmetic and sparse update are both one-way-output machines. -/ +theorem binaryInstructionUpdateTM_isTransducer {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) : + (binaryInstructionUpdateTM tapes op).IsTransducer := by + apply TM.IsTransducer.seqTM + Β· cases op with + | add => exact TM.binaryRippleAddTM_isTransducer _ _ _ + | sub => exact TM.binaryRippleSubTM_isTransducer _ _ _ + | mul => exact TM.binaryShiftMulTM_isTransducer _ + Β· exact entryUpdateTM_isTransducer tapes.update + +/-- Two direct sparse-register reads, arithmetic, and the destination write +realize one complete direct `add`, `sub`, or `mul` instruction. -/ +theorem directBinaryInstructionTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (directBinaryInstructionTM tapes op destination sourceβ‚€ source₁).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryInstructionResult tapes op store destination sourceβ‚€ + source₁ initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (op.eval (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁))).flatMap Entry.encode)) + (directBinaryInstructionTime tapes op store destination sourceβ‚€ + source₁) := + directBinaryInstructionTM_hoareTime_frame_internal tapes op store + destination sourceβ‚€ source₁ emittedBits initialWork inpβ‚€ outβ‚€ + hcanonical hinitial hrhsβ‚€ hreplacement htmp hdbl hinput houtput + +/-- Direct arithmetic instruction simulation never moves the output head left. -/ +theorem directBinaryInstructionTM_isTransducer {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (destination sourceβ‚€ source₁ : β„•) : + (directBinaryInstructionTM tapes op destination sourceβ‚€ + source₁).IsTransducer := by + exact + (entryLookupStaticTM_isTransducer tapes.lhsLookup sourceβ‚€).seqTM + ((entryLookupStaticTM_isTransducer tapes.rhsLookup source₁).seqTM + ((TM.binaryAddConstTM_isTransducer tapes.update.entry.query + destination).seqTM + (binaryInstructionUpdateTM_isTransducer tapes op))) + +/-- Every prefix of a direct arithmetic instruction respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem directBinaryInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ : β„•) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (directBinaryInstructionTM tapes op destination sourceβ‚€ source₁).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (directBinaryInstructionTM tapes op destination sourceβ‚€ + source₁).reachesIn time start current) + (htime : time ≀ directBinaryInstructionTime tapes op store destination + sourceβ‚€ source₁) : + current.WithinAuxSpace inputLength + (initialSpace + directBinaryInstructionTime tapes op store destination + sourceβ‚€ source₁) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- A fixed-address lookup followed by a loaded runtime-address lookup and +sparse update realizes one indirect `load`. -/ +theorem indirectLoadInstructionTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination addressRegister : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (indirectLoadInstructionTM tapes destination addressRegister).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectLoadInstructionResult tapes store destination addressRegister + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (RegisterStore.read store + (RegisterStore.read store addressRegister))).flatMap + Entry.encode)) + (indirectLoadInstructionTime tapes store destination addressRegister) := + indirectLoadInstructionTM_hoareTime_frame_internal tapes store destination + addressRegister emittedBits initialWork inpβ‚€ outβ‚€ hcanonical hinitial + hreplacement hinput houtput + +/-- Indirect-load simulation never moves the output head left. -/ +theorem indirectLoadInstructionTM_isTransducer {n : β„•} + (tapes : BinaryInstructionTapes n) (destination addressRegister : β„•) : + (indirectLoadInstructionTM tapes destination + addressRegister).IsTransducer := by + exact + (entryLookupStaticTM_isTransducer tapes.lhsLookup addressRegister).seqTM + ((entryLookupLoadedTM_isTransducer tapes.indirectLoadLookup).seqTM + ((TM.binaryAddConstTM_isTransducer tapes.update.entry.query + destination).seqTM + (entryUpdateTM_isTransducer tapes.update))) + +/-- Every indirect-load prefix respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem indirectLoadInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination addressRegister inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (indirectLoadInstructionTM tapes destination addressRegister).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (indirectLoadInstructionTM tapes destination + addressRegister).reachesIn time start current) + (htime : time ≀ indirectLoadInstructionTime tapes store destination + addressRegister) : + current.WithinAuxSpace inputLength + (initialSpace + indirectLoadInstructionTime tapes store destination + addressRegister) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Immediate-value and destination synthesis followed by sparse update +realizes one `imm` instruction. -/ +theorem immediateInstructionTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (immediateInstructionTM tapes destination value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ImmediateInstructionResult tapes store destination value initialWork + work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination value).flatMap Entry.encode)) + (immediateInstructionTime tapes store destination value) := + immediateInstructionTM_hoareTime_frame_internal tapes store destination value + emittedBits initialWork inpβ‚€ outβ‚€ hcanonical hinitial hreplacement + hinput houtput + +/-- Immediate-instruction simulation never moves the output head left. -/ +theorem immediateInstructionTM_isTransducer {n : β„•} + (tapes : BinaryInstructionTapes n) (destination value : β„•) : + (immediateInstructionTM tapes destination value).IsTransducer := by + exact + (TM.binaryAddConstTM_isTransducer tapes.update.replacement value).seqTM + ((TM.binaryAddConstTM_isTransducer tapes.update.entry.query + destination).seqTM + (entryUpdateTM_isTransducer tapes.update)) + +/-- Every immediate-instruction prefix respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem immediateInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (immediateInstructionTM tapes destination value).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (immediateInstructionTM tapes destination value).reachesIn time + start current) + (htime : time ≀ immediateInstructionTime tapes store destination value) : + current.WithinAuxSpace inputLength + (initialSpace + immediateInstructionTime tapes store destination value) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Two direct lookups followed by framed binary copies into the update ABI +realize one indirect `store`. -/ +theorem indirectStoreInstructionTM_hoareTime_frame {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (indirectStoreInstructionTM tapes addressRegister source).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectStoreInstructionResult tapes store addressRegister source + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store + (RegisterStore.read store addressRegister) + (RegisterStore.read store source)).flatMap Entry.encode)) + (indirectStoreInstructionTime tapes store addressRegister source) := + indirectStoreInstructionTM_hoareTime_frame_internal tapes store + addressRegister source emittedBits initialWork inpβ‚€ outβ‚€ hcanonical + hinitial hrhsβ‚€ hreplacement hinput houtput + +/-- Indirect-store simulation never moves the output head left. -/ +theorem indirectStoreInstructionTM_isTransducer {n : β„•} + (tapes : BinaryInstructionTapes n) (addressRegister source : β„•) : + (indirectStoreInstructionTM tapes addressRegister source).IsTransducer := by + exact + ((entryLookupStaticTM_isTransducer tapes.lhsLookup + addressRegister).seqTM + (entryLookupStaticTM_isTransducer tapes.rhsLookup source)).seqTM + ((TM.binaryCopyIntoTM_isTransducer tapes.lhs tapes.update.entry.query + tapes.update.found).seqTM + ((TM.binaryCopyIntoTM_isTransducer tapes.rhs tapes.update.replacement + tapes.update.found).seqTM + (entryUpdateTM_isTransducer tapes.update))) + +/-- Every indirect-store prefix respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem indirectStoreInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (indirectStoreInstructionTM tapes addressRegister source).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (indirectStoreInstructionTM tapes addressRegister + source).reachesIn time start current) + (htime : time ≀ indirectStoreInstructionTime tapes store addressRegister + source) : + current.WithinAuxSpace inputLength + (initialSpace + indirectStoreInstructionTime tapes store addressRegister + source) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Reset and replace a canonical binary program counter by a fixed literal. -/ +theorem setProgramCounterTM_hoareTime_frame {n : β„•} + (pc : Fin n) (pcValue target : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hpc : (workβ‚€ pc).HasBinaryNat pcValue) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (setProgramCounterTM pc target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ pc + ((Tape.init (target.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + out = outβ‚€) + (setProgramCounterTime pcValue target) := + setProgramCounterTM_hoareTime_frame_internal pc pcValue target inpβ‚€ workβ‚€ + outβ‚€ hpc hinput hwork houtput + +/-- Conditional-zero control realizes sparse `jz` and restores its loaded +operand to the clean lookup ABI. -/ +theorem zeroJumpInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue source target : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (zeroJumpInstructionTM tapes source target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store + (if RegisterStore.read store source = 0 then target + else pcValue + 1) + initialWork work ∧ + out = outβ‚€) + (zeroJumpInstructionTime tapes store pcValue source target) := + zeroJumpInstructionTM_hoareTime_frame_internal tapes store pcValue source + target initialWork inpβ‚€ outβ‚€ hready hinput houtput + +/-- Unconditional control replaces the program counter by its jump target. -/ +theorem jumpInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue target : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (jumpInstructionTM tapes target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store target initialWork work ∧ + out = outβ‚€) + (jumpInstructionTime pcValue target) := + jumpInstructionTM_hoareTime_frame_internal tapes store pcValue target + initialWork inpβ‚€ outβ‚€ hready hinput houtput + +/-- Halt is an exact no-op at the clean control boundary. -/ +theorem haltInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (haltInstructionTM (n := n)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store pcValue initialWork work ∧ + out = outβ‚€) + haltInstructionTime := + haltInstructionTM_hoareTime_frame_internal tapes store pcValue initialWork + inpβ‚€ outβ‚€ hready hinput houtput + +/-- Program-counter replacement never moves the output head left. -/ +theorem setProgramCounterTM_isTransducer {n : β„•} (pc : Fin n) + (target : β„•) : (setProgramCounterTM pc target).IsTransducer := + (TM.resetBinaryWorkTM_isTransducer pc).seqTM + (TM.binaryAddConstTM_isTransducer pc target) + +/-- Conditional-zero control never moves the output head left. -/ +theorem zeroJumpInstructionTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (source target : β„•) : + (zeroJumpInstructionTM tapes source target).IsTransducer := by + exact + (entryLookupStaticTM_isTransducer tapes.data.lhsLookup source).seqTM + (((setProgramCounterTM_isTransducer tapes.pc target).branchWorkBlankTM + (TM.binarySuccTM_isTransducer tapes.pc)).seqTM + (TM.resetBinaryWorkTM_isTransducer tapes.data.lhs)) + +/-- Unconditional jump control never moves the output head left. -/ +theorem jumpInstructionTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (target : β„•) : + (jumpInstructionTM tapes target).IsTransducer := + setProgramCounterTM_isTransducer tapes.pc target + +/-- Halt control never moves the output head left. -/ +theorem haltInstructionTM_isTransducer {n : β„•} : + (haltInstructionTM (n := n)).IsTransducer := by + intro state iHead wHeads oHead + cases state <;> cases oHead <;> simp [haltInstructionTM, TM.skipTM, + TM.idleDir] + +/-- Every conditional-zero prefix respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem zeroJumpInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue source target inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (zeroJumpInstructionTM tapes source target).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (zeroJumpInstructionTM tapes source target).reachesIn time start + current) + (htime : time ≀ + zeroJumpInstructionTime tapes store pcValue source target) : + current.WithinAuxSpace inputLength + (initialSpace + + zeroJumpInstructionTime tapes store pcValue source target) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Every unconditional-jump prefix respects the coarse +initial-space-plus-total-time auxiliary-space envelope. -/ +theorem jumpInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : ControlInstructionTapes n) + (pcValue target inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (jumpInstructionTM tapes target).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (jumpInstructionTM tapes target).reachesIn time start current) + (htime : time ≀ jumpInstructionTime pcValue target) : + current.WithinAuxSpace inputLength + (initialSpace + jumpInstructionTime pcValue target) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Every halt prefix respects its one-step auxiliary-space envelope. -/ +theorem haltInstructionTM_prefix_withinAuxSpace {n : β„•} + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (haltInstructionTM (n := n)).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (haltInstructionTM (n := n)).reachesIn time start current) + (htime : time ≀ haltInstructionTime) : + current.WithinAuxSpace inputLength + (initialSpace + haltInstructionTime) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Control.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Control.lean new file mode 100644 index 0000000000..3e8df141f5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Control.lean @@ -0,0 +1,630 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookupRestore + +/-! +# Sparse-store control instructions + +This proof layer realizes conditional-zero jump, unconditional jump, and halt +over the reusable sparse-lookup ABI and a disjoint canonical binary program- +counter tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem controlReady_update_pc + (tapes : ControlInstructionTapes n) (store : Store) + (oldPC newPC : β„•) (work : Fin n β†’ Tape) (newTape : Tape) + (hready : ControlInstructionReady tapes store oldPC work) + (hnewTape : newTape.HasBinaryNat newPC) : + ControlInstructionReady tapes store newPC + (Function.update work tapes.pc newTape) := by + let finalWork := Function.update work tapes.pc newTape + have hsourceNe : tapes.data.lhsLookup.scan.entry.source β‰  tapes.pc := by + exact tapes.lookup_ne_pc 0 + have haddressNe : tapes.data.lhsLookup.scan.entry.address β‰  tapes.pc := by + exact tapes.lookup_ne_pc 1 + have hvalueNe : tapes.data.lhsLookup.scan.entry.value β‰  tapes.pc := by + exact tapes.lookup_ne_pc 2 + have haddressCounterNe : + tapes.data.lhsLookup.scan.entry.addressCounter β‰  tapes.pc := by + exact tapes.lookup_ne_pc 3 + have haddressWidthNe : + tapes.data.lhsLookup.scan.entry.addressWidth β‰  tapes.pc := by + exact tapes.lookup_ne_pc 4 + have hvalueCounterNe : + tapes.data.lhsLookup.scan.entry.valueCounter β‰  tapes.pc := by + exact tapes.lookup_ne_pc 5 + have hvalueWidthNe : + tapes.data.lhsLookup.scan.entry.valueWidth β‰  tapes.pc := by + exact tapes.lookup_ne_pc 6 + have hqueryNe : tapes.data.lhsLookup.scan.entry.query β‰  tapes.pc := by + exact tapes.lookup_ne_pc 7 + have hresultNe : tapes.data.lhsLookup.scan.entry.result β‰  tapes.pc := by + exact tapes.lookup_ne_pc 8 + have hcountNe : tapes.data.lhsLookup.scan.count β‰  tapes.pc := by + exact tapes.lookup_ne_pc 9 + have hcountSourceNe : tapes.data.lhsLookup.countSource β‰  tapes.pc := by + exact tapes.lookup_ne_pc 10 + have hquerySourceNe : tapes.data.lhsLookup.querySource β‰  tapes.pc := by + exact tapes.lookup_ne_pc 11 + have hdestinationNe : tapes.data.lhsLookup.destination β‰  tapes.pc := by + exact tapes.lookup_ne_pc 12 + have hcopyScratchNe : tapes.data.lhsLookup.copyScratch β‰  tapes.pc := by + exact tapes.lookup_ne_pc 13 + have hscanner : EntryScanReady tapes.data.lhsLookup.scan.entry + (store.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· simpa only [finalWork, Function.update_of_ne hsourceNe] using + hready.lookup.scanner.source + Β· simpa only [finalWork, Function.update_of_ne haddressNe] using + hready.lookup.scanner.address + Β· simpa only [finalWork, Function.update_of_ne haddressNe] using + hready.lookup.scanner.addressStart + Β· simpa only [finalWork, Function.update_of_ne hvalueNe] using + hready.lookup.scanner.value + Β· simpa only [finalWork, Function.update_of_ne hvalueNe] using + hready.lookup.scanner.valueStart + Β· simpa only [finalWork, Function.update_of_ne haddressCounterNe] using + hready.lookup.scanner.addressCounter + Β· simpa only [finalWork, Function.update_of_ne haddressWidthNe] using + hready.lookup.scanner.addressWidth + Β· simpa only [finalWork, Function.update_of_ne hvalueCounterNe] using + hready.lookup.scanner.valueCounter + Β· simpa only [finalWork, Function.update_of_ne hvalueWidthNe] using + hready.lookup.scanner.valueWidth + Β· simpa only [finalWork, Function.update_of_ne hqueryNe] using + hready.lookup.scanner.query + Β· simpa only [finalWork, Function.update_of_ne hqueryNe] using + hready.lookup.scanner.queryStart + Β· simpa only [finalWork, Function.update_of_ne hresultNe] using + hready.lookup.scanner.result + Β· simpa only [finalWork, Function.update_of_ne hresultNe] using + hready.lookup.scanner.resultStart + Β· intro i + by_cases hi : i = tapes.pc + Β· subst i + simpa only [finalWork, Function.update_self] using + hasBinaryNat_parked hnewTape + Β· simpa only [finalWork, Function.update_of_ne hi] using + hready.lookup.scanner.parked i + refine + { lookup := + { scanner := hscanner + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ } + pc := ?_ } + Β· simpa only [finalWork, Function.update_of_ne hsourceNe] using + hready.lookup.sourceStart + Β· simpa only [finalWork, Function.update_of_ne hsourceNe] using + hready.lookup.sourceHead + Β· simpa only [finalWork, Function.update_of_ne hcountNe] using + hready.lookup.count + Β· simpa only [finalWork, Function.update_of_ne hcountSourceNe] using + hready.lookup.countSource + Β· simpa only [finalWork, Function.update_of_ne hquerySourceNe] using + hready.lookup.querySource + Β· simpa only [finalWork, Function.update_of_ne hdestinationNe] using + hready.lookup.destination + Β· simpa only [finalWork, Function.update_of_ne hcopyScratchNe] using + hready.lookup.copyScratch + Β· simpa only [finalWork, Function.update_self] using hnewTape + +private def ZeroJumpBranchResult + (tapes : ControlInstructionTapes n) (store : Store) + (source newPC : β„•) (initialWork finalWork : Fin n β†’ Tape) : + Prop := + βˆƒ lookupWork : Fin n β†’ Tape, + EntryLookupStaticResult tapes.data.lhsLookup store source + initialWork lookupWork ∧ + (finalWork tapes.data.lhs).HasBinaryNat + (RegisterStore.read store source) ∧ + (finalWork tapes.pc).HasBinaryNat newPC ∧ + (βˆ€ i, TM.Parked (finalWork i)) ∧ + βˆ€ i, i β‰  tapes.pc β†’ finalWork i = lookupWork i + +private theorem controlResult_of_zeroJumpReset + (tapes : ControlInstructionTapes n) (store : Store) + (oldPC source newPC : β„•) (initialWork branchWork : Fin n β†’ Tape) + (hinitial : ControlInstructionReady tapes store oldPC initialWork) + (hbranch : ZeroJumpBranchResult tapes store source newPC + initialWork branchWork) : + ControlInstructionResult tapes store newPC initialWork + (Function.update branchWork tapes.data.lhs + ((Tape.init []).move Dir3.right)) := by + obtain ⟨lookupWork, hlookup, hoperand, hpc, hparked, hframe⟩ := hbranch + let finalWork := Function.update branchWork tapes.data.lhs + ((Tape.init []).move Dir3.right) + have hrole (slot : Fin 14) (hslot : slot β‰  12) : + finalWork (tapes.data.lhsLookup.idx slot) = + lookupWork (tapes.data.lhsLookup.idx slot) := by + have hneLhs : tapes.data.lhsLookup.idx slot β‰  tapes.data.lhs := by + intro heq + apply hslot + apply tapes.data.lhsLookup.injective + exact heq + simp only [finalWork, Function.update_of_ne hneLhs] + exact hframe _ (tapes.lookup_ne_pc slot) + have hfinalParked : βˆ€ i, TM.Parked (finalWork i) := by + intro i + by_cases hi : i = tapes.data.lhs + Β· subst i + simp only [finalWork, Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat 0) + Β· simpa only [finalWork, Function.update_of_ne hi] using hparked i + have hscanner : EntryScanReady tapes.data.lhsLookup.scan.entry + (store.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := hfinalParked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).HasBinarySuffix _ + rw [hrole 0 (by decide)] + exact hlookup.scanner.source + Β· change (finalWork (tapes.data.lhsLookup.idx 1)).HasBinaryPrefix [] + rw [hrole 1 (by decide)] + exact hlookup.scanner.address + Β· change (finalWork (tapes.data.lhsLookup.idx 1)).cells 0 = Ξ“.start + rw [hrole 1 (by decide)] + exact hlookup.scanner.addressStart + Β· change (finalWork (tapes.data.lhsLookup.idx 2)).HasBinaryPrefix [] + rw [hrole 2 (by decide)] + exact hlookup.scanner.value + Β· change (finalWork (tapes.data.lhsLookup.idx 2)).cells 0 = Ξ“.start + rw [hrole 2 (by decide)] + exact hlookup.scanner.valueStart + Β· change (finalWork (tapes.data.lhsLookup.idx 3)).HasBinaryNat 0 + rw [hrole 3 (by decide)] + exact hlookup.scanner.addressCounter + Β· change (finalWork (tapes.data.lhsLookup.idx 4)).HasBinaryNat 0 + rw [hrole 4 (by decide)] + exact hlookup.scanner.addressWidth + Β· change (finalWork (tapes.data.lhsLookup.idx 5)).HasBinaryNat 0 + rw [hrole 5 (by decide)] + exact hlookup.scanner.valueCounter + Β· change (finalWork (tapes.data.lhsLookup.idx 6)).HasBinaryNat 0 + rw [hrole 6 (by decide)] + exact hlookup.scanner.valueWidth + Β· change (finalWork (tapes.data.lhsLookup.idx 7)).HasBinaryString [] + rw [hrole 7 (by decide)] + exact hlookup.scanner.query + Β· change (finalWork (tapes.data.lhsLookup.idx 7)).cells 0 = Ξ“.start + rw [hrole 7 (by decide)] + exact hlookup.scanner.queryStart + Β· change (finalWork (tapes.data.lhsLookup.idx 8)).HasBinaryPrefix [] + rw [hrole 8 (by decide)] + exact hlookup.scanner.result + Β· change (finalWork (tapes.data.lhsLookup.idx 8)).cells 0 = Ξ“.start + rw [hrole 8 (by decide)] + exact hlookup.scanner.resultStart + have hfinalReady : ControlInstructionReady tapes store newPC finalWork := by + refine + { lookup := + { scanner := hscanner + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ } + pc := ?_ } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).cells 0 = Ξ“.start + rw [hrole 0 (by decide)] + exact hlookup.sourceStart + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).head = 1 + rw [hrole 0 (by decide)] + exact hlookup.sourceHead + Β· change (finalWork (tapes.data.lhsLookup.idx 9)).HasBinaryNat _ + rw [hrole 9 (by decide)] + exact hlookup.count + Β· change (finalWork (tapes.data.lhsLookup.idx 10)).HasBinaryNat _ + rw [hrole 10 (by decide)] + have hcountSource := hlookup.countSource + change lookupWork (tapes.data.lhsLookup.idx 10) = + initialWork (tapes.data.lhsLookup.idx 10) at hcountSource + rw [hcountSource] + exact hinitial.lookup.countSource + Β· change (finalWork (tapes.data.lhsLookup.idx 11)).HasBinaryNat 0 + rw [hrole 11 (by decide)] + exact hlookup.querySource + Β· change (finalWork tapes.data.lhs).HasBinaryNat 0 + simp only [finalWork, Function.update_self] + exact Tape.init_move_right_hasBinaryNat 0 + Β· change (finalWork (tapes.data.lhsLookup.idx 13)).HasBinaryNat 0 + rw [hrole 13 (by decide)] + exact hlookup.copyScratch + Β· simpa only [finalWork, + Function.update_of_ne tapes.pc_ne_lhs] using hpc + refine + { ready := hfinalReady + sourceCells := ?_ + frame := ?_ } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).cells = + (initialWork (tapes.data.lhsLookup.idx 0)).cells + rw [hrole 0 (by decide)] + exact hlookup.sourceCells + intro i hipc hdata + have hiLhs : i β‰  tapes.data.lhs := hdata 12 + simp only [Function.update_of_ne hiLhs] + rw [hframe i hipc] + exact hlookup.frame i hdata + +/-- Reset a canonical PC and load a fixed target, preserving the literal +external frame. -/ +theorem setProgramCounterTM_hoareTime_frame_internal + (pc : Fin n) (pcValue target : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hpc : (workβ‚€ pc).HasBinaryNat pcValue) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (setProgramCounterTM pc target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ pc + ((Tape.init (target.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + out = outβ‚€) + (setProgramCounterTime pcValue target) := by + let midWork := Function.update workβ‚€ pc + ((Tape.init []).move Dir3.right) + have hreset := TM.resetBinaryWorkTM_hoareTime_frame pc pcValue.bits 1 + inpβ‚€ workβ‚€ outβ‚€ hpc.2.hasBinaryContent hpc.1 + ⟨by rw [hpc.2.1], by rw [hpc.2.1]⟩ hinput + (fun i _ => hwork i) houtput + have hreset' : (TM.resetBinaryWorkTM pc).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = midWork ∧ out = outβ‚€) + (TM.resetBinaryWorkTime 1 pcValue.bits.length) := by + simpa only [midWork] using hreset + have hzero : (midWork pc).HasBinaryNat 0 := by + simp only [midWork, Function.update_self] + exact Tape.init_move_right_hasBinaryNat 0 + have hmidWork : βˆ€ i, TM.Parked (midWork i) := by + intro i + by_cases hi : i = pc + Β· subst i + exact hasBinaryNat_parked hzero + Β· simpa only [midWork, Function.update_of_ne hi] using hwork i + have hadd := TM.binaryAddConstTM_hoareTime_frame pc target 0 inpβ‚€ + midWork outβ‚€ hzero hinput (fun i _ => hmidWork i) houtput + have hseq := TM.seqTM_hoareTime (TM.resetBinaryWorkTM pc) + (TM.binaryAddConstTM pc target) hreset' + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) + (by simpa [hworkEq] using hmidWork) + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hworkEq, hout⟩) + hadd + simpa only [setProgramCounterTM, setProgramCounterTime, midWork, + Function.update_idem, Nat.zero_add] using hseq + +/-- Unconditional jump replaces the PC and preserves the clean sparse-lookup +boundary. -/ +theorem jumpInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue target : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (jumpInstructionTM tapes target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store target initialWork work ∧ + out = outβ‚€) + (jumpInstructionTime pcValue target) := by + have hset := setProgramCounterTM_hoareTime_frame_internal tapes.pc + pcValue target inpβ‚€ initialWork outβ‚€ hready.pc hinput + hready.lookup.scanner.parked houtput + apply hset.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + let targetTape := + (Tape.init (target.bits.map Ξ“.ofBool)).move Dir3.right + have htarget : targetTape.HasBinaryNat target := by + exact Tape.init_move_right_hasBinaryNat target + have hfinalReady := controlReady_update_pc tapes store pcValue target + initialWork targetTape hready htarget + refine ⟨hinp, ?_, hout⟩ + rw [hworkEq] + refine + { ready := hfinalReady + sourceCells := ?_ + frame := ?_ } + Β· exact congrArg Tape.cells + (Function.update_of_ne (tapes.lookup_ne_pc 0) targetTape initialWork) + Β· intro i hipc _ + simp only [Function.update_of_ne hipc] + Β· exact le_rfl + +/-- Conditional-zero lookup and PC update realize the sparse interpreter's +`jz` semantics and restore the lookup operand to zero. -/ +theorem zeroJumpInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue source target : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (zeroJumpInstructionTM tapes source target).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store + (if RegisterStore.read store source = 0 then target + else pcValue + 1) + initialWork work ∧ + out = outβ‚€) + (zeroJumpInstructionTime tapes store pcValue source target) := by + let value := RegisterStore.read store source + let newPC := if value = 0 then target else pcValue + 1 + let lookupPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.data.lhsLookup store source + initialWork work ∧ + out = outβ‚€ + let branchPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + ZeroJumpBranchResult tapes store source newPC + initialWork work ∧ + out = outβ‚€ + have hlookup := entryLookupStaticTM_hoareTime_frame + tapes.data.lhsLookup store source initialWork inpβ‚€ outβ‚€ hready.lookup + hinput houtput + have hbranch : + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) + (TM.binarySuccTM tapes.pc)).HoareTime lookupPost branchPost + (TM.branchWorkBlankTime (setProgramCounterTime pcValue target) + (TM.binarySuccTime pcValue)) := by + let blankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ value = 0 + let nonblankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ value β‰  0 + have hblank : (setProgramCounterTM tapes.pc target).HoareTime + blankPre branchPost (setProgramCounterTime pcValue target) := by + rintro inp work out ⟨⟨hinp, hlookupResult, hout⟩, hzero⟩ + have hpcWork : (work tapes.pc).HasBinaryNat pcValue := by + have hpcEq := hlookupResult.frame tapes.pc + (fun slot => (tapes.lookup_ne_pc slot).symm) + rw [hpcEq] + exact hready.pc + have hset := setProgramCounterTM_hoareTime_frame_internal tapes.pc + pcValue target inp work out hpcWork + (by simpa [hinp] using hinput) + hlookupResult.parked (by simpa [hout] using houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hset inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, ?_, ?_, ?_⟩ + Β· exact hfinalInput.trans hinp + Β· rw [hfinalWork] + let targetTape := + (Tape.init (target.bits.map Ξ“.ofBool)).move Dir3.right + have htarget : targetTape.HasBinaryNat target := + Tape.init_move_right_hasBinaryNat target + refine ⟨work, hlookupResult, ?_, ?_, ?_, ?_⟩ + Β· have hoperand := hlookupResult.destination + change (work tapes.data.lhs).HasBinaryNat value at hoperand + simpa only [Function.update_of_ne tapes.lhs_ne_pc] using hoperand + Β· simpa only [targetTape, Function.update_self, newPC, value, + hzero, ite_eq_left] using htarget + Β· intro i + by_cases hi : i = tapes.pc + Β· subst i + simpa only [targetTape, Function.update_self] using + hasBinaryNat_parked htarget + Β· simpa only [targetTape, Function.update_of_ne hi] using + hlookupResult.parked i + Β· intro i hi + simp only [Function.update_of_ne hi] + Β· exact hfinalOutput.trans hout + have hnonblank : (TM.binarySuccTM tapes.pc).HoareTime + nonblankPre branchPost (TM.binarySuccTime pcValue) := by + rintro inp work out ⟨⟨hinp, hlookupResult, hout⟩, hnonzero⟩ + have hpcWork : (work tapes.pc).HasBinaryNat pcValue := by + have hpcEq := hlookupResult.frame tapes.pc + (fun slot => (tapes.lookup_ne_pc slot).symm) + rw [hpcEq] + exact hready.pc + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have houtParked : TM.Parked out := by simpa [hout] using houtput + have hsucc := TM.binarySuccTM_hoareTime_frame tapes.pc pcValue inp + work out hpcWork hinpParked.read_ne_start + (fun i _ => (hlookupResult.parked i).read_ne_start) + houtParked.read_ne_start + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hframe, hfinalPC, hfinalOutput⟩ := + hsucc inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, ?_, ?_, ?_⟩ + Β· exact hfinalInput.trans hinp + Β· refine ⟨work, hlookupResult, ?_, ?_, ?_, hframe⟩ + Β· rw [hframe tapes.data.lhs tapes.lhs_ne_pc] + change (work tapes.data.lhs).HasBinaryNat value + exact hlookupResult.destination + Β· simpa only [newPC, value, ite_eq_right hnonzero] using hfinalPC + Β· intro i + by_cases hi : i = tapes.pc + Β· subst i + exact hasBinaryNat_parked hfinalPC + Β· rw [hframe i hi] + exact hlookupResult.parked i + Β· exact hfinalOutput.trans hout + have hdispatch := TM.branchWorkBlankTM_hoareTime tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc) + (pre := lookupPost) (blankPre := blankPre) + (nonblankPre := nonblankPre) (blankPost := branchPost) + (nonblankPost := branchPost) + (fun inp work out hpre => by + have hinpParked : TM.Parked inp := by simpa [hpre.1] using hinput + have houtParked : TM.Parked out := by simpa [hpre.2.2] using houtput + exact ⟨hinpParked.read_ne_start, + fun i => (hpre.2.1.parked i).read_ne_start, + houtParked.read_ne_start⟩) + (fun _ work _ hpre hread => + ⟨hpre, + hpre.2.1.destination.read_eq_blank_iff.mp hread⟩) + (fun _ work _ hpre hread => + ⟨hpre, fun hzero => + hread (hpre.2.1.destination.read_eq_blank_iff.mpr hzero)⟩) + hblank hnonblank + exact hdispatch.consequence (fun _ _ _ h => h) + (fun _ _ _ h => h.elim id id) le_rfl + have hreset : (TM.resetBinaryWorkTM tapes.data.lhs).HoareTime + branchPost + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store newPC initialWork work ∧ + out = outβ‚€) + (TM.resetBinaryWorkTime 1 value.bits.length) := by + rintro inp work out ⟨hinp, hbranchResult, hout⟩ + obtain ⟨lookupWork, hlookupResult, hoperand, hpcResult, + hparked, hframe⟩ := hbranchResult + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have hrun := TM.resetBinaryWorkTM_hoareTime_frame tapes.data.lhs + value.bits 1 inp work out hoperand.2.hasBinaryContent + hoperand.1 + ⟨by rw [hoperand.2.1], by rw [hoperand.2.1]⟩ + hinpParked (fun i _ => hparked i) + (by simpa [hout] using houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, ?_, ?_, ?_⟩ + Β· exact hfinalInput.trans hinp + Β· rw [hfinalWork] + exact controlResult_of_zeroJumpReset tapes store pcValue source newPC + initialWork work hready + ⟨lookupWork, hlookupResult, hoperand, hpcResult, hparked, hframe⟩ + Β· exact hfinalOutput.trans hout + have hbranchReset := TM.seqTM_hoareTime + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs) hbranch + (by + rintro inp work out ⟨hinp, hbranchResult, hout⟩ + obtain ⟨lookupWork, hlookupResult, hoperand, hpcResult, + hparked, hframe⟩ := hbranchResult + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hparked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, + ⟨lookupWork, hlookupResult, hoperand, hpcResult, hparked, hframe⟩, + hout⟩) + hreset + have hall := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.data.lhsLookup source) + (TM.seqTM + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs)) hlookup + (by + rintro inp work out ⟨hinp, hlookupResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hlookupResult.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hlookupResult, hout⟩) + hbranchReset + simpa only [zeroJumpInstructionTM, zeroJumpInstructionTime, value, newPC] + using hall + +/-- Halt is an exact one-step no-op at the clean control boundary. -/ +theorem haltInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : ControlInstructionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (haltInstructionTM (n := n)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes store pcValue initialWork work ∧ + out = outβ‚€) + haltInstructionTime := by + have hskip := TM.skipTM_hoareTime_frame inpβ‚€ initialWork outβ‚€ hinput + hready.lookup.scanner.parked houtput + apply hskip.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + subst work + exact ⟨hinp, ⟨hready, rfl, by intros; rfl⟩, hout⟩ + Β· exact le_rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Defs.lean new file mode 100644 index 0000000000..990c418e04 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Defs.lean @@ -0,0 +1,371 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Tapes + +/-! +# Concrete sparse-store arithmetic instruction kernel + +This layer joins the width-efficient arithmetic machines to encoded sparse +update. The destination address and two looked-up operands are supplied on +canonical work tapes; the arithmetic result is written directly to the update +controller's replacement tape, so no value-sized bridge is hidden between the +two phases. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Pure result of the selected arithmetic operation. -/ +def BinaryInstrOp.eval : BinaryInstrOp β†’ β„• β†’ β„• β†’ β„• + | .add, lhs, rhs => lhs + rhs + | .sub, lhs, rhs => lhs - rhs + | .mul, lhs, rhs => lhs * rhs + +/-- Concrete arithmetic phase selected in finite control. -/ +def binaryInstructionArithmeticTM {n : β„•} + (tapes : BinaryInstructionTapes n) : BinaryInstrOp β†’ TM n + | .add => TM.binaryRippleAddTM tapes.lhs tapes.rhs tapes.update.replacement + | .sub => TM.binaryRippleSubTM tapes.lhs tapes.rhs tapes.update.replacement + | .mul => TM.binaryShiftMulTM tapes.mul + +/-- Uniform endpoint of the selected arithmetic phase. -/ +structure BinaryInstructionArithmeticResult {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (lhs rhs : β„•) (initialWork finalWork : Fin n β†’ Tape) : Prop where + /-- First operand is restored canonically. -/ + lhsValue : (finalWork tapes.lhs).HasBinaryNat lhs + /-- Second operand is restored canonically. -/ + rhsValue : (finalWork tapes.rhs).HasBinaryNat rhs + /-- The update replacement tape contains the selected result. -/ + result : (finalWork tapes.update.replacement).HasBinaryNat (op.eval lhs rhs) + /-- Multiplication scratch is reset. -/ + shift : (finalWork tapes.shift).HasBinaryNat 0 + /-- First alternating scratch is reset. -/ + tmp : (finalWork tapes.tmp).HasBinaryNat 0 + /-- Second alternating scratch is reset. -/ + dbl : (finalWork tapes.dbl).HasBinaryNat 0 + /-- Every work head is parked at the phase boundary. -/ + parked : βˆ€ i, TM.Parked (finalWork i) + /-- Tapes outside the six arithmetic roles are literally preserved. -/ + frame : βˆ€ i, i β‰  tapes.lhs β†’ i β‰  tapes.rhs β†’ + i β‰  tapes.update.replacement β†’ i β‰  tapes.shift β†’ + i β‰  tapes.tmp β†’ i β‰  tapes.dbl β†’ + finalWork i = initialWork i + +/-- Uniform endpoint of arithmetic followed by encoded sparse update. -/ +def BinaryInstructionUpdateResult {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (address lhs rhs : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ arithmeticWork : Fin n β†’ Tape, + BinaryInstructionArithmeticResult tapes op lhs rhs + initialWork arithmeticWork ∧ + EntryUpdateOutcome tapes.update store address (op.eval lhs rhs) + arithmeticWork finalWork ∧ + (finalWork tapes.update.entry.source).cells = + (initialWork tapes.update.entry.source).cells + +/-- Arithmetic followed immediately by the fixed sparse update controller. -/ +def binaryInstructionUpdateTM {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) : TM n := + TM.seqTM (binaryInstructionArithmeticTM tapes op) + (entryUpdateTM tapes.update) + +/-- Load two direct register operands, prepare the direct destination address, +then run arithmetic and sparse update. -/ +def directBinaryInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (destination sourceβ‚€ source₁ : β„•) : TM n := + TM.seqTM (entryLookupStaticTM tapes.lhsLookup sourceβ‚€) + (TM.seqTM (entryLookupStaticTM tapes.rhsLookup source₁) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (binaryInstructionUpdateTM tapes op))) + +/-- Load an address register, perform the loaded indirect read into the update +replacement tape, synthesize the direct destination, and update the store. -/ +def indirectLoadInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) (destination addressRegister : β„•) : + TM n := + TM.seqTM (entryLookupStaticTM tapes.lhsLookup addressRegister) + (TM.seqTM (entryLookupLoadedTM tapes.indirectLoadLookup) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update))) + +/-- Synthesize an immediate value and direct destination, then update the +sparse store. -/ +def immediateInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) (destination value : β„•) : TM n := + TM.seqTM (TM.binaryAddConstTM tapes.update.replacement value) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update)) + +/-- Load the indirect destination and direct source, copy both into the update +ABI, and update the sparse store. -/ +def indirectStoreInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) + (addressRegister source : β„•) : TM n := + TM.seqTM + (TM.seqTM (entryLookupStaticTM tapes.lhsLookup addressRegister) + (entryLookupStaticTM tapes.rhsLookup source)) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query + tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement + tapes.update.found) + (entryUpdateTM tapes.update))) + +/-- Replace the canonical binary program counter by a fixed literal. -/ +def setProgramCounterTM {n : β„•} (pc : Fin n) (target : β„•) : TM n := + TM.seqTM (TM.resetBinaryWorkTM pc) (TM.binaryAddConstTM pc target) + +/-- Conditional-zero control instruction. The fixed sparse read is cleared +after branching so the reusable lookup ABI is restored at the endpoint. -/ +def zeroJumpInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) + (source target : β„•) : TM n := + TM.seqTM (entryLookupStaticTM tapes.data.lhsLookup source) + (TM.seqTM + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) + (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs)) + +/-- Unconditional jump control instruction. -/ +def jumpInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) + (target : β„•) : TM n := + setProgramCounterTM tapes.pc target + +/-- Halt is represented by a one-step exact no-op instruction kernel. The +outer run controller detects halt before beginning another iteration. -/ +def haltInstructionTM {n : β„•} : TM n := TM.skipTM + +/-- Canonical entry boundary for a control instruction. -/ +structure ControlInstructionReady {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (work : Fin n β†’ Tape) : Prop where + /-- The fixed sparse-lookup ABI is ready. -/ + lookup : EntryLookupStaticReady tapes.data.lhsLookup store work + /-- The program counter contains the represented value. -/ + pc : (work tapes.pc).HasBinaryNat pcValue + +/-- Semantic endpoint shared by the three control-only instruction forms. -/ +structure ControlInstructionResult {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + /-- The clean control ABI is restored with the new program counter. -/ + ready : ControlInstructionReady tapes store pcValue finalWork + /-- The encoded source cells are read-only. -/ + sourceCells : (finalWork tapes.data.update.entry.source).cells = + (initialWork tapes.data.update.entry.source).cells + /-- Every tape outside the lookup ABI and PC assignment is preserved. -/ + frame : βˆ€ i, i β‰  tapes.pc β†’ + (βˆ€ slot, i β‰  tapes.data.lhsLookup.idx slot) β†’ + finalWork i = initialWork i + +/-- Runtime for replacing a canonical program counter by a literal. -/ +def setProgramCounterTime (pcValue target : β„•) : β„• := + TM.resetBinaryWorkTime 1 pcValue.bits.length + 1 + + TM.binaryAddConstTime target 0 + +/-- Runtime for conditional-zero control, including lookup and operand reset. -/ +def zeroJumpInstructionTime {n : β„•} (tapes : ControlInstructionTapes n) + (store : Store) (pcValue source target : β„•) : β„• := + entryLookupStaticTime tapes.data.lhsLookup store source + 1 + + (TM.branchWorkBlankTime (setProgramCounterTime pcValue target) + (TM.binarySuccTime pcValue) + 1 + + TM.resetBinaryWorkTime 1 + (RegisterStore.read store source).bits.length) + +/-- Runtime for an unconditional jump. -/ +def jumpInstructionTime (pcValue target : β„•) : β„• := + setProgramCounterTime pcValue target + +/-- Runtime for the exact halt no-op. -/ +def haltInstructionTime : β„• := 1 + +/-- Boundary after the two direct source-register lookups. -/ +def DirectBinaryOperandsResult {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (sourceβ‚€ source₁ : β„•) (initialWork finalWork : Fin n β†’ Tape) : + Prop := + βˆƒ lhsWork, + EntryLookupStaticResult tapes.lhsLookup store sourceβ‚€ + initialWork lhsWork ∧ + EntryLookupStaticResult tapes.rhsLookup store source₁ + lhsWork finalWork + +/-- Boundary after the direct destination literal has been synthesized on the +update query tape. -/ +def DirectBinaryAddressResult {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ operandsWork, + DirectBinaryOperandsResult tapes store sourceβ‚€ source₁ + initialWork operandsWork ∧ + finalWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + +/-- Exact update-controller ABI established by the lookup and address-loading +prefix of a direct arithmetic instruction. -/ +structure DirectBinaryUpdateReady {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination sourceβ‚€ source₁ : β„•) (work : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.update.entry (store.flatMap Entry.encode) + destination.bits work work + lhs : (work tapes.lhs).HasBinaryNat (RegisterStore.read store sourceβ‚€) + rhs : (work tapes.rhs).HasBinaryNat (RegisterStore.read store source₁) + replacement : (work tapes.update.replacement).HasBinaryNat 0 + shift : (work tapes.shift).HasBinaryNat 0 + tmp : (work tapes.tmp).HasBinaryNat 0 + dbl : (work tapes.dbl).HasBinaryNat 0 + remaining : (work tapes.update.remaining).HasBinaryNat store.length + found : (work tapes.update.found).HasBinaryNat 0 + resultCount : (work tapes.update.resultCount).HasBinaryNat store.length + parked : βˆ€ i, TM.Parked (work i) + +/-- Semantic endpoint of a complete direct arithmetic instruction. -/ +def DirectBinaryInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ updateWork, + DirectBinaryAddressResult tapes store destination sourceβ‚€ source₁ + initialWork updateWork ∧ + BinaryInstructionUpdateResult tapes op store destination + (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁) updateWork finalWork + +/-- Semantic endpoint of a complete indirect load. -/ +def IndirectLoadInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination addressRegister : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ addressWork loadedWork updateWork, + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork ∧ + EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork loadedWork ∧ + updateWork = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + EntryUpdateOutcome tapes.update store destination + (RegisterStore.read store (RegisterStore.read store addressRegister)) + updateWork finalWork ∧ + (finalWork tapes.update.entry.source).cells = + (initialWork tapes.update.entry.source).cells + +/-- Semantic endpoint of one immediate assignment. -/ +def ImmediateInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value : β„•) (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ valueWork updateWork, + valueWork = Function.update initialWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + updateWork = Function.update valueWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + EntryUpdateOutcome tapes.update store destination value updateWork finalWork ∧ + (finalWork tapes.update.entry.source).cells = + (initialWork tapes.update.entry.source).cells + +/-- Semantic endpoint of one indirect store. -/ +def IndirectStoreInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ operandsWork queryWork updateWork, + DirectBinaryOperandsResult tapes store addressRegister source initialWork + operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init ((RegisterStore.read store addressRegister).bits.map + Ξ“.ofBool)).move Dir3.right) ∧ + updateWork = Function.update queryWork tapes.update.replacement + ((Tape.init ((RegisterStore.read store source).bits.map Ξ“.ofBool)).move + Dir3.right) ∧ + EntryUpdateOutcome tapes.update store + (RegisterStore.read store addressRegister) + (RegisterStore.read store source) updateWork finalWork ∧ + (finalWork tapes.update.entry.source).cells = + (initialWork tapes.update.entry.source).cells + +/-- Operation-specific arithmetic budget. -/ +def binaryInstructionArithmeticTime (op : BinaryInstrOp) (lhs rhs : β„•) : β„• := + match op with + | .add => TM.binaryRippleAddTime lhs rhs + | .sub => TM.binaryRippleSubTime lhs rhs + | .mul => TM.binaryShiftMulTime lhs rhs + +/-- Complete arithmetic-plus-update budget, including the composition seam. -/ +def binaryInstructionUpdateTime {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (address lhs rhs : β„•) : β„• := + binaryInstructionArithmeticTime op lhs rhs + 1 + + entryUpdateTime tapes.update store address (op.eval lhs rhs) + +/-- Complete direct arithmetic-instruction budget. -/ +def directBinaryInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ : β„•) : β„• := + entryLookupStaticTime tapes.lhsLookup store sourceβ‚€ + 1 + + (entryLookupStaticTime tapes.rhsLookup store source₁ + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + binaryInstructionUpdateTime tapes op store destination + (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁))) + +/-- Complete indirect-load instruction budget. -/ +def indirectLoadInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination addressRegister : β„•) : β„• := + entryLookupStaticTime tapes.lhsLookup store addressRegister + 1 + + (entryLookupLoadedTime tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + entryUpdateTime tapes.update store destination + (RegisterStore.read store + (RegisterStore.read store addressRegister)))) + +/-- Complete immediate-assignment instruction budget. -/ +def immediateInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value : β„•) : β„• := + TM.binaryAddConstTime value 0 + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + entryUpdateTime tapes.update store destination value) + +/-- Complete indirect-store instruction budget. -/ +def indirectStoreInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) : β„• := + (entryLookupStaticTime tapes.lhsLookup store addressRegister + 1 + + entryLookupStaticTime tapes.rhsLookup store source) + 1 + + (TM.binaryCopyTime (RegisterStore.read store addressRegister) 0 + 1 + + (TM.binaryCopyTime (RegisterStore.read store source) 0 + 1 + + entryUpdateTime tapes.update store + (RegisterStore.read store addressRegister) + (RegisterStore.read store source))) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dense.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dense.lean new file mode 100644 index 0000000000..2da1c473b2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dense.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Finset.Attr +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Dense-overlay RAM instruction kernels + +This module collects the concrete positive-tag instruction simulators and +their exact Hoare/time contracts. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseControl.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseControl.lean new file mode 100644 index 0000000000..1e70852f65 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseControl.lean @@ -0,0 +1,374 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Control + +/-! +# Dense-overlay control instructions +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private def DenseZeroJumpBranchResult + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (source newPC : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ lookupWork : Fin n β†’ Tape, + DenseOverlayLookupStaticResult tapes.data.lhsLookup input overlay source + initialWork lookupWork ∧ + (finalWork tapes.data.lhs).HasBinaryNat + (DenseOverlay.read input overlay source) ∧ + (finalWork tapes.pc).HasBinaryNat newPC ∧ + (βˆ€ i, TM.Parked (finalWork i)) ∧ + βˆ€ i, i β‰  tapes.pc β†’ finalWork i = lookupWork i + +private theorem denseControlResult_of_zeroJumpReset + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (oldPC source newPC : β„•) + (initialWork branchWork : Fin n β†’ Tape) + (hinitial : ControlInstructionReady tapes overlay oldPC initialWork) + (hbranch : DenseZeroJumpBranchResult tapes input overlay source newPC + initialWork branchWork) : + ControlInstructionResult tapes overlay newPC initialWork + (Function.update branchWork tapes.data.lhs + ((Tape.init []).move Dir3.right)) := by + obtain ⟨lookupWork, hlookup, hoperand, hpc, hparked, hframe⟩ := hbranch + let finalWork := Function.update branchWork tapes.data.lhs + ((Tape.init []).move Dir3.right) + have hrole (slot : Fin 14) (hslot : slot β‰  12) : + finalWork (tapes.data.lhsLookup.idx slot) = + lookupWork (tapes.data.lhsLookup.idx slot) := by + have hneLhs : tapes.data.lhsLookup.idx slot β‰  tapes.data.lhs := by + intro heq + apply hslot + apply tapes.data.lhsLookup.injective + exact heq + simp only [finalWork, Function.update_of_ne hneLhs] + exact hframe _ (tapes.lookup_ne_pc slot) + have hfinalParked : βˆ€ i, TM.Parked (finalWork i) := by + intro i + by_cases hi : i = tapes.data.lhs + Β· subst i + simp only [finalWork, Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat 0) + Β· simpa only [finalWork, Function.update_of_ne hi] using! hparked i + have hscanner : EntryScanReady tapes.data.lhsLookup.scan.entry + (overlay.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := hfinalParked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).HasBinarySuffix _ + rw [hrole 0 (by decide)] + exact hlookup.scanner.source + Β· change (finalWork (tapes.data.lhsLookup.idx 1)).HasBinaryPrefix [] + rw [hrole 1 (by decide)] + exact hlookup.scanner.address + Β· change (finalWork (tapes.data.lhsLookup.idx 1)).cells 0 = Ξ“.start + rw [hrole 1 (by decide)] + exact hlookup.scanner.addressStart + Β· change (finalWork (tapes.data.lhsLookup.idx 2)).HasBinaryPrefix [] + rw [hrole 2 (by decide)] + exact hlookup.scanner.value + Β· change (finalWork (tapes.data.lhsLookup.idx 2)).cells 0 = Ξ“.start + rw [hrole 2 (by decide)] + exact hlookup.scanner.valueStart + Β· change (finalWork (tapes.data.lhsLookup.idx 3)).HasBinaryNat 0 + rw [hrole 3 (by decide)] + exact hlookup.scanner.addressCounter + Β· change (finalWork (tapes.data.lhsLookup.idx 4)).HasBinaryNat 0 + rw [hrole 4 (by decide)] + exact hlookup.scanner.addressWidth + Β· change (finalWork (tapes.data.lhsLookup.idx 5)).HasBinaryNat 0 + rw [hrole 5 (by decide)] + exact hlookup.scanner.valueCounter + Β· change (finalWork (tapes.data.lhsLookup.idx 6)).HasBinaryNat 0 + rw [hrole 6 (by decide)] + exact hlookup.scanner.valueWidth + Β· change (finalWork (tapes.data.lhsLookup.idx 7)).HasBinaryString [] + rw [hrole 7 (by decide)] + exact hlookup.scanner.query + Β· change (finalWork (tapes.data.lhsLookup.idx 7)).cells 0 = Ξ“.start + rw [hrole 7 (by decide)] + exact hlookup.scanner.queryStart + Β· change (finalWork (tapes.data.lhsLookup.idx 8)).HasBinaryPrefix [] + rw [hrole 8 (by decide)] + exact hlookup.scanner.result + Β· change (finalWork (tapes.data.lhsLookup.idx 8)).cells 0 = Ξ“.start + rw [hrole 8 (by decide)] + exact hlookup.scanner.resultStart + have hfinalReady : ControlInstructionReady tapes overlay newPC finalWork := by + refine + { lookup := + { scanner := hscanner + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ } + pc := ?_ } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).cells 0 = Ξ“.start + rw [hrole 0 (by decide)] + exact hlookup.sourceStart + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).head = 1 + rw [hrole 0 (by decide)] + exact hlookup.sourceHead + Β· change (finalWork (tapes.data.lhsLookup.idx 9)).HasBinaryNat _ + rw [hrole 9 (by decide)] + exact hlookup.count + Β· change (finalWork (tapes.data.lhsLookup.idx 10)).HasBinaryNat _ + rw [hrole 10 (by decide)] + rw [show lookupWork (tapes.data.lhsLookup.idx 10) = + initialWork (tapes.data.lhsLookup.idx 10) by + simpa using! hlookup.countSource] + exact hinitial.lookup.countSource + Β· change (finalWork (tapes.data.lhsLookup.idx 11)).HasBinaryNat 0 + rw [hrole 11 (by decide)] + exact hlookup.querySource + Β· change (finalWork tapes.data.lhs).HasBinaryNat 0 + simp only [finalWork, Function.update_self] + exact Tape.init_move_right_hasBinaryNat 0 + Β· change (finalWork (tapes.data.lhsLookup.idx 13)).HasBinaryNat 0 + rw [hrole 13 (by decide)] + exact hlookup.copyScratch + Β· simpa only [finalWork, Function.update_of_ne tapes.pc_ne_lhs] using! hpc + refine + { ready := hfinalReady + sourceCells := ?_ + frame := ?_ } + Β· change (finalWork (tapes.data.lhsLookup.idx 0)).cells = + (initialWork (tapes.data.lhsLookup.idx 0)).cells + rw [hrole 0 (by decide)] + exact hlookup.sourceCells + Β· intro i hipc hdata + have hiLhs : i β‰  tapes.data.lhs := hdata 12 + simp only [Function.update_of_ne hiLhs] + rw [hframe i hipc] + exact hlookup.frame i hdata + +/-- A dense-overlay conditional read implements `jz` and restores the shared +lookup ABI after the program-counter branch. -/ +theorem denseZeroJumpInstructionTM_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue source target : β„•) + (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : ControlInstructionReady tapes overlay pcValue initialWork) + (houtput : TM.Parked outβ‚€) : + (denseZeroJumpInstructionTM tapes source target).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + ControlInstructionResult tapes overlay + (if DenseOverlay.read input overlay source = 0 then target + else pcValue + 1) + initialWork work ∧ out = outβ‚€) + (denseZeroJumpInstructionTime tapes input overlay pcValue source + target) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let value := DenseOverlay.read input overlay source + let newPC := if value = 0 then target else pcValue + 1 + let lookupPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes.data.lhsLookup input overlay source + initialWork work ∧ out = outβ‚€ + let branchPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + DenseZeroJumpBranchResult tapes input overlay source newPC initialWork + work ∧ out = outβ‚€ + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlookup := denseOverlayLookupStaticTM_hoareTime_frame + tapes.data.lhsLookup input overlay source initialWork outβ‚€ hvalid + hready.lookup houtput + have hbranch : + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) + (TM.binarySuccTM tapes.pc)).HoareTime lookupPost branchPost + (TM.branchWorkBlankTime (setProgramCounterTime pcValue target) + (TM.binarySuccTime pcValue)) := by + let blankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ value = 0 + let nonblankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ value β‰  0 + have hblank : (setProgramCounterTM tapes.pc target).HoareTime + blankPre branchPost (setProgramCounterTime pcValue target) := by + rintro inp work out ⟨⟨hinp, hlookupResult, hout⟩, hzero⟩ + have hpcWork : (work tapes.pc).HasBinaryNat pcValue := by + rw [hlookupResult.frame tapes.pc + (fun slot => (tapes.lookup_ne_pc slot).symm)] + exact hready.pc + have hset := setProgramCounterTM_hoareTime_frame_internal tapes.pc + pcValue target inp work out hpcWork + (by simpa [hinp] using! hinput) + hlookupResult.parked (by simpa [hout] using! houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hset inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, + hfinalInput.trans hinp, ?_, hfinalOutput.trans hout⟩ + rw [hfinalWork] + let targetTape := + (Tape.init (target.bits.map Ξ“.ofBool)).move Dir3.right + have htarget : targetTape.HasBinaryNat target := + Tape.init_move_right_hasBinaryNat target + refine ⟨work, hlookupResult, ?_, ?_, ?_, ?_⟩ + Β· simpa only [Function.update_of_ne tapes.lhs_ne_pc, value] using! + hlookupResult.destination + Β· simpa only [targetTape, Function.update_self, newPC, hzero, ite_eq_left] + using! htarget + Β· intro i + by_cases hi : i = tapes.pc + Β· subst i + simpa only [targetTape, Function.update_self] using! + hasBinaryNat_parked htarget + Β· simpa only [targetTape, Function.update_of_ne hi] using! + hlookupResult.parked i + Β· intro i hi + exact Function.update_of_ne hi _ work + have hnonblank : (TM.binarySuccTM tapes.pc).HoareTime + nonblankPre branchPost (TM.binarySuccTime pcValue) := by + rintro inp work out ⟨⟨hinp, hlookupResult, hout⟩, hnonzero⟩ + have hpcWork : (work tapes.pc).HasBinaryNat pcValue := by + rw [hlookupResult.frame tapes.pc + (fun slot => (tapes.lookup_ne_pc slot).symm)] + exact hready.pc + have hsucc := TM.binarySuccTM_hoareTime_frame tapes.pc pcValue inp + work out hpcWork (by simpa [hinp] using! hinput.read_ne_start) + (fun i _ => (hlookupResult.parked i).read_ne_start) + (by simpa [hout] using! houtput.read_ne_start) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hframe, hfinalPC, hfinalOutput⟩ := + hsucc inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, + hfinalInput.trans hinp, ?_, hfinalOutput.trans hout⟩ + refine ⟨work, hlookupResult, ?_, ?_, ?_, hframe⟩ + Β· rw [hframe tapes.data.lhs tapes.lhs_ne_pc] + simpa only [value] using! hlookupResult.destination + Β· simpa only [newPC, ite_eq_right hnonzero] using! hfinalPC + Β· intro i + by_cases hi : i = tapes.pc + Β· subst i + exact hasBinaryNat_parked hfinalPC + Β· rw [hframe i hi] + exact hlookupResult.parked i + have hdispatch := TM.branchWorkBlankTM_hoareTime tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc) + (pre := lookupPost) (blankPre := blankPre) + (nonblankPre := nonblankPre) (blankPost := branchPost) + (nonblankPost := branchPost) + (fun inp work out hpre => + ⟨(by simpa [hpre.1] using! hinput.read_ne_start), + fun i => (hpre.2.1.parked i).read_ne_start, + by simpa [hpre.2.2] using! houtput.read_ne_start⟩) + (fun _ _ _ hpre hread => + ⟨hpre, hpre.2.1.destination.read_eq_blank_iff.mp hread⟩) + (fun _ _ _ hpre hread => + ⟨hpre, fun hzero => + hread (hpre.2.1.destination.read_eq_blank_iff.mpr hzero)⟩) + hblank hnonblank + exact hdispatch.consequence (fun _ _ _ h => h) + (fun _ _ _ h => h.elim id id) le_rfl + have hreset : (TM.resetBinaryWorkTM tapes.data.lhs).HoareTime branchPost + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes overlay newPC initialWork work ∧ + out = outβ‚€) + (TM.resetBinaryWorkTime 1 value.bits.length) := by + rintro inp work out ⟨hinp, hbranchResult, hout⟩ + obtain ⟨lookupWork, hlookupResult, hoperand, hpcResult, + hparked, hframe⟩ := hbranchResult + have hrun := TM.resetBinaryWorkTM_hoareTime_frame tapes.data.lhs + value.bits 1 inp work out hoperand.2.hasBinaryContent hoperand.1 + ⟨by rw [hoperand.2.1], by rw [hoperand.2.1]⟩ + (by simpa [hinp] using! hinput) + (fun i _ => hparked i) (by simpa [hout] using! houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, + hfinalInput.trans hinp, ?_, hfinalOutput.trans hout⟩ + rw [hfinalWork] + exact denseControlResult_of_zeroJumpReset tapes input overlay pcValue + source newPC initialWork work hready + ⟨lookupWork, hlookupResult, hoperand, hpcResult, hparked, hframe⟩ + have hbranchReset := TM.seqTM_hoareTime + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs) hbranch + (by + rintro inp work out ⟨hinp, hbranchResult, hout⟩ + obtain ⟨lookupWork, hlookupResult, hoperand, hpcResult, + hparked, hframe⟩ := hbranchResult + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, + ⟨lookupWork, hlookupResult, hoperand, hpcResult, hparked, hframe⟩, + hout⟩) + hreset + have hall := TM.seqTM_hoareTime + (denseOverlayLookupStaticTM tapes.data.lhsLookup source) + (TM.seqTM + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs)) hlookup + (by + rintro inp work out ⟨hinp, hlookupResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [inpβ‚€, hinp] using! hinput) hlookupResult.parked + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, hlookupResult, hout⟩) + hbranchReset + simpa [denseZeroJumpInstructionTM, denseZeroJumpInstructionTime, inpβ‚€, + value, newPC] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseCtrlSim.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseCtrlSim.lean new file mode 100644 index 0000000000..5f3add3637 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseCtrlSim.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseControl +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Control + +/-! +# Dense-overlay control-instruction simulation +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem denseInput_parked (input : List Bool) : + TM.Parked ((Tape.init (input.map Ξ“.ofBool)).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + simpa using Tape.init_ofBool_move_right_cells_ne_start input + +private theorem blankOutput_parked : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.init, Tape.move] + omega + +/-- Dense conditional-zero execution preserves the overlay and exposes the +generic buffered endpoint. -/ +theorem denseExecuteInstructionTM_jz_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue source target : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes (.jz source target)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input (.jz source target) + pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input (.jz source target) + pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + let newPC := if DenseOverlay.read input overlay source = 0 then target + else pcValue + 1 + have hcontrol := denseZeroJumpInstructionTM_hoareTime_frame tapes.lifted + input overlay pcValue source target initialWork outβ‚€ hvalid + hready.control blankOutput_parked + have hfinish := + finishBufferedControlInstructionTM_hoareTime_frame_internal tapes overlay + pcValue newPC initialWork inpβ‚€ outβ‚€ + (denseZeroJumpInstructionTM tapes.lifted source target) + (denseZeroJumpInstructionTime tapes.lifted input overlay pcValue source + target) + hready (denseInput_parked input) blankOutput_parked + (by simpa [inpβ‚€, newPC] using hcontrol) + have hcleanup : + denseInstructionCleanupValue input (.jz source target) overlay = + fun _ => 0 := by + funext slot + fin_cases slot <;> rfl + by_cases hzero : DenseOverlay.read input overlay source = 0 + Β· simpa [inpβ‚€, outβ‚€, newPC, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, hcleanup, + denseInstructionRemainingValue, DenseOverlay.Snapshot.stepInstr, + hzero] using hfinish + Β· simpa [inpβ‚€, outβ‚€, newPC, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, hcleanup, + denseInstructionRemainingValue, DenseOverlay.Snapshot.stepInstr, + hzero] using hfinish + +/-- Dense unconditional-jump execution preserves the overlay and exposes the +generic buffered endpoint. -/ +theorem denseExecuteInstructionTM_jmp_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue target : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes (.jmp target)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input (.jmp target) + pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input (.jmp target) + pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + have hcontrol := jumpInstructionTM_hoareTime_frame_internal tapes.lifted + overlay pcValue target initialWork inpβ‚€ outβ‚€ hready.control + (denseInput_parked input) blankOutput_parked + have hfinish := + finishBufferedControlInstructionTM_hoareTime_frame_internal tapes overlay + pcValue target initialWork inpβ‚€ outβ‚€ + (jumpInstructionTM tapes.lifted target) + (jumpInstructionTime pcValue target) hready (denseInput_parked input) + blankOutput_parked hcontrol + have hcleanup : denseInstructionCleanupValue input (.jmp target) overlay = + fun _ => 0 := by + funext slot + fin_cases slot <;> rfl + simpa [inpβ‚€, outβ‚€, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, hcleanup, + denseInstructionRemainingValue, + DenseOverlay.Snapshot.stepInstr] using hfinish + +/-- Dense halt execution preserves both the overlay and program counter and +exposes the generic buffered endpoint. -/ +theorem denseExecuteInstructionTM_halt_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes .halt).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input .halt pcValue overlay + work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input .halt pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + have hcontrol := haltInstructionTM_hoareTime_frame_internal tapes.lifted + overlay pcValue initialWork inpβ‚€ outβ‚€ hready.control + (denseInput_parked input) blankOutput_parked + have hfinish := + finishBufferedControlInstructionTM_hoareTime_frame_internal tapes overlay + pcValue pcValue initialWork inpβ‚€ outβ‚€ + (haltInstructionTM (n := n + 1)) haltInstructionTime hready + (denseInput_parked input) blankOutput_parked hcontrol + have hcleanup : denseInstructionCleanupValue input .halt overlay = + fun _ => 0 := by + funext slot + fin_cases slot <;> rfl + simpa [inpβ‚€, outβ‚€, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, hcleanup, + denseInstructionRemainingValue, + DenseOverlay.Snapshot.stepInstr] using hfinish + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDefs.lean new file mode 100644 index 0000000000..33da66557f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDefs.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.TaggedDefs + +/-! +# Dense-overlay RAM instruction kernels -- definitions + +These kernels retain the checked sparse scanner/update ABI while interpreting +the immutable public input in place. Reads use the dense-overlay lookup and +writes successor-tag their actual value before sparse update. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Arithmetic followed by positive tagging and sparse overlay update. -/ +def denseBinaryInstructionUpdateTM {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) : TM n := + TM.seqTM (binaryInstructionArithmeticTM tapes op) + (taggedEntryUpdateTM tapes.update) + +/-- Two direct dense-overlay reads, arithmetic, and a tagged destination write. -/ +def denseDirectBinaryInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (destination sourceβ‚€ source₁ : β„•) : TM n := + TM.seqTM + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup sourceβ‚€) + (denseOverlayLookupStaticTM tapes.rhsLookup source₁)) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (denseBinaryInstructionUpdateTM tapes op)) + +/-- Dense-overlay indirect read followed by a tagged direct destination write. -/ +def denseIndirectLoadInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) + (destination addressRegister : β„•) : TM n := + TM.seqTM + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupTM tapes.indirectLoadLookup)) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update)) + +/-- Immediate assignment with its value converted to a positive overlay tag. -/ +def denseImmediateInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) (destination value : β„•) : TM n := + TM.seqTM (TM.binaryAddConstTM tapes.update.replacement value) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update)) + +/-- Dense-overlay indirect destination/source reads followed by a tagged write. -/ +def denseIndirectStoreInstructionTM {n : β„•} + (tapes : BinaryInstructionTapes n) + (addressRegister source : β„•) : TM n := + TM.seqTM + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupStaticTM tapes.rhsLookup source)) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query + tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement + tapes.update.found) + (taggedEntryUpdateTM tapes.update))) + +/-- Conditional jump whose tested register is read through the dense overlay. -/ +def denseZeroJumpInstructionTM {n : β„•} + (tapes : ControlInstructionTapes n) (source target : β„•) : TM n := + TM.seqTM (denseOverlayLookupStaticTM tapes.data.lhsLookup source) + (TM.seqTM + (TM.branchWorkBlankTM tapes.data.lhs + (setProgramCounterTM tapes.pc target) + (TM.binarySuccTM tapes.pc)) + (TM.resetBinaryWorkTM tapes.data.lhs)) + +/-- Semantic endpoint of arithmetic and one tagged overlay update. -/ +def DenseBinaryInstructionUpdateResult {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (overlay : Store) (address lhs rhs : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ arithmeticWork : Fin n β†’ Tape, + BinaryInstructionArithmeticResult tapes op lhs rhs + initialWork arithmeticWork ∧ + TaggedEntryUpdateResult tapes.update overlay address (op.eval lhs rhs) + arithmeticWork finalWork + +/-- Boundary after two fixed-address dense-overlay reads. -/ +def DenseDirectBinaryOperandsResult {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ lhsWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay sourceβ‚€ + initialWork lhsWork ∧ + DenseOverlayLookupStaticResult tapes.rhsLookup input overlay source₁ + lhsWork finalWork + +/-- Boundary after dense operands and direct destination synthesis. -/ +def DenseDirectBinaryAddressResult {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ operandsWork, + DenseDirectBinaryOperandsResult tapes input overlay sourceβ‚€ source₁ + initialWork operandsWork ∧ + finalWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + +/-- Semantic endpoint of a complete dense direct arithmetic instruction. -/ +def DenseDirectBinaryInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (input : List Bool) (overlay : Store) + (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ updateWork, + DenseDirectBinaryAddressResult tapes input overlay destination sourceβ‚€ + source₁ initialWork updateWork ∧ + DenseBinaryInstructionUpdateResult tapes op overlay destination + (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) updateWork finalWork + +/-- Semantic endpoint of one dense immediate assignment. -/ +def DenseImmediateInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (overlay : Store) + (destination value : β„•) (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ valueWork updateWork, + valueWork = Function.update initialWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + updateWork = Function.update valueWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + TaggedEntryUpdateResult tapes.update overlay destination value updateWork + finalWork + +/-- Semantic endpoint of a complete dense indirect load. -/ +def DenseIndirectLoadInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (destination addressRegister : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ addressWork loadedWork updateWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork loadedWork ∧ + updateWork = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + TaggedEntryUpdateResult tapes.update overlay destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister)) + updateWork finalWork + +/-- Semantic endpoint of a complete dense indirect store. -/ +def DenseIndirectStoreInstructionResult {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop := + βˆƒ operandsWork queryWork updateWork, + DenseDirectBinaryOperandsResult tapes input overlay addressRegister source + initialWork operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init ((DenseOverlay.read input overlay addressRegister).bits.map + Ξ“.ofBool)).move Dir3.right) ∧ + updateWork = Function.update queryWork tapes.update.replacement + ((Tape.init ((DenseOverlay.read input overlay source).bits.map Ξ“.ofBool)).move + Dir3.right) ∧ + TaggedEntryUpdateResult tapes.update overlay + (DenseOverlay.read input overlay addressRegister) + (DenseOverlay.read input overlay source) updateWork finalWork + +/-- Runtime of arithmetic followed by positive tagging and overlay update. -/ +def denseBinaryInstructionUpdateTime {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (overlay : Store) (address lhs rhs : β„•) : β„• := + binaryInstructionArithmeticTime op lhs rhs + 1 + + taggedEntryUpdateTime tapes.update overlay address (op.eval lhs rhs) + +/-- Complete direct dense arithmetic-instruction budget. -/ +def denseDirectBinaryInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (input : List Bool) (overlay : Store) + (destination sourceβ‚€ source₁ : β„•) : β„• := + (denseOverlayLookupStaticTime tapes.lhsLookup input.length overlay sourceβ‚€ + 1 + + denseOverlayLookupStaticTime tapes.rhsLookup input.length overlay source₁) + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + denseBinaryInstructionUpdateTime tapes op overlay destination + (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁)) + +/-- Complete immediate dense assignment budget. -/ +def denseImmediateInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (overlay : Store) + (destination value : β„•) : β„• := + TM.binaryAddConstTime value 0 + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + taggedEntryUpdateTime tapes.update overlay destination value) + +/-- Complete dense indirect-load instruction budget. -/ +def denseIndirectLoadInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (destination addressRegister : β„•) : β„• := + (denseOverlayLookupStaticTime tapes.lhsLookup input.length overlay + addressRegister + 1 + + denseOverlayLookupTime tapes.indirectLoadLookup input.length overlay + (DenseOverlay.read input overlay addressRegister)) + 1 + + (TM.binaryAddConstTime destination 0 + 1 + + taggedEntryUpdateTime tapes.update overlay destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister))) + +/-- Complete dense indirect-store instruction budget. -/ +def denseIndirectStoreInstructionTime {n : β„•} + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) : β„• := + (denseOverlayLookupStaticTime tapes.lhsLookup input.length overlay + addressRegister + 1 + + denseOverlayLookupStaticTime tapes.rhsLookup input.length overlay source) + 1 + + (TM.binaryCopyTime (DenseOverlay.read input overlay addressRegister) 0 + 1 + + (TM.binaryCopyTime (DenseOverlay.read input overlay source) 0 + 1 + + taggedEntryUpdateTime tapes.update overlay + (DenseOverlay.read input overlay addressRegister) + (DenseOverlay.read input overlay source))) + +/-- Runtime for a conditional jump using one dense-overlay register read. -/ +def denseZeroJumpInstructionTime {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue source target : β„•) : β„• := + denseOverlayLookupStaticTime tapes.data.lhsLookup input.length overlay source + 1 + + (TM.branchWorkBlankTime (setProgramCounterTime pcValue target) + (TM.binarySuccTime pcValue) + 1 + + TM.resetBinaryWorkTime 1 + (DenseOverlay.read input overlay source).bits.length) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDirect.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDirect.lean new file mode 100644 index 0000000000..4f9ffb82cf --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDirect.lean @@ -0,0 +1,535 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Direct +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Tagged +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal + +/-! +# Dense-overlay direct arithmetic instructions +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem denseScanner_rhs_of_lhs + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlookup : DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + source initialWork finalWork) : + EntryScanReady tapes.rhsLookup.scan.entry (overlay.flatMap Entry.encode) [] + finalWork finalWork := by + exact + { source := hlookup.scanner.source + address := hlookup.scanner.address + addressStart := hlookup.scanner.addressStart + value := hlookup.scanner.value + valueStart := hlookup.scanner.valueStart + addressCounter := hlookup.scanner.addressCounter + addressWidth := hlookup.scanner.addressWidth + valueCounter := hlookup.scanner.valueCounter + valueWidth := hlookup.scanner.valueWidth + query := hlookup.scanner.query + queryStart := hlookup.scanner.queryStart + result := hlookup.scanner.result + resultStart := hlookup.scanner.resultStart + parked := hlookup.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + +private theorem denseRhsReady_of_lhs + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hrhs : (initialWork tapes.rhs).HasBinaryNat 0) + (hlookup : DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + source initialWork finalWork) : + EntryLookupStaticReady tapes.rhsLookup overlay finalWork := by + have hrhsEq : finalWork tapes.rhs = initialWork tapes.rhs := + hlookup.frame tapes.rhs (fun slot => (tapes.lhsLookup_ne_rhs slot).symm) + refine + { scanner := denseScanner_rhs_of_lhs tapes input overlay source initialWork + finalWork hlookup + sourceStart := hlookup.sourceStart + sourceHead := hlookup.sourceHead + count := by simpa using! hlookup.count + countSource := ?_ + querySource := by simpa using! hlookup.querySource + destination := by + change (finalWork tapes.rhs).HasBinaryNat 0 + rw [hrhsEq] + exact hrhs + copyScratch := by simpa using! hlookup.copyScratch } + change (finalWork tapes.update.resultCount).HasBinaryNat overlay.length + rw [show finalWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! hlookup.countSource] + simpa using! hinitial.countSource + +/-- Two fixed dense-overlay reads compose while retaining the shared scanner +ABI and the immutable input tape. -/ +theorem denseDirectBinaryOperands_hoareTime + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (sourceβ‚€ source₁ : β„•) + (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (houtput : TM.Parked outβ‚€) : + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup sourceβ‚€) + (denseOverlayLookupStaticTM tapes.rhsLookup source₁)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseDirectBinaryOperandsResult tapes input overlay sourceβ‚€ source₁ + initialWork work ∧ out = outβ‚€) + (denseOverlayLookupStaticTime tapes.lhsLookup input.length overlay + sourceβ‚€ + 1 + + denseOverlayLookupStaticTime tapes.rhsLookup input.length overlay + source₁) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlhs := denseOverlayLookupStaticTM_hoareTime_internal tapes.lhsLookup + input overlay sourceβ‚€ initialWork outβ‚€ hvalid hinitial houtput + have hrhs : (denseOverlayLookupStaticTM tapes.rhsLookup source₁).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay sourceβ‚€ + initialWork work ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryOperandsResult tapes input overlay sourceβ‚€ source₁ + initialWork work ∧ out = outβ‚€) + (denseOverlayLookupStaticTime tapes.rhsLookup input.length overlay + source₁) := by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + have hready := denseRhsReady_of_lhs tapes input overlay sourceβ‚€ initialWork + work hinitial hrhsβ‚€ hlhsResult + have hrun := denseOverlayLookupStaticTM_hoareTime_internal tapes.rhsLookup + input overlay source₁ work outβ‚€ hvalid hready houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hrhsResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, hlhsResult, hrhsResult⟩, hfinalOutput⟩ + have hall := TM.seqTM_hoareTime + (denseOverlayLookupStaticTM tapes.lhsLookup sourceβ‚€) + (denseOverlayLookupStaticTM tapes.rhsLookup source₁) hlhs + (by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [inpβ‚€, hinp] using! hinput) hlhsResult.parked + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, hlhsResult, hout⟩) + hrhs + simpa only [inpβ‚€] using! hall + +private theorem denseDirectAddress_ready + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (haddress : DenseDirectBinaryAddressResult tapes input overlay destination + sourceβ‚€ source₁ initialWork finalWork) : + EntryScanReady tapes.update.entry (overlay.flatMap Entry.encode) + destination.bits finalWork finalWork ∧ + (finalWork tapes.lhs).HasBinaryNat + (DenseOverlay.read input overlay sourceβ‚€) ∧ + (finalWork tapes.rhs).HasBinaryNat + (DenseOverlay.read input overlay source₁) ∧ + (finalWork tapes.update.replacement).HasBinaryNat 0 ∧ + (finalWork tapes.shift).HasBinaryNat 0 ∧ + (finalWork tapes.tmp).HasBinaryNat 0 ∧ + (finalWork tapes.dbl).HasBinaryNat 0 ∧ + (finalWork tapes.update.remaining).HasBinaryNat overlay.length ∧ + (finalWork tapes.update.found).HasBinaryNat 0 ∧ + (finalWork tapes.update.resultCount).HasBinaryNat overlay.length ∧ + βˆ€ i, TM.Parked (finalWork i) := by + rcases haddress with ⟨operandsWork, ⟨lhsWork, hlhs, hrhs⟩, rfl⟩ + have hlhsEq : operandsWork tapes.lhs = lhsWork tapes.lhs := + hrhs.frame tapes.lhs (fun slot => (tapes.rhsLookup_ne_lhs slot).symm) + have hreplacementEq : operandsWork tapes.update.replacement = + initialWork tapes.update.replacement := by + rw [hrhs.frame tapes.update.replacement + (fun slot => (tapes.rhsLookup_ne_replacement slot).symm)] + exact hlhs.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + have htmpEq : operandsWork tapes.tmp = initialWork tapes.tmp := by + rw [hrhs.frame tapes.tmp (fun slot => (tapes.rhsLookup_ne_tmp slot).symm)] + exact hlhs.frame tapes.tmp (fun slot => (tapes.lhsLookup_ne_tmp slot).symm) + have hdblEq : operandsWork tapes.dbl = initialWork tapes.dbl := by + rw [hrhs.frame tapes.dbl (fun slot => (tapes.rhsLookup_ne_dbl slot).symm)] + exact hlhs.frame tapes.dbl (fun slot => (tapes.lhsLookup_ne_dbl slot).symm) + have hresultCount : + (operandsWork tapes.update.resultCount).HasBinaryNat overlay.length := by + rw [show operandsWork tapes.update.resultCount = + lhsWork tapes.update.resultCount by simpa using! hrhs.countSource] + rw [show lhsWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! hlhs.countSource] + simpa using! hinitial.countSource + have hqueryNe (i : Fin n) (h : i β‰  tapes.update.entry.query) : + Function.update operandsWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) i = + operandsWork i := Function.update_of_ne h _ _ + have hscanner := scanner_updateQuery_internal tapes overlay destination + operandsWork hrhs.scanner + refine ⟨hscanner, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hscanner.parked⟩ + Β· rw [hqueryNe tapes.lhs (tapes.ne (by decide)), hlhsEq] + exact hlhs.destination + Β· rw [hqueryNe tapes.rhs (tapes.ne (by decide))] + exact hrhs.destination + Β· rw [hqueryNe tapes.update.replacement (tapes.update.ne (by decide)), + hreplacementEq] + exact hreplacement + Β· rw [hqueryNe tapes.shift ((tapes.update_ne_shift 7).symm)] + exact hrhs.querySource + Β· rw [hqueryNe tapes.tmp ((tapes.update_ne_tmp 7).symm), htmpEq] + exact htmp + Β· rw [hqueryNe tapes.dbl ((tapes.update_ne_dbl 7).symm), hdblEq] + exact hdbl + Β· rw [hqueryNe tapes.update.remaining (tapes.update.ne (by decide))] + exact hrhs.count + Β· rw [hqueryNe tapes.update.found (tapes.update.ne (by decide))] + exact hrhs.copyScratch + Β· rw [hqueryNe tapes.update.resultCount (tapes.update.ne (by decide))] + exact hresultCount + +private theorem denseArithmetic_update_ready + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (overlay : Store) (address lhs rhs : β„•) + (initialWork work : Fin n β†’ Tape) + (hready : EntryScanReady tapes.update.entry + (overlay.flatMap Entry.encode) address.bits initialWork initialWork) + (hremaining : + (initialWork tapes.update.remaining).HasBinaryNat overlay.length) + (hfound : (initialWork tapes.update.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.update.resultCount).HasBinaryNat overlay.length) + (harith : BinaryInstructionArithmeticResult tapes op lhs rhs + initialWork work) : + EntryScanReady tapes.update.entry (overlay.flatMap Entry.encode) + address.bits work work ∧ + (work tapes.update.remaining).HasBinaryNat overlay.length ∧ + (work tapes.update.found).HasBinaryNat 0 ∧ + (work tapes.update.resultCount).HasBinaryNat overlay.length := by + have hslotEq (slot : Fin 13) (hne : slot β‰  10) : + work (tapes.update.idx slot) = initialWork (tapes.update.idx slot) := + harith.frame (tapes.update.idx slot) + (tapes.update_ne_lhs slot) (tapes.update_ne_rhs slot) + (tapes.update.ne hne) (tapes.update_ne_shift slot) + (tapes.update_ne_tmp slot) (tapes.update_ne_dbl slot) + have hready' : EntryScanReady tapes.update.entry + (overlay.flatMap Entry.encode) address.bits work work := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := harith.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· change (work (tapes.update.idx 0)).HasBinarySuffix _ + rw [hslotEq 0 (by decide)] + exact hready.source + Β· change (work (tapes.update.idx 1)).HasBinaryPrefix [] + rw [hslotEq 1 (by decide)] + exact hready.address + Β· change (work (tapes.update.idx 1)).cells 0 = Ξ“.start + rw [hslotEq 1 (by decide)] + exact hready.addressStart + Β· change (work (tapes.update.idx 2)).HasBinaryPrefix [] + rw [hslotEq 2 (by decide)] + exact hready.value + Β· change (work (tapes.update.idx 2)).cells 0 = Ξ“.start + rw [hslotEq 2 (by decide)] + exact hready.valueStart + Β· change (work (tapes.update.idx 3)).HasBinaryNat 0 + rw [hslotEq 3 (by decide)] + exact hready.addressCounter + Β· change (work (tapes.update.idx 4)).HasBinaryNat 0 + rw [hslotEq 4 (by decide)] + exact hready.addressWidth + Β· change (work (tapes.update.idx 5)).HasBinaryNat 0 + rw [hslotEq 5 (by decide)] + exact hready.valueCounter + Β· change (work (tapes.update.idx 6)).HasBinaryNat 0 + rw [hslotEq 6 (by decide)] + exact hready.valueWidth + Β· change (work (tapes.update.idx 7)).HasBinaryString address.bits + rw [hslotEq 7 (by decide)] + exact hready.query + Β· change (work (tapes.update.idx 7)).cells 0 = Ξ“.start + rw [hslotEq 7 (by decide)] + exact hready.queryStart + Β· change (work (tapes.update.idx 8)).HasBinaryPrefix [] + rw [hslotEq 8 (by decide)] + exact hready.result + Β· change (work (tapes.update.idx 8)).cells 0 = Ξ“.start + rw [hslotEq 8 (by decide)] + exact hready.resultStart + refine ⟨hready', ?_, ?_, ?_⟩ + Β· change (work (tapes.update.idx 9)).HasBinaryNat _ + rw [hslotEq 9 (by decide)] + exact hremaining + Β· change (work (tapes.update.idx 11)).HasBinaryNat 0 + rw [hslotEq 11 (by decide)] + exact hfound + Β· change (work (tapes.update.idx 12)).HasBinaryNat _ + rw [hslotEq 12 (by decide)] + exact hresultCount + +/-- Arithmetic feeds its canonical result through successor tagging and into +the sparse overlay update controller. -/ +theorem denseBinaryInstructionUpdateTM_hoareTime_frame + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (overlay : Store) (address lhs rhs : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) (hcanonical : Canonical overlay) + (hready : EntryScanReady tapes.update.entry + (overlay.flatMap Entry.encode) address.bits initialWork initialWork) + (hlhs : (initialWork tapes.lhs).HasBinaryNat lhs) + (hrhs : (initialWork tapes.rhs).HasBinaryNat rhs) + (hresult : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hshift : (initialWork tapes.shift).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (hremaining : + (initialWork tapes.update.remaining).HasBinaryNat overlay.length) + (hfound : (initialWork tapes.update.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.update.resultCount).HasBinaryNat overlay.length) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (initialWork i)) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (denseBinaryInstructionUpdateTM tapes op).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseBinaryInstructionUpdateResult tapes op overlay address lhs rhs + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address (op.eval lhs rhs)).flatMap + Entry.encode)) + (denseBinaryInstructionUpdateTime tapes op overlay address lhs rhs) := by + have harithmetic := binaryInstructionArithmeticTM_hoareTime_frame_internal + tapes op lhs rhs inpβ‚€ initialWork outβ‚€ hlhs hrhs hresult hshift htmp hdbl + hinput hwork (hasBinaryPrefix_parked houtput) + have hupdate : (taggedEntryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseBinaryInstructionUpdateResult tapes op overlay address lhs rhs + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address (op.eval lhs rhs)).flatMap + Entry.encode)) + (taggedEntryUpdateTime tapes.update overlay address (op.eval lhs rhs)) := by + rintro inp work out ⟨hinp, harith, hout⟩ + have hready' := denseArithmetic_update_ready tapes op overlay address lhs + rhs initialWork work hready hremaining hfound hresultCount harith + have hrun := taggedEntryUpdateTM_hoareTime_frame tapes.update overlay + address (op.eval lhs rhs) emittedBits work inpβ‚€ outβ‚€ hcanonical + hready'.1 harith.result hready'.2.1 hready'.2.2.1 hready'.2.2.2 + hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + htagged, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, harith, htagged⟩, hfinalOutput⟩ + have hall := TM.seqTM_hoareTime (binaryInstructionArithmeticTM tapes op) + (taggedEntryUpdateTM tapes.update) harithmetic + (by + rintro inp work out ⟨hinp, harith, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) harith.parked + (by simpa [hout] using! hasBinaryPrefix_parked houtput) + rw [hi, hw, ho] + exact ⟨hinp, harith, hout⟩) + hupdate + simpa [denseBinaryInstructionUpdateTM, + denseBinaryInstructionUpdateTime] using! hall + +/-- Two dense reads, direct destination synthesis, arithmetic, successor +tagging, and sparse update implement one RAM arithmetic instruction. -/ +theorem denseDirectBinaryInstructionTM_hoareTime_frame + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (input : List Bool) (overlay : Store) + (destination sourceβ‚€ source₁ : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (denseDirectBinaryInstructionTM tapes op destination sourceβ‚€ source₁).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseDirectBinaryInstructionResult tapes op input overlay destination + sourceβ‚€ source₁ initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination + (op.eval (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁))).flatMap Entry.encode)) + (denseDirectBinaryInstructionTime tapes op input overlay destination + sourceβ‚€ source₁) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have houtputParked := hasBinaryPrefix_parked houtput + have hoperands := denseDirectBinaryOperands_hoareTime tapes input overlay + sourceβ‚€ source₁ initialWork outβ‚€ hvalid hinitial hrhsβ‚€ houtputParked + have haddress : (TM.binaryAddConstTM tapes.update.entry.query + destination).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryOperandsResult tapes input overlay sourceβ‚€ source₁ + initialWork work ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryAddressResult tapes input overlay destination sourceβ‚€ + source₁ initialWork work ∧ out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + rintro inp work out ⟨hinp, operands, hout⟩ + rcases operands with ⟨lhsWork, hlhsResult, hrhsResult⟩ + have hquery : (work tapes.update.entry.query).HasBinaryNat 0 := + ⟨hrhsResult.scanner.queryStart, by simpa using! hrhsResult.scanner.query⟩ + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inp work out hquery + (by simpa [hinp] using! hinput) + (fun i _ => hrhsResult.parked i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨work, ⟨lhsWork, hlhsResult, hrhsResult⟩, + by simpa only [zero_add] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hupdate : (denseBinaryInstructionUpdateTM tapes op).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryAddressResult tapes input overlay destination sourceβ‚€ + source₁ initialWork work ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryInstructionResult tapes op input overlay destination + sourceβ‚€ source₁ initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination + (op.eval (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁))).flatMap Entry.encode)) + (denseBinaryInstructionUpdateTime tapes op overlay destination + (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁)) := by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := denseDirectAddress_ready tapes input overlay destination + sourceβ‚€ source₁ initialWork work hinitial hreplacement htmp hdbl + haddressResult + rcases hready with ⟨hscanner, hlhs, hrhs, hrepl, hshift, htmp', hdbl', + hremaining, hfound, hresultCount, hparked⟩ + have hrun := denseBinaryInstructionUpdateTM_hoareTime_frame tapes op + overlay destination (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) emittedBits work inpβ‚€ outβ‚€ + hvalid.1 hscanner hlhs hrhs hrepl hshift htmp' hdbl' hremaining hfound + hresultCount hinput hparked houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hupdateResult, hfinalOutput⟩ := hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, haddressResult, hupdateResult⟩, hfinalOutput⟩ + have haddressUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (denseBinaryInstructionUpdateTM tapes op) haddress + (by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := denseDirectAddress_ready tapes input overlay destination + sourceβ‚€ source₁ initialWork work hinitial hreplacement htmp hdbl + haddressResult + rcases hready with ⟨_, _, _, _, _, _, _, _, _, _, hparked⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) + hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, haddressResult, hout⟩) + hupdate + have hall := TM.seqTM_hoareTime + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup sourceβ‚€) + (denseOverlayLookupStaticTM tapes.rhsLookup source₁)) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (denseBinaryInstructionUpdateTM tapes op)) hoperands + (by + rintro inp work out ⟨hinp, operands, hout⟩ + rcases operands with ⟨lhsWork, hlhsResult, hrhsResult⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hrhsResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨lhsWork, hlhsResult, hrhsResult⟩, hout⟩) + haddressUpdate + simpa [denseDirectBinaryInstructionTM, denseDirectBinaryInstructionTime, + inpβ‚€] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDispatch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDispatch.lean new file mode 100644 index 0000000000..5e1eb66f42 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseDispatch.lean @@ -0,0 +1,555 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Internal + +/-! +# Fixed-program dense-overlay dispatch +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem denseInput_parked (input : List Bool) : + TM.Parked ((Tape.init (input.map Ξ“.ofBool)).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + simpa using! Tape.init_ofBool_move_right_cells_ne_start input + +private theorem blankOutput_parked : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.init, Tape.move] + omega + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Dispatch's temporary selector update preserves parking of every work tape. -/ +private theorem denseDispatch_work_parked + {tapes : ControlInstructionTapes n} {overlay : Store} {pcValue selector : β„•} + {cleanWork workβ‚€ : Fin (n + 1) β†’ Tape} + (hready : DispatchReady tapes overlay pcValue selector cleanWork workβ‚€) : + βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + rw [hready.2] + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat selector) + Β· simp only [Function.update_of_ne hi] + exact hready.1.control.lookup.scanner.parked i + +/-- A zero dispatch selector leaves the clean work configuration unchanged. -/ +private theorem denseDispatch_zero_work + {tapes : ControlInstructionTapes n} {overlay : Store} {pcValue : β„•} + {cleanWork workβ‚€ : Fin (n + 1) β†’ Tape} + (hready : DispatchReady tapes overlay pcValue 0 cleanWork workβ‚€) : + workβ‚€ = cleanWork := by + have hcleanLhs := Tape.HasBinaryNat.eq_init_move_right + hready.1.control.lookup.destination + change cleanWork tapes.liftedLhs = + (Tape.init []).move Dir3.right at hcleanLhs + rw [hready.2] + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hcleanLhs.symm + Β· simp only [Function.update_of_ne hi] + +/-- An empty dense program clears the dispatch selector and executes the halt instruction. -/ +private theorem denseDispatchEmpty_hoareTime + (tapes : ControlInstructionTapes n) + (input : List Bool) (overlay : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : DispatchReady tapes overlay pcValue selector cleanWork workβ‚€) : + (denseDispatchProgramTM tapes ([] : Program)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = workβ‚€ ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (selectedInstruction ([] : Program) selector) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseDispatchProgramTime tapes input overlay pcValue ([] : Program) + selector) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have houtput : TM.Parked outβ‚€ := by + simpa only [outβ‚€] using! blankOutput_parked + let blankTape := (Tape.init []).move Dir3.right + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hcleanLhs : cleanWork tapes.liftedLhs = blankTape := by + have hzero := hready.1.control.lookup.destination + change (cleanWork tapes.liftedLhs).HasBinaryNat 0 at hzero + simpa only [blankTape] using! + Tape.HasBinaryNat.eq_init_move_right hzero + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := + denseDispatch_work_parked hready + have hreset := TM.resetBinaryWorkTM_hoareTime_frame tapes.liftedLhs + selector.bits 1 inpβ‚€ workβ‚€ outβ‚€ + hselector.2.hasBinaryContent hselector.1 + ⟨by rw [hselector.2.1], by rw [hselector.2.1]⟩ + hinput (fun i _ => hworkβ‚€Parked i) houtput + have hreset' : (TM.resetBinaryWorkTM tapes.liftedLhs).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ out = outβ‚€) + (TM.resetBinaryWorkTime 1 selector.bits.length) := by + apply hreset.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + refine ⟨hinp, ?_, hout⟩ + rw [hworkEq, hready.2, Function.update_idem] + change Function.update cleanWork tapes.liftedLhs blankTape = + cleanWork + rw [← hcleanLhs, Function.update_eq_self] + Β· exact le_rfl + have hhalt := denseExecuteInstructionTM_hoareTime_frame tapes input + .halt overlay pcValue cleanWork hvalid hready.1 + have hseq := TM.seqTM_hoareTime + (TM.resetBinaryWorkTM tapes.liftedLhs) + (denseExecuteInstructionTM tapes .halt) hreset' + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) + (by simpa [hworkEq] using! + hready.1.control.lookup.scanner.parked) + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, hworkEq, hout⟩) + hhalt + simpa only [denseDispatchProgramTM, dispatchWithTM, + denseDispatchProgramTime, dispatchWithTime, + selectedInstruction, inpβ‚€, outβ‚€] using! hseq + +/-- The decrementing branch tree selects the corresponding dense instruction, +including the out-of-range halt convention. -/ +theorem denseDispatchProgramTM_hoareTime_frame + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (overlay : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : DispatchReady tapes overlay pcValue selector cleanWork workβ‚€) : + (denseDispatchProgramTM tapes program).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = workβ‚€ ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (selectedInstruction program selector) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseDispatchProgramTime tapes input overlay pcValue program + selector) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have houtput : TM.Parked outβ‚€ := by + simpa only [outβ‚€] using! blankOutput_parked + induction program generalizing selector workβ‚€ with + | nil => + exact denseDispatchEmpty_hoareTime tapes input overlay pcValue selector + cleanWork workβ‚€ hvalid hready + | cons instruction program ih => + let pre : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€ + let post : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + DenseInstructionExecutionResult tapes input + (selectedInstruction (instruction :: program) selector) + pcValue overlay work ∧ + out = outβ‚€ + let blankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector = 0 + let nonblankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector β‰  0 + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := + denseDispatch_work_parked hready + have hblank : (denseExecuteInstructionTM tapes instruction).HoareTime + blankPre post + (denseExecuteInstructionTime tapes input instruction pcValue + overlay) := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hzero⟩ + subst selector + have hworkClean : work = cleanWork := + hworkEq.trans (denseDispatch_zero_work hready) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hresult, hfinalOutput⟩ := + denseExecuteInstructionTM_hoareTime_frame tapes input instruction + overlay pcValue cleanWork hvalid hready.1 inp cleanWork out + ⟨hinp, rfl, hout⟩ + refine ⟨final, time, htime, ?_, hhalt, hfinalInput, ?_, + hfinalOutput⟩ + Β· simpa [hworkClean] using! hreach + Β· simpa only [selectedInstruction] using! hresult + have hnonblank : + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (denseDispatchProgramTM tapes program)).HoareTime + nonblankPre post + (TM.binaryPredTime (selector - 1) + 1 + + denseDispatchProgramTime tapes input overlay pcValue program + (selector - 1)) := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hnonzero⟩ + have hsucc : selector = (selector - 1) + 1 := by omega + have hvalue : (work tapes.liftedLhs).HasBinaryNat + ((selector - 1) + 1) := by + rw [hworkEq] + rw [hsucc] at hselector + exact hselector + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [hout] using! houtput + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + simpa [hworkEq] using! hworkβ‚€Parked i + have hpred := TM.binaryPredTM_hoareTime_frame tapes.liftedLhs + (selector - 1) inp work out hvalue hinpParked.read_ne_start + (fun i _ => (hworkParked i).read_ne_start) + houtParked.read_ne_start + let nextWork := Function.update cleanWork tapes.liftedLhs + ((Tape.init ((selector - 1).bits.map Ξ“.ofBool)).move Dir3.right) + have hpred' : (TM.binaryPredTM tapes.liftedLhs).HoareTime + (fun inp' work' out' => + inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => + inp' = inp ∧ work' = nextWork ∧ out' = out) + (TM.binaryPredTime (selector - 1)) := by + apply hpred.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp' work' out' ⟨hinp', hframe, hvalue', hout'⟩ + refine ⟨hinp', ?_, hout'⟩ + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact Tape.HasBinaryNat.eq_init_move_right hvalue' + Β· simp only [nextWork, Function.update_of_ne hi] + rw [hframe i hi, hworkEq, hready.2, + Function.update_of_ne hi] + Β· exact le_rfl + have hnextReady : DispatchReady tapes overlay pcValue + (selector - 1) cleanWork nextWork := ⟨hready.1, rfl⟩ + have hrecursive := ih (selector - 1) nextWork hnextReady + have hrecursive' : + (denseDispatchProgramTM tapes program).HoareTime + (fun inp' work' out' => + inp' = inp ∧ work' = nextWork ∧ out' = out) + post + (denseDispatchProgramTime tapes input overlay pcValue program + (selector - 1)) := by + apply hrecursive.consequence + Β· rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + exact ⟨hinp'.trans hinp, hwork', hout'.trans hout⟩ + Β· rintro inp' work' out' ⟨hinp', hresult, hout'⟩ + have hselected : + selectedInstruction (instruction :: program) selector = + selectedInstruction program (selector - 1) := by + rw [hsucc] + rfl + exact ⟨hinp', by simpa only [hselected] using! hresult, hout'⟩ + Β· exact le_rfl + have hseq := TM.seqTM_hoareTime + (TM.binaryPredTM tapes.liftedLhs) + (denseDispatchProgramTM tapes program) hpred' + (by + rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp') (work := work') (out := out') + (by simpa [hinp', hinp] using! hinput) + (by + intro i + rw [hwork'] + by_cases hidx : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat (selector - 1)) + Β· simp only [nextWork, Function.update_of_ne hidx] + exact hready.1.control.lookup.scanner.parked i) + (by simpa [hout', hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp', hwork', hout'⟩) + hrecursive' + exact hseq inp work out ⟨rfl, rfl, rfl⟩ + by_cases hzero : selector = 0 + Β· subst selector + intro inp work out hpre + obtain ⟨branchDone, time, htime, hreach, hhalt, hpost⟩ := + hblank inp work out ⟨hpre, rfl⟩ + have hread : (work tapes.liftedLhs).read = Ξ“.blank := by + rw [hpre.2.1] + exact hselector.read_eq_blank_iff.mpr rfl + have hinpRead : inp.read β‰  Ξ“.start := by + simpa [hpre.1] using! hinput.read_ne_start + have hworkRead : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + simpa [hpre.2.1] using! (hworkβ‚€Parked i).read_ne_start + have houtRead : out.read β‰  Ξ“.start := by + simp [hpre.2.2] + obtain ⟨done, hreach', hhalt', hdoneInput, hdoneWork, + hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_blank_frame tapes.liftedLhs + (denseExecuteInstructionTM tapes instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (denseDispatchProgramTM tapes program)) + inp work out hread hinpRead hworkRead houtRead hreach hhalt + refine ⟨done, time + 1, ?_, ?_, hhalt', ?_⟩ + Β· simpa only [denseDispatchProgramTime, dispatchWithTime] using! + Nat.add_le_add_right htime 1 + Β· simpa only [denseDispatchProgramTM, dispatchWithTM] using! hreach' + Β· rw [hdoneInput, hdoneWork, hdoneOutput] + exact hpost + Β· intro inp work out hpre + obtain ⟨branchDone, time, htime, hreach, hhalt, hpost⟩ := + hnonblank inp work out ⟨hpre, hzero⟩ + have hread : (work tapes.liftedLhs).read β‰  Ξ“.blank := by + intro hblankRead + apply hzero + exact hselector.read_eq_blank_iff.mp (by + simpa [hpre.2.1] using! hblankRead) + have hinpRead : inp.read β‰  Ξ“.start := by + simpa [hpre.1] using! hinput.read_ne_start + have hworkRead : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + simpa [hpre.2.1] using! (hworkβ‚€Parked i).read_ne_start + have houtRead : out.read β‰  Ξ“.start := by + simp [hpre.2.2] + obtain ⟨done, hreach', hhalt', hdoneInput, hdoneWork, + hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_nonblank_frame tapes.liftedLhs + (denseExecuteInstructionTM tapes instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (denseDispatchProgramTM tapes program)) + inp work out hread hinpRead hworkRead houtRead hreach hhalt + refine ⟨done, time + 1, ?_, ?_, hhalt', ?_⟩ + Β· rw [show selector = selector - 1 + 1 by omega] + simpa only [denseDispatchProgramTime, dispatchWithTime] using! + Nat.add_le_add_right htime 1 + Β· simpa only [denseDispatchProgramTM, dispatchWithTM] using! hreach' + Β· rw [hdoneInput, hdoneWork, hdoneOutput] + exact hpost + +/-- Copy the canonical PC into dispatch scratch and execute the selected dense +instruction. -/ +theorem denseProgramInstructionTM_hoareTime_frame + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseProgramInstructionTM tapes program).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (selectedInstruction program pcValue) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseProgramInstructionTime tapes program input pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let outβ‚€ := (Tape.init []).move Dir3.right + let selectorTape := + (Tape.init (pcValue.bits.map Ξ“.ofBool)).move Dir3.right + let selectorWork := + Function.update initialWork tapes.liftedLhs selectorTape + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have houtput : TM.Parked outβ‚€ := by + simpa only [outβ‚€] using! blankOutput_parked + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame tapes.liftedPC + tapes.liftedLhs tapes.liftedFound tapes.lifted.pc_ne_lhs + (tapes.lifted.pc_ne 11) (tapes.lifted.data.ne (by decide)) pcValue 0 + inpβ‚€ initialWork outβ‚€ hready.control.pc + hready.control.lookup.destination hready.control.lookup.copyScratch + hinput (fun i _ _ _ => hready.control.lookup.scanner.parked i) houtput + have hselectorReady : DispatchReady tapes overlay pcValue pcValue + initialWork selectorWork := ⟨hready, rfl⟩ + have hdispatch := denseDispatchProgramTM_hoareTime_frame tapes program + input overlay pcValue pcValue initialWork selectorWork hvalid + hselectorReady + have hselectorParked : βˆ€ i, TM.Parked (selectorWork i) := by + intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [selectorWork, Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat pcValue) + Β· simp only [selectorWork, Function.update_of_ne hi] + exact hready.control.lookup.scanner.parked i + have hseq := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (denseDispatchProgramTM tapes program) hcopy + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [hout] using! houtput + have hworkParked : βˆ€ i, TM.Parked (work i) := by + simpa [hworkEq, selectorWork, selectorTape] using! hselectorParked + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + hinpParked hworkParked houtParked + rw [hi, hw, ho] + exact ⟨hinp, by simpa [selectorWork, selectorTape] using! hworkEq, + hout⟩) + hdispatch + simpa only [denseProgramInstructionTM, denseProgramInstructionTime, + selectorWork, selectorTape, inpβ‚€, outβ‚€] using! hseq + +/-- One fixed-program dense RAM step returns to the reusable clean ABI for the +exact successor overlay snapshot. -/ +theorem denseProgramStepTM_hoareTime_frame + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseProgramStepTM tapes program).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + InstructionExecutionReady tapes + (denseInstructionStore input + (selectedInstruction program pcValue) pcValue overlay) + (denseInstructionPC input + (selectedInstruction program pcValue) pcValue overlay) + work ∧ + out = (Tape.init []).move Dir3.right) + (denseProgramStepTime tapes program input pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let blank := (Tape.init []).move Dir3.right + let instruction := selectedInstruction program pcValue + let nextStore := denseInstructionStore input instruction pcValue overlay + let nextPC := denseInstructionPC input instruction pcValue overlay + let cleanupValues := + denseInstructionCleanupValue input instruction overlay + let remainingValue := denseInstructionRemainingValue instruction overlay + let sourceBound := + denseProgramStepSourceHeadBound tapes program input pcValue overlay + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have hprogram := denseProgramInstructionTM_hoareTime_frame tapes program + input overlay pcValue initialWork hvalid hready + have hprogramCleanup : + (denseProgramInstructionTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = blank) + (fun inp work out => + inp = inpβ‚€ ∧ + BufferedCleanupReady tapes overlay nextStore nextPC cleanupValues + remainingValue sourceBound work ∧ + out = blank) + (denseProgramInstructionTime tapes program input pcValue + overlay) := by + intro inp work out hpre + obtain ⟨c, time, htime, hreach, hhalt, hinp, hresult, hout⟩ := + hprogram inp work out (by simpa [inpβ‚€, blank] using! hpre) + have hsourceStartβ‚€ : + (work tapes.liftedSource).cells 0 = Ξ“.start := by + simpa [hpre.2.1] using! hready.control.lookup.sourceStart + have hsourceStart := TM.work_cells_zero_eq_start_of_reachesIn + tapes.liftedSource hreach hsourceStartβ‚€ + have hbufferStartβ‚€ : + (work tapes.buffer).cells 0 = Ξ“.start := by + rw [hpre.2.1, hready.buffer] + simp [Tape.move, Tape.init] + have hbufferStart := TM.work_cells_zero_eq_start_of_reachesIn + tapes.buffer hreach hbufferStartβ‚€ + have hsourceHead := + (denseProgramInstructionTM tapes program).work_head_reachesIn_bound + hreach tapes.liftedSource + refine ⟨c, time, htime, hreach, hhalt, hinp, ?_, hout⟩ + refine + { nextCanonical := ?_ + result := ?_ + sourceStart := hsourceStart + bufferStart := hbufferStart + sourceHead := ?_ } + Β· simpa [nextStore, denseInstructionStore, instruction] using! + DenseOverlay.Snapshot.stepInstr_canonical input instruction + { pc := pcValue, overlay := overlay } hvalid.1 + Β· simpa only [instruction, nextStore, nextPC, cleanupValues, + remainingValue] using! hresult + Β· have hsourceHeadβ‚€ : (work tapes.liftedSource).head = 1 := by + simpa [hpre.2.1] using! hready.control.lookup.sourceHead + rw [hsourceHeadβ‚€] at hsourceHead + simp only [sourceBound, denseProgramStepSourceHeadBound] + omega + have hcleanup : + (instructionCleanupTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + BufferedCleanupReady tapes overlay nextStore nextPC cleanupValues + remainingValue sourceBound work ∧ + out = blank) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes nextStore nextPC work ∧ + out = blank) + (bufferedCleanupTime tapes overlay nextStore cleanupValues + remainingValue sourceBound) := by + intro inp work out hpre + have hcleanupWork := bufferedCleanupTM_hoareTime_frame_internal tapes + overlay nextStore nextPC cleanupValues remainingValue sourceBound work + inpβ‚€ blank hpre.2.1 hinput blankOutput_parked + exact hcleanupWork inp work out ⟨hpre.1, rfl, hpre.2.2⟩ + have hseq := TM.seqTM_hoareTime + (denseProgramInstructionTM tapes program) (instructionCleanupTM tapes) + hprogramCleanup + (by + rintro inp work out ⟨hinp, hcleanupReady, hout⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by + simpa [hout, blank] using! blankOutput_parked + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked hinpParked + hcleanupReady.result.parked houtParked + rw [hi, hw, ho] + exact ⟨hinp, hcleanupReady, hout⟩) + hcleanup + simpa only [denseProgramStepTM, denseProgramStepTime, instruction, + nextStore, nextPC, cleanupValues, remainingValue, sourceBound, inpβ‚€, + blank] using! hseq + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseImm.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseImm.lean new file mode 100644 index 0000000000..7f8ee2bc12 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseImm.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Immediate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Tagged + +/-! +# Dense-overlay immediate instruction +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Exact semantic and time contract for one immediate dense-overlay write. -/ +theorem denseImmediateInstructionTM_hoareTime_frame + (tapes : BinaryInstructionTapes n) (overlay : Store) + (destination value : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (denseImmediateInstructionTM tapes destination value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseImmediateInstructionResult tapes overlay destination value + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination value).flatMap Entry.encode)) + (denseImmediateInstructionTime tapes overlay destination value) := by + let valueWork := Function.update initialWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update valueWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have houtputParked := hasBinaryPrefix_parked houtput + have hvalue := TM.binaryAddConstTM_hoareTime_frame + tapes.update.replacement value 0 inpβ‚€ initialWork outβ‚€ hreplacement + hinput (fun i _ => hinitial.scanner.parked i) houtputParked + have hvalue' : (TM.binaryAddConstTM tapes.update.replacement value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = valueWork ∧ out = outβ‚€) + (TM.binaryAddConstTime value 0) := by + simpa only [valueWork, zero_add] using! hvalue + have hquery : (TM.binaryAddConstTM tapes.update.entry.query + destination).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = valueWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = updateWork ∧ out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + have hqueryZero : (valueWork tapes.update.entry.query).HasBinaryNat 0 := by + have hqueryReplacement : + tapes.update.entry.query β‰  tapes.update.replacement := + tapes.update.ne (by decide) + rw [show valueWork tapes.update.entry.query = + initialWork tapes.update.entry.query by + exact Function.update_of_ne hqueryReplacement _ initialWork] + exact ⟨hinitial.scanner.queryStart, by simpa using! hinitial.scanner.query⟩ + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inpβ‚€ valueWork outβ‚€ hqueryZero + hinput + (fun i _ => by + by_cases hi : i = tapes.update.replacement + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat value + simpa only [valueWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], + hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [valueWork, Function.update_of_ne hi] using! + hinitial.scanner.parked i) + houtputParked + simpa only [updateWork, zero_add] using! hrun + have hready := immediateUpdate_ready_internal tapes overlay destination value + initialWork hinitial + have hupdate := taggedEntryUpdateTM_hoareTime_frame tapes.update overlay + destination value emittedBits updateWork inpβ‚€ outβ‚€ hcanonical hready.1 + hready.2.1 hready.2.2.1 hready.2.2.2.1 hready.2.2.2.2.1 hinput houtput + have hupdate' : (taggedEntryUpdateTM tapes.update).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = updateWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseImmediateInstructionResult tapes overlay destination value + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination value).flatMap Entry.encode)) + (taggedEntryUpdateTime tapes.update overlay destination value) := + hupdate.strengthen_post (by + rintro inp work out ⟨hinp, houtcome, hout⟩ + exact ⟨hinp, ⟨valueWork, updateWork, rfl, rfl, houtcome⟩, hout⟩) + have hqueryUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update) hquery + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := updateWork) (out := out) + (by simpa [hinp] using! hinput) hready.2.2.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hupdate' + have hall := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.replacement value) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update)) hvalue' + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + have hparked : βˆ€ i, TM.Parked (valueWork i) := by + intro i + by_cases hi : i = tapes.update.replacement + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat value + simpa only [valueWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [valueWork, Function.update_of_ne hi] using! + hinitial.scanner.parked i + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := valueWork) (out := out) + (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hqueryUpdate + simpa [denseImmediateInstructionTM, denseImmediateInstructionTime] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseLoad.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseLoad.lean new file mode 100644 index 0000000000..62955529c5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseLoad.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Tagged +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal + +/-! +# Dense-overlay indirect load +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem denseScanner_indirect_of_lhs + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlookup : DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + source initialWork finalWork) : + EntryScanReady tapes.indirectLoadLookup.scan.entry + (overlay.flatMap Entry.encode) [] finalWork finalWork := + { source := hlookup.scanner.source + address := hlookup.scanner.address + addressStart := hlookup.scanner.addressStart + value := hlookup.scanner.value + valueStart := hlookup.scanner.valueStart + addressCounter := hlookup.scanner.addressCounter + addressWidth := hlookup.scanner.addressWidth + valueCounter := hlookup.scanner.valueCounter + valueWidth := hlookup.scanner.valueWidth + query := hlookup.scanner.query + queryStart := hlookup.scanner.queryStart + result := hlookup.scanner.result + resultStart := hlookup.scanner.resultStart + parked := hlookup.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + +private theorem denseIndirectLoaded_ready + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister : β„•) + (initialWork addressWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (haddress : DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork) : + EntryLookupRestoreReady tapes.indirectLoadLookup overlay + (DenseOverlay.read input overlay addressRegister) addressWork := by + have hreplacementEq : addressWork tapes.update.replacement = + initialWork tapes.update.replacement := + haddress.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + have hcountSource : + (addressWork tapes.update.resultCount).HasBinaryNat overlay.length := by + rw [show addressWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! haddress.countSource] + simpa using! hinitial.countSource + refine + { scanner := denseScanner_indirect_of_lhs tapes input overlay + addressRegister initialWork addressWork haddress + sourceStart := haddress.sourceStart + sourceHead := haddress.sourceHead + count := by simpa using! haddress.count + countSource := by simpa using! hcountSource + querySource := by simpa using! haddress.destination + destination := ?_ + copyScratch := by simpa using! haddress.copyScratch } + change (addressWork tapes.update.replacement).HasBinaryNat 0 + rw [hreplacementEq] + exact hreplacement + +/-- One static dense-overlay address read followed by a loaded dense-overlay +read leaves the indirect value in the update replacement tape. -/ +private theorem denseIndirectReads_hoareTime + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister : β„•) + (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (houtput : TM.Parked outβ‚€) : + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupTM tapes.indirectLoadLookup)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + (βˆƒ addressWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork work) ∧ + out = outβ‚€) + (denseOverlayLookupStaticTime tapes.lhsLookup input.length overlay + addressRegister + 1 + + denseOverlayLookupTime tapes.indirectLoadLookup input.length overlay + (DenseOverlay.read input overlay addressRegister)) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have haddress := denseOverlayLookupStaticTM_hoareTime_internal + tapes.lhsLookup input overlay addressRegister initialWork outβ‚€ hvalid + hinitial houtput + have hloaded : (denseOverlayLookupTM tapes.indirectLoadLookup).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork work ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork work) ∧ + out = outβ‚€) + (denseOverlayLookupTime tapes.indirectLoadLookup input.length overlay + (DenseOverlay.read input overlay addressRegister)) := by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := denseIndirectLoaded_ready tapes input overlay addressRegister + initialWork work hinitial hreplacement haddressResult + have hrun := denseOverlayLookupTM_hoareTime_internal + tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) work outβ‚€ hvalid hready + houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hloadedResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, haddressResult, hloadedResult⟩, hfinalOutput⟩ + have hall := TM.seqTM_hoareTime + (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupTM tapes.indirectLoadLookup) haddress + (by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [inpβ‚€, hinp] using! hinput) haddressResult.parked + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, haddressResult, hout⟩) + hloaded + simpa only [inpβ‚€] using! hall + +/-- Exact semantic and time contract for one dense-overlay indirect load. -/ +theorem denseIndirectLoadInstructionTM_hoareTime_frame + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (destination addressRegister : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (denseIndirectLoadInstructionTM tapes destination addressRegister).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseIndirectLoadInstructionResult tapes input overlay destination + addressRegister initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister))).flatMap + Entry.encode)) + (denseIndirectLoadInstructionTime tapes input overlay destination + addressRegister) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have houtputParked := hasBinaryPrefix_parked houtput + have hreads := denseIndirectReads_hoareTime tapes input overlay + addressRegister initialWork outβ‚€ hvalid hinitial hreplacement houtputParked + have hquery : (TM.binaryAddConstTM tapes.update.entry.query + destination).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork work) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork loadedWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork + loadedWork ∧ + work = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + rintro inp work out ⟨hinp, ⟨addressWork, haddressResult, + hloadedResult⟩, hout⟩ + have hqueryZero : (work tapes.update.entry.query).HasBinaryNat 0 := + ⟨hloadedResult.scanner.queryStart, by + simpa using! hloadedResult.scanner.query⟩ + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inp work out hqueryZero + (by simpa [hinp] using! hinput) + (fun i _ => hloadedResult.parked i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨addressWork, work, haddressResult, hloadedResult, + by simpa only [zero_add] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hupdate : (taggedEntryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork loadedWork, + DenseOverlayLookupStaticResult tapes.lhsLookup input overlay + addressRegister initialWork addressWork ∧ + DenseOverlayLookupResult tapes.indirectLoadLookup input overlay + (DenseOverlay.read input overlay addressRegister) addressWork + loadedWork ∧ + work = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseIndirectLoadInstructionResult tapes input overlay destination + addressRegister initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister))).flatMap + Entry.encode)) + (taggedEntryUpdateTime tapes.update overlay destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister))) := by + rintro inp work out ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, hwork⟩, hout⟩ + subst work + let updateWork := Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have hscanner := scanner_updateQuery_of_indirect_internal tapes overlay + destination loadedWork hloadedResult.scanner + have hreplacementNe : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hremainingNe : tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundNe : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCountNe : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCount : + (loadedWork tapes.update.resultCount).HasBinaryNat overlay.length := by + rw [show loadedWork tapes.update.resultCount = + addressWork tapes.update.resultCount by + simpa using! hloadedResult.countSource] + rw [show addressWork tapes.update.resultCount = + initialWork tapes.update.resultCount by + simpa using! haddressResult.countSource] + simpa using! hinitial.countSource + have hrun := taggedEntryUpdateTM_hoareTime_frame tapes.update overlay + destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister)) + emittedBits updateWork inpβ‚€ outβ‚€ hvalid.1 hscanner + (by simpa only [updateWork, Function.update_of_ne hreplacementNe] using! + hloadedResult.value) + (by simpa only [updateWork, Function.update_of_ne hremainingNe] using! + hloadedResult.count) + (by simpa only [updateWork, Function.update_of_ne hfoundNe] using! + hloadedResult.copyScratch) + (by simpa only [updateWork, Function.update_of_ne hresultCountNe] using! + hresultCount) + hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hupdateResult, hfinalOutput⟩ := + hrun inp updateWork out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨addressWork, loadedWork, updateWork, haddressResult, hloadedResult, + rfl, hupdateResult⟩, hfinalOutput⟩ + have hqueryUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update) hquery + (by + rintro inp work out ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, hwork⟩, hout⟩ + subst work + have hparked := (scanner_updateQuery_of_indirect_internal tapes overlay + destination loadedWork hloadedResult.scanner).parked + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) + (work := Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, rfl⟩, hout⟩) + hupdate + have hall := TM.seqTM_hoareTime + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupTM tapes.indirectLoadLookup)) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (taggedEntryUpdateTM tapes.update)) hreads + (by + rintro inp work out ⟨hinp, ⟨addressWork, haddressResult, + hloadedResult⟩, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hloadedResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨addressWork, haddressResult, hloadedResult⟩, hout⟩) + hqueryUpdate + simpa [denseIndirectLoadInstructionTM, denseIndirectLoadInstructionTime, + inpβ‚€] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSim.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSim.lean new file mode 100644 index 0000000000..07e7751806 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSim.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseCtrlSim +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimData + +/-! +# Dense-overlay instruction simulation +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Every statically selected RAM instruction realizes the common dense +buffered snapshot-step contract. -/ +theorem denseExecuteInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) + (instruction : Instr) (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes instruction).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input instruction pcValue + overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input instruction pcValue + overlay) := by + cases instruction with + | imm destination value => + exact denseExecuteInstructionTM_imm_hoareTime_frame tapes input overlay + pcValue destination value initialWork hvalid hready + | add destination sourceβ‚€ source₁ => + exact denseExecuteInstructionTM_add_hoareTime_frame tapes input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + | sub destination sourceβ‚€ source₁ => + exact denseExecuteInstructionTM_sub_hoareTime_frame tapes input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + | mul destination sourceβ‚€ source₁ => + exact denseExecuteInstructionTM_mul_hoareTime_frame tapes input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + | load destination addressRegister => + exact denseExecuteInstructionTM_load_hoareTime_frame tapes input overlay + pcValue destination addressRegister initialWork hvalid hready + | store addressRegister source => + exact denseExecuteInstructionTM_store_hoareTime_frame tapes input overlay + pcValue addressRegister source initialWork hvalid hready + | jz source target => + exact denseExecuteInstructionTM_jz_hoareTime_frame tapes input overlay + pcValue source target initialWork hvalid hready + | jmp target => + exact denseExecuteInstructionTM_jmp_hoareTime_frame tapes input overlay + pcValue target initialWork hready + | halt => + exact denseExecuteInstructionTM_halt_hoareTime_frame tapes input overlay + pcValue initialWork hready + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimData.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimData.lean new file mode 100644 index 0000000000..cf573f8354 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimData.lean @@ -0,0 +1,1020 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Data +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseImm +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseLoad +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseStore + +/-! +# Dense-overlay data-instruction simulation +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +/-- A dense immediate write produces the generic buffered endpoint and advances +the program counter. -/ +theorem denseExecuteInstructionTM_imm_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue destination value : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes (.imm destination value)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input (.imm destination value) + pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input (.imm destination value) + pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let nextStore := DenseOverlay.write overlay destination value + let cleanupValues := + denseInstructionCleanupValue input (.imm destination value) overlay + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup overlay + baseWork := + instructionExecutionReady_baseLookup_internal tapes overlay pcValue + initialWork hready + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := denseImmediateInstructionTM_hoareTime_frame tapes.data + overlay destination value [] baseWork inpβ‚€ (initialWork tapes.buffer) + hvalid.1 hlookup hreplacement hinput hbuffer + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + DenseImmediateInstructionResult tapes.data overlay destination value + baseWork work + have hbase : (denseImmediateInstructionTM tapes.data destination value).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = baseWork ∧ out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix (nextStore.flatMap Entry.encode)) + (denseImmediateInstructionTime tapes.data overlay destination value) := by + simpa [Result, nextStore] using! hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat nextStore.length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat 0 ∧ + EntryScanReady tapes.data.update.entry [] (cleanupValues 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨valueWork, updateWork, hvalueWork, hupdateWork, + taggedWork, htagValue, htagFrame, houtcome, hsourceCells⟩ := hsemantic + have hpc : work tapes.pc = baseWork tapes.pc := by + have hpcQuery : + tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcReplacement : + tapes.pc β‰  tapes.data.update.replacement := tapes.pc_ne 10 + calc + work tapes.pc = taggedWork tapes.pc := + houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + _ = updateWork tapes.pc := + htagFrame tapes.pc (tapes.pc_ne 10) + _ = valueWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + _ = baseWork tapes.pc := by + rw [hvalueWork, Function.update_of_ne hpcReplacement] + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) := by + have hcells : (work tapes.data.update.entry.source).cells = + (baseWork tapes.data.update.entry.source).cells := by + calc + (work tapes.data.update.entry.source).cells = + (updateWork tapes.data.update.entry.source).cells := hsourceCells + _ = (valueWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + _ = (baseWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + unfold Tape.HasBinaryContent + rw [hcells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat (value + 1) + rw [houtcome.replacement] + exact htagValue + Β· simpa [cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat 0 + rw [houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + htagFrame tapes.data.lhs + (tapes.data.update_ne_lhs 10).symm, + show updateWork tapes.data.lhs = valueWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _, + show valueWork tapes.data.lhs = baseWork tapes.data.lhs by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 10).symm _ _] + exact hready.control.lookup.destination + Β· change (work tapes.data.rhs).HasBinaryNat 0 + rw [houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + htagFrame tapes.data.rhs + (tapes.data.update_ne_rhs 10).symm, + show updateWork tapes.data.rhs = valueWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _, + show valueWork tapes.data.rhs = baseWork tapes.data.rhs by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 10).symm _ _] + exact hready.rhs + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + htagFrame tapes.data.shift (tapes.data.update_ne_shift 10).symm, + show updateWork tapes.data.shift = valueWork tapes.data.shift by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_shift 7).symm _ _, + show valueWork tapes.data.shift = baseWork tapes.data.shift by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_shift 10).symm _ _] + exact hready.control.lookup.querySource + have htmp : (work tapes.data.tmp).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + htagFrame tapes.data.tmp (tapes.data.update_ne_tmp 10).symm, + show updateWork tapes.data.tmp = valueWork tapes.data.tmp by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_tmp 7).symm _ _, + show valueWork tapes.data.tmp = baseWork tapes.data.tmp by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_tmp 10).symm _ _] + exact hready.tmp + have hdbl : (work tapes.data.dbl).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + htagFrame tapes.data.dbl (tapes.data.update_ne_dbl 10).symm, + show updateWork tapes.data.dbl = valueWork tapes.data.dbl by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_dbl 7).symm _ _, + show valueWork tapes.data.dbl = baseWork tapes.data.dbl by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_dbl 10).symm _ _] + exact hready.dbl + refine ⟨hpc, ?_, hsourceContent, hcleanup, ?_, ?_, hshift, htmp, + hdbl, houtcome.ready.parked⟩ + Β· simpa [nextStore] using! houtcome.resultCount + Β· simpa using! houtcome.remaining + Β· simpa [cleanupValues, denseInstructionCleanupValue] using! + houtcome.ready + have hdata := retargetBufferedDataKernel_hoareTime_frame_internal tapes + overlay nextStore cleanupValues 0 pcValue initialWork inpβ‚€ + (denseImmediateInstructionTM tapes.data destination value) + (denseImmediateInstructionTime tapes.data overlay destination value) + Result hready hbase hresult + have hall := finishBufferedDataTM_hoareTime_frame_internal tapes overlay + nextStore (pcValue + 1) pcValue cleanupValues 0 initialWork inpβ‚€ + (denseImmediateInstructionTM tapes.data destination value) + (denseImmediateInstructionTime tapes.data overlay destination value) + rfl hinput hdata + simpa [denseExecuteInstructionTM, denseExecuteInstructionTime, + DenseInstructionExecutionResult, denseInstructionStore, + denseInstructionPC, DenseOverlay.Snapshot.stepInstr, nextStore, + cleanupValues] using! hall + +/-- Instruction constructor corresponding to a dense direct arithmetic +kernel. -/ +def denseDirectInstruction (op : BinaryInstrOp) + (destination sourceβ‚€ source₁ : β„•) : Instr := + match op with + | .add => .add destination sourceβ‚€ source₁ + | .sub => .sub destination sourceβ‚€ source₁ + | .mul => .mul destination sourceβ‚€ source₁ + +/-- A dense direct arithmetic instruction produces the generic buffered +endpoint and advances the program counter. -/ +theorem denseExecuteInstructionTM_direct_hoareTime_frame + (tapes : ControlInstructionTapes n) (op : BinaryInstrOp) + (input : List Bool) (overlay : Store) + (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (denseDirectInstruction op destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (denseDirectInstruction op destination sourceβ‚€ source₁) + pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (denseDirectInstruction op destination sourceβ‚€ source₁) + pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let instruction := denseDirectInstruction op destination sourceβ‚€ source₁ + let lhs := DenseOverlay.read input overlay sourceβ‚€ + let rhs := DenseOverlay.read input overlay source₁ + let nextStore := DenseOverlay.write overlay destination (op.eval lhs rhs) + let cleanupValues := denseInstructionCleanupValue input instruction overlay + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup overlay + baseWork := + instructionExecutionReady_baseLookup_internal tapes overlay pcValue + initialWork hready + have hrhs : (baseWork tapes.data.rhs).HasBinaryNat 0 := hready.rhs + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have htmp : (baseWork tapes.data.tmp).HasBinaryNat 0 := hready.tmp + have hdbl : (baseWork tapes.data.dbl).HasBinaryNat 0 := hready.dbl + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := denseDirectBinaryInstructionTM_hoareTime_frame tapes.data + op input overlay destination sourceβ‚€ source₁ [] baseWork + (initialWork tapes.buffer) hvalid hlookup hrhs hreplacement htmp hdbl + hbuffer + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + DenseDirectBinaryInstructionResult tapes.data op input overlay destination + sourceβ‚€ source₁ baseWork work + have hbase : (denseDirectBinaryInstructionTM tapes.data op destination + sourceβ‚€ source₁).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = baseWork ∧ out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix (nextStore.flatMap Entry.encode)) + (denseDirectBinaryInstructionTime tapes.data op input overlay destination + sourceβ‚€ source₁) := by + simpa [Result, lhs, rhs, nextStore] using! hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat nextStore.length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat 0 ∧ + EntryScanReady tapes.data.update.entry [] (cleanupValues 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨updateWork, haddress, hbinary⟩ := hsemantic + obtain ⟨operandsWork, hoperands, hupdateWork⟩ := haddress + obtain ⟨lhsWork, hlhs, hrhsResult⟩ := hoperands + obtain ⟨arithmeticWork, harithmetic, htagged⟩ := hbinary + obtain ⟨taggedWork, htagValue, htagFrame, houtcome, + hsourceCells⟩ := htagged + have hpcUpdate : work tapes.pc = taggedWork tapes.pc := + houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcTag : taggedWork tapes.pc = arithmeticWork tapes.pc := + htagFrame tapes.pc (tapes.pc_ne 10) + have hpcArithmetic : arithmeticWork tapes.pc = updateWork tapes.pc := + harithmetic.frame tapes.pc (tapes.pc_ne 13) (tapes.pc_ne 14) + (tapes.pc_ne 10) (tapes.pc_ne 15) (tapes.pc_ne 16) + (tapes.pc_ne 17) + have hpcQuery : + tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcAddress : updateWork tapes.pc = operandsWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + have hpcRhs : operandsWork tapes.pc = lhsWork tapes.pc := + hrhsResult.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.rhsLookupSlot slot)) + have hpcLhs : lhsWork tapes.pc = baseWork tapes.pc := + hlhs.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) := by + have harithmeticSource : + arithmeticWork tapes.data.update.entry.source = + updateWork tapes.data.update.entry.source := + harithmetic.frame tapes.data.update.entry.source + (tapes.data.update_ne_lhs 0) + (tapes.data.update_ne_rhs 0) + (tapes.data.update.ne (by decide)) + (tapes.data.update_ne_shift 0) + (tapes.data.update_ne_tmp 0) + (tapes.data.update_ne_dbl 0) + have hcells : (work tapes.data.update.entry.source).cells = + (baseWork tapes.data.update.entry.source).cells := by + calc + (work tapes.data.update.entry.source).cells = + (arithmeticWork tapes.data.update.entry.source).cells := + hsourceCells + _ = (updateWork tapes.data.update.entry.source).cells := by + rw [harithmeticSource] + _ = (operandsWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + _ = (lhsWork tapes.data.update.entry.source).cells := + hrhsResult.sourceCells + _ = (baseWork tapes.data.update.entry.source).cells := + hlhs.sourceCells + unfold Tape.HasBinaryContent + rw [hcells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue, instructionCleanupParentSlot] + using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [houtcome.replacement] + cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue, lhs, rhs, BinaryInstrOp.eval] + using! htagValue + Β· cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue, instructionCleanupParentSlot] + using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + htagFrame tapes.data.lhs + (tapes.data.update_ne_lhs 10).symm] + cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue, lhs] using! harithmetic.lhsValue + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + htagFrame tapes.data.rhs + (tapes.data.update_ne_rhs 10).symm] + cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue, rhs] using! harithmetic.rhsValue + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + htagFrame tapes.data.shift (tapes.data.update_ne_shift 10).symm] + exact harithmetic.shift + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + htagFrame tapes.data.tmp (tapes.data.update_ne_tmp 10).symm] + exact harithmetic.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + htagFrame tapes.data.dbl (tapes.data.update_ne_dbl 10).symm] + exact harithmetic.dbl + refine ⟨hpcUpdate.trans (hpcTag.trans (hpcArithmetic.trans + (hpcAddress.trans (hpcRhs.trans hpcLhs)))), ?_, hsourceContent, + hcleanup, ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· simpa [nextStore, DenseOverlay.write] using! houtcome.resultCount + Β· simpa using! houtcome.remaining + Β· cases op <;> + simpa [instruction, denseDirectInstruction, cleanupValues, + denseInstructionCleanupValue] using! houtcome.ready + have hdata := retargetBufferedDataKernel_hoareTime_frame_internal tapes + overlay nextStore cleanupValues 0 pcValue initialWork inpβ‚€ + (denseDirectBinaryInstructionTM tapes.data op destination sourceβ‚€ source₁) + (denseDirectBinaryInstructionTime tapes.data op input overlay destination + sourceβ‚€ source₁) Result hready hbase hresult + have hall := finishBufferedDataTM_hoareTime_frame_internal tapes overlay + nextStore (pcValue + 1) pcValue cleanupValues 0 initialWork inpβ‚€ + (denseDirectBinaryInstructionTM tapes.data op destination sourceβ‚€ source₁) + (denseDirectBinaryInstructionTime tapes.data op input overlay destination + sourceβ‚€ source₁) rfl hinput hdata + cases op <;> + simpa [instruction, denseDirectInstruction, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, + DenseOverlay.Snapshot.stepInstr, nextStore, cleanupValues, lhs, rhs, + BinaryInstrOp.eval] using! hall + +/-- Dense direct addition has the common buffered instruction contract. -/ +theorem denseExecuteInstructionTM_add_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (.add destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (.add destination sourceβ‚€ source₁) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (.add destination sourceβ‚€ source₁) pcValue overlay) := by + simpa [denseDirectInstruction] using! + denseExecuteInstructionTM_direct_hoareTime_frame tapes .add input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + +/-- Dense direct subtraction has the common buffered instruction contract. -/ +theorem denseExecuteInstructionTM_sub_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (.sub destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (.sub destination sourceβ‚€ source₁) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (.sub destination sourceβ‚€ source₁) pcValue overlay) := by + simpa [denseDirectInstruction] using! + denseExecuteInstructionTM_direct_hoareTime_frame tapes .sub input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + +/-- Dense direct multiplication has the common buffered instruction contract. -/ +theorem denseExecuteInstructionTM_mul_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (.mul destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (.mul destination sourceβ‚€ source₁) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (.mul destination sourceβ‚€ source₁) pcValue overlay) := by + simpa [denseDirectInstruction] using! + denseExecuteInstructionTM_direct_hoareTime_frame tapes .mul input overlay + pcValue destination sourceβ‚€ source₁ initialWork hvalid hready + +/-- A dense indirect load produces the generic buffered endpoint and advances +the program counter. -/ +theorem denseExecuteInstructionTM_load_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue destination addressRegister : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (.load destination addressRegister)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (.load destination addressRegister) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (.load destination addressRegister) pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let instruction : Instr := .load destination addressRegister + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay address + let nextStore := DenseOverlay.write overlay destination value + let cleanupValues := denseInstructionCleanupValue input instruction overlay + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup overlay + baseWork := + instructionExecutionReady_baseLookup_internal tapes overlay pcValue + initialWork hready + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := denseIndirectLoadInstructionTM_hoareTime_frame tapes.data + input overlay destination addressRegister [] baseWork + (initialWork tapes.buffer) hvalid hlookup hreplacement hbuffer + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + DenseIndirectLoadInstructionResult tapes.data input overlay destination + addressRegister baseWork work + have hbase : (denseIndirectLoadInstructionTM tapes.data destination + addressRegister).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = baseWork ∧ out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix (nextStore.flatMap Entry.encode)) + (denseIndirectLoadInstructionTime tapes.data input overlay destination + addressRegister) := by + simpa [Result, address, value, nextStore] using! hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat nextStore.length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat 0 ∧ + EntryScanReady tapes.data.update.entry [] (cleanupValues 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨addressWork, loadedWork, updateWork, haddress, hloaded, + hupdateWork, htagged⟩ := hsemantic + obtain ⟨taggedWork, htagValue, htagFrame, houtcome, + hsourceCells⟩ := htagged + have hpcOutcome : work tapes.pc = taggedWork tapes.pc := + houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcTag : taggedWork tapes.pc = updateWork tapes.pc := + htagFrame tapes.pc (tapes.pc_ne 10) + have hpcQuery : + tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcUpdate : updateWork tapes.pc = loadedWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + have hpcLoaded : loadedWork tapes.pc = addressWork tapes.pc := + hloaded.frame tapes.pc (fun slot => by + exact tapes.pc_ne + (BinaryInstructionTapes.indirectLoadLookupSlot slot)) + have hpcAddress : addressWork tapes.pc = baseWork tapes.pc := + haddress.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) := by + have hcells : (work tapes.data.update.entry.source).cells = + (baseWork tapes.data.update.entry.source).cells := by + calc + (work tapes.data.update.entry.source).cells = + (updateWork tapes.data.update.entry.source).cells := + hsourceCells + _ = (loadedWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + _ = (addressWork tapes.data.update.entry.source).cells := + hloaded.sourceCells + _ = (baseWork tapes.data.update.entry.source).cells := + haddress.sourceCells + unfold Tape.HasBinaryContent + rw [hcells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [houtcome.replacement] + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + address, value] using! htagValue + Β· simpa [instruction, cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + htagFrame tapes.data.lhs + (tapes.data.update_ne_lhs 10).symm, + show updateWork tapes.data.lhs = loadedWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _, + show loadedWork tapes.data.lhs = addressWork tapes.data.lhs from + hloaded.querySource] + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + address] using! haddress.destination + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + htagFrame tapes.data.rhs + (tapes.data.update_ne_rhs 10).symm, + show updateWork tapes.data.rhs = loadedWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _, + hloaded.frame tapes.data.rhs (fun role => by + apply tapes.data.ne + fin_cases role <;> decide), + haddress.frame tapes.data.rhs (fun role => + (tapes.data.lhsLookup_ne_rhs role).symm)] + exact hready.rhs + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + have hqueryNe : + tapes.data.shift β‰  tapes.data.update.entry.query := + (tapes.data.update_ne_shift 7).symm + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + htagFrame tapes.data.shift (tapes.data.update_ne_shift 10).symm, + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.shift (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide)] + simpa using! haddress.querySource + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + have hqueryNe : tapes.data.tmp β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_tmp 7).symm + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + htagFrame tapes.data.tmp (tapes.data.update_ne_tmp 10).symm, + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.tmp (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide), + haddress.frame tapes.data.tmp (fun slot => + (tapes.data.lhsLookup_ne_tmp slot).symm)] + exact hready.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + have hqueryNe : tapes.data.dbl β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_dbl 7).symm + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + htagFrame tapes.data.dbl (tapes.data.update_ne_dbl 10).symm, + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.dbl (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide), + haddress.frame tapes.data.dbl (fun slot => + (tapes.data.lhsLookup_ne_dbl slot).symm)] + exact hready.dbl + refine ⟨hpcOutcome.trans (hpcTag.trans (hpcUpdate.trans + (hpcLoaded.trans hpcAddress))), ?_, hsourceContent, hcleanup, + ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· simpa [nextStore, DenseOverlay.write] using! houtcome.resultCount + Β· simpa using! houtcome.remaining + Β· simpa [instruction, cleanupValues, denseInstructionCleanupValue] + using! houtcome.ready + have hdata := retargetBufferedDataKernel_hoareTime_frame_internal tapes + overlay nextStore cleanupValues 0 pcValue initialWork inpβ‚€ + (denseIndirectLoadInstructionTM tapes.data destination addressRegister) + (denseIndirectLoadInstructionTime tapes.data input overlay destination + addressRegister) Result hready hbase hresult + have hall := finishBufferedDataTM_hoareTime_frame_internal tapes overlay + nextStore (pcValue + 1) pcValue cleanupValues 0 initialWork inpβ‚€ + (denseIndirectLoadInstructionTM tapes.data destination addressRegister) + (denseIndirectLoadInstructionTime tapes.data input overlay destination + addressRegister) rfl hinput hdata + simpa [instruction, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, + DenseOverlay.Snapshot.stepInstr, nextStore, cleanupValues, address, + value] using! hall + +/-- The dense-store endpoint supplies every frame and cleanup invariant for buffering. -/ +private theorem denseStore_buffered_result + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue addressRegister source : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + βˆ€ work, DenseIndirectStoreInstructionResult tapes.data input overlay + addressRegister source (fun i => initialWork (Fin.castSucc i)) work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + (DenseOverlay.write overlay (DenseOverlay.read input overlay addressRegister) + (DenseOverlay.read input overlay source)).length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (denseInstructionCleanupValue input (.store addressRegister source) overlay slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat 0 ∧ + EntryScanReady tapes.data.update.entry [] + (denseInstructionCleanupValue input (.store addressRegister source) overlay 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let instruction : Instr := .store addressRegister source + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + let nextStore := DenseOverlay.write overlay address value + let cleanupValues := denseInstructionCleanupValue input instruction overlay + intro work hsemantic + obtain ⟨operandsWork, queryWork, updateWork, hoperands, hqueryWork, + hupdateWork, htagged⟩ := hsemantic + obtain ⟨lhsWork, hlhs, hrhsResult⟩ := hoperands + obtain ⟨taggedWork, htagValue, htagFrame, houtcome, + hsourceCells⟩ := htagged + have hpcOutcome : work tapes.pc = taggedWork tapes.pc := + houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcTag : taggedWork tapes.pc = updateWork tapes.pc := + htagFrame tapes.pc (tapes.pc_ne 10) + have hpcReplacement : + tapes.pc β‰  tapes.data.update.replacement := tapes.pc_ne 10 + have hpcUpdate : updateWork tapes.pc = queryWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcReplacement] + have hpcQuery : + tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcQueryWork : queryWork tapes.pc = operandsWork tapes.pc := by + rw [hqueryWork, Function.update_of_ne hpcQuery] + have hpcRhs : operandsWork tapes.pc = lhsWork tapes.pc := + hrhsResult.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.rhsLookupSlot slot)) + have hpcLhs : lhsWork tapes.pc = baseWork tapes.pc := + hlhs.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) := by + have hcells : (work tapes.data.update.entry.source).cells = + (baseWork tapes.data.update.entry.source).cells := by + calc + (work tapes.data.update.entry.source).cells = + (updateWork tapes.data.update.entry.source).cells := + hsourceCells + _ = (queryWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + _ = (operandsWork tapes.data.update.entry.source).cells := by + congr 1 + rw [hqueryWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _ + _ = (lhsWork tapes.data.update.entry.source).cells := + hrhsResult.sourceCells + _ = (baseWork tapes.data.update.entry.source).cells := + hlhs.sourceCells + unfold Tape.HasBinaryContent + rw [hcells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot, address] using! + houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [houtcome.replacement] + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + value] using! htagValue + Β· simpa [instruction, cleanupValues, denseInstructionCleanupValue, + instructionCleanupParentSlot, address] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + htagFrame tapes.data.lhs + (tapes.data.update_ne_lhs 10).symm, + show updateWork tapes.data.lhs = queryWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 10).symm _ _, + show queryWork tapes.data.lhs = operandsWork tapes.data.lhs by + rw [hqueryWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _, + hrhsResult.frame tapes.data.lhs (fun role => + (tapes.data.rhsLookup_ne_lhs role).symm)] + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + address] using! hlhs.destination + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + htagFrame tapes.data.rhs + (tapes.data.update_ne_rhs 10).symm, + show updateWork tapes.data.rhs = queryWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 10).symm _ _, + show queryWork tapes.data.rhs = operandsWork tapes.data.rhs by + rw [hqueryWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _] + simpa [instruction, cleanupValues, denseInstructionCleanupValue, + value] using! hrhsResult.destination + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + have hreplacementNe : + tapes.data.shift β‰  tapes.data.update.replacement := + (tapes.data.update_ne_shift 10).symm + have hqueryNe : + tapes.data.shift β‰  tapes.data.update.entry.query := + (tapes.data.update_ne_shift 7).symm + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + htagFrame tapes.data.shift hreplacementNe, + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe] + simpa using! hrhsResult.querySource + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + have hreplacementNe : + tapes.data.tmp β‰  tapes.data.update.replacement := + (tapes.data.update_ne_tmp 10).symm + have hqueryNe : tapes.data.tmp β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_tmp 7).symm + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + htagFrame tapes.data.tmp hreplacementNe, + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe, + hrhsResult.frame tapes.data.tmp (fun slot => + (tapes.data.rhsLookup_ne_tmp slot).symm), + hlhs.frame tapes.data.tmp (fun slot => + (tapes.data.lhsLookup_ne_tmp slot).symm)] + exact hready.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + have hreplacementNe : + tapes.data.dbl β‰  tapes.data.update.replacement := + (tapes.data.update_ne_dbl 10).symm + have hqueryNe : tapes.data.dbl β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_dbl 7).symm + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + htagFrame tapes.data.dbl hreplacementNe, + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe, + hrhsResult.frame tapes.data.dbl (fun slot => + (tapes.data.rhsLookup_ne_dbl slot).symm), + hlhs.frame tapes.data.dbl (fun slot => + (tapes.data.lhsLookup_ne_dbl slot).symm)] + exact hready.dbl + refine ⟨hpcOutcome.trans (hpcTag.trans (hpcUpdate.trans + (hpcQueryWork.trans (hpcRhs.trans hpcLhs)))), ?_, hsourceContent, + hcleanup, ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· simpa [nextStore, DenseOverlay.write] using! houtcome.resultCount + Β· simpa using! houtcome.remaining + Β· simpa [instruction, cleanupValues, denseInstructionCleanupValue, + address] using! houtcome.ready + +/-- A dense indirect store produces the generic buffered endpoint and advances +the program counter. -/ +theorem denseExecuteInstructionTM_store_hoareTime_frame + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue addressRegister source : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseExecuteInstructionTM tapes + (.store addressRegister source)).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseInstructionExecutionResult tapes input + (.store addressRegister source) pcValue overlay work ∧ + out = (Tape.init []).move Dir3.right) + (denseExecuteInstructionTime tapes input + (.store addressRegister source) pcValue overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + let instruction : Instr := .store addressRegister source + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + let nextStore := DenseOverlay.write overlay address value + let cleanupValues := denseInstructionCleanupValue input instruction overlay + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup overlay + baseWork := + instructionExecutionReady_baseLookup_internal tapes overlay pcValue + initialWork hready + have hrhs : (baseWork tapes.data.rhs).HasBinaryNat 0 := hready.rhs + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := denseIndirectStoreInstructionTM_hoareTime_frame tapes.data + input overlay addressRegister source [] baseWork + (initialWork tapes.buffer) hvalid hlookup hrhs hreplacement hbuffer + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + DenseIndirectStoreInstructionResult tapes.data input overlay + addressRegister source baseWork work + have hbase : (denseIndirectStoreInstructionTM tapes.data addressRegister + source).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = baseWork ∧ out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix (nextStore.flatMap Entry.encode)) + (denseIndirectStoreInstructionTime tapes.data input overlay + addressRegister source) := by + simpa [Result, address, value, nextStore] using! hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat nextStore.length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (overlay.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat 0 ∧ + EntryScanReady tapes.data.update.entry [] (cleanupValues 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := + denseStore_buffered_result tapes input overlay pcValue addressRegister source + initialWork hready + have hdata := retargetBufferedDataKernel_hoareTime_frame_internal tapes + overlay nextStore cleanupValues 0 pcValue initialWork inpβ‚€ + (denseIndirectStoreInstructionTM tapes.data addressRegister source) + (denseIndirectStoreInstructionTime tapes.data input overlay + addressRegister source) Result hready hbase hresult + have hall := finishBufferedDataTM_hoareTime_frame_internal tapes overlay + nextStore (pcValue + 1) pcValue cleanupValues 0 initialWork inpβ‚€ + (denseIndirectStoreInstructionTM tapes.data addressRegister source) + (denseIndirectStoreInstructionTime tapes.data input overlay + addressRegister source) rfl hinput hdata + simpa [instruction, denseExecuteInstructionTM, + denseExecuteInstructionTime, DenseInstructionExecutionResult, + denseInstructionStore, denseInstructionPC, + DenseOverlay.Snapshot.stepInstr, nextStore, cleanupValues, address, + value] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimDefs.lean new file mode 100644 index 0000000000..03a811fc4e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseSimDefs.lean @@ -0,0 +1,247 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs + +/-! +# Dense-overlay instruction simulation -- controller definitions + +These definitions connect the dense instruction kernels to the existing +fixed-program selector and representation-independent buffered cleanup pass. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Execute one selected instruction against the dense public-input overlay. -/ +def denseExecuteInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) : + Instr β†’ TM (n + 1) + | .imm destination value => + TM.seqTM + (denseImmediateInstructionTM tapes.data destination value).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .add destination sourceβ‚€ source₁ => + TM.seqTM + (denseDirectBinaryInstructionTM tapes.data .add destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .sub destination sourceβ‚€ source₁ => + TM.seqTM + (denseDirectBinaryInstructionTM tapes.data .sub destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .mul destination sourceβ‚€ source₁ => + TM.seqTM + (denseDirectBinaryInstructionTM tapes.data .mul destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .load destination addressRegister => + TM.seqTM + (denseIndirectLoadInstructionTM tapes.data destination + addressRegister).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .store addressRegister source => + TM.seqTM + (denseIndirectStoreInstructionTM tapes.data addressRegister + source).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .jz source target => + finishControlInstructionTM tapes + (denseZeroJumpInstructionTM tapes.lifted source target) + | .jmp target => + finishControlInstructionTM tapes (jumpInstructionTM tapes.lifted target) + | .halt => + finishControlInstructionTM tapes (haltInstructionTM (n := n + 1)) + +/-- Dense finite branch tree selected by a decrementing PC copy. -/ +def denseDispatchProgramTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + dispatchWithTM tapes (denseExecuteInstructionTM tapes) program + +/-- Copy the dense snapshot PC into selector scratch and dispatch once. -/ +def denseProgramInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (denseDispatchProgramTM tapes program) + +/-- Mutable overlay after one dense instruction. -/ +def denseInstructionStore (input : List Bool) (instruction : Instr) + (pcValue : β„•) (overlay : Store) : Store := + (DenseOverlay.Snapshot.stepInstr input instruction + { pc := pcValue, overlay := overlay }).overlay + +/-- Program counter after one dense instruction. -/ +def denseInstructionPC (input : List Bool) (instruction : Instr) + (pcValue : β„•) (overlay : Store) : β„• := + (DenseOverlay.Snapshot.stepInstr input instruction + { pc := pcValue, overlay := overlay }).pc + +/-- Exact values left on the five physical cleanup roles by a dense kernel. -/ +def denseInstructionCleanupValue (input : List Bool) + (instruction : Instr) (overlay : Store) : Fin 5 β†’ β„• + | 0 => + match instruction with + | .imm destination _ | .add destination _ _ | + .sub destination _ _ | .mul destination _ _ | + .load destination _ => destination + | .store addressRegister _ => + DenseOverlay.read input overlay addressRegister + | .jz _ _ | .jmp _ | .halt => 0 + | 1 => + match instruction with + | .imm _ value => value + 1 + | .add _ sourceβ‚€ source₁ => + DenseOverlay.read input overlay sourceβ‚€ + + DenseOverlay.read input overlay source₁ + 1 + | .sub _ sourceβ‚€ source₁ => + (DenseOverlay.read input overlay sourceβ‚€ - + DenseOverlay.read input overlay source₁) + 1 + | .mul _ sourceβ‚€ source₁ => + DenseOverlay.read input overlay sourceβ‚€ * + DenseOverlay.read input overlay source₁ + 1 + | .load _ addressRegister => + DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister) + 1 + | .store _ source => DenseOverlay.read input overlay source + 1 + | .jz _ _ | .jmp _ | .halt => 0 + | 2 => + match instruction with + | .imm destination _ | .add destination _ _ | + .sub destination _ _ | .mul destination _ _ | + .load destination _ => + if destination ∈ overlay.map Prod.fst then 1 else 0 + | .store addressRegister _ => + if DenseOverlay.read input overlay addressRegister ∈ + overlay.map Prod.fst then 1 else 0 + | .jz _ _ | .jmp _ | .halt => 0 + | 3 => + match instruction with + | .add _ sourceβ‚€ _ | .sub _ sourceβ‚€ _ | .mul _ sourceβ‚€ _ => + DenseOverlay.read input overlay sourceβ‚€ + | .load _ addressRegister | .store addressRegister _ => + DenseOverlay.read input overlay addressRegister + | .imm _ _ | .jz _ _ | .jmp _ | .halt => 0 + | _ => + match instruction with + | .add _ _ source₁ | .sub _ _ source₁ | .mul _ _ source₁ => + DenseOverlay.read input overlay source₁ + | .store _ source => DenseOverlay.read input overlay source + | .imm _ _ | .load _ _ | .jz _ _ | .jmp _ | .halt => 0 + +/-- Old overlay counter state before generic buffered cleanup. -/ +def denseInstructionRemainingValue (instruction : Instr) + (overlay : Store) : β„• := + match instruction with + | .imm _ _ | .add _ _ _ | .sub _ _ _ | .mul _ _ _ | + .load _ _ | .store _ _ => 0 + | .jz _ _ | .jmp _ | .halt => overlay.length + +/-- Common dense semantic endpoint before representation cleanup. -/ +abbrev DenseInstructionExecutionResult {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) + (instruction : Instr) (pcValue : β„•) (overlay : Store) + (work : Fin (n + 1) β†’ Tape) : Prop := + BufferedInstructionResult tapes overlay + (denseInstructionStore input instruction pcValue overlay) + (denseInstructionPC input instruction pcValue overlay) + (denseInstructionCleanupValue input instruction overlay) + (denseInstructionRemainingValue instruction overlay) work + +/-- Dense endpoint plus the marker and source-cursor bounds needed by cleanup. -/ +abbrev DenseInstructionCleanupReady {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) + (instruction : Instr) (pcValue : β„•) (overlay : Store) + (sourceHeadBound : β„•) (work : Fin (n + 1) β†’ Tape) : Prop := + BufferedCleanupReady tapes overlay + (denseInstructionStore input instruction pcValue overlay) + (denseInstructionPC input instruction pcValue overlay) + (denseInstructionCleanupValue input instruction overlay) + (denseInstructionRemainingValue instruction overlay) + sourceHeadBound work + +/-- Runtime of one statically selected dense instruction before cleanup. -/ +def denseExecuteInstructionTime {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) + (instruction : Instr) (pcValue : β„•) (overlay : Store) : β„• := + match instruction with + | .imm destination value => + denseImmediateInstructionTime tapes.data overlay destination value + 1 + + TM.binarySuccTime pcValue + | .add destination sourceβ‚€ source₁ => + denseDirectBinaryInstructionTime tapes.data .add input overlay destination + sourceβ‚€ source₁ + 1 + TM.binarySuccTime pcValue + | .sub destination sourceβ‚€ source₁ => + denseDirectBinaryInstructionTime tapes.data .sub input overlay destination + sourceβ‚€ source₁ + 1 + TM.binarySuccTime pcValue + | .mul destination sourceβ‚€ source₁ => + denseDirectBinaryInstructionTime tapes.data .mul input overlay destination + sourceβ‚€ source₁ + 1 + TM.binarySuccTime pcValue + | .load destination addressRegister => + denseIndirectLoadInstructionTime tapes.data input overlay destination + addressRegister + 1 + TM.binarySuccTime pcValue + | .store addressRegister source => + denseIndirectStoreInstructionTime tapes.data input overlay addressRegister + source + 1 + TM.binarySuccTime pcValue + | .jz source target => + denseZeroJumpInstructionTime tapes.lifted input overlay pcValue source + target + 1 + (overlay.flatMap Entry.encode).length + 1 + | .jmp target => + jumpInstructionTime pcValue target + 1 + + (overlay.flatMap Entry.encode).length + 1 + | .halt => + haltInstructionTime + 1 + (overlay.flatMap Entry.encode).length + 1 + +/-- Dense branch-tree runtime for a represented selector. -/ +def denseDispatchProgramTime {n : β„•} (tapes : ControlInstructionTapes n) + (input : List Bool) (overlay : Store) (pcValue : β„•) : + Program β†’ β„• β†’ β„• := + dispatchWithTime tapes + (fun instruction => + denseExecuteInstructionTime tapes input instruction pcValue overlay) + +/-- Complete dense selection and selected-instruction runtime. -/ +def denseProgramInstructionTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (pcValue : β„•) (overlay : Store) : β„• := + TM.binaryCopyTime pcValue 0 + 1 + + denseDispatchProgramTime tapes input overlay pcValue program pcValue + +/-- Select, execute, and clean one dense RAM instruction. -/ +def denseProgramStepTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM (denseProgramInstructionTM tapes program) + (instructionCleanupTM tapes) + +/-- Source-head bound after dense selection and execution. -/ +def denseProgramStepSourceHeadBound {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (pcValue : β„•) (overlay : Store) : β„• := + 1 + denseProgramInstructionTime tapes program input pcValue overlay + +/-- Exact compositional time for one selected and cleaned dense RAM step. -/ +noncomputable def denseProgramStepTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (pcValue : β„•) (overlay : Store) : β„• := + let instruction := selectedInstruction program pcValue + let nextStore := denseInstructionStore input instruction pcValue overlay + denseProgramInstructionTime tapes program input pcValue overlay + 1 + + bufferedCleanupTime tapes overlay nextStore + (denseInstructionCleanupValue input instruction overlay) + (denseInstructionRemainingValue instruction overlay) + (denseProgramStepSourceHeadBound tapes program input pcValue overlay) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseStore.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseStore.lean new file mode 100644 index 0000000000..5f7312c135 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/DenseStore.lean @@ -0,0 +1,493 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDirect + +/-! +# Dense-overlay indirect store +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem denseStoreOperands_values + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) + (initialWork operandsWork : Fin n β†’ Tape) + (hoperands : DenseDirectBinaryOperandsResult tapes input overlay + addressRegister source initialWork operandsWork) : + (operandsWork tapes.lhs).HasBinaryNat + (DenseOverlay.read input overlay addressRegister) ∧ + (operandsWork tapes.rhs).HasBinaryNat + (DenseOverlay.read input overlay source) ∧ + (operandsWork tapes.update.found).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (operandsWork i) := by + rcases hoperands with ⟨lhsWork, hlhs, hrhs⟩ + have hlhsEq : operandsWork tapes.lhs = lhsWork tapes.lhs := + hrhs.frame tapes.lhs (fun slot => (tapes.rhsLookup_ne_lhs slot).symm) + refine ⟨?_, by simpa using! hrhs.destination, + by simpa using! hrhs.copyScratch, hrhs.parked⟩ + rw [hlhsEq] + exact hlhs.destination + +private theorem scanner_after_replacement + (tapes : BinaryInstructionTapes n) (overlay : Store) (address value : β„•) + (work : Fin n β†’ Tape) + (hscanner : EntryScanReady tapes.update.entry + (overlay.flatMap Entry.encode) address.bits work work) : + EntryScanReady tapes.update.entry (overlay.flatMap Entry.encode) + address.bits + (Function.update work tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) + (Function.update work tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) := by + let finalWork := Function.update work tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + have hsource : tapes.update.entry.source β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddress : tapes.update.entry.address β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalue : tapes.update.entry.value β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressCounter : + tapes.update.entry.addressCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressWidth : + tapes.update.entry.addressWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueCounter : + tapes.update.entry.valueCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueWidth : + tapes.update.entry.valueWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hquery : tapes.update.entry.query β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresult : tapes.update.entry.result β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hnat := Tape.init_move_right_hasBinaryNat value + refine + { source := by + simpa only [finalWork, Function.update_of_ne hsource] using! + hscanner.source + address := by + simpa only [finalWork, Function.update_of_ne haddress] using! + hscanner.address + addressStart := by + simpa only [finalWork, Function.update_of_ne haddress] using! + hscanner.addressStart + value := by + simpa only [finalWork, Function.update_of_ne hvalue] using! + hscanner.value + valueStart := by + simpa only [finalWork, Function.update_of_ne hvalue] using! + hscanner.valueStart + addressCounter := by + simpa only [finalWork, Function.update_of_ne haddressCounter] using! + hscanner.addressCounter + addressWidth := by + simpa only [finalWork, Function.update_of_ne haddressWidth] using! + hscanner.addressWidth + valueCounter := by + simpa only [finalWork, Function.update_of_ne hvalueCounter] using! + hscanner.valueCounter + valueWidth := by + simpa only [finalWork, Function.update_of_ne hvalueWidth] using! + hscanner.valueWidth + query := by + simpa only [finalWork, Function.update_of_ne hquery] using! + hscanner.query + queryStart := by + simpa only [finalWork, Function.update_of_ne hquery] using! + hscanner.queryStart + result := by + simpa only [finalWork, Function.update_of_ne hresult] using! + hscanner.result + resultStart := by + simpa only [finalWork, Function.update_of_ne hresult] using! + hscanner.resultStart + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + intro i + by_cases hi : i = tapes.update.replacement + Β· subst i + simpa only [finalWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [finalWork, Function.update_of_ne hi] using! hscanner.parked i + +private theorem denseStoreUpdate_ready + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) + (initialWork operandsWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hoperands : DenseDirectBinaryOperandsResult tapes input overlay + addressRegister source initialWork operandsWork) : + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + let queryWork := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + EntryScanReady tapes.update.entry (overlay.flatMap Entry.encode) + address.bits updateWork updateWork ∧ + (updateWork tapes.update.replacement).HasBinaryNat value ∧ + (updateWork tapes.update.remaining).HasBinaryNat overlay.length ∧ + (updateWork tapes.update.found).HasBinaryNat 0 ∧ + (updateWork tapes.update.resultCount).HasBinaryNat overlay.length ∧ + βˆ€ i, TM.Parked (updateWork i) := by + dsimp only + rcases hoperands with ⟨lhsWork, hlhs, hrhs⟩ + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + let queryWork := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + have hqueryScanner := scanner_updateQuery_internal tapes overlay address + operandsWork hrhs.scanner + have hscanner : EntryScanReady tapes.update.entry + (overlay.flatMap Entry.encode) address.bits updateWork updateWork := by + simpa only [queryWork, updateWork] using! + scanner_after_replacement tapes overlay address value queryWork + hqueryScanner + have hvalueNat := Tape.init_move_right_hasBinaryNat value + have hresultCount : + (operandsWork tapes.update.resultCount).HasBinaryNat overlay.length := by + rw [show operandsWork tapes.update.resultCount = + lhsWork tapes.update.resultCount by simpa using! hrhs.countSource] + rw [show lhsWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! hlhs.countSource] + simpa using! hinitial.countSource + have hremainingReplacement : + tapes.update.remaining β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hremainingQuery : + tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundReplacement : tapes.update.found β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hfoundQuery : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCountReplacement : + tapes.update.resultCount β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultCountQuery : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + refine ⟨hscanner, ?_, ?_, ?_, ?_, hscanner.parked⟩ + Β· simpa only [updateWork, Function.update_self] using! hvalueNat + Β· simpa only [updateWork, Function.update_of_ne hremainingReplacement, + queryWork, Function.update_of_ne hremainingQuery] using! hrhs.count + Β· simpa only [updateWork, Function.update_of_ne hfoundReplacement, + queryWork, Function.update_of_ne hfoundQuery] using! hrhs.copyScratch + Β· simpa only [updateWork, Function.update_of_ne hresultCountReplacement, + queryWork, Function.update_of_ne hresultCountQuery] using! hresultCount + +/-- The dense-store update stage preserves its operand witnesses and exact encoded-write output. -/ +private theorem denseStore_updateStage + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hinput : TM.Parked ((Tape.init (input.map Ξ“.ofBool)).move Dir3.right)) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + (taggedEntryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork queryWork, + DenseDirectBinaryOperandsResult tapes input overlay addressRegister + source initialWork operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + work = Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseIndirectStoreInstructionResult tapes input overlay addressRegister + source initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay address value).flatMap Entry.encode)) + (taggedEntryUpdateTime tapes.update overlay address value) := by + dsimp only + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + rintro inp work out ⟨hinp, ⟨operandsWork, queryWork, hops, + hqueryWork, hwork⟩, hout⟩ + subst queryWork + subst work + have hready := denseStoreUpdate_ready tapes input overlay addressRegister + source initialWork operandsWork hinitial hops + let updateWork := Function.update + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + have hrun := taggedEntryUpdateTM_hoareTime_frame tapes.update overlay + address value emittedBits updateWork inpβ‚€ outβ‚€ hvalid.1 hready.1 + hready.2.1 hready.2.2.1 hready.2.2.2.1 hready.2.2.2.2.1 hinput + houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + houtcome, hfinalOutput⟩ := + hrun inp updateWork out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨operandsWork, + Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right), + updateWork, hops, rfl, rfl, by simpa [address, value] using! houtcome⟩, + by simpa [address, value] using! hfinalOutput⟩ + +/-- Exact semantic and time contract for one dense-overlay indirect store. -/ +theorem denseIndirectStoreInstructionTM_hoareTime_frame + (tapes : BinaryInstructionTapes n) (input : List Bool) + (overlay : Store) (addressRegister source : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalid : DenseOverlay.Valid overlay) + (hinitial : EntryLookupStaticReady tapes.lhsLookup overlay initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (denseIndirectStoreInstructionTM tapes addressRegister source).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseIndirectStoreInstructionResult tapes input overlay addressRegister + source initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (DenseOverlay.write overlay + (DenseOverlay.read input overlay addressRegister) + (DenseOverlay.read input overlay source)).flatMap Entry.encode)) + (denseIndirectStoreInstructionTime tapes input overlay addressRegister + source) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using! Tape.init_ofBool_move_right_cells_ne_start input + have houtputParked := hasBinaryPrefix_parked houtput + have hoperands := denseDirectBinaryOperands_hoareTime tapes input overlay + addressRegister source initialWork outβ‚€ hvalid hinitial hrhsβ‚€ houtputParked + have hquery : + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query + tapes.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseDirectBinaryOperandsResult tapes input overlay addressRegister + source initialWork work ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork, + DenseDirectBinaryOperandsResult tapes input overlay addressRegister + source initialWork operandsWork ∧ + work = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryCopyTime address 0) := by + rintro inp work out ⟨hinp, hops, hout⟩ + have hvalues := denseStoreOperands_values tapes input overlay + addressRegister source initialWork work hops + have hrun := TM.binaryCopyIntoTM_hoareTime_frame tapes.lhs + tapes.update.entry.query tapes.update.found (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.update.ne (by decide)) address 0 inp work + out (by simpa [address] using! hvalues.1) + ⟨(by rcases hops with ⟨_, _, hrhs⟩; exact hrhs.scanner.queryStart), + (by rcases hops with ⟨_, _, hrhs⟩; + simpa using! hrhs.scanner.query)⟩ + hvalues.2.2.1 (by simpa [hinp] using! hinput) + (fun i _ _ _ => hvalues.2.2.2 i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨work, hops, by simpa [address] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hvalue : + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement + tapes.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork, + DenseDirectBinaryOperandsResult tapes input overlay addressRegister + source initialWork operandsWork ∧ + work = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork queryWork, + DenseDirectBinaryOperandsResult tapes input overlay addressRegister + source initialWork operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + work = Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryCopyTime value 0) := by + rintro inp work out ⟨hinp, ⟨operandsWork, hops, hwork⟩, hout⟩ + subst work + have hvalues := denseStoreOperands_values tapes input overlay + addressRegister source initialWork operandsWork hops + let queryWork := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + have hrhsQuery : tapes.rhs β‰  tapes.update.entry.query := + tapes.ne (by decide) + have hreplacementQuery : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundQuery : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hrun := TM.binaryCopyIntoTM_hoareTime_frame tapes.rhs + tapes.update.replacement tapes.update.found (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.update.ne (by decide)) value 0 inp + queryWork out + (by simpa only [queryWork, Function.update_of_ne hrhsQuery, value] using! + hvalues.2.1) + (by + have hreplEq : operandsWork tapes.update.replacement = + initialWork tapes.update.replacement := by + rcases hops with ⟨lhsWork, hlhs, hrhs⟩ + rw [hrhs.frame tapes.update.replacement + (fun slot => (tapes.rhsLookup_ne_replacement slot).symm)] + exact hlhs.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + simpa only [queryWork, Function.update_of_ne hreplacementQuery, + hreplEq] using! hreplacement) + (by simpa only [queryWork, Function.update_of_ne hfoundQuery] using! + hvalues.2.2.1) + (by simpa [hinp] using! hinput) + (fun i _ _ _ => by + by_cases hi : i = tapes.update.entry.query + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat address + simpa only [queryWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [queryWork, Function.update_of_ne hi] using! + hvalues.2.2.2 i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp queryWork out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨operandsWork, queryWork, hops, rfl, + by simpa [value] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hupdate := denseStore_updateStage tapes input overlay addressRegister source emittedBits + initialWork outβ‚€ hvalid hinitial hinput houtput + have hvalueUpdate := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement tapes.update.found) + (taggedEntryUpdateTM tapes.update) hvalue + (by + rintro inp work out ⟨hinp, ⟨operandsWork, queryWork, hops, + hqueryWork, hwork⟩, hout⟩ + subst queryWork + subst work + have hready := denseStoreUpdate_ready tapes input overlay addressRegister + source initialWork operandsWork hinitial hops + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) + (work := Function.update + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hready.2.2.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨operandsWork, _, hops, rfl, rfl⟩, hout⟩) + hupdate + have hqueryRest := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement tapes.update.found) + (taggedEntryUpdateTM tapes.update)) hquery + (by + rintro inp work out ⟨hinp, ⟨operandsWork, hops, hwork⟩, hout⟩ + subst work + have hvalues := denseStoreOperands_values tapes input overlay + addressRegister source initialWork operandsWork hops + have hparked : βˆ€ i, TM.Parked + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) i) := by + intro i + by_cases hi : i = tapes.update.entry.query + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat address + simpa only [Function.update_self] using! + (show TM.Parked + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [Function.update_of_ne hi] using! hvalues.2.2.2 i + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) + (work := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨operandsWork, hops, rfl⟩, hout⟩) + hvalueUpdate + have hall := TM.seqTM_hoareTime + (TM.seqTM (denseOverlayLookupStaticTM tapes.lhsLookup addressRegister) + (denseOverlayLookupStaticTM tapes.rhsLookup source)) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement + tapes.update.found) + (taggedEntryUpdateTM tapes.update))) hoperands + (by + rintro inp work out ⟨hinp, hops, hout⟩ + have hvalues := denseStoreOperands_values tapes input overlay + addressRegister source initialWork work hops + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hvalues.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, hops, hout⟩) + hqueryRest + simpa [denseIndirectStoreInstructionTM, denseIndirectStoreInstructionTime, + inpβ‚€, address, value] using! hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Direct.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Direct.lean new file mode 100644 index 0000000000..6dcb1b6120 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Direct.lean @@ -0,0 +1,503 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static + +/-! +# Direct sparse-store arithmetic instructions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +theorem scanner_rhs_of_lhs_internal + (tapes : BinaryInstructionTapes n) (store : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlookup : EntryLookupStaticResult tapes.lhsLookup store source + initialWork finalWork) : + EntryScanReady tapes.rhsLookup.scan.entry (store.flatMap Entry.encode) [] + finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := hlookup.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· exact hlookup.scanner.source + Β· exact hlookup.scanner.address + Β· exact hlookup.scanner.addressStart + Β· exact hlookup.scanner.value + Β· exact hlookup.scanner.valueStart + Β· exact hlookup.scanner.addressCounter + Β· exact hlookup.scanner.addressWidth + Β· exact hlookup.scanner.valueCounter + Β· exact hlookup.scanner.valueWidth + Β· exact hlookup.scanner.query + Β· exact hlookup.scanner.queryStart + Β· exact hlookup.scanner.result + Β· exact hlookup.scanner.resultStart + +theorem rhsReady_of_lhs_internal + (tapes : BinaryInstructionTapes n) (store : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhs : (initialWork tapes.rhs).HasBinaryNat 0) + (hlookup : EntryLookupStaticResult tapes.lhsLookup store source + initialWork finalWork) : + EntryLookupStaticReady tapes.rhsLookup store finalWork := by + have hrhsEq : finalWork tapes.rhs = initialWork tapes.rhs := + hlookup.frame tapes.rhs + (fun slot => (tapes.lhsLookup_ne_rhs slot).symm) + refine + { scanner := scanner_rhs_of_lhs_internal tapes store source initialWork finalWork + hlookup + sourceStart := hlookup.sourceStart + sourceHead := hlookup.sourceHead + count := by simpa using! hlookup.count + countSource := ?_ + querySource := by simpa using! hlookup.querySource + destination := by + change (finalWork tapes.rhs).HasBinaryNat 0 + rw [hrhsEq] + exact hrhs + copyScratch := by simpa using! hlookup.copyScratch } + change (finalWork tapes.update.resultCount).HasBinaryNat store.length + have hcountSource : finalWork tapes.update.resultCount = + initialWork tapes.update.resultCount := by + simpa using! hlookup.countSource + rw [hcountSource] + simpa using! hinitial.countSource + +theorem scanner_updateQuery_internal + (tapes : BinaryInstructionTapes n) (store : Store) (destination : β„•) + (work : Fin n β†’ Tape) + (hscanner : EntryScanReady tapes.rhsLookup.scan.entry + (store.flatMap Entry.encode) [] work work) : + EntryScanReady tapes.update.entry (store.flatMap Entry.encode) + destination.bits + (Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) + (Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) := by + let finalWork := Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have hsource : tapes.update.entry.source β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddress : tapes.update.entry.address β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalue : tapes.update.entry.value β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressCounter : + tapes.update.entry.addressCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressWidth : + tapes.update.entry.addressWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueCounter : + tapes.update.entry.valueCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueWidth : + tapes.update.entry.valueWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresult : tapes.update.entry.result β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hnat := Tape.init_move_right_hasBinaryNat destination + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· simpa only [finalWork, Function.update_of_ne hsource] using! hscanner.source + Β· simpa only [finalWork, Function.update_of_ne haddress] using! hscanner.address + Β· simpa only [finalWork, Function.update_of_ne haddress] using! + hscanner.addressStart + Β· simpa only [finalWork, Function.update_of_ne hvalue] using! hscanner.value + Β· simpa only [finalWork, Function.update_of_ne hvalue] using! + hscanner.valueStart + Β· simpa only [finalWork, Function.update_of_ne haddressCounter] using! + hscanner.addressCounter + Β· simpa only [finalWork, Function.update_of_ne haddressWidth] using! + hscanner.addressWidth + Β· simpa only [finalWork, Function.update_of_ne hvalueCounter] using! + hscanner.valueCounter + Β· simpa only [finalWork, Function.update_of_ne hvalueWidth] using! + hscanner.valueWidth + Β· simpa only [finalWork, Function.update_self] using! hnat.2 + Β· simpa only [finalWork, Function.update_self] using! hnat.1 + Β· simpa only [finalWork, Function.update_of_ne hresult] using! hscanner.result + Β· simpa only [finalWork, Function.update_of_ne hresult] using! + hscanner.resultStart + Β· intro i + by_cases hi : i = tapes.update.entry.query + Β· subst i + simpa only [finalWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [finalWork, Function.update_of_ne hi] using! hscanner.parked i + +private theorem directAddress_ready + (tapes : BinaryInstructionTapes n) (store : Store) + (destination sourceβ‚€ source₁ : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (haddress : DirectBinaryAddressResult tapes store destination sourceβ‚€ + source₁ initialWork finalWork) : + DirectBinaryUpdateReady tapes store destination sourceβ‚€ source₁ + finalWork := by + rcases haddress with ⟨operandsWork, ⟨lhsWork, hlhs, hrhs⟩, rfl⟩ + have hlhsEq : operandsWork tapes.lhs = lhsWork tapes.lhs := + hrhs.frame tapes.lhs + (fun slot => (tapes.rhsLookup_ne_lhs slot).symm) + have hlhsValue : + (operandsWork tapes.lhs).HasBinaryNat + (RegisterStore.read store sourceβ‚€) := by + rw [hlhsEq] + simpa using! hlhs.destination + have hreplacementEq : + operandsWork tapes.update.replacement = + initialWork tapes.update.replacement := by + rw [hrhs.frame tapes.update.replacement + (fun slot => (tapes.rhsLookup_ne_replacement slot).symm)] + exact hlhs.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + have htmpEq : operandsWork tapes.tmp = initialWork tapes.tmp := by + rw [hrhs.frame tapes.tmp + (fun slot => (tapes.rhsLookup_ne_tmp slot).symm)] + exact hlhs.frame tapes.tmp + (fun slot => (tapes.lhsLookup_ne_tmp slot).symm) + have hdblEq : operandsWork tapes.dbl = initialWork tapes.dbl := by + rw [hrhs.frame tapes.dbl + (fun slot => (tapes.rhsLookup_ne_dbl slot).symm)] + exact hlhs.frame tapes.dbl + (fun slot => (tapes.lhsLookup_ne_dbl slot).symm) + have hresultCount : + (operandsWork tapes.update.resultCount).HasBinaryNat store.length := by + rw [show operandsWork tapes.update.resultCount = + lhsWork tapes.update.resultCount by simpa using! hrhs.countSource] + rw [show lhsWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! hlhs.countSource] + simpa using! hinitial.countSource + have hqueryNeLhs : tapes.lhs β‰  tapes.update.entry.query := + tapes.ne (by decide) + have hqueryNeRhs : tapes.rhs β‰  tapes.update.entry.query := + tapes.ne (by decide) + have hqueryNeReplacement : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hqueryNeShift : tapes.shift β‰  tapes.update.entry.query := + (tapes.update_ne_shift 7).symm + have hqueryNeTmp : tapes.tmp β‰  tapes.update.entry.query := + (tapes.update_ne_tmp 7).symm + have hqueryNeDbl : tapes.dbl β‰  tapes.update.entry.query := + (tapes.update_ne_dbl 7).symm + have hqueryNeRemaining : + tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hqueryNeFound : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hqueryNeResultCount : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + refine + { scanner := scanner_updateQuery_internal tapes store destination operandsWork + hrhs.scanner + lhs := ?_ + rhs := ?_ + replacement := ?_ + shift := ?_ + tmp := ?_ + dbl := ?_ + remaining := ?_ + found := ?_ + resultCount := ?_ + parked := ?_ } + Β· simpa only [Function.update_of_ne hqueryNeLhs] using! hlhsValue + Β· simpa only [Function.update_of_ne hqueryNeRhs] using! hrhs.destination + Β· simpa only [Function.update_of_ne hqueryNeReplacement, hreplacementEq] + using! hreplacement + Β· simpa only [Function.update_of_ne hqueryNeShift] using! hrhs.querySource + Β· simpa only [Function.update_of_ne hqueryNeTmp, htmpEq] using! htmp + Β· simpa only [Function.update_of_ne hqueryNeDbl, hdblEq] using! hdbl + Β· simpa only [Function.update_of_ne hqueryNeRemaining] using! hrhs.count + Β· simpa only [Function.update_of_ne hqueryNeFound] using! hrhs.copyScratch + Β· simpa only [Function.update_of_ne hqueryNeResultCount] using! hresultCount + Β· exact (scanner_updateQuery_internal tapes store destination operandsWork + hrhs.scanner).parked + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- The shared two-direct-operand prefix used by arithmetic and indirect +store instructions. -/ +theorem directBinaryOperands_hoareTime_internal + (tapes : BinaryInstructionTapes n) (store : Store) + (sourceβ‚€ source₁ : β„•) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.seqTM (entryLookupStaticTM tapes.lhsLookup sourceβ‚€) + (entryLookupStaticTM tapes.rhsLookup source₁)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryOperandsResult tapes store sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (entryLookupStaticTime tapes.lhsLookup store sourceβ‚€ + 1 + + entryLookupStaticTime tapes.rhsLookup store source₁) := by + have hlhs := entryLookupStatic_hoareTime_internal tapes.lhsLookup store + sourceβ‚€ initialWork inpβ‚€ outβ‚€ hinitial hinput houtput + have hrhs : (entryLookupStaticTM tapes.rhsLookup source₁).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.lhsLookup store sourceβ‚€ + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryOperandsResult tapes store sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (entryLookupStaticTime tapes.rhsLookup store source₁) := by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + have hready := rhsReady_of_lhs_internal tapes store sourceβ‚€ initialWork + work hinitial hrhsβ‚€ hlhsResult + have hrun := entryLookupStatic_hoareTime_internal tapes.rhsLookup store + source₁ work inpβ‚€ outβ‚€ hready hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hrhsResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, hlhsResult, hrhsResult⟩, hfinalOutput⟩ + exact TM.seqTM_hoareTime + (entryLookupStaticTM tapes.lhsLookup sourceβ‚€) + (entryLookupStaticTM tapes.rhsLookup source₁) hlhs + (by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hlhsResult.parked + (by simpa [hout] using! houtput) + rw [hi, hw, ho] + exact ⟨hinp, hlhsResult, hout⟩) + hrhs + +/-- Two fixed sparse reads, direct destination synthesis, width-efficient +arithmetic, and sparse update compose to the pure direct RAM operation. -/ +theorem directBinaryInstructionTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (directBinaryInstructionTM tapes op destination sourceβ‚€ source₁).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryInstructionResult tapes op store destination sourceβ‚€ + source₁ initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (op.eval (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁))).flatMap Entry.encode)) + (directBinaryInstructionTime tapes op store destination sourceβ‚€ + source₁) := by + have houtputParked := hasBinaryPrefix_parked houtput + have hlhs := entryLookupStatic_hoareTime_internal tapes.lhsLookup store + sourceβ‚€ initialWork inpβ‚€ outβ‚€ hinitial hinput houtputParked + have hrhs : (entryLookupStaticTM tapes.rhsLookup source₁).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.lhsLookup store sourceβ‚€ + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryOperandsResult tapes store sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (entryLookupStaticTime tapes.rhsLookup store source₁) := by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + have hready := rhsReady_of_lhs_internal tapes store sourceβ‚€ initialWork work + hinitial hrhsβ‚€ hlhsResult + have hrun := entryLookupStatic_hoareTime_internal tapes.rhsLookup store + source₁ work inpβ‚€ outβ‚€ hready hinput houtputParked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hrhsResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, hlhsResult, hrhsResult⟩, hfinalOutput⟩ + have haddress : + (TM.binaryAddConstTM tapes.update.entry.query destination).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryOperandsResult tapes store sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryAddressResult tapes store destination sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + rintro inp work out ⟨hinp, operands, hout⟩ + rcases operands with ⟨lhsWork, hlhsResult, hrhsResult⟩ + have hquery : (work tapes.update.entry.query).HasBinaryNat 0 := by + refine ⟨?_, ?_⟩ + Β· exact hrhsResult.scanner.queryStart + Β· simpa using! hrhsResult.scanner.query + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inp work out hquery + (by simpa [hinp] using! hinput) + (fun i _ => hrhsResult.parked i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, + hfinalInput.trans hinp, ?_, hfinalOutput.trans hout⟩ + exact ⟨work, ⟨lhsWork, hlhsResult, hrhsResult⟩, + by simpa only [zero_add] using! hfinalWork⟩ + have hupdate : (binaryInstructionUpdateTM tapes op).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryAddressResult tapes store destination sourceβ‚€ source₁ + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryInstructionResult tapes op store destination sourceβ‚€ + source₁ initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (op.eval (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁))).flatMap Entry.encode)) + (binaryInstructionUpdateTime tapes op store destination + (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁)) := by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := directAddress_ready tapes store destination sourceβ‚€ + source₁ initialWork work hinitial hreplacement htmp hdbl haddressResult + have hrun := binaryInstructionUpdateTM_hoareTime_frame_internal tapes op + store destination (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁) emittedBits work inpβ‚€ outβ‚€ + hcanonical hready.scanner hready.lhs hready.rhs hready.replacement + hready.shift hready.tmp hready.dbl hready.remaining hready.found + hready.resultCount hinput hready.parked houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hupdateResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, haddressResult, hupdateResult⟩, hfinalOutput⟩ + have haddressUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (binaryInstructionUpdateTM tapes op) haddress + (by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := directAddress_ready tapes store destination sourceβ‚€ + source₁ initialWork work hinitial hreplacement htmp hdbl + haddressResult + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hready.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, haddressResult, hout⟩) + hupdate + have hrhsRest := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.rhsLookup source₁) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (binaryInstructionUpdateTM tapes op)) hrhs + (by + rintro inp work out ⟨hinp, operands, hout⟩ + rcases operands with ⟨lhsWork, hlhsResult, hrhsResult⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hrhsResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨lhsWork, hlhsResult, hrhsResult⟩, hout⟩) + haddressUpdate + have hall := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.lhsLookup sourceβ‚€) + (TM.seqTM (entryLookupStaticTM tapes.rhsLookup source₁) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (binaryInstructionUpdateTM tapes op))) hlhs + (by + rintro inp work out ⟨hinp, hlhsResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hlhsResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, hlhsResult, hout⟩) + hrhsRest + simpa [directBinaryInstructionTM, directBinaryInstructionTime] using! hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dispatch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dispatch.lean new file mode 100644 index 0000000000..f651b345b5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Dispatch.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Data +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Internal + +/-! +# Fixed-program sparse RAM dispatch + +The dispatch machine copies the canonical PC, walks a fixed decrementing +branch tree, and runs the selected instruction with a uniform next-store work +buffer. This surface currently exposes its structural transducer and coarse +all-prefix space certificates; semantic selection is proved in the internal +execution layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +private theorem parked_blank : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.move, Tape.init, show j β‰  0 by omega] + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem copyWorkToWorkTM_isTransducer {n : β„•} + (source destination : Fin n) : + (TM.copyWorkToWorkTM source destination).IsTransducer := by + intro state iHead wHeads oHead + cases state <;> dsimp only [TM.copyWorkToWorkTM, TM.allIdle] + Β· split <;> simp only [TM.idleDir] <;> split <;> decide + Β· simp only [TM.idleDir] + split <;> decide + +/-- Pure branch-tree selection agrees with list lookup and the RAM model's +out-of-range `halt` convention. -/ +theorem selectedInstruction_eq_getElem?_getD (program : Program) + (selector : β„•) : + selectedInstruction program selector = + (program[selector]?).getD Instr.halt := by + induction program generalizing selector with + | nil => simp [selectedInstruction] + | cons instruction program ih => + cases selector with + | zero => simp [selectedInstruction] + | succ selector => simp [selectedInstruction, ih] + +/-- Public generic correctness rule for the finite decrementing dispatch +tree. -/ +theorem dispatchProgramTM_hoareTime_of_execute {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : DispatchReady tapes store pcValue selector cleanWork workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) + (hexecute : βˆ€ instruction, + (executeInstructionTM tapes instruction).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes instruction pcValue store work ∧ + out = outβ‚€) + (executeInstructionTime tapes instruction pcValue store)) : + (dispatchProgramTM tapes program).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction program selector) pcValue store work ∧ + out = outβ‚€) + (dispatchProgramTime tapes store pcValue program selector) := + dispatchProgramTM_hoareTime_of_execute_internal tapes program store pcValue + selector cleanWork workβ‚€ inpβ‚€ outβ‚€ hready hinput houtput hexecute + +/-- Every statically selected RAM instruction realizes the common buffered +snapshot-step contract. -/ +theorem executeInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (store : Store) (pcValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes instruction).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes instruction pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes instruction pcValue store) := by + have hblank := parked_blank + cases instruction with + | imm destination value => + exact executeInstructionTM_imm_hoareTime_frame tapes store pcValue + destination value initialWork inpβ‚€ hready hinput + | add destination sourceβ‚€ source₁ => + exact executeInstructionTM_add_hoareTime_frame tapes store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + | sub destination sourceβ‚€ source₁ => + exact executeInstructionTM_sub_hoareTime_frame tapes store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + | mul destination sourceβ‚€ source₁ => + exact executeInstructionTM_mul_hoareTime_frame tapes store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + | load destination addressRegister => + exact executeInstructionTM_load_hoareTime_frame tapes store pcValue + destination addressRegister initialWork inpβ‚€ hready hinput + | store addressRegister source => + exact executeInstructionTM_store_hoareTime_frame tapes store pcValue + addressRegister source initialWork inpβ‚€ hready hinput + | jz source target => + exact executeInstructionTM_jz_hoareTime_frame tapes store pcValue source + target initialWork inpβ‚€ ((Tape.init []).move Dir3.right) hready hinput + hblank + | jmp target => + exact executeInstructionTM_jmp_hoareTime_frame tapes store pcValue target + initialWork inpβ‚€ ((Tape.init []).move Dir3.right) hready hinput hblank + | halt => + exact executeInstructionTM_halt_hoareTime_frame tapes store pcValue + initialWork inpβ‚€ ((Tape.init []).move Dir3.right) hready hinput hblank + +/-- Copy the canonical PC into dispatch scratch, select the fixed program +instruction, and realize one exact sparse snapshot step. -/ +theorem programInstructionTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programInstructionTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction program pcValue) pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (programInstructionTime tapes program pcValue store) := by + let selectorTape := + (Tape.init (pcValue.bits.map Ξ“.ofBool)).move Dir3.right + let selectorWork := + Function.update initialWork tapes.liftedLhs selectorTape + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame tapes.liftedPC + tapes.liftedLhs tapes.liftedFound tapes.lifted.pc_ne_lhs + (tapes.lifted.pc_ne 11) (tapes.lifted.data.ne (by decide)) pcValue 0 + inpβ‚€ initialWork ((Tape.init []).move Dir3.right) hready.control.pc + hready.control.lookup.destination hready.control.lookup.copyScratch hinput + (fun i _ _ _ => hready.control.lookup.scanner.parked i) parked_blank + have hselectorReady : DispatchReady tapes store pcValue pcValue initialWork + selectorWork := by + exact ⟨hready, rfl⟩ + have hdispatch := dispatchProgramTM_hoareTime_of_execute tapes program store + pcValue pcValue initialWork selectorWork inpβ‚€ + ((Tape.init []).move Dir3.right) hselectorReady hinput parked_blank + (fun instruction => executeInstructionTM_hoareTime_frame tapes instruction + store pcValue initialWork inpβ‚€ hready hinput) + have hselectorParked : βˆ€ i, TM.Parked (selectorWork i) := by + intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [selectorWork, Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat pcValue) + Β· simp only [selectorWork, Function.update_of_ne hi] + exact hready.control.lookup.scanner.parked i + have hseq := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (dispatchProgramTM tapes program) hcopy + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have houtParked : TM.Parked out := by simpa [hout] using parked_blank + have hworkParked : βˆ€ i, TM.Parked (work i) := by + simpa [hworkEq, selectorWork, selectorTape] using hselectorParked + obtain ⟨hi, hw, ho⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hinpParked.read_ne_start + (fun i => (hworkParked i).read_ne_start) + houtParked.read_ne_start + rw [hi, hw, ho] + exact ⟨hinp, by simpa [selectorWork, selectorTape] using hworkEq, hout⟩) + hdispatch + simpa only [programInstructionTM, programInstructionTime, selectorWork, + selectorTape] using hseq + +/-- Restore the clean instruction ABI after a buffered instruction result. -/ +theorem instructionCleanupTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (pcValue : β„•) (store : Store) (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : InstructionCleanupReady tapes instruction pcValue store + sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (instructionCleanupTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes + (instructionStore instruction pcValue store) + (instructionPC instruction pcValue store) work ∧ + out = outβ‚€) + (instructionCleanupTime tapes instruction pcValue store + sourceHeadBound) := + instructionCleanupTM_hoareTime_frame_internal tapes instruction pcValue + store sourceHeadBound initialWork inpβ‚€ outβ‚€ hready hinput houtput + +/-- One fixed-program RAM step returns directly to the reusable clean ABI for +the exact successor sparse snapshot. -/ +theorem programStepTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programStepTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + let next := + ({ pc := pcValue, store := store } : Snapshot).step program + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes next.store next.pc work ∧ + out = (Tape.init []).move Dir3.right) + (programStepTime tapes program pcValue store) := by + have hstep := programStepTM_hoareTime_frame_internal tapes program store + pcValue initialWork inpβ‚€ hready hinput + (programInstructionTM_hoareTime_frame tapes program store pcValue + initialWork inpβ‚€ hready hinput) + refine hstep.consequence (fun _ _ _ h => h) ?_ le_rfl + rintro inp work out ⟨hinp, hnext, hout⟩ + refine ⟨hinp, ?_, hout⟩ + simpa [instructionStore, instructionPC, Snapshot.step, Snapshot.curInstr, + selectedInstruction_eq_getElem?_getD] using hnext + +/-- Control execution followed by unchanged-store copying is append-only on +the real output tape. -/ +theorem finishControlInstructionTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (control : TM (n + 1)) + (hcontrol : control.IsTransducer) : + (finishControlInstructionTM tapes control).IsTransducer := + hcontrol.seqTM + (copyWorkToWorkTM_isTransducer tapes.liftedSource tapes.buffer) + +/-- Every statically selected RAM instruction is append-only on real output. -/ +theorem executeInstructionTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) : + (executeInstructionTM tapes instruction).IsTransducer := by + cases instruction with + | imm destination value => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | add destination sourceβ‚€ source₁ => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | sub destination sourceβ‚€ source₁ => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | mul destination sourceβ‚€ source₁ => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | load destination addressRegister => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | store addressRegister source => + exact (TM.retargetOutput_isTransducer _).seqTM + (TM.binarySuccTM_isTransducer tapes.liftedPC) + | jz source target => + exact finishControlInstructionTM_isTransducer tapes _ + (zeroJumpInstructionTM_isTransducer tapes.lifted source target) + | jmp target => + exact finishControlInstructionTM_isTransducer tapes _ + (jumpInstructionTM_isTransducer tapes.lifted target) + | halt => + exact finishControlInstructionTM_isTransducer tapes _ + haltInstructionTM_isTransducer + +/-- Every node of the fixed finite dispatch tree preserves one-way output. -/ +theorem dispatchProgramTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) : + (dispatchProgramTM tapes program).IsTransducer := by + induction program with + | nil => + simpa only [dispatchProgramTM] using + ((TM.resetBinaryWorkTM_isTransducer tapes.liftedLhs).seqTM + (executeInstructionTM_isTransducer tapes .halt)) + | cons instruction program ih => + simpa only [dispatchProgramTM] using + ((executeInstructionTM_isTransducer tapes instruction).branchWorkBlankTM + ((TM.binaryPredTM_isTransducer tapes.liftedLhs).seqTM ih)) + +/-- Fixed-program selection followed by selected execution preserves one-way +output. -/ +theorem programInstructionTM_isTransducer {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) : + (programInstructionTM tapes program).IsTransducer := + (TM.binaryCopyIntoTM_isTransducer tapes.liftedPC tapes.liftedLhs + tapes.liftedFound).seqTM (dispatchProgramTM_isTransducer tapes program) + +/-- Every prefix of fixed-program selection and execution stays within the +initial auxiliary space plus its advertised total running-time bound. -/ +theorem programInstructionTM_prefix_withinAuxSpace {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (pcValue : β„•) (store : Store) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg (n + 1) + (programInstructionTM tapes program).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (programInstructionTM tapes program).reachesIn time start current) + (htime : time ≀ programInstructionTime tapes program pcValue store) : + current.WithinAuxSpace inputLength + (initialSpace + programInstructionTime tapes program pcValue store) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Immediate.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Immediate.lean new file mode 100644 index 0000000000..089fef93e5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Immediate.lean @@ -0,0 +1,357 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs + +/-! +# Immediate sparse-store instructions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +theorem immediateUpdate_ready_internal + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value : β„•) (initialWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) : + let valueWork := Function.update initialWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update valueWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + EntryScanReady tapes.update.entry (store.flatMap Entry.encode) + destination.bits updateWork updateWork ∧ + (updateWork tapes.update.replacement).HasBinaryNat value ∧ + (updateWork tapes.update.remaining).HasBinaryNat store.length ∧ + (updateWork tapes.update.found).HasBinaryNat 0 ∧ + (updateWork tapes.update.resultCount).HasBinaryNat store.length ∧ + βˆ€ i, TM.Parked (updateWork i) := by + dsimp only + let valueTape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + let queryTape := + (Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right + let valueWork := Function.update initialWork tapes.update.replacement valueTape + let updateWork := Function.update valueWork tapes.update.entry.query queryTape + have hsourceReplacement : + tapes.update.entry.source β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hsourceQuery : + tapes.update.entry.source β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressReplacement : + tapes.update.entry.address β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressQuery : + tapes.update.entry.address β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueReplacement : + tapes.update.entry.value β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueQuery : + tapes.update.entry.value β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressCounterReplacement : + tapes.update.entry.addressCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressCounterQuery : + tapes.update.entry.addressCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressWidthReplacement : + tapes.update.entry.addressWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressWidthQuery : + tapes.update.entry.addressWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueCounterReplacement : + tapes.update.entry.valueCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueCounterQuery : + tapes.update.entry.valueCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueWidthReplacement : + tapes.update.entry.valueWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueWidthQuery : + tapes.update.entry.valueWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hqueryReplacement : + tapes.update.entry.query β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultReplacement : + tapes.update.entry.result β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultQuery : + tapes.update.entry.result β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hreplacementQuery : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hremainingReplacement : + tapes.update.remaining β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hremainingQuery : + tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundReplacement : + tapes.update.found β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hfoundQuery : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCountReplacement : + tapes.update.resultCount β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultCountQuery : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueNat := Tape.init_move_right_hasBinaryNat value + have hqueryNat := Tape.init_move_right_hasBinaryNat destination + have hscanner : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) destination.bits updateWork updateWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· simpa only [updateWork, valueWork, Function.update_of_ne hsourceQuery, + Function.update_of_ne hsourceReplacement] using! hinitial.scanner.source + Β· simpa only [updateWork, valueWork, Function.update_of_ne haddressQuery, + Function.update_of_ne haddressReplacement] using! hinitial.scanner.address + Β· simpa only [updateWork, valueWork, Function.update_of_ne haddressQuery, + Function.update_of_ne haddressReplacement] using! + hinitial.scanner.addressStart + Β· simpa only [updateWork, valueWork, Function.update_of_ne hvalueQuery, + Function.update_of_ne hvalueReplacement] using! hinitial.scanner.value + Β· simpa only [updateWork, valueWork, Function.update_of_ne hvalueQuery, + Function.update_of_ne hvalueReplacement] using! + hinitial.scanner.valueStart + Β· simpa only [updateWork, valueWork, + Function.update_of_ne haddressCounterQuery, + Function.update_of_ne haddressCounterReplacement] using! + hinitial.scanner.addressCounter + Β· simpa only [updateWork, valueWork, + Function.update_of_ne haddressWidthQuery, + Function.update_of_ne haddressWidthReplacement] using! + hinitial.scanner.addressWidth + Β· simpa only [updateWork, valueWork, + Function.update_of_ne hvalueCounterQuery, + Function.update_of_ne hvalueCounterReplacement] using! + hinitial.scanner.valueCounter + Β· simpa only [updateWork, valueWork, + Function.update_of_ne hvalueWidthQuery, + Function.update_of_ne hvalueWidthReplacement] using! + hinitial.scanner.valueWidth + Β· simpa only [updateWork, Function.update_self, queryTape] using! + hqueryNat.2 + Β· simpa only [updateWork, Function.update_self, queryTape] using! + hqueryNat.1 + Β· simpa only [updateWork, valueWork, Function.update_of_ne hresultQuery, + Function.update_of_ne hresultReplacement] using! hinitial.scanner.result + Β· simpa only [updateWork, valueWork, Function.update_of_ne hresultQuery, + Function.update_of_ne hresultReplacement] using! + hinitial.scanner.resultStart + Β· intro i + by_cases hiQuery : i = tapes.update.entry.query + Β· subst i + simpa only [updateWork, Function.update_self, queryTape] using! + (show TM.Parked queryTape from + ⟨by rw [hqueryNat.2.1], + hqueryNat.2.hasBinaryContent.cells_ne_start⟩) + Β· have hiEq : updateWork i = valueWork i := + Function.update_of_ne hiQuery _ valueWork + rw [hiEq] + by_cases hiReplacement : i = tapes.update.replacement + Β· subst i + simpa only [valueWork, Function.update_self, valueTape] using! + (show TM.Parked valueTape from + ⟨by rw [hvalueNat.2.1], + hvalueNat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [valueWork, Function.update_of_ne hiReplacement] using! + hinitial.scanner.parked i + refine ⟨hscanner, ?_, ?_, ?_, ?_, hscanner.parked⟩ + Β· simpa only [updateWork, Function.update_of_ne hreplacementQuery, + valueWork, Function.update_self, valueTape] using! hvalueNat + Β· simpa only [updateWork, Function.update_of_ne hremainingQuery, + valueWork, Function.update_of_ne hremainingReplacement] using! + hinitial.count + Β· simpa only [updateWork, Function.update_of_ne hfoundQuery, valueWork, + Function.update_of_ne hfoundReplacement] using! hinitial.copyScratch + Β· simpa only [updateWork, Function.update_of_ne hresultCountQuery, + valueWork, Function.update_of_ne hresultCountReplacement] using! + hinitial.countSource + +/-- Exact semantic and time contract for one immediate sparse assignment. -/ +theorem immediateInstructionTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (store : Store) + (destination value : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (immediateInstructionTM tapes destination value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ImmediateInstructionResult tapes store destination value initialWork + work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination value).flatMap Entry.encode)) + (immediateInstructionTime tapes store destination value) := by + let valueWork := Function.update initialWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update valueWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have houtputParked := hasBinaryPrefix_parked houtput + have hvalue := TM.binaryAddConstTM_hoareTime_frame + tapes.update.replacement value 0 inpβ‚€ initialWork outβ‚€ hreplacement + hinput (fun i _ => hinitial.scanner.parked i) houtputParked + have hvalue' : (TM.binaryAddConstTM tapes.update.replacement value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = valueWork ∧ out = outβ‚€) + (TM.binaryAddConstTime value 0) := by + simpa only [valueWork, zero_add] using! hvalue + have hquery : (TM.binaryAddConstTM tapes.update.entry.query + destination).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = valueWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = updateWork ∧ out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + have hqueryZero : (valueWork tapes.update.entry.query).HasBinaryNat 0 := by + have hqueryReplacement : + tapes.update.entry.query β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have heq : valueWork tapes.update.entry.query = + initialWork tapes.update.entry.query := + Function.update_of_ne hqueryReplacement _ initialWork + rw [heq] + exact ⟨hinitial.scanner.queryStart, by simpa using! hinitial.scanner.query⟩ + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inpβ‚€ valueWork outβ‚€ hqueryZero + hinput + (fun i _ => by + by_cases hi : i = tapes.update.replacement + Β· subst i + exact ⟨by simp [valueWork, Tape.init, Tape.move], by + simpa [valueWork] using! + (Tape.init_move_right_hasBinaryNat value).2.hasBinaryContent.cells_ne_start⟩ + Β· simpa only [valueWork, Function.update_of_ne hi] using! + hinitial.scanner.parked i) + houtputParked + simpa only [updateWork, zero_add] using! hrun + have hready := immediateUpdate_ready_internal tapes store destination value initialWork + hinitial + have hupdate := entryUpdateTM_hoareTime_frame tapes.update store destination + value emittedBits updateWork inpβ‚€ outβ‚€ hcanonical hready.1 hready.2.1 + hready.2.2.1 hready.2.2.2.1 hready.2.2.2.2.1 hinput houtput + have hupdate' : (entryUpdateTM tapes.update).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = updateWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ImmediateInstructionResult tapes store destination value initialWork + work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination value).flatMap Entry.encode)) + (entryUpdateTime tapes.update store destination value) := + hupdate.strengthen_post (by + rintro inp work out ⟨hinp, houtcome, hout, hsourceCells⟩ + refine ⟨hinp, ⟨valueWork, updateWork, rfl, rfl, houtcome, ?_⟩, hout⟩ + calc + (work tapes.update.entry.source).cells = + (updateWork tapes.update.entry.source).cells := hsourceCells + _ = (valueWork tapes.update.entry.source).cells := by + rw [show updateWork tapes.update.entry.source = + valueWork tapes.update.entry.source by + exact Function.update_of_ne (tapes.update.ne (by decide)) _ _] + _ = (initialWork tapes.update.entry.source).cells := by + rw [show valueWork tapes.update.entry.source = + initialWork tapes.update.entry.source by + exact Function.update_of_ne (tapes.update.ne (by decide)) _ _]) + have hqueryUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update) hquery + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := updateWork) (out := out) + (by simpa [hinp] using! hinput) hready.2.2.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hupdate' + have hall := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.replacement value) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update)) hvalue' + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + have hparked : βˆ€ i, TM.Parked (valueWork i) := by + intro i + by_cases hi : i = tapes.update.replacement + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat value + simpa only [valueWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [valueWork, Function.update_of_ne hi] using! + hinitial.scanner.parked i + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := valueWork) (out := out) + (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hqueryUpdate + simpa [immediateInstructionTM, immediateInstructionTime] using! hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Internal.lean new file mode 100644 index 0000000000..85ca00054e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Internal.lean @@ -0,0 +1,358 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul + +/-! +# Concrete sparse-store arithmetic instruction kernel -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem arithmeticResult_of_threeTape + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) (lhs rhs : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlhs : (finalWork tapes.lhs).HasBinaryNat lhs) + (hrhs : (finalWork tapes.rhs).HasBinaryNat rhs) + (hresult : + (finalWork tapes.update.replacement).HasBinaryNat (op.eval lhs rhs)) + (hframe : βˆ€ i, i β‰  tapes.lhs β†’ i β‰  tapes.rhs β†’ + i β‰  tapes.update.replacement β†’ finalWork i = initialWork i) + (hwork : βˆ€ i, TM.Parked (initialWork i)) + (hshift : (initialWork tapes.shift).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) : + BinaryInstructionArithmeticResult tapes op lhs rhs initialWork + finalWork := by + have hshift' : (finalWork tapes.shift).HasBinaryNat 0 := by + rw [hframe tapes.shift (tapes.ne (by decide)) (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hshift + have htmp' : (finalWork tapes.tmp).HasBinaryNat 0 := by + rw [hframe tapes.tmp (tapes.ne (by decide)) (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact htmp + have hdbl' : (finalWork tapes.dbl).HasBinaryNat 0 := by + rw [hframe tapes.dbl (tapes.ne (by decide)) (tapes.ne (by decide)) + (tapes.ne (by decide))] + exact hdbl + refine ⟨hlhs, hrhs, hresult, hshift', htmp', hdbl', ?_, ?_⟩ + Β· intro i + by_cases hilhs : i = tapes.lhs + Β· subst i + exact hasBinaryNat_parked hlhs + Β· by_cases hirhs : i = tapes.rhs + Β· subst i + exact hasBinaryNat_parked hrhs + Β· by_cases hires : i = tapes.update.replacement + Β· subst i + exact hasBinaryNat_parked hresult + Β· rw [hframe i hilhs hirhs hires] + exact hwork i + Β· intro i hilhs hirhs hires _ _ _ + exact hframe i hilhs hirhs hires + +private theorem arithmeticResult_of_sub + (tapes : BinaryInstructionTapes n) (lhs rhs : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlhs : (finalWork tapes.lhs).HasBinaryNat lhs) + (hrhs : (finalWork tapes.rhs).HasBinaryNat rhs) + (hresult : + (finalWork tapes.update.replacement).HasBinaryNat (lhs - rhs)) + (hframe : βˆ€ i, i β‰  tapes.lhs β†’ i β‰  tapes.rhs β†’ + i β‰  tapes.update.replacement β†’ finalWork i = initialWork i) + (hwork : βˆ€ i, TM.Parked (initialWork i)) + (hshift : (initialWork tapes.shift).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) : + BinaryInstructionArithmeticResult tapes .sub lhs rhs initialWork + finalWork := by + exact arithmeticResult_of_threeTape tapes .sub lhs rhs initialWork finalWork hlhs hrhs + hresult hframe hwork hshift htmp hdbl + +/-- The selected width-efficient arithmetic phase has one uniform framed +contract. -/ +theorem binaryInstructionArithmeticTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ tapes.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ tapes.rhs).HasBinaryNat rhs) + (hresult : (workβ‚€ tapes.update.replacement).HasBinaryNat 0) + (hshift : (workβ‚€ tapes.shift).HasBinaryNat 0) + (htmp : (workβ‚€ tapes.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ tapes.dbl).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (binaryInstructionArithmeticTM tapes op).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs workβ‚€ work ∧ + out = outβ‚€) + (binaryInstructionArithmeticTime op lhs rhs) := by + cases op with + | add => + exact (TM.binaryRippleAddTM_hoareTime_frame tapes.lhs tapes.rhs + tapes.update.replacement tapes.arithmeticDistinct lhs rhs inpβ‚€ workβ‚€ + outβ‚€ hlhs hrhs hresult hinput + (fun i _ _ _ => hwork i) houtput).strengthen_post (by + rintro inp work out ⟨hinp, hlhs', hrhs', hresult', hframe, hout⟩ + exact ⟨hinp, arithmeticResult_of_threeTape tapes .add lhs rhs workβ‚€ work + hlhs' hrhs' hresult' hframe hwork hshift htmp hdbl, hout⟩) + | sub => + exact (TM.binaryRippleSubTM_hoareTime_frame tapes.lhs tapes.rhs + tapes.update.replacement tapes.subtractionDistinct lhs rhs inpβ‚€ workβ‚€ + outβ‚€ hlhs hrhs hresult hinput + (fun i _ _ _ => hwork i) houtput).strengthen_post (by + rintro inp work out ⟨hinp, hlhs', hrhs', hresult', hframe, hout⟩ + exact ⟨hinp, arithmeticResult_of_sub tapes lhs rhs workβ‚€ work + hlhs' hrhs' hresult' hframe hwork hshift htmp hdbl, hout⟩) + | mul => + exact (TM.binaryShiftMulTM_hoareTime_frame tapes.mul lhs rhs inpβ‚€ workβ‚€ + outβ‚€ (by simpa using! hlhs) (by simpa using! hrhs) + (by simpa using! hresult) (by simpa using! hshift) + (by simpa using! htmp) (by simpa using! hdbl) hinput hwork + houtput).strengthen_post (by + rintro inp work out + ⟨hinp, hlhs', hrhs', hresult', hshift', htmp', hdbl', hframe, + hout⟩ + refine ⟨hinp, ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩, hout⟩ + Β· simpa using! hlhs' + Β· simpa using! hrhs' + Β· simpa using! hresult' + Β· simpa using! hshift' + Β· simpa using! htmp' + Β· simpa using! hdbl' + Β· intro i + by_cases hilhs : i = tapes.lhs + Β· subst i + exact hasBinaryNat_parked (by simpa using! hlhs') + Β· by_cases hirhs : i = tapes.rhs + Β· subst i + exact hasBinaryNat_parked (by simpa using! hrhs') + Β· by_cases hires : i = tapes.update.replacement + Β· subst i + exact hasBinaryNat_parked (by simpa using! hresult') + Β· by_cases hishift : i = tapes.shift + Β· subst i + exact hasBinaryNat_parked (by simpa using! hshift') + Β· by_cases hitmp : i = tapes.tmp + Β· subst i + exact hasBinaryNat_parked (by simpa using! htmp') + Β· by_cases hidbl : i = tapes.dbl + Β· subst i + exact hasBinaryNat_parked (by simpa using! hdbl') + Β· rw [hframe i (by simpa using! hilhs) + (by simpa using! hirhs) (by simpa using! hires) + (by simpa using! hishift) (by simpa using! hitmp) + (by simpa using! hidbl)] + exact hwork i + Β· intro i hilhs hirhs hires hishift hitmp hidbl + exact hframe i (by simpa using! hilhs) (by simpa using! hirhs) + (by simpa using! hires) (by simpa using! hishift) + (by simpa using! hitmp) (by simpa using! hidbl)) + +/-- Arithmetic feeds its canonical result directly into sparse update. -/ +theorem binaryInstructionUpdateTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (op : BinaryInstrOp) + (store : Store) (address lhs rhs : β„•) + (emittedBits : List Bool) (initialWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hready : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) address.bits initialWork initialWork) + (hlhs : (initialWork tapes.lhs).HasBinaryNat lhs) + (hrhs : (initialWork tapes.rhs).HasBinaryNat rhs) + (hresult : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hshift : (initialWork tapes.shift).HasBinaryNat 0) + (htmp : (initialWork tapes.tmp).HasBinaryNat 0) + (hdbl : (initialWork tapes.dbl).HasBinaryNat 0) + (hremaining : + (initialWork tapes.update.remaining).HasBinaryNat store.length) + (hfound : (initialWork tapes.update.found).HasBinaryNat 0) + (hresultCount : + (initialWork tapes.update.resultCount).HasBinaryNat store.length) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (initialWork i)) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (binaryInstructionUpdateTM tapes op).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionUpdateResult tapes op store address lhs rhs + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address (op.eval lhs rhs)).flatMap + Entry.encode)) + (binaryInstructionUpdateTime tapes op store address lhs rhs) := by + have harithmetic := + binaryInstructionArithmeticTM_hoareTime_frame_internal tapes op lhs rhs + inpβ‚€ initialWork outβ‚€ hlhs hrhs hresult hshift htmp hdbl hinput + hwork (hasBinaryPrefix_parked houtput) + have hupdate : (entryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionUpdateResult tapes op store address lhs rhs + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address (op.eval lhs rhs)).flatMap + Entry.encode)) + (entryUpdateTime tapes.update store address (op.eval lhs rhs)) := by + rintro inp work out ⟨hinp, harith, hout⟩ + subst inp + subst out + have hslotEq (slot : Fin 13) (hne : slot β‰  10) : + work (tapes.update.idx slot) = initialWork (tapes.update.idx slot) := + harith.frame (tapes.update.idx slot) + (tapes.update_ne_lhs slot) (tapes.update_ne_rhs slot) + (tapes.update.ne hne) (tapes.update_ne_shift slot) + (tapes.update_ne_tmp slot) (tapes.update_ne_dbl slot) + have hready' : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) address.bits work work := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := harith.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· change (work (tapes.update.idx 0)).HasBinarySuffix _ + rw [hslotEq 0 (by decide)] + exact hready.source + Β· change (work (tapes.update.idx 1)).HasBinaryPrefix [] + rw [hslotEq 1 (by decide)] + exact hready.address + Β· change (work (tapes.update.idx 1)).cells 0 = _ + rw [hslotEq 1 (by decide)] + exact hready.addressStart + Β· change (work (tapes.update.idx 2)).HasBinaryPrefix [] + rw [hslotEq 2 (by decide)] + exact hready.value + Β· change (work (tapes.update.idx 2)).cells 0 = _ + rw [hslotEq 2 (by decide)] + exact hready.valueStart + Β· change (work (tapes.update.idx 3)).HasBinaryNat 0 + rw [hslotEq 3 (by decide)] + exact hready.addressCounter + Β· change (work (tapes.update.idx 4)).HasBinaryNat 0 + rw [hslotEq 4 (by decide)] + exact hready.addressWidth + Β· change (work (tapes.update.idx 5)).HasBinaryNat 0 + rw [hslotEq 5 (by decide)] + exact hready.valueCounter + Β· change (work (tapes.update.idx 6)).HasBinaryNat 0 + rw [hslotEq 6 (by decide)] + exact hready.valueWidth + Β· change (work (tapes.update.idx 7)).HasBinaryString address.bits + rw [hslotEq 7 (by decide)] + exact hready.query + Β· change (work (tapes.update.idx 7)).cells 0 = _ + rw [hslotEq 7 (by decide)] + exact hready.queryStart + Β· change (work (tapes.update.idx 8)).HasBinaryPrefix [] + rw [hslotEq 8 (by decide)] + exact hready.result + Β· change (work (tapes.update.idx 8)).cells 0 = _ + rw [hslotEq 8 (by decide)] + exact hready.resultStart + have hremaining' : + (work tapes.update.remaining).HasBinaryNat store.length := by + change (work (tapes.update.idx 9)).HasBinaryNat _ + rw [hslotEq 9 (by decide)] + exact hremaining + have hfound' : (work tapes.update.found).HasBinaryNat 0 := by + change (work (tapes.update.idx 11)).HasBinaryNat 0 + rw [hslotEq 11 (by decide)] + exact hfound + have hresultCount' : + (work tapes.update.resultCount).HasBinaryNat store.length := by + change (work (tapes.update.idx 12)).HasBinaryNat _ + rw [hslotEq 12 (by decide)] + exact hresultCount + have hrun := entryUpdateTM_hoareTime_frame tapes.update store address + (op.eval lhs rhs) emittedBits work inpβ‚€ outβ‚€ hcanonical hready' + harith.result hremaining' hfound' hresultCount' hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, houtcome, + hfinalOutput, hsource⟩ := + hrun inpβ‚€ work outβ‚€ ⟨rfl, rfl, rfl⟩ + have hsourceInitial : + work tapes.update.entry.source = + initialWork tapes.update.entry.source := + hslotEq 0 (by decide) + refine ⟨final, time, htime, hreach, hhalt, hfinalInput, ?_, + hfinalOutput⟩ + exact ⟨work, harith, houtcome, hsource.trans + (congrArg Tape.cells hsourceInitial)⟩ + refine TM.seqTM_hoareTime (binaryInstructionArithmeticTM tapes op) + (entryUpdateTM tapes.update) + (mid := fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs initialWork work ∧ + out = outβ‚€) + (mid' := fun inp work out => + inp = inpβ‚€ ∧ + BinaryInstructionArithmeticResult tapes op lhs rhs initialWork work ∧ + out = outβ‚€) + harithmetic ?_ hupdate + rintro inp work out ⟨hinp, harith, hout⟩ + have hinread : inp.read β‰  Ξ“.start := by + rw [hinp] + exact hinput.read_ne_start + have hworkread : βˆ€ i, (work i).read β‰  Ξ“.start := + fun i => (harith.parked i).read_ne_start + have houtread : out.read β‰  Ξ“.start := by + rw [hout] + exact (hasBinaryPrefix_parked houtput).read_ne_start + have htransition := TM.phaseTransition_eq_self_of_reads_ne_start + hinread hworkread houtread + rw [htransition.1, htransition.2.1, htransition.2.2] + exact ⟨hinp, harith, hout⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Load.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Load.lean new file mode 100644 index 0000000000..3e7618f3b0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Load.lean @@ -0,0 +1,420 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static + +/-! +# Indirect sparse-store load instructions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem scanner_indirect_of_lhs + (tapes : BinaryInstructionTapes n) (store : Store) (source : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hlookup : EntryLookupStaticResult tapes.lhsLookup store source + initialWork finalWork) : + EntryScanReady tapes.indirectLoadLookup.scan.entry + (store.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := hlookup.scanner.source + address := hlookup.scanner.address + addressStart := hlookup.scanner.addressStart + value := hlookup.scanner.value + valueStart := hlookup.scanner.valueStart + addressCounter := hlookup.scanner.addressCounter + addressWidth := hlookup.scanner.addressWidth + valueCounter := hlookup.scanner.valueCounter + valueWidth := hlookup.scanner.valueWidth + query := hlookup.scanner.query + queryStart := hlookup.scanner.queryStart + result := hlookup.scanner.result + resultStart := hlookup.scanner.resultStart + parked := hlookup.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + +private theorem indirectLoaded_ready + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister : β„•) (initialWork addressWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (haddress : EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork) : + EntryLookupRestoreReady tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork := by + have hreplacementEq : addressWork tapes.update.replacement = + initialWork tapes.update.replacement := + haddress.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + have hcountSource : + (addressWork tapes.update.resultCount).HasBinaryNat store.length := by + rw [show addressWork tapes.update.resultCount = + initialWork tapes.update.resultCount by + simpa using! haddress.countSource] + simpa using! hinitial.countSource + refine + { scanner := scanner_indirect_of_lhs tapes store addressRegister + initialWork addressWork haddress + sourceStart := haddress.sourceStart + sourceHead := haddress.sourceHead + count := by simpa using! haddress.count + countSource := by simpa using! hcountSource + querySource := by simpa using! haddress.destination + destination := by + change (addressWork tapes.update.replacement).HasBinaryNat 0 + rw [hreplacementEq] + exact hreplacement + copyScratch := by simpa using! haddress.copyScratch } + +theorem scanner_updateQuery_of_indirect_internal + (tapes : BinaryInstructionTapes n) (store : Store) (destination : β„•) + (work : Fin n β†’ Tape) + (hscanner : EntryScanReady tapes.indirectLoadLookup.scan.entry + (store.flatMap Entry.encode) [] work work) : + EntryScanReady tapes.update.entry (store.flatMap Entry.encode) + destination.bits + (Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) + (Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) := by + let finalWork := Function.update work tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have hsource : tapes.update.entry.source β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddress : tapes.update.entry.address β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalue : tapes.update.entry.value β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressCounter : + tapes.update.entry.addressCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressWidth : + tapes.update.entry.addressWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueCounter : + tapes.update.entry.valueCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueWidth : + tapes.update.entry.valueWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresult : tapes.update.entry.result β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hnat := Tape.init_move_right_hasBinaryNat destination + refine + { source := by + simpa only [finalWork, Function.update_of_ne hsource] using! + hscanner.source + address := by + simpa only [finalWork, Function.update_of_ne haddress] using! + hscanner.address + addressStart := by + simpa only [finalWork, Function.update_of_ne haddress] using! + hscanner.addressStart + value := by + simpa only [finalWork, Function.update_of_ne hvalue] using! + hscanner.value + valueStart := by + simpa only [finalWork, Function.update_of_ne hvalue] using! + hscanner.valueStart + addressCounter := by + simpa only [finalWork, Function.update_of_ne haddressCounter] using! + hscanner.addressCounter + addressWidth := by + simpa only [finalWork, Function.update_of_ne haddressWidth] using! + hscanner.addressWidth + valueCounter := by + simpa only [finalWork, Function.update_of_ne hvalueCounter] using! + hscanner.valueCounter + valueWidth := by + simpa only [finalWork, Function.update_of_ne hvalueWidth] using! + hscanner.valueWidth + query := by + simpa only [finalWork, Function.update_self] using! hnat.2 + queryStart := by + simpa only [finalWork, Function.update_self] using! hnat.1 + result := by + simpa only [finalWork, Function.update_of_ne hresult] using! + hscanner.result + resultStart := by + simpa only [finalWork, Function.update_of_ne hresult] using! + hscanner.resultStart + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + intro i + by_cases hi : i = tapes.update.entry.query + Β· subst i + simpa only [finalWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [finalWork, Function.update_of_ne hi] using! hscanner.parked i + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Both indirect lookups preserve the source count used by the final store update. -/ +private theorem indirectLoaded_resultCount + (tapes : BinaryInstructionTapes n) (store : Store) (addressRegister : β„•) + (initialWork addressWork loadedWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (haddressResult : EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork) + (hloadedResult : EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork loadedWork) : + (loadedWork tapes.update.resultCount).HasBinaryNat store.length := by + rw [show loadedWork tapes.update.resultCount = + addressWork tapes.update.resultCount by + simpa using! hloadedResult.countSource] + rw [show addressWork tapes.update.resultCount = + initialWork tapes.update.resultCount by + simpa using! haddressResult.countSource] + simpa using! hinitial.countSource + +/-- Exact semantic and time contract for one indirect sparse-register load. -/ +theorem indirectLoadInstructionTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (store : Store) + (destination addressRegister : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (indirectLoadInstructionTM tapes destination addressRegister).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectLoadInstructionResult tapes store destination addressRegister + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (RegisterStore.read store + (RegisterStore.read store addressRegister))).flatMap + Entry.encode)) + (indirectLoadInstructionTime tapes store destination addressRegister) := by + have houtputParked := hasBinaryPrefix_parked houtput + have haddress := entryLookupStatic_hoareTime_internal tapes.lhsLookup store + addressRegister initialWork inpβ‚€ outβ‚€ hinitial hinput houtputParked + have hloaded : (entryLookupLoadedTM tapes.indirectLoadLookup).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork, + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork ∧ + EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork work) ∧ + out = outβ‚€) + (entryLookupLoadedTime tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister)) := by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + have hready := indirectLoaded_ready tapes store addressRegister initialWork + work hinitial hreplacement haddressResult + have hrun := entryLookupLoaded_hoareTime_internal + tapes.indirectLoadLookup store (RegisterStore.read store addressRegister) + work inpβ‚€ outβ‚€ hready hinput houtputParked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hloadedResult, hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, haddressResult, hloadedResult⟩, hfinalOutput⟩ + have hquery : + (TM.binaryAddConstTM tapes.update.entry.query destination).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork, + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork ∧ + EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork work) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork loadedWork, + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork ∧ + EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork loadedWork ∧ + work = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryAddConstTime destination 0) := by + rintro inp work out ⟨hinp, ⟨addressWork, haddressResult, + hloadedResult⟩, hout⟩ + have hqueryZero : (work tapes.update.entry.query).HasBinaryNat 0 := + ⟨hloadedResult.scanner.queryStart, by + simpa using! hloadedResult.scanner.query⟩ + have hrun := TM.binaryAddConstTM_hoareTime_frame + tapes.update.entry.query destination 0 inp work out hqueryZero + (by simpa [hinp] using! hinput) + (fun i _ => hloadedResult.parked i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨addressWork, work, haddressResult, hloadedResult, + by simpa only [zero_add] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hupdate : (entryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ addressWork loadedWork, + EntryLookupStaticResult tapes.lhsLookup store addressRegister + initialWork addressWork ∧ + EntryLookupRestoreResult tapes.indirectLoadLookup store + (RegisterStore.read store addressRegister) addressWork loadedWork ∧ + work = Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectLoadInstructionResult tapes store destination addressRegister + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store destination + (RegisterStore.read store + (RegisterStore.read store addressRegister))).flatMap + Entry.encode)) + (entryUpdateTime tapes.update store destination + (RegisterStore.read store + (RegisterStore.read store addressRegister))) := by + rintro inp work out ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, hwork⟩, hout⟩ + subst work + let updateWork := Function.update loadedWork tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right) + have hscanner := scanner_updateQuery_of_indirect_internal tapes store destination + loadedWork hloadedResult.scanner + have hreplacementNe : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hremainingNe : + tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundNe : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCountNe : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCount := indirectLoaded_resultCount tapes store addressRegister + initialWork addressWork loadedWork hinitial haddressResult hloadedResult + have hrun := entryUpdateTM_hoareTime_frame tapes.update store destination + (RegisterStore.read store (RegisterStore.read store addressRegister)) + emittedBits updateWork inpβ‚€ outβ‚€ hcanonical hscanner + (by simpa only [updateWork, Function.update_of_ne hreplacementNe] using! + hloadedResult.value) + (by simpa only [updateWork, Function.update_of_ne hremainingNe] using! + hloadedResult.count) + (by simpa only [updateWork, Function.update_of_ne hfoundNe] using! + hloadedResult.copyScratch) + (by simpa only [updateWork, Function.update_of_ne hresultCountNe] using! + hresultCount) + hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hupdateResult, hfinalOutput, hsourceCells⟩ := + hrun inp updateWork out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨addressWork, loadedWork, updateWork, haddressResult, hloadedResult, + rfl, hupdateResult, by + calc + (final.work tapes.update.entry.source).cells = + (updateWork tapes.update.entry.source).cells := hsourceCells + _ = (loadedWork tapes.update.entry.source).cells := by + rw [show updateWork tapes.update.entry.source = + loadedWork tapes.update.entry.source by + exact Function.update_of_ne (tapes.update.ne (by decide)) _ _] + _ = (addressWork tapes.update.entry.source).cells := + hloadedResult.sourceCells + _ = (initialWork tapes.update.entry.source).cells := + haddressResult.sourceCells⟩, + hfinalOutput⟩ + have hqueryUpdate := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update) hquery + (by + rintro inp work out ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, hwork⟩, hout⟩ + subst work + have hparked := (scanner_updateQuery_of_indirect_internal tapes store destination + loadedWork hloadedResult.scanner).parked + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := Function.update loadedWork + tapes.update.entry.query + ((Tape.init (destination.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨addressWork, loadedWork, haddressResult, + hloadedResult, rfl⟩, hout⟩) + hupdate + have hloadedRest := TM.seqTM_hoareTime + (entryLookupLoadedTM tapes.indirectLoadLookup) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update)) hloaded + (by + rintro inp work out ⟨hinp, ⟨addressWork, haddressResult, + hloadedResult⟩, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hloadedResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨addressWork, haddressResult, hloadedResult⟩, hout⟩) + hqueryUpdate + have hall := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.lhsLookup addressRegister) + (TM.seqTM (entryLookupLoadedTM tapes.indirectLoadLookup) + (TM.seqTM (TM.binaryAddConstTM tapes.update.entry.query destination) + (entryUpdateTM tapes.update))) haddress + (by + rintro inp work out ⟨hinp, haddressResult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) haddressResult.parked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, haddressResult, hout⟩) + hloadedRest + simpa [indirectLoadInstructionTM, indirectLoadInstructionTime] using! hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim.lean new file mode 100644 index 0000000000..2b6a9ed6a0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Data +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Control.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Control.lean new file mode 100644 index 0000000000..9baa75ae71 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Control.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput + +/-! +# Uniform next-store buffering for control instructions +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +/-- Restore the empty entry scanner after copying a control instruction's store buffer. -/ +private theorem controlCopy_entryScannerReady + (tapes : ControlInstructionTapes n) (store : Store) (newPC : β„•) + (initialWork work finalWork : Fin (n + 1) β†’ Tape) + (hcontrolResult : + ControlInstructionResult tapes.lifted store newPC initialWork work) : + let bits := store.flatMap Entry.encode + let source := tapes.liftedSource + let buffer := tapes.buffer + (βˆ€ i, i β‰  source β†’ i β‰  buffer β†’ finalWork i = work i) β†’ + (βˆ€ i, TM.Parked (finalWork i)) β†’ + (work source).HasBinarySuffix bits β†’ + (finalWork source).cells = (work source).cells β†’ + (finalWork source).head = bits.length + 1 β†’ + (finalWork source).HasOutput bits β†’ + EntryScanReady tapes.lifted.data.update.entry [] [] finalWork finalWork := by + dsimp only + intro hotherFrame hfinalParked hsourceSuffix hsourceCells + hsourceFinalHead hsourceFinalOutput + let bits := store.flatMap Entry.encode + let source := tapes.liftedSource + let buffer := tapes.buffer + let entry := tapes.lifted.data.update.entry + have hrole (slot : Fin 9) (hne : slot β‰  0) : + finalWork (entry.idx slot) = work (entry.idx slot) := by + exact hotherFrame _ (entry.ne hne) + (tapes.liftedData_ne_buffer ⟨slot, by omega⟩) + refine + { source := ?_ + address := by + change (finalWork (entry.idx 1)).HasBinaryPrefix [] + rw [hrole 1 (by decide)] + exact hcontrolResult.ready.lookup.scanner.address + addressStart := by + change (finalWork (entry.idx 1)).cells 0 = Ξ“.start + rw [hrole 1 (by decide)] + exact hcontrolResult.ready.lookup.scanner.addressStart + value := by + change (finalWork (entry.idx 2)).HasBinaryPrefix [] + rw [hrole 2 (by decide)] + exact hcontrolResult.ready.lookup.scanner.value + valueStart := by + change (finalWork (entry.idx 2)).cells 0 = Ξ“.start + rw [hrole 2 (by decide)] + exact hcontrolResult.ready.lookup.scanner.valueStart + addressCounter := by + change (finalWork (entry.idx 3)).HasBinaryNat 0 + rw [hrole 3 (by decide)] + exact hcontrolResult.ready.lookup.scanner.addressCounter + addressWidth := by + change (finalWork (entry.idx 4)).HasBinaryNat 0 + rw [hrole 4 (by decide)] + exact hcontrolResult.ready.lookup.scanner.addressWidth + valueCounter := by + change (finalWork (entry.idx 5)).HasBinaryNat 0 + rw [hrole 5 (by decide)] + exact hcontrolResult.ready.lookup.scanner.valueCounter + valueWidth := by + change (finalWork (entry.idx 6)).HasBinaryNat 0 + rw [hrole 6 (by decide)] + exact hcontrolResult.ready.lookup.scanner.valueWidth + query := by + change (finalWork (entry.idx 7)).HasBinaryString [] + rw [hrole 7 (by decide)] + exact hcontrolResult.ready.lookup.scanner.query + queryStart := by + change (finalWork (entry.idx 7)).cells 0 = Ξ“.start + rw [hrole 7 (by decide)] + exact hcontrolResult.ready.lookup.scanner.queryStart + result := by + change (finalWork (entry.idx 8)).HasBinaryPrefix [] + rw [hrole 8 (by decide)] + exact hcontrolResult.ready.lookup.scanner.result + resultStart := by + change (finalWork (entry.idx 8)).cells 0 = Ξ“.start + rw [hrole 8 (by decide)] + exact hcontrolResult.ready.lookup.scanner.resultStart + parked := hfinalParked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + change (finalWork tapes.liftedSource).HasBinarySuffix [] + refine ⟨by rw [hsourceFinalHead]; omega, ?_, ?_, ?_⟩ + Β· intro i hi + simp at hi + Β· rw [hsourceFinalHead] + simpa only [List.length_nil, Nat.add_zero] using hsourceFinalOutput.2 + Β· intro j hj + rw [hsourceCells] + exact hsourceSuffix.2.2.2 j hj + +private theorem finishControlInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue newPC : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) (control : TM (n + 1)) (controlTime : β„•) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) + (hcontrol : control.HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes.lifted store newPC initialWork work ∧ + out = outβ‚€) + controlTime) : + (finishControlInstructionTM tapes control).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + (store.flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat newPC ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + store.length ∧ + (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, (work (instructionCleanupTape tapes slot)).HasBinaryNat 0) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat store.length ∧ + EntryScanReady tapes.lifted.data.update.entry [] [] work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = outβ‚€) + (controlTime + 1 + (store.flatMap Entry.encode).length + 1) := by + let bits := store.flatMap Entry.encode + let source := tapes.liftedSource + let buffer := tapes.buffer + have hsourceBuffer : source β‰  buffer := tapes.liftedSource_ne_buffer + have hcopy : (TM.copyWorkToWorkTM source buffer).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes.lifted store newPC initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work buffer).HasBinaryPrefix bits ∧ + (work tapes.liftedPC).HasBinaryNat newPC ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat store.length ∧ + (work tapes.liftedSource).HasBinaryContent bits ∧ + (βˆ€ slot, (work (instructionCleanupTape tapes slot)).HasBinaryNat 0) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat store.length ∧ + EntryScanReady tapes.lifted.data.update.entry [] [] work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = outβ‚€) + (bits.length + 1) := by + rintro inp work out ⟨hinp, hcontrolResult, hout⟩ + have hsourceHead : (work source).head = 1 := by + exact hcontrolResult.ready.lookup.sourceHead + have hsourceSuffix : (work source).HasBinarySuffix bits := by + exact hcontrolResult.ready.lookup.scanner.source + have hsourceOutput : (work source).HasOutput bits := by + refine ⟨?_, ?_⟩ + Β· intro i hi + simpa [hsourceHead, Nat.add_comm] using! hsourceSuffix.2.1 i hi + Β· simpa [hsourceHead, Nat.add_comm] using! hsourceSuffix.2.2.1 + have hbufferEq : work buffer = (Tape.init []).move Dir3.right := by + rw [hcontrolResult.frame buffer + tapes.liftedPC_ne_buffer.symm + (fun slot => (tapes.liftedData_ne_buffer + (BinaryInstructionTapes.lhsLookupSlot slot)).symm)] + exact hready.buffer + have hcleanup : βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat 0 := by + intro slot + fin_cases slot + Β· exact ⟨hcontrolResult.ready.lookup.scanner.queryStart, + by simpa [instructionCleanupTape, instructionCleanupParentSlot] using! + hcontrolResult.ready.lookup.scanner.query⟩ + Β· change (work tapes.lifted.data.update.replacement).HasBinaryNat 0 + rw [show work tapes.lifted.data.update.replacement = + initialWork tapes.lifted.data.update.replacement from + hcontrolResult.frame _ (tapes.lifted.data_ne_pc 10) + (fun role => + (tapes.lifted.data.lhsLookup_ne_replacement role).symm)] + exact hready.replacement + Β· simpa [instructionCleanupTape, instructionCleanupParentSlot] using! + hcontrolResult.ready.lookup.copyScratch + Β· simpa [instructionCleanupTape, instructionCleanupParentSlot] using! + hcontrolResult.ready.lookup.destination + Β· change (work tapes.lifted.data.rhs).HasBinaryNat 0 + rw [show work tapes.lifted.data.rhs = initialWork tapes.lifted.data.rhs + from hcontrolResult.frame _ (tapes.lifted.data_ne_pc 14) + (fun role => (tapes.lifted.data.lhsLookup_ne_rhs role).symm)] + exact hready.rhs + let P : TM.TapePred (n + 1) := fun inp' work' out' => + inp' = inpβ‚€ ∧ out' = outβ‚€ ∧ + (work' tapes.liftedPC).HasBinaryNat newPC ∧ + (work' tapes.lifted.data.update.resultCount).HasBinaryNat store.length ∧ + (βˆ€ slot, (work' (instructionCleanupTape tapes slot)).HasBinaryNat 0) ∧ + (work' tapes.lifted.data.update.remaining).HasBinaryNat store.length ∧ + (βˆ€ i, i β‰  source β†’ i β‰  buffer β†’ TM.Parked (work' i)) ∧ + βˆ€ i, i β‰  source β†’ i β‰  buffer β†’ work' i = work i + have hP : P inp work out := by + refine ⟨hinp, hout, hcontrolResult.ready.pc, ?_, hcleanup, + hcontrolResult.ready.lookup.count, ?_, ?_⟩ + Β· exact hcontrolResult.ready.lookup.countSource + Β· intro i _ _ + exact hcontrolResult.ready.lookup.scanner.parked i + Β· intro i _ _ + rfl + have hframe := TM.copyWorkToWorkTM_hoareTime_frame_of_hasOutput + source buffer hsourceBuffer bits (work source) + (P := P) + (by + intro inp' work' out' inp'' work'' out'' hPred _ _ _ _ _ + hinpEq houtEq hworkFrame + obtain ⟨hPredInput, hPredOutput, hPredPC, hPredCount, + hPredCleanup, hPredRemaining, hPredParked, hPredFrame⟩ := hPred + refine ⟨hinpEq.trans hPredInput, houtEq.trans hPredOutput, ?_, ?_, + ?_, ?_, ?_, ?_⟩ + Β· rw [hworkFrame tapes.liftedPC tapes.liftedPC_ne_source + tapes.liftedPC_ne_buffer] + exact hPredPC + Β· have hpcResultCount : + tapes.lifted.data.update.resultCount β‰  source := by + exact tapes.lifted.data.ne (by decide) + have hresultBuffer : + tapes.lifted.data.update.resultCount β‰  buffer := by + exact tapes.liftedData_ne_buffer 12 + rw [hworkFrame _ hpcResultCount hresultBuffer] + exact hPredCount + Β· intro slot + rw [hworkFrame _ (instructionCleanupTape_ne_source tapes slot) + (instructionCleanupTape_ne_buffer tapes slot)] + exact hPredCleanup slot + Β· rw [hworkFrame tapes.lifted.data.update.remaining + (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 9)] + exact hPredRemaining + Β· intro i hiSource hiBuffer + rw [hworkFrame i hiSource hiBuffer] + exact hPredParked i hiSource hiBuffer + Β· intro i hiSource hiBuffer + rw [hworkFrame i hiSource hiBuffer] + exact hPredFrame i hiSource hiBuffer) + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [hout] using! houtput + obtain ⟨final, time, htime, hreach, hhalt, hsourceCells, + hsourceFinalHead, hsourceFinalOutput, hbufferPrefix, _hbufferStart, + hfinalInput, hfinalOutput, hfinalPC, hfinalCount, hfinalCleanup, + hfinalRemaining, hotherParked, hotherFrame⟩ := + hframe inp work out + ⟨rfl, hsourceHead, hsourceOutput, hbufferEq, + hinpParked.read_ne_start, + houtParked.read_ne_start, + houtParked.1, + (fun i hiSource hiBuffer => + ⟨(hcontrolResult.ready.lookup.scanner.parked i).read_ne_start, + (hcontrolResult.ready.lookup.scanner.parked i).1⟩), + hP⟩ + have hfinalSourceContent : + (final.work source).HasBinaryContent bits := by + have hsourceInitial : (work source).cells = + (initialWork source).cells := hcontrolResult.sourceCells + unfold Tape.HasBinaryContent + rw [hsourceCells, hsourceInitial] + exact hready.sourceContent + have hfinalParked : βˆ€ i, TM.Parked (final.work i) := by + intro i + by_cases hiSource : i = source + Β· subst i + refine ⟨by omega, ?_⟩ + intro j hj + rw [hsourceCells] + exact hsourceSuffix.2.2.2 j hj + by_cases hiBuffer : i = buffer + Β· subst i + exact hasBinaryPrefix_parked hbufferPrefix + Β· exact hotherParked i hiSource hiBuffer + have hfinalScanner : EntryScanReady + tapes.lifted.data.update.entry [] [] final.work final.work := by + exact controlCopy_entryScannerReady tapes store newPC initialWork work + final.work hcontrolResult hotherFrame hfinalParked hsourceSuffix + hsourceCells hsourceFinalHead hsourceFinalOutput + have hfinalShift : + (final.work tapes.lifted.data.shift).HasBinaryNat 0 := by + change (final.work (tapes.lifted.data.idx 15)).HasBinaryNat 0 + rw [hotherFrame _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 15)] + exact hcontrolResult.ready.lookup.querySource + have hfinalTmp : + (final.work tapes.lifted.data.tmp).HasBinaryNat 0 := by + change (final.work (tapes.lifted.data.idx 16)).HasBinaryNat 0 + rw [hotherFrame _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 16)] + rw [hcontrolResult.frame _ (tapes.lifted.data_ne_pc 16) + (fun slot => (tapes.lifted.data.lhsLookup_ne_tmp slot).symm)] + exact hready.tmp + have hfinalDbl : + (final.work tapes.lifted.data.dbl).HasBinaryNat 0 := by + change (final.work (tapes.lifted.data.idx 17)).HasBinaryNat 0 + rw [hotherFrame _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 17)] + rw [hcontrolResult.frame _ (tapes.lifted.data_ne_pc 17) + (fun slot => (tapes.lifted.data.lhsLookup_ne_dbl slot).symm)] + exact hready.dbl + refine ⟨final, time, htime, hreach, hhalt, hfinalInput, + hbufferPrefix, hfinalPC, hfinalCount, hfinalSourceContent, + hfinalCleanup, hfinalRemaining, hfinalScanner, hfinalShift, hfinalTmp, + hfinalDbl, hfinalParked, hfinalOutput⟩ + have hseq := TM.seqTM_hoareTime control + (TM.copyWorkToWorkTM source buffer) hcontrol + (by + rintro inp work out ⟨hinp, hcontrolResult, hout⟩ + have hworkParked := hcontrolResult.ready.lookup.scanner.parked + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [hout] using! houtput + obtain ⟨hi, hw, ho⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hinpParked.read_ne_start + (fun i => (hworkParked i).read_ne_start) + houtParked.read_ne_start + rw [hi, hw, ho] + exact ⟨hinp, hcontrolResult, hout⟩) + hcopy + simpa only [finishControlInstructionTM, bits, source, buffer] using! hseq + +/-- Representation-independent form of the control-instruction finisher. +Control instructions preserve the encoded store, leave zero on every cleanup +role, and retain the old entry count for the generic cleanup pass. -/ +theorem finishBufferedControlInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue newPC : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) (control : TM (n + 1)) (controlTime : β„•) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) + (hcontrol : control.HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + ControlInstructionResult tapes.lifted store newPC initialWork work ∧ + out = outβ‚€) + controlTime) : + (finishControlInstructionTM tapes control).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BufferedInstructionResult tapes store store newPC (fun _ => 0) + store.length work ∧ + out = outβ‚€) + (controlTime + 1 + (store.flatMap Entry.encode).length + 1) := by + have hfinish := finishControlInstructionTM_hoareTime_frame_internal tapes + store pcValue newPC initialWork inpβ‚€ outβ‚€ control controlTime hready + hinput houtput hcontrol + apply hfinish.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, hout⟩ + exact ⟨hinp, + { buffer := hbuffer + pc := hpc + resultCount := hcount + sourceContent := hsourceContent + cleanup := hcleanup + remaining := hremaining + scanner := hscanner + shift := hshift + tmp := htmp + dbl := hdbl + parked := hparked }, + hout⟩ + Β· exact le_rfl + +/-- Conditional-zero execution has the common one-buffer instruction +contract. -/ +theorem executeInstructionTM_jz_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue source target : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (executeInstructionTM tapes (.jz source target)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.jz source target) pcValue store + work ∧ + out = outβ‚€) + (executeInstructionTime tapes (.jz source target) pcValue store) := by + have hcontrol := zeroJumpInstructionTM_hoareTime_frame tapes.lifted store + pcValue source target initialWork inpβ‚€ outβ‚€ hready.control hinput houtput + have hfinish := finishControlInstructionTM_hoareTime_frame_internal tapes + store pcValue + (if RegisterStore.read store source = 0 then target else pcValue + 1) + initialWork inpβ‚€ outβ‚€ _ _ hready hinput houtput hcontrol + apply hfinish.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, hout⟩ + by_cases hzero : RegisterStore.read store source = 0 + Β· exact ⟨hinp, + { buffer := by + simpa [instructionStore, Snapshot.stepInstr, hzero] using! hbuffer + pc := by + simpa [instructionPC, Snapshot.stepInstr, hzero] using! hpc + resultCount := by + simpa [instructionStore, Snapshot.stepInstr, hzero] using! hcount + sourceContent := hsourceContent + cleanup := by + intro slot + have hvalue : instructionCleanupValue (.jz source target) store + slot = 0 := by + fin_cases slot <;> rfl + rw [hvalue] + exact hcleanup slot + remaining := by + simpa [instructionRemainingValue] using! hremaining + scanner := by + simpa [instructionCleanupValue] using! hscanner + shift := hshift + tmp := htmp + dbl := hdbl + parked := hparked }, + hout⟩ + Β· exact ⟨hinp, + { buffer := by + simpa [instructionStore, Snapshot.stepInstr, hzero] using! hbuffer + pc := by + simpa [instructionPC, Snapshot.stepInstr, hzero] using! hpc + resultCount := by + simpa [instructionStore, Snapshot.stepInstr, hzero] using! hcount + sourceContent := hsourceContent + cleanup := by + intro slot + have hvalue : instructionCleanupValue (.jz source target) store + slot = 0 := by + fin_cases slot <;> rfl + rw [hvalue] + exact hcleanup slot + remaining := by + simpa [instructionRemainingValue] using! hremaining + scanner := by + simpa [instructionCleanupValue] using! hscanner + shift := hshift + tmp := htmp + dbl := hdbl + parked := hparked }, + hout⟩ + Β· exact le_rfl + +/-- Unconditional-jump execution has the common one-buffer instruction +contract. -/ +theorem executeInstructionTM_jmp_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue target : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (executeInstructionTM tapes (.jmp target)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.jmp target) pcValue store work ∧ + out = outβ‚€) + (executeInstructionTime tapes (.jmp target) pcValue store) := by + have hcontrol := jumpInstructionTM_hoareTime_frame tapes.lifted store + pcValue target initialWork inpβ‚€ outβ‚€ hready.control hinput houtput + have hfinish := finishControlInstructionTM_hoareTime_frame_internal tapes + store pcValue target initialWork inpβ‚€ outβ‚€ _ _ hready hinput houtput + hcontrol + apply hfinish.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, hout⟩ + exact ⟨hinp, + { buffer := by + simpa [instructionStore, Snapshot.stepInstr] using! hbuffer + pc := by simpa [instructionPC, Snapshot.stepInstr] using! hpc + resultCount := by + simpa [instructionStore, Snapshot.stepInstr] using! hcount + sourceContent := hsourceContent + cleanup := by + intro slot + have hvalue : instructionCleanupValue (.jmp target) store slot = 0 := by + fin_cases slot <;> rfl + rw [hvalue] + exact hcleanup slot + remaining := by + simpa [instructionRemainingValue] using! hremaining + scanner := by + simpa [instructionCleanupValue] using! hscanner + shift := hshift + tmp := htmp + dbl := hdbl + parked := hparked }, + hout⟩ + Β· exact le_rfl + +/-- Halt execution has the common one-buffer instruction contract. -/ +theorem executeInstructionTM_halt_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (executeInstructionTM tapes .halt).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes .halt pcValue store work ∧ + out = outβ‚€) + (executeInstructionTime tapes .halt pcValue store) := by + have hcontrol := haltInstructionTM_hoareTime_frame tapes.lifted store + pcValue initialWork inpβ‚€ outβ‚€ hready.control hinput houtput + have hfinish := finishControlInstructionTM_hoareTime_frame_internal tapes + store pcValue pcValue initialWork inpβ‚€ outβ‚€ _ _ hready hinput houtput + hcontrol + apply hfinish.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, hout⟩ + exact ⟨hinp, + { buffer := by + simpa [instructionStore, Snapshot.stepInstr] using! hbuffer + pc := by simpa [instructionPC, Snapshot.stepInstr] using! hpc + resultCount := by + simpa [instructionStore, Snapshot.stepInstr] using! hcount + sourceContent := hsourceContent + cleanup := by + intro slot + have hvalue : instructionCleanupValue .halt store slot = 0 := by + fin_cases slot <;> rfl + rw [hvalue] + exact hcleanup slot + remaining := by + simpa [instructionRemainingValue] using! hremaining + scanner := by + simpa [instructionCleanupValue] using! hscanner + shift := hshift + tmp := htmp + dbl := hdbl + parked := hparked }, + hout⟩ + Β· exact le_rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Data.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Data.lean new file mode 100644 index 0000000000..9291ec5069 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Data.lean @@ -0,0 +1,1415 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction + +/-! +# Uniform next-store buffering for data instructions +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +/-- Restrict the lifted clean lookup ABI to the original data-tape family. -/ +theorem instructionExecutionReady_baseLookup_internal + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (work : Fin (n + 1) β†’ Tape) + (hready : InstructionExecutionReady tapes store pcValue work) : + EntryLookupStaticReady tapes.data.lhsLookup store + (fun i => work (Fin.castSucc i)) := by + let baseWork : Fin n β†’ Tape := fun i => work (Fin.castSucc i) + have hcastNe {i j : Fin n} (h : i β‰  j) : + Fin.castSucc i β‰  Fin.castSucc j := by + intro hij + exact h (Fin.castSucc_injective _ hij) + have hscanner : EntryScanReady tapes.data.lhsLookup.scan.entry + (store.flatMap Entry.encode) [] baseWork baseWork := by + let hs := hready.control.lookup.scanner + refine + { source := hs.source + address := hs.address + addressStart := hs.addressStart + value := hs.value + valueStart := hs.valueStart + addressCounter := hs.addressCounter + addressWidth := hs.addressWidth + valueCounter := hs.valueCounter + valueWidth := hs.valueWidth + query := hs.query + queryStart := hs.queryStart + result := hs.result + resultStart := hs.resultStart + parked := fun i => hs.parked (Fin.castSucc i) + frame := ?_ } + intro i hsource haddress hvalue haddressCounter haddressWidth + hvalueCounter hvalueWidth hquery hresult + exact hs.frame (Fin.castSucc i) (hcastNe hsource) (hcastNe haddress) + (hcastNe hvalue) (hcastNe haddressCounter) (hcastNe haddressWidth) + (hcastNe hvalueCounter) (hcastNe hvalueWidth) (hcastNe hquery) + (hcastNe hresult) + exact + { scanner := hscanner + sourceStart := hready.control.lookup.sourceStart + sourceHead := hready.control.lookup.sourceHead + count := hready.control.lookup.count + countSource := hready.control.lookup.countSource + querySource := hready.control.lookup.querySource + destination := hready.control.lookup.destination + copyScratch := hready.control.lookup.copyScratch } + +private theorem entryScanReady_of_role_frame {m : β„•} + (tapes : EntryMatchTapes m) (sourceBits queryBits : List Bool) + (initialWork finalWork : Fin m β†’ Tape) + (hready : EntryScanReady tapes sourceBits queryBits initialWork initialWork) + (hframe : βˆ€ slot, finalWork (tapes.idx slot) = + initialWork (tapes.idx slot)) + (hparked : βˆ€ i, TM.Parked (finalWork i)) : + EntryScanReady tapes sourceBits queryBits finalWork finalWork := by + refine + { source := by rw [show finalWork tapes.source = initialWork tapes.source + from hframe 0]; exact hready.source + address := by rw [show finalWork tapes.address = initialWork tapes.address + from hframe 1]; exact hready.address + addressStart := by + rw [show finalWork tapes.address = initialWork tapes.address + from hframe 1]; exact hready.addressStart + value := by rw [show finalWork tapes.value = initialWork tapes.value + from hframe 2]; exact hready.value + valueStart := by rw [show finalWork tapes.value = initialWork tapes.value + from hframe 2]; exact hready.valueStart + addressCounter := by + rw [show finalWork tapes.addressCounter = + initialWork tapes.addressCounter from hframe 3] + exact hready.addressCounter + addressWidth := by + rw [show finalWork tapes.addressWidth = initialWork tapes.addressWidth + from hframe 4] + exact hready.addressWidth + valueCounter := by + rw [show finalWork tapes.valueCounter = initialWork tapes.valueCounter + from hframe 5] + exact hready.valueCounter + valueWidth := by + rw [show finalWork tapes.valueWidth = initialWork tapes.valueWidth + from hframe 6] + exact hready.valueWidth + query := by rw [show finalWork tapes.query = initialWork tapes.query + from hframe 7]; exact hready.query + queryStart := by rw [show finalWork tapes.query = initialWork tapes.query + from hframe 7]; exact hready.queryStart + result := by rw [show finalWork tapes.result = initialWork tapes.result + from hframe 8]; exact hready.result + resultStart := by + rw [show finalWork tapes.result = initialWork tapes.result + from hframe 8]; exact hready.resultStart + parked := hparked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + +/-- Lift a scanner-ready state on the initial tape family to the one-buffer +layout. The scanner roles all live below the fresh final tape. -/ +private theorem entryScanReady_lifted {m : β„•} + (tapes : EntryMatchTapes m) (sourceBits queryBits : List Bool) + (work : Fin (m + 1) β†’ Tape) + (hready : EntryScanReady tapes sourceBits queryBits + (fun i => work (Fin.castSucc i)) (fun i => work (Fin.castSucc i))) + (hparked : βˆ€ i, TM.Parked (work i)) : + EntryScanReady + { idx := fun slot => Fin.castSucc (tapes.idx slot) + injective := by + intro i j h + apply tapes.injective + exact Fin.castSucc_injective _ h } + sourceBits queryBits work work := by + refine + { source := hready.source + address := hready.address + addressStart := hready.addressStart + value := hready.value + valueStart := hready.valueStart + addressCounter := hready.addressCounter + addressWidth := hready.addressWidth + valueCounter := hready.valueCounter + valueWidth := hready.valueWidth + query := hready.query + queryStart := hready.queryStart + result := hready.result + resultStart := hready.resultStart + parked := hparked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + +/-- Increment the PC after a redirected data kernel satisfying the common +pre-successor boundary. -/ +theorem finishBufferedDataTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (nextPC pcValue : β„•) (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) (dataTM : TM n) (dataTime : β„•) + (hpcNext : nextPC = pcValue + 1) + (hinput : TM.Parked inpβ‚€) + (hdata : dataTM.retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + (nextStore.flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + nextStore.length ∧ + (work tapes.liftedSource).HasBinaryContent + (oldStore.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + remainingValue ∧ + EntryScanReady tapes.lifted.data.update.entry [] + (cleanupValues 0).bits work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = (Tape.init []).move Dir3.right) + dataTime) : + (TM.seqTM dataTM.retargetOutput + (TM.binarySuccTM tapes.liftedPC)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + BufferedInstructionResult tapes oldStore nextStore nextPC + cleanupValues remainingValue work ∧ + out = (Tape.init []).move Dir3.right) + (dataTime + 1 + TM.binarySuccTime pcValue) := by + let outβ‚€ := (Tape.init []).move Dir3.right + have hout : TM.Parked outβ‚€ := + hasBinaryPrefix_parked Tape.init_nil_move_right_hasBinaryPrefix_nil + have hsucc : (TM.binarySuccTM tapes.liftedPC).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + (nextStore.flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + nextStore.length ∧ + (work tapes.liftedSource).HasBinaryContent + (oldStore.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + remainingValue ∧ + EntryScanReady tapes.lifted.data.update.entry [] + (cleanupValues 0).bits work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + BufferedInstructionResult tapes oldStore nextStore nextPC + cleanupValues remainingValue work ∧ + out = outβ‚€) + (TM.binarySuccTime pcValue) := by + rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, houtEq⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [houtEq] using! hout + have hrun := TM.binarySuccTM_hoareTime_frame tapes.liftedPC pcValue + inp work out hpc hinpParked.read_ne_start + (fun i _ => (hparked i).read_ne_start) houtParked.read_ne_start + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, hframe, + hfinalPC, hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ?_, hfinalOutput.trans houtEq⟩ + refine + { buffer := ?_ + pc := ?_ + resultCount := ?_ + sourceContent := ?_ + cleanup := ?_ + remaining := ?_ + scanner := ?_ + shift := ?_ + tmp := ?_ + dbl := ?_ + parked := ?_ } + Β· rw [hframe tapes.buffer tapes.liftedPC_ne_buffer.symm] + exact hbuffer + Β· rw [hpcNext] + exact hfinalPC + Β· rw [hframe tapes.lifted.data.update.resultCount + (tapes.lifted.data_ne_pc 12)] + exact hcount + Β· rw [hframe tapes.liftedSource tapes.liftedPC_ne_source.symm] + exact hsourceContent + Β· intro slot + rw [show final.work (instructionCleanupTape tapes slot) = + work (instructionCleanupTape tapes slot) from + hframe _ (tapes.lifted.data_ne_pc + (instructionCleanupParentSlot slot))] + exact hcleanup slot + Β· rw [hframe tapes.lifted.data.update.remaining + (tapes.lifted.data_ne_pc 9)] + exact hremaining + Β· exact entryScanReady_of_role_frame _ _ _ _ _ hscanner + (fun slot => hframe _ (tapes.lifted.pc_ne ⟨slot, by omega⟩).symm) + (by + intro i + by_cases hi : i = tapes.liftedPC + Β· subst i + exact hasBinaryNat_parked hfinalPC + Β· rw [hframe i hi] + exact hparked i) + Β· rw [hframe tapes.lifted.data.shift (tapes.lifted.data_ne_pc 15)] + exact hshift + Β· rw [hframe tapes.lifted.data.tmp (tapes.lifted.data_ne_pc 16)] + exact htmp + Β· rw [hframe tapes.lifted.data.dbl (tapes.lifted.data_ne_pc 17)] + exact hdbl + Β· intro i + by_cases hi : i = tapes.liftedPC + Β· subst i + exact hasBinaryNat_parked hfinalPC + Β· rw [hframe i hi] + exact hparked i + have hseq := TM.seqTM_hoareTime dataTM.retargetOutput + (TM.binarySuccTM tapes.liftedPC) hdata + (by + rintro inp work out + ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, hremaining, + hscanner, hshift, htmp, hdbl, hparked, houtEq⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [houtEq] using! hout + obtain ⟨hi, hw, ho⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hinpParked.read_ne_start + (fun i => (hparked i).read_ne_start) + houtParked.read_ne_start + rw [hi, hw, ho] + exact ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, + hremaining, hscanner, hshift, htmp, hdbl, hparked, houtEq⟩) + hsucc + simpa only [outβ‚€] using! hseq + +/-- Sparse-instruction specialization of buffered data finalization. -/ +private theorem finishDataInstructionTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (instruction : Instr) + (store : Store) (pcValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) (dataTM : TM n) (dataTime : β„•) + (hpcNext : instructionPC instruction pcValue store = pcValue + 1) + (hinput : TM.Parked inpβ‚€) + (hdata : dataTM.retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length ∧ + (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (instructionCleanupValue instruction store slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) ∧ + EntryScanReady tapes.lifted.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = (Tape.init []).move Dir3.right) + dataTime) : + (TM.seqTM dataTM.retargetOutput + (TM.binarySuccTM tapes.liftedPC)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes instruction pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (dataTime + 1 + TM.binarySuccTime pcValue) := by + have hrun := finishBufferedDataTM_hoareTime_frame_internal tapes store + (instructionStore instruction pcValue store) + (instructionPC instruction pcValue store) pcValue + (instructionCleanupValue instruction store) + (instructionRemainingValue instruction store) initialWork inpβ‚€ dataTM + dataTime hpcNext hinput hdata + exact hrun.strengthen_post (by + rintro inp work out ⟨hinp, hresult, hout⟩ + exact ⟨hinp, + { buffer := hresult.buffer + pc := hresult.pc + resultCount := hresult.resultCount + sourceContent := hresult.sourceContent + cleanup := hresult.cleanup + remaining := hresult.remaining + scanner := hresult.scanner + shift := hresult.shift + tmp := hresult.tmp + dbl := hresult.dbl + parked := hresult.parked }, + hout⟩) + +/-- Lift a base data-kernel contract through output redirection once its +semantic result exposes PC framing, the next-store count, and parked heads. -/ +theorem retargetBufferedDataKernel_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (cleanupValues : Fin 5 β†’ β„•) (remainingValue pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) (dataTM : TM n) (dataTime : β„•) + (Result : (Fin n β†’ Tape) β†’ Prop) + (hready : InstructionExecutionReady tapes oldStore pcValue initialWork) + (hbase : dataTM.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + work = (fun i => initialWork (Fin.castSucc i)) ∧ + out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix + (nextStore.flatMap Entry.encode)) + dataTime) + (hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + nextStore.length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (oldStore.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat + remainingValue ∧ + EntryScanReady tapes.data.update.entry [] + (cleanupValues 0).bits work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i)) : + dataTM.retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + (nextStore.flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + nextStore.length ∧ + (work tapes.liftedSource).HasBinaryContent + (oldStore.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (cleanupValues slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + remainingValue ∧ + EntryScanReady tapes.lifted.data.update.entry [] + (cleanupValues 0).bits work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = (Tape.init []).move Dir3.right) + dataTime := by + have hlift := TM.retargetOutput_hoareTime dataTM hbase + apply hlift.consequence + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + exact ⟨⟨hinp, rfl, rfl⟩, hout⟩ + Β· rintro inp work out ⟨⟨hinp, hsemantic, hbuffer⟩, hout⟩ + obtain ⟨hpcEq, hcount, hsourceContent, hcleanup, hremaining, hscanner, + hshift, htmp, hdbl, hparkedBase⟩ := + hresult _ hsemantic + have hpc : (work tapes.liftedPC).HasBinaryNat pcValue := by + change (work (Fin.castSucc tapes.pc)).HasBinaryNat pcValue + rw [hpcEq] + exact hready.control.pc + have hparked : βˆ€ i, TM.Parked (work i) := by + intro i + exact Fin.lastCases (hasBinaryPrefix_parked hbuffer) + (fun j => hparkedBase j) i + exact ⟨hinp, hbuffer, hpc, hcount, hsourceContent, hcleanup, + hremaining, by + simpa [ControlInstructionTapes.lifted] using! + entryScanReady_lifted tapes.data.update.entry _ _ work hscanner + hparked, + hshift, htmp, hdbl, hparked, hout⟩ + Β· exact le_rfl + +/-- Sparse specialization of representation-independent output retargeting. -/ +private theorem retargetDataKernel_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (instruction : Instr) + (store : Store) (pcValue : β„•) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) (dataTM : TM n) (dataTime : β„•) + (Result : (Fin n β†’ Tape) β†’ Prop) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hbase : dataTM.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + work = (fun i => initialWork (Fin.castSucc i)) ∧ + out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode)) + dataTime) + (hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue instruction store slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) ∧ + EntryScanReady tapes.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i)) : + dataTM.retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length ∧ + (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (instructionCleanupValue instruction store slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) ∧ + EntryScanReady tapes.lifted.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = (Tape.init []).move Dir3.right) + dataTime := + retargetBufferedDataKernel_hoareTime_frame_internal tapes store + (instructionStore instruction pcValue store) + (instructionCleanupValue instruction store) + (instructionRemainingValue instruction store) pcValue initialWork inpβ‚€ + dataTM dataTime Result hready hbase hresult + +/-- Instruction constructor corresponding to a direct arithmetic kernel. -/ +def directInstruction (op : BinaryInstrOp) (destination sourceβ‚€ + source₁ : β„•) : Instr := + match op with + | .add => .add destination sourceβ‚€ source₁ + | .sub => .sub destination sourceβ‚€ source₁ + | .mul => .mul destination sourceβ‚€ source₁ + +/-- Immediate execution redirects the new sparse store and increments the +program counter. -/ +theorem executeInstructionTM_imm_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue destination value : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.imm destination value)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.imm destination value) pcValue + store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.imm destination value) pcValue store) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup store baseWork := by + exact instructionExecutionReady_baseLookup_internal tapes store pcValue + initialWork + hready + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := by + exact hready.replacement + have hbuffer : + (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbase := immediateInstructionTM_hoareTime_frame tapes.data store + destination value [] baseWork inpβ‚€ (initialWork tapes.buffer) + hready.canonical hlookup hreplacement hinput hbuffer + have hlift := TM.retargetOutput_hoareTime + (immediateInstructionTM tapes.data destination value) hbase + have hdata : + (immediateInstructionTM tapes.data destination value).retargetOutput.HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + (work tapes.buffer).HasBinaryPrefix + ((instructionStore (.imm destination value) pcValue store).flatMap + Entry.encode) ∧ + (work tapes.liftedPC).HasBinaryNat pcValue ∧ + (work tapes.lifted.data.update.resultCount).HasBinaryNat + (instructionStore (.imm destination value) pcValue store).length ∧ + (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (instructionCleanupValue (.imm destination value) store slot)) ∧ + (work tapes.lifted.data.update.remaining).HasBinaryNat + (instructionRemainingValue (.imm destination value) store) ∧ + EntryScanReady tapes.lifted.data.update.entry [] destination.bits + work work ∧ + (work tapes.lifted.data.shift).HasBinaryNat 0 ∧ + (work tapes.lifted.data.tmp).HasBinaryNat 0 ∧ + (work tapes.lifted.data.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, TM.Parked (work i)) ∧ + out = (Tape.init []).move Dir3.right) + (immediateInstructionTime tapes.data store destination value) := by + apply hlift.consequence + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + exact ⟨⟨hinp, rfl, rfl⟩, hout⟩ + Β· rintro inp work out ⟨⟨hinp, hresult, hbuffer'⟩, hout⟩ + obtain ⟨valueWork, updateWork, hvalueWork, hupdateWork, houtcome, + hsourceCells⟩ := hresult + have hpcBase : + (fun i => work (Fin.castSucc i)) tapes.pc = baseWork tapes.pc := by + have hpcQuery : + tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcReplacement : + tapes.pc β‰  tapes.data.update.replacement := tapes.pc_ne 10 + calc + work (Fin.castSucc tapes.pc) = updateWork tapes.pc := + houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + _ = valueWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + _ = baseWork tapes.pc := by + rw [hvalueWork, Function.update_of_ne hpcReplacement] + have hpc : (work tapes.liftedPC).HasBinaryNat pcValue := by + change ((fun i => work (Fin.castSucc i)) tapes.pc).HasBinaryNat pcValue + rw [hpcBase] + exact hready.control.pc + have hcount : + (work tapes.lifted.data.update.resultCount).HasBinaryNat + (RegisterStore.write store destination value).length := by + exact houtcome.resultCount + have hparked : βˆ€ i, TM.Parked (work i) := by + intro i + exact Fin.lastCases (hasBinaryPrefix_parked hbuffer') + (fun j => houtcome.ready.parked j) i + have hsourceContent : + (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) := by + change ((fun i => work (Fin.castSucc i)) + tapes.data.update.entry.source).HasBinaryContent _ + unfold Tape.HasBinaryContent + rw [hsourceCells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (instructionCleanupValue (.imm destination value) store slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [instructionCleanupValue, instructionCleanupTape, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change ((fun i => work (Fin.castSucc i)) + tapes.data.update.replacement).HasBinaryNat value + rw [show (fun i => work (Fin.castSucc i)) + tapes.data.update.replacement = + updateWork tapes.data.update.replacement from + houtcome.replacement] + rw [show updateWork tapes.data.update.replacement = + valueWork tapes.data.update.replacement by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _] + rw [show valueWork tapes.data.update.replacement = + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right by + rw [hvalueWork] + exact Function.update_self _ _ _] + exact Tape.init_move_right_hasBinaryNat value + Β· simpa [instructionCleanupValue, instructionCleanupTape, + instructionCleanupParentSlot] using! houtcome.found + Β· change ((fun i => work (Fin.castSucc i)) tapes.data.lhs).HasBinaryNat 0 + rw [show (fun i => work (Fin.castSucc i)) tapes.data.lhs = + updateWork tapes.data.lhs from + houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + show updateWork tapes.data.lhs = valueWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _, + show valueWork tapes.data.lhs = baseWork tapes.data.lhs by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 10).symm _ _] + exact hready.control.lookup.destination + Β· change ((fun i => work (Fin.castSucc i)) tapes.data.rhs).HasBinaryNat 0 + rw [show (fun i => work (Fin.castSucc i)) tapes.data.rhs = + updateWork tapes.data.rhs from + houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + show updateWork tapes.data.rhs = valueWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _, + show valueWork tapes.data.rhs = baseWork tapes.data.rhs by + rw [hvalueWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 10).symm _ _] + exact hready.rhs + have hshift : (work tapes.lifted.data.shift).HasBinaryNat 0 := by + change ((fun i => work (Fin.castSucc i)) + tapes.data.shift).HasBinaryNat 0 + have hqueryNe : tapes.data.shift β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_shift 7).symm + have hreplacementNe : tapes.data.shift β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_shift 10).symm + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hvalueWork, Function.update_of_ne hreplacementNe] + exact hready.control.lookup.querySource + have htmp' : (work tapes.lifted.data.tmp).HasBinaryNat 0 := by + change ((fun i => work (Fin.castSucc i)) + tapes.data.tmp).HasBinaryNat 0 + have hqueryNe : tapes.data.tmp β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_tmp 7).symm + have hreplacementNe : tapes.data.tmp β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_tmp 10).symm + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hvalueWork, Function.update_of_ne hreplacementNe] + exact hready.tmp + have hdbl' : (work tapes.lifted.data.dbl).HasBinaryNat 0 := by + change ((fun i => work (Fin.castSucc i)) + tapes.data.dbl).HasBinaryNat 0 + have hqueryNe : tapes.data.dbl β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_dbl 7).symm + have hreplacementNe : tapes.data.dbl β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_dbl 10).symm + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hvalueWork, Function.update_of_ne hreplacementNe] + exact hready.dbl + refine ⟨hinp, ?_, hpc, ?_, hsourceContent, hcleanup, ?_, ?_, hshift, + htmp', hdbl', hparked, hout⟩ + Β· simpa [instructionStore, Snapshot.stepInstr] using! hbuffer' + Β· simpa [instructionStore, Snapshot.stepInstr] using! hcount + Β· simpa [instructionRemainingValue] using! houtcome.remaining + Β· simpa [ControlInstructionTapes.lifted] using! + entryScanReady_lifted tapes.data.update.entry _ _ work + houtcome.ready hparked + Β· exact le_rfl + simpa only [executeInstructionTM, executeInstructionTime] using! + finishDataInstructionTM_hoareTime_frame_internal tapes + (.imm destination value) store pcValue initialWork inpβ‚€ + (immediateInstructionTM tapes.data destination value) + (immediateInstructionTime tapes.data store destination value) rfl hinput + hdata + +/-- A direct arithmetic kernel redirects its next sparse store and increments +the program counter. -/ +theorem executeInstructionTM_direct_hoareTime_frame + (tapes : ControlInstructionTapes n) (op : BinaryInstrOp) (store : Store) + (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes + (directInstruction op destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (directInstruction op destination sourceβ‚€ source₁) pcValue store + work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes + (directInstruction op destination sourceβ‚€ source₁) pcValue store) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup store baseWork := + instructionExecutionReady_baseLookup_internal tapes store pcValue + initialWork hready + have hrhs : (baseWork tapes.data.rhs).HasBinaryNat 0 := hready.rhs + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have htmp : (baseWork tapes.data.tmp).HasBinaryNat 0 := hready.tmp + have hdbl : (baseWork tapes.data.dbl).HasBinaryNat 0 := hready.dbl + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := directBinaryInstructionTM_hoareTime_frame tapes.data op store + destination sourceβ‚€ source₁ [] baseWork inpβ‚€ + (initialWork tapes.buffer) hready.canonical hlookup hrhs hreplacement htmp + hdbl hinput hbuffer + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + DirectBinaryInstructionResult tapes.data op store destination sourceβ‚€ + source₁ baseWork work + have hbase : (directBinaryInstructionTM tapes.data op destination sourceβ‚€ + source₁).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = baseWork ∧ + out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix + ((instructionStore + (directInstruction op destination sourceβ‚€ source₁) pcValue store).flatMap + Entry.encode)) + (directBinaryInstructionTime tapes.data op store destination sourceβ‚€ + source₁) := by + cases op <;> + simpa [Result, directInstruction, instructionStore, Snapshot.stepInstr, + BinaryInstrOp.eval] using! hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + (instructionStore (directInstruction op destination sourceβ‚€ source₁) + pcValue store).length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue + (directInstruction op destination sourceβ‚€ source₁) store slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat + (instructionRemainingValue + (directInstruction op destination sourceβ‚€ source₁) store) ∧ + EntryScanReady tapes.data.update.entry [] + (instructionCleanupValue + (directInstruction op destination sourceβ‚€ source₁) store 0).bits + work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨updateWork, haddress, hbinary⟩ := hsemantic + obtain ⟨operandsWork, hoperands, hupdateWork⟩ := haddress + obtain ⟨lhsWork, hlhs, hrhsResult⟩ := hoperands + obtain ⟨arithmeticWork, harithmetic, houtcome, hsourceCells⟩ := hbinary + have hpcUpdate : work tapes.pc = arithmeticWork tapes.pc := by + exact houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcArithmetic : arithmeticWork tapes.pc = updateWork tapes.pc := by + exact harithmetic.frame tapes.pc (tapes.pc_ne 13) (tapes.pc_ne 14) + (tapes.pc_ne 10) (tapes.pc_ne 15) (tapes.pc_ne 16) + (tapes.pc_ne 17) + have hpcQuery : tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcAddress : updateWork tapes.pc = operandsWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + have hpcRhs : operandsWork tapes.pc = lhsWork tapes.pc := by + exact hrhsResult.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.rhsLookupSlot slot)) + have hpcLhs : lhsWork tapes.pc = baseWork tapes.pc := by + exact hlhs.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) := by + have hcells : (work tapes.data.update.entry.source).cells = + (baseWork tapes.data.update.entry.source).cells := by + calc + (work tapes.data.update.entry.source).cells = + (updateWork tapes.data.update.entry.source).cells := hsourceCells + _ = (operandsWork tapes.data.update.entry.source).cells := by + rw [show updateWork tapes.data.update.entry.source = + operandsWork tapes.data.update.entry.source by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _] + _ = (lhsWork tapes.data.update.entry.source).cells := + hrhsResult.sourceCells + _ = (baseWork tapes.data.update.entry.source).cells := + hlhs.sourceCells + unfold Tape.HasBinaryContent + rw [hcells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue + (directInstruction op destination sourceβ‚€ source₁) store slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + cases op <;> + simpa [directInstruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [show work tapes.data.update.replacement = + arithmeticWork tapes.data.update.replacement from + houtcome.replacement] + cases op <;> + simpa [directInstruction, instructionCleanupValue, + BinaryInstrOp.eval] using! harithmetic.result + Β· cases op <;> + simpa [directInstruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm)] + cases op <;> + simpa [directInstruction, instructionCleanupValue, + instructionCleanupParentSlot] using! harithmetic.lhsValue + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm)] + cases op <;> + simpa [directInstruction, instructionCleanupValue, + instructionCleanupParentSlot] using! harithmetic.rhsValue + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm)] + exact harithmetic.shift + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm)] + exact harithmetic.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm)] + exact harithmetic.dbl + refine ⟨hpcUpdate.trans (hpcArithmetic.trans + (hpcAddress.trans (hpcRhs.trans hpcLhs))), ?_, hsourceContent, + hcleanup, ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· cases op <;> + simpa [directInstruction, instructionStore, Snapshot.stepInstr, + BinaryInstrOp.eval] using! houtcome.resultCount + Β· cases op <;> + simpa [directInstruction, instructionRemainingValue] using! + houtcome.remaining + Β· cases op <;> + simpa [directInstruction, instructionCleanupValue] using! + houtcome.ready + have hdata := retargetDataKernel_hoareTime_frame_internal tapes + (directInstruction op destination sourceβ‚€ source₁) store pcValue + initialWork inpβ‚€ + (directBinaryInstructionTM tapes.data op destination sourceβ‚€ source₁) + (directBinaryInstructionTime tapes.data op store destination sourceβ‚€ + source₁) Result hready hbase hresult + have hall := finishDataInstructionTM_hoareTime_frame_internal tapes + (directInstruction op destination sourceβ‚€ source₁) store pcValue + initialWork inpβ‚€ + (directBinaryInstructionTM tapes.data op destination sourceβ‚€ source₁) + (directBinaryInstructionTime tapes.data op store destination sourceβ‚€ + source₁) (by cases op <;> rfl) hinput hdata + cases op <;> + simpa [directInstruction, executeInstructionTM, executeInstructionTime] + using! hall + +/-- Direct addition has the common one-buffer instruction contract. -/ +theorem executeInstructionTM_add_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.add destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.add destination sourceβ‚€ source₁) + pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.add destination sourceβ‚€ source₁) + pcValue store) := by + simpa [directInstruction] using! + executeInstructionTM_direct_hoareTime_frame tapes .add store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + +/-- Direct subtraction has the common one-buffer instruction contract. -/ +theorem executeInstructionTM_sub_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.sub destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.sub destination sourceβ‚€ source₁) + pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.sub destination sourceβ‚€ source₁) + pcValue store) := by + simpa [directInstruction] using! + executeInstructionTM_direct_hoareTime_frame tapes .sub store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + +/-- Direct multiplication has the common one-buffer instruction contract. -/ +theorem executeInstructionTM_mul_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue destination sourceβ‚€ source₁ : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.mul destination sourceβ‚€ source₁)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.mul destination sourceβ‚€ source₁) + pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.mul destination sourceβ‚€ source₁) + pcValue store) := by + simpa [directInstruction] using! + executeInstructionTM_direct_hoareTime_frame tapes .mul store pcValue + destination sourceβ‚€ source₁ initialWork inpβ‚€ hready hinput + +/-- Indirect-load execution redirects its next sparse store and increments +the program counter. -/ +theorem executeInstructionTM_load_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue destination addressRegister : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.load destination addressRegister)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.load destination addressRegister) + pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.load destination addressRegister) + pcValue store) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup store baseWork := + instructionExecutionReady_baseLookup_internal tapes store pcValue + initialWork hready + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := indirectLoadInstructionTM_hoareTime_frame tapes.data store + destination addressRegister [] baseWork inpβ‚€ (initialWork tapes.buffer) + hready.canonical hlookup hreplacement hinput hbuffer + let instruction : Instr := .load destination addressRegister + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + IndirectLoadInstructionResult tapes.data store destination addressRegister + baseWork work + have hbase : (indirectLoadInstructionTM tapes.data destination + addressRegister).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = baseWork ∧ + out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode)) + (indirectLoadInstructionTime tapes.data store destination + addressRegister) := by + simpa [Result, instruction, instructionStore, Snapshot.stepInstr] using! + hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue instruction store slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) ∧ + EntryScanReady tapes.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨addressWork, loadedWork, updateWork, haddress, hloaded, + hupdateWork, houtcome, hsourceCells⟩ := hsemantic + have hpcOutcome : work tapes.pc = updateWork tapes.pc := by + exact houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcQuery : tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcUpdate : updateWork tapes.pc = loadedWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcQuery] + have hpcLoaded : loadedWork tapes.pc = addressWork tapes.pc := by + exact hloaded.frame tapes.pc (fun slot => by + exact tapes.pc_ne + (BinaryInstructionTapes.indirectLoadLookupSlot slot)) + have hpcAddress : addressWork tapes.pc = baseWork tapes.pc := by + exact haddress.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) := by + unfold Tape.HasBinaryContent + rw [hsourceCells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue instruction store slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [instruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [show work tapes.data.update.replacement = + updateWork tapes.data.update.replacement from houtcome.replacement, + show updateWork tapes.data.update.replacement = + loadedWork tapes.data.update.replacement by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update.ne (by decide)) _ _] + exact hloaded.value + Β· simpa [instruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [show work tapes.data.lhs = updateWork tapes.data.lhs from + houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + show updateWork tapes.data.lhs = loadedWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _] + rw [show loadedWork tapes.data.lhs = addressWork tapes.data.lhs from + hloaded.querySource] + simpa [instruction, instructionCleanupValue] using! haddress.destination + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [show work tapes.data.rhs = updateWork tapes.data.rhs from + houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + show updateWork tapes.data.rhs = loadedWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _, + hloaded.frame tapes.data.rhs (fun role => by + apply tapes.data.ne + fin_cases role <;> decide), + haddress.frame tapes.data.rhs (fun role => + (tapes.data.lhsLookup_ne_rhs role).symm)] + exact hready.rhs + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + have hqueryNe : tapes.data.shift β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_shift 7).symm + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.shift (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide)] + simpa using! haddress.querySource + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + have hqueryNe : tapes.data.tmp β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_tmp 7).symm + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.tmp (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide), + haddress.frame tapes.data.tmp (fun slot => + (tapes.data.lhsLookup_ne_tmp slot).symm)] + exact hready.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + have hqueryNe : tapes.data.dbl β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_dbl 7).symm + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + hupdateWork, Function.update_of_ne hqueryNe, + hloaded.frame tapes.data.dbl (fun slot => by + apply tapes.data.ne + fin_cases slot <;> decide), + haddress.frame tapes.data.dbl (fun slot => + (tapes.data.lhsLookup_ne_dbl slot).symm)] + exact hready.dbl + refine ⟨hpcOutcome.trans (hpcUpdate.trans + (hpcLoaded.trans hpcAddress)), ?_, hsourceContent, hcleanup, + ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· simpa [instruction, instructionStore, Snapshot.stepInstr] using! + houtcome.resultCount + Β· simpa [instruction, instructionRemainingValue] using! + houtcome.remaining + Β· simpa [instruction, instructionCleanupValue] using! houtcome.ready + have hdata := retargetDataKernel_hoareTime_frame_internal tapes instruction + store pcValue initialWork inpβ‚€ + (indirectLoadInstructionTM tapes.data destination addressRegister) + (indirectLoadInstructionTime tapes.data store destination addressRegister) + Result hready hbase hresult + simpa only [instruction, executeInstructionTM, executeInstructionTime] using! + finishDataInstructionTM_hoareTime_frame_internal tapes instruction store + pcValue initialWork inpβ‚€ + (indirectLoadInstructionTM tapes.data destination addressRegister) + (indirectLoadInstructionTime tapes.data store destination addressRegister) + rfl hinput hdata + +/-- Indirect-store execution redirects its next sparse store and increments +the program counter. -/ +theorem executeInstructionTM_store_hoareTime_frame + (tapes : ControlInstructionTapes n) (store : Store) + (pcValue addressRegister source : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (executeInstructionTM tapes (.store addressRegister source)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes (.store addressRegister source) + pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (executeInstructionTime tapes (.store addressRegister source) + pcValue store) := by + let baseWork : Fin n β†’ Tape := fun i => initialWork (Fin.castSucc i) + have hlookup : EntryLookupStaticReady tapes.data.lhsLookup store baseWork := + instructionExecutionReady_baseLookup_internal tapes store pcValue + initialWork hready + have hrhs : (baseWork tapes.data.rhs).HasBinaryNat 0 := hready.rhs + have hreplacement : + (baseWork tapes.data.update.replacement).HasBinaryNat 0 := + hready.replacement + have hbuffer : (initialWork tapes.buffer).HasBinaryPrefix [] := by + rw [hready.buffer] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hbaseRaw := indirectStoreInstructionTM_hoareTime_frame tapes.data store + addressRegister source [] baseWork inpβ‚€ (initialWork tapes.buffer) + hready.canonical hlookup hrhs hreplacement hinput hbuffer + let instruction : Instr := .store addressRegister source + let Result : (Fin n β†’ Tape) β†’ Prop := fun work => + IndirectStoreInstructionResult tapes.data store addressRegister source + baseWork work + have hbase : (indirectStoreInstructionTM tapes.data addressRegister + source).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = baseWork ∧ + out = initialWork tapes.buffer) + (fun inp work out => + inp = inpβ‚€ ∧ Result work ∧ + out.HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode)) + (indirectStoreInstructionTime tapes.data store addressRegister source) := by + simpa [Result, instruction, instructionStore, Snapshot.stepInstr] using! + hbaseRaw + have hresult : βˆ€ work, Result work β†’ + work tapes.pc = initialWork (Fin.castSucc tapes.pc) ∧ + (work tapes.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length ∧ + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) ∧ + (βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue instruction store slot)) ∧ + (work tapes.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) ∧ + EntryScanReady tapes.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work ∧ + (work tapes.data.shift).HasBinaryNat 0 ∧ + (work tapes.data.tmp).HasBinaryNat 0 ∧ + (work tapes.data.dbl).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (work i) := by + intro work hsemantic + obtain ⟨operandsWork, queryWork, updateWork, hoperands, hqueryWork, + hupdateWork, houtcome, hsourceCells⟩ := hsemantic + obtain ⟨lhsWork, hlhs, hrhsResult⟩ := hoperands + have hpcOutcome : work tapes.pc = updateWork tapes.pc := by + exact houtcome.frame tapes.pc (fun slot => by + exact tapes.pc_ne ⟨slot, by omega⟩) + have hpcReplacement : + tapes.pc β‰  tapes.data.update.replacement := tapes.pc_ne 10 + have hpcUpdate : updateWork tapes.pc = queryWork tapes.pc := by + rw [hupdateWork, Function.update_of_ne hpcReplacement] + have hpcQuery : tapes.pc β‰  tapes.data.update.entry.query := tapes.pc_ne 7 + have hpcQueryWork : queryWork tapes.pc = operandsWork tapes.pc := by + rw [hqueryWork, Function.update_of_ne hpcQuery] + have hpcRhs : operandsWork tapes.pc = lhsWork tapes.pc := by + exact hrhsResult.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.rhsLookupSlot slot)) + have hpcLhs : lhsWork tapes.pc = baseWork tapes.pc := by + exact hlhs.frame tapes.pc (fun slot => by + exact tapes.pc_ne (BinaryInstructionTapes.lhsLookupSlot slot)) + have hsourceContent : + (work tapes.data.update.entry.source).HasBinaryContent + (store.flatMap Entry.encode) := by + unfold Tape.HasBinaryContent + rw [hsourceCells] + exact hready.sourceContent + have hcleanup : βˆ€ slot, + (work (tapes.data.idx (instructionCleanupParentSlot slot))).HasBinaryNat + (instructionCleanupValue instruction store slot) := by + intro slot + fin_cases slot + Β· exact ⟨houtcome.ready.queryStart, by + simpa [instruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.ready.query⟩ + Β· change (work tapes.data.update.replacement).HasBinaryNat _ + rw [show work tapes.data.update.replacement = + updateWork tapes.data.update.replacement from houtcome.replacement, + hupdateWork, Function.update_self] + exact Tape.init_move_right_hasBinaryNat + (RegisterStore.read store source) + Β· simpa [instruction, instructionCleanupValue, + instructionCleanupParentSlot] using! houtcome.found + Β· change (work tapes.data.lhs).HasBinaryNat _ + rw [show work tapes.data.lhs = updateWork tapes.data.lhs from + houtcome.frame tapes.data.lhs (fun role => + (tapes.data.update_ne_lhs role).symm), + show updateWork tapes.data.lhs = queryWork tapes.data.lhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 10).symm _ _, + show queryWork tapes.data.lhs = operandsWork tapes.data.lhs by + rw [hqueryWork] + exact Function.update_of_ne + (tapes.data.update_ne_lhs 7).symm _ _, + hrhsResult.frame tapes.data.lhs (fun role => + (tapes.data.rhsLookup_ne_lhs role).symm)] + exact hlhs.destination + Β· change (work tapes.data.rhs).HasBinaryNat _ + rw [show work tapes.data.rhs = updateWork tapes.data.rhs from + houtcome.frame tapes.data.rhs (fun role => + (tapes.data.update_ne_rhs role).symm), + show updateWork tapes.data.rhs = queryWork tapes.data.rhs by + rw [hupdateWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 10).symm _ _, + show queryWork tapes.data.rhs = operandsWork tapes.data.rhs by + rw [hqueryWork] + exact Function.update_of_ne + (tapes.data.update_ne_rhs 7).symm _ _] + exact hrhsResult.destination + have hshift : (work tapes.data.shift).HasBinaryNat 0 := by + have hreplacementNe : tapes.data.shift β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_shift 10).symm + have hqueryNe : tapes.data.shift β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_shift 7).symm + rw [houtcome.frame tapes.data.shift (fun slot => + (tapes.data.update_ne_shift slot).symm), + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe] + simpa using! hrhsResult.querySource + have htmp' : (work tapes.data.tmp).HasBinaryNat 0 := by + have hreplacementNe : tapes.data.tmp β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_tmp 10).symm + have hqueryNe : tapes.data.tmp β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_tmp 7).symm + rw [houtcome.frame tapes.data.tmp (fun slot => + (tapes.data.update_ne_tmp slot).symm), + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe, + hrhsResult.frame tapes.data.tmp (fun slot => + (tapes.data.rhsLookup_ne_tmp slot).symm), + hlhs.frame tapes.data.tmp (fun slot => + (tapes.data.lhsLookup_ne_tmp slot).symm)] + exact hready.tmp + have hdbl' : (work tapes.data.dbl).HasBinaryNat 0 := by + have hreplacementNe : tapes.data.dbl β‰  + tapes.data.update.replacement := + (tapes.data.update_ne_dbl 10).symm + have hqueryNe : tapes.data.dbl β‰  + tapes.data.update.entry.query := + (tapes.data.update_ne_dbl 7).symm + rw [houtcome.frame tapes.data.dbl (fun slot => + (tapes.data.update_ne_dbl slot).symm), + hupdateWork, Function.update_of_ne hreplacementNe, + hqueryWork, Function.update_of_ne hqueryNe, + hrhsResult.frame tapes.data.dbl (fun slot => + (tapes.data.rhsLookup_ne_dbl slot).symm), + hlhs.frame tapes.data.dbl (fun slot => + (tapes.data.lhsLookup_ne_dbl slot).symm)] + exact hready.dbl + refine ⟨hpcOutcome.trans (hpcUpdate.trans + (hpcQueryWork.trans (hpcRhs.trans hpcLhs))), ?_, hsourceContent, + hcleanup, ?_, ?_, hshift, htmp', hdbl', houtcome.ready.parked⟩ + Β· simpa [instruction, instructionStore, Snapshot.stepInstr] using! + houtcome.resultCount + Β· simpa [instruction, instructionRemainingValue] using! + houtcome.remaining + Β· simpa [instruction, instructionCleanupValue] using! houtcome.ready + have hdata := retargetDataKernel_hoareTime_frame_internal tapes instruction + store pcValue initialWork inpβ‚€ + (indirectStoreInstructionTM tapes.data addressRegister source) + (indirectStoreInstructionTime tapes.data store addressRegister source) + Result hready hbase hresult + simpa only [instruction, executeInstructionTM, executeInstructionTime] using! + finishDataInstructionTM_hoareTime_frame_internal tapes instruction store + pcValue initialWork inpβ‚€ + (indirectStoreInstructionTM tapes.data addressRegister source) + (indirectStoreInstructionTime tapes.data store addressRegister source) + rfl hinput hdata + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Defs.lean new file mode 100644 index 0000000000..4adfdf0d34 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Defs.lean @@ -0,0 +1,615 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift + +/-! +# Fixed-program sparse RAM instruction dispatch -- definitions + +One fresh last work tape is the next-store buffer. Data instructions redirect +their encoded output there; control instructions copy the unchanged read-only +store there. A binary copy of the program counter is then decremented through a +fixed finite branch tree, so the resulting TM depends only on the RAM program. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +namespace ControlInstructionTapes + +/-- Embed every control/data role into the initial `n` tapes of the one-buffer +layout. -/ +def lifted {n : β„•} (tapes : ControlInstructionTapes n) : + ControlInstructionTapes (n + 1) where + data := + { idx := fun slot => Fin.castSucc (tapes.data.idx slot) + injective := by + intro i j h + apply tapes.data.injective + exact Fin.castSucc_injective _ h } + pc := Fin.castSucc tapes.pc + pc_ne := by + intro slot h + exact tapes.pc_ne slot (Fin.castSucc_injective _ h) + +/-- Program counter in the one-buffer execution layout. -/ +def liftedPC {n : β„•} (tapes : ControlInstructionTapes n) : Fin (n + 1) := + tapes.lifted.pc + +/-- First temporary operand in the one-buffer execution layout. -/ +def liftedLhs {n : β„•} (tapes : ControlInstructionTapes n) : Fin (n + 1) := + tapes.lifted.data.lhs + +/-- Zero scratch used while copying the dispatch selector. -/ +def liftedFound {n : β„•} (tapes : ControlInstructionTapes n) : Fin (n + 1) := + tapes.lifted.data.update.found + +/-- Read-only encoded-store source in the one-buffer execution layout. -/ +def liftedSource {n : β„•} (tapes : ControlInstructionTapes n) : Fin (n + 1) := + tapes.lifted.data.update.entry.source + +/-- Fresh last work tape receiving the next encoded store. -/ +def buffer {n : β„•} (_tapes : ControlInstructionTapes n) : Fin (n + 1) := + Fin.last n + +theorem liftedSource_ne_buffer {n : β„•} + (tapes : ControlInstructionTapes n) : + tapes.liftedSource β‰  tapes.buffer := by + intro h + have hval : tapes.data.update.entry.source.val = n := by + simpa [liftedSource, buffer, lifted] using! congrArg Fin.val h + have hlt := tapes.data.update.entry.source.isLt + omega + +theorem liftedPC_ne_buffer {n : β„•} + (tapes : ControlInstructionTapes n) : + tapes.liftedPC β‰  tapes.buffer := by + intro h + have hval : tapes.pc.val = n := by + simpa [liftedPC, buffer, lifted] using congrArg Fin.val h + exact Nat.ne_of_lt tapes.pc.isLt hval + +/-- The lifted program counter is disjoint from the encoded-store source. -/ +theorem liftedPC_ne_source {n : β„•} + (tapes : ControlInstructionTapes n) : + tapes.liftedPC β‰  tapes.liftedSource := by + exact tapes.lifted.pc_ne 0 + +theorem liftedData_ne_buffer {n : β„•} + (tapes : ControlInstructionTapes n) (slot : Fin 18) : + tapes.lifted.data.idx slot β‰  tapes.buffer := by + intro h + have hval : (tapes.data.idx slot).val = n := by + simpa [buffer, lifted] using congrArg Fin.val h + exact Nat.ne_of_lt (tapes.data.idx slot).isLt hval + +end ControlInstructionTapes + +/-- Emit the unchanged store from the read-only source into the fresh buffer +after executing a control-only instruction. -/ +def finishControlInstructionTM {n : β„•} + (tapes : ControlInstructionTapes n) (control : TM (n + 1)) : TM (n + 1) := + TM.seqTM control + (TM.copyWorkToWorkTM tapes.liftedSource tapes.buffer) + +/-- Execute one statically selected RAM instruction. Every case writes the +next encoded store to the fresh last work tape and leaves real output blank. -/ +def executeInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) : + Instr β†’ TM (n + 1) + | .imm destination value => + TM.seqTM + (immediateInstructionTM tapes.data destination value).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .add destination sourceβ‚€ source₁ => + TM.seqTM + (directBinaryInstructionTM tapes.data .add destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .sub destination sourceβ‚€ source₁ => + TM.seqTM + (directBinaryInstructionTM tapes.data .sub destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .mul destination sourceβ‚€ source₁ => + TM.seqTM + (directBinaryInstructionTM tapes.data .mul destination sourceβ‚€ + source₁).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .load destination addressRegister => + TM.seqTM + (indirectLoadInstructionTM tapes.data destination + addressRegister).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .store addressRegister source => + TM.seqTM + (indirectStoreInstructionTM tapes.data addressRegister + source).retargetOutput + (TM.binarySuccTM tapes.liftedPC) + | .jz source target => + finishControlInstructionTM tapes + (zeroJumpInstructionTM tapes.lifted source target) + | .jmp target => + finishControlInstructionTM tapes (jumpInstructionTM tapes.lifted target) + | .halt => + finishControlInstructionTM tapes (haltInstructionTM (n := n + 1)) + +/-- Representation-independent finite branch tree for any family of static +instruction executors sharing the standard decrementing selector tape. -/ +def dispatchWithTM {n : β„•} (tapes : ControlInstructionTapes n) + (execute : Instr β†’ TM (n + 1)) : Program β†’ TM (n + 1) + | [] => TM.seqTM (TM.resetBinaryWorkTM tapes.liftedLhs) (execute .halt) + | instruction :: program => + TM.branchWorkBlankTM tapes.liftedLhs + (execute instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchWithTM tapes execute program)) + +/-- Finite branch tree selected by a decrementing canonical PC copy. -/ +def dispatchProgramTM {n : β„•} (tapes : ControlInstructionTapes n) : + Program β†’ TM (n + 1) + | [] => TM.seqTM (TM.resetBinaryWorkTM tapes.liftedLhs) + (executeInstructionTM tapes .halt) + | instruction :: program => + TM.branchWorkBlankTM tapes.liftedLhs + (executeInstructionTM tapes instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchProgramTM tapes program)) + +/-- Pure instruction selected by the same finite branch-tree recursion. -/ +def selectedInstruction : Program β†’ β„• β†’ Instr + | [], _ => .halt + | instruction :: _, 0 => instruction + | _ :: program, selector + 1 => selectedInstruction program selector + +/-- Copy the preserved PC into zero scratch and enter the fixed branch tree. -/ +def programInstructionTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (dispatchProgramTM tapes program) + +/-- Pure next store selected by one RAM instruction. -/ +def instructionStore (instruction : Instr) (pcValue : β„•) + (store : Store) : Store := + (Snapshot.stepInstr instruction { pc := pcValue, store := store }).store + +/-- Pure next program counter selected by one RAM instruction. -/ +def instructionPC (instruction : Instr) (pcValue : β„•) + (store : Store) : β„• := + (Snapshot.stepInstr instruction { pc := pcValue, store := store }).pc + +/-- Parent data slots cleared between simulated RAM instructions. -/ +def instructionCleanupParentSlot : Fin 5 β†’ Fin 18 + | 0 => 7 + | 1 => 10 + | 2 => 11 + | 3 => 13 + | _ => 14 + +/-- Five canonical data roles that must be cleared between simulated RAM +instructions: update query, replacement, found flag, and the two operands. -/ +def instructionCleanupTape {n : β„•} (tapes : ControlInstructionTapes n) + (slot : Fin 5) : Fin (n + 1) := + tapes.lifted.data.idx (instructionCleanupParentSlot slot) + +theorem instructionCleanupTape_ne_source {n : β„•} + (tapes : ControlInstructionTapes n) (slot : Fin 5) : + instructionCleanupTape tapes slot β‰  tapes.liftedSource := by + exact tapes.lifted.data.ne (by fin_cases slot <;> decide) + +theorem instructionCleanupTape_ne_buffer {n : β„•} + (tapes : ControlInstructionTapes n) (slot : Fin 5) : + instructionCleanupTape tapes slot β‰  tapes.buffer := + tapes.liftedData_ne_buffer (instructionCleanupParentSlot slot) + +/-- Exact values left on the five cleanup roles by one instruction kernel. -/ +def instructionCleanupValue (instruction : Instr) (store : Store) : + Fin 5 β†’ β„• + | 0 => + match instruction with + | .imm destination _ => destination + | .add destination _ _ => destination + | .sub destination _ _ => destination + | .mul destination _ _ => destination + | .load destination _ => destination + | .store addressRegister _ => RegisterStore.read store addressRegister + | .jz _ _ | .jmp _ | .halt => 0 + | 1 => + match instruction with + | .imm _ value => value + | .add _ sourceβ‚€ source₁ => + RegisterStore.read store sourceβ‚€ + RegisterStore.read store source₁ + | .sub _ sourceβ‚€ source₁ => + RegisterStore.read store sourceβ‚€ - RegisterStore.read store source₁ + | .mul _ sourceβ‚€ source₁ => + RegisterStore.read store sourceβ‚€ * RegisterStore.read store source₁ + | .load _ addressRegister => + RegisterStore.read store (RegisterStore.read store addressRegister) + | .store _ source => RegisterStore.read store source + | .jz _ _ | .jmp _ | .halt => 0 + | 2 => + match instruction with + | .imm destination _ | .add destination _ _ | + .sub destination _ _ | .mul destination _ _ | + .load destination _ => + if destination ∈ store.map Prod.fst then 1 else 0 + | .store addressRegister _ => + if RegisterStore.read store addressRegister ∈ store.map Prod.fst then + 1 + else 0 + | .jz _ _ | .jmp _ | .halt => 0 + | 3 => + match instruction with + | .add _ sourceβ‚€ _ | .sub _ sourceβ‚€ _ | .mul _ sourceβ‚€ _ => + RegisterStore.read store sourceβ‚€ + | .load _ addressRegister | .store addressRegister _ => + RegisterStore.read store addressRegister + | .imm _ _ | .jz _ _ | .jmp _ | .halt => 0 + | _ => + match instruction with + | .add _ _ source₁ | .sub _ _ source₁ | .mul _ _ source₁ => + RegisterStore.read store source₁ + | .store _ source => RegisterStore.read store source + | .imm _ _ | .load _ _ | .jz _ _ | .jmp _ | .halt => 0 + +/-- The old-entry counter is exhausted by data updates and untouched by +control instructions. Cleanup resets either canonical value uniformly. -/ +def instructionRemainingValue (instruction : Instr) (store : Store) : β„• := + match instruction with + | .imm _ _ | .add _ _ _ | .sub _ _ _ | .mul _ _ _ | + .load _ _ | .store _ _ => 0 + | .jz _ _ | .jmp _ | .halt => store.length + +/-- Clean one-buffer entry boundary shared by every selected instruction. -/ +structure InstructionExecutionReady {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (work : Fin (n + 1) β†’ Tape) : Prop where + /-- The sparse representation contains one nonzero entry per address. -/ + canonical : Canonical store + /-- The lifted control/lookup ABI is ready. -/ + control : ControlInstructionReady tapes.lifted store pcValue work + /-- The read-only source has the complete canonical sparse-store image. -/ + sourceContent : (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) + /-- The second direct operand starts at zero. -/ + rhs : (work tapes.lifted.data.rhs).HasBinaryNat 0 + /-- Sparse-update replacement starts at zero. -/ + replacement : + (work tapes.lifted.data.update.replacement).HasBinaryNat 0 + /-- First multiplication alternating scratch starts at zero. -/ + tmp : (work tapes.lifted.data.tmp).HasBinaryNat 0 + /-- Second multiplication alternating scratch starts at zero. -/ + dbl : (work tapes.lifted.data.dbl).HasBinaryNat 0 + /-- The next-store buffer is fresh. -/ + buffer : work tapes.buffer = (Tape.init []).move Dir3.right + +/-- Dispatch boundary obtained by replacing the clean zero `lhs` tape by a +canonical decrementing selector. -/ +def DispatchReady {n : β„•} (tapes : ControlInstructionTapes n) + (store : Store) (pcValue selector : β„•) + (cleanWork work : Fin (n + 1) β†’ Tape) : Prop := + InstructionExecutionReady tapes store pcValue cleanWork ∧ + work = Function.update cleanWork tapes.liftedLhs + ((Tape.init (selector.bits.map Ξ“.ofBool)).move Dir3.right) + +/-- Common semantic endpoint of every selected instruction before cleanup. -/ +structure InstructionExecutionResult {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (pcValue : β„•) (store : Store) (work : Fin (n + 1) β†’ Tape) : Prop where + /-- The fresh buffer contains exactly the pure next sparse store. -/ + buffer : (work tapes.buffer).HasBinaryPrefix + ((instructionStore instruction pcValue store).flatMap Entry.encode) + /-- The canonical PC equals the pure instruction successor. -/ + pc : (work tapes.liftedPC).HasBinaryNat + (instructionPC instruction pcValue store) + /-- The preserved output-entry count equals the next store cardinality. -/ + resultCount : + (work tapes.lifted.data.update.resultCount).HasBinaryNat + (instructionStore instruction pcValue store).length + /-- The old encoded source remains available for bounded clearing. -/ + sourceContent : (work tapes.liftedSource).HasBinaryContent + (store.flatMap Entry.encode) + /-- Every instruction leaves the cleanup roles as canonical binary naturals. -/ + cleanup : βˆ€ slot, (work (instructionCleanupTape tapes slot)).HasBinaryNat + (instructionCleanupValue instruction store slot) + /-- The runtime old-entry counter has a canonical value before reset. -/ + remaining : (work tapes.lifted.data.update.remaining).HasBinaryNat + (instructionRemainingValue instruction store) + /-- Decode/match scratch is clean; only the update query remains loaded. -/ + scanner : EntryScanReady tapes.lifted.data.update.entry [] + (instructionCleanupValue instruction store 0).bits work work + /-- Lookup query-source scratch is restored. -/ + shift : (work tapes.lifted.data.shift).HasBinaryNat 0 + /-- First multiplication scratch is restored. -/ + tmp : (work tapes.lifted.data.tmp).HasBinaryNat 0 + /-- Second multiplication scratch is restored. -/ + dbl : (work tapes.lifted.data.dbl).HasBinaryNat 0 + /-- Every work head is parked at the instruction/cleanup boundary. -/ + parked : βˆ€ i, TM.Parked (work i) + +/-- Instruction-independent buffered endpoint. This is the semantic interface +needed by physical cleanup; sparse and dense register representations provide +their own next-store, next-PC, and scratch-value witnesses. -/ +structure BufferedInstructionResult {n : β„•} + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (nextPC : β„•) (cleanupValues : Fin 5 β†’ β„•) (remainingValue : β„•) + (work : Fin (n + 1) β†’ Tape) : Prop where + buffer : (work tapes.buffer).HasBinaryPrefix + (nextStore.flatMap Entry.encode) + pc : (work tapes.liftedPC).HasBinaryNat nextPC + resultCount : + (work tapes.lifted.data.update.resultCount).HasBinaryNat nextStore.length + sourceContent : (work tapes.liftedSource).HasBinaryContent + (oldStore.flatMap Entry.encode) + cleanup : βˆ€ slot, + (work (instructionCleanupTape tapes slot)).HasBinaryNat + (cleanupValues slot) + remaining : (work tapes.lifted.data.update.remaining).HasBinaryNat + remainingValue + scanner : EntryScanReady tapes.lifted.data.update.entry [] + (cleanupValues 0).bits work work + shift : (work tapes.lifted.data.shift).HasBinaryNat 0 + tmp : (work tapes.lifted.data.tmp).HasBinaryNat 0 + dbl : (work tapes.lifted.data.dbl).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + +/-- Parent roles reset before the buffered successor store is installed. The +first five are instruction-specific data, followed by the old remaining count +and the old encoded source. -/ +def instructionCleanupResetParentSlot : Fin 7 β†’ Fin 18 + | 0 => 7 + | 1 => 10 + | 2 => 11 + | 3 => 13 + | 4 => 14 + | 5 => 9 + | _ => 0 + +/-- Physical reset target in the one-buffer instruction layout. -/ +def instructionCleanupResetTape {n : β„•} + (tapes : ControlInstructionTapes n) (slot : Fin 7) : Fin (n + 1) := + tapes.lifted.data.idx (instructionCleanupResetParentSlot slot) + +theorem instructionCleanupResetTape_injective {n : β„•} + (tapes : ControlInstructionTapes n) : + Function.Injective (instructionCleanupResetTape tapes) := by + intro i j h + apply Fin.ext + have hparent := tapes.lifted.data.injective h + fin_cases i <;> fin_cases j <;> + simp [instructionCleanupResetParentSlot] at hparent ⊒ + +/-- Fixed distinct list consumed by the bulk binary reset. -/ +def instructionCleanupResetTargets {n : β„•} + (tapes : ControlInstructionTapes n) : List (Fin (n + 1)) := + List.ofFn (instructionCleanupResetTape tapes) + +/-- Binary contents advertised at each reset target. -/ +def instructionCleanupResetBits (instruction : Instr) (store : Store) : + Fin 7 β†’ List Bool + | 0 => (instructionCleanupValue instruction store 0).bits + | 1 => (instructionCleanupValue instruction store 1).bits + | 2 => (instructionCleanupValue instruction store 2).bits + | 3 => (instructionCleanupValue instruction store 3).bits + | 4 => (instructionCleanupValue instruction store 4).bits + | 5 => (instructionRemainingValue instruction store).bits + | _ => store.flatMap Entry.encode + +/-- Head bounds at the seven bulk-reset targets. Canonical natural tapes are +at cell one; only the scanned old source needs an external bound. -/ +def instructionCleanupResetHeadBound (sourceHeadBound : β„•) : Fin 7 β†’ β„• + | 0 | 1 | 2 | 3 | 4 | 5 => 1 + | _ => sourceHeadBound + +/-- Extend the indexed reset contents to the whole physical work family. -/ +noncomputable def instructionCleanupResetBitsAt {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (store : Store) : Fin (n + 1) β†’ List Bool := + Function.extend (instructionCleanupResetTape tapes) + (instructionCleanupResetBits instruction store) (fun _ => []) + +/-- Extend the indexed reset head bounds to the whole work family. -/ +noncomputable def instructionCleanupResetHeadBoundAt {n : β„•} + (tapes : ControlInstructionTapes n) (sourceHeadBound : β„•) : + Fin (n + 1) β†’ β„• := + Function.extend (instructionCleanupResetTape tapes) + (instructionCleanupResetHeadBound sourceHeadBound) (fun _ => 0) + +/-- Binary contents reset by representation-independent buffered cleanup. -/ +def bufferedCleanupResetBits (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) (oldStore : Store) : Fin 7 β†’ List Bool + | 0 => (cleanupValues 0).bits + | 1 => (cleanupValues 1).bits + | 2 => (cleanupValues 2).bits + | 3 => (cleanupValues 3).bits + | 4 => (cleanupValues 4).bits + | 5 => remainingValue.bits + | _ => oldStore.flatMap Entry.encode + +/-- Extend generic buffered-cleanup contents to all physical work tapes. -/ +noncomputable def bufferedCleanupResetBitsAt {n : β„•} + (tapes : ControlInstructionTapes n) (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) (oldStore : Store) : Fin (n + 1) β†’ List Bool := + Function.extend (instructionCleanupResetTape tapes) + (bufferedCleanupResetBits cleanupValues remainingValue oldStore) + (fun _ => []) + +/-- Canonical tape with `bits` and its head immediately after the payload. -/ +def instructionCleanupPrefixTape (bits : List Bool) : Tape where + head := bits.length + 1 + cells := (Tape.init (bits.map Ξ“.ofBool)).cells + +/-- Buffered post-state plus the two left markers and old-source cursor bound +needed by the executable cleanup pass. -/ +structure InstructionCleanupReady {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (pcValue : β„•) (store : Store) (sourceHeadBound : β„•) + (work : Fin (n + 1) β†’ Tape) : Prop where + canonical : Canonical store + result : InstructionExecutionResult tapes instruction pcValue store work + sourceStart : (work tapes.liftedSource).cells 0 = Ξ“.start + bufferStart : (work tapes.buffer).cells 0 = Ξ“.start + sourceHead : (work tapes.liftedSource).head ≀ sourceHeadBound + +/-- Representation-independent input boundary for the physical cleanup pass. -/ +structure BufferedCleanupReady {n : β„•} + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (nextPC : β„•) (cleanupValues : Fin 5 β†’ β„•) (remainingValue : β„•) + (sourceHeadBound : β„•) (work : Fin (n + 1) β†’ Tape) : Prop where + nextCanonical : Canonical nextStore + result : BufferedInstructionResult tapes oldStore nextStore nextPC + cleanupValues remainingValue work + sourceStart : (work tapes.liftedSource).cells 0 = Ξ“.start + bufferStart : (work tapes.buffer).cells 0 = Ξ“.start + sourceHead : (work tapes.liftedSource).head ≀ sourceHeadBound + +/-- Restore the clean instruction ABI around the buffered successor store. -/ +def instructionCleanupTM {n : β„•} + (tapes : ControlInstructionTapes n) : TM (n + 1) := + TM.seqTM + (TM.resetBinaryWorkManyTM (instructionCleanupResetTargets tapes)) + (TM.seqTM (TM.rewindWorkTM tapes.buffer) + (TM.seqTM + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining + tapes.lifted.data.update.found))))) + +/-- Exact compositional cleanup bound for one buffered instruction result. -/ +noncomputable def instructionCleanupTime {n : β„•} + (tapes : ControlInstructionTapes n) (instruction : Instr) + (pcValue : β„•) (store : Store) (sourceHeadBound : β„•) : β„• := + let nextStore := instructionStore instruction pcValue store + let nextBits := nextStore.flatMap Entry.encode + TM.resetBinaryWorkManyTime + (instructionCleanupResetBitsAt tapes instruction store) + (instructionCleanupResetHeadBoundAt tapes sourceHeadBound) + (instructionCleanupResetTargets tapes) + 1 + + ((nextBits.length + 1 + 2) + 1 + + ((nextBits.length + 1) + 1 + + (TM.resetBinaryWorkTime (nextBits.length + 1) nextBits.length + 1 + + ((nextBits.length + 1 + 2) + 1 + + TM.binaryCopyTime nextStore.length 0)))) + +/-- Exact cleanup budget expressed only through the buffered representation +boundary, independent of the instruction semantics that produced it. -/ +noncomputable def bufferedCleanupTime {n : β„•} + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (cleanupValues : Fin 5 β†’ β„•) (remainingValue sourceHeadBound : β„•) : β„• := + let nextBits := nextStore.flatMap Entry.encode + TM.resetBinaryWorkManyTime + (bufferedCleanupResetBitsAt tapes cleanupValues remainingValue oldStore) + (instructionCleanupResetHeadBoundAt tapes sourceHeadBound) + (instructionCleanupResetTargets tapes) + 1 + + ((nextBits.length + 1 + 2) + 1 + + ((nextBits.length + 1) + 1 + + (TM.resetBinaryWorkTime (nextBits.length + 1) nextBits.length + 1 + + ((nextBits.length + 1 + 2) + 1 + + TM.binaryCopyTime nextStore.length 0)))) + +/-- Runtime bound for a statically selected instruction before iteration +cleanup. -/ +def executeInstructionTime {n : β„•} (tapes : ControlInstructionTapes n) + (instruction : Instr) (pcValue : β„•) (store : Store) : β„• := + match instruction with + | .imm destination value => + immediateInstructionTime tapes.data store destination value + 1 + + TM.binarySuccTime pcValue + | .add destination sourceβ‚€ source₁ => + directBinaryInstructionTime tapes.data .add store destination sourceβ‚€ + source₁ + 1 + TM.binarySuccTime pcValue + | .sub destination sourceβ‚€ source₁ => + directBinaryInstructionTime tapes.data .sub store destination sourceβ‚€ + source₁ + 1 + TM.binarySuccTime pcValue + | .mul destination sourceβ‚€ source₁ => + directBinaryInstructionTime tapes.data .mul store destination sourceβ‚€ + source₁ + 1 + TM.binarySuccTime pcValue + | .load destination addressRegister => + indirectLoadInstructionTime tapes.data store destination addressRegister + + 1 + TM.binarySuccTime pcValue + | .store addressRegister source => + indirectStoreInstructionTime tapes.data store addressRegister source + 1 + + TM.binarySuccTime pcValue + | .jz source target => + zeroJumpInstructionTime tapes.lifted store pcValue source target + 1 + + (store.flatMap Entry.encode).length + 1 + | .jmp target => + jumpInstructionTime pcValue target + 1 + + (store.flatMap Entry.encode).length + 1 + | .halt => + haltInstructionTime + 1 + (store.flatMap Entry.encode).length + 1 + +/-- Representation-independent path-sensitive branch-tree time. Unlike the +coarse branch combinator bound, this charges only the instruction selected by +the represented selector. -/ +def dispatchWithTime {n : β„•} (tapes : ControlInstructionTapes n) + (executeTime : Instr β†’ β„•) : Program β†’ β„• β†’ β„• + | [], selector => + TM.resetBinaryWorkTime 1 selector.bits.length + 1 + executeTime .halt + | instruction :: _, 0 => executeTime instruction + 1 + | _ :: program, selector + 1 => + TM.binaryPredTime selector + 1 + + dispatchWithTime tapes executeTime program selector + 1 + +/-- Branch-tree bound for a selector currently represented by `selector`. -/ +def dispatchProgramTime {n : β„•} (tapes : ControlInstructionTapes n) + (store : Store) (pcValue : β„•) : Program β†’ β„• β†’ β„• + | [], selector => + TM.resetBinaryWorkTime 1 selector.bits.length + 1 + + executeInstructionTime tapes .halt pcValue store + | instruction :: program, selector => + TM.branchWorkBlankTime + (executeInstructionTime tapes instruction pcValue store) + (TM.binaryPredTime (selector - 1) + 1 + + dispatchProgramTime tapes store pcValue program (selector - 1)) + +/-- Complete fixed-program selection and selected-instruction bound. -/ +def programInstructionTime {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) (pcValue : β„•) (store : Store) : β„• := + TM.binaryCopyTime pcValue 0 + 1 + + dispatchProgramTime tapes store pcValue program pcValue + +/-- Select and execute one RAM instruction, then restore the clean instruction +ABI for the successor snapshot. -/ +def programStepTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM (programInstructionTM tapes program) (instructionCleanupTM tapes) + +/-- Source-head bound available after fixed-program selection and execution. -/ +def programStepSourceHeadBound {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (pcValue : β„•) (store : Store) : β„• := + 1 + programInstructionTime tapes program pcValue store + +/-- Exact compositional time bound for one selected and cleaned RAM step. -/ +noncomputable def programStepTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (pcValue : β„•) (store : Store) : β„• := + let instruction := selectedInstruction program pcValue + programInstructionTime tapes program pcValue store + 1 + + instructionCleanupTime tapes instruction pcValue store + (programStepSourceHeadBound tapes program pcValue store) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Internal.lean new file mode 100644 index 0000000000..1b9c2f1640 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Sim/Internal.lean @@ -0,0 +1,1732 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany + +/-! +# Fixed-program dispatch -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem instructionCleanupPrefixTape_hasBinaryPrefix + (bits : List Bool) : + (instructionCleanupPrefixTape bits).HasBinaryPrefix bits := by + refine ⟨rfl, ?_, ?_⟩ + Β· intro i hi + exact Tape.init_ofBool_cells_lt bits i hi + Β· intro i hi + exact Tape.init_ofBool_cells_ge bits i hi + +private theorem instructionCleanupPrefixTape_start (bits : List Bool) : + (instructionCleanupPrefixTape bits).cells 0 = Ξ“.start := by + simp [instructionCleanupPrefixTape, Tape.init] + +private theorem instructionCleanupPrefixTape_parked (bits : List Bool) : + TM.Parked (instructionCleanupPrefixTape bits) := + hasBinaryPrefix_parked (instructionCleanupPrefixTape_hasBinaryPrefix bits) + +private theorem hasBinaryString_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : TM.Parked t := by + exact ⟨by rw [h.1], Tape.cells_ne_start_of_hasBinaryString h⟩ + +private theorem blank_parked : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.move, Tape.init, show j β‰  0 by omega] + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Reset the dispatch selector and execute halt when the program list is empty. -/ +private theorem dispatchEmptyProgramTM_hoareTime + (tapes : ControlInstructionTapes n) + (store : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : DispatchReady tapes store pcValue selector cleanWork workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) + (hexecute : βˆ€ instruction, + (executeInstructionTM tapes instruction).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes instruction pcValue store work ∧ + out = outβ‚€) + (executeInstructionTime tapes instruction pcValue store)) : + (dispatchProgramTM tapes ([] : Program)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction ([] : Program) selector) pcValue store work ∧ + out = outβ‚€) + (dispatchProgramTime tapes store pcValue ([] : Program) selector) := by + let blankTape := (Tape.init []).move Dir3.right + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hcleanLhs : cleanWork tapes.liftedLhs = blankTape := by + have hzero := hready.1.control.lookup.destination + change (cleanWork tapes.liftedLhs).HasBinaryNat 0 at hzero + simpa only [blankTape] using! + Tape.HasBinaryNat.eq_init_move_right hzero + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + rw [hready.2] + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat selector) + Β· simp only [Function.update_of_ne hi] + exact hready.1.control.lookup.scanner.parked i + have hreset := TM.resetBinaryWorkTM_hoareTime_frame tapes.liftedLhs + selector.bits 1 inpβ‚€ workβ‚€ outβ‚€ + hselector.2.hasBinaryContent hselector.1 + ⟨by rw [hselector.2.1], by rw [hselector.2.1]⟩ + hinput (fun i _ => hworkβ‚€Parked i) houtput + have hreset' : (TM.resetBinaryWorkTM tapes.liftedLhs).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = cleanWork ∧ out = outβ‚€) + (TM.resetBinaryWorkTime 1 selector.bits.length) := by + apply hreset.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + refine ⟨hinp, ?_, hout⟩ + rw [hworkEq, hready.2, Function.update_idem] + change Function.update cleanWork tapes.liftedLhs blankTape = cleanWork + rw [← hcleanLhs, Function.update_eq_self] + Β· exact le_rfl + have hseq := TM.seqTM_hoareTime + (TM.resetBinaryWorkTM tapes.liftedLhs) + (executeInstructionTM tapes .halt) hreset' + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) + (by simpa [hworkEq] using + hready.1.control.lookup.scanner.parked) + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hworkEq, hout⟩) + (hexecute .halt) + simpa only [dispatchProgramTM, dispatchProgramTime, + selectedInstruction] using hseq + +/-- The finite decrementing branch tree selects the corresponding static +instruction, assuming the individual instruction kernels satisfy their common +semantic contract. -/ +theorem dispatchProgramTM_hoareTime_of_execute_internal + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : DispatchReady tapes store pcValue selector cleanWork workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) + (hexecute : βˆ€ instruction, + (executeInstructionTM tapes instruction).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes instruction pcValue store work ∧ + out = outβ‚€) + (executeInstructionTime tapes instruction pcValue store)) : + (dispatchProgramTM tapes program).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction program selector) pcValue store work ∧ + out = outβ‚€) + (dispatchProgramTime tapes store pcValue program selector) := by + induction program generalizing selector workβ‚€ with + | nil => + exact dispatchEmptyProgramTM_hoareTime tapes store pcValue selector + cleanWork workβ‚€ inpβ‚€ outβ‚€ hready hinput houtput hexecute + | cons instruction program ih => + let pre : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€ + let post : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction (instruction :: program) selector) + pcValue store work ∧ + out = outβ‚€ + let blankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector = 0 + let nonblankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector β‰  0 + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + rw [hready.2] + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked (Tape.init_move_right_hasBinaryNat selector) + Β· simp only [Function.update_of_ne hi] + exact hready.1.control.lookup.scanner.parked i + have hblank : (executeInstructionTM tapes instruction).HoareTime + blankPre post + (executeInstructionTime tapes instruction pcValue store) := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hzero⟩ + subst selector + have hcleanLhs := Tape.HasBinaryNat.eq_init_move_right + hready.1.control.lookup.destination + change cleanWork tapes.liftedLhs = + (Tape.init []).move Dir3.right at hcleanLhs + have hworkClean : work = cleanWork := by + rw [hworkEq, hready.2] + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hcleanLhs.symm + Β· simp only [Function.update_of_ne hi] + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hresult, hfinalOutput⟩ := + hexecute instruction inp cleanWork out ⟨hinp, rfl, hout⟩ + refine ⟨final, time, htime, ?_, hhalt, hfinalInput, ?_, hfinalOutput⟩ + Β· simpa [hworkClean] using hreach + Β· simpa only [selectedInstruction] using hresult + have hnonblank : + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchProgramTM tapes program)).HoareTime + nonblankPre post + (TM.binaryPredTime (selector - 1) + 1 + + dispatchProgramTime tapes store pcValue program (selector - 1)) := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hnonzero⟩ + have hsucc : selector = (selector - 1) + 1 := by omega + have hvalue : (work tapes.liftedLhs).HasBinaryNat + ((selector - 1) + 1) := by + rw [hworkEq] + rw [hsucc] at hselector + exact hselector + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have houtParked : TM.Parked out := by simpa [hout] using houtput + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + simpa [hworkEq] using hworkβ‚€Parked i + have hpred := TM.binaryPredTM_hoareTime_frame tapes.liftedLhs + (selector - 1) inp work out hvalue hinpParked.read_ne_start + (fun i _ => (hworkParked i).read_ne_start) + houtParked.read_ne_start + let nextWork := Function.update cleanWork tapes.liftedLhs + ((Tape.init ((selector - 1).bits.map Ξ“.ofBool)).move Dir3.right) + have hpred' : (TM.binaryPredTM tapes.liftedLhs).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = nextWork ∧ out' = out) + (TM.binaryPredTime (selector - 1)) := by + apply hpred.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp' work' out' ⟨hinp', hframe, hvalue', hout'⟩ + refine ⟨hinp', ?_, hout'⟩ + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact Tape.HasBinaryNat.eq_init_move_right hvalue' + Β· simp only [nextWork, Function.update_of_ne hi] + rw [hframe i hi, hworkEq, hready.2, + Function.update_of_ne hi] + Β· exact le_rfl + have hnextReady : DispatchReady tapes store pcValue (selector - 1) + cleanWork nextWork := ⟨hready.1, rfl⟩ + have hrecursive := ih (selector - 1) nextWork hnextReady + have hrecursive' : (dispatchProgramTM tapes program).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = nextWork ∧ out' = out) + post + (dispatchProgramTime tapes store pcValue program + (selector - 1)) := by + apply hrecursive.consequence + Β· rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + exact ⟨hinp'.trans hinp, hwork', hout'.trans hout⟩ + Β· rintro inp' work' out' ⟨hinp', hresult, hout'⟩ + have hselected : + selectedInstruction (instruction :: program) selector = + selectedInstruction program (selector - 1) := by + rw [hsucc] + rfl + exact ⟨hinp', by simpa only [hselected] using hresult, hout'⟩ + Β· exact le_rfl + have hseq := TM.seqTM_hoareTime (TM.binaryPredTM tapes.liftedLhs) + (dispatchProgramTM tapes program) hpred' + (by + rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp') (work := work') (out := out') + (by simpa [hinp', hinp] using hinput) + (by + intro i + rw [hwork'] + by_cases hidx : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat (selector - 1)) + Β· simp only [nextWork, Function.update_of_ne hidx] + exact hready.1.control.lookup.scanner.parked i) + (by simpa [hout', hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp', hwork', hout'⟩) + hrecursive' + exact hseq inp work out ⟨rfl, rfl, rfl⟩ + have hdispatch := TM.branchWorkBlankTM_hoareTime tapes.liftedLhs + (executeInstructionTM tapes instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchProgramTM tapes program)) + (pre := pre) (blankPre := blankPre) (nonblankPre := nonblankPre) + (blankPost := post) (nonblankPost := post) + (fun inp work out hpre => by + have hinpParked : TM.Parked inp := by simpa [hpre.1] using hinput + have houtParked : TM.Parked out := by simpa [hpre.2.2] using houtput + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + simpa [hpre.2.1] using hworkβ‚€Parked i + exact ⟨hinpParked.read_ne_start, + fun i => (hworkParked i).read_ne_start, + houtParked.read_ne_start⟩) + (fun _ work _ hpre hread => + ⟨hpre, hselector.read_eq_blank_iff.mp (by simpa [hpre.2.1] using hread)⟩) + (fun _ work _ hpre hread => + ⟨hpre, fun hzero => hread (by + rw [hpre.2.1] + exact hselector.read_eq_blank_iff.mpr hzero)⟩) + hblank hnonblank + simpa only [dispatchProgramTM, dispatchProgramTime, pre, post] using + hdispatch.consequence (fun _ _ _ h => h) + (fun _ _ _ h => h.elim id id) le_rfl + +/-- Reset the seven cleanup targets while preserving the buffer and all other data roles. -/ +private theorem bufferedCleanup_resetPhase + (tapes : ControlInstructionTapes n) + (oldStore : Store) + (nextStore : Store) + (nextPC : β„•) + (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (outβ‚€ : Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) + (houtput : TM.Parked outβ‚€) + : + let targets := instructionCleanupResetTargets tapes + let resetBits := bufferedCleanupResetBitsAt tapes cleanupValues + remainingValue oldStore + let resetHeads := + instructionCleanupResetHeadBoundAt tapes sourceHeadBound + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + ((TM.resetBinaryWorkManyTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = resetWork ∧ out = outβ‚€) + (TM.resetBinaryWorkManyTime resetBits resetHeads targets)) ∧ + (βˆ€ (role : Fin 18) + (hrole : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + resetWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) ∧ + (resetWork tapes.buffer = initialWork tapes.buffer) ∧ + (βˆ€ i, TM.Parked (resetWork i)) ∧ + (βˆ€ (slot : Fin 7), + resetWork (instructionCleanupResetTape tapes slot) = + TM.resetBinaryBlank) := by + intro targets resetBits resetHeads resetWork + have hresetContentIndexed : βˆ€ slot, + (initialWork (instructionCleanupResetTape tapes slot)).HasBinaryContent + (bufferedCleanupResetBits cleanupValues remainingValue oldStore + slot) := by + intro slot + fin_cases slot + Β· exact (hready.result.cleanup 0).2.hasBinaryContent + Β· exact (hready.result.cleanup 1).2.hasBinaryContent + Β· exact (hready.result.cleanup 2).2.hasBinaryContent + Β· exact (hready.result.cleanup 3).2.hasBinaryContent + Β· exact (hready.result.cleanup 4).2.hasBinaryContent + Β· exact hready.result.remaining.2.hasBinaryContent + Β· exact hready.result.sourceContent + have hresetStartIndexed : βˆ€ slot, + (initialWork (instructionCleanupResetTape tapes slot)).cells 0 = + Ξ“.start := by + intro slot + fin_cases slot + Β· exact (hready.result.cleanup 0).1 + Β· exact (hready.result.cleanup 1).1 + Β· exact (hready.result.cleanup 2).1 + Β· exact (hready.result.cleanup 3).1 + Β· exact (hready.result.cleanup 4).1 + Β· exact hready.result.remaining.1 + Β· exact hready.sourceStart + have hresetHeadIndexed : βˆ€ slot, + (initialWork (instructionCleanupResetTape tapes slot)).head ≀ + instructionCleanupResetHeadBound sourceHeadBound slot := by + intro slot + fin_cases slot + Β· simpa using! (hready.result.cleanup 0).2.1.le + Β· simpa using! (hready.result.cleanup 1).2.1.le + Β· simpa using! (hready.result.cleanup 2).2.1.le + Β· simpa using! (hready.result.cleanup 3).2.1.le + Β· simpa using! (hready.result.cleanup 4).2.1.le + Β· simpa using! hready.result.remaining.2.1.le + Β· exact hready.sourceHead + have hreset := TM.resetBinaryWorkManyTM_hoareTime_frame targets resetBits + resetHeads inpβ‚€ initialWork outβ‚€ + (by + exact List.nodup_ofFn_ofInjective + (instructionCleanupResetTape_injective tapes)) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + change (initialWork (instructionCleanupResetTape tapes slot)).HasBinaryContent + (bufferedCleanupResetBitsAt tapes cleanupValues remainingValue oldStore + (instructionCleanupResetTape tapes slot)) + rw [bufferedCleanupResetBitsAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + exact hresetContentIndexed slot) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + exact hresetStartIndexed slot) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + change (initialWork (instructionCleanupResetTape tapes slot)).head ≀ + instructionCleanupResetHeadBoundAt tapes sourceHeadBound + (instructionCleanupResetTape tapes slot) + rw [instructionCleanupResetHeadBoundAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + exact hresetHeadIndexed slot) + hinput hready.result.parked houtput + have hdataNotMem (role : Fin 18) + (hrole : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot) : + tapes.lifted.data.idx role βˆ‰ targets := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + exact tapes.lifted.data.ne (hrole slot) hslot.symm + have hbufferNotMem : tapes.buffer βˆ‰ targets := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + exact tapes.liftedData_ne_buffer + (instructionCleanupResetParentSlot slot) hslot + have hresetDataOutside (role : Fin 18) + (hrole : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot) : + resetWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role) := by + exact TM.resetBinaryWorkManyResult_eq_of_not_mem initialWork targets _ + (hdataNotMem role hrole) + have hresetBuffer : resetWork tapes.buffer = initialWork tapes.buffer := by + exact TM.resetBinaryWorkManyResult_eq_of_not_mem initialWork targets _ + hbufferNotMem + have hresetParked : βˆ€ i, TM.Parked (resetWork i) := by + exact TM.resetBinaryWorkManyResult_parked initialWork targets + hready.result.parked + have hresetTarget (slot : Fin 7) : + resetWork (instructionCleanupResetTape tapes slot) = + TM.resetBinaryBlank := by + exact TM.resetBinaryWorkManyResult_eq_blank_of_mem initialWork targets _ + (List.mem_ofFn.mpr ⟨slot, rfl⟩) + exact ⟨hreset, hresetDataOutside, hresetBuffer, hresetParked, hresetTarget⟩ + +/-- Rewind the preserved next-store buffer with the source blank and all tapes parked. -/ +private theorem bufferedCleanup_rewindBufferPhase + (tapes : ControlInstructionTapes n) + (oldStore : Store) + (nextStore : Store) + (nextPC : β„•) + (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (outβ‚€ : Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) + (houtput : TM.Parked outβ‚€) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + (resetWork tapes.buffer = initialWork tapes.buffer) β†’ + (βˆ€ i, TM.Parked (resetWork i)) β†’ + (βˆ€ (slot : Fin 7), + resetWork (instructionCleanupResetTape tapes slot) = + TM.resetBinaryBlank) β†’ + ((TM.rewindWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = resetWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (nextBits.length + 1 + 2)) ∧ + (rewoundWork tapes.liftedSource = TM.resetBinaryBlank) ∧ + (βˆ€ i, TM.Parked (rewoundWork i)) := by + intro nextBits targets resetWork nextTape rewoundWork hresetBuffer hresetParked hresetTarget + have hresetBufferContent : + (resetWork tapes.buffer).HasBinaryContent nextBits := by + rw [hresetBuffer] + exact hready.result.buffer.2 + have hresetBufferStart : (resetWork tapes.buffer).cells 0 = Ξ“.start := by + rw [hresetBuffer] + exact hready.bufferStart + have hresetBufferHead : + (resetWork tapes.buffer).head = nextBits.length + 1 := by + rw [hresetBuffer] + exact hready.result.buffer.1 + have hrewindRaw := TM.rewindBinaryWorkTM_hoareTime_frame tapes.buffer + nextBits (nextBits.length + 1) inpβ‚€ resetWork outβ‚€ + hresetBufferContent hresetBufferStart + ⟨by rw [hresetBufferHead]; omega, hresetBufferHead.le⟩ hinput + (fun i _ => hresetParked i) houtput + have hrewind : (TM.rewindWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = resetWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (nextBits.length + 1 + 2) := hrewindRaw.strengthen_post (by + rintro inp work out ⟨hinp, htarget, hframe, hout⟩ + have hwork : work = rewoundWork := by + funext i + by_cases hi : i = tapes.buffer + Β· subst i + simpa [rewoundWork, nextTape] using htarget + Β· simp [rewoundWork, hi, hframe i hi] + exact ⟨hinp, hwork, hout⟩) + have hresetSource : resetWork tapes.liftedSource = TM.resetBinaryBlank := by + simpa [instructionCleanupResetTape, instructionCleanupResetParentSlot, + ControlInstructionTapes.liftedSource] using! hresetTarget 6 + have hrewoundSource : + rewoundWork tapes.liftedSource = TM.resetBinaryBlank := by + simp [rewoundWork, tapes.liftedSource_ne_buffer, hresetSource] + have hrewoundParked : βˆ€ i, TM.Parked (rewoundWork i) := by + intro i + by_cases hi : i = tapes.buffer + Β· subst i + simp only [rewoundWork, Function.update_self, nextTape] + exact hasBinaryString_parked + (Tape.init_move_right_hasBinaryString nextBits) + Β· simp only [rewoundWork, Function.update_of_ne hi] + exact hresetParked i + exact ⟨hrewind, hrewoundSource, hrewoundParked⟩ + +/-- Copy the next-store bits from the rewound buffer to the blank source with an exact frame. -/ +private theorem bufferedCleanup_copyPhase + (tapes : ControlInstructionTapes n) + (nextStore : Store) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) + (houtput : TM.Parked outβ‚€) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + (rewoundWork tapes.liftedSource = TM.resetBinaryBlank) β†’ + (βˆ€ i, TM.Parked (rewoundWork i)) β†’ + ((TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (nextBits.length + 1)) ∧ + (copiedWork tapes.buffer = prefixTape) ∧ + (copiedWork tapes.liftedSource = prefixTape) ∧ + (βˆ€ i, TM.Parked (copiedWork i)) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork hrewoundSource + hrewoundParked + let copyFrame : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ out = outβ‚€ ∧ + βˆ€ i, i β‰  tapes.buffer β†’ i β‰  tapes.liftedSource β†’ + work i = rewoundWork i + have hcopyBase := TM.copyWorkToWorkTM_hoareTime_frame_of_binaryString + tapes.buffer tapes.liftedSource tapes.liftedSource_ne_buffer.symm + nextBits (P := copyFrame) + (by + rintro inp work out inp' work' out' + ⟨hinp, hout, hframe⟩ _ _ _ _ hinpEq houtEq hworkFrame + refine ⟨hinpEq.trans hinp, houtEq.trans hout, ?_⟩ + intro i hiBuffer hiSource + rw [hworkFrame i hiBuffer hiSource] + exact hframe i hiBuffer hiSource) + have hcopyReady : + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (fun inp work out => + (work tapes.buffer).cells = + (Tape.init (nextBits.map Ξ“.ofBool)).cells ∧ + (work tapes.buffer).head = nextBits.length + 1 ∧ + (work tapes.liftedSource).HasBinaryPrefix nextBits ∧ + (work tapes.liftedSource).cells 0 = Ξ“.start ∧ + copyFrame inp work out) + (nextBits.length + 1) := hcopyBase.consequence + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + refine ⟨?_, hrewoundSource, ?_, ?_, ?_, ?_, ?_⟩ + Β· simp [rewoundWork, nextTape] + Β· simpa [hinp] using hinput.read_ne_start + Β· simpa [hout] using houtput.read_ne_start + Β· simpa [hout] using houtput.1 + Β· intro i _ _ + exact ⟨(hrewoundParked i).read_ne_start, (hrewoundParked i).1⟩ + Β· exact ⟨hinp, hout, fun _ _ _ => rfl⟩) + (fun _ _ _ h => h) le_rfl + have hcopy : + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = rewoundWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (nextBits.length + 1) := hcopyReady.strengthen_post (by + rintro inp work out ⟨hsrcCells, hsrcHead, hdstPrefix, hdstStart, + hinp, hout, hframe⟩ + have hsrc : work tapes.buffer = prefixTape := by + exact Tape.ext (by simpa [prefixTape, instructionCleanupPrefixTape] + using hsrcHead) (by simpa [prefixTape, instructionCleanupPrefixTape] + using hsrcCells) + have hdst : work tapes.liftedSource = prefixTape := by + exact Tape.ext (by simpa [prefixTape, instructionCleanupPrefixTape] + using hdstPrefix.1) (by + simpa [prefixTape, instructionCleanupPrefixTape] using + hdstPrefix.cells_eq_init hdstStart) + have hwork : work = copiedWork := by + funext i + by_cases hiSource : i = tapes.liftedSource + Β· subst i + simp [copiedWork, hdst] + by_cases hiBuffer : i = tapes.buffer + Β· subst i + simpa only [copiedWork, + Function.update_of_ne tapes.liftedSource_ne_buffer.symm, + Function.update_self] using hsrc + Β· simp [copiedWork, hiSource, hiBuffer, + hframe i hiBuffer hiSource] + exact ⟨hinp, hwork, hout⟩) + have hcopiedBuffer : copiedWork tapes.buffer = prefixTape := by + simp [copiedWork, tapes.liftedSource_ne_buffer.symm] + have hcopiedSource : copiedWork tapes.liftedSource = prefixTape := by + simp [copiedWork] + have hcopiedParked : βˆ€ i, TM.Parked (copiedWork i) := by + intro i + by_cases hiSource : i = tapes.liftedSource + Β· subst i + simpa [hcopiedSource] using + instructionCleanupPrefixTape_parked nextBits + by_cases hiBuffer : i = tapes.buffer + Β· subst i + simpa [hcopiedBuffer] using + instructionCleanupPrefixTape_parked nextBits + Β· simp [copiedWork, hiSource, hiBuffer] + exact hrewoundParked i + exact ⟨hcopy, hcopiedBuffer, hcopiedSource, hcopiedParked⟩ + +/-- Clear the copied buffer and rewind the source, preserving the other reset tapes. -/ +private theorem bufferedCleanup_restoreSourcePhase + (tapes : ControlInstructionTapes n) + (nextStore : Store) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) + (houtput : TM.Parked outβ‚€) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + (copiedWork tapes.buffer = prefixTape) β†’ + (copiedWork tapes.liftedSource = prefixTape) β†’ + (βˆ€ i, TM.Parked (copiedWork i)) β†’ + (βˆ€ i, TM.Parked (resetWork i)) β†’ + ((TM.resetBinaryWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = bufferResetWork ∧ out = outβ‚€) + (TM.resetBinaryWorkTime (nextBits.length + 1) nextBits.length)) ∧ + ((TM.rewindWorkTM tapes.liftedSource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = bufferResetWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = sourceReadyWork ∧ out = outβ‚€) + (nextBits.length + 1 + 2)) ∧ + (βˆ€ (i : Fin (n + 1)) + (hiSource : i β‰  tapes.liftedSource) (hiBuffer : i β‰  tapes.buffer), + sourceReadyWork i = resetWork i) ∧ + (βˆ€ i, TM.Parked (sourceReadyWork i)) ∧ + (βˆ€ i, TM.Parked (bufferResetWork i)) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork hcopiedBuffer hcopiedSource hcopiedParked hresetParked + have hresetBufferRaw := TM.resetBinaryWorkTM_hoareTime_frame tapes.buffer + nextBits (nextBits.length + 1) inpβ‚€ copiedWork outβ‚€ + (by + rw [hcopiedBuffer] + exact (instructionCleanupPrefixTape_hasBinaryPrefix nextBits).2) + (by + rw [hcopiedBuffer] + exact instructionCleanupPrefixTape_start nextBits) + (by + rw [hcopiedBuffer] + exact ⟨by simp [prefixTape, instructionCleanupPrefixTape], le_rfl⟩) + hinput (fun i _ => hcopiedParked i) houtput + have hresetBufferPhase : (TM.resetBinaryWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = bufferResetWork ∧ out = outβ‚€) + (TM.resetBinaryWorkTime (nextBits.length + 1) nextBits.length) := by + simpa only [bufferResetWork] using hresetBufferRaw + have hbufferResetSource : + bufferResetWork tapes.liftedSource = prefixTape := by + simp [bufferResetWork, tapes.liftedSource_ne_buffer, hcopiedSource] + have hbufferResetParked : βˆ€ i, TM.Parked (bufferResetWork i) := by + intro i + by_cases hi : i = tapes.buffer + Β· subst i + simp only [bufferResetWork, Function.update_self] + exact hasBinaryString_parked + (Tape.init_move_right_hasBinaryString []) + Β· simp only [bufferResetWork, Function.update_of_ne hi] + exact hcopiedParked i + have hrewindSourceRaw := TM.rewindBinaryWorkTM_hoareTime_frame + tapes.liftedSource nextBits (nextBits.length + 1) inpβ‚€ bufferResetWork + outβ‚€ + (by + rw [hbufferResetSource] + exact (instructionCleanupPrefixTape_hasBinaryPrefix nextBits).2) + (by + rw [hbufferResetSource] + exact instructionCleanupPrefixTape_start nextBits) + (by + rw [hbufferResetSource] + exact ⟨by simp [prefixTape, instructionCleanupPrefixTape], le_rfl⟩) + hinput (fun i _ => hbufferResetParked i) houtput + have hrewindSource : (TM.rewindWorkTM tapes.liftedSource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = bufferResetWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ work = sourceReadyWork ∧ out = outβ‚€) + (nextBits.length + 1 + 2) := + hrewindSourceRaw.strengthen_post (by + rintro inp work out ⟨hinp, htarget, hframe, hout⟩ + have hwork : work = sourceReadyWork := by + funext i + by_cases hi : i = tapes.liftedSource + Β· subst i + simpa [sourceReadyWork, nextTape] using htarget + Β· simp [sourceReadyWork, hi, hframe i hi] + exact ⟨hinp, hwork, hout⟩) + have hsourceReadyOutside (i : Fin (n + 1)) + (hiSource : i β‰  tapes.liftedSource) (hiBuffer : i β‰  tapes.buffer) : + sourceReadyWork i = resetWork i := by + simp [sourceReadyWork, bufferResetWork, copiedWork, rewoundWork, + hiSource, hiBuffer] + have hsourceReadyParked : βˆ€ i, TM.Parked (sourceReadyWork i) := by + intro i + by_cases hiSource : i = tapes.liftedSource + Β· subst i + simp only [sourceReadyWork, Function.update_self, nextTape] + exact hasBinaryString_parked + (Tape.init_move_right_hasBinaryString nextBits) + by_cases hiBuffer : i = tapes.buffer + Β· subst i + simp only [sourceReadyWork, Function.update_of_ne + tapes.liftedSource_ne_buffer.symm] + exact hbufferResetParked tapes.buffer + Β· rw [hsourceReadyOutside i hiSource hiBuffer] + exact hresetParked i + exact ⟨hresetBufferPhase, hrewindSource, hsourceReadyOutside, + hsourceReadyParked, hbufferResetParked⟩ + +/-- Copy the next-store entry count into the cleared remaining-count tape. -/ +private theorem bufferedCleanup_copyCountPhase + (tapes : ControlInstructionTapes n) + (oldStore : Store) + (nextStore : Store) + (nextPC : β„•) + (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (outβ‚€ : Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) + (houtput : TM.Parked outβ‚€) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + (βˆ€ (i : Fin (n + 1)) + (hiSource : i β‰  tapes.liftedSource) (hiBuffer : i β‰  tapes.buffer), + sourceReadyWork i = resetWork i) β†’ + (βˆ€ (role : Fin 18) + (hrole : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + resetWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) β†’ + (βˆ€ (slot : Fin 7), + resetWork (instructionCleanupResetTape tapes slot) = + TM.resetBinaryBlank) β†’ + (βˆ€ i, TM.Parked (sourceReadyWork i)) β†’ + ((TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining + tapes.lifted.data.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = sourceReadyWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = finalWork ∧ out = outβ‚€) + (TM.binaryCopyTime nextStore.length 0)) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork countTape finalWork hsourceReadyOutside hresetDataOutside hresetTarget + hsourceReadyParked + have hresultCount : + (sourceReadyWork tapes.lifted.data.update.resultCount).HasBinaryNat + nextStore.length := by + change (sourceReadyWork (tapes.lifted.data.idx 12)).HasBinaryNat _ + rw [hsourceReadyOutside _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 12), + hresetDataOutside 12 (by intro slot; fin_cases slot <;> decide)] + exact hready.result.resultCount + have hremainingZero : + (sourceReadyWork tapes.lifted.data.update.remaining).HasBinaryNat 0 := by + change (sourceReadyWork (tapes.lifted.data.idx 9)).HasBinaryNat 0 + rw [hsourceReadyOutside _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 9)] + have htarget : resetWork (tapes.lifted.data.idx 9) = + TM.resetBinaryBlank := by + simpa [instructionCleanupResetTape, + instructionCleanupResetParentSlot] using hresetTarget 5 + rw [htarget] + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + have hfoundZero : + (sourceReadyWork tapes.lifted.data.update.found).HasBinaryNat 0 := by + change (sourceReadyWork (tapes.lifted.data.idx 11)).HasBinaryNat 0 + rw [hsourceReadyOutside _ (tapes.lifted.data.ne (by decide)) + (tapes.liftedData_ne_buffer 11)] + have htarget : resetWork (tapes.lifted.data.idx 11) = + TM.resetBinaryBlank := by + simpa [instructionCleanupResetTape, + instructionCleanupResetParentSlot] using hresetTarget 2 + rw [htarget] + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + have hcountCopyRaw := TM.binaryCopyIntoTM_hoareTime_frame + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining tapes.lifted.data.update.found + (tapes.lifted.data.ne (by decide)) + (tapes.lifted.data.ne (by decide)) + (tapes.lifted.data.ne (by decide)) nextStore.length 0 inpβ‚€ + sourceReadyWork outβ‚€ hresultCount hremainingZero hfoundZero hinput + (fun i _ _ _ => hsourceReadyParked i) houtput + have hcountCopy : + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining + tapes.lifted.data.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = sourceReadyWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = finalWork ∧ out = outβ‚€) + (TM.binaryCopyTime nextStore.length 0) := by + simpa only [finalWork, countTape] using hcountCopyRaw + exact hcountCopy + +/-- Identify the preserved, cleared, and refreshed roles in the final work-tape frame. -/ +private theorem bufferedCleanup_finalFrame + (tapes : ControlInstructionTapes n) + (nextStore : Store) + (initialWork : Fin (n + 1) β†’ Tape) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + (βˆ€ (i : Fin (n + 1)) + (hiSource : i β‰  tapes.liftedSource) (hiBuffer : i β‰  tapes.buffer), + sourceReadyWork i = resetWork i) β†’ + (βˆ€ (role : Fin 18) + (hrole : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + resetWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) β†’ + (βˆ€ (slot : Fin 7), + resetWork (instructionCleanupResetTape tapes slot) = + TM.resetBinaryBlank) β†’ + (βˆ€ i, TM.Parked (sourceReadyWork i)) β†’ + (βˆ€ (role : Fin 18) + (hremaining : role β‰  9) (hsource : role β‰  0) + (hreset : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + finalWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) ∧ + (βˆ€ (slot : Fin 5), + finalWork (instructionCleanupTape tapes slot) = + TM.resetBinaryBlank) ∧ + (TM.resetBinaryBlank.HasBinaryNat 0) ∧ + (finalWork tapes.liftedSource = nextTape) ∧ + (finalWork tapes.buffer = (Tape.init []).move Dir3.right) ∧ + (βˆ€ i, TM.Parked (finalWork i)) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork countTape finalWork hsourceReadyOutside hresetDataOutside hresetTarget + hsourceReadyParked + have hfinalDataOutside (role : Fin 18) (hremaining : role β‰  9) + (hsource : role β‰  0) : + finalWork (tapes.lifted.data.idx role) = + resetWork (tapes.lifted.data.idx role) := by + rw [show finalWork (tapes.lifted.data.idx role) = + sourceReadyWork (tapes.lifted.data.idx role) from + Function.update_of_ne (tapes.lifted.data.ne hremaining) _ _] + exact hsourceReadyOutside _ (tapes.lifted.data.ne hsource) + (tapes.liftedData_ne_buffer role) + have hfinalPreservedData (role : Fin 18) + (hremaining : role β‰  9) (hsource : role β‰  0) + (hreset : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot) : + finalWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role) := by + rw [hfinalDataOutside role hremaining hsource, + hresetDataOutside role hreset] + have hfinalReset (slot : Fin 5) : + finalWork (instructionCleanupTape tapes slot) = + TM.resetBinaryBlank := by + fin_cases slot + Β· change finalWork (tapes.lifted.data.idx 7) = _ + rw [hfinalDataOutside 7 (by decide) (by decide)] + simpa [instructionCleanupTape, instructionCleanupResetTape, + instructionCleanupParentSlot, instructionCleanupResetParentSlot] + using hresetTarget 0 + Β· change finalWork (tapes.lifted.data.idx 10) = _ + rw [hfinalDataOutside 10 (by decide) (by decide)] + simpa [instructionCleanupTape, instructionCleanupResetTape, + instructionCleanupParentSlot, instructionCleanupResetParentSlot] + using hresetTarget 1 + Β· change finalWork (tapes.lifted.data.idx 11) = _ + rw [hfinalDataOutside 11 (by decide) (by decide)] + simpa [instructionCleanupTape, instructionCleanupResetTape, + instructionCleanupParentSlot, instructionCleanupResetParentSlot] + using hresetTarget 2 + Β· change finalWork (tapes.lifted.data.idx 13) = _ + rw [hfinalDataOutside 13 (by decide) (by decide)] + simpa [instructionCleanupTape, instructionCleanupResetTape, + instructionCleanupParentSlot, instructionCleanupResetParentSlot] + using hresetTarget 3 + Β· change finalWork (tapes.lifted.data.idx 14) = _ + rw [hfinalDataOutside 14 (by decide) (by decide)] + simpa [instructionCleanupTape, instructionCleanupResetTape, + instructionCleanupParentSlot, instructionCleanupResetParentSlot] + using hresetTarget 4 + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + have hfinalSource : finalWork tapes.liftedSource = nextTape := by + change finalWork (tapes.lifted.data.idx 0) = nextTape + rw [show finalWork (tapes.lifted.data.idx 0) = + sourceReadyWork (tapes.lifted.data.idx 0) from + Function.update_of_ne (tapes.lifted.data.ne (by decide)) _ _] + exact Function.update_self _ _ _ + have hfinalBuffer : + finalWork tapes.buffer = (Tape.init []).move Dir3.right := by + rw [show finalWork tapes.buffer = sourceReadyWork tapes.buffer from + Function.update_of_ne (tapes.liftedData_ne_buffer 9).symm _ _] + rw [show sourceReadyWork tapes.buffer = bufferResetWork tapes.buffer from + Function.update_of_ne tapes.liftedSource_ne_buffer.symm _ _] + exact Function.update_self _ _ _ + have hfinalParked : βˆ€ i, TM.Parked (finalWork i) := by + intro i + by_cases hi : i = tapes.lifted.data.update.remaining + Β· subst i + simp only [finalWork, Function.update_self, countTape] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat nextStore.length) + Β· simp only [finalWork, Function.update_of_ne hi] + exact hsourceReadyParked i + exact ⟨hfinalPreservedData, hfinalReset, hblankNat, hfinalSource, hfinalBuffer, hfinalParked⟩ + +/-- Restore the reusable entry-scanner contract from the final tape frame. -/ +private theorem bufferedCleanup_finalScanner + (tapes : ControlInstructionTapes n) + (oldStore : Store) + (nextStore : Store) + (nextPC : β„•) + (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + (finalWork tapes.liftedSource = nextTape) β†’ + (βˆ€ (role : Fin 18) + (hremaining : role β‰  9) (hsource : role β‰  0) + (hreset : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + finalWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) β†’ + (βˆ€ (slot : Fin 5), + finalWork (instructionCleanupTape tapes slot) = + TM.resetBinaryBlank) β†’ + (TM.resetBinaryBlank.HasBinaryNat 0) β†’ + (βˆ€ i, TM.Parked (finalWork i)) β†’ + (EntryScanReady tapes.lifted.data.update.entry + nextBits [] finalWork finalWork) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork countTape finalWork hfinalSource hfinalPreservedData hfinalReset hblankNat + hfinalParked + have hfinalScanner : EntryScanReady tapes.lifted.data.update.entry + nextBits [] finalWork finalWork := by + let entry := tapes.lifted.data.update.entry + refine + { source := by + change (finalWork tapes.liftedSource).HasBinarySuffix nextBits + rw [hfinalSource] + exact (Tape.init_move_right_hasBinaryString nextBits).hasBinarySuffix + address := by + change (finalWork (tapes.lifted.data.idx 1)).HasBinaryPrefix [] + rw [hfinalPreservedData 1 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.address + addressStart := by + change (finalWork (tapes.lifted.data.idx 1)).cells 0 = Ξ“.start + rw [hfinalPreservedData 1 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.addressStart + value := by + change (finalWork (tapes.lifted.data.idx 2)).HasBinaryPrefix [] + rw [hfinalPreservedData 2 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.value + valueStart := by + change (finalWork (tapes.lifted.data.idx 2)).cells 0 = Ξ“.start + rw [hfinalPreservedData 2 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.valueStart + addressCounter := by + change (finalWork (tapes.lifted.data.idx 3)).HasBinaryNat 0 + rw [hfinalPreservedData 3 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.addressCounter + addressWidth := by + change (finalWork (tapes.lifted.data.idx 4)).HasBinaryNat 0 + rw [hfinalPreservedData 4 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.addressWidth + valueCounter := by + change (finalWork (tapes.lifted.data.idx 5)).HasBinaryNat 0 + rw [hfinalPreservedData 5 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.valueCounter + valueWidth := by + change (finalWork (tapes.lifted.data.idx 6)).HasBinaryNat 0 + rw [hfinalPreservedData 6 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.valueWidth + query := by + change (finalWork (instructionCleanupTape tapes 0)).HasBinaryString [] + rw [hfinalReset 0] + exact hblankNat.2 + queryStart := by + change (finalWork (instructionCleanupTape tapes 0)).cells 0 = Ξ“.start + rw [hfinalReset 0] + exact hblankNat.1 + result := by + change (finalWork (tapes.lifted.data.idx 8)).HasBinaryPrefix [] + rw [hfinalPreservedData 8 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.result + resultStart := by + change (finalWork (tapes.lifted.data.idx 8)).cells 0 = Ξ“.start + rw [hfinalPreservedData 8 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.scanner.resultStart + parked := hfinalParked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + exact hfinalScanner + +/-- Preserve the program counter and transport the restored scanner to the lookup layout. -/ +private theorem bufferedCleanup_finalLookup + (tapes : ControlInstructionTapes n) + (nextStore : Store) + (initialWork : Fin (n + 1) β†’ Tape) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + (βˆ€ (i : Fin (n + 1)) + (hiSource : i β‰  tapes.liftedSource) (hiBuffer : i β‰  tapes.buffer), + sourceReadyWork i = resetWork i) β†’ + (EntryScanReady tapes.lifted.data.update.entry + nextBits [] finalWork finalWork) β†’ + (βˆ€ i, TM.Parked (finalWork i)) β†’ + (finalWork tapes.liftedPC = initialWork tapes.liftedPC) ∧ + (EntryScanReady + tapes.lifted.data.lhsLookup.scan.entry nextBits [] finalWork + finalWork) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork countTape finalWork hsourceReadyOutside hfinalScanner hfinalParked + have hfinalPC : finalWork tapes.liftedPC = initialWork tapes.liftedPC := by + rw [show finalWork tapes.liftedPC = sourceReadyWork tapes.liftedPC by + exact Function.update_of_ne (tapes.lifted.pc_ne 9) _ _] + rw [hsourceReadyOutside _ tapes.liftedPC_ne_source + tapes.liftedPC_ne_buffer] + exact TM.resetBinaryWorkManyResult_eq_of_not_mem initialWork targets _ (by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + exact tapes.lifted.pc_ne (instructionCleanupResetParentSlot slot) + hslot.symm) + have hfinalLookupScanner : EntryScanReady + tapes.lifted.data.lhsLookup.scan.entry nextBits [] finalWork + finalWork := by + refine + { source := by + change (finalWork (tapes.lifted.data.idx 0)).HasBinarySuffix nextBits + exact hfinalScanner.source + address := by + change (finalWork (tapes.lifted.data.idx 1)).HasBinaryPrefix [] + exact hfinalScanner.address + addressStart := by + change (finalWork (tapes.lifted.data.idx 1)).cells 0 = Ξ“.start + exact hfinalScanner.addressStart + value := by + change (finalWork (tapes.lifted.data.idx 2)).HasBinaryPrefix [] + exact hfinalScanner.value + valueStart := by + change (finalWork (tapes.lifted.data.idx 2)).cells 0 = Ξ“.start + exact hfinalScanner.valueStart + addressCounter := by + change (finalWork (tapes.lifted.data.idx 3)).HasBinaryNat 0 + exact hfinalScanner.addressCounter + addressWidth := by + change (finalWork (tapes.lifted.data.idx 4)).HasBinaryNat 0 + exact hfinalScanner.addressWidth + valueCounter := by + change (finalWork (tapes.lifted.data.idx 5)).HasBinaryNat 0 + exact hfinalScanner.valueCounter + valueWidth := by + change (finalWork (tapes.lifted.data.idx 6)).HasBinaryNat 0 + exact hfinalScanner.valueWidth + query := by + change (finalWork (tapes.lifted.data.idx 7)).HasBinaryString [] + exact hfinalScanner.query + queryStart := by + change (finalWork (tapes.lifted.data.idx 7)).cells 0 = Ξ“.start + exact hfinalScanner.queryStart + result := by + change (finalWork (tapes.lifted.data.idx 8)).HasBinaryPrefix [] + exact hfinalScanner.result + resultStart := by + change (finalWork (tapes.lifted.data.idx 8)).cells 0 = Ξ“.start + exact hfinalScanner.resultStart + parked := hfinalParked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + exact ⟨hfinalPC, hfinalLookupScanner⟩ + +/-- Assemble the complete clean instruction ABI from the restored scanner and final frame. -/ +private theorem bufferedCleanup_finalReady + (tapes : ControlInstructionTapes n) + (oldStore : Store) + (nextStore : Store) + (nextPC : β„•) + (cleanupValues : Fin 5 β†’ β„•) + (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + : + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + let rewoundWork := Function.update resetWork tapes.buffer nextTape + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + (EntryScanReady + tapes.lifted.data.lhsLookup.scan.entry nextBits [] finalWork + finalWork) β†’ + (finalWork tapes.liftedSource = nextTape) β†’ + (βˆ€ (role : Fin 18) + (hremaining : role β‰  9) (hsource : role β‰  0) + (hreset : βˆ€ slot : Fin 7, + role β‰  instructionCleanupResetParentSlot slot), + finalWork (tapes.lifted.data.idx role) = + initialWork (tapes.lifted.data.idx role)) β†’ + (βˆ€ (slot : Fin 5), + finalWork (instructionCleanupTape tapes slot) = + TM.resetBinaryBlank) β†’ + (TM.resetBinaryBlank.HasBinaryNat 0) β†’ + (finalWork tapes.liftedPC = initialWork tapes.liftedPC) β†’ + (finalWork tapes.buffer = (Tape.init []).move Dir3.right) β†’ + (InstructionExecutionReady tapes nextStore + nextPC finalWork) := by + intro nextBits targets resetWork nextTape rewoundWork prefixTape copiedWork bufferResetWork + sourceReadyWork countTape finalWork hfinalLookupScanner hfinalSource hfinalPreservedData + hfinalReset hblankNat hfinalPC hfinalBuffer + have hfinalReady : InstructionExecutionReady tapes nextStore + nextPC finalWork := by + refine + { canonical := hready.nextCanonical + control := + { lookup := + { scanner := hfinalLookupScanner + sourceStart := by + change (finalWork tapes.liftedSource).cells 0 = Ξ“.start + rw [hfinalSource] + simp [nextTape, Tape.init, Tape.move] + sourceHead := by + change (finalWork tapes.liftedSource).head = 1 + rw [hfinalSource] + simp [nextTape, Tape.move] + count := by + change (finalWork (tapes.lifted.data.idx 9)).HasBinaryNat _ + rw [show finalWork (tapes.lifted.data.idx 9) = countTape from + Function.update_self _ _ _] + exact Tape.init_move_right_hasBinaryNat nextStore.length + countSource := by + change (finalWork (tapes.lifted.data.idx 12)).HasBinaryNat _ + rw [hfinalPreservedData 12 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.resultCount + querySource := by + change (finalWork (tapes.lifted.data.idx 15)).HasBinaryNat 0 + rw [hfinalPreservedData 15 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.shift + destination := by + change (finalWork (instructionCleanupTape tapes 3)).HasBinaryNat 0 + rw [hfinalReset 3] + exact hblankNat + copyScratch := by + change (finalWork (instructionCleanupTape tapes 2)).HasBinaryNat 0 + rw [hfinalReset 2] + exact hblankNat } + pc := by + change (finalWork tapes.liftedPC).HasBinaryNat _ + rw [hfinalPC] + exact hready.result.pc } + sourceContent := by + rw [hfinalSource] + exact (Tape.init_move_right_hasBinaryString nextBits).hasBinaryContent + rhs := by + rw [show tapes.lifted.data.rhs = instructionCleanupTape tapes 4 by rfl, + hfinalReset 4] + exact hblankNat + replacement := by + rw [show tapes.lifted.data.update.replacement = + instructionCleanupTape tapes 1 by rfl, + hfinalReset 1] + exact hblankNat + tmp := by + change (finalWork (tapes.lifted.data.idx 16)).HasBinaryNat 0 + rw [hfinalPreservedData 16 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.tmp + dbl := by + change (finalWork (tapes.lifted.data.idx 17)).HasBinaryNat 0 + rw [hfinalPreservedData 17 (by decide) (by decide) + (by intro slot; fin_cases slot <;> decide)] + exact hready.result.dbl + buffer := hfinalBuffer } + exact hfinalReady + +/-- Any buffered representation endpoint is restored to the reusable clean ABI. -/ +theorem bufferedCleanupTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (oldStore nextStore : Store) + (nextPC : β„•) (cleanupValues : Fin 5 β†’ β„•) (remainingValue : β„•) + (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : BufferedCleanupReady tapes oldStore nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (instructionCleanupTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes nextStore nextPC work ∧ + out = outβ‚€) + (bufferedCleanupTime tapes oldStore nextStore cleanupValues + remainingValue sourceHeadBound) := by + let nextBits := nextStore.flatMap Entry.encode + let targets := instructionCleanupResetTargets tapes + let resetBits := bufferedCleanupResetBitsAt tapes cleanupValues + remainingValue oldStore + let resetHeads := + instructionCleanupResetHeadBoundAt tapes sourceHeadBound + let resetWork := TM.resetBinaryWorkManyResult initialWork targets + let nextTape := (Tape.init (nextBits.map Ξ“.ofBool)).move Dir3.right + obtain ⟨hreset, hresetDataOutside, hresetBuffer, hresetParked, hresetTarget⟩ := + bufferedCleanup_resetPhase + (tapes := tapes) + (oldStore := oldStore) + (nextStore := nextStore) + (nextPC := nextPC) + (cleanupValues := cleanupValues) + (remainingValue := remainingValue) + (sourceHeadBound := sourceHeadBound) + (initialWork := initialWork) + (inpβ‚€ := inpβ‚€) + (outβ‚€ := outβ‚€) + (hready := hready) + (hinput := hinput) + (houtput := houtput) + obtain ⟨hrewind, hrewoundSource, hrewoundParked⟩ := + bufferedCleanup_rewindBufferPhase + (tapes := tapes) + (oldStore := oldStore) + (nextStore := nextStore) + (nextPC := nextPC) + (cleanupValues := cleanupValues) + (remainingValue := remainingValue) + (sourceHeadBound := sourceHeadBound) + (initialWork := initialWork) + (inpβ‚€ := inpβ‚€) + (outβ‚€ := outβ‚€) + (hready := hready) + (hinput := hinput) + (houtput := houtput) + hresetBuffer hresetParked hresetTarget + let rewoundWork := Function.update resetWork tapes.buffer nextTape + obtain ⟨hcopy, hcopiedBuffer, hcopiedSource, hcopiedParked⟩ := + bufferedCleanup_copyPhase + (tapes := tapes) + (nextStore := nextStore) + (initialWork := initialWork) + (inpβ‚€ := inpβ‚€) + (outβ‚€ := outβ‚€) + (hinput := hinput) + (houtput := houtput) + hrewoundSource hrewoundParked + let prefixTape := instructionCleanupPrefixTape nextBits + let copiedWork := Function.update + (Function.update rewoundWork tapes.buffer prefixTape) + tapes.liftedSource prefixTape + obtain ⟨hresetBufferPhase, hrewindSource, hsourceReadyOutside, + hsourceReadyParked, hbufferResetParked⟩ := + bufferedCleanup_restoreSourcePhase + (tapes := tapes) + (nextStore := nextStore) + (initialWork := initialWork) + (inpβ‚€ := inpβ‚€) + (outβ‚€ := outβ‚€) + (hinput := hinput) + (houtput := houtput) + hcopiedBuffer hcopiedSource hcopiedParked hresetParked + let bufferResetWork := Function.update copiedWork tapes.buffer + ((Tape.init []).move Dir3.right) + let sourceReadyWork := Function.update bufferResetWork tapes.liftedSource + nextTape + have hcountCopy := + bufferedCleanup_copyCountPhase + (tapes := tapes) + (oldStore := oldStore) + (nextStore := nextStore) + (nextPC := nextPC) + (cleanupValues := cleanupValues) + (remainingValue := remainingValue) + (sourceHeadBound := sourceHeadBound) + (initialWork := initialWork) + (inpβ‚€ := inpβ‚€) + (outβ‚€ := outβ‚€) + (hready := hready) + (hinput := hinput) + (houtput := houtput) + hsourceReadyOutside hresetDataOutside hresetTarget hsourceReadyParked + let countTape := + (Tape.init (nextStore.length.bits.map Ξ“.ofBool)).move Dir3.right + let finalWork := Function.update sourceReadyWork + tapes.lifted.data.update.remaining countTape + obtain ⟨hfinalPreservedData, hfinalReset, hblankNat, hfinalSource, hfinalBuffer, hfinalParked⟩ := + bufferedCleanup_finalFrame + (tapes := tapes) + (nextStore := nextStore) + (initialWork := initialWork) + hsourceReadyOutside hresetDataOutside hresetTarget hsourceReadyParked + have hfinalScanner := + bufferedCleanup_finalScanner + (tapes := tapes) + (oldStore := oldStore) + (nextStore := nextStore) + (nextPC := nextPC) + (cleanupValues := cleanupValues) + (remainingValue := remainingValue) + (sourceHeadBound := sourceHeadBound) + (initialWork := initialWork) + (hready := hready) + hfinalSource hfinalPreservedData hfinalReset hblankNat hfinalParked + obtain ⟨hfinalPC, hfinalLookupScanner⟩ := + bufferedCleanup_finalLookup + (tapes := tapes) + (nextStore := nextStore) + (initialWork := initialWork) + hsourceReadyOutside hfinalScanner hfinalParked + have hfinalReady := + bufferedCleanup_finalReady + (tapes := tapes) + (oldStore := oldStore) + (nextStore := nextStore) + (nextPC := nextPC) + (cleanupValues := cleanupValues) + (remainingValue := remainingValue) + (sourceHeadBound := sourceHeadBound) + (initialWork := initialWork) + (hready := hready) + hfinalLookupScanner hfinalSource hfinalPreservedData hfinalReset + hblankNat hfinalPC hfinalBuffer + have hcountFinal : + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining + tapes.lifted.data.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = sourceReadyWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes nextStore nextPC work ∧ + out = outβ‚€) + (TM.binaryCopyTime nextStore.length 0) := + hcountCopy.strengthen_post (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + exact ⟨hinp, hfinalReady, hout⟩) + have hseam (workβ‚€ : Fin (n + 1) β†’ Tape) + (hworkβ‚€ : βˆ€ i, TM.Parked (workβ‚€ i)) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + TM.transitionInput inp = inpβ‚€ ∧ + (fun i => TM.transitionTape (work i)) = workβ‚€ ∧ + TM.transitionTape out = outβ‚€ := by + rintro inp work out ⟨hinp, hwork, hout⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have houtParked : TM.Parked out := by simpa [hout] using houtput + have hworkParked : βˆ€ i, TM.Parked (work i) := by + simpa [hwork] using hworkβ‚€ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked hinpParked + hworkParked houtParked + rw [hi, hw, ho] + exact ⟨hinp, hwork, hout⟩ + have htailβ‚€ := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining tapes.lifted.data.update.found) + hrewindSource (hseam sourceReadyWork hsourceReadyParked) hcountFinal + have htail₁ := TM.seqTM_hoareTime + (TM.resetBinaryWorkTM tapes.buffer) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining tapes.lifted.data.update.found)) + hresetBufferPhase (hseam bufferResetWork hbufferResetParked) htailβ‚€ + have htailβ‚‚ := TM.seqTM_hoareTime + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining tapes.lifted.data.update.found))) + hcopy (hseam copiedWork hcopiedParked) htail₁ + have htail₃ := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.buffer) + (TM.seqTM (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining tapes.lifted.data.update.found)))) + hrewind (hseam rewoundWork hrewoundParked) htailβ‚‚ + have hall := TM.seqTM_hoareTime + (TM.resetBinaryWorkManyTM targets) + (TM.seqTM (TM.rewindWorkTM tapes.buffer) + (TM.seqTM (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.binaryCopyIntoTM tapes.lifted.data.update.resultCount + tapes.lifted.data.update.remaining + tapes.lifted.data.update.found))))) + hreset (hseam resetWork hresetParked) htail₃ + simpa only [instructionCleanupTM, bufferedCleanupTime, + nextBits, targets, resetBits, resetHeads] using hall + +/-- The ordinary sparse instruction endpoint is an instance of generic +buffered cleanup. -/ +theorem instructionCleanupTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (instruction : Instr) + (pcValue : β„•) (store : Store) (sourceHeadBound : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : InstructionCleanupReady tapes instruction pcValue store + sourceHeadBound initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (instructionCleanupTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes + (instructionStore instruction pcValue store) + (instructionPC instruction pcValue store) work ∧ + out = outβ‚€) + (instructionCleanupTime tapes instruction pcValue store + sourceHeadBound) := by + let nextStore := instructionStore instruction pcValue store + let nextPC := instructionPC instruction pcValue store + let cleanupValues := instructionCleanupValue instruction store + let remainingValue := instructionRemainingValue instruction store + have hgenericReady : BufferedCleanupReady tapes store nextStore nextPC + cleanupValues remainingValue sourceHeadBound initialWork := + { nextCanonical := by + simpa [nextStore, instructionStore] using + Snapshot.stepInstr_canonical instruction + { pc := pcValue, store := store } hready.canonical + result := + { buffer := hready.result.buffer + pc := hready.result.pc + resultCount := hready.result.resultCount + sourceContent := hready.result.sourceContent + cleanup := hready.result.cleanup + remaining := hready.result.remaining + scanner := hready.result.scanner + shift := hready.result.shift + tmp := hready.result.tmp + dbl := hready.result.dbl + parked := hready.result.parked } + sourceStart := hready.sourceStart + bufferStart := hready.bufferStart + sourceHead := hready.sourceHead } + have hgeneric := bufferedCleanupTM_hoareTime_frame_internal tapes store + nextStore nextPC cleanupValues remainingValue sourceHeadBound initialWork + inpβ‚€ outβ‚€ hgenericReady hinput houtput + simpa only [nextStore, nextPC, cleanupValues, remainingValue, + instructionCleanupTime, bufferedCleanupTime, + instructionCleanupResetBitsAt, bufferedCleanupResetBitsAt, + instructionCleanupResetBits, bufferedCleanupResetBits] using! hgeneric + +/-- One selected instruction followed by cleanup realizes the next reusable +sparse-snapshot boundary. -/ +theorem programStepTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) + (hprogram : (programInstructionTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionResult tapes + (selectedInstruction program pcValue) pcValue store work ∧ + out = (Tape.init []).move Dir3.right) + (programInstructionTime tapes program pcValue store)) : + (programStepTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes + (instructionStore (selectedInstruction program pcValue) + pcValue store) + (instructionPC (selectedInstruction program pcValue) + pcValue store) work ∧ + out = (Tape.init []).move Dir3.right) + (programStepTime tapes program pcValue store) := by + let instruction := selectedInstruction program pcValue + let sourceBound := + programStepSourceHeadBound tapes program pcValue store + let blank := (Tape.init []).move Dir3.right + have hprogramCleanup : + (programInstructionTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ out = blank) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionCleanupReady tapes instruction pcValue store + sourceBound work ∧ + out = blank) + (programInstructionTime tapes program pcValue store) := by + intro inp work out hpre + obtain ⟨c, time, htime, hreach, hhalt, hinp, hresult, hout⟩ := + hprogram inp work out hpre + have hsourceStartβ‚€ : + (work tapes.liftedSource).cells 0 = Ξ“.start := by + simpa [hpre.2.1] using! hready.control.lookup.sourceStart + have hsourceStart := TM.work_cells_zero_eq_start_of_reachesIn + tapes.liftedSource hreach hsourceStartβ‚€ + have hbufferStartβ‚€ : + (work tapes.buffer).cells 0 = Ξ“.start := by + rw [hpre.2.1, hready.buffer] + simp [Tape.move, Tape.init] + have hbufferStart := TM.work_cells_zero_eq_start_of_reachesIn + tapes.buffer hreach hbufferStartβ‚€ + have hsourceHead := + (programInstructionTM tapes program).work_head_reachesIn_bound + hreach tapes.liftedSource + refine ⟨c, time, htime, hreach, hhalt, hinp, ?_, hout⟩ + refine + { canonical := hready.canonical + result := by simpa only [instruction] using hresult + sourceStart := hsourceStart + bufferStart := hbufferStart + sourceHead := ?_ } + have hsourceHeadβ‚€ : (work tapes.liftedSource).head = 1 := by + simpa [hpre.2.1] using! hready.control.lookup.sourceHead + rw [hsourceHeadβ‚€] at hsourceHead + simp only [sourceBound, programStepSourceHeadBound] + omega + have hcleanup : + (instructionCleanupTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionCleanupReady tapes instruction pcValue store + sourceBound work ∧ + out = blank) + (fun inp work out => + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes + (instructionStore instruction pcValue store) + (instructionPC instruction pcValue store) work ∧ + out = blank) + (instructionCleanupTime tapes instruction pcValue store + sourceBound) := by + intro inp work out hpre + have hcleanupWork := instructionCleanupTM_hoareTime_frame_internal + tapes instruction pcValue store sourceBound work inpβ‚€ blank + hpre.2.1 hinput blank_parked + exact hcleanupWork inp work out ⟨hpre.1, rfl, hpre.2.2⟩ + have hseq := TM.seqTM_hoareTime + (programInstructionTM tapes program) (instructionCleanupTM tapes) + hprogramCleanup + (by + rintro inp work out ⟨hinp, hcleanupReady, hout⟩ + have hinpParked : TM.Parked inp := by simpa [hinp] using hinput + have houtParked : TM.Parked out := by simpa [hout, blank] using blank_parked + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked hinpParked + hcleanupReady.result.parked houtParked + rw [hi, hw, ho] + exact ⟨hinp, hcleanupReady, hout⟩) + hcleanup + simpa only [programStepTM, programStepTime, instruction, sourceBound, + blank] using hseq + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Store.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Store.lean new file mode 100644 index 0000000000..03838bc2b2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Store.lean @@ -0,0 +1,559 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Direct + +/-! +# Indirect sparse-store instructions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + TM.hasBinaryPrefix_parked h + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem storeOperands_values + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) (initialWork operandsWork : Fin n β†’ Tape) + (hoperands : DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork) : + (operandsWork tapes.lhs).HasBinaryNat + (RegisterStore.read store addressRegister) ∧ + (operandsWork tapes.rhs).HasBinaryNat (RegisterStore.read store source) ∧ + (operandsWork tapes.update.found).HasBinaryNat 0 ∧ + βˆ€ i, TM.Parked (operandsWork i) := by + rcases hoperands with ⟨lhsWork, hlhs, hrhs⟩ + have hlhsEq : operandsWork tapes.lhs = lhsWork tapes.lhs := + hrhs.frame tapes.lhs + (fun slot => (tapes.rhsLookup_ne_lhs slot).symm) + refine ⟨?_, by simpa using! hrhs.destination, by simpa using! hrhs.copyScratch, + hrhs.parked⟩ + rw [hlhsEq] + simpa using! hlhs.destination + +private theorem storeUpdate_ready + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) (initialWork operandsWork : Fin n β†’ Tape) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hoperands : DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork) : + let queryWork := Function.update operandsWork tapes.update.entry.query + ((Tape.init ((RegisterStore.read store addressRegister).bits.map + Ξ“.ofBool)).move Dir3.right) + let updateWork := Function.update queryWork tapes.update.replacement + ((Tape.init ((RegisterStore.read store source).bits.map Ξ“.ofBool)).move + Dir3.right) + EntryScanReady tapes.update.entry (store.flatMap Entry.encode) + (RegisterStore.read store addressRegister).bits updateWork updateWork ∧ + (updateWork tapes.update.replacement).HasBinaryNat + (RegisterStore.read store source) ∧ + (updateWork tapes.update.remaining).HasBinaryNat store.length ∧ + (updateWork tapes.update.found).HasBinaryNat 0 ∧ + (updateWork tapes.update.resultCount).HasBinaryNat store.length ∧ + βˆ€ i, TM.Parked (updateWork i) := by + dsimp only + rcases hoperands with ⟨lhsWork, hlhs, hrhs⟩ + let queryTape := + (Tape.init ((RegisterStore.read store addressRegister).bits.map Ξ“.ofBool)).move + Dir3.right + let valueTape := + (Tape.init ((RegisterStore.read store source).bits.map Ξ“.ofBool)).move + Dir3.right + let queryWork := Function.update operandsWork tapes.update.entry.query queryTape + let updateWork := Function.update queryWork tapes.update.replacement valueTape + have hqueryNat := Tape.init_move_right_hasBinaryNat + (RegisterStore.read store addressRegister) + have hvalueNat := Tape.init_move_right_hasBinaryNat + (RegisterStore.read store source) + have hqueryReplacement : + tapes.update.entry.query β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hscanner : EntryScanReady tapes.update.entry + (store.flatMap Entry.encode) + (RegisterStore.read store addressRegister).bits updateWork updateWork := by + have hsourceQuery : + tapes.update.entry.source β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hsourceReplacement : + tapes.update.entry.source β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressQuery : + tapes.update.entry.address β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressReplacement : + tapes.update.entry.address β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueQuery : tapes.update.entry.value β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueReplacement : + tapes.update.entry.value β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressCounterQuery : + tapes.update.entry.addressCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressCounterReplacement : + tapes.update.entry.addressCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have haddressWidthQuery : + tapes.update.entry.addressWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have haddressWidthReplacement : + tapes.update.entry.addressWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueCounterQuery : + tapes.update.entry.valueCounter β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueCounterReplacement : + tapes.update.entry.valueCounter β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hvalueWidthQuery : + tapes.update.entry.valueWidth β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hvalueWidthReplacement : + tapes.update.entry.valueWidth β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultQuery : + tapes.update.entry.result β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultReplacement : + tapes.update.entry.result β‰  tapes.update.replacement := + tapes.update.ne (by decide) + refine + { source := by + simpa only [updateWork, queryWork, + Function.update_of_ne hsourceReplacement, + Function.update_of_ne hsourceQuery] using! hrhs.scanner.source + address := by + simpa only [updateWork, queryWork, + Function.update_of_ne haddressReplacement, + Function.update_of_ne haddressQuery] using! hrhs.scanner.address + addressStart := by + simpa only [updateWork, queryWork, + Function.update_of_ne haddressReplacement, + Function.update_of_ne haddressQuery] using! + hrhs.scanner.addressStart + value := by + simpa only [updateWork, queryWork, + Function.update_of_ne hvalueReplacement, + Function.update_of_ne hvalueQuery] using! hrhs.scanner.value + valueStart := by + simpa only [updateWork, queryWork, + Function.update_of_ne hvalueReplacement, + Function.update_of_ne hvalueQuery] using! hrhs.scanner.valueStart + addressCounter := by + simpa only [updateWork, queryWork, + Function.update_of_ne haddressCounterReplacement, + Function.update_of_ne haddressCounterQuery] using! + hrhs.scanner.addressCounter + addressWidth := by + simpa only [updateWork, queryWork, + Function.update_of_ne haddressWidthReplacement, + Function.update_of_ne haddressWidthQuery] using! + hrhs.scanner.addressWidth + valueCounter := by + simpa only [updateWork, queryWork, + Function.update_of_ne hvalueCounterReplacement, + Function.update_of_ne hvalueCounterQuery] using! + hrhs.scanner.valueCounter + valueWidth := by + simpa only [updateWork, queryWork, + Function.update_of_ne hvalueWidthReplacement, + Function.update_of_ne hvalueWidthQuery] using! + hrhs.scanner.valueWidth + query := by + simpa only [updateWork, + Function.update_of_ne hqueryReplacement, queryWork, + Function.update_self, queryTape] using! hqueryNat.2 + queryStart := by + simpa only [updateWork, + Function.update_of_ne hqueryReplacement, queryWork, + Function.update_self, queryTape] using! hqueryNat.1 + result := by + simpa only [updateWork, queryWork, + Function.update_of_ne hresultReplacement, + Function.update_of_ne hresultQuery] using! hrhs.scanner.result + resultStart := by + simpa only [updateWork, queryWork, + Function.update_of_ne hresultReplacement, + Function.update_of_ne hresultQuery] using! + hrhs.scanner.resultStart + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + intro i + by_cases hiReplacement : i = tapes.update.replacement + Β· subst i + simpa only [updateWork, Function.update_self, valueTape] using! + (show TM.Parked valueTape from + ⟨by rw [hvalueNat.2.1], + hvalueNat.2.hasBinaryContent.cells_ne_start⟩) + Β· have hiUpdate : updateWork i = queryWork i := + Function.update_of_ne hiReplacement _ queryWork + rw [hiUpdate] + by_cases hiQuery : i = tapes.update.entry.query + Β· subst i + simpa only [queryWork, Function.update_self, queryTape] using! + (show TM.Parked queryTape from + ⟨by rw [hqueryNat.2.1], + hqueryNat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [queryWork, Function.update_of_ne hiQuery] using! + hrhs.parked i + have hresultCount : + (operandsWork tapes.update.resultCount).HasBinaryNat store.length := by + rw [show operandsWork tapes.update.resultCount = + lhsWork tapes.update.resultCount by simpa using! hrhs.countSource] + rw [show lhsWork tapes.update.resultCount = + initialWork tapes.update.resultCount by simpa using! hlhs.countSource] + simpa using! hinitial.countSource + have hremainingReplacement : + tapes.update.remaining β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hremainingQuery : + tapes.update.remaining β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundReplacement : + tapes.update.found β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hfoundQuery : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hresultCountReplacement : + tapes.update.resultCount β‰  tapes.update.replacement := + tapes.update.ne (by decide) + have hresultCountQuery : + tapes.update.resultCount β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + refine ⟨hscanner, ?_, ?_, ?_, ?_, hscanner.parked⟩ + Β· simpa only [updateWork, Function.update_self, valueTape] using! hvalueNat + Β· simpa only [updateWork, + Function.update_of_ne hremainingReplacement, queryWork, + Function.update_of_ne hremainingQuery] using! hrhs.count + Β· simpa only [updateWork, + Function.update_of_ne hfoundReplacement, queryWork, + Function.update_of_ne hfoundQuery] using! + hrhs.copyScratch + Β· simpa only [updateWork, + Function.update_of_ne hresultCountReplacement, queryWork, + Function.update_of_ne hresultCountQuery] using! hresultCount + +/-- The sparse-store update stage preserves operand witnesses, source cells, and encoded output. -/ +private theorem sparseStore_updateStage + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + let address := RegisterStore.read store addressRegister + let value := RegisterStore.read store source + (entryUpdateTM tapes.update).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork queryWork, + DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + work = Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectStoreInstructionResult tapes store addressRegister source + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store address value).flatMap Entry.encode)) + (entryUpdateTime tapes.update store address value) := by + dsimp only + let address := RegisterStore.read store addressRegister + let value := RegisterStore.read store source + rintro inp work out ⟨hinp, ⟨operandsWork, queryWork, hops, + hqueryWork, hwork⟩, hout⟩ + subst queryWork + subst work + have hready := storeUpdate_ready tapes store addressRegister source + initialWork operandsWork hinitial hops + let updateWork := Function.update + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right) + have hrun := entryUpdateTM_hoareTime_frame tapes.update store address value + emittedBits updateWork inpβ‚€ outβ‚€ hcanonical hready.1 hready.2.1 + hready.2.2.1 hready.2.2.2.1 hready.2.2.2.2.1 hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + houtcome, hfinalOutput, hsourceCells⟩ := + hrun inp updateWork out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨operandsWork, + Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right), + updateWork, hops, rfl, rfl, by simpa [address, value] using! houtcome, + by + rcases hops with ⟨lhsWork, hlhs, hrhs⟩ + calc + (final.work tapes.update.entry.source).cells = + (updateWork tapes.update.entry.source).cells := hsourceCells + _ = (operandsWork tapes.update.entry.source).cells := by + rw [show updateWork tapes.update.entry.source = + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move + Dir3.right)) tapes.update.entry.source by + exact Function.update_of_ne (tapes.update.ne (by decide)) _ _] + rw [show (Function.update operandsWork + tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + tapes.update.entry.source = + operandsWork tapes.update.entry.source by + exact Function.update_of_ne (tapes.update.ne (by decide)) _ _] + _ = (lhsWork tapes.update.entry.source).cells := hrhs.sourceCells + _ = (initialWork tapes.update.entry.source).cells := + hlhs.sourceCells⟩, + by simpa [address, value] using! hfinalOutput⟩ + +/-- Exact semantic and time contract for one indirect sparse store. -/ +theorem indirectStoreInstructionTM_hoareTime_frame_internal + (tapes : BinaryInstructionTapes n) (store : Store) + (addressRegister source : β„•) (emittedBits : List Bool) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcanonical : Canonical store) + (hinitial : EntryLookupStaticReady tapes.lhsLookup store initialWork) + (hrhsβ‚€ : (initialWork tapes.rhs).HasBinaryNat 0) + (hreplacement : (initialWork tapes.update.replacement).HasBinaryNat 0) + (hinput : TM.Parked inpβ‚€) + (houtput : outβ‚€.HasBinaryPrefix emittedBits) : + (indirectStoreInstructionTM tapes addressRegister source).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + IndirectStoreInstructionResult tapes store addressRegister source + initialWork work ∧ + out.HasBinaryPrefix + (emittedBits ++ + (RegisterStore.write store + (RegisterStore.read store addressRegister) + (RegisterStore.read store source)).flatMap Entry.encode)) + (indirectStoreInstructionTime tapes store addressRegister source) := by + let address := RegisterStore.read store addressRegister + let value := RegisterStore.read store source + have houtputParked := hasBinaryPrefix_parked houtput + have hoperands := directBinaryOperands_hoareTime_internal tapes store + addressRegister source initialWork inpβ‚€ outβ‚€ hinitial hrhsβ‚€ hinput + houtputParked + have hquery : + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query + tapes.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DirectBinaryOperandsResult tapes store addressRegister source + initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork, + DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork ∧ + work = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryCopyTime address 0) := by + rintro inp work out ⟨hinp, hops, hout⟩ + have hvalues := storeOperands_values tapes store addressRegister source + initialWork work hops + have hrun := TM.binaryCopyIntoTM_hoareTime_frame tapes.lhs + tapes.update.entry.query tapes.update.found (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.update.ne (by decide)) address 0 inp work + out (by simpa [address] using! hvalues.1) + ⟨(by rcases hops with ⟨_, _, hrhs⟩; exact hrhs.scanner.queryStart), + (by rcases hops with ⟨_, _, hrhs⟩; + simpa using! hrhs.scanner.query)⟩ + hvalues.2.2.1 (by simpa [hinp] using! hinput) + (fun i _ _ _ => hvalues.2.2.2 i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨work, hops, by simpa [address] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hvalue : + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement + tapes.update.found).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork, + DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork ∧ + work = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆƒ operandsWork queryWork, + DirectBinaryOperandsResult tapes store addressRegister source + initialWork operandsWork ∧ + queryWork = Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + work = Function.update queryWork tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) ∧ + out = outβ‚€) + (TM.binaryCopyTime value 0) := by + rintro inp work out ⟨hinp, ⟨operandsWork, hops, hwork⟩, hout⟩ + subst work + have hvalues := storeOperands_values tapes store addressRegister source + initialWork operandsWork hops + let queryWork := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + have hrhsQuery : tapes.rhs β‰  tapes.update.entry.query := + tapes.ne (by decide) + have hreplacementQuery : + tapes.update.replacement β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hfoundQuery : tapes.update.found β‰  tapes.update.entry.query := + tapes.update.ne (by decide) + have hrun := TM.binaryCopyIntoTM_hoareTime_frame tapes.rhs + tapes.update.replacement tapes.update.found (tapes.ne (by decide)) + (tapes.ne (by decide)) (tapes.update.ne (by decide)) value 0 inp + queryWork out + (by simpa only [queryWork, + Function.update_of_ne hrhsQuery, value] using! hvalues.2.1) + (by + have hreplEq : operandsWork tapes.update.replacement = + initialWork tapes.update.replacement := by + rcases hops with ⟨lhsWork, hlhs, hrhs⟩ + rw [hrhs.frame tapes.update.replacement + (fun slot => (tapes.rhsLookup_ne_replacement slot).symm)] + exact hlhs.frame tapes.update.replacement + (fun slot => (tapes.lhsLookup_ne_replacement slot).symm) + simpa only [queryWork, + Function.update_of_ne hreplacementQuery, hreplEq] using! + hreplacement) + (by simpa only [queryWork, + Function.update_of_ne hfoundQuery] using! hvalues.2.2.1) + (by simpa [hinp] using! hinput) + (fun i _ _ _ => by + by_cases hi : i = tapes.update.entry.query + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat address + simpa only [queryWork, Function.update_self] using! + (show TM.Parked + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [queryWork, Function.update_of_ne hi] using! + hvalues.2.2.2 i) + (by simpa [hout] using! houtputParked) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp queryWork out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + ⟨operandsWork, queryWork, hops, rfl, + by simpa [value] using! hfinalWork⟩, + hfinalOutput.trans hout⟩ + have hupdate := sparseStore_updateStage tapes store addressRegister source emittedBits + initialWork inpβ‚€ outβ‚€ hcanonical hinitial hinput houtput + have hvalueUpdate := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement tapes.update.found) + (entryUpdateTM tapes.update) hvalue + (by + rintro inp work out ⟨hinp, ⟨operandsWork, queryWork, hops, + hqueryWork, hwork⟩, hout⟩ + subst queryWork + subst work + have hready := storeUpdate_ready tapes store addressRegister source + initialWork operandsWork hinitial hops + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) + (work := Function.update + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + tapes.update.replacement + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hready.2.2.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨operandsWork, _, hops, rfl, rfl⟩, hout⟩) + hupdate + have hqueryRest := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement tapes.update.found) + (entryUpdateTM tapes.update)) hquery + (by + rintro inp work out ⟨hinp, ⟨operandsWork, hops, hwork⟩, hout⟩ + subst work + have hvalues := storeOperands_values tapes store addressRegister source + initialWork operandsWork hops + have hparked : βˆ€ i, TM.Parked + (Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) i) := by + intro i + by_cases hi : i = tapes.update.entry.query + Β· subst i + have hnat := Tape.init_move_right_hasBinaryNat address + simpa only [Function.update_self] using! + (show TM.Parked + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) from + ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [Function.update_of_ne hi] using! hvalues.2.2.2 i + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) + (work := Function.update operandsWork tapes.update.entry.query + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + (out := out) (by simpa [hinp] using! hinput) hparked + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, ⟨operandsWork, hops, rfl⟩, hout⟩) + hvalueUpdate + have hall := TM.seqTM_hoareTime + (TM.seqTM (entryLookupStaticTM tapes.lhsLookup addressRegister) + (entryLookupStaticTM tapes.rhsLookup source)) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.lhs tapes.update.entry.query tapes.update.found) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.rhs tapes.update.replacement tapes.update.found) + (entryUpdateTM tapes.update))) hoperands + (by + rintro inp work out ⟨hinp, hops, hout⟩ + have hvalues := storeOperands_values tapes store addressRegister source + initialWork work hops + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hvalues.2.2.2 + (by simpa [hout] using! houtputParked) + rw [hi, hw, ho] + exact ⟨hinp, hops, hout⟩) + hqueryRest + simpa [indirectStoreInstructionTM, indirectStoreInstructionTime, address, + value] using! hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Tapes.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Tapes.lean new file mode 100644 index 0000000000..874f1064f1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Instruction/Tapes.lean @@ -0,0 +1,399 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryUpdate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs + +/-! +# Tape layouts for sparse-register instructions + +Arithmetic and control instruction tape assignments and their injectivity and +non-aliasing facts, shared by the concrete instruction machines. +-/ + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The three arithmetic operations shared by RAM register instructions. -/ +inductive BinaryInstrOp where + | add + | sub + | mul + deriving DecidableEq + +/-- Eighteen pairwise-distinct tapes used by arithmetic followed by sparse +update. Slots `0..12` are the update controller, slots `13` and `14` are the +operands, and slots `15..17` are multiplication scratch. -/ +structure BinaryInstructionTapes (n : β„•) where + /-- Complete injective physical assignment. -/ + idx : Fin 18 β†’ Fin n + /-- No two semantic roles alias. -/ + injective : Function.Injective idx + +namespace BinaryInstructionTapes + +/-- The thirteen-tape sparse-update view. -/ +def update {n : β„•} (tapes : BinaryInstructionTapes n) : EntryUpdateTapes n where + idx := fun i => tapes.idx ⟨i, by omega⟩ + injective := by + intro i j h + apply Fin.ext + simpa using congrArg Fin.val (tapes.injective h) + +/-- First looked-up arithmetic operand. -/ +def lhs {n : β„•} (tapes : BinaryInstructionTapes n) : Fin n := tapes.idx 13 + +/-- Second looked-up arithmetic operand. -/ +def rhs {n : β„•} (tapes : BinaryInstructionTapes n) : Fin n := tapes.idx 14 + +/-- Multiplication's shifted-multiplicand scratch tape. -/ +def shift {n : β„•} (tapes : BinaryInstructionTapes n) : Fin n := tapes.idx 15 + +/-- Multiplication's first alternating scratch tape. -/ +def tmp {n : β„•} (tapes : BinaryInstructionTapes n) : Fin n := tapes.idx 16 + +/-- Multiplication's second alternating scratch tape. -/ +def dbl {n : β„•} (tapes : BinaryInstructionTapes n) : Fin n := tapes.idx 17 + +/-- Parent-slot inequality gives physical tape inequality. -/ +theorem ne {n : β„•} (tapes : BinaryInstructionTapes n) + {i j : Fin 18} (hne : i β‰  j) : tapes.idx i β‰  tapes.idx j := + fun heq => hne (tapes.injective heq) + +theorem update_ne_lhs {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 13) : tapes.update.idx slot β‰  tapes.lhs := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = 13 at hval + omega + +theorem update_ne_rhs {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 13) : tapes.update.idx slot β‰  tapes.rhs := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = 14 at hval + omega + +theorem update_ne_shift {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 13) : tapes.update.idx slot β‰  tapes.shift := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = 15 at hval + omega + +theorem update_ne_tmp {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 13) : tapes.update.idx slot β‰  tapes.tmp := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = 16 at hval + omega + +theorem update_ne_dbl {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 13) : tapes.update.idx slot β‰  tapes.dbl := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = 17 at hval + omega + +/-- Parent slots for a reusable lookup whose destination is `lhs`. -/ +def lhsLookupSlot (i : Fin 14) : Fin 18 := + match i.val with + | 0 => 0 + | 1 => 1 + | 2 => 2 + | 3 => 3 + | 4 => 4 + | 5 => 5 + | 6 => 6 + | 7 => 7 + | 8 => 8 + | 9 => 9 + | 10 => 12 + | 11 => 15 + | 12 => 13 + | _ => 11 + +private theorem lhsLookupSlot_injective : Function.Injective lhsLookupSlot := by + intro i j h + fin_cases i <;> fin_cases j <;> simp [lhsLookupSlot] at h ⊒ + +/-- Reusable sparse lookup view targeting the first operand. -/ +def lhsLookup {n : β„•} (tapes : BinaryInstructionTapes n) : + EntryLookupRestoreTapes n where + idx := fun i => tapes.idx (lhsLookupSlot i) + injective := fun _ _ h => by + exact lhsLookupSlot_injective (tapes.injective h) + +/-- Parent slots for a reusable lookup whose destination is `rhs`. -/ +def rhsLookupSlot (i : Fin 14) : Fin 18 := + match i.val with + | 0 => 0 + | 1 => 1 + | 2 => 2 + | 3 => 3 + | 4 => 4 + | 5 => 5 + | 6 => 6 + | 7 => 7 + | 8 => 8 + | 9 => 9 + | 10 => 12 + | 11 => 15 + | 12 => 14 + | _ => 11 + +private theorem rhsLookupSlot_injective : Function.Injective rhsLookupSlot := by + intro i j h + fin_cases i <;> fin_cases j <;> simp [rhsLookupSlot] at h ⊒ + +/-- Reusable sparse lookup view targeting the second operand. -/ +def rhsLookup {n : β„•} (tapes : BinaryInstructionTapes n) : + EntryLookupRestoreTapes n where + idx := fun i => tapes.idx (rhsLookupSlot i) + injective := fun _ _ h => by + exact rhsLookupSlot_injective (tapes.injective h) + +@[simp] theorem lhsLookup_count {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.lhsLookup.idx 9 = tapes.update.remaining := rfl + +@[simp] theorem rhsLookup_count {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.rhsLookup.idx 9 = tapes.update.remaining := rfl + +@[simp] theorem lhsLookup_countSource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.lhsLookup.countSource = tapes.update.resultCount := rfl + +@[simp] theorem rhsLookup_countSource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.rhsLookup.countSource = tapes.update.resultCount := rfl + +@[simp] theorem lhsLookup_querySource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.lhsLookup.querySource = tapes.shift := rfl + +@[simp] theorem rhsLookup_querySource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.rhsLookup.querySource = tapes.shift := rfl + +@[simp] theorem lhsLookup_destination {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.lhsLookup.destination = tapes.lhs := rfl + +@[simp] theorem rhsLookup_destination {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.rhsLookup.destination = tapes.rhs := rfl + +@[simp] theorem lhsLookup_copyScratch {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.lhsLookup.copyScratch = tapes.update.found := rfl + +@[simp] theorem rhsLookup_copyScratch {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.rhsLookup.copyScratch = tapes.update.found := rfl + +theorem lhsLookup_ne_rhs {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.lhsLookup.idx slot β‰  tapes.rhs := by + apply tapes.ne + fin_cases slot <;> decide + +theorem rhsLookup_ne_lhs {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.rhsLookup.idx slot β‰  tapes.lhs := by + apply tapes.ne + fin_cases slot <;> decide + +theorem lhsLookup_ne_tmp {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.lhsLookup.idx slot β‰  tapes.tmp := by + apply tapes.ne + fin_cases slot <;> decide + +theorem rhsLookup_ne_tmp {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.rhsLookup.idx slot β‰  tapes.tmp := by + apply tapes.ne + fin_cases slot <;> decide + +theorem lhsLookup_ne_dbl {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.lhsLookup.idx slot β‰  tapes.dbl := by + apply tapes.ne + fin_cases slot <;> decide + +theorem rhsLookup_ne_dbl {n : β„•} (tapes : BinaryInstructionTapes n) + (slot : Fin 14) : tapes.rhsLookup.idx slot β‰  tapes.dbl := by + apply tapes.ne + fin_cases slot <;> decide + +theorem lhsLookup_ne_replacement {n : β„•} + (tapes : BinaryInstructionTapes n) (slot : Fin 14) : + tapes.lhsLookup.idx slot β‰  tapes.update.replacement := by + apply tapes.ne + fin_cases slot <;> decide + +theorem rhsLookup_ne_replacement {n : β„•} + (tapes : BinaryInstructionTapes n) (slot : Fin 14) : + tapes.rhsLookup.idx slot β‰  tapes.update.replacement := by + apply tapes.ne + fin_cases slot <;> decide + +/-- Parent slots for a loaded indirect read. The first operand supplies the +runtime address and the update replacement tape receives the loaded value. -/ +def indirectLoadLookupSlot (i : Fin 14) : Fin 18 := + match i.val with + | 0 => 0 + | 1 => 1 + | 2 => 2 + | 3 => 3 + | 4 => 4 + | 5 => 5 + | 6 => 6 + | 7 => 7 + | 8 => 8 + | 9 => 9 + | 10 => 12 + | 11 => 13 + | 12 => 10 + | _ => 11 + +private theorem indirectLoadLookupSlot_injective : + Function.Injective indirectLoadLookupSlot := by + intro i j h + fin_cases i <;> fin_cases j <;> simp [indirectLoadLookupSlot] at h ⊒ + +/-- Reusable loaded lookup view for indirect `load`. -/ +def indirectLoadLookup {n : β„•} (tapes : BinaryInstructionTapes n) : + EntryLookupRestoreTapes n where + idx := fun i => tapes.idx (indirectLoadLookupSlot i) + injective := fun _ _ h => by + exact indirectLoadLookupSlot_injective (tapes.injective h) + +@[simp] theorem indirectLoadLookup_count {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.indirectLoadLookup.idx 9 = tapes.update.remaining := rfl + +@[simp] theorem indirectLoadLookup_countSource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.indirectLoadLookup.countSource = tapes.update.resultCount := rfl + +@[simp] theorem indirectLoadLookup_querySource {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.indirectLoadLookup.querySource = tapes.lhs := rfl + +@[simp] theorem indirectLoadLookup_destination {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.indirectLoadLookup.destination = tapes.update.replacement := rfl + +@[simp] theorem indirectLoadLookup_copyScratch {n : β„•} + (tapes : BinaryInstructionTapes n) : + tapes.indirectLoadLookup.copyScratch = tapes.update.found := rfl + +/-- Multiplication-role parent slots. The accumulator deliberately aliases the +update replacement slot `10`. -/ +def mulSlot (i : Fin 6) : Fin 18 := + match i.val with + | 0 => 13 + | 1 => 14 + | 2 => 10 + | 3 => 15 + | 4 => 16 + | _ => 17 + +private theorem mulSlot_injective : Function.Injective mulSlot := by + intro i j hij + fin_cases i <;> fin_cases j <;> simp [mulSlot] at hij ⊒ + +/-- Six-tape multiplication view, with its accumulator on update replacement. -/ +def mul {n : β„•} (tapes : BinaryInstructionTapes n) : TM.BinaryShiftMulABI n where + tape := + ⟨fun i => tapes.idx (mulSlot i), fun _ _ h => + by exact mulSlot_injective (tapes.injective h)⟩ + +@[simp] theorem mul_lhs {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.lhs = tapes.lhs := rfl + +@[simp] theorem mul_rhs {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.rhs = tapes.rhs := rfl + +@[simp] theorem mul_acc {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.acc = tapes.update.replacement := rfl + +@[simp] theorem mul_shift {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.shift = tapes.shift := rfl + +@[simp] theorem mul_tmp {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.tmp = tapes.tmp := rfl + +@[simp] theorem mul_dbl {n : β„•} (tapes : BinaryInstructionTapes n) : + tapes.mul.dbl = tapes.dbl := rfl + +/-- The addition/subtraction operands and result are pairwise distinct. -/ +theorem arithmeticDistinct {n : β„•} (tapes : BinaryInstructionTapes n) : + TM.BinaryRippleAddDistinct tapes.lhs tapes.rhs + tapes.update.replacement := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), + tapes.ne (by decide)⟩ + +/-- The same physical inequalities as a subtraction certificate. -/ +theorem subtractionDistinct {n : β„•} (tapes : BinaryInstructionTapes n) : + TM.BinaryRippleSubDistinct tapes.lhs tapes.rhs + tapes.update.replacement := by + exact ⟨tapes.ne (by decide), tapes.ne (by decide), + tapes.ne (by decide)⟩ + +end BinaryInstructionTapes + +/-- The arithmetic/store ABI together with one disjoint canonical program- +counter tape. Nineteen work tapes suffice for every RAM instruction. -/ +structure ControlInstructionTapes (n : β„•) where + /-- The complete data-instruction assignment. -/ + data : BinaryInstructionTapes n + /-- Canonical binary program counter. -/ + pc : Fin n + /-- The program counter aliases no data-instruction role. -/ + pc_ne : βˆ€ slot, pc β‰  data.idx slot + +namespace ControlInstructionTapes + +/-- Every data-instruction role is distinct from the program counter. -/ +theorem data_ne_pc {n : β„•} (tapes : ControlInstructionTapes n) + (slot : Fin 18) : tapes.data.idx slot β‰  tapes.pc := + (tapes.pc_ne slot).symm + +/-- The first loaded operand is distinct from the program counter. -/ +theorem lhs_ne_pc {n : β„•} (tapes : ControlInstructionTapes n) : + tapes.data.lhs β‰  tapes.pc := tapes.data_ne_pc 13 + +/-- The program counter is distinct from the first loaded operand. -/ +theorem pc_ne_lhs {n : β„•} (tapes : ControlInstructionTapes n) : + tapes.pc β‰  tapes.data.lhs := tapes.pc_ne 13 + +/-- No tape owned by the first lookup aliases the program counter. -/ +theorem lookup_ne_pc {n : β„•} (tapes : ControlInstructionTapes n) + (slot : Fin 14) : tapes.data.lhsLookup.idx slot β‰  tapes.pc := by + exact tapes.data_ne_pc (BinaryInstructionTapes.lhsLookupSlot slot) + +end ControlInstructionTapes + + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup.lean new file mode 100644 index 0000000000..bc7de32abb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.DenseInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Defs.lean new file mode 100644 index 0000000000..5384458913 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Defs.lean @@ -0,0 +1,426 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import Mathlib.Tactic.FinCases + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.ResetLayout + +/-! +# Reusable sparse-register operand lookup -- definitions + +One RAM instruction may need several direct or indirect register reads. This +module gives lookup a reusable phase boundary: it loads a query from a +canonical source, scans the encoded store, copies out the decoded value, resets +all scanner scratch, rewinds the source, and restores the runtime entry count. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Uniform scanner-head bound from a canonical cell-one start. -/ +def entryLookupRestoreHeadBound {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) : β„• := + 1 + entryLookupTime tapes.scan address store + +/-- Reset budget obtained from the nine fixed owned targets and the common +head/width envelopes. -/ +def entryLookupResetTime {n : β„•} (tapes : EntryLookupRestoreTapes n) + (store : Store) (address : β„•) : β„• := + 9 * (entryLookupRestoreHeadBound tapes store address + + 2 * entryLookupResetWidth store address + 9) + 1 + +/-- Restore scanner scratch, source cursor, and runtime count after a completed +lookup whose value has already been copied out. -/ +def entryLookupRestoreTailTM {n : β„•} + (tapes : EntryLookupRestoreTapes n) : TM n := + TM.seqTM (TM.resetBinaryWorkManyTM (entryLookupResetTargets tapes)) + (TM.seqTM (TM.rewindWorkTM tapes.scan.entry.source) + (TM.binaryCopyIntoTM tapes.countSource tapes.scan.count + tapes.copyScratch)) + +/-- Copy out a lookup result, then restore the complete reusable scanner ABI. -/ +def entryLookupCopyRestoreTM {n : β„•} + (tapes : EntryLookupRestoreTapes n) : TM n := + TM.seqTM (entryLookupTM tapes.scan) + (TM.seqTM (TM.rewindWorkTM tapes.scan.entry.value) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch) + (entryLookupRestoreTailTM tapes))) + +/-- Load the supplied query, perform one sparse lookup, copy out its value, and +return to the same reusable blank-query scanner boundary. -/ +def entryLookupLoadedTM {n : β„•} (tapes : EntryLookupRestoreTapes n) : TM n := + TM.seqTM + (TM.binaryCopyIntoTM tapes.querySource tapes.scan.entry.query + tapes.copyScratch) + (entryLookupCopyRestoreTM tapes) + +/-- Time bound for scanner reset, source rewind, and count restoration. -/ +def entryLookupRestoreTailTime {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) : β„• := + entryLookupResetTime tapes store address + 1 + + (entryLookupRestoreHeadBound tapes store address + 2 + 1 + + TM.binaryCopyTime store.length 0) + +/-- Time bound after the query has been prepared. -/ +def entryLookupCopyRestoreTime {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) : β„• := + entryLookupTime tapes.scan address store + 1 + + (entryLookupRestoreHeadBound tapes store address + 2 + 1 + + (TM.binaryCopyTime (RegisterStore.read store address) 0 + 1 + + entryLookupRestoreTailTime tapes store address)) + +/-- Complete reusable loaded-lookup time bound. -/ +def entryLookupLoadedTime {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) : β„• := + TM.binaryCopyTime address 0 + 1 + + entryLookupCopyRestoreTime tapes store address + +/-- Read a positive-tag sparse overlay and either decode the tag or fall back +to the immutable public-input bank on a sparse miss. -/ +def denseOverlayLookupTM {n : β„•} (tapes : EntryLookupRestoreTapes n) : TM n := + TM.seqTM (entryLookupLoadedTM tapes) + (TM.branchWorkBlankTM tapes.destination + (denseInputLookupTM tapes.querySource tapes.scan.entry.address + tapes.destination tapes.copyScratch) + (TM.binaryPredTM tapes.destination)) + +/-- Complete reusable dense-overlay lookup budget. -/ +def denseOverlayLookupTime {n : β„•} (tapes : EntryLookupRestoreTapes n) + (inputLength : β„•) (overlay : Store) (address : β„•) : β„• := + entryLookupLoadedTime tapes overlay address + 1 + + TM.branchWorkBlankTime (denseInputLookupTime inputLength address) + (TM.binaryPredTime (RegisterStore.read overlay address - 1)) + +/-- Load one fixed address from canonical zero, read through the dense input +and sparse overlay, then clear the fixed-address source back to zero. -/ +def denseOverlayLookupStaticTM {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : TM n := + TM.seqTM (TM.binaryAddConstTM tapes.querySource address) + (TM.seqTM (denseOverlayLookupTM tapes) + (TM.resetBinaryWorkTM tapes.querySource)) + +/-- Complete fixed-address dense-overlay lookup budget. -/ +def denseOverlayLookupStaticTime {n : β„•} + (tapes : EntryLookupRestoreTapes n) (inputLength : β„•) + (overlay : Store) (address : β„•) : β„• := + TM.binaryAddConstTime address 0 + 1 + + (denseOverlayLookupTime tapes inputLength overlay address + 1 + + TM.resetBinaryWorkTime 1 address.bits.length) + +/-- Load one fixed address from canonical zero, run a reusable lookup, then +clear the fixed-address source back to zero. -/ +def entryLookupStaticTM {n : β„•} (tapes : EntryLookupRestoreTapes n) + (address : β„•) : TM n := + TM.seqTM (TM.binaryAddConstTM tapes.querySource address) + (TM.seqTM (entryLookupLoadedTM tapes) + (TM.resetBinaryWorkTM tapes.querySource)) + +/-- Complete fixed-address lookup budget. -/ +def entryLookupStaticTime {n : β„•} (tapes : EntryLookupRestoreTapes n) + (store : Store) (address : β„•) : β„• := + TM.binaryAddConstTime address 0 + 1 + + (entryLookupLoadedTime tapes store address + 1 + + TM.resetBinaryWorkTime 1 address.bits.length) + +/-- Canonical precondition for one reusable loaded lookup. -/ +structure EntryLookupRestoreReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (work : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) [] + work work + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (work tapes.scan.entry.source).head = 1 + count : (work tapes.scan.count).HasBinaryNat store.length + countSource : (work tapes.countSource).HasBinaryNat store.length + querySource : (work tapes.querySource).HasBinaryNat address + destination : (work tapes.destination).HasBinaryNat 0 + copyScratch : (work tapes.copyScratch).HasBinaryNat 0 + +/-- Canonical precondition for a fixed-address lookup whose query source starts +at zero and is restored to zero. -/ +structure EntryLookupStaticReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) + (work : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) [] + work work + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (work tapes.scan.entry.source).head = 1 + count : (work tapes.scan.count).HasBinaryNat store.length + countSource : (work tapes.countSource).HasBinaryNat store.length + querySource : (work tapes.querySource).HasBinaryNat 0 + destination : (work tapes.destination).HasBinaryNat 0 + copyScratch : (work tapes.copyScratch).HasBinaryNat 0 + +/-- Boundary after the external query has been copied into scanner storage. -/ +structure EntryLookupPrepared {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) + address.bits work work + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (work tapes.scan.entry.source).head = 1 + count : (work tapes.scan.count).HasBinaryNat store.length + countSource : work tapes.countSource = initialWork tapes.countSource + countSourceNat : (work tapes.countSource).HasBinaryNat store.length + querySource : work tapes.querySource = initialWork tapes.querySource + querySourceNat : (work tapes.querySource).HasBinaryNat address + destination : (work tapes.destination).HasBinaryNat 0 + copyScratch : (work tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + frame : βˆ€ i, i β‰  tapes.scan.entry.query β†’ work i = initialWork i + +/-- Uniform cleanup certificate extracted from either scanner outcome. -/ +def EntryLookupResetReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (work : Fin n β†’ Tape) : Prop := + βˆƒ bits : Fin n β†’ List Bool, + (βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (work i).HasBinaryContent (bits i)) ∧ + (βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (work i).cells 0 = Ξ“.start) ∧ + (βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (bits i).length ≀ entryLookupResetWidth store address) ∧ + βˆ€ i, TM.Parked (work i) + +/-- Boundary after the bounded scanner has produced a semantic lookup result. +It retains the exact cleanup certificate, the read-only source image, a +uniform cursor bound, and the complete external frame needed by restoration. -/ +structure EntryLookupScanned {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork work : Fin n β†’ Tape) : Prop where + result : EntryLookupResult tapes.scan store address preparedWork work + resetReady : EntryLookupResetReady tapes store address work + sourceCells : (work tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHeadBound : (work tapes.scan.entry.source).head ≀ + entryLookupRestoreHeadBound tapes store address + resetHeadBound : βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (work i).head ≀ entryLookupRestoreHeadBound tapes store address + countSource : work tapes.countSource = initialWork tapes.countSource + querySource : work tapes.querySource = initialWork tapes.querySource + destination : work tapes.destination = initialWork tapes.destination + copyScratch : work tapes.copyScratch = initialWork tapes.copyScratch + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + work i = initialWork i + +/-- Existentially packages the concrete prepared work family between query +copying and scanning, so subsequent phases can use a semantic Hoare boundary. -/ +def EntryLookupScannedReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop := + βˆƒ preparedWork, + EntryLookupPrepared tapes store address initialWork preparedWork ∧ + EntryLookupScanned tapes store address initialWork preparedWork work + +/-- Stable semantic state carried through value rewind, value copy, scratch +reset, source rewind, and count restoration. -/ +structure EntryLookupRestoreInvariant {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + valueContent : (work tapes.scan.entry.value).HasBinaryContent + (RegisterStore.read store address).bits + valueStart : (work tapes.scan.entry.value).cells 0 = Ξ“.start + resetReady : EntryLookupResetReady tapes store address work + sourceCells : (work tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHeadBound : (work tapes.scan.entry.source).head ≀ + entryLookupRestoreHeadBound tapes store address + resetHeadBound : βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (work i).head ≀ entryLookupRestoreHeadBound tapes store address + countSource : work tapes.countSource = initialWork tapes.countSource + countSourceNat : (work tapes.countSource).HasBinaryNat store.length + querySource : work tapes.querySource = initialWork tapes.querySource + querySourceNat : (work tapes.querySource).HasBinaryNat address + copyScratch : work tapes.copyScratch = initialWork tapes.copyScratch + copyScratchNat : (work tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + work i = initialWork i + +/-- The decoded value has been rewound to the canonical read boundary. -/ +structure EntryLookupValueReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + restore : EntryLookupRestoreInvariant tapes store address initialWork work + value : (work tapes.scan.entry.value).HasBinaryNat + (RegisterStore.read store address) + destination : (work tapes.destination).HasBinaryNat 0 + +/-- The decoded value has been copied to the instruction operand tape while +all scanner restoration data remains available. -/ +structure EntryLookupCopied {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + restore : EntryLookupRestoreInvariant tapes store address initialWork work + value : (work tapes.scan.entry.value).HasBinaryNat + (RegisterStore.read store address) + destination : (work tapes.destination).HasBinaryNat + (RegisterStore.read store address) + +/-- Exact boundary after all nine scanner-owned binary tapes have been reset. -/ +structure EntryLookupResetDone {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork copiedWork work : Fin n β†’ Tape) : Prop where + copied : EntryLookupCopied tapes store address initialWork copiedWork + work_eq : work = TM.resetBinaryWorkManyResult copiedWork + (entryLookupResetTargets tapes) + +/-- Semantic form of the reset endpoint, stable while the encoded source is +rewound. -/ +structure EntryLookupScratchReset {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + sourceCells : (work tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHeadBound : (work tapes.scan.entry.source).head ≀ + entryLookupRestoreHeadBound tapes store address + targetsBlank : βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + work i = TM.resetBinaryBlank + countSource : work tapes.countSource = initialWork tapes.countSource + countSourceNat : (work tapes.countSource).HasBinaryNat store.length + querySource : work tapes.querySource = initialWork tapes.querySource + querySourceNat : (work tapes.querySource).HasBinaryNat address + destination : (work tapes.destination).HasBinaryNat + (RegisterStore.read store address) + copyScratch : work tapes.copyScratch = initialWork tapes.copyScratch + copyScratchNat : (work tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + work i = initialWork i + +/-- Boundary after scanner reset and encoded-source rewind, immediately before +the runtime entry count is copied back. -/ +structure EntryLookupSourceReady {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) [] + work work + sourceCells : (work tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (work tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (work tapes.scan.entry.source).head = 1 + countZero : (work tapes.scan.count).HasBinaryNat 0 + countSource : work tapes.countSource = initialWork tapes.countSource + countSourceNat : (work tapes.countSource).HasBinaryNat store.length + querySource : work tapes.querySource = initialWork tapes.querySource + destination : (work tapes.destination).HasBinaryNat + (RegisterStore.read store address) + copyScratch : work tapes.copyScratch = initialWork tapes.copyScratch + copyScratchNat : (work tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (work i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + work i = initialWork i + +/-- Reusable endpoint after one loaded sparse-register read. -/ +structure EntryLookupRestoreResult {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) [] + finalWork finalWork + sourceCells : (finalWork tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (finalWork tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (finalWork tapes.scan.entry.source).head = 1 + count : (finalWork tapes.scan.count).HasBinaryNat store.length + countSource : finalWork tapes.countSource = initialWork tapes.countSource + querySource : finalWork tapes.querySource = initialWork tapes.querySource + value : (finalWork tapes.destination).HasBinaryNat + (RegisterStore.read store address) + copyScratch : (finalWork tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + finalWork i = initialWork i + +/-- Reusable endpoint after reading through a tagged mutable overlay into the +immutable public-input bank. -/ +structure DenseOverlayLookupResult {n : β„•} + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (overlay.flatMap Entry.encode) [] + finalWork finalWork + sourceCells : (finalWork tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (finalWork tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (finalWork tapes.scan.entry.source).head = 1 + count : (finalWork tapes.scan.count).HasBinaryNat overlay.length + countSource : finalWork tapes.countSource = initialWork tapes.countSource + querySource : finalWork tapes.querySource = initialWork tapes.querySource + value : (finalWork tapes.destination).HasBinaryNat + (DenseOverlay.read input overlay address) + copyScratch : (finalWork tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + finalWork i = initialWork i + +/-- Reusable fixed-address dense-overlay endpoint. The destination contains +the decoded register value and the temporary query source is zero again. -/ +structure DenseOverlayLookupStaticResult {n : β„•} + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (overlay.flatMap Entry.encode) [] + finalWork finalWork + sourceCells : (finalWork tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (finalWork tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (finalWork tapes.scan.entry.source).head = 1 + count : (finalWork tapes.scan.count).HasBinaryNat overlay.length + countSource : finalWork tapes.countSource = initialWork tapes.countSource + querySource : (finalWork tapes.querySource).HasBinaryNat 0 + destination : (finalWork tapes.destination).HasBinaryNat + (DenseOverlay.read input overlay address) + copyScratch : (finalWork tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + finalWork i = initialWork i + +/-- Reusable fixed-address endpoint. The destination holds the semantic read, +the scanner is restored, and the fixed query source is zero again. -/ +structure EntryLookupStaticResult {n : β„•} + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) : Prop where + scanner : EntryScanReady tapes.scan.entry (store.flatMap Entry.encode) [] + finalWork finalWork + sourceCells : (finalWork tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells + sourceStart : (finalWork tapes.scan.entry.source).cells 0 = Ξ“.start + sourceHead : (finalWork tapes.scan.entry.source).head = 1 + count : (finalWork tapes.scan.count).HasBinaryNat store.length + countSource : finalWork tapes.countSource = initialWork tapes.countSource + querySource : (finalWork tapes.querySource).HasBinaryNat 0 + destination : (finalWork tapes.destination).HasBinaryNat + (RegisterStore.read store address) + copyScratch : (finalWork tapes.copyScratch).HasBinaryNat 0 + parked : βˆ€ i, TM.Parked (finalWork i) + frame : βˆ€ i, (βˆ€ slot, i β‰  tapes.idx slot) β†’ + finalWork i = initialWork i + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/DenseInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/DenseInternal.lean new file mode 100644 index 0000000000..0d666693dc --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/DenseInternal.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Internal + +/-! +# Dense overlay lookup -- proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem denseOverlayResult_of_destination_update + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) + (initialWork loadedWork finalWork : Fin n β†’ Tape) + (hloaded : EntryLookupRestoreResult tapes overlay address initialWork + loadedWork) + (hvalue : (finalWork tapes.destination).HasBinaryNat + (DenseOverlay.read input overlay address)) + (hother : βˆ€ i, i β‰  tapes.destination β†’ + finalWork i = loadedWork i) + (hparked : βˆ€ i, TM.Parked (finalWork i)) : + DenseOverlayLookupResult tapes input overlay address initialWork + finalWork := by + constructor + Β· constructor + Β· rw [hother tapes.scan.entry.source (tapes.scan_ne_external 0 2)] + exact hloaded.scanner.source + Β· rw [hother tapes.scan.entry.address (tapes.scan_ne_external 1 2)] + exact hloaded.scanner.address + Β· rw [hother tapes.scan.entry.address (tapes.scan_ne_external 1 2)] + exact hloaded.scanner.addressStart + Β· rw [hother tapes.scan.entry.value (tapes.scan_ne_external 2 2)] + exact hloaded.scanner.value + Β· rw [hother tapes.scan.entry.value (tapes.scan_ne_external 2 2)] + exact hloaded.scanner.valueStart + Β· rw [hother tapes.scan.entry.addressCounter + (tapes.scan_ne_external 3 2)] + exact hloaded.scanner.addressCounter + Β· rw [hother tapes.scan.entry.addressWidth + (tapes.scan_ne_external 4 2)] + exact hloaded.scanner.addressWidth + Β· rw [hother tapes.scan.entry.valueCounter + (tapes.scan_ne_external 5 2)] + exact hloaded.scanner.valueCounter + Β· rw [hother tapes.scan.entry.valueWidth + (tapes.scan_ne_external 6 2)] + exact hloaded.scanner.valueWidth + Β· rw [hother tapes.scan.entry.query (tapes.scan_ne_external 7 2)] + exact hloaded.scanner.query + Β· rw [hother tapes.scan.entry.query (tapes.scan_ne_external 7 2)] + exact hloaded.scanner.queryStart + Β· rw [hother tapes.scan.entry.result (tapes.scan_ne_external 8 2)] + exact hloaded.scanner.result + Β· rw [hother tapes.scan.entry.result (tapes.scan_ne_external 8 2)] + exact hloaded.scanner.resultStart + Β· exact hparked + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + Β· rw [hother tapes.scan.entry.source (tapes.scan_ne_external 0 2)] + exact hloaded.sourceCells + Β· rw [hother tapes.scan.entry.source (tapes.scan_ne_external 0 2)] + exact hloaded.sourceStart + Β· rw [hother tapes.scan.entry.source (tapes.scan_ne_external 0 2)] + exact hloaded.sourceHead + Β· rw [hother tapes.scan.count (tapes.scan_ne_external 9 2)] + exact hloaded.count + Β· rw [hother tapes.countSource tapes.countSource_ne_destination] + exact hloaded.countSource + Β· rw [hother tapes.querySource tapes.querySource_ne_destination] + exact hloaded.querySource + Β· exact hvalue + Β· rw [hother tapes.copyScratch tapes.destination_ne_copyScratch.symm] + exact hloaded.copyScratch + Β· exact hparked + Β· intro i hi + rw [hother i (hi 12)] + exact hloaded.frame i hi + +private theorem denseOverlayResult_of_fallback + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) + (initialWork loadedWork finalWork : Fin n β†’ Tape) + (hloaded : EntryLookupRestoreResult tapes overlay address initialWork + loadedWork) + (htagZero : RegisterStore.read overlay address = 0) + (hfallback : DenseInputLookupResult tapes.querySource + tapes.scan.entry.address tapes.destination tapes.copyScratch input address + loadedWork finalWork) : + DenseOverlayLookupResult tapes input overlay address initialWork + finalWork := by + have hscanFrame : βˆ€ slot : Fin 9, slot β‰  1 β†’ + finalWork (tapes.scan.entry.idx slot) = + loadedWork (tapes.scan.entry.idx slot) := by + intro slot hslot + exact hfallback.frame _ + (tapes.scan_ne_external ⟨slot.val, by omega⟩ 1) + (tapes.scan.entry.ne hslot) + (tapes.scan_ne_external ⟨slot.val, by omega⟩ 2) + (tapes.scan_ne_external ⟨slot.val, by omega⟩ 3) + have hcountFrame : finalWork tapes.scan.count = + loadedWork tapes.scan.count := by + exact hfallback.frame _ (tapes.scan_ne_external 9 1) + (tapes.scan.count_ne 1) (tapes.scan_ne_external 9 2) + (tapes.scan_ne_external 9 3) + have hsourceFrame : finalWork tapes.scan.entry.source = + loadedWork tapes.scan.entry.source := by + exact hscanFrame 0 (by decide) + have hvalueFrame : finalWork tapes.scan.entry.value = + loadedWork tapes.scan.entry.value := by + exact hscanFrame 2 (by decide) + have haddressCounterFrame : finalWork tapes.scan.entry.addressCounter = + loadedWork tapes.scan.entry.addressCounter := by + exact hscanFrame 3 (by decide) + have haddressWidthFrame : finalWork tapes.scan.entry.addressWidth = + loadedWork tapes.scan.entry.addressWidth := by + exact hscanFrame 4 (by decide) + have hvalueCounterFrame : finalWork tapes.scan.entry.valueCounter = + loadedWork tapes.scan.entry.valueCounter := by + exact hscanFrame 5 (by decide) + have hvalueWidthFrame : finalWork tapes.scan.entry.valueWidth = + loadedWork tapes.scan.entry.valueWidth := by + exact hscanFrame 6 (by decide) + have hqueryFrame : finalWork tapes.scan.entry.query = + loadedWork tapes.scan.entry.query := by + exact hscanFrame 7 (by decide) + have hresultFrame : finalWork tapes.scan.entry.result = + loadedWork tapes.scan.entry.result := by + exact hscanFrame 8 (by decide) + constructor + Β· constructor + Β· rw [hsourceFrame] + exact hloaded.scanner.source + Β· exact hfallback.counter_zero.2 + Β· exact hfallback.counter_zero.1 + Β· rw [hvalueFrame] + exact hloaded.scanner.value + Β· rw [hvalueFrame] + exact hloaded.scanner.valueStart + Β· rw [haddressCounterFrame] + exact hloaded.scanner.addressCounter + Β· rw [haddressWidthFrame] + exact hloaded.scanner.addressWidth + Β· rw [hvalueCounterFrame] + exact hloaded.scanner.valueCounter + Β· rw [hvalueWidthFrame] + exact hloaded.scanner.valueWidth + Β· rw [hqueryFrame] + exact hloaded.scanner.query + Β· rw [hqueryFrame] + exact hloaded.scanner.queryStart + Β· rw [hresultFrame] + exact hloaded.scanner.result + Β· rw [hresultFrame] + exact hloaded.scanner.resultStart + Β· exact hfallback.parked + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + Β· rw [hsourceFrame] + exact hloaded.sourceCells + Β· rw [hsourceFrame] + exact hloaded.sourceStart + Β· rw [hsourceFrame] + exact hloaded.sourceHead + Β· rw [hcountFrame] + exact hloaded.count + Β· rw [hfallback.frame tapes.countSource + tapes.countSource_ne_querySource + (tapes.scan_ne_external 1 0).symm + tapes.countSource_ne_destination + tapes.countSource_ne_copyScratch] + exact hloaded.countSource + Β· exact hfallback.query_eq.trans hloaded.querySource + Β· simpa [DenseOverlay.read, htagZero] using hfallback.result_value + Β· rw [hfallback.scratch_eq] + exact hloaded.copyScratch + Β· exact hfallback.parked + Β· intro i hi + rw [hfallback.frame i (hi 11) (hi 1) (hi 12) (hi 13)] + exact hloaded.frame i hi + +theorem denseOverlayLookupTM_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (hvalid : DenseOverlay.Valid overlay) + (hready : EntryLookupRestoreReady tapes overlay address initialWork) + (houtput : TM.Parked outβ‚€) : + (denseOverlayLookupTM tapes).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseOverlayLookupResult tapes input overlay address initialWork work ∧ + out = outβ‚€) + (denseOverlayLookupTime tapes input.length overlay address) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let lookupPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes overlay address initialWork work ∧ + out = outβ‚€ + let finalPost : TM.TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupResult tapes input overlay address initialWork work ∧ + out = outβ‚€ + let blankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ (work tapes.destination).read = Ξ“.blank + let nonblankPre : TM.TapePred n := fun inp work out => + lookupPost inp work out ∧ (work tapes.destination).read β‰  Ξ“.blank + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using Tape.init_ofBool_move_right_cells_ne_start input + have hlookup := entryLookupLoaded_hoareTime_internal tapes overlay address + initialWork inpβ‚€ outβ‚€ hready hinput houtput + have hblank : + (denseInputLookupTM tapes.querySource tapes.scan.entry.address + tapes.destination tapes.copyScratch).HoareTime + blankPre finalPost (denseInputLookupTime input.length address) := by + intro inp work out ⟨⟨hinp, hloaded, hout⟩, hread⟩ + have htagZero : RegisterStore.read overlay address = 0 := + hloaded.value.read_eq_blank_iff.mp hread + have haddress : address β‰  0 := by + intro hzero + subst address + exact hvalid.2 htagZero + have hcounter : + (work tapes.scan.entry.address).HasBinaryNat 0 := by + refine ⟨hloaded.scanner.addressStart, ?_⟩ + simpa [Tape.HasBinaryString, Tape.HasBinaryPrefix] using + hloaded.scanner.address + have hdenseReady : DenseInputLookupReady tapes.querySource + tapes.scan.entry.address tapes.destination tapes.copyScratch address + work := by + constructor + Β· rw [hloaded.querySource] + exact hready.querySource + Β· exact hcounter + Β· simpa [htagZero] using hloaded.value + Β· exact hloaded.copyScratch + Β· exact hloaded.parked + have hdense := denseInputLookupTM_hoareTime_internal + tapes.querySource tapes.scan.entry.address tapes.destination + tapes.copyScratch (tapes.scan_ne_external 1 1).symm + tapes.querySource_ne_destination tapes.querySource_ne_copyScratch + (tapes.scan_ne_external 1 2) (tapes.scan_ne_external 1 3) + tapes.destination_ne_copyScratch input address work out haddress + hdenseReady (by simpa [hout] using houtput) + obtain ⟨done, time, htime, hreach, hhalt, hdoneInput, + hdenseResult, hdoneOutput⟩ := + hdense inp work out ⟨hinp, rfl, rfl⟩ + exact ⟨done, time, htime, hreach, hhalt, hdoneInput, + denseOverlayResult_of_fallback tapes input overlay address initialWork + work done.work hloaded htagZero hdenseResult, + hdoneOutput.trans hout⟩ + have hnonblank : (TM.binaryPredTM tapes.destination).HoareTime + nonblankPre finalPost + (TM.binaryPredTime (RegisterStore.read overlay address - 1)) := by + intro inp work out ⟨⟨hinp, hloaded, hout⟩, hread⟩ + have htagNonzero : RegisterStore.read overlay address β‰  0 := by + intro hzero + have hblankRead := hloaded.value.read_eq_blank_iff.mpr hzero + exact hread hblankRead + have htagSucc : RegisterStore.read overlay address - 1 + 1 = + RegisterStore.read overlay address := by omega + have hpredValue : (work tapes.destination).HasBinaryNat + (RegisterStore.read overlay address - 1 + 1) := by + rw [htagSucc] + exact hloaded.value + have hpred := TM.binaryPredTM_hoareTime_frame tapes.destination + (RegisterStore.read overlay address - 1) inp work out hpredValue + (by simpa [hinp] using hinput.read_ne_start) + (fun i _ => (hloaded.parked i).read_ne_start) + (by simpa [hout] using houtput.read_ne_start) + obtain ⟨done, time, htime, hreach, hhalt, hdoneInput, + hdoneOther, hdoneValue, hdoneOutput⟩ := + hpred inp work out ⟨rfl, rfl, rfl⟩ + have hdenseValue : (done.work tapes.destination).HasBinaryNat + (DenseOverlay.read input overlay address) := by + simpa [DenseOverlay.read, htagNonzero] using hdoneValue + have hdoneParked : βˆ€ i, TM.Parked (done.work i) := by + intro i + by_cases hi : i = tapes.destination + Β· subst i + exact ⟨by rw [hdoneValue.2.1], + hdoneValue.2.hasBinaryContent.cells_ne_start⟩ + Β· rw [hdoneOther i hi] + exact hloaded.parked i + exact ⟨done, time, htime, hreach, hhalt, + hdoneInput.trans hinp, + denseOverlayResult_of_destination_update tapes input overlay address + initialWork work done.work hloaded hdenseValue hdoneOther hdoneParked, + hdoneOutput.trans hout⟩ + have hbranchRaw := TM.branchWorkBlankTM_hoareTime tapes.destination + (denseInputLookupTM tapes.querySource tapes.scan.entry.address + tapes.destination tapes.copyScratch) + (TM.binaryPredTM tapes.destination) + (pre := lookupPost) (blankPre := blankPre) + (nonblankPre := nonblankPre) + (blankPost := finalPost) (nonblankPost := finalPost) + (by + intro inp work out ⟨hinp, hloaded, hout⟩ + exact ⟨by simpa [hinp] using hinput.read_ne_start, + fun i => (hloaded.parked i).read_ne_start, + by simpa [hout] using houtput.read_ne_start⟩) + (by + intro inp work out hpost hread + exact ⟨hpost, hread⟩) + (by + intro inp work out hpost hread + exact ⟨hpost, hread⟩) + hblank hnonblank + have hbranch : + (TM.branchWorkBlankTM tapes.destination + (denseInputLookupTM tapes.querySource tapes.scan.entry.address + tapes.destination tapes.copyScratch) + (TM.binaryPredTM tapes.destination)).HoareTime + lookupPost finalPost + (TM.branchWorkBlankTime (denseInputLookupTime input.length address) + (TM.binaryPredTime + (RegisterStore.read overlay address - 1))) := by + intro inp work out hpost + obtain ⟨done, time, htime, hreach, hhalt, hfinal⟩ := + hbranchRaw inp work out hpost + exact ⟨done, time, htime, hreach, hhalt, hfinal.elim id id⟩ + have htransition : βˆ€ inp work out, lookupPost inp work out β†’ + lookupPost (TM.transitionInput inp) + (fun i => TM.transitionTape (work i)) (TM.transitionTape out) := by + intro inp work out ⟨hinp, hloaded, hout⟩ + subst inp + subst out + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinput.read_ne_start + (fun i => (hloaded.parked i).read_ne_start) + houtput.read_ne_start + rw [hi, hw, ho] + exact ⟨rfl, hloaded, rfl⟩ + have hall := TM.seqTM_hoareTime (entryLookupLoadedTM tapes) + (TM.branchWorkBlankTM tapes.destination + (denseInputLookupTM tapes.querySource tapes.scan.entry.address + tapes.destination tapes.copyScratch) + (TM.binaryPredTM tapes.destination)) + hlookup htransition hbranch + simpa [denseOverlayLookupTM, denseOverlayLookupTime, inpβ‚€, lookupPost, + finalPost] using hall + +private theorem denseStaticReset_result + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) + (initialWork loadedWork : Fin n β†’ Tape) + (hloaded : DenseOverlayLookupResult tapes input overlay address + (Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + loadedWork) : + DenseOverlayLookupStaticResult tapes input overlay address initialWork + (Function.update loadedWork tapes.querySource + ((Tape.init []).move Dir3.right)) := by + let finalWork := Function.update loadedWork tapes.querySource + ((Tape.init []).move Dir3.right) + have hsource : tapes.scan.entry.source β‰  tapes.querySource := + tapes.ne (by decide) + have haddress : tapes.scan.entry.address β‰  tapes.querySource := + tapes.ne (by decide) + have hvalue : tapes.scan.entry.value β‰  tapes.querySource := + tapes.ne (by decide) + have haddressCounter : + tapes.scan.entry.addressCounter β‰  tapes.querySource := + tapes.ne (by decide) + have haddressWidth : tapes.scan.entry.addressWidth β‰  tapes.querySource := + tapes.ne (by decide) + have hvalueCounter : tapes.scan.entry.valueCounter β‰  tapes.querySource := + tapes.ne (by decide) + have hvalueWidth : tapes.scan.entry.valueWidth β‰  tapes.querySource := + tapes.ne (by decide) + have hquery : tapes.scan.entry.query β‰  tapes.querySource := + tapes.ne (by decide) + have hresult : tapes.scan.entry.result β‰  tapes.querySource := + tapes.ne (by decide) + have hcount : tapes.scan.count β‰  tapes.querySource := + tapes.ne (by decide) + have hcountSource : tapes.countSource β‰  tapes.querySource := + tapes.countSource_ne_querySource + have hdestination : tapes.destination β‰  tapes.querySource := + tapes.querySource_ne_destination.symm + have hcopyScratch : tapes.copyScratch β‰  tapes.querySource := + tapes.querySource_ne_copyScratch.symm + have hzero : ((Tape.init []).move Dir3.right).HasBinaryNat 0 := by + simpa using Tape.init_move_right_hasBinaryNat 0 + have hscanner : EntryScanReady tapes.scan.entry + (overlay.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.scanner.source + Β· simpa only [finalWork, Function.update_of_ne haddress] using + hloaded.scanner.address + Β· simpa only [finalWork, Function.update_of_ne haddress] using + hloaded.scanner.addressStart + Β· simpa only [finalWork, Function.update_of_ne hvalue] using + hloaded.scanner.value + Β· simpa only [finalWork, Function.update_of_ne hvalue] using + hloaded.scanner.valueStart + Β· simpa only [finalWork, Function.update_of_ne haddressCounter] using + hloaded.scanner.addressCounter + Β· simpa only [finalWork, Function.update_of_ne haddressWidth] using + hloaded.scanner.addressWidth + Β· simpa only [finalWork, Function.update_of_ne hvalueCounter] using + hloaded.scanner.valueCounter + Β· simpa only [finalWork, Function.update_of_ne hvalueWidth] using + hloaded.scanner.valueWidth + Β· simpa only [finalWork, Function.update_of_ne hquery] using + hloaded.scanner.query + Β· simpa only [finalWork, Function.update_of_ne hquery] using + hloaded.scanner.queryStart + Β· simpa only [finalWork, Function.update_of_ne hresult] using + hloaded.scanner.result + Β· simpa only [finalWork, Function.update_of_ne hresult] using + hloaded.scanner.resultStart + Β· intro i + by_cases hi : i = tapes.querySource + Β· subst i + exact ⟨by + simpa only [finalWork, Function.update_self] using + (show 1 ≀ ((Tape.init []).move Dir3.right).head by + rw [hzero.2.1]), + by simpa only [finalWork, Function.update_self] using + hzero.2.hasBinaryContent.cells_ne_start⟩ + Β· simpa only [finalWork, Function.update_of_ne hi] using hloaded.parked i + refine + { scanner := hscanner + sourceCells := ?_ + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ + parked := hscanner.parked + frame := ?_ } + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceCells + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceStart + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceHead + Β· simpa only [finalWork, Function.update_of_ne hcount] using hloaded.count + Β· simp only [hloaded.countSource, Function.update_of_ne hcountSource] + Β· simpa only [finalWork, Function.update_self] using hzero + Β· simpa only [finalWork, Function.update_of_ne hdestination] using + hloaded.value + Β· simpa only [finalWork, Function.update_of_ne hcopyScratch] using + hloaded.copyScratch + Β· intro i hi + have hquerySource : i β‰  tapes.querySource := hi 11 + rw [Function.update_of_ne hquerySource] + rw [hloaded.frame i hi] + exact Function.update_of_ne hquerySource _ initialWork + +theorem denseOverlayLookupStaticTM_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (input : List Bool) + (overlay : Store) (address : β„•) (initialWork : Fin n β†’ Tape) + (outβ‚€ : Tape) (hvalid : DenseOverlay.Valid overlay) + (hready : EntryLookupStaticReady tapes overlay initialWork) + (houtput : TM.Parked outβ‚€) : + (denseOverlayLookupStaticTM tapes address).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + DenseOverlayLookupStaticResult tapes input overlay address initialWork + work ∧ out = outβ‚€) + (denseOverlayLookupStaticTime tapes input.length overlay address) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let loadedInitial := Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + have hinput : TM.Parked inpβ‚€ := by + refine ⟨by simp [inpβ‚€, Tape.move], ?_⟩ + simpa [inpβ‚€] using Tape.init_ofBool_move_right_cells_ne_start input + have hadd := TM.binaryAddConstTM_hoareTime_frame tapes.querySource address 0 + inpβ‚€ initialWork outβ‚€ hready.querySource hinput + (fun i _ => hready.scanner.parked i) houtput + have hadd' : (TM.binaryAddConstTM tapes.querySource address).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = loadedInitial ∧ out = outβ‚€) + (TM.binaryAddConstTime address 0) := by + simpa only [loadedInitial, zero_add] using hadd + have hloadedReady : + EntryLookupRestoreReady tapes overlay address loadedInitial := by + simpa only [loadedInitial, zero_add] using + staticAdd_ready_internal tapes overlay address initialWork hready + have hloaded := denseOverlayLookupTM_hoareTime_internal tapes input overlay + address loadedInitial outβ‚€ hvalid hloadedReady houtput + have hreset : (TM.resetBinaryWorkTM tapes.querySource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupResult tapes input overlay address loadedInitial work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes input overlay address initialWork + work ∧ out = outβ‚€) + (TM.resetBinaryWorkTime 1 address.bits.length) := by + rintro inp work out ⟨hinp, hlookup, hout⟩ + have hqueryNat : (work tapes.querySource).HasBinaryNat address := by + rw [hlookup.querySource] + simpa only [loadedInitial, Function.update_self] using + Tape.init_move_right_hasBinaryNat address + have hrun := TM.resetBinaryWorkTM_hoareTime_frame tapes.querySource + address.bits 1 inp work out hqueryNat.2.hasBinaryContent hqueryNat.1 + ⟨by rw [hqueryNat.2.1], by rw [hqueryNat.2.1]⟩ + (by simpa [hinp] using hinput) + (fun i _ => hlookup.parked i) + (by simpa [hout] using houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput.trans hinp, + (by + rw [hfinalWork] + exact denseStaticReset_result tapes input overlay address initialWork + work hlookup), + hfinalOutput.trans hout⟩ + have hloadedReset := TM.seqTM_hoareTime (denseOverlayLookupTM tapes) + (TM.resetBinaryWorkTM tapes.querySource) hloaded + (by + rintro inp work out ⟨hinp, hlookup, hout⟩ + subst inp + subst out + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinput.read_ne_start (fun i => (hlookup.parked i).read_ne_start) + houtput.read_ne_start + rw [hi, hw, ho] + exact ⟨rfl, hlookup, rfl⟩) + hreset + have hall := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.querySource address) + (TM.seqTM (denseOverlayLookupTM tapes) + (TM.resetBinaryWorkTM tapes.querySource)) hadd' + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + (inp := inp) (work := loadedInitial) (out := out) + (by simpa [hinp] using hinput.read_ne_start) + (fun i => (hloadedReady.scanner.parked i).read_ne_start) + (by simpa [hout] using houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hloadedReset + simpa [denseOverlayLookupStaticTM, denseOverlayLookupStaticTime, inpβ‚€, + loadedInitial] using hall + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal.lean new file mode 100644 index 0000000000..65f4328c1b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Assemble +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Prepare +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Reset +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Restore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Static +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Value + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Assemble.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Assemble.lean new file mode 100644 index 0000000000..c96daabe9f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Assemble.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Prepare +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Restore +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Value + +/-! +# Reusable sparse-register lookup -- phase assembly +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem entryLookupScan_ready_hoareTime + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupTM tapes.scan).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupPrepared tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupScannedReady tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupTime tapes.scan address store) := by + intro inp work out ⟨hinp, hprepared, hout⟩ + have hrun := entryLookupScan_hoareTime_internal tapes store address + initialWork work inpβ‚€ outβ‚€ hprepared hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, hscanned, + hfinalOutput⟩ := hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + ⟨work, hprepared, hscanned⟩, hfinalOutput⟩ + +private theorem entryLookupValueRewind_ready_hoareTime + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.rewindWorkTM tapes.scan.entry.value).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupScannedReady tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupValueReady tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupRestoreHeadBound tapes store address + 2) := by + intro inp work out ⟨hinp, hscanned, hout⟩ + rcases hscanned with ⟨preparedWork, hprepared, hscanned⟩ + exact entryLookupValueRewind_hoareTime_internal tapes store address + initialWork preparedWork work inpβ‚€ outβ‚€ hprepared hscanned hinput + houtput inp work out ⟨hinp, rfl, hout⟩ + +private theorem entryLookupValueCopy_ready_hoareTime + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupValueReady tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupCopied tapes store address initialWork work ∧ + out = outβ‚€) + (TM.binaryCopyTime (RegisterStore.read store address) 0) := by + intro inp work out ⟨hinp, hready, hout⟩ + exact entryLookupValueCopy_hoareTime_internal tapes store address + initialWork work inpβ‚€ outβ‚€ hready hinput houtput inp work out + ⟨hinp, rfl, hout⟩ + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Scanner reset, source rewind, and count restoration form one reusable tail +whose endpoint is the original blank-query scanner ABI. -/ +theorem entryLookupRestoreTail_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinitial : EntryLookupRestoreReady tapes store address initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupRestoreTailTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupCopied tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupRestoreTailTime tapes store address) := by + have hreset := entryLookupReset_ready_hoareTime_internal tapes store address + initialWork inpβ‚€ outβ‚€ hinput houtput + have hsource := entryLookupSourceRewind_ready_hoareTime_internal tapes store + address initialWork inpβ‚€ outβ‚€ hinitial hinput houtput + have hcount := entryLookupCountRestore_ready_hoareTime_internal tapes store + address initialWork inpβ‚€ outβ‚€ hinput houtput + have hsourceCount := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.scan.entry.source) + (TM.binaryCopyIntoTM tapes.countSource tapes.scan.count + tapes.copyScratch) + hsource + (by + rintro inp work out ⟨hinp, hready, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hready.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hready, hout⟩) + hcount + have hall := TM.seqTM_hoareTime + (TM.resetBinaryWorkManyTM (entryLookupResetTargets tapes)) + (TM.seqTM (TM.rewindWorkTM tapes.scan.entry.source) + (TM.binaryCopyIntoTM tapes.countSource tapes.scan.count + tapes.copyScratch)) + hreset + (by + rintro inp work out ⟨hinp, hready, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hready.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hready, hout⟩) + hsourceCount + simpa [entryLookupRestoreTailTM, entryLookupRestoreTailTime] using hall + +/-- Once the external query has been prepared, scanning, value extraction, +and complete restoration form one reusable lookup. -/ +theorem entryLookupCopyRestore_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinitial : EntryLookupRestoreReady tapes store address initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupCopyRestoreTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupPrepared tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupCopyRestoreTime tapes store address) := by + have hscan := entryLookupScan_ready_hoareTime tapes store address initialWork + inpβ‚€ outβ‚€ hinput houtput + have hrewind := entryLookupValueRewind_ready_hoareTime tapes store address + initialWork inpβ‚€ outβ‚€ hinput houtput + have hcopy := entryLookupValueCopy_ready_hoareTime tapes store address + initialWork inpβ‚€ outβ‚€ hinput houtput + have htail := entryLookupRestoreTail_hoareTime_internal tapes store address + initialWork inpβ‚€ outβ‚€ hinitial hinput houtput + have hcopyTail := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch) + (entryLookupRestoreTailTM tapes) hcopy + (by + rintro inp work out ⟨hinp, hready, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hready.restore.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hready, hout⟩) + htail + have hrewindRest := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.scan.entry.value) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch) + (entryLookupRestoreTailTM tapes)) + hrewind + (by + rintro inp work out ⟨hinp, hready, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hready.restore.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hready, hout⟩) + hcopyTail + have hall := TM.seqTM_hoareTime (entryLookupTM tapes.scan) + (TM.seqTM (TM.rewindWorkTM tapes.scan.entry.value) + (TM.seqTM + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch) + (entryLookupRestoreTailTM tapes))) + hscan + (by + rintro inp work out ⟨hinp, hready, hout⟩ + rcases hready with ⟨preparedWork, hprepared, hscanned⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hscanned.result.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, ⟨preparedWork, hprepared, hscanned⟩, hout⟩) + hrewindRest + simpa [entryLookupCopyRestoreTM, entryLookupCopyRestoreTime] using hall + +/-- Complete semantic and time contract for one reusable loaded sparse-register +lookup. -/ +theorem entryLookupLoaded_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupRestoreReady tapes store address initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupLoadedTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupLoadedTime tapes store address) := by + have hprepare := entryLookupPrepare_hoareTime_internal tapes store address + initialWork inpβ‚€ outβ‚€ hready hinput houtput + have hrest := entryLookupCopyRestore_hoareTime_internal tapes store address + initialWork inpβ‚€ outβ‚€ hready hinput houtput + have hall := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.querySource tapes.scan.entry.query + tapes.copyScratch) + (entryLookupCopyRestoreTM tapes) hprepare + (by + rintro inp work out ⟨hinp, hprepared, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hprepared.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hprepared, hout⟩) + hrest + simpa [entryLookupLoadedTM, entryLookupLoadedTime] using hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Bounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Bounds.lean new file mode 100644 index 0000000000..b347117963 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Bounds.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs + +/-! +# Reusable sparse-register lookup -- reset bounds +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +theorem entryLookupEntryWidth_le_storeWidth_internal + (store : Store) (address : β„•) (entry : Entry) (hentry : entry ∈ store) : + entryLookupEntryWidth entry address ≀ + entryLookupStoreWidth address store := by + induction store with + | nil => simp at hentry + | cons current rest ih => + simp only [List.mem_cons] at hentry + simp only [entryLookupStoreWidth] + rcases hentry with rfl | hentry + Β· exact le_max_left _ _ + Β· exact le_trans (ih hentry) (le_max_right _ _) + +theorem entryLookupEntryWidth_le_resetWidth_internal + (store : Store) (address : β„•) (entry : Entry) (hentry : entry ∈ store) : + entryLookupEntryWidth entry address ≀ + entryLookupResetWidth store address := + le_trans (entryLookupEntryWidth_le_storeWidth_internal store address entry hentry) + (le_max_right _ _) + +theorem entryLookupAddressWidth_le_resetWidth_internal + (store : Store) (address : β„•) : + address.bits.length ≀ entryLookupResetWidth store address := by + apply le_trans _ (le_max_right _ _) + induction store with + | nil => exact le_rfl + | cons entry rest ih => + exact le_trans ih (le_max_right _ _) + +theorem entryLookupRemainingWidth_le_resetWidth_internal + (store : Store) (address remaining : β„•) (hle : remaining ≀ store.length) : + remaining.bits.length ≀ entryLookupResetWidth store address := by + have hsize := Nat.size_le_size hle + have hbits : remaining.bits.length ≀ store.length.bits.length := by + simpa only [Nat.size_eq_bits_len] using hsize + exact le_trans hbits (le_max_left _ _) + +theorem entryLookupEntryAddressWidth_le_internal + (entry : Entry) (address : β„•) : + entry.1.bits.length ≀ entryLookupEntryWidth entry address := by + simp only [entryLookupEntryWidth] + exact le_trans (le_max_left _ _) (le_max_right _ _) + +theorem entryLookupEntryValueWidth_le_internal + (entry : Entry) (address : β„•) : + entry.2.bits.length ≀ entryLookupEntryWidth entry address := by + simp only [entryLookupEntryWidth] + exact le_trans (le_max_left _ _) + (le_trans (le_max_right _ _) (le_max_right _ _)) + +theorem entryLookupEntryAddressCounterWidth_le_internal + (entry : Entry) (address : β„•) : + bitlen entry.1 ≀ entryLookupEntryWidth entry address := by + simp only [entryLookupEntryWidth] + exact le_trans (le_max_left _ _) + (le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) (le_max_right _ _))) + +theorem entryLookupEntryValueCounterWidth_le_internal + (entry : Entry) (address : β„•) : + bitlen entry.2 ≀ entryLookupEntryWidth entry address := by + simp only [entryLookupEntryWidth] + exact le_trans (le_max_left _ _) + (le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) (le_max_right _ _)))) + +theorem entryLookupResultWidth_le_internal (entry : Entry) (address : β„•) : + 1 ≀ entryLookupEntryWidth entry address := by + simp only [entryLookupEntryWidth] + exact le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) + (le_trans (le_max_right _ _) (le_max_right _ _)))) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Prepare.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Prepare.lean new file mode 100644 index 0000000000..aded57c958 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Prepare.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy + +/-! +# Reusable sparse-register lookup -- query preparation +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem query_ne_external (tapes : EntryLookupRestoreTapes n) + (external : Fin 4) : + tapes.scan.entry.query β‰  tapes.idx ⟨external.val + 10, by omega⟩ := + tapes.scan_ne_external 7 external + +/-- Copying the external query source into the blank scanner query tape +establishes the exact lookup-ready boundary and changes no other tape. -/ +theorem entryLookupPrepare_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (workβ‚€ : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupRestoreReady tapes store address workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.binaryCopyIntoTM tapes.querySource tapes.scan.entry.query + tapes.copyScratch).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupPrepared tapes store address workβ‚€ work ∧ + out = outβ‚€) + (TM.binaryCopyTime address 0) := by + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame + tapes.querySource tapes.scan.entry.query tapes.copyScratch + (Ne.symm (query_ne_external tapes 1)) + tapes.querySource_ne_copyScratch + (query_ne_external tapes 3) address 0 inpβ‚€ workβ‚€ outβ‚€ + hready.querySource + ⟨hready.scanner.queryStart, by simpa using hready.scanner.query⟩ + hready.copyScratch hinput + (fun i _ _ _ => hready.scanner.parked i) houtput + exact hcopy.strengthen_post (by + rintro inp work out ⟨hinp, hwork, hout⟩ + let queryTape := (Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right + let preparedWork := Function.update workβ‚€ tapes.scan.entry.query queryTape + have hwork' : work = preparedWork := by + simpa [preparedWork, queryTape] using hwork + clear hwork + subst work + have hquery : + preparedWork tapes.scan.entry.query = queryTape := by + simp [preparedWork] + have hother : βˆ€ i, i β‰  tapes.scan.entry.query β†’ + preparedWork i = workβ‚€ i := by + intro i hi + simp [preparedWork, Function.update_of_ne hi] + have hsourceQuery : + tapes.scan.entry.source β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have haddressQuery : + tapes.scan.entry.address β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have hvalueQuery : + tapes.scan.entry.value β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have haddressCounterQuery : + tapes.scan.entry.addressCounter β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have haddressWidthQuery : + tapes.scan.entry.addressWidth β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have hvalueCounterQuery : + tapes.scan.entry.valueCounter β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have hvalueWidthQuery : + tapes.scan.entry.valueWidth β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have hresultQuery : + tapes.scan.entry.result β‰  tapes.scan.entry.query := + tapes.scan.entry.ne (by decide) + have hdestinationQuery : + tapes.destination β‰  tapes.scan.entry.query := by + exact Ne.symm (query_ne_external tapes 2) + have hcopyScratchQuery : + tapes.copyScratch β‰  tapes.scan.entry.query := by + exact Ne.symm (query_ne_external tapes 3) + have hscanner : EntryScanReady tapes.scan.entry + (store.flatMap Entry.encode) address.bits preparedWork + preparedWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + Β· rw [hother _ hsourceQuery] + exact hready.scanner.source + Β· rw [hother _ haddressQuery] + exact hready.scanner.address + Β· rw [hother _ haddressQuery] + exact hready.scanner.addressStart + Β· rw [hother _ hvalueQuery] + exact hready.scanner.value + Β· rw [hother _ hvalueQuery] + exact hready.scanner.valueStart + Β· rw [hother _ haddressCounterQuery] + exact hready.scanner.addressCounter + Β· rw [hother _ haddressWidthQuery] + exact hready.scanner.addressWidth + Β· rw [hother _ hvalueCounterQuery] + exact hready.scanner.valueCounter + Β· rw [hother _ hvalueWidthQuery] + exact hready.scanner.valueWidth + Β· rw [hquery] + exact Tape.init_move_right_hasBinaryString address.bits + Β· rw [hquery] + simp [queryTape, Tape.init, Tape.move] + Β· rw [hother _ hresultQuery] + exact hready.scanner.result + Β· rw [hother _ hresultQuery] + exact hready.scanner.resultStart + Β· intro i + by_cases hi : i = tapes.scan.entry.query + Β· subst i + rw [hquery] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat address) + Β· rw [hother i hi] + exact hready.scanner.parked i + refine ⟨hinp, ⟨hscanner, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + hscanner.parked, + hother⟩, hout⟩ + Β· rw [hother _ hsourceQuery] + exact hready.sourceStart + Β· rw [hother _ hsourceQuery] + exact hready.sourceHead + Β· rw [hother _ (tapes.scan.count_ne 7)] + exact hready.count + Β· exact hother _ (Ne.symm (query_ne_external tapes 0)) + Β· have heq : preparedWork tapes.countSource = + workβ‚€ tapes.countSource := + hother _ (Ne.symm (query_ne_external tapes 0)) + rw [heq] + exact hready.countSource + Β· exact hother _ (Ne.symm (query_ne_external tapes 1)) + Β· have heq : preparedWork tapes.querySource = + workβ‚€ tapes.querySource := + hother _ (Ne.symm (query_ne_external tapes 1)) + rw [heq] + exact hready.querySource + Β· rw [hother _ hdestinationQuery] + exact hready.destination + Β· rw [hother _ hcopyScratchQuery] + exact hready.copyScratch) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Reset.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Reset.lean new file mode 100644 index 0000000000..17874e7bda --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Reset.lean @@ -0,0 +1,326 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Bounds +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Reusable sparse-register lookup -- reset certificates +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem matched_mem_store + (tapes : EntryScanTapes n) (store scanned : Store) + (matched : Entry) (rest : Store) (queryBits : List Bool) + (initialWork hitBase finalWork : Fin n β†’ Tape) + (hfound : EntryScanFound tapes store scanned matched rest queryBits + initialWork hitBase finalWork) : + matched ∈ store := by + rw [hfound.store_eq] + simp + +private theorem found_reset_content + (tapes : EntryLookupRestoreTapes n) (store scanned : Store) + (matched : Entry) (rest : Store) (address : β„•) + (initialWork hitBase finalWork : Fin n β†’ Tape) + (hfound : EntryScanFound tapes.scan store scanned matched rest address.bits + initialWork hitBase finalWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (finalWork i).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address i) := by + obtain ⟨iterationWork, hreadable⟩ := hfound.hit.readable + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change (finalWork tapes.scan.entry.address).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.address) + simpa only [entryLookupFoundBits_zero] using hreadable.address + Β· change (finalWork tapes.scan.entry.value).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.value) + simpa only [entryLookupFoundBits_one] using! hreadable.value.2 + Β· change (finalWork tapes.scan.entry.addressCounter).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.addressCounter) + simpa only [entryLookupFoundBits_two] using! + hreadable.addressCounter.2 + Β· change (finalWork tapes.scan.entry.addressWidth).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.addressWidth) + simpa only [entryLookupFoundBits_three] using! + hreadable.addressWidth.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.valueCounter).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.valueCounter) + simpa only [entryLookupFoundBits_four] using! + hreadable.valueCounter.2 + Β· change (finalWork tapes.scan.entry.valueWidth).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.valueWidth) + simpa only [entryLookupFoundBits_five] using! + hreadable.valueWidth.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.result).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.result) + simpa only [entryLookupFoundBits_six] using + hreadable.result.hasBinaryContent + Β· change (finalWork tapes.scan.entry.query).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.query) + simpa only [entryLookupFoundBits_seven] using hreadable.query + Β· change (finalWork tapes.scan.count).HasBinaryContent + (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.count) + simpa only [EntryLookupRestoreTapes.scan_count, + entryLookupFoundBits_eight] using + hfound.count.2.hasBinaryContent + +private theorem found_reset_start + (tapes : EntryLookupRestoreTapes n) (store scanned : Store) + (matched : Entry) (rest : Store) (address : β„•) + (initialWork hitBase finalWork : Fin n β†’ Tape) + (hfound : EntryScanFound tapes.scan store scanned matched rest address.bits + initialWork hitBase finalWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (finalWork i).cells 0 = Ξ“.start := by + obtain ⟨iterationWork, hreadable⟩ := hfound.hit.readable + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· exact hreadable.addressStart + Β· exact hreadable.valueStart + Β· exact hreadable.addressCounterStart + Β· exact hreadable.addressWidth.1 + Β· exact hreadable.valueCounterStart + Β· exact hreadable.valueWidth.1 + Β· exact hreadable.resultStart + Β· exact hreadable.queryStart + Β· exact hfound.count.1 + +private theorem found_reset_width + (tapes : EntryLookupRestoreTapes n) (store scanned : Store) + (matched : Entry) (rest : Store) (address : β„•) + (initialWork hitBase finalWork : Fin n β†’ Tape) + (hfound : EntryScanFound tapes.scan store scanned matched rest address.bits + initialWork hitBase finalWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (entryLookupFoundBits tapes matched (rest.length + 1) address i).length ≀ + entryLookupResetWidth store address := by + have hmem := matched_mem_store tapes.scan store scanned matched rest + address.bits initialWork hitBase finalWork hfound + have hentry := entryLookupEntryWidth_le_resetWidth_internal store address + matched hmem + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.address).length ≀ _ + rw [entryLookupFoundBits_zero] + exact le_trans (entryLookupEntryAddressWidth_le_internal matched address) + hentry + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.value).length ≀ _ + rw [entryLookupFoundBits_one] + exact le_trans (entryLookupEntryValueWidth_le_internal matched address) + hentry + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.addressCounter).length ≀ _ + rw [entryLookupFoundBits_two] + simpa using le_trans + (entryLookupEntryAddressCounterWidth_le_internal matched address) hentry + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.addressWidth).length ≀ _ + rw [entryLookupFoundBits_three] + simp + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.valueCounter).length ≀ _ + rw [entryLookupFoundBits_four] + simpa using le_trans + (entryLookupEntryValueCounterWidth_le_internal matched address) hentry + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.valueWidth).length ≀ _ + rw [entryLookupFoundBits_five] + simp + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.result).length ≀ _ + rw [entryLookupFoundBits_six] + simpa using le_trans (entryLookupResultWidth_le_internal matched address) + hentry + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.entry.query).length ≀ _ + rw [entryLookupFoundBits_seven] + exact entryLookupAddressWidth_le_resetWidth_internal store address + Β· change (entryLookupFoundBits tapes matched (rest.length + 1) address + tapes.scan.count).length ≀ _ + simp only [EntryLookupRestoreTapes.scan_count, + entryLookupFoundBits_eight] + apply entryLookupRemainingWidth_le_resetWidth_internal + rw [hfound.store_eq] + simp + +private theorem miss_reset_content + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork readyBase finalWork : Fin n β†’ Tape) + (hmiss : EntryScanMiss tapes.scan store address.bits initialWork readyBase + finalWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (finalWork i).HasBinaryContent (entryLookupMissBits tapes address i) := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change (finalWork tapes.scan.entry.address).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.address) + rw [entryLookupMissBits_zero] + exact hmiss.ready.address.2 + Β· change (finalWork tapes.scan.entry.value).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.value) + rw [entryLookupMissBits_one] + exact hmiss.ready.value.2 + Β· change (finalWork tapes.scan.entry.addressCounter).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.addressCounter) + rw [entryLookupMissBits_two] + exact hmiss.ready.addressCounter.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.addressWidth).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.addressWidth) + rw [entryLookupMissBits_three] + exact hmiss.ready.addressWidth.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.valueCounter).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.valueCounter) + rw [entryLookupMissBits_four] + exact hmiss.ready.valueCounter.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.valueWidth).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.valueWidth) + rw [entryLookupMissBits_five] + exact hmiss.ready.valueWidth.2.hasBinaryContent + Β· change (finalWork tapes.scan.entry.result).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.result) + rw [entryLookupMissBits_six] + exact hmiss.ready.result.2 + Β· change (finalWork tapes.scan.entry.query).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.entry.query) + rw [entryLookupMissBits_seven] + exact hmiss.ready.query.hasBinaryContent + Β· change (finalWork tapes.scan.count).HasBinaryContent + (entryLookupMissBits tapes address tapes.scan.count) + simpa only [EntryLookupRestoreTapes.scan_count, + entryLookupMissBits_eight] using! hmiss.count.2.hasBinaryContent + +private theorem miss_reset_start + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork readyBase finalWork : Fin n β†’ Tape) + (hmiss : EntryScanMiss tapes.scan store address.bits initialWork readyBase + finalWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (finalWork i).cells 0 = Ξ“.start := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· exact hmiss.ready.addressStart + Β· exact hmiss.ready.valueStart + Β· exact hmiss.ready.addressCounter.1 + Β· exact hmiss.ready.addressWidth.1 + Β· exact hmiss.ready.valueCounter.1 + Β· exact hmiss.ready.valueWidth.1 + Β· exact hmiss.ready.resultStart + Β· exact hmiss.ready.queryStart + Β· exact hmiss.count.1 + +private theorem miss_reset_width + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (entryLookupMissBits tapes address i).length ≀ + entryLookupResetWidth store address := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.address).length ≀ _ + rw [entryLookupMissBits_zero] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.value).length ≀ _ + rw [entryLookupMissBits_one] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.addressCounter).length ≀ _ + rw [entryLookupMissBits_two] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.addressWidth).length ≀ _ + rw [entryLookupMissBits_three] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.valueCounter).length ≀ _ + rw [entryLookupMissBits_four] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.valueWidth).length ≀ _ + rw [entryLookupMissBits_five] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.result).length ≀ _ + rw [entryLookupMissBits_six] + simp + Β· change (entryLookupMissBits tapes address + tapes.scan.entry.query).length ≀ _ + rw [entryLookupMissBits_seven] + exact entryLookupAddressWidth_le_resetWidth_internal store address + Β· change (entryLookupMissBits tapes address tapes.scan.count).length ≀ _ + simp only [EntryLookupRestoreTapes.scan_count, + entryLookupMissBits_eight] + simp + +/-- Every semantic scanner result determines exact bounded contents for all +nine reset targets. -/ +theorem EntryLookupResult.resetReady_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork finalWork : Fin n β†’ Tape) + (hresult : EntryLookupResult tapes.scan store address initialWork + finalWork) : + EntryLookupResetReady tapes store address finalWork := by + rcases hresult.outcome with hfound | hmiss + Β· rcases hfound with ⟨scanned, matched, rest, hitBase, hfound⟩ + exact ⟨entryLookupFoundBits tapes matched (rest.length + 1) address, + found_reset_content tapes store scanned matched rest address initialWork + hitBase finalWork hfound, + found_reset_start tapes store scanned matched rest address initialWork + hitBase finalWork hfound, + found_reset_width tapes store scanned matched rest address initialWork + hitBase finalWork hfound, + hresult.parked⟩ + Β· rcases hmiss with ⟨readyBase, hmiss⟩ + exact ⟨entryLookupMissBits tapes address, + miss_reset_content tapes store address initialWork readyBase finalWork + hmiss, + miss_reset_start tapes store address initialWork readyBase finalWork + hmiss, + miss_reset_width tapes store address, + hresult.parked⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Restore.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Restore.lean new file mode 100644 index 0000000000..6ddda29f29 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Restore.lean @@ -0,0 +1,709 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Reusable sparse-register lookup -- scanner restoration +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- Reset all nine scanner-owned binary tapes under one uniform width and +cursor envelope. -/ +theorem entryLookupReset_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork copiedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hcopied : EntryLookupCopied tapes store address initialWork copiedWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.resetBinaryWorkManyTM (entryLookupResetTargets tapes)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = copiedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupResetDone tapes store address initialWork copiedWork work ∧ + out = outβ‚€) + (entryLookupResetTime tapes store address) := by + rcases hcopied.restore.resetReady with + ⟨bits, hcontent, hstart, hwidth, hparked⟩ + let headBound : Fin n β†’ β„• := + fun _ => entryLookupRestoreHeadBound tapes store address + have hreset := TM.resetBinaryWorkManyTM_hoareTime_frame + (entryLookupResetTargets tapes) bits headBound inpβ‚€ copiedWork outβ‚€ + (List.nodup_ofFn_ofInjective tapes.resetIdx_injective) + hcontent hstart + (by + intro i hi + exact hcopied.restore.resetHeadBound i hi) + hinput hparked houtput + have htime : TM.resetBinaryWorkManyTime bits headBound + (entryLookupResetTargets tapes) ≀ + entryLookupResetTime tapes store address := by + have hcoarse := TM.resetBinaryWorkManyTime_le + (entryLookupResetTargets tapes) bits headBound + (entryLookupRestoreHeadBound tapes store address) + (entryLookupResetWidth store address) + (by intro i hi; exact le_rfl) hwidth + simpa [entryLookupResetTime, entryLookupResetTargets] using hcoarse + exact (hreset.mono_bound htime).strengthen_post (by + rintro inp work out ⟨hinp, hwork, hout⟩ + exact ⟨hinp, ⟨hcopied, hwork⟩, hout⟩) + +private theorem reset_source_not_mem + (tapes : EntryLookupRestoreTapes n) : + tapes.scan.entry.source βˆ‰ entryLookupResetTargets tapes := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change tapes.scan.entry.address = tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 1) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.value = tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 2) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.addressCounter = + tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 3) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.addressWidth = + tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 4) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.valueCounter = + tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 5) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.valueWidth = tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 6) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.result = tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 8) (j := 0) (by decide) hslot + Β· change tapes.scan.entry.query = tapes.scan.entry.source at hslot + exact tapes.scan.entry.ne (i := 7) (j := 0) (by decide) hslot + Β· change tapes.scan.count = tapes.scan.entry.source at hslot + exact tapes.scan.count_ne_source hslot + +private theorem reset_external_not_mem + (tapes : EntryLookupRestoreTapes n) (external : Fin 4) : + tapes.idx ⟨external.val + 10, by omega⟩ βˆ‰ + entryLookupResetTargets tapes := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change tapes.scan.entry.address = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 1 external hslot + Β· change tapes.scan.entry.value = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 2 external hslot + Β· change tapes.scan.entry.addressCounter = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 3 external hslot + Β· change tapes.scan.entry.addressWidth = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 4 external hslot + Β· change tapes.scan.entry.valueCounter = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 5 external hslot + Β· change tapes.scan.entry.valueWidth = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 6 external hslot + Β· change tapes.scan.entry.result = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 8 external hslot + Β· change tapes.scan.entry.query = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 7 external hslot + Β· change tapes.scan.count = + tapes.idx ⟨external.val + 10, by omega⟩ at hslot + exact tapes.scan_ne_external 9 external hslot + +private theorem not_mem_resetTargets_of_outside + (tapes : EntryLookupRestoreTapes n) (i : Fin n) + (hall : βˆ€ slot, i β‰  tapes.idx slot) : + i βˆ‰ entryLookupResetTargets tapes := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + exact hall (EntryLookupRestoreTapes.resetSlot slot) hslot.symm + +private theorem resetDone_scratchReset + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork copiedWork resetWork : Fin n β†’ Tape) + (hdone : EntryLookupResetDone tapes store address initialWork copiedWork + resetWork) : + EntryLookupScratchReset tapes store address initialWork resetWork := by + rw [hdone.work_eq] + let targets := entryLookupResetTargets tapes + let work := TM.resetBinaryWorkManyResult copiedWork targets + have hsource : work tapes.scan.entry.source = + copiedWork tapes.scan.entry.source := by + exact TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets _ + (reset_source_not_mem tapes) + have hcountSource : TM.resetBinaryWorkManyResult copiedWork + (entryLookupResetTargets tapes) tapes.countSource = + copiedWork tapes.countSource := + TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets _ + (reset_external_not_mem tapes 0) + have hquerySource : TM.resetBinaryWorkManyResult copiedWork + (entryLookupResetTargets tapes) tapes.querySource = + copiedWork tapes.querySource := + TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets _ + (reset_external_not_mem tapes 1) + have hdestination : TM.resetBinaryWorkManyResult copiedWork + (entryLookupResetTargets tapes) tapes.destination = + copiedWork tapes.destination := + TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets _ + (reset_external_not_mem tapes 2) + have hcopyScratch : TM.resetBinaryWorkManyResult copiedWork + (entryLookupResetTargets tapes) tapes.copyScratch = + copiedWork tapes.copyScratch := + TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets _ + (reset_external_not_mem tapes 3) + refine + { sourceCells := by + rw [TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork + (entryLookupResetTargets tapes) _ (reset_source_not_mem tapes)] + exact hdone.copied.restore.sourceCells + sourceStart := by + rw [TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork + (entryLookupResetTargets tapes) _ (reset_source_not_mem tapes)] + exact hdone.copied.restore.sourceStart + sourceHeadBound := by + rw [TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork + (entryLookupResetTargets tapes) _ (reset_source_not_mem tapes)] + exact hdone.copied.restore.sourceHeadBound + targetsBlank := by + intro i hi + exact TM.resetBinaryWorkManyResult_eq_blank_of_mem copiedWork targets i hi + countSource := hcountSource.trans hdone.copied.restore.countSource + countSourceNat := by + rw [hcountSource] + exact hdone.copied.restore.countSourceNat + querySource := hquerySource.trans hdone.copied.restore.querySource + querySourceNat := by + rw [hquerySource] + exact hdone.copied.restore.querySourceNat + destination := by + rw [hdestination] + exact hdone.copied.destination + copyScratch := hcopyScratch.trans hdone.copied.restore.copyScratch + copyScratchNat := by + rw [hcopyScratch] + exact hdone.copied.restore.copyScratchNat + parked := TM.resetBinaryWorkManyResult_parked copiedWork targets + hdone.copied.restore.parked + frame := ?_ } + intro i hall + rw [TM.resetBinaryWorkManyResult_eq_of_not_mem copiedWork targets i + (not_mem_resetTargets_of_outside tapes i hall)] + exact hdone.copied.restore.frame i hall + +private theorem scratchReset_rewindSource + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work work' : Fin n β†’ Tape) + (hreset : EntryLookupScratchReset tapes store address initialWork work) + (hcells : (work' tapes.scan.entry.source).cells = + (work tapes.scan.entry.source).cells) + (hhead : (work' tapes.scan.entry.source).head = 1) + (hother : βˆ€ i, i β‰  tapes.scan.entry.source β†’ work' i = work i) : + EntryLookupScratchReset tapes store address initialWork work' := by + have hcountSource : tapes.countSource β‰  tapes.scan.entry.source := + Ne.symm (tapes.scan_ne_external 0 0) + have hquerySource : tapes.querySource β‰  tapes.scan.entry.source := + Ne.symm (tapes.scan_ne_external 0 1) + have hdestination : tapes.destination β‰  tapes.scan.entry.source := + Ne.symm (tapes.scan_ne_external 0 2) + have hcopyScratch : tapes.copyScratch β‰  tapes.scan.entry.source := + Ne.symm (tapes.scan_ne_external 0 3) + refine + { sourceCells := by + rw [hcells] + exact hreset.sourceCells + sourceStart := by + rw [hcells] + exact hreset.sourceStart + sourceHeadBound := by + simp only [entryLookupRestoreHeadBound] + omega + targetsBlank := ?_ + countSource := by + rw [hother _ hcountSource] + exact hreset.countSource + countSourceNat := by + rw [hother _ hcountSource] + exact hreset.countSourceNat + querySource := by + rw [hother _ hquerySource] + exact hreset.querySource + querySourceNat := by + rw [hother _ hquerySource] + exact hreset.querySourceNat + destination := by + rw [hother _ hdestination] + exact hreset.destination + copyScratch := by + rw [hother _ hcopyScratch] + exact hreset.copyScratch + copyScratchNat := by + rw [hother _ hcopyScratch] + exact hreset.copyScratchNat + parked := ?_ + frame := ?_ } + Β· intro i hi + have hne : i β‰  tapes.scan.entry.source := by + intro heq + exact reset_source_not_mem tapes (heq β–Έ hi) + rw [hother i hne] + exact hreset.targetsBlank i hi + Β· intro i + by_cases hi : i = tapes.scan.entry.source + Β· subst i + exact ⟨by omega, by simpa only [hcells] using (hreset.parked _).2⟩ + Β· rw [hother i hi] + exact hreset.parked i + Β· intro i hall + rw [hother i (hall 0)] + exact hreset.frame i hall + +private theorem reset_target_mem + (tapes : EntryLookupRestoreTapes n) (slot : Fin 9) : + tapes.resetIdx slot ∈ entryLookupResetTargets tapes := + List.mem_ofFn.mpr ⟨slot, rfl⟩ + +private theorem blank_hasBinaryNat_zero : + TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + +private theorem blank_hasBinaryPrefix_nil : + TM.resetBinaryBlank.HasBinaryPrefix [] := by + have hstring : TM.resetBinaryBlank.HasBinaryString [] := by + simpa using blank_hasBinaryNat_zero.2 + exact ⟨by simpa using hstring.1, hstring.2⟩ + +private theorem blank_parked : TM.Parked TM.resetBinaryBlank := + ⟨by rw [blank_hasBinaryNat_zero.2.1], + blank_hasBinaryNat_zero.2.hasBinaryContent.cells_ne_start⟩ + +private theorem scratchReset_sourceReady + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) + (hinitial : EntryLookupRestoreReady tapes store address initialWork) + (hreset : EntryLookupScratchReset tapes store address initialWork work) + (hsourceHead : (work tapes.scan.entry.source).head = 1) : + EntryLookupSourceReady tapes store address initialWork work := by + have hsource : (work tapes.scan.entry.source).HasBinarySuffix + (store.flatMap Entry.encode) := by + rw [Tape.HasBinarySuffix, hreset.sourceCells, hsourceHead] + have hinitialSource := hinitial.scanner.source + rw [Tape.HasBinarySuffix, hinitial.sourceHead] at hinitialSource + exact hinitialSource + have hblank := hreset.targetsBlank + have haddress : work tapes.scan.entry.address = TM.resetBinaryBlank := by + change work (tapes.resetIdx 0) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 0) + have hvalue : work tapes.scan.entry.value = TM.resetBinaryBlank := by + change work (tapes.resetIdx 1) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 1) + have haddressCounter : work tapes.scan.entry.addressCounter = + TM.resetBinaryBlank := by + change work (tapes.resetIdx 2) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 2) + have haddressWidth : work tapes.scan.entry.addressWidth = + TM.resetBinaryBlank := by + change work (tapes.resetIdx 3) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 3) + have hvalueCounter : work tapes.scan.entry.valueCounter = + TM.resetBinaryBlank := by + change work (tapes.resetIdx 4) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 4) + have hvalueWidth : work tapes.scan.entry.valueWidth = + TM.resetBinaryBlank := by + change work (tapes.resetIdx 5) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 5) + have hresult : work tapes.scan.entry.result = TM.resetBinaryBlank := by + change work (tapes.resetIdx 6) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 6) + have hquery : work tapes.scan.entry.query = TM.resetBinaryBlank := by + change work (tapes.resetIdx 7) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 7) + have hcount : work tapes.scan.count = TM.resetBinaryBlank := by + change work (tapes.resetIdx 8) = TM.resetBinaryBlank + exact hblank _ (reset_target_mem tapes 8) + have hscanner : EntryScanReady tapes.scan.entry + (store.flatMap Entry.encode) [] work work := by + refine + { source := hsource + address := by rw [haddress]; exact blank_hasBinaryPrefix_nil + addressStart := by rw [haddress]; exact blank_hasBinaryNat_zero.1 + value := by rw [hvalue]; exact blank_hasBinaryPrefix_nil + valueStart := by rw [hvalue]; exact blank_hasBinaryNat_zero.1 + addressCounter := by rw [haddressCounter]; exact blank_hasBinaryNat_zero + addressWidth := by rw [haddressWidth]; exact blank_hasBinaryNat_zero + valueCounter := by rw [hvalueCounter]; exact blank_hasBinaryNat_zero + valueWidth := by rw [hvalueWidth]; exact blank_hasBinaryNat_zero + query := by + rw [hquery] + simpa using blank_hasBinaryNat_zero.2 + queryStart := by rw [hquery]; exact blank_hasBinaryNat_zero.1 + result := by rw [hresult]; exact blank_hasBinaryPrefix_nil + resultStart := by rw [hresult]; exact blank_hasBinaryNat_zero.1 + parked := hreset.parked + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + exact + { scanner := hscanner + sourceCells := hreset.sourceCells + sourceStart := hreset.sourceStart + sourceHead := hsourceHead + countZero := by rw [hcount]; exact blank_hasBinaryNat_zero + countSource := hreset.countSource + countSourceNat := hreset.countSourceNat + querySource := hreset.querySource + destination := hreset.destination + copyScratch := hreset.copyScratch + copyScratchNat := hreset.copyScratchNat + parked := hreset.parked + frame := hreset.frame } + +/-- Rewind the read-only encoded store after resetting scanner scratch. -/ +theorem entryLookupSourceRewind_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork copiedWork resetWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hinitial : EntryLookupRestoreReady tapes store address initialWork) + (hdone : EntryLookupResetDone tapes store address initialWork copiedWork + resetWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.rewindWorkTM tapes.scan.entry.source).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = resetWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupSourceReady tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupRestoreHeadBound tapes store address + 2) := by + let P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop := + fun inp work out => inp = inpβ‚€ ∧ + EntryLookupScratchReset tapes store address initialWork work ∧ + out = outβ‚€ + have hpreserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' tapes.scan.entry.source).cells = + (work tapes.scan.entry.source).cells β†’ + (work' tapes.scan.entry.source).head = 1 β†’ + (βˆ€ i, i β‰  tapes.scan.entry.source β†’ work' i = work i) β†’ + inp' = inp β†’ out'.cells = out.cells β†’ out'.head = out.head β†’ + P inp' work' out' := by + rintro inp work out inp' work' out' ⟨hinp, hreset, hout⟩ + hcells hhead hother hinp' houtCells houtHead + exact ⟨hinp'.trans hinp, + scratchReset_rewindSource tapes store address initialWork work work' + hreset hcells hhead hother, + (Tape.ext houtHead houtCells).trans hout⟩ + have hrewind := TM.rewindWorkTM_hoareTime_frame + tapes.scan.entry.source + (entryLookupRestoreHeadBound tapes store address) hpreserved + exact hrewind.consequence + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + rw [hinp, hwork, hout] + have hreset := resetDone_scratchReset tapes store address initialWork + copiedWork resetWork hdone + refine ⟨hreset.sourceStart, (hreset.parked _).2, + hreset.sourceHeadBound, hinput.read_ne_start, + houtput.read_ne_start, houtput.1, ?_, ⟨rfl, hreset, rfl⟩⟩ + intro i hi + exact ⟨(hreset.parked i).read_ne_start, (hreset.parked i).1⟩) + (by + rintro inp work out ⟨hsourceHead, hinp, hreset, hout⟩ + exact ⟨hinp, + scratchReset_sourceReady tapes store address initialWork work hinitial + hreset hsourceHead, + hout⟩) + le_rfl + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +/-- Restore the runtime entry count from its preserved canonical copy. This is +the final phase returning the scanner to its reusable blank-query boundary. -/ +theorem entryLookupCountRestore_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork workβ‚€ : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupSourceReady tapes store address initialWork workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.binaryCopyIntoTM tapes.countSource tapes.scan.count + tapes.copyScratch).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (TM.binaryCopyTime store.length 0) := by + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame + tapes.countSource tapes.scan.count tapes.copyScratch + (Ne.symm (tapes.scan_ne_external 9 0)) + tapes.countSource_ne_copyScratch + (tapes.scan_ne_external 9 3) store.length 0 inpβ‚€ workβ‚€ outβ‚€ + hready.countSourceNat hready.countZero hready.copyScratchNat hinput + (fun i _ _ _ => hready.parked i) houtput + exact hcopy.strengthen_post (by + rintro inp work out ⟨hinp, hwork, hout⟩ + let countTape := + (Tape.init (store.length.bits.map Ξ“.ofBool)).move Dir3.right + let restoredWork := Function.update workβ‚€ tapes.scan.count countTape + have hwork' : work = restoredWork := by + simpa [restoredWork, countTape] using hwork + clear hwork + subst work + have hother : βˆ€ i, i β‰  tapes.scan.count β†’ + restoredWork i = workβ‚€ i := by + intro i hi + have hi' : i β‰  tapes.scan.count := hi + exact Function.update_of_ne hi' countTape workβ‚€ + have hcount : + (restoredWork tapes.scan.count).HasBinaryNat store.length := by + rw [show restoredWork tapes.scan.count = countTape by + simp [restoredWork]] + simpa [countTape] using Tape.init_move_right_hasBinaryNat store.length + have hscanner : EntryScanReady tapes.scan.entry + (store.flatMap Entry.encode) [] restoredWork restoredWork := by + have hcountNe : βˆ€ slot, tapes.scan.entry.idx slot β‰  + tapes.scan.count := by + intro slot + exact Ne.symm (tapes.scan.count_ne slot) + have hentryOther : βˆ€ slot, restoredWork (tapes.scan.entry.idx slot) = + workβ‚€ (tapes.scan.entry.idx slot) := by + intro slot + exact hother _ (hcountNe slot) + refine + { source := by + change (restoredWork (tapes.scan.entry.idx 0)).HasBinarySuffix _ + rw [hentryOther 0] + exact hready.scanner.source + address := by + change (restoredWork (tapes.scan.entry.idx 1)).HasBinaryPrefix [] + rw [hentryOther 1] + exact hready.scanner.address + addressStart := by + change (restoredWork (tapes.scan.entry.idx 1)).cells 0 = Ξ“.start + rw [hentryOther 1] + exact hready.scanner.addressStart + value := by + change (restoredWork (tapes.scan.entry.idx 2)).HasBinaryPrefix [] + rw [hentryOther 2] + exact hready.scanner.value + valueStart := by + change (restoredWork (tapes.scan.entry.idx 2)).cells 0 = Ξ“.start + rw [hentryOther 2] + exact hready.scanner.valueStart + addressCounter := by + change (restoredWork (tapes.scan.entry.idx 3)).HasBinaryNat 0 + rw [hentryOther 3] + exact hready.scanner.addressCounter + addressWidth := by + change (restoredWork (tapes.scan.entry.idx 4)).HasBinaryNat 0 + rw [hentryOther 4] + exact hready.scanner.addressWidth + valueCounter := by + change (restoredWork (tapes.scan.entry.idx 5)).HasBinaryNat 0 + rw [hentryOther 5] + exact hready.scanner.valueCounter + valueWidth := by + change (restoredWork (tapes.scan.entry.idx 6)).HasBinaryNat 0 + rw [hentryOther 6] + exact hready.scanner.valueWidth + query := by + change (restoredWork (tapes.scan.entry.idx 7)).HasBinaryString [] + rw [hentryOther 7] + exact hready.scanner.query + queryStart := by + change (restoredWork (tapes.scan.entry.idx 7)).cells 0 = Ξ“.start + rw [hentryOther 7] + exact hready.scanner.queryStart + result := by + change (restoredWork (tapes.scan.entry.idx 8)).HasBinaryPrefix [] + rw [hentryOther 8] + exact hready.scanner.result + resultStart := by + change (restoredWork (tapes.scan.entry.idx 8)).cells 0 = Ξ“.start + rw [hentryOther 8] + exact hready.scanner.resultStart + parked := by + intro i + by_cases hi : i = tapes.scan.count + Β· subst i + exact hasBinaryNat_parked hcount + Β· rw [hother i hi] + exact hready.parked i + frame := by intro i _ _ _ _ _ _ _ _ _; rfl } + have hcountSource : restoredWork tapes.countSource = + initialWork tapes.countSource := by + have heq : restoredWork tapes.countSource = workβ‚€ tapes.countSource := + hother _ (Ne.symm (tapes.scan_ne_external 9 0)) + exact heq.trans hready.countSource + have hquerySource : restoredWork tapes.querySource = + initialWork tapes.querySource := by + have heq : restoredWork tapes.querySource = workβ‚€ tapes.querySource := + hother _ (Ne.symm (tapes.scan_ne_external 9 1)) + exact heq.trans hready.querySource + have hdestination : + (restoredWork tapes.destination).HasBinaryNat + (RegisterStore.read store address) := by + have heq : restoredWork tapes.destination = workβ‚€ tapes.destination := + hother _ (Ne.symm (tapes.scan_ne_external 9 2)) + rw [heq] + exact hready.destination + have hcopyScratch : restoredWork tapes.copyScratch = + initialWork tapes.copyScratch := by + have heq : restoredWork tapes.copyScratch = workβ‚€ tapes.copyScratch := + hother _ (Ne.symm (tapes.scan_ne_external 9 3)) + exact heq.trans hready.copyScratch + have hcopyScratchNat : + (restoredWork tapes.copyScratch).HasBinaryNat 0 := by + have heq : restoredWork tapes.copyScratch = workβ‚€ tapes.copyScratch := + hother _ (Ne.symm (tapes.scan_ne_external 9 3)) + rw [heq] + exact hready.copyScratchNat + have hparked : βˆ€ i, TM.Parked (restoredWork i) := hscanner.parked + have hsourceStart : + (restoredWork tapes.scan.entry.source).cells 0 = Ξ“.start := by + rw [hother _ (Ne.symm tapes.scan.count_ne_source)] + exact hready.sourceStart + have hsourceHead : + (restoredWork tapes.scan.entry.source).head = 1 := by + rw [hother _ (Ne.symm tapes.scan.count_ne_source)] + exact hready.sourceHead + refine ⟨hinp, ⟨hscanner, ?_, hsourceStart, hsourceHead, hcount, + hcountSource, hquerySource, + hdestination, hcopyScratchNat, hparked, ?_⟩, hout⟩ + Β· rw [hother _ (Ne.symm tapes.scan.count_ne_source)] + exact hready.sourceCells + intro i hall + rw [hother i (hall 9)] + exact hready.frame i hall) + +/-- Semantic reset boundary used by sequential lookup composition. -/ +theorem entryLookupReset_ready_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.resetBinaryWorkManyTM (entryLookupResetTargets tapes)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupCopied tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupScratchReset tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupResetTime tapes store address) := by + intro inp work out ⟨hinp, hcopied, hout⟩ + have hrun := entryLookupReset_hoareTime_internal tapes store address + initialWork work inpβ‚€ outβ‚€ hcopied hinput houtput + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, hdone, + hfinalOutput⟩ := + hrun inp work out ⟨hinp, rfl, hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, + resetDone_scratchReset tapes store address initialWork work final.work + hdone, + hfinalOutput⟩ + +/-- Semantic encoded-source rewind boundary used by sequential composition. -/ +theorem entryLookupSourceRewind_ready_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinitial : EntryLookupRestoreReady tapes store address initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.rewindWorkTM tapes.scan.entry.source).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupScratchReset tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupSourceReady tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupRestoreHeadBound tapes store address + 2) := by + let P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop := + fun inp work out => inp = inpβ‚€ ∧ + EntryLookupScratchReset tapes store address initialWork work ∧ + out = outβ‚€ + have hpreserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' tapes.scan.entry.source).cells = + (work tapes.scan.entry.source).cells β†’ + (work' tapes.scan.entry.source).head = 1 β†’ + (βˆ€ i, i β‰  tapes.scan.entry.source β†’ work' i = work i) β†’ + inp' = inp β†’ out'.cells = out.cells β†’ out'.head = out.head β†’ + P inp' work' out' := by + rintro inp work out inp' work' out' ⟨hinp, hreset, hout⟩ + hcells hhead hother hinp' houtCells houtHead + exact ⟨hinp'.trans hinp, + scratchReset_rewindSource tapes store address initialWork work work' + hreset hcells hhead hother, + (Tape.ext houtHead houtCells).trans hout⟩ + have hrewind := TM.rewindWorkTM_hoareTime_frame + tapes.scan.entry.source + (entryLookupRestoreHeadBound tapes store address) hpreserved + exact hrewind.consequence + (by + rintro inp work out ⟨hinp, hreset, hout⟩ + refine ⟨hreset.sourceStart, (hreset.parked _).2, + hreset.sourceHeadBound, ?_, ?_, ?_, ?_, ⟨hinp, hreset, hout⟩⟩ + Β· simpa [hinp] using hinput.read_ne_start + Β· simpa [hout] using houtput.read_ne_start + Β· simpa [hout] using houtput.1 + Β· intro i hi + exact ⟨(hreset.parked i).read_ne_start, (hreset.parked i).1⟩) + (by + rintro inp work out ⟨hsourceHead, hinp, hreset, hout⟩ + exact ⟨hinp, + scratchReset_sourceReady tapes store address initialWork work hinitial + hreset hsourceHead, + hout⟩) + le_rfl + +/-- Semantic count-copy boundary used by sequential composition. -/ +theorem entryLookupCountRestore_ready_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.binaryCopyIntoTM tapes.countSource tapes.scan.count + tapes.copyScratch).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupSourceReady tapes store address initialWork work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address initialWork work ∧ + out = outβ‚€) + (TM.binaryCopyTime store.length 0) := by + intro inp work out ⟨hinp, hready, hout⟩ + exact entryLookupCountRestore_hoareTime_internal tapes store address + initialWork work inpβ‚€ outβ‚€ hready hinput houtput inp work out + ⟨hinp, rfl, hout⟩ + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Scan.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Scan.lean new file mode 100644 index 0000000000..2c7f2bee89 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Scan.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Reset + +/-! +# Reusable sparse-register lookup -- bounded scan phase +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem external_frame + (tapes : EntryLookupRestoreTapes n) (external : Fin 4) + (initialWork finalWork : Fin n β†’ Tape) + (hframe : EntryScanFrame tapes.scan initialWork finalWork) : + finalWork (tapes.idx ⟨external.val + 10, by omega⟩) = + initialWork (tapes.idx ⟨external.val + 10, by omega⟩) := by + apply hframe + Β· exact Ne.symm (tapes.scan_ne_external 9 external) + Β· exact Ne.symm (tapes.scan_ne_external 0 external) + Β· exact Ne.symm (tapes.scan_ne_external 1 external) + Β· exact Ne.symm (tapes.scan_ne_external 2 external) + Β· exact Ne.symm (tapes.scan_ne_external 3 external) + Β· exact Ne.symm (tapes.scan_ne_external 4 external) + Β· exact Ne.symm (tapes.scan_ne_external 5 external) + Β· exact Ne.symm (tapes.scan_ne_external 6 external) + Β· exact Ne.symm (tapes.scan_ne_external 7 external) + Β· exact Ne.symm (tapes.scan_ne_external 8 external) + +private theorem prepared_reset_head + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork : Fin n β†’ Tape) + (hprepared : EntryLookupPrepared tapes store address initialWork + preparedWork) : + βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (preparedWork i).head = 1 := by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· simpa using hprepared.scanner.address.1 + Β· simpa using hprepared.scanner.value.1 + Β· exact hprepared.scanner.addressCounter.2.1 + Β· exact hprepared.scanner.addressWidth.2.1 + Β· exact hprepared.scanner.valueCounter.2.1 + Β· exact hprepared.scanner.valueWidth.2.1 + Β· simpa using hprepared.scanner.result.1 + Β· exact hprepared.scanner.query.1 + Β· exact hprepared.count.2.1 + +/-- The scanner phase preserves the reusable external ABI and packages every +fact needed to copy the value and restore the scanner-owned tapes. -/ +theorem entryLookupScan_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hprepared : EntryLookupPrepared tapes store address initialWork + preparedWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupTM tapes.scan).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = preparedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupScanned tapes store address initialWork preparedWork work ∧ + out = outβ‚€) + (entryLookupTime tapes.scan address store) := by + have hlookup := entryLookupTM_hoareTime_frame_source tapes.scan store address + preparedWork inpβ‚€ outβ‚€ hprepared.scanner hprepared.count hinput houtput + exact hlookup.strengthen_post (by + rintro inp work out + ⟨hinp, hresult, hsourceCells, hheads, hout⟩ + have hsourcePrepared : + preparedWork tapes.scan.entry.source = + initialWork tapes.scan.entry.source := + hprepared.frame _ (tapes.scan.entry.ne (by decide)) + have hsourceInitial : (work tapes.scan.entry.source).cells = + (initialWork tapes.scan.entry.source).cells := + hsourceCells.trans + (congrArg Tape.cells hsourcePrepared) + have hsourceHead : (work tapes.scan.entry.source).head ≀ + entryLookupRestoreHeadBound tapes store address := by + have hhead := hheads tapes.scan.entry.source + simp only [entryLookupRestoreHeadBound] + rw [hprepared.sourceHead] at hhead + omega + have hresetHead : βˆ€ i, i ∈ entryLookupResetTargets tapes β†’ + (work i).head ≀ + entryLookupRestoreHeadBound tapes store address := by + intro i hi + have hhead := hheads i + rw [prepared_reset_head tapes store address initialWork preparedWork + hprepared i hi] at hhead + simpa only [entryLookupRestoreHeadBound] using hhead + have hcountSource : work tapes.countSource = + initialWork tapes.countSource := + (external_frame tapes 0 preparedWork work hresult.frame).trans + hprepared.countSource + have hquerySource : work tapes.querySource = + initialWork tapes.querySource := + (external_frame tapes 1 preparedWork work hresult.frame).trans + hprepared.querySource + have hdestination : work tapes.destination = + initialWork tapes.destination := + (external_frame tapes 2 preparedWork work hresult.frame).trans (by + exact hprepared.frame _ + (Ne.symm (tapes.scan_ne_external 7 2))) + have hcopyScratch : work tapes.copyScratch = + initialWork tapes.copyScratch := + (external_frame tapes 3 preparedWork work hresult.frame).trans (by + exact hprepared.frame _ + (Ne.symm (tapes.scan_ne_external 7 3))) + refine ⟨hinp, ⟨hresult, + hresult.resetReady_internal tapes store address preparedWork work, + hsourceInitial, by + rw [hsourceCells] + exact hprepared.sourceStart, + hsourceHead, hresetHead, hcountSource, hquerySource, + hdestination, hcopyScratch, ?_⟩, hout⟩ + intro i hall + calc + work i = preparedWork i := hresult.frame i + (hall 9) (hall 0) (hall 1) (hall 2) (hall 3) (hall 4) + (hall 5) (hall 6) (hall 7) (hall 8) + _ = initialWork i := hprepared.frame i (hall 7)) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Static.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Static.lean new file mode 100644 index 0000000000..b98f6667fb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Static.lean @@ -0,0 +1,381 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Internal.Assemble +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst + +/-! +# Fixed-address sparse-register lookup -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +private theorem staticAddress_parked (address : β„•) : + TM.Parked + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) := by + have hnat := Tape.init_move_right_hasBinaryNat address + exact ⟨by rw [hnat.2.1], hnat.2.hasBinaryContent.cells_ne_start⟩ + +private theorem staticBlank_hasBinaryNat : + ((Tape.init []).move Dir3.right).HasBinaryNat 0 := by + simpa using Tape.init_move_right_hasBinaryNat 0 + +theorem staticAdd_ready_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) + (hready : EntryLookupStaticReady tapes store initialWork) : + EntryLookupRestoreReady tapes store address + (Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) := by + let work₁ := Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + have hsource : tapes.scan.entry.source β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddress : tapes.scan.entry.address β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalue : tapes.scan.entry.value β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddressCounter : + tapes.scan.entry.addressCounter β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddressWidth : + tapes.scan.entry.addressWidth β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalueCounter : + tapes.scan.entry.valueCounter β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalueWidth : tapes.scan.entry.valueWidth β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hquery : tapes.scan.entry.query β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hresult : tapes.scan.entry.result β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hcount : tapes.scan.count β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hcountSource : tapes.countSource β‰  tapes.querySource := + tapes.countSource_ne_querySource + have hdestination : tapes.destination β‰  tapes.querySource := + tapes.querySource_ne_destination.symm + have hcopyScratch : tapes.copyScratch β‰  tapes.querySource := + tapes.querySource_ne_copyScratch.symm + have hscanner : EntryScanReady tapes.scan.entry + (store.flatMap Entry.encode) [] work₁ work₁ := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := ?_ } + Β· simpa only [work₁, Function.update_of_ne hsource] using + hready.scanner.source + Β· simpa only [work₁, Function.update_of_ne haddress] using + hready.scanner.address + Β· simpa only [work₁, Function.update_of_ne haddress] using + hready.scanner.addressStart + Β· simpa only [work₁, Function.update_of_ne hvalue] using + hready.scanner.value + Β· simpa only [work₁, Function.update_of_ne hvalue] using + hready.scanner.valueStart + Β· simpa only [work₁, Function.update_of_ne haddressCounter] using + hready.scanner.addressCounter + Β· simpa only [work₁, Function.update_of_ne haddressWidth] using + hready.scanner.addressWidth + Β· simpa only [work₁, Function.update_of_ne hvalueCounter] using + hready.scanner.valueCounter + Β· simpa only [work₁, Function.update_of_ne hvalueWidth] using + hready.scanner.valueWidth + Β· simpa only [work₁, Function.update_of_ne hquery] using + hready.scanner.query + Β· simpa only [work₁, Function.update_of_ne hquery] using + hready.scanner.queryStart + Β· simpa only [work₁, Function.update_of_ne hresult] using + hready.scanner.result + Β· simpa only [work₁, Function.update_of_ne hresult] using + hready.scanner.resultStart + Β· intro i + by_cases hi : i = tapes.querySource + Β· subst i + simpa only [work₁, Function.update_self] using + staticAddress_parked address + Β· simpa only [work₁, Function.update_of_ne hi] using + hready.scanner.parked i + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + refine + { scanner := hscanner + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ } + Β· simpa only [work₁, Function.update_of_ne hsource] using + hready.sourceStart + Β· simpa only [work₁, Function.update_of_ne hsource] using + hready.sourceHead + Β· simpa only [work₁, Function.update_of_ne hcount] using hready.count + Β· simpa only [work₁, Function.update_of_ne + hcountSource] using hready.countSource + Β· simpa only [work₁, Function.update_self] using + Tape.init_move_right_hasBinaryNat address + Β· simpa only [work₁, Function.update_of_ne hdestination] using + hready.destination + Β· simpa only [work₁, Function.update_of_ne hcopyScratch] using + hready.copyScratch + +private theorem staticReset_result + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork loadedWork : Fin n β†’ Tape) + (hloaded : EntryLookupRestoreResult tapes store address + (Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right)) + loadedWork) : + EntryLookupStaticResult tapes store address initialWork + (Function.update loadedWork tapes.querySource + ((Tape.init []).move Dir3.right)) := by + let finalWork := Function.update loadedWork tapes.querySource + ((Tape.init []).move Dir3.right) + have hsource : tapes.scan.entry.source β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddress : tapes.scan.entry.address β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalue : tapes.scan.entry.value β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddressCounter : + tapes.scan.entry.addressCounter β‰  tapes.querySource := by + exact tapes.ne (by decide) + have haddressWidth : + tapes.scan.entry.addressWidth β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalueCounter : + tapes.scan.entry.valueCounter β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hvalueWidth : tapes.scan.entry.valueWidth β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hquery : tapes.scan.entry.query β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hresult : tapes.scan.entry.result β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hcount : tapes.scan.count β‰  tapes.querySource := by + exact tapes.ne (by decide) + have hcountSource : tapes.countSource β‰  tapes.querySource := + tapes.countSource_ne_querySource + have hdestination : tapes.destination β‰  tapes.querySource := + tapes.querySource_ne_destination.symm + have hcopyScratch : tapes.copyScratch β‰  tapes.querySource := + tapes.querySource_ne_copyScratch.symm + have hscanner : EntryScanReady tapes.scan.entry + (store.flatMap Entry.encode) [] finalWork finalWork := by + refine + { source := ?_ + address := ?_ + addressStart := ?_ + value := ?_ + valueStart := ?_ + addressCounter := ?_ + addressWidth := ?_ + valueCounter := ?_ + valueWidth := ?_ + query := ?_ + queryStart := ?_ + result := ?_ + resultStart := ?_ + parked := ?_ + frame := ?_ } + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.scanner.source + Β· simpa only [finalWork, Function.update_of_ne haddress] using + hloaded.scanner.address + Β· simpa only [finalWork, Function.update_of_ne haddress] using + hloaded.scanner.addressStart + Β· simpa only [finalWork, Function.update_of_ne hvalue] using + hloaded.scanner.value + Β· simpa only [finalWork, Function.update_of_ne hvalue] using + hloaded.scanner.valueStart + Β· simpa only [finalWork, Function.update_of_ne haddressCounter] using + hloaded.scanner.addressCounter + Β· simpa only [finalWork, Function.update_of_ne haddressWidth] using + hloaded.scanner.addressWidth + Β· simpa only [finalWork, Function.update_of_ne hvalueCounter] using + hloaded.scanner.valueCounter + Β· simpa only [finalWork, Function.update_of_ne hvalueWidth] using + hloaded.scanner.valueWidth + Β· simpa only [finalWork, Function.update_of_ne hquery] using + hloaded.scanner.query + Β· simpa only [finalWork, Function.update_of_ne hquery] using + hloaded.scanner.queryStart + Β· simpa only [finalWork, Function.update_of_ne hresult] using + hloaded.scanner.result + Β· simpa only [finalWork, Function.update_of_ne hresult] using + hloaded.scanner.resultStart + Β· intro i + by_cases hi : i = tapes.querySource + Β· subst i + have hzero := staticBlank_hasBinaryNat + simpa only [finalWork, Function.update_self] using + (show TM.Parked ((Tape.init []).move Dir3.right) from + ⟨by rw [hzero.2.1], hzero.2.hasBinaryContent.cells_ne_start⟩) + Β· simpa only [finalWork, Function.update_of_ne hi] using hloaded.parked i + Β· intro i _ _ _ _ _ _ _ _ _ + rfl + refine + { scanner := hscanner + sourceCells := by + simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceCells + sourceStart := ?_ + sourceHead := ?_ + count := ?_ + countSource := ?_ + querySource := ?_ + destination := ?_ + copyScratch := ?_ + parked := hscanner.parked + frame := ?_ } + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceStart + Β· simpa only [finalWork, Function.update_of_ne hsource] using + hloaded.sourceHead + Β· simpa only [finalWork, Function.update_of_ne hcount] using hloaded.count + Β· simp only [hloaded.countSource, Function.update_of_ne hcountSource] + Β· simpa only [finalWork, Function.update_self] using staticBlank_hasBinaryNat + Β· simpa only [finalWork, Function.update_of_ne hdestination] using + hloaded.value + Β· simpa only [finalWork, Function.update_of_ne hcopyScratch] using + hloaded.copyScratch + Β· intro i hi + have hquery : i β‰  tapes.querySource := hi 11 + rw [Function.update_of_ne hquery] + have houtside : βˆ€ slot, i β‰  tapes.idx slot := by + intro slot + exact hi slot + rw [hloaded.frame i houtside] + exact Function.update_of_ne hquery _ initialWork + +theorem entryLookupStatic_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupStaticReady tapes store initialWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (entryLookupStaticTM tapes address).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupStaticTime tapes store address) := by + let loadedInitial := Function.update initialWork tapes.querySource + ((Tape.init (address.bits.map Ξ“.ofBool)).move Dir3.right) + have hadd := TM.binaryAddConstTM_hoareTime_frame tapes.querySource address 0 + inpβ‚€ initialWork outβ‚€ hready.querySource hinput + (fun i _ => hready.scanner.parked i) houtput + have hadd' : (TM.binaryAddConstTM tapes.querySource address).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = initialWork ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = loadedInitial ∧ out = outβ‚€) + (TM.binaryAddConstTime address 0) := by + simpa only [loadedInitial, zero_add] using hadd + have hloadedReady : EntryLookupRestoreReady tapes store address loadedInitial := by + simpa only [loadedInitial, zero_add] using + staticAdd_ready_internal tapes store address initialWork hready + have hloaded := entryLookupLoaded_hoareTime_internal tapes store address + loadedInitial inpβ‚€ outβ‚€ hloadedReady hinput houtput + have hreset : (TM.resetBinaryWorkTM tapes.querySource).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreResult tapes store address loadedInitial work ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes store address initialWork work ∧ + out = outβ‚€) + (TM.resetBinaryWorkTime 1 address.bits.length) := by + rintro inp work out ⟨hinp, hlookup, hout⟩ + have hqueryNat : (work tapes.querySource).HasBinaryNat address := by + rw [hlookup.querySource] + simpa only [loadedInitial, Function.update_self] using + Tape.init_move_right_hasBinaryNat address + have hrun := TM.resetBinaryWorkTM_hoareTime_frame tapes.querySource + address.bits 1 inp work out hqueryNat.2.hasBinaryContent hqueryNat.1 + ⟨by rw [hqueryNat.2.1], by rw [hqueryNat.2.1]⟩ + (by simpa [hinp] using hinput) + (fun i _ => hlookup.parked i) + (by simpa [hout] using houtput) + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨final, time, htime, hreach, hhalt, + hfinalInput.trans hinp, + (by + rw [hfinalWork] + exact staticReset_result tapes store address initialWork work hlookup), + hfinalOutput.trans hout⟩ + have hloadedReset := TM.seqTM_hoareTime + (entryLookupLoadedTM tapes) + (TM.resetBinaryWorkTM tapes.querySource) hloaded + (by + rintro inp work out ⟨hinp, hlookup, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using hinput) hlookup.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, hlookup, hout⟩) + hreset + have hall := TM.seqTM_hoareTime + (TM.binaryAddConstTM tapes.querySource address) + (TM.seqTM (entryLookupLoadedTM tapes) + (TM.resetBinaryWorkTM tapes.querySource)) hadd' + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + subst work + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := loadedInitial) (out := out) + (by simpa [hinp] using hinput) hloadedReady.scanner.parked + (by simpa [hout] using houtput) + rw [hi, hw, ho] + exact ⟨hinp, rfl, hout⟩) + hloadedReset + simpa [entryLookupStaticTM, entryLookupStaticTime, loadedInitial] using hall + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Value.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Value.lean new file mode 100644 index 0000000000..fb43a419a3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/Internal/Value.lean @@ -0,0 +1,440 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Lookup.Defs +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Reusable sparse-register lookup -- value rewind and copy +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem reset_value_mem (tapes : EntryLookupRestoreTapes n) : + tapes.scan.entry.value ∈ entryLookupResetTargets tapes := by + apply List.mem_ofFn.mpr + exact ⟨1, EntryLookupRestoreTapes.resetIdx_one tapes⟩ + +private theorem scanned_restoreInvariant + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork scannedWork : Fin n β†’ Tape) + (hprepared : EntryLookupPrepared tapes store address initialWork + preparedWork) + (hscanned : EntryLookupScanned tapes store address initialWork + preparedWork scannedWork) : + EntryLookupRestoreInvariant tapes store address initialWork scannedWork := by + have hpreparedScratch : preparedWork tapes.copyScratch = + initialWork tapes.copyScratch := + hprepared.frame _ (Ne.symm (tapes.scan_ne_external 7 3)) + refine + { valueContent := hscanned.result.value.2 + valueStart := hscanned.result.valueStart + resetReady := hscanned.resetReady + sourceCells := hscanned.sourceCells + sourceStart := hscanned.sourceStart + sourceHeadBound := hscanned.sourceHeadBound + resetHeadBound := hscanned.resetHeadBound + countSource := hscanned.countSource + countSourceNat := ?_ + querySource := hscanned.querySource + querySourceNat := ?_ + copyScratch := hscanned.copyScratch + copyScratchNat := ?_ + parked := hscanned.result.parked + frame := hscanned.frame } + Β· rw [hscanned.countSource, ← hprepared.countSource] + exact hprepared.countSourceNat + Β· rw [hscanned.querySource, ← hprepared.querySource] + exact hprepared.querySourceNat + Β· rw [hscanned.copyScratch, ← hpreparedScratch] + exact hprepared.copyScratch + +private theorem restoreInvariant_rewindValue + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work work' : Fin n β†’ Tape) + (hrestore : EntryLookupRestoreInvariant tapes store address initialWork + work) + (hcells : (work' tapes.scan.entry.value).cells = + (work tapes.scan.entry.value).cells) + (hhead : (work' tapes.scan.entry.value).head = 1) + (hother : βˆ€ i, i β‰  tapes.scan.entry.value β†’ work' i = work i) : + EntryLookupRestoreInvariant tapes store address initialWork work' := by + have hsourceValue : + tapes.scan.entry.source β‰  tapes.scan.entry.value := + tapes.scan.entry.ne (by decide) + have hcountSourceValue : tapes.countSource β‰  + tapes.scan.entry.value := + Ne.symm (tapes.scan_ne_external 2 0) + have hquerySourceValue : tapes.querySource β‰  + tapes.scan.entry.value := + Ne.symm (tapes.scan_ne_external 2 1) + have hcopyScratchValue : tapes.copyScratch β‰  + tapes.scan.entry.value := + Ne.symm (tapes.scan_ne_external 2 3) + have hreset : EntryLookupResetReady tapes store address work' := by + rcases hrestore.resetReady with + ⟨bits, hcontent, hstart, hwidth, hparked⟩ + refine ⟨bits, ?_, ?_, hwidth, ?_⟩ + Β· intro i hi + by_cases hivalue : i = tapes.scan.entry.value + Β· subst i + simpa only [Tape.HasBinaryContent, hcells] using hcontent _ hi + Β· rw [hother i hivalue] + exact hcontent i hi + Β· intro i hi + by_cases hivalue : i = tapes.scan.entry.value + Β· subst i + simpa only [hcells] using hstart _ hi + Β· rw [hother i hivalue] + exact hstart i hi + Β· intro i + by_cases hivalue : i = tapes.scan.entry.value + Β· subst i + exact ⟨by omega, by + simpa only [hcells] using + hrestore.valueContent.cells_ne_start⟩ + Β· rw [hother i hivalue] + exact hparked i + refine + { valueContent := by + simpa only [Tape.HasBinaryContent, hcells] using + hrestore.valueContent + valueStart := by simpa only [hcells] using hrestore.valueStart + resetReady := hreset + sourceCells := by + rw [hother _ hsourceValue] + exact hrestore.sourceCells + sourceStart := by + rw [hother _ hsourceValue] + exact hrestore.sourceStart + sourceHeadBound := by + rw [hother _ hsourceValue] + exact hrestore.sourceHeadBound + resetHeadBound := ?_ + countSource := by + rw [hother _ hcountSourceValue] + exact hrestore.countSource + countSourceNat := by + rw [hother _ hcountSourceValue] + exact hrestore.countSourceNat + querySource := by + rw [hother _ hquerySourceValue] + exact hrestore.querySource + querySourceNat := by + rw [hother _ hquerySourceValue] + exact hrestore.querySourceNat + copyScratch := by + rw [hother _ hcopyScratchValue] + exact hrestore.copyScratch + copyScratchNat := by + rw [hother _ hcopyScratchValue] + exact hrestore.copyScratchNat + parked := hreset.choose_spec.2.2.2 + frame := ?_ } + Β· intro i hi + by_cases hivalue : i = tapes.scan.entry.value + Β· subst i + simp only [entryLookupRestoreHeadBound] + omega + Β· rw [hother i hivalue] + exact hrestore.resetHeadBound i hi + Β· intro i hall + rw [hother i (hall 2)] + exact hrestore.frame i hall + +private theorem destination_zero_of_scanned + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork scannedWork : Fin n β†’ Tape) + (hprepared : EntryLookupPrepared tapes store address initialWork + preparedWork) + (hscanned : EntryLookupScanned tapes store address initialWork + preparedWork scannedWork) : + (scannedWork tapes.destination).HasBinaryNat 0 := by + have hpreparedDestination : preparedWork tapes.destination = + initialWork tapes.destination := + hprepared.frame _ (Ne.symm (tapes.scan_ne_external 7 2)) + rw [hscanned.destination, ← hpreparedDestination] + exact hprepared.destination + +/-- Rewinding the decoded value converts its append-position prefix into a +canonical binary natural without losing any cleanup or frame information. -/ +theorem entryLookupValueRewind_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork preparedWork scannedWork : Fin n β†’ Tape) + (inpβ‚€ outβ‚€ : Tape) + (hprepared : EntryLookupPrepared tapes store address initialWork + preparedWork) + (hscanned : EntryLookupScanned tapes store address initialWork + preparedWork scannedWork) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.rewindWorkTM tapes.scan.entry.value).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = scannedWork ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupValueReady tapes store address initialWork work ∧ + out = outβ‚€) + (entryLookupRestoreHeadBound tapes store address + 2) := by + let P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop := + fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupRestoreInvariant tapes store address initialWork work ∧ + (work tapes.destination).HasBinaryNat 0 ∧ + out = outβ‚€ + have hpreserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' tapes.scan.entry.value).cells = + (work tapes.scan.entry.value).cells β†’ + (work' tapes.scan.entry.value).head = 1 β†’ + (βˆ€ i, i β‰  tapes.scan.entry.value β†’ work' i = work i) β†’ + inp' = inp β†’ out'.cells = out.cells β†’ out'.head = out.head β†’ + P inp' work' out' := by + rintro inp work out inp' work' out' + ⟨hinp, hrestore, hdestination, hout⟩ hcells hhead hother + hinp' houtCells houtHead + have hdestinationValue : tapes.destination β‰  + tapes.scan.entry.value := + Ne.symm (tapes.scan_ne_external 2 2) + refine ⟨hinp'.trans hinp, + restoreInvariant_rewindValue tapes store address initialWork work work' + hrestore hcells hhead hother, ?_, ?_⟩ + Β· rw [hother _ hdestinationValue] + exact hdestination + Β· exact (Tape.ext houtHead houtCells).trans hout + have hrewind := TM.rewindWorkTM_hoareTime_frame + tapes.scan.entry.value + (entryLookupRestoreHeadBound tapes store address) hpreserved + exact hrewind.consequence + (by + rintro inp work out ⟨hinp, hwork, hout⟩ + rw [hinp, hwork, hout] + have hrestore := scanned_restoreInvariant tapes store address initialWork + preparedWork scannedWork hprepared hscanned + refine ⟨hrestore.valueStart, + hrestore.valueContent.cells_ne_start, + hrestore.resetHeadBound _ (reset_value_mem tapes), + hinput.read_ne_start, houtput.read_ne_start, houtput.1, ?_, ?_⟩ + Β· intro i hi + exact ⟨(hrestore.parked i).read_ne_start, + (hrestore.parked i).1⟩ + Β· exact ⟨rfl, hrestore, + destination_zero_of_scanned tapes store address initialWork + preparedWork scannedWork hprepared hscanned, + rfl⟩) + (by + rintro inp work out ⟨hvalueHead, hinp, hrestore, hdestination, hout⟩ + exact ⟨hinp, ⟨hrestore, + ⟨hrestore.valueStart, + hrestore.valueContent.hasBinaryString hvalueHead⟩, + hdestination⟩, hout⟩) + le_rfl + +private theorem reset_destination_not_mem + (tapes : EntryLookupRestoreTapes n) : + tapes.destination βˆ‰ entryLookupResetTargets tapes := by + intro hi + obtain ⟨slot, hslot⟩ := List.mem_ofFn.mp hi + fin_cases slot + Β· change tapes.scan.entry.address = tapes.destination at hslot + exact tapes.scan_ne_external 1 2 hslot + Β· change tapes.scan.entry.value = tapes.destination at hslot + exact tapes.scan_ne_external 2 2 hslot + Β· change tapes.scan.entry.addressCounter = tapes.destination at hslot + exact tapes.scan_ne_external 3 2 hslot + Β· change tapes.scan.entry.addressWidth = tapes.destination at hslot + exact tapes.scan_ne_external 4 2 hslot + Β· change tapes.scan.entry.valueCounter = tapes.destination at hslot + exact tapes.scan_ne_external 5 2 hslot + Β· change tapes.scan.entry.valueWidth = tapes.destination at hslot + exact tapes.scan_ne_external 6 2 hslot + Β· change tapes.scan.entry.result = tapes.destination at hslot + exact tapes.scan_ne_external 8 2 hslot + Β· change tapes.scan.entry.query = tapes.destination at hslot + exact tapes.scan_ne_external 7 2 hslot + Β· change tapes.scan.count = tapes.destination at hslot + exact tapes.scan_ne_external 9 2 hslot + +private theorem restoreInvariant_update_destination + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork work : Fin n β†’ Tape) (destinationTape : Tape) + (hrestore : EntryLookupRestoreInvariant tapes store address initialWork + work) + (hdestinationParked : TM.Parked destinationTape) : + EntryLookupRestoreInvariant tapes store address initialWork + (Function.update work tapes.destination destinationTape) := by + let work' := Function.update work tapes.destination destinationTape + have hsourceDestination : tapes.scan.entry.source β‰  tapes.destination := + tapes.scan_ne_external 0 2 + have hvalueDestination : tapes.scan.entry.value β‰  tapes.destination := + tapes.scan_ne_external 2 2 + have hcountSourceDestination : + tapes.countSource β‰  tapes.destination := + tapes.countSource_ne_destination + have hquerySourceDestination : + tapes.querySource β‰  tapes.destination := + tapes.querySource_ne_destination + have hcopyScratchDestination : + tapes.copyScratch β‰  tapes.destination := + Ne.symm tapes.destination_ne_copyScratch + have hreset : EntryLookupResetReady tapes store address work' := by + rcases hrestore.resetReady with + ⟨bits, hcontent, hstart, hwidth, hparked⟩ + refine ⟨bits, ?_, ?_, hwidth, ?_⟩ + Β· intro i hi + have hne : i β‰  tapes.destination := by + intro heq + exact reset_destination_not_mem tapes (heq β–Έ hi) + simp only [work', Function.update_of_ne hne] + exact hcontent i hi + Β· intro i hi + have hne : i β‰  tapes.destination := by + intro heq + exact reset_destination_not_mem tapes (heq β–Έ hi) + simp only [work', Function.update_of_ne hne] + exact hstart i hi + Β· intro i + by_cases hi : i = tapes.destination + Β· subst i + simpa only [work', Function.update_self] using hdestinationParked + Β· simp only [work', Function.update_of_ne hi] + exact hparked i + refine + { valueContent := by + simpa only [work', Function.update_of_ne hvalueDestination] using + hrestore.valueContent + valueStart := by + simpa only [work', Function.update_of_ne hvalueDestination] using + hrestore.valueStart + resetReady := hreset + sourceCells := by + simpa only [work', Function.update_of_ne hsourceDestination] using + hrestore.sourceCells + sourceStart := by + simpa only [work', Function.update_of_ne hsourceDestination] using + hrestore.sourceStart + sourceHeadBound := by + simpa only [work', Function.update_of_ne hsourceDestination] using + hrestore.sourceHeadBound + resetHeadBound := ?_ + countSource := by + simpa only [work', Function.update_of_ne hcountSourceDestination] using + hrestore.countSource + countSourceNat := by + simpa only [work', Function.update_of_ne hcountSourceDestination] using + hrestore.countSourceNat + querySource := by + simpa only [work', Function.update_of_ne hquerySourceDestination] using + hrestore.querySource + querySourceNat := by + simpa only [work', Function.update_of_ne hquerySourceDestination] using + hrestore.querySourceNat + copyScratch := by + simpa only [work', Function.update_of_ne hcopyScratchDestination] using + hrestore.copyScratch + copyScratchNat := by + simpa only [work', Function.update_of_ne hcopyScratchDestination] using + hrestore.copyScratchNat + parked := hreset.choose_spec.2.2.2 + frame := ?_ } + Β· intro i hi + have hne : i β‰  tapes.destination := by + intro heq + exact reset_destination_not_mem tapes (heq β–Έ hi) + simpa only [work', Function.update_of_ne hne] using + hrestore.resetHeadBound i hi + Β· intro i hall + have hne : i β‰  tapes.destination := hall 12 + change Function.update work tapes.destination destinationTape i = + initialWork i + rw [Function.update_of_ne hne] + exact hrestore.frame i hall + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +/-- Copy the rewound decoded value into the instruction operand tape. The +source value and zero scratch stay canonical, and all restoration data is +preserved. -/ +theorem entryLookupValueCopy_hoareTime_internal + (tapes : EntryLookupRestoreTapes n) (store : Store) (address : β„•) + (initialWork workβ‚€ : Fin n β†’ Tape) (inpβ‚€ outβ‚€ : Tape) + (hready : EntryLookupValueReady tapes store address initialWork workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (TM.binaryCopyIntoTM tapes.scan.entry.value tapes.destination + tapes.copyScratch).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupCopied tapes store address initialWork work ∧ + out = outβ‚€) + (TM.binaryCopyTime (RegisterStore.read store address) 0) := by + let value := RegisterStore.read store address + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame + tapes.scan.entry.value tapes.destination tapes.copyScratch + (tapes.scan_ne_external 2 2) (tapes.scan_ne_external 2 3) + tapes.destination_ne_copyScratch value 0 inpβ‚€ workβ‚€ outβ‚€ + hready.value hready.destination hready.restore.copyScratchNat hinput + (fun i _ _ _ => hready.restore.parked i) houtput + exact hcopy.strengthen_post (by + rintro inp work out ⟨hinp, hwork, hout⟩ + let destinationTape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + let copiedWork := Function.update workβ‚€ tapes.destination destinationTape + have hwork' : work = copiedWork := by + simpa [copiedWork, destinationTape, value] using hwork + clear hwork + subst work + have hdestinationNat : + (copiedWork tapes.destination).HasBinaryNat value := by + rw [show copiedWork tapes.destination = destinationTape by + simp [copiedWork]] + simpa [destinationTape] using + Tape.init_move_right_hasBinaryNat value + have hrestore : EntryLookupRestoreInvariant tapes store address + initialWork copiedWork := by + exact restoreInvariant_update_destination tapes store address initialWork + workβ‚€ destinationTape hready.restore + (hasBinaryNat_parked (by + simpa [destinationTape] using + Tape.init_move_right_hasBinaryNat value)) + have hvalueNat : + (copiedWork tapes.scan.entry.value).HasBinaryNat value := by + have heq : copiedWork tapes.scan.entry.value = + workβ‚€ tapes.scan.entry.value := by + have hne : tapes.scan.entry.value β‰  tapes.destination := + tapes.scan_ne_external 2 2 + change Function.update workβ‚€ tapes.destination destinationTape + tapes.scan.entry.value = workβ‚€ tapes.scan.entry.value + rw [Function.update_of_ne hne] + rw [heq] + simpa [value] using hready.value + exact ⟨hinp, ⟨hrestore, by simpa [value] using hvalueNat, + by simpa [value] using hdestinationNat⟩, hout⟩) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/ResetLayout.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/ResetLayout.lean new file mode 100644 index 0000000000..a8f81504d4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Lookup/ResetLayout.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import Mathlib.Tactic.FinCases + +/-! +# Reusable lookup tape layout and scratch encodings + +The fourteen-tape lookup assignment, fixed reset targets, width bounds, and +found/missing bit encodings used by the reusable lookup controller. +-/ + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Fourteen pairwise-distinct tapes for a reusable sparse operand lookup. +Slots `0..9` are the bounded scanner; the final four slots preserve the entry +count, supply the query, receive the value, and provide zero copy scratch. -/ +structure EntryLookupRestoreTapes (n : β„•) where + /-- Physical work tape assigned to each logical lookup role. -/ + idx : Fin 14 β†’ Fin n + /-- Distinct logical lookup roles occupy distinct physical tapes. -/ + injective : Function.Injective idx + +namespace EntryLookupRestoreTapes + +/-- Bounded scanner view of the reusable lookup assignment. -/ +def scan {n : β„•} (tapes : EntryLookupRestoreTapes n) : EntryScanTapes n where + entry := + { idx := fun i => tapes.idx ⟨i, by omega⟩ + injective := by + intro i j h + apply Fin.ext + simpa using congrArg Fin.val (tapes.injective h) } + count := tapes.idx 9 + count_ne := by + intro i h + have h' : (9 : Fin 14) = ⟨i.val, by omega⟩ := tapes.injective h + have hval := congrArg Fin.val h' + change (9 : β„•) = i.val at hval + omega + +@[simp] theorem scan_entry_idx {n : β„•} (tapes : EntryLookupRestoreTapes n) + (slot : Fin 9) : + tapes.scan.entry.idx slot = tapes.idx ⟨slot.val, by omega⟩ := rfl + +@[simp] theorem scan_count {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.scan.count = tapes.idx 9 := rfl + +/-- Preserved canonical copy of the store cardinality. -/ +def countSource {n : β„•} (tapes : EntryLookupRestoreTapes n) : Fin n := + tapes.idx 10 + +/-- Canonical address supplied to this lookup. -/ +def querySource {n : β„•} (tapes : EntryLookupRestoreTapes n) : Fin n := + tapes.idx 11 + +/-- Canonical destination receiving the looked-up register value. -/ +def destination {n : β„•} (tapes : EntryLookupRestoreTapes n) : Fin n := + tapes.idx 12 + +/-- Preserved zero tape used by width-linear binary copying. -/ +def copyScratch {n : β„•} (tapes : EntryLookupRestoreTapes n) : Fin n := + tapes.idx 13 + +/-- Inequality of logical slots gives inequality of physical tapes. -/ +theorem ne {n : β„•} (tapes : EntryLookupRestoreTapes n) + {i j : Fin 14} (hne : i β‰  j) : tapes.idx i β‰  tapes.idx j := + fun heq => hne (tapes.injective heq) + +/-- Every scanner tape is distinct from an external reusable-lookup role. -/ +theorem scan_ne_external {n : β„•} (tapes : EntryLookupRestoreTapes n) + (slot : Fin 10) (external : Fin 4) : + tapes.idx ⟨slot.val, by omega⟩ β‰  + tapes.idx ⟨external.val + 10, by omega⟩ := by + apply tapes.ne + intro h + have hval := congrArg Fin.val h + change slot.val = external.val + 10 at hval + omega + +theorem countSource_ne_querySource {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.countSource β‰  tapes.querySource := tapes.ne (by decide) + +theorem countSource_ne_destination {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.countSource β‰  tapes.destination := tapes.ne (by decide) + +theorem countSource_ne_copyScratch {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.countSource β‰  tapes.copyScratch := tapes.ne (by decide) + +theorem querySource_ne_destination {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.querySource β‰  tapes.destination := tapes.ne (by decide) + +theorem querySource_ne_copyScratch {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.querySource β‰  tapes.copyScratch := tapes.ne (by decide) + +theorem destination_ne_copyScratch {n : β„•} + (tapes : EntryLookupRestoreTapes n) : + tapes.destination β‰  tapes.copyScratch := tapes.ne (by decide) + +/-- Logical parent slots reset after one lookup. -/ +def resetSlot (slot : Fin 9) : Fin 14 := + match slot.val with + | 0 => 1 + | 1 => 2 + | 2 => 3 + | 3 => 4 + | 4 => 5 + | 5 => 6 + | 6 => 8 + | 7 => 7 + | _ => 9 + +private theorem resetSlot_injective : Function.Injective resetSlot := by + intro i j h + fin_cases i <;> fin_cases j <;> simp [resetSlot] at h ⊒ + +/-- Physical reset target selected by a finite logical slot. -/ +def resetIdx {n : β„•} (tapes : EntryLookupRestoreTapes n) + (slot : Fin 9) : Fin n := tapes.idx (resetSlot slot) + +theorem resetIdx_injective {n : β„•} (tapes : EntryLookupRestoreTapes n) : + Function.Injective tapes.resetIdx := + fun _ _ h => resetSlot_injective (tapes.injective h) + +@[simp] theorem resetIdx_zero {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 0 = tapes.scan.entry.address := rfl + +@[simp] theorem resetIdx_one {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 1 = tapes.scan.entry.value := rfl + +@[simp] theorem resetIdx_two {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 2 = tapes.scan.entry.addressCounter := rfl + +@[simp] theorem resetIdx_three {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 3 = tapes.scan.entry.addressWidth := rfl + +@[simp] theorem resetIdx_four {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 4 = tapes.scan.entry.valueCounter := rfl + +@[simp] theorem resetIdx_five {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 5 = tapes.scan.entry.valueWidth := rfl + +@[simp] theorem resetIdx_six {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 6 = tapes.scan.entry.result := rfl + +@[simp] theorem resetIdx_seven {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 7 = tapes.scan.entry.query := rfl + +@[simp] theorem resetIdx_eight {n : β„•} (tapes : EntryLookupRestoreTapes n) : + tapes.resetIdx 8 = tapes.scan.count := rfl + +end EntryLookupRestoreTapes + +/-- Scanner-owned tapes reset after copying out a lookup result. The encoded +source is deliberately excluded because it is read-only and merely rewound. -/ +def entryLookupResetTargets {n : β„•} (tapes : EntryLookupRestoreTapes n) : + List (Fin n) := + List.ofFn tapes.resetIdx + +/-- Width envelope for every binary scratch value at a successful hit on one +entry. -/ +def entryLookupEntryWidth (entry : Entry) (address : β„•) : β„• := + max address.bits.length + (max entry.1.bits.length + (max entry.2.bits.length + (max (bitlen entry.1) + (max (bitlen entry.2) 1)))) + +/-- Width envelope contributed by possible hit entries in a complete store. -/ +def entryLookupStoreWidth (address : β„•) : Store β†’ β„• + | [] => address.bits.length + | entry :: rest => + max (entryLookupEntryWidth entry address) + (entryLookupStoreWidth address rest) + +/-- Width envelope for every hit or miss reset target in a complete store. -/ +def entryLookupResetWidth (store : Store) (address : β„•) : β„• := + max store.length.bits.length (entryLookupStoreWidth address store) + +/-- Exact reset contents at a successful lookup endpoint. -/ +def entryLookupFoundBits {n : β„•} (tapes : EntryLookupRestoreTapes n) + (entry : Entry) (remaining address : β„•) (i : Fin n) : List Bool := + if i = tapes.scan.entry.query then address.bits + else if i = tapes.scan.count then remaining.bits + else entryMissBits tapes.scan.entry entry address.bits i + +/-- Exact reset contents at an unsuccessful lookup endpoint. -/ +def entryLookupMissBits {n : β„•} (tapes : EntryLookupRestoreTapes n) + (address : β„•) (i : Fin n) : List Bool := + if i = tapes.scan.entry.query then address.bits else [] + +-- These repetitive projection simplifications intentionally share one stable +-- simp set; individual cases use different subsets of it. +@[simp] theorem entryLookupFoundBits_zero {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address + tapes.scan.entry.address = + entry.1.bits := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_one {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address tapes.scan.entry.value = + entry.2.bits := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_two {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address + tapes.scan.entry.addressCounter = + List.replicate (bitlen entry.1) true := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_three {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address + tapes.scan.entry.addressWidth = + [] := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_four {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address + tapes.scan.entry.valueCounter = + List.replicate (bitlen entry.2) true := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_five {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address + tapes.scan.entry.valueWidth = + [] := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_six {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address tapes.scan.entry.result = + [decide (entry.1.bits = address.bits)] := by + simp [entryLookupFoundBits, entryMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.address, + EntryMatchTapes.value, EntryMatchTapes.addressCounter, + EntryMatchTapes.addressWidth, EntryMatchTapes.valueCounter, + EntryMatchTapes.valueWidth, EntryMatchTapes.query, EntryMatchTapes.result, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_seven {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address tapes.scan.entry.query = + address.bits := by + simp [entryLookupFoundBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupFoundBits_eight {n : β„•} + (tapes : EntryLookupRestoreTapes n) (entry : Entry) + (remaining address : β„•) : + entryLookupFoundBits tapes entry remaining address (tapes.idx 9) = + remaining.bits := by + simp [entryLookupFoundBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_seven {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.query = address.bits := by + simp [entryLookupMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_zero {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.address = [] := by + simp [entryLookupMissBits, EntryMatchTapes.address, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_one {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.value = [] := by + simp [entryLookupMissBits, EntryMatchTapes.value, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_two {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.addressCounter = [] := by + simp [entryLookupMissBits, EntryMatchTapes.addressCounter, + EntryMatchTapes.query, tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_three {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.addressWidth = [] := by + simp [entryLookupMissBits, EntryMatchTapes.addressWidth, + EntryMatchTapes.query, tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_four {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.valueCounter = [] := by + simp [entryLookupMissBits, EntryMatchTapes.valueCounter, + EntryMatchTapes.query, tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_five {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.valueWidth = [] := by + simp [entryLookupMissBits, EntryMatchTapes.valueWidth, + EntryMatchTapes.query, tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_six {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address tapes.scan.entry.result = [] := by + simp [entryLookupMissBits, EntryMatchTapes.result, EntryMatchTapes.query, + tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_eight {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) : + entryLookupMissBits tapes address (tapes.idx 9) = [] := by + simp [entryLookupMissBits, EntryMatchTapes.query, tapes.injective.eq_iff] + +@[simp] theorem entryLookupMissBits_other {n : β„•} + (tapes : EntryLookupRestoreTapes n) (address : β„•) (slot : Fin 9) + (hslot : slot β‰  7) : + entryLookupMissBits tapes address (tapes.resetIdx slot) = [] := by + fin_cases slot <;> + simp_all [entryLookupMissBits, EntryLookupRestoreTapes.resetIdx, + EntryLookupRestoreTapes.resetSlot, EntryMatchTapes.query, + tapes.injective.eq_iff] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program.lean new file mode 100644 index 0000000000..d42e1a40ea --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal + +/-! +# Sparse RAM program controller + +The fixed-program halt test copies the canonical sparse-snapshot PC, walks a +finite decrementing selector, restores its scratch, and writes `1` exactly when +the selected instruction is `halt`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +@[simp] theorem instructionHaltOutput_head (instruction : Instr) : + (instructionHaltOutput instruction).head = 1 := + instructionHaltOutput_head_internal instruction + +@[simp] theorem instructionHaltOutput_cells_zero (instruction : Instr) : + (instructionHaltOutput instruction).cells 0 = Ξ“.start := + instructionHaltOutput_cells_zero_internal instruction + +theorem instructionHaltOutput_cells_ne_start (instruction : Instr) : + βˆ€ j, j β‰₯ 1 β†’ (instructionHaltOutput instruction).cells j β‰  Ξ“.start := + instructionHaltOutput_cells_ne_start_internal instruction + +@[simp] theorem instructionHaltOutput_cell_one_eq_one_iff + (instruction : Instr) : + (instructionHaltOutput instruction).cells 1 = Ξ“.one ↔ + instruction = .halt := + instructionHaltOutput_cell_one_eq_one_iff_internal instruction + +@[simp] theorem instructionHaltOutput_eq_blank_of_ne_halt + {instruction : Instr} (h : instruction β‰  .halt) : + instructionHaltOutput instruction = + (Tape.init []).move Dir3.right := + instructionHaltOutput_eq_blank_of_ne_halt_internal h + +/-- The canonical work-tape image of a sparse snapshot satisfies the complete +reusable instruction ABI. -/ +theorem programSnapshotWork_ready {n : β„•} + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + InstructionExecutionReady tapes snapshot.store snapshot.pc + (programSnapshotWork tapes snapshot) := + programSnapshotWork_ready_internal tapes snapshot hcanonical + +@[simp] theorem registerVerdictOutput_cell_one (value : β„•) : + (registerVerdictOutput value).cells 1 = + if value = 0 then Ξ“.zero else Ξ“.one := + registerVerdictOutput_cell_one_internal value + +/-- Final sparse lookup recovers `Rβ‚€` and emits zero exactly for value zero, +or one for any nonzero value. -/ +theorem programOutputTM_hoareTime {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programOutputTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + (programOutputTime tapes store) := + programOutputTM_hoareTime_internal tapes store pcValue initialWork inpβ‚€ + hready hinput + +/-- Final sparse lookup overwrites the loop's halt-test bit with the RAM +verdict, allowing direct controller/extractor composition. -/ +theorem programOutputTM_hoareTime_haltOutput {n : β„•} + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programOutputTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = instructionHaltOutput .halt) + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + (programOutputTime tapes store) := + programOutputTM_hoareTime_haltOutput_internal tapes store pcValue + initialWork inpβ‚€ hready hinput + +/-- The fixed-program test preserves the complete clean instruction ABI and +emits the exact sparse snapshot's halt status. -/ +theorem programHaltTM_hoareTime_frame {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programHaltTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + let snapshot : Snapshot := { pc := pcValue, store := store } + inp = inpβ‚€ ∧ work = initialWork ∧ + out = instructionHaltOutput (snapshot.curInstr program)) + (programHaltTime tapes program pcValue) := by + simpa [Snapshot.curInstr, selectedInstruction_eq_getElem?_getD] using + programHaltTM_hoareTime_frame_internal tapes program store pcValue + initialWork inpβ‚€ hready hinput + +/-- A halted sparse snapshot is stationary under both one pure step and every +fuel-bounded run. -/ +theorem Snapshot.step_eq_self_of_halted (program : Program) + (snapshot : Snapshot) (hhalted : snapshot.Halted program) : + snapshot.step program = snapshot := + snapshot_step_eq_self_of_halted_internal program snapshot hhalted + +/-- Running a halted sparse snapshot for arbitrary additional fuel is a no-op. -/ +theorem Snapshot.run_halted (program : Program) (snapshot : Snapshot) + (hhalted : snapshot.Halted program) (fuel : β„•) : + snapshot.run program fuel = snapshot := + snapshot_run_halted_internal program snapshot hhalted fuel + +/-- If the pure fuel-bounded sparse run is halted, the fixed controller loop +reaches that exact reusable snapshot and exposes its halt verdict. -/ +theorem programLoopTM_hoareTime_run {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (fuel : β„•) (snapshot : Snapshot) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes snapshot.store snapshot.pc + initialWork) + (hinput : TM.Parked inpβ‚€) + (hhalted : (snapshot.run program fuel).Halted program) : + (programLoopTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + let final := snapshot.run program fuel + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes final.store final.pc work ∧ + out = instructionHaltOutput (final.curInstr program)) + (programLoopTime tapes program (fuel + 1) snapshot) := + programLoopTM_hoareTime_run_internal tapes program fuel snapshot + initialWork inpβ‚€ hready hinput hhalted + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds.lean new file mode 100644 index 0000000000..aad51474d4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Internal + +/-! +# Sparse RAM decision-machine resource bounds +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The fixed program magnitude is positive. -/ +theorem programResourceMagnitude_pos (program : Program) : + 1 ≀ programResourceMagnitude program := + programResourceMagnitude_pos_internal program + +/-- The fixed program length is absorbed by its resource magnitude. -/ +theorem program_length_le_resourceMagnitude (program : Program) : + program.length ≀ programResourceMagnitude program := + program_length_le_resourceMagnitude_internal program + +/-- Every fixed program literal width is absorbed by the resource magnitude. -/ +theorem programStaticWidth_le_resourceMagnitude (program : Program) : + programStaticWidth program ≀ programResourceMagnitude program := + programStaticWidth_le_resourceMagnitude_internal program + +/-- The common run scale is positive. -/ +theorem programDecisionScale_pos (program : Program) + (inputLength cost : β„•) : + 1 ≀ programDecisionScale program inputLength cost := + programDecisionScale_pos_internal program inputLength cost + +/-- A fuel-bounded halted RAM run whose fuel is charged by logarithmic time is +simulated by the concrete decision TM within the checked fourth-degree +envelope. -/ +theorem programDecisionTime_le_envelope {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) + (hfuel : fuel ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input)) : + programDecisionTime tapes program input fuel ≀ + programDecisionEnvelope program input.length + (RAM.logTimeUpto program fuel (RAM.initCfg input)) := + programDecisionTime_le_envelope_internal tapes program input fuel + hhalted hfuel + +/-- Increasing the charged RAM-time argument can only increase the concrete +simulation envelope. -/ +theorem programDecisionEnvelope_mono_cost (program : Program) + (inputLength left right : β„•) (hle : left ≀ right) : + programDecisionEnvelope program inputLength left ≀ + programDecisionEnvelope program inputLength right := + programDecisionEnvelope_mono_cost_internal program inputLength left right hle + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Defs.lean new file mode 100644 index 0000000000..2e348fbaec --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Defs.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Sparse RAM decision-machine resource-bound definitions + +The concrete simulator has fixed control once its RAM program is fixed. The +only program-dependent quantities that matter asymptotically are therefore +collected in `programResourceMagnitude`. `programDecisionScale` combines +that constant with the public input length and the charged logarithmic RAM +time. The fourth-power envelope is deliberately coarse: it keeps the public +class-transfer theorem independent of low-level controller constants while +still recording a genuine polynomial simulation. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- A positive magnitude containing every natural literal of one instruction. -/ +def instructionResourceMagnitude : Instr β†’ β„• + | .imm destination value => destination + value + 1 + | .add destination sourceβ‚€ source₁ + | .sub destination sourceβ‚€ source₁ + | .mul destination sourceβ‚€ source₁ => + destination + sourceβ‚€ + source₁ + 1 + | .load destination addressRegister + | .store destination addressRegister => destination + addressRegister + 1 + | .jz source target => source + target + 1 + | .jmp target => target + 1 + | .halt => 1 + +/-- One positive fixed constant containing the program length and every +hardwired register, immediate, and jump literal. -/ +def programResourceMagnitude (program : Program) : β„• := + program.length + (program.map instructionResourceMagnitude).sum + 1 + +/-- Common width/count scale for a run with charged logarithmic time `cost`. -/ +def programDecisionScale (program : Program) (inputLength cost : β„•) : β„• := + inputLength + cost * (programResourceMagnitude program + 2) + + programResourceMagnitude program + 3 + +/-- Coarse checked polynomial envelope for the complete concrete simulation. -/ +def programDecisionEnvelope (program : Program) (inputLength cost : β„•) : β„• := + 1000000000 * programResourceMagnitude program * + (programDecisionScale program inputLength cost + 1) ^ 4 + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Internal.lean new file mode 100644 index 0000000000..03cafd1549 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Bounds/Internal.lean @@ -0,0 +1,2276 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal + +/-! +# Sparse RAM decision-machine resource-bound proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem size_le_self (value : β„•) : value.size ≀ value := by + rw [Nat.size_le] + exact Nat.lt_pow_self (by decide) + +private theorem bitlen_le_succ (value : β„•) : bitlen value ≀ value + 1 := by + unfold bitlen + exact le_trans (size_le_self value) (Nat.le_succ value) + +private theorem instructionStaticWidth_le_resourceMagnitude + (instruction : Instr) : + RegisterStore.Instr.staticWidth instruction ≀ + instructionResourceMagnitude instruction := by + cases instruction with + | imm destination value => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (le_trans (bitlen_le_succ value) (by omega)) + | add destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (max_le (le_trans (bitlen_le_succ sourceβ‚€) (by omega)) + (le_trans (bitlen_le_succ source₁) (by omega))) + | sub destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (max_le (le_trans (bitlen_le_succ sourceβ‚€) (by omega)) + (le_trans (bitlen_le_succ source₁) (by omega))) + | mul destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (max_le (le_trans (bitlen_le_succ sourceβ‚€) (by omega)) + (le_trans (bitlen_le_succ source₁) (by omega))) + | load destination addressRegister => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (le_trans (bitlen_le_succ addressRegister) (by omega)) + | store destination addressRegister => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ destination) (by omega)) + (le_trans (bitlen_le_succ addressRegister) (by omega)) + | jz source target => + simp only [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + exact max_le (le_trans (bitlen_le_succ source) (by omega)) + (le_trans (bitlen_le_succ target) (by omega)) + | jmp target => + exact le_trans (bitlen_le_succ target) (by + simp [instructionResourceMagnitude]) + | halt => simp [RegisterStore.Instr.staticWidth, + instructionResourceMagnitude] + +theorem programResourceMagnitude_pos_internal (program : Program) : + 1 ≀ programResourceMagnitude program := by + simp [programResourceMagnitude] + +theorem program_length_le_resourceMagnitude_internal (program : Program) : + program.length ≀ programResourceMagnitude program := by + unfold programResourceMagnitude + omega + +theorem programStaticWidth_le_resourceMagnitude_internal (program : Program) : + programStaticWidth program ≀ programResourceMagnitude program := by + induction program with + | nil => simp [programStaticWidth, programResourceMagnitude] + | cons instruction rest ih => + have hinstruction := + instructionStaticWidth_le_resourceMagnitude instruction + simp only [programStaticWidth, programResourceMagnitude, + List.length_cons, List.map_cons, List.sum_cons] + apply max_le + Β· omega + Β· unfold programResourceMagnitude at ih + omega + +theorem programDecisionScale_pos_internal (program : Program) + (inputLength cost : β„•) : + 1 ≀ programDecisionScale program inputLength cost := by + simp [programDecisionScale] + +private theorem binarySuccTime_le_width (value width : β„•) + (hvalue : value.size ≀ width) : + TM.binarySuccTime value ≀ 2 * width + 2 := by + exact le_trans (TM.binarySuccTime_le value) (by omega) + +private theorem binaryPredTime_le_width (value width : β„•) + (hvalue : (value + 1).size ≀ width) : + TM.binaryPredTime value ≀ 2 * width + 2 := by + exact le_trans (TM.binaryPredTime_le value) (by omega) + +private theorem binaryCopyTime_le_width (srcValue dstValue width : β„•) + (hsrc : srcValue.size ≀ width) (hdst : dstValue.size ≀ width) : + TM.binaryCopyTime srcValue dstValue ≀ 5 * width + 20 := by + exact le_trans (TM.binaryCopyTime_le srcValue dstValue) (by omega) + +private theorem binaryAddConstTime_zero_le (fixedValue : β„•) : + TM.binaryAddConstTime fixedValue 0 ≀ 4 * (fixedValue + 1) ^ 2 := + TM.binaryAddConstTime_zero_le fixedValue + +private theorem binaryAddConstTime_zero_le_width (fixedValue width : β„•) + (hconstant : fixedValue ≀ width) : + TM.binaryAddConstTime fixedValue 0 ≀ 5 * (width + 1) ^ 2 := by + have htime := binaryAddConstTime_zero_le fixedValue + nlinarith [Nat.mul_le_mul (Nat.add_le_add_right hconstant 1) + (Nat.add_le_add_right hconstant 1)] + +private theorem forWorkOnesLoopTime_succ_le + (limit value count : β„•) (hsum : value + count ≀ limit) : + TM.forWorkOnesLoopTime TM.binarySuccTime value count ≀ + 1 + count * (2 * limit + 4) := by + induction count generalizing value with + | zero => simp [TM.forWorkOnesLoopTime] + | succ count ih => + rw [TM.forWorkOnesLoopTime] + have hvalue : value ≀ limit := by omega + have hsize : value.size ≀ limit := + le_trans (size_le_self value) hvalue + have hsucc := binarySuccTime_le_width value limit hsize + have htail := ih (value + 1) (by omega) + rw [Nat.succ_mul] + omega + +private theorem wordWidthTime_le (width : β„•) : + wordWidthTime width ≀ 4 * (width + 1) ^ 2 := by + have hloop := forWorkOnesLoopTime_succ_le width 0 width (by omega) + unfold wordWidthTime + nlinarith + +private theorem binaryForLoopTime_one_le + (limit value count : β„•) (hsum : value + count ≀ limit) : + TM.binaryForLoopTime (fun _ => 1) limit value count ≀ + (count + 1) * (4 * limit + 8) := by + induction count generalizing value with + | zero => + simp only [TM.binaryForLoopTime, TM.binaryForCompareTime] + have hsize := size_le_self limit + omega + | succ count ih => + rw [TM.binaryForLoopTime] + have hvalue : value ≀ limit := by omega + have hsize : value.size ≀ limit := + le_trans (size_le_self value) hvalue + have hsucc := binarySuccTime_le_width value limit hsize + have hlimitSize := size_le_self limit + have htail := ih (value + 1) (by omega) + simp only [TM.binaryForCompareTime, TM.binaryForIterationTime] + nlinarith + +private theorem wordPayloadTime_le (width : β„•) : + wordPayloadTime width ≀ 8 * (width + 1) ^ 2 := by + have hloop := binaryForLoopTime_one_le width 0 width (by omega) + unfold wordPayloadTime + nlinarith + +private theorem wordDecodeTime_le (width bound : β„•) + (hwidth : width ≀ bound) : + wordDecodeTime width ≀ 20 * (bound + 1) ^ 2 := by + have hprefix := wordWidthTime_le width + have hpayload := wordPayloadTime_le width + unfold wordDecodeTime + nlinarith [Nat.mul_le_mul hwidth hwidth] + +private theorem entryMatchReadTime_le (entry : Entry) + (queryBits : List Bool) (bound : β„•) + (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryMatchReadTime entry queryBits ≀ 100 * (bound + 1) ^ 2 := by + have hlinear := entryMatchReadTime_le_linear entry queryBits + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + +private theorem entryMissBits_length_le {m : β„•} + (tapes : EntryMatchTapes m) (entry : Entry) + (queryBits : List Bool) (bound : β„•) + (hbound : 1 ≀ bound) + (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) (i : Fin m) : + (entryMissBits tapes entry queryBits i).length ≀ bound := by + have haddressWidth : bitlen entry.1 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! haddress + have hvalueWidth : bitlen entry.2 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hvalue + unfold entryMissBits + split_ifs <;> + (try simp only [List.length_nil, List.length_replicate, + List.length_singleton]) <;> omega + +private theorem entryMissCleanupTime_canonical_le {m : β„•} + (tapes : EntryMatchTapes m) (entry : Entry) + (queryBits : List Bool) (bound : β„•) + (hbound : 1 ≀ bound) + (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryMissCleanupTime tapes entry queryBits + (entryScanCanonicalWork (n := m)) ≀ + 1000 * (bound + 1) ^ 2 := by + let matchTime := entryMatchReadTime entry queryBits + have hmatch : matchTime ≀ 100 * (bound + 1) ^ 2 := + entryMatchReadTime_le entry queryBits bound haddress hvalue hquery + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes) (entryMissBits tapes entry queryBits) + (entryMissHeadBound entry queryBits (entryScanCanonicalWork (n := m))) + (1 + matchTime) bound + (fun i _ => by + unfold entryMissHeadBound entryScanCanonicalWork + simp only [Function.const_apply] + dsimp only [matchTime] + simp [TM.resetBinaryBlank, Tape.move, Tape.init]) + (fun i _ => entryMissBits_length_le tapes entry queryBits bound hbound + haddress hvalue i) + have htargets : (entryMissTargets tapes).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + dsimp only [matchTime] at hmatch hreset + have hreset' : + TM.resetBinaryWorkManyTime (entryMissBits tapes entry queryBits) + (fun _ => 1 + entryMatchReadTime entry queryBits) + (entryMissTargets tapes) ≀ + 7 * (1 + entryMatchReadTime entry queryBits + 2 * bound + 9) + 1 := by + simpa [entryMissHeadBound, entryScanCanonicalWork, + TM.resetBinaryBlank, Tape.move, Tape.init] using! hreset + unfold entryMissCleanupTime entryMissHeadBound entryScanCanonicalWork + simp only [Function.const_apply] + simp only [TM.resetBinaryBlank, Tape.move, Tape.init] + simp only [Nat.zero_add] + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + +private theorem entryScanOneTime_le {m : β„•} + (tapes : EntryScanTapes m) (entry : Entry) + (queryBits : List Bool) (bound : β„•) + (hbound : 1 ≀ bound) + (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryScanOneTime tapes entry queryBits ≀ + 1200 * (bound + 1) ^ 2 := by + have hmatch := entryMatchReadTime_le entry queryBits bound + haddress hvalue hquery + have hcleanup := entryMissCleanupTime_canonical_le tapes.entry entry + queryBits bound hbound haddress hvalue hquery + unfold entryScanOneTime entryScanStepTime entryScanBranchTime + TM.branchWorkSymbolTime + have hbranch : 1 + max 1 + (entryMissCleanupTime tapes.entry entry queryBits + (entryScanCanonicalWork (n := m))) ≀ + 1 + 1000 * (bound + 1) ^ 2 := by + apply Nat.add_le_add_left + apply max_le + Β· have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + Β· exact hcleanup + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + +private theorem entryScanTime_le {m : β„•} (tapes : EntryScanTapes m) + (queryBits : List Bool) (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryScanTime tapes queryBits store ≀ + 1300 * (store.length + 1) * (bound + 1) ^ 2 := by + induction store with + | nil => + simp [entryScanTime] + nlinarith + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrestEntries : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + have hrestLength : rest.length ≀ bound := by + simp only [List.length_cons] at hstoreLength + omega + have hone := entryScanOneTime_le tapes entry queryBits bound hbound + hentry.1 hentry.2 hquery + have hpred := TM.binaryPredTime_le rest.length + have hpredSize : (rest.length + 1).size ≀ bound := by + exact le_trans (size_le_self (rest.length + 1)) (by simp_all) + have hpred' : TM.binaryPredTime rest.length ≀ 2 * bound + 2 := + le_trans hpred (by omega) + have htail := ih hrestLength hrestEntries + simp only [entryScanTime, List.length_cons] + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + nlinarith + +private theorem entryScanTime_le_cube {m : β„•} + (tapes : EntryScanTapes m) (queryBits : List Bool) + (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryScanTime tapes queryBits store ≀ 1300 * (bound + 1) ^ 3 := by + have htime := entryScanTime_le tapes queryBits store bound hbound + hstoreLength hentries hquery + have hfactor : store.length + 1 ≀ bound + 1 := by omega + calc + entryScanTime tapes queryBits store ≀ + 1300 * (store.length + 1) * (bound + 1) ^ 2 := htime + _ ≀ 1300 * (bound + 1) * (bound + 1) ^ 2 := by + exact Nat.mul_le_mul_right _ (Nat.mul_le_mul_left 1300 hfactor) + _ = 1300 * (bound + 1) ^ 3 := by ring + +private theorem encodedStoreLength_le_uniform (store : Store) (bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + encodedStoreLength store ≀ store.length * (4 * bound + 2) := by + induction store with + | nil => simp [encodedStoreLength] + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + have htail := ih hrest + have hhead : (Entry.encode entry).length ≀ 4 * bound + 2 := by + rw [Entry.encode_length] + have haddressWidth : bitlen entry.1 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hentry.1 + have hvalueWidth : bitlen entry.2 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hentry.2 + omega + unfold encodedStoreLength at htail ⊒ + simp only [List.flatMap_cons, List.length_append, List.length_cons, + Nat.succ_mul] + ring_nf at htail ⊒ + omega + +private theorem entryScanTime_le_square {m : β„•} + (tapes : EntryScanTapes m) (queryBits : List Bool) + (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hquery : queryBits.length ≀ bound) : + entryScanTime tapes queryBits store ≀ 7000 * (bound + 1) ^ 2 := by + have hscan := entryScanTime_le_encoded tapes queryBits store + have hencoded := encodedStoreLength_le_uniform store bound hentries + have hcount : bitlen store.length ≀ bound := by + unfold bitlen + exact le_trans (size_le_self store.length) hstoreLength + have hfactor : queryBits.length + bitlen store.length + 2 ≀ + 2 * bound + 2 := by omega + have hencoded' : encodedStoreLength store ≀ + bound * (4 * bound + 2) := + le_trans hencoded (Nat.mul_le_mul_right _ hstoreLength) + have hqueryTerm : store.length * + (queryBits.length + bitlen store.length + 2) ≀ + bound * (2 * bound + 2) := + Nat.mul_le_mul hstoreLength hfactor + have hinside : encodedStoreLength store + + store.length * (queryBits.length + bitlen store.length + 2) + 1 ≀ + 7 * (bound + 1) ^ 2 := by + nlinarith + exact le_trans hscan (by + calc + 1000 * (encodedStoreLength store + + store.length * + (queryBits.length + bitlen store.length + 2) + 1) + ≀ 1000 * (7 * (bound + 1) ^ 2) := + Nat.mul_le_mul_left 1000 hinside + _ = 7000 * (bound + 1) ^ 2 := by ring) + +private theorem read_bits_length_le (store : Store) (address bound : β„•) + (hentries : βˆ€ entry ∈ store, entry.2.bits.length ≀ bound) : + (RegisterStore.read store address).bits.length ≀ bound := by + induction store with + | nil => simp [RegisterStore.read] + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + simp only [RegisterStore.read] + split + Β· exact hentry + Β· exact ih hrest + +private theorem entryLookupEntryWidth_le (entry : Entry) + (address bound : β„•) (hbound : 1 ≀ bound) + (haddress : address.bits.length ≀ bound) + (hentryAddress : entry.1.bits.length ≀ bound) + (hentryValue : entry.2.bits.length ≀ bound) : + entryLookupEntryWidth entry address ≀ bound := by + have haddressWidth : bitlen entry.1 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hentryAddress + have hvalueWidth : bitlen entry.2 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hentryValue + unfold entryLookupEntryWidth + omega + +private theorem entryLookupStoreWidth_le (store : Store) + (address bound : β„•) (hbound : 1 ≀ bound) + (haddress : address.bits.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + entryLookupStoreWidth address store ≀ bound := by + induction store with + | nil => simpa [entryLookupStoreWidth] using! haddress + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + simp only [entryLookupStoreWidth] + exact max_le + (entryLookupEntryWidth_le entry address bound hbound haddress + hentry.1 hentry.2) + (ih hrest) + +private theorem entryLookupResetWidth_le (store : Store) + (address bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (haddress : address.bits.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + entryLookupResetWidth store address ≀ bound := by + have hlengthBits : store.length.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len store.length] + exact le_trans (size_le_self store.length) hstoreLength + unfold entryLookupResetWidth + exact max_le hlengthBits + (entryLookupStoreWidth_le store address bound hbound haddress hentries) + +private theorem entryLookupLoadedTime_le {m : β„•} + (tapes : EntryLookupRestoreTapes m) (store : Store) + (address bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (haddress : address.bits.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + entryLookupLoadedTime tapes store address ≀ + 20000 * (bound + 1) ^ 3 := by + have hscan := entryScanTime_le_cube tapes.scan address.bits store bound + hbound hstoreLength hentries haddress + have hlookup : entryLookupTime tapes.scan address store ≀ + 1300 * (bound + 1) ^ 3 := hscan + have hwidth := entryLookupResetWidth_le store address bound hbound + hstoreLength haddress hentries + have hread := read_bits_length_le store address bound + (fun entry hentry => (hentries entry hentry).2) + have hcopyAddress := binaryCopyTime_le_width address 0 bound + (by simpa [Nat.size_eq_bits_len] using! haddress) (by simp) + have hcopyRead := binaryCopyTime_le_width + (RegisterStore.read store address) 0 bound + (by simpa [Nat.size_eq_bits_len] using! hread) (by simp) + have hcopyCount := binaryCopyTime_le_width store.length 0 bound + (le_trans (size_le_self store.length) hstoreLength) (by simp) + unfold entryLookupLoadedTime entryLookupCopyRestoreTime + entryLookupRestoreTailTime entryLookupResetTime + entryLookupRestoreHeadBound + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + omega + +private theorem entryLookupStaticTime_le {m : β„•} + (tapes : EntryLookupRestoreTapes m) (store : Store) + (address bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (haddressValue : address ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + entryLookupStaticTime tapes store address ≀ + 21000 * (bound + 1) ^ 3 := by + have haddress : address.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len address] + exact le_trans (size_le_self address) haddressValue + have hloaded := entryLookupLoadedTime_le tapes store address bound hbound + hstoreLength haddress hentries + have hadd := binaryAddConstTime_zero_le_width address bound haddressValue + unfold entryLookupStaticTime + have hreset : TM.resetBinaryWorkTime 1 address.bits.length ≀ + 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + omega + +private theorem rewindEntryEncodeTime_le (entry : Entry) + (addressHead valueHead bound : β„•) + (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) + (haddressHead : addressHead ≀ bound) + (hvalueHead : valueHead ≀ bound) : + rewindEntryEncodeTime entry addressHead valueHead ≀ 10 * bound + 21 := by + unfold rewindEntryEncodeTime rewindWordEncodeTime wordEncodeTime + omega + +private theorem entryUpdatePostEmitHead_le {m : β„•} + (tapes : EntryUpdateTapes m) (entry : Entry) (i : Fin m) + (bound : β„•) (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) : + entryUpdatePostEmitHead tapes entry i ≀ bound + 1 := by + have haddressWidth : bitlen entry.1 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! haddress + have hvalueWidth : bitlen entry.2 ≀ bound := by + simpa only [bitlen, Nat.size_eq_bits_len] using! hvalue + unfold entryUpdatePostEmitHead + split_ifs <;> omega + +private theorem entryUpdateReadyCleanupTime_le {m : β„•} + (tapes : EntryUpdateTapes m) (entry : Entry) (address bound : β„•) + (hbound : 1 ≀ bound) + (hentryAddress : entry.1.bits.length ≀ bound) + (hentryValue : entry.2.bits.length ≀ bound) + (haddress : address.bits.length ≀ bound) : + entryUpdateReadyCleanupTime tapes entry address ≀ + 1000 * (bound + 1) ^ 2 := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ 100 * (bound + 1) ^ 2 := + entryMatchReadTime_le entry address.bits bound hentryAddress hentryValue + haddress + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes.entry) (entryMissBits tapes.entry entry address.bits) + (fun _ => 1 + matchTime) (1 + matchTime) bound + (fun _ _ => le_rfl) + (fun i _ => entryMissBits_length_le tapes.entry entry address.bits bound + hbound hentryAddress hentryValue i) + have htargets : (entryMissTargets tapes.entry).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + unfold entryUpdateReadyCleanupTime + dsimp only [matchTime] at hmatch hreset ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + +private theorem entryUpdatePostEmitCleanupTime_le {m : β„•} + (tapes : EntryUpdateTapes m) (entry : Entry) (address bound : β„•) + (hbound : 1 ≀ bound) + (hentryAddress : entry.1.bits.length ≀ bound) + (hentryValue : entry.2.bits.length ≀ bound) + (haddress : address.bits.length ≀ bound) : + entryUpdatePostEmitCleanupTime tapes entry address ≀ + 2000 * (bound + 1) ^ 2 := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ 100 * (bound + 1) ^ 2 := + entryMatchReadTime_le entry address.bits bound hentryAddress hentryValue + haddress + have hreset := TM.resetBinaryWorkManyTime_le + (entryMissTargets tapes.entry) (entryMissBits tapes.entry entry address.bits) + (fun i => entryUpdatePostEmitHead tapes entry i + matchTime) + (bound + 1 + matchTime) bound + (fun i _ => Nat.add_le_add_right + (entryUpdatePostEmitHead_le tapes entry i bound hentryAddress hentryValue) + matchTime) + (fun i _ => entryMissBits_length_le tapes.entry entry address.bits bound + hbound hentryAddress hentryValue i) + have htargets : (entryMissTargets tapes.entry).length = 7 := by + simp [entryMissTargets] + rw [htargets] at hreset + unfold entryUpdatePostEmitCleanupTime + dsimp only [matchTime] at hmatch hreset ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + +private theorem entryUpdateBranchTime_le {m : β„•} + (tapes : EntryUpdateTapes m) (entry : Entry) + (address newValue total bound : β„•) (hbound : 1 ≀ bound) + (hentryAddress : entry.1.bits.length ≀ bound) + (hentryValue : entry.2.bits.length ≀ bound) + (haddress : address.bits.length ≀ bound) + (hnewValue : newValue.bits.length ≀ bound) + (htotal : total ≀ bound) : + entryUpdateBranchTime tapes entry address newValue total ≀ + 4000 * (bound + 1) ^ 2 := by + let matchTime := entryMatchReadTime entry address.bits + have hmatch : matchTime ≀ 100 * (bound + 1) ^ 2 := + entryMatchReadTime_le entry address.bits bound hentryAddress hentryValue + haddress + have hpost := entryUpdatePostEmitCleanupTime_le tapes entry address bound + hbound hentryAddress hentryValue haddress + have hready := entryUpdateReadyCleanupTime_le tapes entry address bound + hbound hentryAddress hentryValue haddress + have hrewindMiss := rewindEntryEncodeTime_le entry (1 + matchTime) + (1 + matchTime) (1 + 100 * (bound + 1) ^ 2) + (le_trans hentryAddress (by nlinarith)) + (le_trans hentryValue (by nlinarith)) (by omega) (by omega) + have hrewindReplace := rewindEntryEncodeTime_le (entry.1, newValue) + (1 + matchTime) 1 (1 + 100 * (bound + 1) ^ 2) + (le_trans hentryAddress (by nlinarith)) + (le_trans hnewValue (by nlinarith)) (by omega) (by omega) + have hcount : entryUpdateCountTime total ≀ 2 * bound + 2 := by + unfold entryUpdateCountTime + exact Nat.add_le_add_right + (Nat.mul_le_mul_left 2 (le_trans (size_le_self total) htotal)) 2 + unfold entryUpdateBranchTime entryUpdateMissTime entryUpdateReplaceTime + dsimp only [matchTime] at hmatch hpost hready hrewindMiss hrewindReplace ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + apply max_le + Β· omega + Β· apply max_le <;> omega + +private theorem entryUpdateTime_le {m : β„•} (tapes : EntryUpdateTapes m) + (store : Store) (address newValue bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (haddress : address.bits.length ≀ bound) + (hnewValue : newValue.bits.length ≀ bound) : + entryUpdateTime tapes store address newValue ≀ + 5000 * (bound + 1) ^ 3 := by + have hloop : βˆ€ remaining : Store, remaining.length ≀ bound β†’ + (βˆ€ entry ∈ remaining, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) β†’ + entryUpdateLoopTime tapes address newValue store.length remaining ≀ + 5000 * (remaining.length + 1) * (bound + 1) ^ 2 := by + intro remaining + induction remaining with + | nil => + intro _ _ + have hrewind := rewindEntryEncodeTime_le (address, newValue) 1 1 + bound haddress hnewValue hbound hbound + have hcount : entryUpdateCountTime store.length ≀ 2 * bound + 2 := by + unfold entryUpdateCountTime + exact Nat.add_le_add_right + (Nat.mul_le_mul_left 2 + (le_trans (size_le_self store.length) hstoreLength)) 2 + unfold entryUpdateLoopTime entryAppendRestoreTime + simp only [List.length_nil, Nat.zero_add, Nat.mul_one] + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + omega + | cons entry rest ih => + intro hremainingLength hremainingEntries + have hentry := hremainingEntries entry (by simp) + have hrestEntries : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hremainingEntries current (by simp [hcurrent]) + have hrestLength : rest.length ≀ bound := by + simp only [List.length_cons] at hremainingLength + omega + have hmatch := entryMatchReadTime_le entry address.bits bound + hentry.1 hentry.2 haddress + have hbranch := entryUpdateBranchTime_le tapes entry address newValue + store.length bound hbound hentry.1 hentry.2 haddress hnewValue + hstoreLength + have hpred := TM.binaryPredTime_le rest.length + have hpredSize : (rest.length + 1).size ≀ bound := + le_trans (size_le_self (rest.length + 1)) (by + simp only [List.length_cons] at hremainingLength + omega) + have hpred' : TM.binaryPredTime rest.length ≀ 2 * bound + 2 := + le_trans hpred (by omega) + have htail := ih hrestLength hrestEntries + unfold entryUpdateLoopTime entryUpdateIterationTime + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + simp only [List.length_cons] + nlinarith + unfold entryUpdateTime + have htime := hloop store hstoreLength hentries + have hfactor : store.length + 1 ≀ bound + 1 := by omega + calc + entryUpdateLoopTime tapes address newValue store.length store ≀ + 5000 * (store.length + 1) * (bound + 1) ^ 2 := htime + _ ≀ 5000 * (bound + 1) * (bound + 1) ^ 2 := by + exact Nat.mul_le_mul_right _ (Nat.mul_le_mul_left 5000 hfactor) + _ = 5000 * (bound + 1) ^ 3 := by ring + +private theorem entriesEncode_length_le (store : Store) (bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + (store.flatMap Entry.encode).length ≀ store.length * (4 * bound + 2) := by + induction store with + | nil => simp + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + have htail := ih hrest + have hhead : (Entry.encode entry).length ≀ 4 * bound + 2 := by + rw [Entry.encode_length] + simpa [bitlen, Nat.size_eq_bits_len] using! + (show 2 * entry.1.bits.length + 2 * entry.2.bits.length + 2 ≀ + 4 * bound + 2 by omega) + simp only [List.flatMap_cons, List.length_append, List.length_cons] + rw [Nat.succ_mul] + omega + +private theorem binaryInstructionArithmeticTime_le + (op : BinaryInstrOp) (lhs rhs bound : β„•) + (hlhs : lhs.bits.length ≀ bound) + (hrhs : rhs.bits.length ≀ bound) : + binaryInstructionArithmeticTime op lhs rhs ≀ + 1000 * (bound + 1) ^ 2 := by + have hlhsSize : lhs.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hlhs + have hrhsSize : rhs.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hrhs + cases op with + | add => + have htime := TM.binaryRippleAddTime_le lhs rhs + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + change TM.binaryRippleAddTime lhs rhs ≀ 1000 * (bound + 1) ^ 2 + omega + | sub => + have htime := TM.binaryRippleSubTime_le lhs rhs + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + change TM.binaryRippleSubTime lhs rhs ≀ 1000 * (bound + 1) ^ 2 + omega + | mul => + change TM.binaryShiftMulTime lhs rhs ≀ 1000 * (bound + 1) ^ 2 + unfold TM.binaryShiftMulTime TM.binaryShiftMulWidth + nlinarith + +private theorem binaryInstrResult_bits_length_le + (op : BinaryInstrOp) (lhs rhs bound : β„•) + (hlhs : lhs.bits.length ≀ bound) + (hrhs : rhs.bits.length ≀ bound) : + (op.eval lhs rhs).bits.length ≀ 2 * bound + 1 := by + have hlhsSize : lhs.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hlhs + have hrhsSize : rhs.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hrhs + rw [Nat.size_eq_bits_len (op.eval lhs rhs)] + cases op with + | add => + exact le_trans (TM.binaryRippleAdd_sum_size_le lhs rhs) (by omega) + | sub => + exact le_trans (Nat.size_le_size (Nat.sub_le lhs rhs)) (by omega) + | mul => + exact le_trans (BinaryShiftMul.size_mul_le_add lhs rhs) (by omega) + +private theorem directBinaryInstructionTime_le {m : β„•} + (tapes : BinaryInstructionTapes m) (op : BinaryInstrOp) + (store : Store) (destination sourceβ‚€ source₁ bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hdestination : destination ≀ bound) + (hsourceβ‚€ : sourceβ‚€ ≀ bound) (hsource₁ : source₁ ≀ bound) : + directBinaryInstructionTime tapes op store destination sourceβ‚€ source₁ ≀ + 100000 * (bound + 1) ^ 3 := by + let lhs := RegisterStore.read store sourceβ‚€ + let rhs := RegisterStore.read store source₁ + have hlhs : lhs.bits.length ≀ bound := read_bits_length_le store sourceβ‚€ bound + (fun entry hentry => (hentries entry hentry).2) + have hrhs : rhs.bits.length ≀ bound := read_bits_length_le store source₁ bound + (fun entry hentry => (hentries entry hentry).2) + have hlookupβ‚€ := entryLookupStaticTime_le tapes.lhsLookup store sourceβ‚€ + bound hbound hstoreLength hsourceβ‚€ hentries + have hlookup₁ := entryLookupStaticTime_le tapes.rhsLookup store source₁ + bound hbound hstoreLength hsource₁ hentries + have hadd := binaryAddConstTime_zero_le_width destination bound hdestination + have harithmetic := binaryInstructionArithmeticTime_le op lhs rhs bound hlhs hrhs + let wide := 2 * bound + 1 + have hwide : 1 ≀ wide := by omega + have hresult : (op.eval lhs rhs).bits.length ≀ wide := + binaryInstrResult_bits_length_le op lhs rhs bound hlhs hrhs + have hdestinationBitsWide : destination.bits.length ≀ wide := by + rw [Nat.size_eq_bits_len destination] + exact le_trans (size_le_self destination) (by omega) + have hupdate := entryUpdateTime_le tapes.update store destination + (op.eval lhs rhs) wide hwide (by omega) + (fun entry hentry => ⟨le_trans (hentries entry hentry).1 (by omega), + le_trans (hentries entry hentry).2 (by omega)⟩) + hdestinationBitsWide hresult + have hwideCube : (wide + 1) ^ 3 = 8 * (bound + 1) ^ 3 := by + simp only [wide] + ring + rw [hwideCube] at hupdate + dsimp only [lhs, rhs] at hlhs hrhs harithmetic hupdate ⊒ + unfold directBinaryInstructionTime binaryInstructionUpdateTime + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + omega + +private theorem immediateInstructionTime_le {m : β„•} + (tapes : BinaryInstructionTapes m) (store : Store) + (destination value bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hdestination : destination ≀ bound) (hvalue : value ≀ bound) : + immediateInstructionTime tapes store destination value ≀ + 30000 * (bound + 1) ^ 3 := by + have hvalueBits : value.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len value] + exact le_trans (size_le_self value) hvalue + have hdestinationBits : destination.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len destination] + exact le_trans (size_le_self destination) hdestination + have hupdate := entryUpdateTime_le tapes.update store destination value bound + hbound hstoreLength hentries hdestinationBits hvalueBits + have hvalueAdd := binaryAddConstTime_zero_le_width value bound hvalue + have hdestinationAdd := binaryAddConstTime_zero_le_width destination bound + hdestination + unfold immediateInstructionTime + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + omega + +private theorem indirectLoadInstructionTime_le {m : β„•} + (tapes : BinaryInstructionTapes m) (store : Store) + (destination addressRegister bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hdestination : destination ≀ bound) + (haddressRegister : addressRegister ≀ bound) : + indirectLoadInstructionTime tapes store destination addressRegister ≀ + 80000 * (bound + 1) ^ 3 := by + let address := RegisterStore.read store addressRegister + let value := RegisterStore.read store address + have haddress : address.bits.length ≀ bound := read_bits_length_le store + addressRegister bound (fun entry hentry => (hentries entry hentry).2) + have hvalue : value.bits.length ≀ bound := read_bits_length_le store address + bound (fun entry hentry => (hentries entry hentry).2) + have hlookup := entryLookupStaticTime_le tapes.lhsLookup store addressRegister + bound hbound hstoreLength haddressRegister hentries + have hloaded := entryLookupLoadedTime_le tapes.indirectLoadLookup store address + bound hbound hstoreLength haddress hentries + have hadd := binaryAddConstTime_zero_le_width destination bound hdestination + have hdestinationBits : destination.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len destination] + exact le_trans (size_le_self destination) hdestination + have hupdate := entryUpdateTime_le tapes.update store destination value bound + hbound hstoreLength hentries hdestinationBits hvalue + dsimp only [address, value] at hloaded hupdate ⊒ + unfold indirectLoadInstructionTime + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + omega + +private theorem indirectStoreInstructionTime_le {m : β„•} + (tapes : BinaryInstructionTapes m) (store : Store) + (addressRegister source bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (haddressRegister : addressRegister ≀ bound) (hsource : source ≀ bound) : + indirectStoreInstructionTime tapes store addressRegister source ≀ + 80000 * (bound + 1) ^ 3 := by + let address := RegisterStore.read store addressRegister + let value := RegisterStore.read store source + have haddress : address.bits.length ≀ bound := read_bits_length_le store + addressRegister bound (fun entry hentry => (hentries entry hentry).2) + have hvalue : value.bits.length ≀ bound := read_bits_length_le store source + bound (fun entry hentry => (hentries entry hentry).2) + have hlookupAddress := entryLookupStaticTime_le tapes.lhsLookup store + addressRegister bound hbound hstoreLength haddressRegister hentries + have hlookupValue := entryLookupStaticTime_le tapes.rhsLookup store source + bound hbound hstoreLength hsource hentries + have hcopyAddress := binaryCopyTime_le_width address 0 bound + (by simpa [Nat.size_eq_bits_len] using! haddress) (by simp) + have hcopyValue := binaryCopyTime_le_width value 0 bound + (by simpa [Nat.size_eq_bits_len] using! hvalue) (by simp) + have hupdate := entryUpdateTime_le tapes.update store address value bound + hbound hstoreLength hentries haddress hvalue + dsimp only [address, value] at hcopyAddress hcopyValue hupdate ⊒ + unfold indirectStoreInstructionTime + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + omega + +private theorem executeInstructionTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (instruction : Instr) + (pcValue : β„•) (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) + (hinstruction : instructionResourceMagnitude instruction ≀ bound) : + executeInstructionTime tapes instruction pcValue store ≀ + 200000 * (bound + 1) ^ 3 := by + have hpcSucc : TM.binarySuccTime pcValue ≀ 2 * bound + 2 := + binarySuccTime_le_width pcValue bound (by + simpa [Nat.size_eq_bits_len] using! hpc) + have hencoded := entriesEncode_length_le store bound hentries + have hencodedCube : (store.flatMap Entry.encode).length ≀ + 6 * (bound + 1) ^ 3 := by + have hproduct := Nat.mul_le_mul hstoreLength (show 4 * bound + 2 ≀ + 6 * (bound + 1) by omega) + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + calc + (store.flatMap Entry.encode).length ≀ store.length * (4 * bound + 2) := + hencoded + _ ≀ bound * (6 * (bound + 1)) := hproduct + _ ≀ 6 * (bound + 1) ^ 2 := by nlinarith + _ ≀ 6 * (bound + 1) ^ 3 := Nat.mul_le_mul_left 6 hsqCube + have hresetPC : TM.resetBinaryWorkTime 1 pcValue.bits.length ≀ + 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + cases instruction with + | imm destination value => + simp only [instructionResourceMagnitude] at hinstruction + have htime := immediateInstructionTime_le tapes.data store destination value + bound hbound hstoreLength hentries (by omega) (by omega) + simp only [executeInstructionTime] + omega + | add destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have htime := directBinaryInstructionTime_le tapes.data .add store + destination sourceβ‚€ source₁ bound hbound hstoreLength hentries + (by omega) (by omega) (by omega) + simp only [executeInstructionTime] + omega + | sub destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have htime := directBinaryInstructionTime_le tapes.data .sub store + destination sourceβ‚€ source₁ bound hbound hstoreLength hentries + (by omega) (by omega) (by omega) + simp only [executeInstructionTime] + omega + | mul destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have htime := directBinaryInstructionTime_le tapes.data .mul store + destination sourceβ‚€ source₁ bound hbound hstoreLength hentries + (by omega) (by omega) (by omega) + simp only [executeInstructionTime] + omega + | load destination addressRegister => + simp only [instructionResourceMagnitude] at hinstruction + have htime := indirectLoadInstructionTime_le tapes.data store destination + addressRegister bound hbound hstoreLength hentries (by omega) (by omega) + simp only [executeInstructionTime] + omega + | store addressRegister source => + simp only [instructionResourceMagnitude] at hinstruction + have htime := indirectStoreInstructionTime_le tapes.data store + addressRegister source bound hbound hstoreLength hentries (by omega) + (by omega) + simp only [executeInstructionTime] + omega + | jz source target => + simp only [instructionResourceMagnitude] at hinstruction + have hlookup := entryLookupStaticTime_le tapes.lifted.data.lhsLookup store + source bound hbound hstoreLength (by omega) hentries + have hadd := binaryAddConstTime_zero_le_width target bound (by omega) + have hread := read_bits_length_le store source bound + (fun entry hentry => (hentries entry hentry).2) + have hresetRead : TM.resetBinaryWorkTime 1 + (RegisterStore.read store source).bits.length ≀ 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + change zeroJumpInstructionTime tapes.lifted store pcValue source target + 1 + + (store.flatMap Entry.encode).length + 1 ≀ + 200000 * (bound + 1) ^ 3 + unfold zeroJumpInstructionTime setProgramCounterTime + TM.branchWorkBlankTime + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + omega + | jmp target => + simp only [instructionResourceMagnitude] at hinstruction + have hadd := binaryAddConstTime_zero_le_width target bound (by omega) + change jumpInstructionTime pcValue target + 1 + + (store.flatMap Entry.encode).length + 1 ≀ + 200000 * (bound + 1) ^ 3 + unfold jumpInstructionTime setProgramCounterTime + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + omega + | halt => + change haltInstructionTime + 1 + (store.flatMap Entry.encode).length + 1 ≀ + 200000 * (bound + 1) ^ 3 + unfold haltInstructionTime + omega + +private theorem instructionResourceMagnitude_le_program + (instruction : Instr) (program : Program) (hinstruction : instruction ∈ program) : + instructionResourceMagnitude instruction ≀ programResourceMagnitude program := by + induction program with + | nil => simp at hinstruction + | cons head rest ih => + simp only [List.mem_cons] at hinstruction + unfold programResourceMagnitude + simp only [List.length_cons, List.map_cons, List.sum_cons] + rcases hinstruction with rfl | hinstruction + Β· omega + Β· have htail := ih hinstruction + unfold programResourceMagnitude at htail + omega + +private theorem dispatchProgramTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (store : Store) (pcValue : β„•) + (program : Program) (selector bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) (hselector : selector ≀ pcValue) + (hprogram : βˆ€ instruction ∈ program, + instructionResourceMagnitude instruction ≀ bound) : + dispatchProgramTime tapes store pcValue program selector ≀ + 210000 * (program.length + 1) * (bound + 1) ^ 3 := by + induction program generalizing selector with + | nil => + have hselectorBits : selector.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len selector] + have hsize := Nat.size_le_size hselector + simpa [Nat.size_eq_bits_len] using! le_trans hsize (by + simpa [Nat.size_eq_bits_len] using! hpc) + have hreset : TM.resetBinaryWorkTime 1 selector.bits.length ≀ + 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hexecute := executeInstructionTime_le tapes .halt pcValue store bound + hbound hstoreLength hentries hpc (by + simpa [instructionResourceMagnitude] using! hbound) + simp only [dispatchProgramTime, List.length_nil, Nat.zero_add] + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + omega + | cons instruction rest ih => + have hinstruction := hprogram instruction (by simp) + have hrest : βˆ€ current ∈ rest, + instructionResourceMagnitude current ≀ bound := by + intro current hcurrent + exact hprogram current (by simp [hcurrent]) + have hexecute := executeInstructionTime_le tapes instruction pcValue store + bound hbound hstoreLength hentries hpc hinstruction + have hrecursive := ih (selector - 1) (Nat.sub_le selector 1 |>.trans hselector) + hrest + have hpred := TM.binaryPredTime_le (selector - 1) + have hpredSize : (selector - 1 + 1).size ≀ bound + 1 := by + have hvalue : selector - 1 + 1 ≀ pcValue + 1 := by omega + have hsize := Nat.size_le_size hvalue + have hpcSize : pcValue.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hpc + have hpcSucc : (pcValue + 1).size ≀ bound + 1 := by + rw [Nat.size_le] + have hlt := Nat.lt_size_self pcValue + have hpow := Nat.pow_le_pow_right (by decide : 1 ≀ 2) hpcSize + rw [pow_succ] + omega + exact le_trans hsize hpcSucc + have hpred' : TM.binaryPredTime (selector - 1) ≀ + 2 * (bound + 1) + 2 := le_trans hpred (by omega) + simp only [dispatchProgramTime, TM.branchWorkBlankTime, + List.length_cons] + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + have hmax : max (executeInstructionTime tapes instruction pcValue store) + (TM.binaryPredTime (selector - 1) + 1 + + dispatchProgramTime tapes store pcValue rest (selector - 1)) ≀ + 200000 * (bound + 1) ^ 3 + 1 + + 210000 * (rest.length + 1) * (bound + 1) ^ 3 := by + apply max_le + Β· omega + Β· omega + nlinarith + +private theorem programInstructionTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (pcValue : β„•) (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) + (hprogram : programResourceMagnitude program ≀ bound) : + programInstructionTime tapes program pcValue store ≀ + 220000 * (program.length + 1) * (bound + 1) ^ 3 := by + have hdispatch := dispatchProgramTime_le tapes store pcValue program pcValue + bound hbound hstoreLength hentries hpc le_rfl + (fun instruction hinstruction => le_trans + (instructionResourceMagnitude_le_program instruction program hinstruction) + hprogram) + have hcopy := binaryCopyTime_le_width pcValue 0 bound + (by simpa [Nat.size_eq_bits_len] using! hpc) (by simp) + unfold programInstructionTime + have hboundCube : bound ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) + (Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1)) + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega) hboundCube + nlinarith + +private theorem bits_length_le_of_value_le (value bound : β„•) + (hvalue : value ≀ bound) : value.bits.length ≀ bound := by + rw [Nat.size_eq_bits_len value] + exact le_trans (size_le_self value) hvalue + +private theorem maxWidth_le_of_entries (store : Store) (bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + maxWidth store ≀ bound := by + induction store with + | nil => simp [maxWidth] + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + simpa [maxWidth, bitlen, Nat.size_eq_bits_len] using! + (max_le hentry.1 (max_le hentry.2 (ih hrest))) + +private theorem snapshotWidth_le_of_bounds (pcValue : β„•) (store : Store) + (bound : β„•) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) : + Snapshot.width { pc := pcValue, store := store } ≀ bound := by + have hcount : store.length.bits.length ≀ bound := + bits_length_le_of_value_le store.length bound hstoreLength + have hwidth := maxWidth_le_of_entries store bound hentries + simpa [Snapshot.width, bitlen, Nat.size_eq_bits_len] using! + (max_le hpc (max_le hcount hwidth)) + +private theorem entryBitlen_le_maxWidth (store : Store) (entry : Entry) + (hentry : entry ∈ store) : + max (bitlen entry.1) (bitlen entry.2) ≀ maxWidth store := by + induction store with + | nil => simp at hentry + | cons head rest ih => + simp only [List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· simp only [maxWidth] + exact max_le (le_max_left _ _) + (le_trans (le_max_left _ _) (le_max_right _ _)) + Β· exact le_trans (ih hentry) + (le_trans (le_max_right _ _) (le_max_right _ _)) + +private theorem snapshotEntryBits_le_width (snapshot : Snapshot) + (entry : Entry) (hentry : entry ∈ snapshot.store) : + entry.1.bits.length ≀ snapshot.width ∧ + entry.2.bits.length ≀ snapshot.width := by + have hstore : maxWidth snapshot.store ≀ snapshot.width := + le_trans (le_max_right _ _) (le_max_right _ _) + have hmember : max (bitlen entry.1) (bitlen entry.2) ≀ + maxWidth snapshot.store := + entryBitlen_le_maxWidth snapshot.store entry hentry + have hboth := le_trans hmember hstore + simpa [bitlen, Nat.size_eq_bits_len] using! + (show bitlen entry.1 ≀ snapshot.width ∧ + bitlen entry.2 ≀ snapshot.width from + ⟨le_trans (le_max_left _ _) hboth, + le_trans (le_max_right _ _) hboth⟩) + +private theorem instructionLogCost_le (instruction : Instr) + (pcValue : β„•) (store : Store) (bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hinstruction : instructionResourceMagnitude instruction ≀ bound) : + instruction.logCost + (Snapshot.decode { pc := pcValue, store := store }) ≀ + 6 * (bound + 1) := by + have hread (address : β„•) : + (RegisterStore.read store address).bits.length ≀ bound := + read_bits_length_le store address bound + (fun entry hentry => (hentries entry hentry).2) + cases instruction with + | imm destination value => + simp only [instructionResourceMagnitude] at hinstruction + simp only [Instr.logCost] + have hvalue := bits_length_le_of_value_le value bound (by omega) + simpa [bitlen, Nat.size_eq_bits_len] using! + (show value.bits.length + 1 ≀ 6 * (bound + 1) by omega) + | add destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + have hresult := binaryInstrResult_bits_length_le .add + (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁) bound hlhs hrhs + have hresult' : (RegisterStore.read store sourceβ‚€ + + RegisterStore.read store source₁).bits.length ≀ 2 * bound + 1 := by + simpa [BinaryInstrOp.eval] using! hresult + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len, BinaryInstrOp.eval] using! + (show (RegisterStore.read store sourceβ‚€).bits.length + + (RegisterStore.read store source₁).bits.length + + (RegisterStore.read store sourceβ‚€ + + RegisterStore.read store source₁).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | sub destination sourceβ‚€ source₁ => + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len] using! + (show (RegisterStore.read store sourceβ‚€).bits.length + + (RegisterStore.read store source₁).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | mul destination sourceβ‚€ source₁ => + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + have hresult := binaryInstrResult_bits_length_le .mul + (RegisterStore.read store sourceβ‚€) + (RegisterStore.read store source₁) bound hlhs hrhs + have hresult' : (RegisterStore.read store sourceβ‚€ * + RegisterStore.read store source₁).bits.length ≀ 2 * bound + 1 := by + simpa [BinaryInstrOp.eval] using! hresult + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len, BinaryInstrOp.eval] using! + (show (RegisterStore.read store sourceβ‚€).bits.length + + (RegisterStore.read store source₁).bits.length + + (RegisterStore.read store sourceβ‚€ * + RegisterStore.read store source₁).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | load destination addressRegister => + have haddress := hread addressRegister + have hvalue := hread (RegisterStore.read store addressRegister) + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len] using! + (show (RegisterStore.read store addressRegister).bits.length + + (RegisterStore.read store + (RegisterStore.read store addressRegister)).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | store addressRegister source => + have haddress := hread addressRegister + have hvalue := hread source + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len] using! + (show (RegisterStore.read store addressRegister).bits.length + + (RegisterStore.read store source).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | jz source target => + have hvalue := hread source + simpa [Instr.logCost, Snapshot.decode, RegisterStore.decode, bitlen, + Nat.size_eq_bits_len] using! + (show (RegisterStore.read store source).bits.length + 1 ≀ + 6 * (bound + 1) by omega) + | jmp target => simp only [Instr.logCost]; omega + | halt => simp only [Instr.logCost]; omega + +private theorem write_length_le (store : Store) (address value : β„•) : + (RegisterStore.write store address value).length ≀ store.length + 1 := by + induction store with + | nil => + by_cases hvalue : value = 0 <;> + simp [RegisterStore.write, hvalue] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + by_cases hvalue : value = 0 + Β· simp [RegisterStore.write, hvalue] + omega + Β· simp [RegisterStore.write, hvalue] + Β· simp only [RegisterStore.write, haddress, ↓reduceIte, + List.length_cons] + omega + +private theorem instructionStoreBounds (instruction : Instr) + (pcValue : β„•) (store : Store) (bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) + (hinstruction : instructionResourceMagnitude instruction ≀ bound) : + (instructionStore instruction pcValue store).length ≀ bound + 1 ∧ + βˆ€ entry ∈ instructionStore instruction pcValue store, + entry.1.bits.length ≀ 6 * (bound + 1) ∧ + entry.2.bits.length ≀ 6 * (bound + 1) := by + let snapshot : Snapshot := { pc := pcValue, store := store } + let next := Snapshot.stepInstr instruction snapshot + have hsnapshot : snapshot.width ≀ bound := + snapshotWidth_le_of_bounds pcValue store bound hstoreLength hentries hpc + have hstatic := instructionStaticWidth_le_resourceMagnitude instruction + have hcost := instructionLogCost_le instruction pcValue store bound hentries + hinstruction + have hnextWidth : next.width ≀ 6 * (bound + 1) := by + exact le_trans (Snapshot.width_stepInstr_le instruction snapshot) (by + unfold Snapshot.stepWidthBound + exact max_le (by omega) + (max_le (le_trans (le_trans hstatic hinstruction) (by omega)) hcost)) + have hnextLength : next.store.length ≀ bound + 1 := by + cases instruction with + | imm destination value => + exact le_trans (write_length_le store destination value) (by omega) + | add destination sourceβ‚€ source₁ => + exact le_trans (write_length_le store destination _) (by omega) + | sub destination sourceβ‚€ source₁ => + exact le_trans (write_length_le store destination _) (by omega) + | mul destination sourceβ‚€ source₁ => + exact le_trans (write_length_le store destination _) (by omega) + | load destination addressRegister => + exact le_trans (write_length_le store destination _) (by omega) + | store addressRegister source => + exact le_trans (write_length_le store _ _) (by omega) + | jz source target => + simp only [next, snapshot, Snapshot.stepInstr] + split <;> simp_all <;> omega + | jmp target => simp [next, snapshot, Snapshot.stepInstr]; omega + | halt => simp [next, snapshot, Snapshot.stepInstr]; omega + constructor + Β· simpa [next, snapshot, instructionStore] using! hnextLength + Β· intro entry hentry + have := snapshotEntryBits_le_width next entry (by + simpa [next, snapshot, instructionStore] using! hentry) + exact ⟨le_trans this.1 hnextWidth, le_trans this.2 hnextWidth⟩ + +private theorem instructionCleanupResetBits_le + (instruction : Instr) (store : Store) (bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hinstruction : instructionResourceMagnitude instruction ≀ bound) + (slot : Fin 7) : + (instructionCleanupResetBits instruction store slot).length ≀ + 6 * (bound + 1) ^ 2 := by + have hread (address : β„•) : + (RegisterStore.read store address).bits.length ≀ bound := + read_bits_length_le store address bound + (fun entry hentry => (hentries entry hentry).2) + have hencoded := entriesEncode_length_le store bound hentries + have hencodedWide : (store.flatMap Entry.encode).length ≀ + 6 * (bound + 1) ^ 2 := by + have hproduct := Nat.mul_le_mul hstoreLength (show 4 * bound + 2 ≀ + 6 * (bound + 1) by omega) + exact le_trans hencoded (le_trans hproduct (by nlinarith)) + have hencodedWide' : (store.map (fun entry => entry.encode.length)).sum ≀ + 6 * (bound + 1) ^ 2 := by + simpa only [List.length_flatMap] using! hencodedWide + have hboundWide : bound ≀ 6 * (bound + 1) ^ 2 := by nlinarith + have hstoreLengthBitsWide : store.length.bits.length ≀ + 6 * (bound + 1) ^ 2 := by + exact le_trans (by + rw [Nat.size_eq_bits_len store.length] + exact le_trans (size_le_self store.length) hstoreLength) hboundWide + have hsmall (width : β„•) (hwidth : width ≀ 2 * bound + 1) : + width ≀ 6 * (bound + 1) ^ 2 := by nlinarith + cases instruction with + | imm destination value => + simp only [instructionResourceMagnitude] at hinstruction + have hdestination := bits_length_le_of_value_le destination bound (by omega) + have hvalue := bits_length_le_of_value_le value bound (by omega) + have hdestinationWide := le_trans hdestination hboundWide + have hvalueWide := le_trans hvalue hboundWide + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | add destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have hdestination := bits_length_le_of_value_le destination bound (by omega) + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + have hresult := binaryInstrResult_bits_length_le .add + (RegisterStore.read store sourceβ‚€) (RegisterStore.read store source₁) + bound hlhs hrhs + have hdestinationWide := le_trans hdestination hboundWide + have hlhsWide := le_trans hlhs hboundWide + have hrhsWide := le_trans hrhs hboundWide + have hresultWide : + (RegisterStore.read store sourceβ‚€ + + RegisterStore.read store source₁).bits.length ≀ + 6 * (bound + 1) ^ 2 := by + simpa [BinaryInstrOp.eval] using! hsmall _ hresult + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | sub destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have hdestination := bits_length_le_of_value_le destination bound (by omega) + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + have hresult := binaryInstrResult_bits_length_le .sub + (RegisterStore.read store sourceβ‚€) (RegisterStore.read store source₁) + bound hlhs hrhs + have hdestinationWide := le_trans hdestination hboundWide + have hlhsWide := le_trans hlhs hboundWide + have hrhsWide := le_trans hrhs hboundWide + have hresultWide : + (RegisterStore.read store sourceβ‚€ - + RegisterStore.read store source₁).bits.length ≀ + 6 * (bound + 1) ^ 2 := by + simpa [BinaryInstrOp.eval] using! hsmall _ hresult + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | mul destination sourceβ‚€ source₁ => + simp only [instructionResourceMagnitude] at hinstruction + have hdestination := bits_length_le_of_value_le destination bound (by omega) + have hlhs := hread sourceβ‚€ + have hrhs := hread source₁ + have hresult := binaryInstrResult_bits_length_le .mul + (RegisterStore.read store sourceβ‚€) (RegisterStore.read store source₁) + bound hlhs hrhs + have hdestinationWide := le_trans hdestination hboundWide + have hlhsWide := le_trans hlhs hboundWide + have hrhsWide := le_trans hrhs hboundWide + have hresultWide : + (RegisterStore.read store sourceβ‚€ * + RegisterStore.read store source₁).bits.length ≀ + 6 * (bound + 1) ^ 2 := by + simpa [BinaryInstrOp.eval] using! hsmall _ hresult + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | load destination addressRegister => + simp only [instructionResourceMagnitude] at hinstruction + have hdestination := bits_length_le_of_value_le destination bound (by omega) + have haddress := hread addressRegister + have hvalue := hread (RegisterStore.read store addressRegister) + have hdestinationWide := le_trans hdestination hboundWide + have haddressWide := le_trans haddress hboundWide + have hvalueWide := le_trans hvalue hboundWide + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | store addressRegister source => + simp only [instructionResourceMagnitude] at hinstruction + have haddress := hread addressRegister + have hvalue := hread source + have haddressWide := le_trans haddress hboundWide + have hvalueWide := le_trans hvalue hboundWide + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> + (try split_ifs) <;> simp_all + | jz source target => + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> try nlinarith + | jmp target => + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> try nlinarith + | halt => + fin_cases slot <;> + simp [instructionCleanupResetBits, instructionCleanupValue, + instructionRemainingValue] <;> try nlinarith + +private theorem instructionCleanupTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (instruction : Instr) + (pcValue : β„•) (store : Store) (sourceHeadBound bound : β„•) + (hbound : 1 ≀ bound) (hsourceHead : 1 ≀ sourceHeadBound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) + (hinstruction : instructionResourceMagnitude instruction ≀ bound) : + instructionCleanupTime tapes instruction pcValue store sourceHeadBound ≀ + 1000 * (sourceHeadBound + (bound + 1) ^ 2 + 1) := by + let nextStore := instructionStore instruction pcValue store + let nextBits := nextStore.flatMap Entry.encode + have hnext := instructionStoreBounds instruction pcValue store bound hbound + hstoreLength hentries hpc hinstruction + have hnextLength : nextStore.length ≀ bound + 1 := by + simpa only [nextStore] using! hnext.1 + have hnextEntries : βˆ€ entry ∈ nextStore, + entry.1.bits.length ≀ 6 * (bound + 1) ∧ + entry.2.bits.length ≀ 6 * (bound + 1) := by + simpa only [nextStore] using! hnext.2 + have hnextEncoded := entriesEncode_length_le nextStore (6 * (bound + 1)) + hnextEntries + have hnextBits : nextBits.length ≀ 26 * (bound + 1) ^ 2 := by + dsimp only [nextBits] + exact le_trans hnextEncoded (by + have hfactor : 4 * (6 * (bound + 1)) + 2 ≀ 26 * (bound + 1) := by + omega + have hproduct := Nat.mul_le_mul hnextLength hfactor + nlinarith) + have hreset := TM.resetBinaryWorkManyTime_le + (instructionCleanupResetTargets tapes) + (instructionCleanupResetBitsAt tapes instruction store) + (instructionCleanupResetHeadBoundAt tapes sourceHeadBound) + sourceHeadBound (6 * (bound + 1) ^ 2) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + rw [instructionCleanupResetHeadBoundAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + fin_cases slot <;> + simp [instructionCleanupResetHeadBound, hsourceHead]) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + rw [instructionCleanupResetBitsAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + exact instructionCleanupResetBits_le instruction store bound hbound + hstoreLength hentries hinstruction slot) + have htargets : (instructionCleanupResetTargets tapes).length = 7 := by + simp [instructionCleanupResetTargets] + rw [htargets] at hreset + have hcopy := TM.binaryCopyTime_le nextStore.length 0 + have hcopy' : TM.binaryCopyTime nextStore.length 0 ≀ + 3 * (bound + 1) + 20 := by + exact le_trans hcopy (by + have hsize := le_trans (size_le_self nextStore.length) hnextLength + simp only [Nat.size_zero] + omega) + have hresetNext : TM.resetBinaryWorkTime (nextBits.length + 1) + nextBits.length ≀ 3 * (26 * (bound + 1) ^ 2) + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + unfold instructionCleanupTime + dsimp only [nextStore, nextBits] at hnextBits hcopy' hresetNext ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + nlinarith + +private theorem selectedInstructionResourceMagnitude_le + (program : Program) (pcValue : β„•) : + instructionResourceMagnitude (selectedInstruction program pcValue) ≀ + programResourceMagnitude program := by + induction program generalizing pcValue with + | nil => simp [selectedInstruction, instructionResourceMagnitude, + programResourceMagnitude] + | cons instruction rest ih => + cases pcValue with + | zero => + simp only [selectedInstruction, programResourceMagnitude, + List.length_cons, List.map_cons, List.sum_cons] + omega + | succ pcValue => + have htail := ih pcValue + simp only [selectedInstruction, programResourceMagnitude, + List.length_cons, List.map_cons, List.sum_cons] + unfold programResourceMagnitude at htail + omega + +private theorem programStepTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (pcValue : β„•) (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hpc : pcValue.bits.length ≀ bound) + (hprogram : programResourceMagnitude program ≀ bound) : + programStepTime tapes program pcValue store ≀ + 300000000 * (program.length + 1) * (bound + 1) ^ 3 := by + let instruction := selectedInstruction program pcValue + let instructionTime := programInstructionTime tapes program pcValue store + have hinstruction : instructionResourceMagnitude instruction ≀ bound := + le_trans (selectedInstructionResourceMagnitude_le program pcValue) hprogram + have hinstructionTime : instructionTime ≀ + 220000 * (program.length + 1) * (bound + 1) ^ 3 := by + exact programInstructionTime_le tapes program pcValue store bound hbound + hstoreLength hentries hpc hprogram + have hcleanup := instructionCleanupTime_le tapes instruction pcValue store + (1 + instructionTime) bound hbound (by omega) hstoreLength hentries hpc + hinstruction + have hsqCube : (bound + 1) ^ 2 ≀ (bound + 1) ^ 3 := by + calc + (bound + 1) ^ 2 = (bound + 1) ^ 2 * 1 := by simp + _ ≀ (bound + 1) ^ 2 * (bound + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (bound + 1) ^ 3 := by ring + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega : 1 ≀ bound + 1) (Nat.le_self_pow + (by decide : (3 : β„•) β‰  0) (bound + 1)) + unfold programStepTime programStepSourceHeadBound + dsimp only [instruction, instructionTime] at hinstructionTime hcleanup ⊒ + nlinarith + +private theorem dispatchHaltTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (selector bound : β„•) (hbound : 1 ≀ bound) + (hselector : selector.bits.length ≀ bound) : + dispatchHaltTime tapes program selector ≀ + 20 * (program.length + 1) * (bound + 1) := by + induction program generalizing selector with + | nil => + have hreset : TM.resetBinaryWorkTime 1 selector.bits.length ≀ + 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + simp only [dispatchHaltTime, List.length_nil, Nat.zero_add, + Nat.mul_one] + omega + | cons instruction rest ih => + have hselectorPred : (selector - 1).bits.length ≀ bound := by + simpa only [Nat.size_eq_bits_len] using! + (le_trans (Nat.size_le_size (Nat.sub_le selector 1)) (by + simpa [Nat.size_eq_bits_len] using! hselector)) + have htail := ih (selector - 1) hselectorPred + have hpred := TM.binaryPredTime_le (selector - 1) + have hpredSize : (selector - 1 + 1).size ≀ bound + 1 := by + have hvalue : selector - 1 + 1 ≀ selector + 1 := by omega + have hsize := Nat.size_le_size hvalue + have hselectorSize : selector.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hselector + have hsucc : (selector + 1).size ≀ bound + 1 := by + rw [Nat.size_le] + have hlt := Nat.lt_size_self selector + have hpow := Nat.pow_le_pow_right (by decide : 1 ≀ 2) hselectorSize + rw [pow_succ] + omega + exact le_trans hsize hsucc + have hpred' : TM.binaryPredTime (selector - 1) ≀ + 2 * (bound + 1) + 2 := le_trans hpred (by omega) + simp only [dispatchHaltTime, TM.branchWorkBlankTime, List.length_cons] + have hmax : max 1 + (TM.binaryPredTime (selector - 1) + 1 + + dispatchHaltTime tapes rest (selector - 1)) ≀ + 2 * (bound + 1) + 3 + + 20 * (rest.length + 1) * (bound + 1) := by + apply max_le <;> omega + nlinarith + +private theorem programHaltTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (pcValue bound : β„•) (hbound : 1 ≀ bound) + (hpc : pcValue.bits.length ≀ bound) : + programHaltTime tapes program pcValue ≀ + 40 * (program.length + 1) * (bound + 1) := by + have hdispatch := dispatchHaltTime_le tapes program pcValue bound hbound hpc + have hcopy := binaryCopyTime_le_width pcValue 0 bound + (by simpa [Nat.size_eq_bits_len] using! hpc) (by simp) + unfold programHaltTime + nlinarith + +private theorem programOutputTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (store : Store) (bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + programOutputTime tapes store ≀ 22000 * (bound + 1) ^ 3 := by + have hlookup := entryLookupStaticTime_le tapes.lifted.data.lhsLookup store + 0 bound hbound hstoreLength (by omega) hentries + unfold programOutputTime + have honeCube : 1 ≀ (bound + 1) ^ 3 := by + exact le_trans (by omega : 1 ≀ bound + 1) (Nat.le_self_pow + (by decide : (3 : β„•) β‰  0) (bound + 1)) + omega + +private def SnapshotBounded (snapshot : Snapshot) (bound : β„•) : Prop := + snapshot.store.length ≀ bound ∧ + (βˆ€ entry ∈ snapshot.store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) ∧ + snapshot.pc.bits.length ≀ bound + +private theorem snapshotSteps_eq_run (program : Program) (fuel : β„•) + (snapshot : Snapshot) : + snapshotSteps program fuel snapshot = snapshot.run program fuel := by + induction fuel generalizing snapshot with + | zero => rfl + | succ fuel ih => + rw [snapshotSteps, ih] + by_cases hhalted : snapshot.Halted program + Β· rw [snapshot_step_eq_self_of_halted_internal program snapshot hhalted, + snapshot_run_halted_internal program snapshot hhalted] + simp [Snapshot.run, hhalted] + Β· simp [Snapshot.run, hhalted] + +private theorem programLoopIterationTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (snapshot : Snapshot) (bound : β„•) (hbound : 1 ≀ bound) + (hcurrent : SnapshotBounded snapshot bound) + (hnext : SnapshotBounded (snapshot.step program) bound) + (hprogram : programResourceMagnitude program ≀ bound) : + programLoopIterationTime tapes program snapshot ≀ + 301000000 * (program.length + 1) * (bound + 1) ^ 3 := by + have hstep := programStepTime_le tapes program snapshot.pc snapshot.store + bound hbound hcurrent.1 hcurrent.2.1 hcurrent.2.2 hprogram + have hhalt := programHaltTime_le tapes program (snapshot.step program).pc + bound hbound hnext.2.2 + unfold programLoopIterationTime + have hlinearCube : bound + 1 ≀ (bound + 1) ^ 3 := by + exact Nat.le_self_pow (by decide : (3 : β„•) β‰  0) (bound + 1) + have honeCube : 1 ≀ (bound + 1) ^ 3 := + le_trans (by omega) hlinearCube + nlinarith + +private theorem programLoopTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (fuel : β„•) (snapshot : Snapshot) (bound : β„•) + (hbound : 1 ≀ bound) + (hall : βˆ€ k, k ≀ fuel β†’ + SnapshotBounded (snapshotSteps program k snapshot) bound) + (hprogram : programResourceMagnitude program ≀ bound) : + programLoopTime tapes program fuel snapshot ≀ + fuel * (301000000 * (program.length + 1) * (bound + 1) ^ 3) := by + induction fuel generalizing snapshot with + | zero => simp [programLoopTime] + | succ fuel ih => + have hcurrent : SnapshotBounded snapshot bound := by + simpa [snapshotSteps] using! hall 0 (by omega) + have hnext : SnapshotBounded (snapshot.step program) bound := by + simpa [snapshotSteps] using! hall 1 (by omega) + have hiteration := programLoopIterationTime_le tapes program snapshot + bound hbound hcurrent hnext hprogram + have htail := ih (snapshot.step program) (by + intro k hk + simpa [snapshotSteps] using! hall (k + 1) (by omega)) + simp only [programLoopTime] + rw [Nat.succ_mul] + omega + +private theorem write_entries_le (store : Store) (address value bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (haddress : address.bits.length ≀ bound) + (hvalue : value.bits.length ≀ bound) : + βˆ€ entry ∈ RegisterStore.write store address value, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound := by + intro entry hentry + induction store with + | nil => + by_cases hvalueZero : value = 0 + Β· simp [RegisterStore.write, hvalueZero] at hentry + Β· simp [RegisterStore.write, hvalueZero] at hentry + subst entry + exact ⟨haddress, hvalue⟩ + | cons head rest ih => + rcases head with ⟨storedAddress, storedValue⟩ + have hhead := hentries (storedAddress, storedValue) (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + by_cases haddressEq : address = storedAddress + Β· subst address + by_cases hvalueZero : value = 0 + Β· simp [RegisterStore.write, hvalueZero] at hentry + exact hrest entry hentry + Β· simp [RegisterStore.write, hvalueZero] at hentry + rcases hentry with rfl | hentry + Β· exact ⟨haddress, hvalue⟩ + Β· exact hrest entry hentry + Β· simp only [RegisterStore.write, haddressEq, ↓reduceIte, + List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· exact hhead + Β· exact ih hrest hentry + +private theorem inputBitStoreFrom_bounds (address : β„•) (input : List Bool) + (bound : β„•) (hsum : address + input.length ≀ bound) : + (inputBitStoreFrom address input).length ≀ input.length ∧ + βˆ€ entry ∈ inputBitStoreFrom address input, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound := by + induction input generalizing address with + | nil => simp [inputBitStoreFrom] + | cons bit rest ih => + have htail := ih (address + 1) (by simp only [List.length_cons] at hsum; omega) + have haddress : address.bits.length ≀ bound := + bits_length_le_of_value_le address bound (by + simp only [List.length_cons] at hsum + omega) + have hone : (1 : β„•).bits.length ≀ bound := by + simpa using! (show 1 ≀ bound by + simp only [List.length_cons] at hsum + omega) + cases bit with + | false => + change (inputBitStoreFrom (address + 1) rest).length ≀ + rest.length + 1 ∧ + βˆ€ entry ∈ inputBitStoreFrom (address + 1) rest, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound + exact ⟨by omega, htail.2⟩ + | true => + change ((address, 1) :: inputBitStoreFrom (address + 1) rest).length ≀ + rest.length + 1 ∧ + βˆ€ entry ∈ (address, 1) :: inputBitStoreFrom (address + 1) rest, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound + constructor + Β· simp only [List.length_cons] + omega + Β· intro entry hentry + simp only [List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· exact ⟨haddress, hone⟩ + Β· exact htail.2 entry hentry + +private theorem programInitialSnapshot_bounded (input : List Bool) : + SnapshotBounded (programInitialSnapshot input) (input.length + 1) := by + have hprefix := inputBitStoreFrom_bounds 1 input (input.length + 1) (by omega) + have hlength := write_length_le (inputBitStoreFrom 1 input) 0 input.length + have hentries := write_entries_le (inputBitStoreFrom 1 input) 0 input.length + (input.length + 1) hprefix.2 (by simp) (by + exact bits_length_le_of_value_le input.length (input.length + 1) (by omega)) + refine ⟨?_, ?_, by simp [programInitialSnapshot]⟩ + Β· change (RegisterStore.write (inputBitStoreFrom 1 input) 0 + input.length).length ≀ input.length + 1 + omega + Β· simpa [programInitialSnapshot, programInitialStore] using! hentries + +private theorem rewindEntryEncodeRestoreTime_bound (entry : Entry) (bound : β„•) + (hbound : 1 ≀ bound) (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) : + rewindEntryEncodeRestoreTime entry ≀ 30 * (bound + 1) := by + have hrewind := rewindEntryEncodeTime_le entry 1 1 bound haddress hvalue + hbound hbound + unfold Machine.rewindEntryEncodeRestoreTime + omega + +private theorem inputTrueCount_le_length (input : List Bool) : + inputTrueCount input ≀ input.length := by + induction input with + | nil => simp [inputTrueCount] + | cons bit rest ih => + cases bit <;> simp [inputTrueCount] <;> omega + +private theorem initialInputLoopTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (address count : β„•) + (input : List Bool) (bound : β„•) (hbound : 1 ≀ bound) + (haddress : address + input.length ≀ bound) + (hcount : count + input.length ≀ bound) : + initialInputLoopTime tapes address count input ≀ + (input.length + 1) * (100 * (bound + 1) ^ 2) := by + induction input generalizing address count with + | nil => + simp only [initialInputLoopTime, List.length_nil, Nat.zero_add, + Nat.one_mul] + nlinarith + | cons bit rest ih => + have haddressValue : address.bits.length ≀ bound := + bits_length_le_of_value_le address bound (by + simp only [List.length_cons] at haddress + omega) + have hone : (1 : β„•).bits.length ≀ bound := by simp [hbound] + have hrewind := rewindEntryEncodeRestoreTime_bound (address, 1) bound + hbound haddressValue hone + have hsuccAddress := binarySuccTime_le_width address bound (by + simpa [Nat.size_eq_bits_len] using! haddressValue) + have hsuccCount := binarySuccTime_le_width count bound (by + exact le_trans (size_le_self count) (by omega)) + cases bit with + | false => + have htail := ih (address + 1) count (by + simp only [List.length_cons] at haddress ⊒ + omega) (by + simp only [List.length_cons] at hcount + omega) + simp [initialInputLoopTime] + have hbody : 1 + TM.binarySuccTime address + 1 ≀ + 100 * (bound + 1) ^ 2 := by nlinarith + nlinarith + | true => + have htail := ih (address + 1) (count + 1) (by + simp only [List.length_cons] at haddress ⊒ + omega) (by + simp only [List.length_cons] at hcount + omega) + simp [initialInputLoopTime] + have hbody : 1 + + (rewindEntryEncodeRestoreTime (address, 1) + 1 + + TM.binarySuccTime count + 1 + TM.binarySuccTime address) + 1 ≀ + 100 * (bound + 1) ^ 2 := by nlinarith + nlinarith + +private theorem initialLengthTime_le (length count : β„•) + (hcount : count ≀ length) : + initialLengthTime length count ≀ 100 * (length + 2) ^ 2 := by + have hbound : 1 ≀ length + 1 := by omega + have hlength : length.bits.length ≀ length + 1 := + bits_length_le_of_value_le length (length + 1) (by omega) + have hzero : (0 : β„•).bits.length ≀ length + 1 := by simp + have hrewind := rewindEntryEncodeRestoreTime_bound (0, length) + (length + 1) hbound hzero hlength + have hsucc := binarySuccTime_le_width count (length + 1) (by + exact le_trans (size_le_self count) (by omega)) + unfold initialLengthTime + split <;> nlinarith + +private theorem initialCleanupBits_le {m : β„•} + (tapes : ControlInstructionTapes m) (length bound : β„•) + (hlength : length.bits.length ≀ bound) (hbound : 1 ≀ bound) + (i : Fin (m + 1)) : + (initialCleanupBits tapes length i).length ≀ bound := by + unfold initialCleanupBits + split + Β· exact hlength + Β· split + Β· simpa using! hbound + Β· simp + +private theorem initialAbiInstallTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (store : Store) (length bound : β„•) + (hbound : 1 ≀ bound) (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hlength : length.bits.length ≀ bound) : + initialAbiInstallTime tapes store length ≀ 100 * (bound + 1) ^ 2 := by + let encoded := store.flatMap Entry.encode + have hencodedBase := entriesEncode_length_le store bound hentries + have hencoded : encoded.length ≀ 6 * (bound + 1) ^ 2 := by + dsimp only [encoded] + have hfactor : 4 * bound + 2 ≀ 6 * (bound + 1) := by omega + have hproduct := Nat.mul_le_mul hstoreLength hfactor + exact le_trans hencodedBase (by nlinarith) + have hcopy := binaryCopyTime_le_width store.length 0 bound + (le_trans (size_le_self store.length) hstoreLength) (by simp) + have hresetEncoded : TM.resetBinaryWorkTime (encoded.length + 1) + encoded.length ≀ 3 * (6 * (bound + 1) ^ 2) + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hresetMany := TM.resetBinaryWorkManyTime_le + (initialCleanupTargets tapes) (initialCleanupBits tapes length) + (fun _ => 1) 1 bound (fun _ _ => le_rfl) + (fun i _ => initialCleanupBits_le tapes length bound hlength hbound i) + have htargets : (initialCleanupTargets tapes).length = 2 := by + simp [initialCleanupTargets] + rw [htargets] at hresetMany + unfold initialAbiInstallTime + dsimp only [encoded] at hencoded hresetEncoded ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + nlinarith + +private theorem programInitTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (input : List Bool) : + programInitTime tapes input ≀ 1000 * (input.length + 2) ^ 3 := by + let bound := input.length + 1 + have hbound : 1 ≀ bound := by simp [bound] + have hloop := initialInputLoopTime_le tapes 1 0 input bound hbound + (by dsimp only [bound]; omega) (by dsimp only [bound]; omega) + have htrueCount := inputTrueCount_le_length input + have hlengthTime := initialLengthTime_le input.length (inputTrueCount input) + htrueCount + have hinitial := programInitialSnapshot_bounded input + have hlengthBits : input.length.bits.length ≀ bound := + bits_length_le_of_value_le input.length bound (by simp [bound]) + have habi := initialAbiInstallTime_le tapes (programInitialStore input) + input.length bound hbound hinitial.1 hinitial.2.1 hlengthBits + have hpred := TM.binaryPredTime_le input.length + have hpred' : TM.binaryPredTime input.length ≀ + 2 * (input.length + 1) + 2 := by + exact le_trans hpred (by + have hsize := size_le_self (input.length + 1) + omega) + have hsuccZero := TM.binarySuccTime_le 0 + have hsuccZero' : TM.binarySuccTime 0 ≀ 2 := by + simpa using! hsuccZero + unfold programInitTime + dsimp only [bound] at hloop habi hlengthBits hbound ⊒ + have hsqCube : (input.length + 2) ^ 2 ≀ + (input.length + 2) ^ 3 := by + calc + (input.length + 2) ^ 2 = (input.length + 2) ^ 2 * 1 := by simp + _ ≀ (input.length + 2) ^ 2 * (input.length + 2) := + Nat.mul_le_mul_left _ (by omega) + _ = (input.length + 2) ^ 3 := by ring + have honeCube : 1 ≀ (input.length + 2) ^ 3 := by nlinarith + have hloopCube : initialInputLoopTime tapes 1 0 input ≀ + 100 * (input.length + 2) ^ 3 := by + calc + initialInputLoopTime tapes 1 0 input ≀ + (input.length + 1) * (100 * (input.length + 2) ^ 2) := by + simpa only [Nat.add_assoc] using! hloop + _ ≀ (input.length + 2) * (100 * (input.length + 2) ^ 2) := + Nat.mul_le_mul_right _ (by omega) + _ = 100 * (input.length + 2) ^ 3 := by ring + have habi' : initialAbiInstallTime tapes (programInitialStore input) + input.length ≀ 100 * (input.length + 2) ^ 2 := by + simpa only [Nat.add_assoc] using! habi + nlinarith + +theorem programDecisionTime_le_envelope_internal {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) + (hfuel : fuel ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input)) : + programDecisionTime tapes program input fuel ≀ + programDecisionEnvelope program input.length + (RAM.logTimeUpto program fuel (RAM.initCfg input)) := by + let initial := programInitialSnapshot input + let cost := RAM.logTimeUpto program fuel (RAM.initCfg input) + let scale := programDecisionScale program input.length cost + let magnitude := programResourceMagnitude program + have hmagnitude : 1 ≀ magnitude := by + exact programResourceMagnitude_pos_internal program + have hprogramLength : program.length ≀ magnitude := by + exact program_length_le_resourceMagnitude_internal program + have hstatic : programStaticWidth program ≀ magnitude := by + exact programStaticWidth_le_resourceMagnitude_internal program + have hscale : 1 ≀ scale := by + exact programDecisionScale_pos_internal program input.length cost + have hinitial := programInitialSnapshot_bounded input + have hinitialRep : initial.Represents (RAM.initCfg input) := by + simpa only [initial] using! programInitialSnapshot_represents_internal input + have hinitialWidth : initial.width ≀ input.length + 1 := by + exact snapshotWidth_le_of_bounds initial.pc initial.store + (input.length + 1) hinitial.1 hinitial.2.1 hinitial.2.2 + have hhaltedInitial : RAM.Halted program + (RAM.run program fuel initial.decode) := by + rw [hinitialRep.2] + exact hhalted + have hcostSucc : RAM.logTimeUpto program (fuel + 1) initial.decode = cost := by + have hsame := RAM.logTimeUpto_eq_of_halted_le program + (Nat.le_succ fuel) hhaltedInitial + calc + RAM.logTimeUpto program (fuel + 1) initial.decode = + RAM.logTimeUpto program fuel initial.decode := by + simpa only [Nat.succ_eq_add_one] using! hsame + _ = cost := by rw [hinitialRep.2] + have hcanonical : Canonical initial.store := hinitialRep.1 + have hall : βˆ€ k, k ≀ fuel + 1 β†’ + SnapshotBounded (snapshotSteps program k initial) scale := by + intro k hk + let current := initial.run program k + have hlog := RAM.logTimeUpto_mono program (c := initial.decode) hk + rw [hcostSucc] at hlog + have hunit := RAM.unitTimeUpto_le_logTimeUpto program k initial.decode + have hunitCost : RAM.unitTimeUpto program k initial.decode ≀ cost := + le_trans hunit hlog + have hlength := Snapshot.length_run_le_internal program k initial hcanonical + have hwidth := Snapshot.width_run_le_internal program k initial hcanonical + have hstaticMagnitude : programStaticWidth program + 1 ≀ magnitude + 1 := + Nat.add_le_add_right hstatic 1 + have hwidthProduct : + RAM.unitTimeUpto program k initial.decode * + (programStaticWidth program + 1) ≀ + cost * (magnitude + 1) := + Nat.mul_le_mul hunitCost hstaticMagnitude + have hlengthScale : current.store.length ≀ scale := by + have hinitialLength : initial.store.length ≀ input.length + 1 := by + simpa only [initial] using! hinitial.1 + have hlengthBase : current.store.length ≀ + input.length + 1 + RAM.unitTimeUpto program k initial.decode := by + dsimp only [current] + exact le_trans hlength + (Nat.add_le_add_right hinitialLength _) + have hcostFactor : cost ≀ cost * (magnitude + 2) := by + calc + cost = cost * 1 := by simp + _ ≀ cost * (magnitude + 2) := + Nat.mul_le_mul_left cost (by omega) + change current.store.length ≀ + input.length + cost * (magnitude + 2) + magnitude + 3 + omega + have hwidthScale : current.width ≀ scale := by + have hwidthBase : current.width ≀ + input.length + 1 + cost * (magnitude + 1) + cost := by + dsimp only [current] + exact le_trans hwidth (by omega) + have hcostSplit : cost * (magnitude + 1) + cost = + cost * (magnitude + 2) := by ring + calc + current.width ≀ input.length + 1 + + (cost * (magnitude + 1) + cost) := by omega + _ = input.length + 1 + cost * (magnitude + 2) := by rw [hcostSplit] + _ ≀ scale := by + change input.length + 1 + cost * (magnitude + 2) ≀ + input.length + cost * (magnitude + 2) + magnitude + 3 + omega + have hentriesScale : βˆ€ entry ∈ current.store, + entry.1.bits.length ≀ scale ∧ + entry.2.bits.length ≀ scale := by + intro entry hentry + have hentryWidth := snapshotEntryBits_le_width current entry hentry + exact ⟨le_trans hentryWidth.1 hwidthScale, + le_trans hentryWidth.2 hwidthScale⟩ + have hpcWidth : current.pc.bits.length ≀ current.width := by + have hpc : bitlen current.pc ≀ current.width := + le_max_left (bitlen current.pc) + (max (bitlen current.store.length) (maxWidth current.store)) + unfold bitlen at hpc + rw [← Nat.size_eq_bits_len] at hpc + exact hpc + rw [snapshotSteps_eq_run] + exact ⟨hlengthScale, hentriesScale, le_trans hpcWidth hwidthScale⟩ + have hprogramScale : magnitude ≀ scale := by + unfold scale programDecisionScale + omega + have hloop := programLoopTime_le tapes program (fuel + 1) initial scale + hscale hall hprogramScale + have hfinalBound : SnapshotBounded (initial.run program fuel) scale := by + rw [← snapshotSteps_eq_run] + exact hall fuel (by omega) + have houtput := programOutputTime_le tapes (initial.run program fuel).store + scale hscale hfinalBound.1 hfinalBound.2.1 + have hinit := programInitTime_le tapes input + have hinputScale : input.length + 2 ≀ scale + 1 := by + unfold scale programDecisionScale + omega + have hinit' : programInitTime tapes input ≀ + 1000 * (scale + 1) ^ 3 := + le_trans hinit (Nat.mul_le_mul_left 1000 + (Nat.pow_le_pow_left hinputScale 3)) + have hfuelScale : fuel + 1 ≀ scale + 1 := by + have hfuelCost : fuel ≀ cost := by simpa only [cost] using! hfuel + have hcostScale : cost ≀ scale := by + change cost ≀ input.length + cost * (magnitude + 2) + magnitude + 3 + have hfactor : cost * 1 ≀ cost * (magnitude + 2) := + Nat.mul_le_mul_left cost (by omega) + omega + omega + have hlengthMagnitude : program.length + 1 ≀ 2 * magnitude := by omega + have hloopProduct : (fuel + 1) * (program.length + 1) ≀ + (scale + 1) * (2 * magnitude) := + Nat.mul_le_mul hfuelScale hlengthMagnitude + have hloop' : programLoopTime tapes program (fuel + 1) initial ≀ + 602000000 * magnitude * (scale + 1) ^ 4 := by + calc + programLoopTime tapes program (fuel + 1) initial ≀ + (fuel + 1) * + (301000000 * (program.length + 1) * (scale + 1) ^ 3) := hloop + _ = 301000000 * ((fuel + 1) * (program.length + 1)) * + (scale + 1) ^ 3 := by ring + _ ≀ 301000000 * ((scale + 1) * (2 * magnitude)) * + (scale + 1) ^ 3 := + Nat.mul_le_mul_right _ (Nat.mul_le_mul_left 301000000 hloopProduct) + _ = 602000000 * magnitude * (scale + 1) ^ 4 := by ring + have hcubeFourth : (scale + 1) ^ 3 ≀ (scale + 1) ^ 4 := by + calc + (scale + 1) ^ 3 = (scale + 1) ^ 3 * 1 := by simp + _ ≀ (scale + 1) ^ 3 * (scale + 1) := + Nat.mul_le_mul_left _ (by omega) + _ = (scale + 1) ^ 4 := by ring + have hinitEnvelope : programInitTime tapes input ≀ + 1000 * magnitude * (scale + 1) ^ 4 := by + exact le_trans hinit' (by + have hmultiply := Nat.mul_le_mul hmagnitude hcubeFourth + nlinarith) + have houtputEnvelope : programOutputTime tapes + (initial.run program fuel).store ≀ + 22000 * magnitude * (scale + 1) ^ 4 := by + exact le_trans houtput (by + have hmultiply := Nat.mul_le_mul hmagnitude hcubeFourth + nlinarith) + let envelopeUnit := magnitude * (scale + 1) ^ 4 + have hunitPos : 1 ≀ envelopeUnit := by + dsimp only [envelopeUnit] + exact Nat.mul_pos hmagnitude (pow_pos (by omega) 4) + have hinitUnit : programInitTime tapes input ≀ 1000 * envelopeUnit := by + simpa only [envelopeUnit, Nat.mul_assoc] using! hinitEnvelope + have hloopUnit : programLoopTime tapes program (fuel + 1) initial ≀ + 602000000 * envelopeUnit := by + simpa only [envelopeUnit, Nat.mul_assoc] using! hloop' + have houtputUnit : programOutputTime tapes + (initial.run program fuel).store ≀ 22000 * envelopeUnit := by + simpa only [envelopeUnit, Nat.mul_assoc] using! houtputEnvelope + have hloopUnit' : programLoopTime tapes program (fuel + 1) + (programInitialSnapshot input) ≀ 602000000 * envelopeUnit := by + simpa only [initial] using! hloopUnit + have houtputUnit' : programOutputTime tapes + ((programInitialSnapshot input).run program fuel).store ≀ + 22000 * envelopeUnit := by + simpa only [initial] using! houtputUnit + have htotal : programDecisionTime tapes program input fuel ≀ + 602023002 * envelopeUnit := by + unfold programDecisionTime + dsimp only + omega + apply le_trans htotal + unfold programDecisionEnvelope + change 602023002 * envelopeUnit ≀ + 1000000000 * magnitude * (scale + 1) ^ 4 + simpa only [envelopeUnit, Nat.mul_assoc] using! + (Nat.mul_le_mul_right envelopeUnit + (show 602023002 ≀ 1000000000 by decide)) + +theorem programDecisionEnvelope_mono_cost_internal (program : Program) + (inputLength left right : β„•) (hle : left ≀ right) : + programDecisionEnvelope program inputLength left ≀ + programDecisionEnvelope program inputLength right := by + have hscale : programDecisionScale program inputLength left ≀ + programDecisionScale program inputLength right := by + unfold programDecisionScale + exact Nat.add_le_add_right + (Nat.add_le_add_left + (Nat.mul_le_mul_right (programResourceMagnitude program + 2) hle) + inputLength) + (programResourceMagnitude program + 3) + unfold programDecisionEnvelope + exact Nat.mul_le_mul_left + (1000000000 * programResourceMagnitude program) + (Nat.pow_le_pow_left (Nat.add_le_add_right hscale 1) 4) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision.lean new file mode 100644 index 0000000000..267fb61e1e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DecisionInternal + +/-! +# Complete sparse RAM decision machine +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The complete concrete machine realizes one halted pure sparse RAM run and +emits its `Rβ‚€` verdict. -/ +theorem programDecisionTM_hoareTime_run {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : ((programInitialSnapshot input).run program fuel).Halted program) : + (programDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + let final := (programInitialSnapshot input).run program fuel + out = registerVerdictOutput (RegisterStore.read final.store 0)) + (programDecisionTime tapes program input fuel) := + programDecisionTM_hoareTime_run_internal tapes program input fuel hhalted + +/-- The complete machine realizes a halted executable RAM run and emits its +public `Rβ‚€` verdict. -/ +theorem programDecisionTM_hoareTime_ramRun {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) : + (programDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + out = registerVerdictOutput + (RAM.run program fuel (RAM.initCfg input)).verdict) + (programDecisionTime tapes program input fuel) := + programDecisionTM_hoareTime_ramRun_internal tapes program input fuel hhalted + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision/Defs.lean new file mode 100644 index 0000000000..00f2cbc16b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Decision/Defs.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs + +/-! +# Complete sparse RAM decision machine -- definitions +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Initialize the public RAM configuration, execute one fixed program through +its first halt, and extract the Boolean verdict from sparse register `Rβ‚€`. -/ +def programDecisionTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM (programInitTM tapes) + (TM.seqTM (programLoopTM tapes program) (programOutputTM tapes)) + +/-- Exact compositional bound for one fuel-certified RAM decision run. -/ +noncomputable def programDecisionTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) : β„• := + let initial := programInitialSnapshot input + let final := initial.run program fuel + programInitTime tapes input + 1 + + (programLoopTime tapes program (fuel + 1) initial + 1 + + programOutputTime tapes final.store) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DecisionInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DecisionInternal.lean new file mode 100644 index 0000000000..eb294b98cd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DecisionInternal.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Decision.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal + +/-! +# Complete sparse RAM decision-machine proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +/-- The complete concrete machine realizes one halted pure sparse RAM run and +emits its `Rβ‚€` verdict. -/ +theorem programDecisionTM_hoareTime_run_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : ((programInitialSnapshot input).run program fuel).Halted program) : + (programDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + let final := (programInitialSnapshot input).run program fuel + out = registerVerdictOutput (RegisterStore.read final.store 0)) + (programDecisionTime tapes program input fuel) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let initial := programInitialSnapshot input + let final := initial.run program fuel + have hinit := programInitTM_hoareTime_internal tapes input + obtain ⟨initDone, initTime, hinitTime, hinitReach, hinitHalt, + hinitInput, hinitWork, hinitOutput⟩ := + hinit _ _ _ ⟨rfl, rfl, rfl⟩ + have hinitialCanonical : Canonical initial.store := by + simpa only [initial, programInitialSnapshot] using! + programInitialStore_canonical_internal input + have hready : InstructionExecutionReady tapes initial.store initial.pc + initDone.work := by + rw [hinitWork] + exact programSnapshotWork_ready_internal tapes initial hinitialCanonical + have hinitInputParked : TM.Parked initDone.input := + ⟨hinitInput.1, hinitInput.2.2.2⟩ + have hloop := programLoopTM_hoareTime_run_internal tapes program fuel initial + initDone.work initDone.input hready hinitInputParked hhalted + obtain ⟨loopDone, loopTime, hloopTime, hloopReach, hloopHalt, + hloopInput, hloopReady, hloopOutput⟩ := + hloop _ _ _ ⟨rfl, rfl, by simpa [TM.resetBinaryBlank] using! hinitOutput⟩ + have hloopInputParked : TM.Parked loopDone.input := by + rw [hloopInput] + exact hinitInputParked + have hloopOutputHalt : loopDone.output = instructionHaltOutput .halt := by + change loopDone.output = instructionHaltOutput (final.curInstr program) at hloopOutput + rw [show final.curInstr program = .halt from hhalted] at hloopOutput + exact hloopOutput + have houtputRun := programOutputTM_hoareTime_haltOutput_internal tapes + final.store final.pc loopDone.work loopDone.input hloopReady + hloopInputParked + obtain ⟨outputDone, outputTime, houtputTime, houtputReach, + houtputHalt, houtputInput, houtputVerdict⟩ := + houtputRun _ _ _ ⟨rfl, rfl, hloopOutputHalt⟩ + have hloopOutputParked : TM.Parked loopDone.output := by + rw [hloopOutputHalt] + refine ⟨?_, instructionHaltOutput_cells_ne_start_internal .halt⟩ + rw [instructionHaltOutput_head_internal] + have houtputReach' : (programOutputTM tapes).reachesIn outputTime + { state := (programOutputTM tapes).qstart + input := TM.transitionInput loopDone.input + work := fun i => TM.transitionTape (loopDone.work i) + output := TM.transitionTape loopDone.output } + outputDone := by + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hloopInputParked.read_ne_start + (fun i => (hloopReady.control.lookup.scanner.parked i).read_ne_start) + hloopOutputParked.read_ne_start + simpa only [hi, hw, ho] using! houtputReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (programLoopTM tapes program) (programOutputTM tapes) + hloopReach hloopHalt houtputReach' + let tailDone := TM.phase2Wrap (programLoopTM tapes program) + (programOutputTM tapes) outputDone + have htailHalt : + (TM.seqTM (programLoopTM tapes program) + (programOutputTM tapes)).halted tailDone := by + rw [TM.phase2Wrap_halted_iff] + exact houtputHalt + have hinitWorkParked : βˆ€ i, TM.Parked (initDone.work i) := by + rw [hinitWork] + exact (programSnapshotWork_ready_internal tapes initial + hinitialCanonical).control.lookup.scanner.parked + have hinitOutputParked : TM.Parked initDone.output := by + rw [hinitOutput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact ⟨by rw [hblankNat.2.1], + hblankNat.2.hasBinaryContent.cells_ne_start⟩ + have htailReach' : + (TM.seqTM (programLoopTM tapes program) + (programOutputTM tapes)).reachesIn + (loopTime + 1 + outputTime) + { state := (TM.seqTM (programLoopTM tapes program) + (programOutputTM tapes)).qstart + input := TM.transitionInput initDone.input + work := fun i => TM.transitionTape (initDone.work i) + output := TM.transitionTape initDone.output } + tailDone := by + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinitInputParked.read_ne_start + (fun i => (hinitWorkParked i).read_ne_start) + hinitOutputParked.read_ne_start + simpa only [hi, hw, ho] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (programInitTM tapes) + (TM.seqTM (programLoopTM tapes program) (programOutputTM tapes)) + hinitReach hinitHalt htailReach' + let done := TM.phase2Wrap (programInitTM tapes) + (TM.seqTM (programLoopTM tapes program) (programOutputTM tapes)) tailDone + refine ⟨done, initTime + 1 + (loopTime + 1 + outputTime), + ?_, hreach, ?_, ?_⟩ + Β· unfold programDecisionTime + dsimp only [initial, final] at hloopTime houtputTime ⊒ + omega + Β· change (programDecisionTM tapes program).halted done + unfold programDecisionTM + exact (TM.phase2Wrap_halted_iff (programInitTM tapes) + (TM.seqTM (programLoopTM tapes program) (programOutputTM tapes)) tailDone).mpr + htailHalt + Β· change outputDone.output = registerVerdictOutput + (RegisterStore.read final.store 0) + exact houtputVerdict + +/-- The complete machine realizes a halted executable RAM run, with the public +RAM verdict rewritten through the sparse representation theorem. -/ +theorem programDecisionTM_hoareTime_ramRun_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) : + (programDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + out = registerVerdictOutput + (RAM.run program fuel (RAM.initCfg input)).verdict) + (programDecisionTime tapes program input fuel) := by + let initial := programInitialSnapshot input + let final := initial.run program fuel + have hinitialRep : initial.Represents (RAM.initCfg input) := by + simpa only [initial] using! programInitialSnapshot_represents_internal input + have hdecode : final.decode = RAM.run program fuel (RAM.initCfg input) := by + have hrun := Snapshot.decode_run_internal program fuel initial hinitialRep.1 + rw [hinitialRep.2] at hrun + exact hrun + have hfinalHalted : final.Halted program := by + apply (Snapshot.halted_decode_iff_internal program final).mp + rw [hdecode] + exact hhalted + have hrun := programDecisionTM_hoareTime_run_internal tapes program input + fuel hfinalHalted + apply hrun.consequence + Β· exact fun _ _ _ h => h + Β· intro inp work out hpost + change out = registerVerdictOutput (RegisterStore.read final.store 0) + at hpost + rw [hpost] + congr 1 + change final.decode.regs 0 = + (RAM.run program fuel (RAM.initCfg input)).regs 0 + rw [hdecode] + Β· exact le_rfl + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Defs.lean new file mode 100644 index 0000000000..6f4501114f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Defs.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Sim.Defs + +/-! +# Sparse RAM program controller -- definitions + +This layer adds the fixed-program halt test needed to iterate the checked +single-instruction simulator. The test copies the canonical program counter, +walks the same decrementing finite branch tree as instruction dispatch, and +writes `1` exactly for a selected `halt`; every continuing branch writes blank. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Two-state leaf that writes one halt verdict at the current output head. -/ +inductive HaltVerdictPhase where + | write + | done + deriving DecidableEq + +instance : Fintype HaltVerdictPhase where + elems := {.write, .done} + complete := fun state => by cases state <;> simp + +/-- Output symbol used by the fixed-program halt test. Continuing instructions +write blank so the instruction body regains its blank-output ABI. -/ +def instructionHaltVerdict : Instr β†’ Ξ“w + | .halt => .one + | _ => .blank + +/-- Canonical output tape produced by one halt-verdict leaf. -/ +def instructionHaltOutput (instruction : Instr) : Tape := + let blank := (Tape.init []).move Dir3.right + blank.writeAndMove (instructionHaltVerdict instruction).toΞ“ + (TM.idleDir blank.read) + +/-- Write the selected instruction's halt verdict in one transition while +preserving input and work tapes. -/ +def instructionHaltVerdictTM {n : β„•} (instruction : Instr) : TM n where + Q := HaltVerdictPhase + qstart := .write + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .write => + (.done, fun i => TM.readBackWrite (wHeads i), + instructionHaltVerdict instruction, + TM.idleDir iHead, fun i => TM.idleDir (wHeads i), + TM.idleDir oHead) + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state <;> exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Decrementing fixed-program branch tree for the halt verdict. -/ +def dispatchHaltTM {n : β„•} (tapes : ControlInstructionTapes n) : + Program β†’ TM (n + 1) + | [] => TM.seqTM (TM.resetBinaryWorkTM tapes.liftedLhs) + (instructionHaltVerdictTM .halt) + | instruction :: program => + TM.branchWorkBlankTM tapes.liftedLhs + (instructionHaltVerdictTM instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchHaltTM tapes program)) + +/-- Copy the canonical PC and emit whether its fixed-program instruction is +`halt`. -/ +def programHaltTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (dispatchHaltTM tapes program) + +/-- Branch-tree bound for a selector represented by `selector`. -/ +def dispatchHaltTime {n : β„•} (tapes : ControlInstructionTapes n) : + Program β†’ β„• β†’ β„• + | [], selector => + TM.resetBinaryWorkTime 1 selector.bits.length + 1 + 1 + | _ :: program, selector => + TM.branchWorkBlankTime 1 + (TM.binaryPredTime (selector - 1) + 1 + + dispatchHaltTime tapes program (selector - 1)) + +/-- Complete fixed-program halt-test bound. -/ +def programHaltTime {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) (pcValue : β„•) : β„• := + TM.binaryCopyTime pcValue 0 + 1 + + dispatchHaltTime tapes program pcValue + +/-- Repeated pure sparse-snapshot stepping without an explicit halt check. +Because the selected `halt` instruction is a no-op, this agrees with +`Snapshot.run`. -/ +def snapshotSteps (program : Program) : β„• β†’ Snapshot β†’ Snapshot + | 0, snapshot => snapshot + | fuel + 1, snapshot => snapshotSteps program fuel (snapshot.step program) + +/-- Canonical parked tape containing one Boolean string. -/ +def programBinaryTape (bits : List Bool) : Tape := + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right + +/-- Exact clean work-tape image of one sparse RAM snapshot. The store stream, +runtime count, preserved count, and program counter occupy their established +instruction-ABI roles; every other tape is the standard parked blank tape. -/ +def programSnapshotWork {n : β„•} (tapes : ControlInstructionTapes n) + (snapshot : Snapshot) : Fin (n + 1) β†’ Tape := + Function.update + (Function.update + (Function.update + (Function.update (Function.const (Fin (n + 1)) TM.resetBinaryBlank) + tapes.liftedSource + (programBinaryTape (snapshot.store.flatMap Entry.encode))) + tapes.lifted.data.update.remaining + (programBinaryTape snapshot.store.length.bits)) + tapes.lifted.data.update.resultCount + (programBinaryTape snapshot.store.length.bits)) + tapes.liftedPC (programBinaryTape snapshot.pc.bits) + +/-- Boolean output symbol obtained from the RAM verdict convention. -/ +def registerVerdictSymbol (value : β„•) : Ξ“w := + if value = 0 then .zero else .one + +/-- Exact output tape emitted from one RAM register value. -/ +def registerVerdictOutput (value : β„•) : Tape := + let blank := (Tape.init []).move Dir3.right + blank.writeAndMove (registerVerdictSymbol value).toΞ“ + (TM.idleDir blank.read) + +/-- Read a canonical register-value tape and emit zero exactly for value zero, +or one for any nonzero value. -/ +def registerVerdictTM {n : β„•} (idx : Fin n) : TM n where + Q := HaltVerdictPhase + qstart := .write + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .write => + (.done, fun i => TM.readBackWrite (wHeads i), + if wHeads idx = Ξ“.blank then .zero else .one, + TM.idleDir iHead, fun i => TM.idleDir (wHeads i), + TM.idleDir oHead) + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state + Β· dsimp only + exact TM.rightOfStart_allIdle iHead wHeads oHead + Β· exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Recover register `Rβ‚€` through the reusable sparse lookup and emit its +Boolean verdict on the real output tape. -/ +def programOutputTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM (entryLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) + +/-- Complete final-verdict extraction bound. -/ +def programOutputTime {n : β„•} (tapes : ControlInstructionTapes n) + (store : Store) : β„• := + entryLookupStaticTime tapes.lifted.data.lhsLookup store 0 + 1 + 1 + +/-- Fixed halt-aware loop for one concrete RAM program. -/ +def programLoopTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.loopTM (programStepTM tapes program) (programHaltTM tapes program) + +/-- Bound for one loop body, body/test seams, halt test, and the three-step +rewind/check tail. -/ +noncomputable def programLoopIterationTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (snapshot : Snapshot) : β„• := + let next := snapshot.step program + programStepTime tapes program snapshot.pc snapshot.store + 1 + + programHaltTime tapes program next.pc + 1 + 3 + +/-- Sum of the first `fuel` loop-iteration bounds. -/ +noncomputable def programLoopTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) : + β„• β†’ Snapshot β†’ β„• + | 0, _ => 0 + | fuel + 1, snapshot => + programLoopIterationTime tapes program snapshot + + programLoopTime tapes program fuel (snapshot.step program) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBounds.lean new file mode 100644 index 0000000000..232b6f2a10 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBounds.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsProof + +/-! +# Dense-overlay RAM decision-machine resource bounds + +This surface exposes the selected-width one-step bound, the amortized +quadratic loop bound, and the complete quadratic decision bound for the +optimized dense-input RAM simulator. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- One selected dense RAM instruction is simulated in time proportional to +the live serialized volume times that instruction's actual charged width. -/ +theorem denseProgramStepTime_le_envelope {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramStepTime tapes program input snapshot.pc snapshot.overlay ≀ + denseStepEnvelope program input snapshot := + denseProgramStepTime_le_envelope_internal tapes program input snapshot + hvalid hpc + +/-- The complete conservative dense loop timer is bounded by the square of a +potential containing live data, remaining fuel, and remaining RAM cost. -/ +theorem denseProgramLoopTime_le_envelope {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramLoopTime tapes program input fuel snapshot ≀ + denseProgramLoopEnvelope program input fuel snapshot := + denseProgramLoopTime_le_envelope_internal tapes program input fuel snapshot + hvalid hpc + +/-- A halted dense RAM run whose fuel is charged by logarithmic time is +simulated within a quadratic envelope in input length plus charged RAM time. -/ +theorem denseProgramDecisionTime_le_envelope {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) + (hfuel : fuel ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input)) : + denseProgramDecisionTime tapes program input fuel ≀ + denseProgramDecisionEnvelope program input.length + (RAM.logTimeUpto program fuel (RAM.initCfg input)) := + denseProgramDecisionTime_le_envelope_internal tapes program input fuel + hhalted hfuel + +/-- Increasing the charged RAM-time argument can only enlarge the optimized +quadratic decision envelope. -/ +theorem denseProgramDecisionEnvelope_mono_cost (program : Program) + (inputLength left right : β„•) (hle : left ≀ right) : + denseProgramDecisionEnvelope program inputLength left ≀ + denseProgramDecisionEnvelope program inputLength right := by + unfold denseProgramDecisionEnvelope + exact Nat.mul_le_mul_left _ + (Nat.pow_le_pow_left (by omega) 2) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsDefs.lean new file mode 100644 index 0000000000..08b0ff3c2b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsDefs.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay.Defs +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Dense-overlay RAM decision-machine resource-bound definitions + +The optimized accounting keeps the live serialized overlay separate from the +width charged by the instruction actually selected at the current program +counter. This is the local product that sums quadratically over a run. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Width charged by the selected instruction, including the fixed program +literals. -/ +def denseStepWidth (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) : β„• := + programStaticWidth program + + RAM.stepLogCost program (snapshot.decode input) + 1 + +/-- Local amount of serialized data exposed to one dense simulated step. -/ +def denseStepVolume (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) : β„• := + encodedStoreLength snapshot.overlay + input.length + + denseStepWidth program input snapshot + 1 + +/-- Width-sensitive envelope for one selected dense step. The program +magnitude is fixed once the simulated RAM program is fixed. -/ +def denseStepEnvelope (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) : β„• := + 1000000000 * (programResourceMagnitude program + 1) ^ 2 * + denseStepVolume program input snapshot * + (denseStepWidth program input snapshot + 1) + +/-- Potential controlling a complete dense run. Its square absorbs both live +overlay growth and the sum of selected-instruction widths. The explicit fuel +reserve also pays for the conservative loop timer after an early halt, when +the semantic RAM costs have become stationary. -/ +def denseRunScale (program : Program) (input : List Bool) (fuel : β„•) + (snapshot : DenseOverlay.Snapshot) : β„• := + encodedStoreLength snapshot.overlay + input.length + 2 + + 3 * ((programStaticWidth program + 1) * + (fuel + RAM.unitTimeUpto program fuel (snapshot.decode input)) + + RAM.logTimeUpto program fuel (snapshot.decode input)) + +/-- Quadratic envelope for a complete dense loop from an arbitrary valid +snapshot. -/ +def denseProgramLoopEnvelope (program : Program) (input : List Bool) + (fuel : β„•) (snapshot : DenseOverlay.Snapshot) : β„• := + 2000000000 * (programResourceMagnitude program + 1) ^ 2 * + (denseRunScale program input fuel snapshot) ^ 2 + +/-- Public-ABI quadratic envelope in input length and charged RAM time. -/ +def denseProgramDecisionEnvelope (program : Program) + (inputLength cost : β„•) : β„• := + 500000000000 * (programResourceMagnitude program + 1) ^ 4 * + (inputLength + cost + 1) ^ 2 + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsProof.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsProof.lean new file mode 100644 index 0000000000..2a26493b5d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseBoundsProof.lean @@ -0,0 +1,2117 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseBoundsDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.DenseInputLookup +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionDefs + +/-! +# Dense-overlay RAM decision-machine resource-bound proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +private theorem encodedStoreLength_eq_sums (store : Store) : + encodedStoreLength store = + 2 * (store.map fun entry => bitlen entry.1).sum + + 2 * (store.map fun entry => bitlen entry.2).sum + + 2 * store.length := by + induction store with + | nil => simp [encodedStoreLength] + | cons entry rest ih => + rw [encodedStoreLength, List.flatMap_cons, List.length_append, + Entry.encode_length] + simp only [List.map_cons, List.sum_cons, List.length_cons] + have ih' : (rest.flatMap Entry.encode).length = + 2 * (rest.map fun entry => bitlen entry.1).sum + + 2 * (rest.map fun entry => bitlen entry.2).sum + + 2 * rest.length := by + simpa only [encodedStoreLength] using! ih + rw [ih'] + omega + +private theorem address_count_width_le_encodedStoreLength + (store : Store) (hcanonical : Canonical store) : + store.length * bitlen store.length ≀ encodedStoreLength store := by + let addresses := store.map Prod.fst + let addressWidths := addresses.map bitlen + have hnodup : addresses.Nodup := hcanonical.1 + have hlength : addresses.length = store.length := by + simp [addresses] + have hsum : addressWidths.sum = + (store.map fun entry => bitlen entry.1).sum := by + simp [addressWidths, addresses, Function.comp_def] + have hencoded : + 2 * addressWidths.sum + 2 * store.length ≀ + encodedStoreLength store := by + rw [encodedStoreLength_eq_sums] + rw [hsum] + omega + generalize hsize : store.length.size = width + cases width with + | zero => + have hzero : store.length = 0 := by + have := Nat.size_pos.not.mp (by omega : Β¬0 < store.length.size) + omega + simp [hzero] + | succ width => + cases width with + | zero => + have hsmall : store.length ≀ 1 := by + have hlt := Nat.lt_size_self store.length + rw [hsize] at hlt + norm_num at hlt + omega + have hbits : bitlen store.length = 1 := by + simpa [bitlen] using! hsize + rw [hbits] + omega + | succ width => + let addressSet := addresses.toFinset + let threshold := 2 ^ width + let low := addressSet.filter fun address => address < threshold + let high := addressSet.filter fun address => threshold ≀ address + have hcard : addressSet.card = store.length := by + rw [List.toFinset_card_of_nodup hnodup, hlength] + have hlowSubset : low βŠ† Finset.range threshold := by + intro address haddress + have := (Finset.mem_filter.mp haddress).2 + simpa [Finset.mem_range] using! this + have hlow : low.card ≀ threshold := by + exact le_trans (Finset.card_le_card hlowSubset) (by simp) + have hpartition : low.card + high.card = store.length := by + have hparts := Finset.card_filter_add_card_filter_not + (s := addressSet) (p := fun address => address < threshold) + simpa [low, high, Nat.not_lt, hcard] using! hparts + have hthresholdTwice : 2 * threshold ≀ store.length := by + have hpow : 2 ^ (width + 1) ≀ store.length := by + rw [← Nat.lt_size] + omega + simpa [threshold, pow_succ, Nat.mul_comm] using! hpow + have hmanyHigh : store.length ≀ 2 * high.card := by omega + have hhighWidth : βˆ€ address ∈ high, width + 1 ≀ bitlen address := by + intro address haddress + have hge := (Finset.mem_filter.mp haddress).2 + unfold bitlen + have hlt : width < address.size := Nat.lt_size.mpr (by + simpa [threshold] using! hge) + omega + have hhighSum : high.card * (width + 1) ≀ + βˆ‘ address ∈ high, bitlen address := by + exact Finset.card_nsmul_le_sum high (fun address => bitlen address) + (width + 1) hhighWidth + have hhighSubset : high βŠ† addressSet := Finset.filter_subset _ _ + have hsumSubset : (βˆ‘ address ∈ high, bitlen address) ≀ + βˆ‘ address ∈ addressSet, bitlen address := by + exact Finset.sum_le_sum_of_subset hhighSubset + have hsetSum : (βˆ‘ address ∈ addressSet, bitlen address) = + addressWidths.sum := by + rw [← List.sum_toFinset (fun address => bitlen address) hnodup] + have hwidth : bitlen store.length = width + 2 := by + simpa [bitlen] using! hsize + rw [hwidth] + have hmain : store.length * (width + 2) ≀ + 2 * addressWidths.sum + store.length := by + rw [show store.length * (width + 2) = + store.length * (width + 1) + store.length by ring] + have hproduct : store.length * (width + 1) ≀ + 2 * (high.card * (width + 1)) := + by simpa [Nat.mul_assoc] using! + Nat.mul_le_mul_right (width + 1) hmanyHigh + omega + omega + +private theorem store_length_le_encodedStoreLength (store : Store) : + store.length ≀ encodedStoreLength store := by + rw [encodedStoreLength_eq_sums] + omega + +private theorem entry_bits_le_encodedStoreLength (store : Store) + (entry : Entry) (hentry : entry ∈ store) : + entry.1.bits.length ≀ encodedStoreLength store ∧ + entry.2.bits.length ≀ encodedStoreLength store := by + induction store with + | nil => simp at hentry + | cons head rest ih => + simp only [List.mem_cons] at hentry + have hcode : (Entry.encode head).length + encodedStoreLength rest = + encodedStoreLength (head :: rest) := by + simp [encodedStoreLength] + rcases hentry with rfl | hentry + Β· rw [Entry.encode_length] at hcode + rw [Nat.size_eq_bits_len, Nat.size_eq_bits_len] + unfold bitlen at hcode + omega + Β· have htail := ih hentry + omega + +private theorem read_bits_le_encodedStoreLength (store : Store) + (address : β„•) : + (RegisterStore.read store address).bits.length ≀ encodedStoreLength store := by + induction store with + | nil => simp [RegisterStore.read, encodedStoreLength] + | cons entry rest ih => + rcases entry with ⟨storedAddress, storedValue⟩ + by_cases haddress : address = storedAddress + Β· subst address + simp only [RegisterStore.read, ↓reduceIte] + exact (entry_bits_le_encodedStoreLength + ((storedAddress, storedValue) :: rest) (storedAddress, storedValue) + (by simp)).2 + Β· simp only [RegisterStore.read, haddress, ↓reduceIte] + exact le_trans ih (by + simp [encodedStoreLength]) + +private theorem count_bits_le_encodedStoreLength (store : Store) + (hcanonical : Canonical store) : + store.length.bits.length ≀ encodedStoreLength store := by + rw [Nat.size_eq_bits_len] + change bitlen store.length ≀ encodedStoreLength store + have hproduct := + address_count_width_le_encodedStoreLength store hcanonical + by_cases hzero : store.length = 0 + Β· simp [hzero, bitlen] + Β· have hpos : 1 ≀ store.length := Nat.one_le_iff_ne_zero.mpr hzero + have hle : bitlen store.length ≀ store.length * bitlen store.length := by + simpa only [one_mul] using! + Nat.mul_le_mul_right (bitlen store.length) hpos + exact le_trans hle hproduct + +private theorem entryLookupStoreWidth_le_encoded (store : Store) + (address : β„•) : + entryLookupStoreWidth address store ≀ + encodedStoreLength store + address.bits.length := by + induction store with + | nil => simp [entryLookupStoreWidth, encodedStoreLength] + | cons entry rest ih => + have hentry := entry_bits_le_encodedStoreLength (entry :: rest) + entry (by simp) + have hrestEncoded : encodedStoreLength rest ≀ + encodedStoreLength (entry :: rest) := by + simp [encodedStoreLength] + simp only [entryLookupStoreWidth] + apply max_le + Β· unfold entryLookupEntryWidth + apply max_le + Β· exact Nat.le_add_left _ _ + Β· apply max_le + Β· exact le_trans hentry.1 (Nat.le_add_right _ _) + Β· apply max_le + Β· exact le_trans hentry.2 (Nat.le_add_right _ _) + Β· apply max_le + Β· simpa [bitlen, Nat.size_eq_bits_len] using! + le_trans hentry.1 (Nat.le_add_right + (encodedStoreLength (entry :: rest)) address.bits.length) + Β· apply max_le + Β· simpa [bitlen, Nat.size_eq_bits_len] using! + le_trans hentry.2 (Nat.le_add_right + (encodedStoreLength (entry :: rest)) address.bits.length) + Β· have hpositive : 1 ≀ encodedStoreLength (entry :: rest) := by + rw [encodedStoreLength_eq_sums] + simp only [List.map_cons, List.sum_cons, List.length_cons] + omega + exact le_trans hpositive (Nat.le_add_right _ _) + Β· exact le_trans ih (Nat.add_le_add_right hrestEncoded _) + +private theorem entryLookupResetWidth_le_encoded + (store : Store) (address : β„•) (hcanonical : Canonical store) : + entryLookupResetWidth store address ≀ + encodedStoreLength store + address.bits.length := by + unfold entryLookupResetWidth + exact max_le (le_trans (count_bits_le_encodedStoreLength store hcanonical) + (Nat.le_add_right _ _)) + (entryLookupStoreWidth_le_encoded store address) + +private def denseLookupVolume (inputLength : β„•) (store : Store) + (address : β„•) : β„• := + encodedStoreLength store + + store.length * (bitlen address + 1) + + inputLength * (bitlen address + 1) + bitlen address + 1 + +private theorem denseLookupVolume_pos (inputLength : β„•) + (store : Store) (address : β„•) : + 1 ≀ denseLookupVolume inputLength store address := by + simp [denseLookupVolume] + +private theorem entryLookupTime_le_volume {m : β„•} + (tapes : EntryLookupRestoreTapes m) (inputLength : β„•) + (store : Store) (address : β„•) (hcanonical : Canonical store) : + entryLookupTime tapes.scan address store ≀ + 3000 * denseLookupVolume inputLength store address := by + have hscan := entryScanTime_le_encoded tapes.scan address.bits store + have hcount := address_count_width_le_encodedStoreLength store hcanonical + have hlength := store_length_le_encodedStoreLength store + have haddress : address.bits.length = bitlen address := by + simp [bitlen, Nat.size_eq_bits_len] + rw [haddress] at hscan + unfold denseLookupVolume + nlinarith + +private theorem entryLookupLoadedTime_le_volume {m : β„•} + (tapes : EntryLookupRestoreTapes m) (inputLength : β„•) + (store : Store) (address : β„•) (hcanonical : Canonical store) : + entryLookupLoadedTime tapes store address ≀ + 100000 * denseLookupVolume inputLength store address := by + let volume := denseLookupVolume inputLength store address + have hvolume : 1 ≀ volume := denseLookupVolume_pos inputLength store address + have hencoded : encodedStoreLength store ≀ volume := by + dsimp only [volume] + unfold denseLookupVolume + omega + have haddressWidth : bitlen address ≀ volume := by + dsimp only [volume] + unfold denseLookupVolume + omega + have hlookup := entryLookupTime_le_volume tapes inputLength store address + hcanonical + have hresetWidth := entryLookupResetWidth_le_encoded store address hcanonical + have hread := read_bits_le_encodedStoreLength store address + have hcount := count_bits_le_encodedStoreLength store hcanonical + have hcopyAddress := TM.binaryCopyTime_le address 0 + have hcopyRead := TM.binaryCopyTime_le + (RegisterStore.read store address) 0 + have hcopyCount := TM.binaryCopyTime_le store.length 0 + have haddress : address.size = bitlen address := rfl + have hreadSize : (RegisterStore.read store address).size = + (RegisterStore.read store address).bits.length := + (Nat.size_eq_bits_len _).symm + have hcountSize : store.length.size = store.length.bits.length := + (Nat.size_eq_bits_len _).symm + rw [haddress, Nat.size_zero] at hcopyAddress + rw [hreadSize, Nat.size_zero] at hcopyRead + rw [hcountSize, Nat.size_zero] at hcopyCount + have hhead : entryLookupRestoreHeadBound tapes store address ≀ + 3000 * volume + 1 := by + unfold entryLookupRestoreHeadBound + omega + have hreset : entryLookupResetTime tapes store address ≀ + 30000 * volume := by + unfold entryLookupResetTime + have haddressBits : address.bits.length = bitlen address := by + simp [bitlen, Nat.size_eq_bits_len] + rw [haddressBits] at hresetWidth + have hresetWidth' : entryLookupResetWidth store address ≀ + 2 * volume := le_trans hresetWidth (by omega) + omega + have htail : entryLookupRestoreTailTime tapes store address ≀ + 40000 * volume := by + unfold entryLookupRestoreTailTime + omega + have hcopyRestore : entryLookupCopyRestoreTime tapes store address ≀ + 70000 * volume := by + unfold entryLookupCopyRestoreTime + omega + unfold entryLookupLoadedTime + omega + +private theorem denseInputLookupTime_le_volume + (inputLength address : β„•) : + denseInputLookupTime inputLength address ≀ + 50 * (inputLength * (bitlen address + 1) + bitlen address + 1) := by + have hscan := denseInputScanTime_le_width inputLength address + have hcopy := TM.binaryCopyTime_le address 0 + have hsubSize : (address - inputLength).bits.length ≀ bitlen address := by + rw [Nat.size_eq_bits_len] + exact Nat.size_le_size (Nat.sub_le address inputLength) + rw [show address.size = bitlen address from rfl] at hscan + rw [show address.size = bitlen address from rfl, Nat.size_zero] at hcopy + unfold denseInputLookupTime TM.resetBinaryWorkTime TM.clearWorkTimeBound + nlinarith + +private theorem denseOverlayLookupTime_le_volume {m : β„•} + (tapes : EntryLookupRestoreTapes m) (inputLength : β„•) + (overlay : Store) (address : β„•) + (hvalid : DenseOverlay.Valid overlay) : + denseOverlayLookupTime tapes inputLength overlay address ≀ + 200000 * denseLookupVolume inputLength overlay address := by + have hvolume := denseLookupVolume_pos inputLength overlay address + have hloaded := entryLookupLoadedTime_le_volume tapes inputLength overlay + address hvalid.1 + have hfallback := denseInputLookupTime_le_volume inputLength address + have htag := read_bits_le_encodedStoreLength overlay address + have hpred := TM.binaryPredTime_le + (RegisterStore.read overlay address - 1) + have hpredSize : + (RegisterStore.read overlay address - 1 + 1).size ≀ + encodedStoreLength overlay + 1 := by + have hreadSize : (RegisterStore.read overlay address).size ≀ + encodedStoreLength overlay := by + simpa [Nat.size_eq_bits_len] using! htag + have hvalue : RegisterStore.read overlay address - 1 + 1 ≀ + RegisterStore.read overlay address + 1 := by omega + have hsize := Nat.size_le_size hvalue + have hsucc : (RegisterStore.read overlay address + 1).size ≀ + (RegisterStore.read overlay address).size + 1 := by + rw [Nat.size_le] + have hlt := Nat.lt_size_self (RegisterStore.read overlay address) + have hpow := Nat.pow_le_pow_right (by decide : 1 ≀ 2) (by + simpa [Nat.size_eq_bits_len] using! htag) + rw [pow_succ] + omega + exact le_trans hsize (le_trans hsucc (by omega)) + have hpred' : TM.binaryPredTime + (RegisterStore.read overlay address - 1) ≀ + 2 * (encodedStoreLength overlay + 1) + 2 := by + exact le_trans hpred (by omega) + have hbranch : max (denseInputLookupTime inputLength address) + (TM.binaryPredTime (RegisterStore.read overlay address - 1)) ≀ + 90000 * denseLookupVolume inputLength overlay address := by + apply max_le + Β· unfold denseLookupVolume at hvolume ⊒ + omega + Β· unfold denseLookupVolume at hvolume ⊒ + omega + unfold denseOverlayLookupTime TM.branchWorkBlankTime + omega + +private theorem size_le_self (value : β„•) : value.size ≀ value := by + rw [Nat.size_le] + exact Nat.lt_pow_self (by decide) + +private theorem bitlen_le_succ (value : β„•) : bitlen value ≀ value + 1 := by + unfold bitlen + exact le_trans (size_le_self value) (Nat.le_succ value) + +private theorem bitlen_succ_le (value : β„•) : + bitlen (value + 1) ≀ bitlen value + 1 := by + rw [bitlen, bitlen, Nat.size_le] + have hvalue := Nat.lt_size_self value + have hpowPos : 0 < 2 ^ value.size := pow_pos (by omega) _ + rw [pow_succ] + omega + +private theorem binaryAddConstTime_zero_le (fixedValue : β„•) : + TM.binaryAddConstTime fixedValue 0 ≀ 4 * (fixedValue + 1) ^ 2 := + TM.binaryAddConstTime_zero_le fixedValue + +private theorem binaryInstructionArithmeticTime_le_width + (op : BinaryInstrOp) (lhs rhs width : β„•) + (hlhs : bitlen lhs ≀ width) (hrhs : bitlen rhs ≀ width) : + binaryInstructionArithmeticTime op lhs rhs ≀ + 1000 * (width + 1) ^ 2 := by + have hlhsSize : lhs.size ≀ width := by simpa [bitlen] using! hlhs + have hrhsSize : rhs.size ≀ width := by simpa [bitlen] using! hrhs + cases op with + | add => + have htime := TM.binaryRippleAddTime_le lhs rhs + have honeSq : 1 ≀ (width + 1) ^ 2 := by nlinarith + have hwidthSq : width ≀ (width + 1) ^ 2 := by nlinarith + change TM.binaryRippleAddTime lhs rhs ≀ 1000 * (width + 1) ^ 2 + omega + | sub => + have htime := TM.binaryRippleSubTime_le lhs rhs + have honeSq : 1 ≀ (width + 1) ^ 2 := by nlinarith + have hwidthSq : width ≀ (width + 1) ^ 2 := by nlinarith + change TM.binaryRippleSubTime lhs rhs ≀ 1000 * (width + 1) ^ 2 + omega + | mul => + change TM.binaryShiftMulTime lhs rhs ≀ 1000 * (width + 1) ^ 2 + unfold TM.binaryShiftMulTime TM.binaryShiftMulWidth + nlinarith + +private theorem binaryInstrResult_bitlen_le + (op : BinaryInstrOp) (lhs rhs : β„•) : + bitlen (op.eval lhs rhs) ≀ bitlen lhs + bitlen rhs + 1 := by + unfold bitlen + cases op with + | add => + exact le_trans (TM.binaryRippleAdd_sum_size_le lhs rhs) (by omega) + | sub => + exact le_trans (Nat.size_le_size (Nat.sub_le lhs rhs)) (by omega) + | mul => + exact le_trans (BinaryShiftMul.size_mul_le_add lhs rhs) (by omega) + +private theorem denseLookupVolume_le_product + (inputLength : β„•) (store : Store) (address width : β„•) + (haddress : bitlen address ≀ width) : + denseLookupVolume inputLength store address ≀ + 4 * (encodedStoreLength store + inputLength + width + 1) * + (width + 1) := by + have hlength := store_length_le_encodedStoreLength store + have hstoreProduct : store.length * (bitlen address + 1) ≀ + encodedStoreLength store * (width + 1) := + Nat.mul_le_mul hlength (Nat.add_le_add_right haddress 1) + have hinputProduct : inputLength * (bitlen address + 1) ≀ + inputLength * (width + 1) := + Nat.mul_le_mul_left inputLength (Nat.add_le_add_right haddress 1) + unfold denseLookupVolume + nlinarith + +private theorem denseOverlayLookupTime_le_product {m : β„•} + (tapes : EntryLookupRestoreTapes m) (inputLength : β„•) + (overlay : Store) (address width : β„•) + (hvalid : DenseOverlay.Valid overlay) (haddress : bitlen address ≀ width) : + denseOverlayLookupTime tapes inputLength overlay address ≀ + 800000 * (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := by + have hlookup := denseOverlayLookupTime_le_volume tapes inputLength overlay + address hvalid + have hvolume := denseLookupVolume_le_product inputLength overlay address width + haddress + calc + denseOverlayLookupTime tapes inputLength overlay address ≀ + 200000 * denseLookupVolume inputLength overlay address := hlookup + _ ≀ 200000 * + (4 * (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1)) := Nat.mul_le_mul_left 200000 hvolume + _ = 800000 * (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := by ring + +private theorem denseOverlayLookupStaticTime_le_product {m : β„•} + (tapes : EntryLookupRestoreTapes m) (inputLength : β„•) + (overlay : Store) (address width magnitude : β„•) + (hvalid : DenseOverlay.Valid overlay) (haddress : bitlen address ≀ width) + (hfixed : address ≀ magnitude) : + denseOverlayLookupStaticTime tapes inputLength overlay address ≀ + 1000000 * (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := by + let volume := encodedStoreLength overlay + inputLength + width + 1 + let unit := (magnitude + 1) ^ 2 * volume * (width + 1) + have hvolume : 1 ≀ volume := by + dsimp only [volume] + omega + have hmagnitudeSq : 1 ≀ (magnitude + 1) ^ 2 := by nlinarith + have hunitPos : 0 < unit := by + dsimp only [unit] + positivity + have hunit : 1 ≀ unit := hunitPos + have hadd := binaryAddConstTime_zero_le address + have hadd' : TM.binaryAddConstTime address 0 ≀ 4 * unit := by + have hfixedSq : (address + 1) ^ 2 ≀ (magnitude + 1) ^ 2 := + Nat.pow_le_pow_left (Nat.add_le_add_right hfixed 1) 2 + have hfactor : (magnitude + 1) ^ 2 ≀ unit := by + dsimp only [unit] + calc + (magnitude + 1) ^ 2 = (magnitude + 1) ^ 2 * 1 * 1 := by ring + _ ≀ (magnitude + 1) ^ 2 * volume * (width + 1) := + Nat.mul_le_mul (Nat.mul_le_mul_left _ hvolume) (by omega) + exact le_trans hadd (by nlinarith) + have hlookup := denseOverlayLookupTime_le_product tapes inputLength overlay + address width hvalid haddress + have hlookup' : denseOverlayLookupTime tapes inputLength overlay address ≀ + 800000 * unit := by + have hbase : volume * (width + 1) ≀ unit := by + dsimp only [unit] + calc + volume * (width + 1) = (1 * volume) * (width + 1) := by simp + _ ≀ ((magnitude + 1) ^ 2 * volume) * (width + 1) := + Nat.mul_le_mul_right (width + 1) + (Nat.mul_le_mul_right volume hmagnitudeSq) + calc + denseOverlayLookupTime tapes inputLength overlay address ≀ + 800000 * (volume * (width + 1)) := by + simpa only [volume, Nat.mul_assoc] using! hlookup + _ ≀ 800000 * unit := Nat.mul_le_mul_left 800000 hbase + have hreset : TM.resetBinaryWorkTime 1 address.bits.length ≀ + 2 * width + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + simpa [bitlen, Nat.size_eq_bits_len] using! + (show 1 + 2 + 1 + (2 * bitlen address + 5) ≀ + 2 * width + 9 by omega) + have hwidthUnit : width + 1 ≀ unit := by + dsimp only [unit] + calc + width + 1 = (1 * 1) * (width + 1) := by simp + _ ≀ ((magnitude + 1) ^ 2 * volume) * (width + 1) := + Nat.mul_le_mul_right (width + 1) (Nat.mul_le_mul hmagnitudeSq hvolume) + have hreset' : TM.resetBinaryWorkTime 1 address.bits.length ≀ + 11 * unit := le_trans hreset (by nlinarith) + unfold denseOverlayLookupStaticTime + calc + TM.binaryAddConstTime address 0 + 1 + + (denseOverlayLookupTime tapes inputLength overlay address + 1 + + TM.resetBinaryWorkTime 1 address.bits.length) ≀ + 1000000 * unit := by omega + _ = 1000000 * (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := by + dsimp only [unit, volume] + ring + +private theorem taggedEntryUpdateTime_le_product {m : β„•} + (tapes : EntryUpdateTapes m) (inputLength : β„•) + (overlay : Store) (address value width : β„•) + (hcanonical : Canonical overlay) (haddress : bitlen address ≀ width) + (hvalue : bitlen value ≀ width) : + taggedEntryUpdateTime tapes overlay address value ≀ + 20000 * (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := by + let volume := encodedStoreLength overlay + inputLength + width + 1 + have hvolume : 1 ≀ volume := by + dsimp only [volume] + omega + have hencoded : encodedStoreLength overlay ≀ volume := by + dsimp only [volume] + omega + have hwidthVolume : width + 1 ≀ volume := by + dsimp only [volume] + omega + have hvolumeFactor : volume ≀ volume * (width + 1) := by + calc + volume = volume * 1 := by simp + _ ≀ volume * (width + 1) := Nat.mul_le_mul_left volume (by omega) + have hlengthEncoded := store_length_le_encodedStoreLength overlay + have hlength : overlay.length ≀ volume := le_trans hlengthEncoded hencoded + have hcountBits := count_bits_le_encodedStoreLength overlay hcanonical + have hcount : bitlen overlay.length ≀ encodedStoreLength overlay := by + simpa [bitlen, Nat.size_eq_bits_len] using! hcountBits + have hcountProduct := + address_count_width_le_encodedStoreLength overlay hcanonical + have htag : bitlen (value + 1) ≀ width + 1 := + le_trans (bitlen_succ_le value) (Nat.add_le_add_right hvalue 1) + have hlengthAddress : overlay.length * bitlen address ≀ + volume * width := Nat.mul_le_mul hlength haddress + have hlengthTag : overlay.length * bitlen (value + 1) ≀ + volume * (width + 1) := Nat.mul_le_mul hlength htag + have hupdate := entryUpdateTime_le_encoded tapes overlay address (value + 1) + have hupdateVolume : entryUpdateTime tapes overlay address (value + 1) ≀ + 12000 * volume * (width + 1) := by + calc + entryUpdateTime tapes overlay address (value + 1) ≀ + 1000 * (encodedStoreLength overlay + + (overlay.length + 1) * + (bitlen address + bitlen (value + 1) + + bitlen overlay.length + 1) + 1) := hupdate + _ ≀ 1000 * (12 * volume * (width + 1)) := by + apply Nat.mul_le_mul_left 1000 + rw [show (overlay.length + 1) * + (bitlen address + bitlen (value + 1) + bitlen overlay.length + 1) = + overlay.length * bitlen address + + overlay.length * bitlen (value + 1) + + overlay.length * bitlen overlay.length + overlay.length + + bitlen address + bitlen (value + 1) + + bitlen overlay.length + 1 by ring] + dsimp only [volume] at hvolumeFactor ⊒ + nlinarith + _ = 12000 * volume * (width + 1) := by ring + have hsucc := TM.binarySuccTime_le value + have hsucc' : TM.binarySuccTime value ≀ + 3 * volume * (width + 1) := by + have hsize : value.size ≀ width := by simpa [bitlen] using! hvalue + exact le_trans hsucc (by nlinarith) + unfold taggedEntryUpdateTime + dsimp only [volume] at hupdateVolume hsucc' ⊒ + nlinarith + +private def denseResourceUnit (magnitude inputLength : β„•) + (overlay : Store) (width : β„•) : β„• := + (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + inputLength + width + 1) * (width + 1) + +private theorem denseResourceUnit_pos (magnitude inputLength : β„•) + (overlay : Store) (width : β„•) : + 1 ≀ denseResourceUnit magnitude inputLength overlay width := by + have hpos : 0 < denseResourceUnit magnitude inputLength overlay width := by + unfold denseResourceUnit + positivity + omega + +private theorem denseResourceBase_le_unit (magnitude inputLength : β„•) + (overlay : Store) (width : β„•) : + (encodedStoreLength overlay + inputLength + width + 1) * (width + 1) ≀ + denseResourceUnit magnitude inputLength overlay width := by + unfold denseResourceUnit + have hmagnitudePos : 0 < (magnitude + 1) ^ 2 := pow_pos (by omega) _ + have hmagnitude : 1 ≀ (magnitude + 1) ^ 2 := by omega + calc + (encodedStoreLength overlay + inputLength + width + 1) * (width + 1) = + (1 * (encodedStoreLength overlay + inputLength + width + 1)) * + (width + 1) := by simp + _ ≀ ((magnitude + 1) ^ 2 * + (encodedStoreLength overlay + inputLength + width + 1)) * + (width + 1) := Nat.mul_le_mul_right (width + 1) + (Nat.mul_le_mul_right _ hmagnitude) + +private theorem denseResourceVolume_le_unit (magnitude inputLength : β„•) + (overlay : Store) (width : β„•) : + encodedStoreLength overlay + inputLength + width + 1 ≀ + denseResourceUnit magnitude inputLength overlay width := by + exact le_trans (by + have := Nat.mul_le_mul_left + (encodedStoreLength overlay + inputLength + width + 1) + (show 1 ≀ width + 1 by omega) + simpa only [Nat.mul_one] using! this) + (denseResourceBase_le_unit magnitude inputLength overlay width) + +private theorem denseResourceWidthSq_le_unit (magnitude inputLength : β„•) + (overlay : Store) (width : β„•) : + (width + 1) ^ 2 ≀ + denseResourceUnit magnitude inputLength overlay width := by + apply le_trans _ (denseResourceBase_le_unit magnitude inputLength overlay width) + calc + (width + 1) ^ 2 = (width + 1) * (width + 1) := by ring + _ ≀ (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := Nat.mul_le_mul_right (width + 1) (by omega) + +private theorem denseResourceMagnitudeSq_le_unit + (magnitude inputLength : β„•) (overlay : Store) (width : β„•) : + (magnitude + 1) ^ 2 ≀ + denseResourceUnit magnitude inputLength overlay width := by + unfold denseResourceUnit + calc + (magnitude + 1) ^ 2 = (magnitude + 1) ^ 2 * 1 * 1 := by ring + _ ≀ (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + inputLength + width + 1) * + (width + 1) := Nat.mul_le_mul + (Nat.mul_le_mul_left _ (by omega)) (by omega) +/-- Shared copying, lookup, update, and program-counter costs fit the resource unit. -/ +private theorem denseInstruction_resourceBounds + {m : β„•} (tapes : ControlInstructionTapes m) (input : List Bool) + (pcValue : β„•) (overlay : Store) (width magnitude : β„•) + (hvalid : DenseOverlay.Valid overlay) + (hpc : pcValue ≀ magnitude) : + let unit := denseResourceUnit magnitude input.length overlay width + (1 ≀ unit) ∧ + ((encodedStoreLength overlay + input.length + width + 1) * + (width + 1) ≀ unit) ∧ + (encodedStoreLength overlay + input.length + width + 1 ≀ + unit) ∧ + ((width + 1) ^ 2 ≀ unit) ∧ + ((magnitude + 1) ^ 2 ≀ unit) ∧ + (encodedStoreLength overlay ≀ unit) ∧ + ((overlay.flatMap Entry.encode).length ≀ unit) ∧ + (βˆ€ fixedValue, fixedValue ≀ magnitude β†’ + TM.binaryAddConstTime fixedValue 0 ≀ 4 * unit) ∧ + (βˆ€ address, bitlen address ≀ width β†’ + address ≀ magnitude β†’ + denseOverlayLookupStaticTime tapes.data.lhsLookup input.length overlay + address ≀ 1000000 * unit) ∧ + (βˆ€ address, bitlen address ≀ width β†’ + address ≀ magnitude β†’ + denseOverlayLookupStaticTime tapes.data.rhsLookup input.length overlay + address ≀ 1000000 * unit) ∧ + (βˆ€ address, bitlen address ≀ width β†’ + denseOverlayLookupTime tapes.data.indirectLoadLookup input.length overlay + address ≀ 800000 * unit) ∧ + (βˆ€ address value, + bitlen address ≀ width β†’ bitlen value ≀ width β†’ + taggedEntryUpdateTime tapes.data.update overlay address value ≀ + 20000 * unit) ∧ + (βˆ€ op lhs rhs, bitlen lhs ≀ width β†’ + bitlen rhs ≀ width β†’ + binaryInstructionArithmeticTime op lhs rhs ≀ 1000 * unit) ∧ + (βˆ€ value, bitlen value ≀ width β†’ + TM.binaryCopyTime value 0 ≀ 23 * unit) ∧ + (βˆ€ value, bitlen value ≀ width β†’ + TM.resetBinaryWorkTime 1 value.bits.length ≀ 11 * unit) ∧ + (pcValue.size ≀ magnitude) ∧ + (TM.binarySuccTime pcValue ≀ 2 * pcValue.size + 2) ∧ + (TM.binarySuccTime pcValue ≀ 4 * unit) ∧ + (TM.resetBinaryWorkTime 1 pcValue.bits.length ≀ + 11 * unit) := by + dsimp only + let unit := denseResourceUnit magnitude input.length overlay width + have hunit : 1 ≀ unit := denseResourceUnit_pos magnitude input.length + overlay width + have hbase : (encodedStoreLength overlay + input.length + width + 1) * + (width + 1) ≀ unit := denseResourceBase_le_unit magnitude input.length + overlay width + have hvolume : encodedStoreLength overlay + input.length + width + 1 ≀ + unit := denseResourceVolume_le_unit magnitude input.length overlay width + have hwidthSq : (width + 1) ^ 2 ≀ unit := + denseResourceWidthSq_le_unit magnitude input.length overlay width + have hmagnitudeSq : (magnitude + 1) ^ 2 ≀ unit := + denseResourceMagnitudeSq_le_unit magnitude input.length overlay width + have hencoded : encodedStoreLength overlay ≀ unit := by + exact le_trans (by omega) hvolume + have hencodedBits : (overlay.flatMap Entry.encode).length ≀ unit := by + simpa only [encodedStoreLength] using! hencoded + have hfixedAdd : βˆ€ fixedValue, fixedValue ≀ magnitude β†’ + TM.binaryAddConstTime fixedValue 0 ≀ 4 * unit := by + intro fixedValue hconstant + have hadd := binaryAddConstTime_zero_le fixedValue + have hsquare : (fixedValue + 1) ^ 2 ≀ (magnitude + 1) ^ 2 := + Nat.pow_le_pow_left (Nat.add_le_add_right hconstant 1) 2 + exact le_trans hadd (by nlinarith) + have hstaticLookup : βˆ€ address, bitlen address ≀ width β†’ + address ≀ magnitude β†’ + denseOverlayLookupStaticTime tapes.data.lhsLookup input.length overlay + address ≀ 1000000 * unit := by + intro address haddress haddressFixed + have hlookup := denseOverlayLookupStaticTime_le_product + tapes.data.lhsLookup input.length overlay address width magnitude hvalid + haddress haddressFixed + calc + denseOverlayLookupStaticTime tapes.data.lhsLookup input.length overlay + address ≀ 1000000 * (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + input.length + width + 1) * + (width + 1) := hlookup + _ = 1000000 * unit := by + dsimp only [unit, denseResourceUnit] + ring + have hstaticLookupRhs : βˆ€ address, bitlen address ≀ width β†’ + address ≀ magnitude β†’ + denseOverlayLookupStaticTime tapes.data.rhsLookup input.length overlay + address ≀ 1000000 * unit := by + intro address haddress haddressFixed + have hlookup := denseOverlayLookupStaticTime_le_product + tapes.data.rhsLookup input.length overlay address width magnitude hvalid + haddress haddressFixed + calc + denseOverlayLookupStaticTime tapes.data.rhsLookup input.length overlay + address ≀ 1000000 * (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + input.length + width + 1) * + (width + 1) := hlookup + _ = 1000000 * unit := by + dsimp only [unit, denseResourceUnit] + ring + have hdynamicLookup : βˆ€ address, bitlen address ≀ width β†’ + denseOverlayLookupTime tapes.data.indirectLoadLookup input.length overlay + address ≀ 800000 * unit := by + intro address haddress + have hlookup := denseOverlayLookupTime_le_product + tapes.data.indirectLoadLookup input.length overlay address width hvalid + haddress + calc + denseOverlayLookupTime tapes.data.indirectLoadLookup input.length overlay + address ≀ 800000 * + ((encodedStoreLength overlay + input.length + width + 1) * + (width + 1)) := by simpa only [Nat.mul_assoc] using! hlookup + _ ≀ 800000 * unit := Nat.mul_le_mul_left 800000 hbase + have htaggedUpdate : βˆ€ address value, + bitlen address ≀ width β†’ bitlen value ≀ width β†’ + taggedEntryUpdateTime tapes.data.update overlay address value ≀ + 20000 * unit := by + intro address value haddress hvalue + have hupdate := taggedEntryUpdateTime_le_product tapes.data.update + input.length overlay address value width hvalid.1 haddress hvalue + calc + taggedEntryUpdateTime tapes.data.update overlay address value ≀ + 20000 * ((encodedStoreLength overlay + input.length + width + 1) * + (width + 1)) := by simpa only [Nat.mul_assoc] using! hupdate + _ ≀ 20000 * unit := Nat.mul_le_mul_left 20000 hbase + have harithmetic : βˆ€ op lhs rhs, bitlen lhs ≀ width β†’ + bitlen rhs ≀ width β†’ + binaryInstructionArithmeticTime op lhs rhs ≀ 1000 * unit := by + intro op lhs rhs hlhs hrhs + exact le_trans (binaryInstructionArithmeticTime_le_width op lhs rhs width + hlhs hrhs) (Nat.mul_le_mul_left 1000 hwidthSq) + have hcopy : βˆ€ value, bitlen value ≀ width β†’ + TM.binaryCopyTime value 0 ≀ 23 * unit := by + intro value hvalue + have htime := TM.binaryCopyTime_le value 0 + have hsize : value.size ≀ width := by simpa [bitlen] using! hvalue + rw [Nat.size_zero] at htime + exact le_trans htime (by nlinarith) + have hreset : βˆ€ value, bitlen value ≀ width β†’ + TM.resetBinaryWorkTime 1 value.bits.length ≀ 11 * unit := by + intro value hvalue + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + have hbits : value.bits.length ≀ width := by + simpa [bitlen, Nat.size_eq_bits_len] using! hvalue + nlinarith + have hpcSize : pcValue.size ≀ magnitude := + le_trans (size_le_self pcValue) hpc + have hpcSucc := TM.binarySuccTime_le pcValue + have hpcSucc' : TM.binarySuccTime pcValue ≀ 4 * unit := + le_trans hpcSucc (by nlinarith) + have hpcReset : TM.resetBinaryWorkTime 1 pcValue.bits.length ≀ + 11 * unit := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + have hbits : pcValue.bits.length ≀ magnitude := by + simpa [Nat.size_eq_bits_len] using! hpcSize + nlinarith + exact ⟨hunit, hbase, hvolume, hwidthSq, hmagnitudeSq, hencoded, hencodedBits, + hfixedAdd, hstaticLookup, hstaticLookupRhs, hdynamicLookup, htaggedUpdate, + harithmetic, hcopy, hreset, hpcSize, hpcSucc, hpcSucc', hpcReset⟩ + +/-- The conditional jump cost is bounded after reading and clearing its test register. -/ +private theorem denseExecuteZeroJumpTime_le_product + {m : β„•} (tapes : ControlInstructionTapes m) (input : List Bool) + (pcValue : β„•) (overlay : Store) (width magnitude : β„•) + (hvalid : DenseOverlay.Valid overlay) + (source target : β„•) + (hstatic : RegisterStore.Instr.staticWidth (.jz source target) ≀ width) + (hcost : (Instr.jz source target).logCost + (DenseOverlay.Snapshot.decode input { pc := pcValue, overlay }) ≀ width) + (hfixed : instructionResourceMagnitude (.jz source target) ≀ magnitude) + (hpc : pcValue ≀ magnitude) : + denseExecuteInstructionTime tapes input (.jz source target) pcValue overlay ≀ + 6000000 * denseResourceUnit magnitude input.length overlay width := by + let unit := denseResourceUnit magnitude input.length overlay width + obtain ⟨hunit, hbase, hvolume, hwidthSq, hmagnitudeSq, hencoded, hencodedBits, + hfixedAdd, hstaticLookup, hstaticLookupRhs, hdynamicLookup, htaggedUpdate, + harithmetic, hcopy, hreset, hpcSize, hpcSucc, hpcSucc', hpcReset⟩ := + denseInstruction_resourceBounds tapes input pcValue overlay width magnitude hvalid hpc + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hsourceWidth : bitlen source ≀ width := + le_trans (le_max_left _ _) hstatic + have hvalue : bitlen (DenseOverlay.read input overlay source) ≀ width := + by omega + have hlookupRaw := denseOverlayLookupStaticTime_le_product + tapes.lifted.data.lhsLookup input.length overlay source width magnitude + hvalid hsourceWidth (by omega) + have hlookup : denseOverlayLookupStaticTime + tapes.lifted.data.lhsLookup input.length overlay source ≀ + 1000000 * unit := by + calc + denseOverlayLookupStaticTime tapes.lifted.data.lhsLookup input.length + overlay source ≀ 1000000 * (magnitude + 1) ^ 2 * + (encodedStoreLength overlay + input.length + width + 1) * + (width + 1) := hlookupRaw + _ = 1000000 * unit := by + dsimp only [unit, denseResourceUnit] + ring + have htargetAdd := hfixedAdd target (by omega) + have hset : setProgramCounterTime pcValue target ≀ 16 * unit := by + unfold setProgramCounterTime + omega + have hbranch : max (setProgramCounterTime pcValue target) + (TM.binarySuccTime pcValue) ≀ 16 * unit := + max_le hset (by omega) + have hresetValue := hreset (DenseOverlay.read input overlay source) hvalue + simp only [denseExecuteInstructionTime, denseZeroJumpInstructionTime, + TM.branchWorkBlankTime] + omega + +private theorem denseExecuteInstructionTime_le_product {m : β„•} + (tapes : ControlInstructionTapes m) (input : List Bool) + (instruction : Instr) (pcValue : β„•) (overlay : Store) + (width magnitude : β„•) (hvalid : DenseOverlay.Valid overlay) + (hstatic : RegisterStore.Instr.staticWidth instruction ≀ width) + (hcost : instruction.logCost + (DenseOverlay.Snapshot.decode input { pc := pcValue, overlay }) ≀ width) + (hfixed : instructionResourceMagnitude instruction ≀ magnitude) + (hpc : pcValue ≀ magnitude) : + denseExecuteInstructionTime tapes input instruction pcValue overlay ≀ + 6000000 * denseResourceUnit magnitude input.length overlay width := by + let unit := denseResourceUnit magnitude input.length overlay width + obtain ⟨hunit, hbase, hvolume, hwidthSq, hmagnitudeSq, hencoded, hencodedBits, + hfixedAdd, hstaticLookup, hstaticLookupRhs, hdynamicLookup, htaggedUpdate, + harithmetic, hcopy, hreset, hpcSize, hpcSucc, hpcSucc', hpcReset⟩ := + denseInstruction_resourceBounds tapes input pcValue overlay width magnitude hvalid hpc + cases instruction with + | imm destination value => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost] at hcost + have hdestinationWidth : bitlen destination ≀ width := + le_trans (le_max_left _ _) hstatic + have hvalueWidth : bitlen value ≀ width := by omega + have hvalueAdd := hfixedAdd value (by omega) + have hdestinationAdd := hfixedAdd destination (by omega) + have hupdate := htaggedUpdate destination value hdestinationWidth hvalueWidth + simp only [denseExecuteInstructionTime, denseImmediateInstructionTime] + omega + | add destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hdestinationWidth : bitlen destination ≀ width := + le_trans (le_max_left _ _) hstatic + have hsourceβ‚€Width : bitlen sourceβ‚€ ≀ width := + le_trans (le_max_left _ _) (le_trans (le_max_right _ _) hstatic) + have hsource₁Width : bitlen source₁ ≀ width := + le_trans (le_max_right _ _) (le_trans (le_max_right _ _) hstatic) + have hlhs : bitlen (DenseOverlay.read input overlay sourceβ‚€) ≀ width := + by omega + have hrhs : bitlen (DenseOverlay.read input overlay source₁) ≀ width := + by omega + have hresult : bitlen (DenseOverlay.read input overlay sourceβ‚€ + + DenseOverlay.read input overlay source₁) ≀ width := by omega + have hlookupβ‚€ := hstaticLookup sourceβ‚€ hsourceβ‚€Width (by omega) + have hlookup₁ := hstaticLookupRhs source₁ hsource₁Width (by omega) + have hadd := hfixedAdd destination (by omega) + have hop := harithmetic .add (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) hlhs hrhs + have hupdate := htaggedUpdate destination + (DenseOverlay.read input overlay sourceβ‚€ + + DenseOverlay.read input overlay source₁) + hdestinationWidth hresult + simp only [denseExecuteInstructionTime, denseDirectBinaryInstructionTime, + denseBinaryInstructionUpdateTime, BinaryInstrOp.eval] + omega + | sub destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hdestinationWidth : bitlen destination ≀ width := + le_trans (le_max_left _ _) hstatic + have hsourceβ‚€Width : bitlen sourceβ‚€ ≀ width := + le_trans (le_max_left _ _) (le_trans (le_max_right _ _) hstatic) + have hsource₁Width : bitlen source₁ ≀ width := + le_trans (le_max_right _ _) (le_trans (le_max_right _ _) hstatic) + have hlhs : bitlen (DenseOverlay.read input overlay sourceβ‚€) ≀ width := + by omega + have hrhs : bitlen (DenseOverlay.read input overlay source₁) ≀ width := + by omega + have hresultRaw := binaryInstrResult_bitlen_le .sub + (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) + have hresult : bitlen (DenseOverlay.read input overlay sourceβ‚€ - + DenseOverlay.read input overlay source₁) ≀ width := + le_trans hresultRaw (by omega) + have hlookupβ‚€ := hstaticLookup sourceβ‚€ hsourceβ‚€Width (by omega) + have hlookup₁ := hstaticLookupRhs source₁ hsource₁Width (by omega) + have hadd := hfixedAdd destination (by omega) + have hop := harithmetic .sub (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) hlhs hrhs + have hupdate := htaggedUpdate destination + (DenseOverlay.read input overlay sourceβ‚€ - + DenseOverlay.read input overlay source₁) + hdestinationWidth hresult + simp only [denseExecuteInstructionTime, denseDirectBinaryInstructionTime, + denseBinaryInstructionUpdateTime, BinaryInstrOp.eval] + omega + | mul destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hdestinationWidth : bitlen destination ≀ width := + le_trans (le_max_left _ _) hstatic + have hsourceβ‚€Width : bitlen sourceβ‚€ ≀ width := + le_trans (le_max_left _ _) (le_trans (le_max_right _ _) hstatic) + have hsource₁Width : bitlen source₁ ≀ width := + le_trans (le_max_right _ _) (le_trans (le_max_right _ _) hstatic) + have hlhs : bitlen (DenseOverlay.read input overlay sourceβ‚€) ≀ width := + by omega + have hrhs : bitlen (DenseOverlay.read input overlay source₁) ≀ width := + by omega + have hresult : bitlen (DenseOverlay.read input overlay sourceβ‚€ * + DenseOverlay.read input overlay source₁) ≀ width := by omega + have hlookupβ‚€ := hstaticLookup sourceβ‚€ hsourceβ‚€Width (by omega) + have hlookup₁ := hstaticLookupRhs source₁ hsource₁Width (by omega) + have hadd := hfixedAdd destination (by omega) + have hop := harithmetic .mul (DenseOverlay.read input overlay sourceβ‚€) + (DenseOverlay.read input overlay source₁) hlhs hrhs + have hupdate := htaggedUpdate destination + (DenseOverlay.read input overlay sourceβ‚€ * + DenseOverlay.read input overlay source₁) + hdestinationWidth hresult + simp only [denseExecuteInstructionTime, denseDirectBinaryInstructionTime, + denseBinaryInstructionUpdateTime, BinaryInstrOp.eval] + omega + | load destination addressRegister => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hdestinationWidth : bitlen destination ≀ width := + le_trans (le_max_left _ _) hstatic + have hregisterWidth : bitlen addressRegister ≀ width := + le_trans (le_max_right _ _) hstatic + have haddress : bitlen + (DenseOverlay.read input overlay addressRegister) ≀ width := by omega + have hvalue : bitlen (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister)) ≀ width := by omega + have hlookup := hstaticLookup addressRegister hregisterWidth (by omega) + have hindirect := hdynamicLookup + (DenseOverlay.read input overlay addressRegister) haddress + have hadd := hfixedAdd destination (by omega) + have hupdate := htaggedUpdate destination + (DenseOverlay.read input overlay + (DenseOverlay.read input overlay addressRegister)) + hdestinationWidth hvalue + simp only [denseExecuteInstructionTime, denseIndirectLoadInstructionTime] + omega + | store addressRegister source => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [instructionResourceMagnitude] at hfixed + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + have hregisterWidth : bitlen addressRegister ≀ width := + le_trans (le_max_left _ _) hstatic + have hsourceWidth : bitlen source ≀ width := + le_trans (le_max_right _ _) hstatic + have haddress : bitlen + (DenseOverlay.read input overlay addressRegister) ≀ width := by omega + have hvalue : bitlen (DenseOverlay.read input overlay source) ≀ width := + by omega + have hlookupAddress := hstaticLookup addressRegister hregisterWidth + (by omega) + have hlookupValue := hstaticLookupRhs source hsourceWidth (by omega) + have hcopyAddress := hcopy + (DenseOverlay.read input overlay addressRegister) haddress + have hcopyValue := hcopy (DenseOverlay.read input overlay source) hvalue + have hupdate := htaggedUpdate + (DenseOverlay.read input overlay addressRegister) + (DenseOverlay.read input overlay source) haddress hvalue + simp only [denseExecuteInstructionTime, denseIndirectStoreInstructionTime] + omega + | jz source target => + exact denseExecuteZeroJumpTime_le_product tapes input pcValue overlay + width magnitude hvalid source target hstatic hcost hfixed hpc + | jmp target => + simp only [instructionResourceMagnitude] at hfixed + have htargetAdd := hfixedAdd target (by omega) + have hset : setProgramCounterTime pcValue target ≀ 16 * unit := by + unfold setProgramCounterTime + omega + simp only [denseExecuteInstructionTime, jumpInstructionTime] + omega + | halt => + simp only [denseExecuteInstructionTime, haltInstructionTime] + omega + +private theorem dispatchWithTime_le_selected {m : β„•} + (tapes : ControlInstructionTapes m) (executeTime : Instr β†’ β„•) + (program : Program) (selector : β„•) : + dispatchWithTime tapes executeTime program selector ≀ + executeTime (selectedInstruction program selector) + + 20 * (selector + 1) ^ 2 + 20 := by + induction program generalizing selector with + | nil => + have hsize := size_le_self selector + simp only [dispatchWithTime, selectedInstruction] + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + rw [Nat.size_eq_bits_len] + nlinarith + | cons instruction rest ih => + cases selector with + | zero => + simp [dispatchWithTime, selectedInstruction] + | succ selector => + have htail := ih selector + have hpred := TM.binaryPredTime_le selector + have hsize := size_le_self (selector + 1) + simp only [dispatchWithTime, selectedInstruction] + nlinarith + +private theorem selectedInstructionResourceMagnitude_le + (program : Program) (selector : β„•) : + instructionResourceMagnitude (selectedInstruction program selector) ≀ + programResourceMagnitude program := by + induction program generalizing selector with + | nil => simp [selectedInstruction, instructionResourceMagnitude, + programResourceMagnitude] + | cons instruction rest ih => + cases selector with + | zero => + simp only [selectedInstruction, programResourceMagnitude, + List.length_cons, List.map_cons, List.sum_cons] + omega + | succ selector => + have htail := ih selector + simp only [selectedInstruction, programResourceMagnitude, + List.length_cons, List.map_cons, List.sum_cons] + unfold programResourceMagnitude at htail + omega + +private theorem selectedInstructionStaticWidth_le + (program : Program) (selector : β„•) : + RegisterStore.Instr.staticWidth (selectedInstruction program selector) ≀ + programStaticWidth program := by + induction program generalizing selector with + | nil => simp [selectedInstruction, RegisterStore.Instr.staticWidth, + programStaticWidth] + | cons instruction rest ih => + cases selector with + | zero => simp [selectedInstruction, programStaticWidth] + | succ selector => + exact le_trans (ih selector) (by + simp [programStaticWidth]) +private theorem denseProgramInstructionTime_le_product {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramInstructionTime tapes program input snapshot.pc + snapshot.overlay ≀ + 7000000 * denseResourceUnit (programResourceMagnitude program) + input.length snapshot.overlay (denseStepWidth program input snapshot) := by + let width := denseStepWidth program input snapshot + let magnitude := programResourceMagnitude program + let unit := denseResourceUnit magnitude input.length snapshot.overlay width + let instruction := selectedInstruction program snapshot.pc + have hunit : 1 ≀ unit := denseResourceUnit_pos magnitude input.length + snapshot.overlay width + have hmagnitudeSq : (magnitude + 1) ^ 2 ≀ unit := + denseResourceMagnitudeSq_le_unit magnitude input.length snapshot.overlay width + have hstatic : RegisterStore.Instr.staticWidth instruction ≀ width := by + exact le_trans (selectedInstructionStaticWidth_le program snapshot.pc) (by + unfold width denseStepWidth + omega) + have hselectedCost : instruction.logCost (snapshot.decode input) = + RAM.stepLogCost program (snapshot.decode input) := by + unfold instruction RAM.stepLogCost RAM.curInstr + rw [selectedInstruction_eq_getElem?_getD] + simp [DenseOverlay.Snapshot.decode] + have hcost : instruction.logCost (snapshot.decode input) ≀ width := by + rw [hselectedCost] + unfold width denseStepWidth + omega + have hfixed : instructionResourceMagnitude instruction ≀ magnitude := by + exact selectedInstructionResourceMagnitude_le program snapshot.pc + have hexecute := denseExecuteInstructionTime_le_product tapes input instruction + snapshot.pc snapshot.overlay width magnitude hvalid hstatic hcost hfixed (by + simpa only [magnitude] using! hpc) + have hdispatchRaw := dispatchWithTime_le_selected tapes + (fun current => denseExecuteInstructionTime tapes input current snapshot.pc + snapshot.overlay) program snapshot.pc + have hselectorSquare : (snapshot.pc + 1) ^ 2 ≀ + (magnitude + 1) ^ 2 := + Nat.pow_le_pow_left (Nat.add_le_add_right (by + simpa only [magnitude] using! hpc) 1) 2 + have hdispatch : denseDispatchProgramTime tapes input snapshot.overlay + snapshot.pc program snapshot.pc ≀ 6100000 * unit := by + unfold denseDispatchProgramTime + apply le_trans hdispatchRaw + dsimp only [instruction] at hexecute ⊒ + nlinarith + have hcopyRaw := TM.binaryCopyTime_le snapshot.pc 0 + have hpcSize : snapshot.pc.size ≀ magnitude := + le_trans (size_le_self snapshot.pc) (by simpa only [magnitude] using! hpc) + have hcopy : TM.binaryCopyTime snapshot.pc 0 ≀ 23 * unit := by + rw [Nat.size_zero] at hcopyRaw + exact le_trans hcopyRaw (by nlinarith) + unfold denseProgramInstructionTime + dsimp only [unit, width, magnitude] at hdispatch hcopy hunit ⊒ + omega + +private theorem bufferedCleanupTime_le_linear {m : β„•} + (tapes : ControlInstructionTapes m) (oldStore nextStore : Store) + (cleanupValues : Fin 5 β†’ β„•) (remainingValue sourceHeadBound bound : β„•) + (hsource : 1 ≀ sourceHeadBound) + (hcleanup : βˆ€ slot, (cleanupValues slot).bits.length ≀ bound) + (hremaining : remainingValue.bits.length ≀ bound) + (hold : encodedStoreLength oldStore ≀ bound) + (hnext : encodedStoreLength nextStore ≀ bound) : + bufferedCleanupTime tapes oldStore nextStore cleanupValues remainingValue + sourceHeadBound ≀ + 100 * (sourceHeadBound + bound + 1) := by + let nextBits := nextStore.flatMap Entry.encode + have hreset := TM.resetBinaryWorkManyTime_le + (instructionCleanupResetTargets tapes) + (bufferedCleanupResetBitsAt tapes cleanupValues remainingValue oldStore) + (instructionCleanupResetHeadBoundAt tapes sourceHeadBound) + sourceHeadBound bound + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + rw [instructionCleanupResetHeadBoundAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + fin_cases slot <;> + simp [instructionCleanupResetHeadBound, hsource]) + (by + intro i hi + obtain ⟨slot, rfl⟩ := List.mem_ofFn.mp hi + rw [bufferedCleanupResetBitsAt, + (instructionCleanupResetTape_injective tapes).extend_apply] + fin_cases slot + Β· simpa [bufferedCleanupResetBits] using! hcleanup 0 + Β· simpa [bufferedCleanupResetBits] using! hcleanup 1 + Β· simpa [bufferedCleanupResetBits] using! hcleanup 2 + Β· simpa [bufferedCleanupResetBits] using! hcleanup 3 + Β· simpa [bufferedCleanupResetBits] using! hcleanup 4 + Β· simpa [bufferedCleanupResetBits] using! hremaining + Β· simpa [bufferedCleanupResetBits, encodedStoreLength] using! hold) + have htargets : (instructionCleanupResetTargets tapes).length = 7 := by + simp [instructionCleanupResetTargets] + rw [htargets] at hreset + have hnextBits : nextBits.length ≀ bound := by + simpa only [nextBits, encodedStoreLength] using! hnext + have hnextLength : nextStore.length ≀ bound := + le_trans (store_length_le_encodedStoreLength nextStore) hnext + have hresetNext : TM.resetBinaryWorkTime (nextBits.length + 1) + nextBits.length ≀ 3 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hcopyRaw := TM.binaryCopyTime_le nextStore.length 0 + have hcopy : TM.binaryCopyTime nextStore.length 0 ≀ 3 * bound + 20 := by + rw [Nat.size_zero] at hcopyRaw + exact le_trans hcopyRaw (by + have hsize := le_trans (size_le_self nextStore.length) hnextLength + omega) + unfold bufferedCleanupTime + dsimp only [nextBits] at hnextBits hresetNext ⊒ + omega + +private theorem denseInstructionCleanupValue_bits_le + (input : List Bool) (instruction : Instr) (pcValue : β„•) + (overlay : Store) (width : β„•) + (hstatic : RegisterStore.Instr.staticWidth instruction ≀ width) + (hcost : instruction.logCost + (DenseOverlay.Snapshot.decode input { pc := pcValue, overlay }) ≀ width) : + βˆ€ slot, (denseInstructionCleanupValue input instruction overlay slot).bits.length + ≀ width + 1 := by + have hbits (value : β„•) (hvalue : bitlen value ≀ width + 1) : + value.bits.length ≀ width + 1 := by + simpa [bitlen, Nat.size_eq_bits_len] using! hvalue + cases instruction with + | imm destination value => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost] at hcost + have hdestination : bitlen destination ≀ width + 1 := by omega + have htag : bitlen (value + 1) ≀ width + 1 := + le_trans (bitlen_succ_le value) (by omega) + intro slot + fin_cases slot + Β· exact hbits destination hdestination + Β· exact hbits (value + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· simp [denseInstructionCleanupValue] + Β· simp [denseInstructionCleanupValue] + | add destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + let lhs := DenseOverlay.read input overlay sourceβ‚€ + let rhs := DenseOverlay.read input overlay source₁ + have hdestination : bitlen destination ≀ width + 1 := by omega + have hlhs : bitlen lhs ≀ width + 1 := by + dsimp only [lhs] + omega + have hrhs : bitlen rhs ≀ width + 1 := by + dsimp only [rhs] + omega + have htag : bitlen (lhs + rhs + 1) ≀ width + 1 := by + exact le_trans (bitlen_succ_le (lhs + rhs)) (by + dsimp only [lhs, rhs] + omega) + intro slot + fin_cases slot + Β· exact hbits destination hdestination + Β· simpa only [lhs, rhs] using! hbits (lhs + rhs + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· simpa only [lhs] using! hbits lhs hlhs + Β· simpa only [rhs] using! hbits rhs hrhs + | sub destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + let lhs := DenseOverlay.read input overlay sourceβ‚€ + let rhs := DenseOverlay.read input overlay source₁ + have hdestination : bitlen destination ≀ width + 1 := by omega + have hlhs : bitlen lhs ≀ width := by + dsimp only [lhs] + omega + have hrhs : bitlen rhs ≀ width := by + dsimp only [rhs] + omega + have hresult := binaryInstrResult_bitlen_le .sub lhs rhs + have hresult' : bitlen (lhs - rhs) ≀ bitlen lhs + bitlen rhs + 1 := by + simpa [BinaryInstrOp.eval] using! hresult + have hresultWidth : bitlen (lhs - rhs) ≀ width := by + apply le_trans hresult' + dsimp only [lhs, rhs] at hcost ⊒ + exact hcost + have htag : bitlen (lhs - rhs + 1) ≀ width + 1 := + le_trans (bitlen_succ_le (lhs - rhs)) + (Nat.add_le_add_right hresultWidth 1) + intro slot + fin_cases slot + Β· exact hbits destination hdestination + Β· simpa only [lhs, rhs] using! hbits (lhs - rhs + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· exact hbits lhs (by omega) + Β· exact hbits rhs (by omega) + | mul destination sourceβ‚€ source₁ => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + let lhs := DenseOverlay.read input overlay sourceβ‚€ + let rhs := DenseOverlay.read input overlay source₁ + have hdestination : bitlen destination ≀ width + 1 := by omega + have hlhs : bitlen lhs ≀ width + 1 := by + dsimp only [lhs] + omega + have hrhs : bitlen rhs ≀ width + 1 := by + dsimp only [rhs] + omega + have htag : bitlen (lhs * rhs + 1) ≀ width + 1 := + le_trans (bitlen_succ_le (lhs * rhs)) (by + dsimp only [lhs, rhs] + omega) + intro slot + fin_cases slot + Β· exact hbits destination hdestination + Β· simpa only [lhs, rhs] using! hbits (lhs * rhs + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· simpa only [lhs] using! hbits lhs hlhs + Β· simpa only [rhs] using! hbits rhs hrhs + | load destination addressRegister => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay address + have hdestination : bitlen destination ≀ width + 1 := by omega + have haddress : bitlen address ≀ width + 1 := by + dsimp only [address] + omega + have htag : bitlen (value + 1) ≀ width + 1 := + le_trans (bitlen_succ_le value) (by + dsimp only [address, value] + omega) + intro slot + fin_cases slot + Β· exact hbits destination hdestination + Β· simpa only [address, value] using! hbits (value + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· simpa only [address] using! hbits address haddress + Β· simp [denseInstructionCleanupValue] + | store addressRegister source => + simp only [RegisterStore.Instr.staticWidth] at hstatic + simp only [Instr.logCost, DenseOverlay.Snapshot.decode, + DenseOverlay.decode] at hcost + let address := DenseOverlay.read input overlay addressRegister + let value := DenseOverlay.read input overlay source + have haddress : bitlen address ≀ width + 1 := by + dsimp only [address] + omega + have hvalue : bitlen value ≀ width := by + dsimp only [value] + omega + have htag : bitlen (value + 1) ≀ width + 1 := + le_trans (bitlen_succ_le value) (by omega) + intro slot + fin_cases slot + Β· simpa only [address] using! hbits address haddress + Β· simpa only [value] using! hbits (value + 1) htag + Β· simp only [denseInstructionCleanupValue] + split <;> simp_all [Fin.ext_iff] + split <;> simp [Nat.bits] + Β· simpa only [address] using! hbits address haddress + Β· simpa only [value] using! hbits value (by omega) + | jz source target => + intro slot + fin_cases slot <;> simp [denseInstructionCleanupValue] + | jmp target => + intro slot + fin_cases slot <;> simp [denseInstructionCleanupValue] + | halt => + intro slot + fin_cases slot <;> simp [denseInstructionCleanupValue] + +private theorem denseInstructionRemainingValue_bits_le + (instruction : Instr) (overlay : Store) (hcanonical : Canonical overlay) : + (denseInstructionRemainingValue instruction overlay).bits.length ≀ + encodedStoreLength overlay := by + have hcount := count_bits_le_encodedStoreLength overlay hcanonical + cases instruction <;> + simp only [denseInstructionRemainingValue] <;> simp_all +theorem denseProgramStepTime_le_envelope_internal {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramStepTime tapes program input snapshot.pc snapshot.overlay ≀ + denseStepEnvelope program input snapshot := by + let width := denseStepWidth program input snapshot + let magnitude := programResourceMagnitude program + let unit := denseResourceUnit magnitude input.length snapshot.overlay width + let instruction := selectedInstruction program snapshot.pc + let nextStore := denseInstructionStore input instruction snapshot.pc + snapshot.overlay + let instructionTime := denseProgramInstructionTime tapes program input + snapshot.pc snapshot.overlay + let cleanupBound := encodedStoreLength snapshot.overlay + 2 * width + 2 + have hunit : 1 ≀ unit := denseResourceUnit_pos magnitude input.length + snapshot.overlay width + have hvolume : encodedStoreLength snapshot.overlay + input.length + width + 1 ≀ + unit := denseResourceVolume_le_unit magnitude input.length snapshot.overlay + width + have hinstruction : instructionTime ≀ 7000000 * unit := by + have htime := denseProgramInstructionTime_le_product tapes program input + snapshot hvalid hpc + simpa only [instructionTime, unit, width, magnitude] using! htime + have hstatic : RegisterStore.Instr.staticWidth instruction ≀ width := by + exact le_trans (selectedInstructionStaticWidth_le program snapshot.pc) (by + unfold width denseStepWidth + omega) + have hselectedCost : instruction.logCost (snapshot.decode input) = + RAM.stepLogCost program (snapshot.decode input) := by + unfold instruction RAM.stepLogCost RAM.curInstr + rw [selectedInstruction_eq_getElem?_getD] + simp [DenseOverlay.Snapshot.decode] + have hcost : instruction.logCost (snapshot.decode input) ≀ width := by + rw [hselectedCost] + unfold width denseStepWidth + omega + have hcleanupValues : βˆ€ slot, + (denseInstructionCleanupValue input instruction snapshot.overlay slot).bits.length + ≀ cleanupBound := by + intro slot + apply le_trans (denseInstructionCleanupValue_bits_le input instruction + snapshot.pc snapshot.overlay width hstatic hcost slot) + unfold cleanupBound + omega + have hremaining : + (denseInstructionRemainingValue instruction snapshot.overlay).bits.length ≀ + cleanupBound := by + apply le_trans (denseInstructionRemainingValue_bits_le instruction + snapshot.overlay hvalid.1) + unfold cleanupBound + omega + have hold : encodedStoreLength snapshot.overlay ≀ cleanupBound := by + unfold cleanupBound + omega + have hnextRaw := DenseOverlay.Snapshot.encodedStoreLength_stepInstr_le input + instruction snapshot + have hnext : encodedStoreLength nextStore ≀ cleanupBound := by + have hincrement : RegisterStore.Instr.staticWidth instruction + + instruction.logCost (snapshot.decode input) + 1 ≀ width := by + rw [hselectedCost] + unfold width denseStepWidth + have hselectedStatic := selectedInstructionStaticWidth_le program snapshot.pc + change RegisterStore.Instr.staticWidth instruction ≀ + programStaticWidth program at hselectedStatic + omega + dsimp only [nextStore] + unfold denseInstructionStore + exact le_trans hnextRaw (by + unfold cleanupBound + omega) + have hcleanup := bufferedCleanupTime_le_linear tapes snapshot.overlay nextStore + (denseInstructionCleanupValue input instruction snapshot.overlay) + (denseInstructionRemainingValue instruction snapshot.overlay) + (denseProgramStepSourceHeadBound tapes program input snapshot.pc + snapshot.overlay) + cleanupBound (by + unfold denseProgramStepSourceHeadBound + omega) + hcleanupValues hremaining hold hnext + have hcleanupBoundUnit : cleanupBound ≀ 3 * unit := by + unfold cleanupBound + nlinarith + have hcleanup' : bufferedCleanupTime tapes snapshot.overlay nextStore + (denseInstructionCleanupValue input instruction snapshot.overlay) + (denseInstructionRemainingValue instruction snapshot.overlay) + (denseProgramStepSourceHeadBound tapes program input snapshot.pc + snapshot.overlay) ≀ + 800000000 * unit := by + apply le_trans hcleanup + unfold denseProgramStepSourceHeadBound + dsimp only [instructionTime] at hinstruction ⊒ + nlinarith + unfold denseProgramStepTime + dsimp only [instruction, nextStore, instructionTime] + apply le_trans (by omega : instructionTime + 1 + + bufferedCleanupTime tapes snapshot.overlay nextStore + (denseInstructionCleanupValue input instruction snapshot.overlay) + (denseInstructionRemainingValue instruction snapshot.overlay) + (denseProgramStepSourceHeadBound tapes program input snapshot.pc + snapshot.overlay) ≀ 1000000000 * unit) + apply le_of_eq + dsimp only [unit, width, magnitude, denseResourceUnit, denseStepEnvelope, + denseStepVolume] + ring + +private theorem denseSnapshot_step_pc_le_resourceMagnitude + (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + (snapshot.step program input).pc ≀ programResourceMagnitude program := by + by_cases hinRange : snapshot.pc < program.length + Β· have hfallthrough : snapshot.pc + 1 ≀ + programResourceMagnitude program := by + exact le_trans (by omega) (program_length_le_resourceMagnitude program) + have hselected := selectedInstructionResourceMagnitude_le program snapshot.pc + unfold DenseOverlay.Snapshot.step DenseOverlay.Snapshot.curInstr + rw [← selectedInstruction_eq_getElem?_getD] + generalize hinstruction : selectedInstruction program snapshot.pc = instruction + rw [hinstruction] at hselected + cases instruction <;> + simp only [DenseOverlay.Snapshot.stepInstr, + instructionResourceMagnitude] at hselected ⊒ + Β· exact hfallthrough + Β· exact hfallthrough + Β· exact hfallthrough + Β· exact hfallthrough + Β· exact hfallthrough + Β· exact hfallthrough + Β· split <;> dsimp only <;> omega + Β· omega + Β· exact hpc + Β· have houtOfRange : program[snapshot.pc]? = none := + List.getElem?_eq_none (by omega) + unfold DenseOverlay.Snapshot.step DenseOverlay.Snapshot.curInstr + rw [houtOfRange] + simpa [DenseOverlay.Snapshot.stepInstr] using! hpc + +private theorem denseStepVolume_le_runScale_succ + (program : Program) (input : List Bool) (fuel : β„•) + (snapshot : DenseOverlay.Snapshot) : + denseStepVolume program input snapshot ≀ + denseRunScale program input (fuel + 1) snapshot := by + have hhalted : snapshot.Halted program ↔ + RAM.Halted program (snapshot.decode input) := Iff.rfl + by_cases hhalt : snapshot.Halted program + Β· have hramHalt := hhalted.mp hhalt + have hcost : RAM.stepLogCost program (snapshot.decode input) = 1 := by + unfold RAM.stepLogCost RAM.curInstr + change (snapshot.curInstr program).logCost (snapshot.decode input) = 1 + rw [hhalt] + rfl + unfold denseStepVolume denseStepWidth denseRunScale + rw [RAM.unitTimeUpto_succ, ite_eq_left hramHalt, + RAM.logTimeUpto_succ, ite_eq_left hramHalt] + rw [hcost] + nlinarith + Β· have hramNotHalt : Β¬RAM.Halted program (snapshot.decode input) := + fun h => hhalt (hhalted.mpr h) + unfold denseStepVolume denseStepWidth denseRunScale + rw [RAM.unitTimeUpto_succ, ite_eq_right hramNotHalt, + RAM.logTimeUpto_succ, ite_eq_right hramNotHalt] + nlinarith + +private theorem denseRunScale_step_add_width_le + (program : Program) (input : List Bool) (fuel : β„•) + (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) : + denseRunScale program input fuel (snapshot.step program input) + + (denseStepWidth program input snapshot + 1) ≀ + denseRunScale program input (fuel + 1) snapshot := by + have hhalted : snapshot.Halted program ↔ + RAM.Halted program (snapshot.decode input) := Iff.rfl + by_cases hhalt : snapshot.Halted program + Β· have hramHalt := hhalted.mp hhalt + have hstep : snapshot.step program input = snapshot := by + change snapshot.stepInstr input (snapshot.curInstr program) = snapshot + rw [hhalt] + rfl + have hcost : RAM.stepLogCost program (snapshot.decode input) = 1 := by + unfold RAM.stepLogCost RAM.curInstr + change (snapshot.curInstr program).logCost (snapshot.decode input) = 1 + rw [hhalt] + rfl + rw [hstep] + unfold denseRunScale denseStepWidth + rw [RAM.unitTimeUpto_halted program hramHalt, + RAM.logTimeUpto_halted program hramHalt] + rw [hcost] + nlinarith + Β· have hramNotHalt : Β¬RAM.Halted program (snapshot.decode input) := + fun h => hhalt (hhalted.mpr h) + have hstore := DenseOverlay.Snapshot.encodedStoreLength_step_le + program input snapshot + have hdecode := DenseOverlay.Snapshot.decode_step program input snapshot + hvalid.1 + unfold denseRunScale denseStepWidth + rw [RAM.unitTimeUpto_succ, ite_eq_right hramNotHalt, + RAM.logTimeUpto_succ, ite_eq_right hramNotHalt, hdecode] + nlinarith + +private theorem denseDispatchHaltTime_le_width {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (selector bound : β„•) (hbound : 1 ≀ bound) + (hselector : selector.bits.length ≀ bound) : + dispatchHaltTime tapes program selector ≀ + 20 * (program.length + 1) * (bound + 1) := by + induction program generalizing selector with + | nil => + have hreset : TM.resetBinaryWorkTime 1 selector.bits.length ≀ + 2 * bound + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + simp only [dispatchHaltTime, List.length_nil, Nat.zero_add, + Nat.mul_one] + omega + | cons instruction rest ih => + have hselectorPred : (selector - 1).bits.length ≀ bound := by + simpa only [Nat.size_eq_bits_len] using! + (le_trans (Nat.size_le_size (Nat.sub_le selector 1)) (by + simpa [Nat.size_eq_bits_len] using! hselector)) + have htail := ih (selector - 1) hselectorPred + have hpred := TM.binaryPredTime_le (selector - 1) + have hpredSize : (selector - 1 + 1).size ≀ bound + 1 := by + have hvalue : selector - 1 + 1 ≀ selector + 1 := by omega + have hsize := Nat.size_le_size hvalue + have hselectorSize : selector.size ≀ bound := by + simpa [Nat.size_eq_bits_len] using! hselector + have hsucc : (selector + 1).size ≀ bound + 1 := by + rw [Nat.size_le] + have hlt := Nat.lt_size_self selector + have hpow := Nat.pow_le_pow_right (by decide : 1 ≀ 2) hselectorSize + rw [pow_succ] + omega + exact le_trans hsize hsucc + have hpred' : TM.binaryPredTime (selector - 1) ≀ + 2 * (bound + 1) + 2 := le_trans hpred (by omega) + simp only [dispatchHaltTime, TM.branchWorkBlankTime, List.length_cons] + have hmax : max 1 + (TM.binaryPredTime (selector - 1) + 1 + + dispatchHaltTime tapes rest (selector - 1)) ≀ + 2 * (bound + 1) + 3 + + 20 * (rest.length + 1) * (bound + 1) := by + apply max_le <;> omega + nlinarith + +private theorem denseProgramHaltTime_le_magnitude {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (pcValue : β„•) (hpc : pcValue ≀ programResourceMagnitude program) : + programHaltTime tapes program pcValue ≀ + 40 * (programResourceMagnitude program + 1) ^ 2 := by + let magnitude := programResourceMagnitude program + have hmagnitude : 1 ≀ magnitude := programResourceMagnitude_pos program + have hpcSize : pcValue.size ≀ magnitude := + le_trans (size_le_self pcValue) hpc + have hpcBits : pcValue.bits.length ≀ magnitude := by + simpa only [Nat.size_eq_bits_len] using! hpcSize + have hdispatch := denseDispatchHaltTime_le_width tapes program pcValue + magnitude hmagnitude hpcBits + have hcopyRaw := TM.binaryCopyTime_le pcValue 0 + have hcopy : TM.binaryCopyTime pcValue 0 ≀ 3 * magnitude + 20 := by + apply le_trans hcopyRaw + simp only [Nat.size_zero, Nat.mul_zero] + omega + have hlength := program_length_le_resourceMagnitude program + unfold programHaltTime + dsimp only [magnitude] at hmagnitude hdispatch hcopy ⊒ + nlinarith + +private theorem denseProgramLoopIterationTime_le_product {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramLoopIterationTime tapes program input snapshot ≀ + 2000000000 * (programResourceMagnitude program + 1) ^ 2 * + denseStepVolume program input snapshot * + (denseStepWidth program input snapshot + 1) := by + let magnitude := programResourceMagnitude program + let volume := denseStepVolume program input snapshot + let width := denseStepWidth program input snapshot + let unit := (magnitude + 1) ^ 2 * volume * (width + 1) + have hstep := denseProgramStepTime_le_envelope_internal tapes program input + snapshot hvalid hpc + have hnextPc := denseSnapshot_step_pc_le_resourceMagnitude program input + snapshot hpc + have hhalt := denseProgramHaltTime_le_magnitude tapes program + (snapshot.step program input).pc hnextPc + have hvolume : 1 ≀ volume := by + unfold volume denseStepVolume + omega + have hwidth : 1 ≀ width + 1 := by omega + have hfixed : (magnitude + 1) ^ 2 ≀ unit := by + calc + (magnitude + 1) ^ 2 = (magnitude + 1) ^ 2 * 1 * 1 := by ring + _ ≀ (magnitude + 1) ^ 2 * volume * (width + 1) := + Nat.mul_le_mul (Nat.mul_le_mul_left _ hvolume) hwidth + unfold denseProgramLoopIterationTime + dsimp only [magnitude, volume, width, unit] at hstep hhalt hfixed ⊒ + unfold denseStepEnvelope at hstep + nlinarith +theorem denseProgramLoopTime_le_envelope_internal {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (fuel : β„•) + (snapshot : DenseOverlay.Snapshot) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hpc : snapshot.pc ≀ programResourceMagnitude program) : + denseProgramLoopTime tapes program input fuel snapshot ≀ + denseProgramLoopEnvelope program input fuel snapshot := by + induction fuel generalizing snapshot with + | zero => + simp [denseProgramLoopTime, denseProgramLoopEnvelope] + | succ fuel ih => + let next := snapshot.step program input + let fixed := 2000000000 * (programResourceMagnitude program + 1) ^ 2 + let volume := denseStepVolume program input snapshot + let width := denseStepWidth program input snapshot + let currentScale := denseRunScale program input (fuel + 1) snapshot + let nextScale := denseRunScale program input fuel next + have hiteration := denseProgramLoopIterationTime_le_product tapes program + input snapshot hvalid hpc + have hnextValid : DenseOverlay.Valid next.overlay := by + dsimp only [next] + exact DenseOverlay.Snapshot.step_valid program input snapshot hvalid + have hnextPc : next.pc ≀ programResourceMagnitude program := by + dsimp only [next] + exact denseSnapshot_step_pc_le_resourceMagnitude program input snapshot hpc + have htail := ih next hnextValid hnextPc + have hvolume : volume ≀ currentScale := by + dsimp only [volume, currentScale] + exact denseStepVolume_le_runScale_succ program input fuel snapshot + have hdrop : nextScale + (width + 1) ≀ currentScale := by + dsimp only [nextScale, next, width, currentScale] + exact denseRunScale_step_add_width_le program input fuel snapshot hvalid + have hnextCurrent : nextScale ≀ currentScale := by omega + have hvolumeProduct : volume * (width + 1) ≀ + currentScale * (width + 1) := + Nat.mul_le_mul_right (width + 1) hvolume + have hnextSquare : nextScale * nextScale ≀ + currentScale * nextScale := + Nat.mul_le_mul_right nextScale hnextCurrent + have hcurrentProduct : + currentScale * (nextScale + (width + 1)) ≀ + currentScale * currentScale := + Nat.mul_le_mul_left currentScale hdrop + have hquadratic : volume * (width + 1) + nextScale ^ 2 ≀ + currentScale ^ 2 := by + nlinarith + have hiteration' : + denseProgramLoopIterationTime tapes program input snapshot ≀ + fixed * volume * (width + 1) := by + simpa only [fixed, volume, width] using! hiteration + have htail' : denseProgramLoopTime tapes program input fuel next ≀ + fixed * nextScale ^ 2 := by + simpa only [denseProgramLoopEnvelope, fixed, nextScale] using! htail + rw [denseProgramLoopTime] + unfold denseProgramLoopEnvelope + dsimp only [next, fixed, currentScale] at hiteration' htail' ⊒ + calc + denseProgramLoopIterationTime tapes program input snapshot + + denseProgramLoopTime tapes program input fuel + (snapshot.step program input) ≀ + (2000000000 * (programResourceMagnitude program + 1) ^ 2) * + volume * (width + 1) + + (2000000000 * (programResourceMagnitude program + 1) ^ 2) * + nextScale ^ 2 := Nat.add_le_add hiteration' htail' + _ = (2000000000 * (programResourceMagnitude program + 1) ^ 2) * + (volume * (width + 1) + nextScale ^ 2) := by ring + _ ≀ (2000000000 * (programResourceMagnitude program + 1) ^ 2) * + currentScale ^ 2 := + Nat.mul_le_mul_left _ hquadratic + +private theorem denseInitialLengthLoopTime_le + (address : β„•) (input : List Bool) (bound : β„•) + (haddress : address + input.length ≀ bound) : + denseInitialLengthLoopTime address input ≀ + (input.length + 1) * (2 * bound + 5) := by + induction input generalizing address with + | nil => + simp [denseInitialLengthLoopTime] + | cons bit rest ih => + have haddressLe : address ≀ bound := by + simp only [List.length_cons] at haddress + omega + have hsuccRaw := TM.binarySuccTime_le address + have hsucc : TM.binarySuccTime address ≀ 2 * bound + 2 := by + exact le_trans hsuccRaw (by + have hsize := le_trans (size_le_self address) haddressLe + omega) + have htail := ih (address + 1) (by + simp only [List.length_cons] at haddress + omega) + simp only [denseInitialLengthLoopTime, List.length_cons] + rw [Nat.succ_add, Nat.succ_mul] + omega + +private theorem denseEntriesEncode_length_le (store : Store) (bound : β„•) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) : + (store.flatMap Entry.encode).length ≀ + store.length * (4 * bound + 2) := by + induction store with + | nil => simp + | cons entry rest ih => + have hentry := hentries entry (by simp) + have hrest : βˆ€ current ∈ rest, + current.1.bits.length ≀ bound ∧ + current.2.bits.length ≀ bound := by + intro current hcurrent + exact hentries current (by simp [hcurrent]) + have htail := ih hrest + have hhead : (Entry.encode entry).length ≀ 4 * bound + 2 := by + rw [Entry.encode_length] + simpa [bitlen, Nat.size_eq_bits_len] using! + (show 2 * entry.1.bits.length + 2 * entry.2.bits.length + 2 ≀ + 4 * bound + 2 by omega) + simp only [List.flatMap_cons, List.length_append, List.length_cons] + rw [Nat.succ_mul] + omega + +private theorem denseInitialCleanupBits_le {m : β„•} + (tapes : ControlInstructionTapes m) (length bound : β„•) + (hlength : length.bits.length ≀ bound) (hbound : 1 ≀ bound) + (i : Fin (m + 1)) : + (initialCleanupBits tapes length i).length ≀ bound := by + unfold initialCleanupBits + split + Β· exact hlength + Β· split + Β· simpa using! hbound + Β· simp + +private theorem denseInitialAbiInstallTime_le {m : β„•} + (tapes : ControlInstructionTapes m) (store : Store) + (length bound : β„•) (hbound : 1 ≀ bound) + (hstoreLength : store.length ≀ bound) + (hentries : βˆ€ entry ∈ store, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound) + (hlength : length.bits.length ≀ bound) : + initialAbiInstallTime tapes store length ≀ 100 * (bound + 1) ^ 2 := by + let encoded := store.flatMap Entry.encode + have hencodedBase := denseEntriesEncode_length_le store bound hentries + have hencoded : encoded.length ≀ 6 * (bound + 1) ^ 2 := by + dsimp only [encoded] + have hfactor : 4 * bound + 2 ≀ 6 * (bound + 1) := by omega + have hproduct := Nat.mul_le_mul hstoreLength hfactor + exact le_trans hencodedBase (by nlinarith) + have hcopyRaw := TM.binaryCopyTime_le store.length 0 + have hcopy : TM.binaryCopyTime store.length 0 ≀ 3 * bound + 20 := by + apply le_trans hcopyRaw + simp only [Nat.size_zero, Nat.mul_zero] + have hsize := le_trans (size_le_self store.length) hstoreLength + omega + have hresetEncoded : TM.resetBinaryWorkTime (encoded.length + 1) + encoded.length ≀ 3 * (6 * (bound + 1) ^ 2) + 9 := by + unfold TM.resetBinaryWorkTime TM.clearWorkTimeBound + omega + have hresetMany := TM.resetBinaryWorkManyTime_le + (initialCleanupTargets tapes) (initialCleanupBits tapes length) + (fun _ => 1) 1 bound (fun _ _ => le_rfl) + (fun i _ => denseInitialCleanupBits_le tapes length bound hlength hbound i) + have htargets : (initialCleanupTargets tapes).length = 2 := by + simp [initialCleanupTargets] + rw [htargets] at hresetMany + unfold initialAbiInstallTime + dsimp only [encoded] at hencoded hresetEncoded ⊒ + have hboundSq : bound ≀ (bound + 1) ^ 2 := by nlinarith + have honeSq : 1 ≀ (bound + 1) ^ 2 := by nlinarith + nlinarith + +private theorem denseRewindEntryEncodeRestoreTime_bound + (entry : Entry) (bound : β„•) + (hbound : 1 ≀ bound) (haddress : entry.1.bits.length ≀ bound) + (hvalue : entry.2.bits.length ≀ bound) : + rewindEntryEncodeRestoreTime entry ≀ 30 * (bound + 1) := by + unfold rewindEntryEncodeRestoreTime rewindEntryEncodeTime + rewindWordEncodeTime wordEncodeTime + have haddressSize : entry.1.size = entry.1.bits.length := + (Nat.size_eq_bits_len entry.1).symm + have hvalueSize : entry.2.size = entry.2.bits.length := + (Nat.size_eq_bits_len entry.2).symm + omega + +private theorem denseProgramInitTime_le_quadratic {m : β„•} + (tapes : ControlInstructionTapes m) (input : List Bool) : + denseProgramInitTime tapes input ≀ 1000 * (input.length + 3) ^ 2 := by + let bound := input.length + 2 + have hbound : 1 ≀ bound := by simp [bound] + have hloop := denseInitialLengthLoopTime_le 1 input (input.length + 1) + (by omega) + have htagBits : (input.length + 1).bits.length ≀ bound := by + simpa only [Nat.size_eq_bits_len] using! + (le_trans (size_le_self (input.length + 1)) (by + dsimp only [bound] + omega)) + have hrewind := denseRewindEntryEncodeRestoreTime_bound + (0, input.length + 1) bound hbound (by simp) htagBits + have hstoreLength : (denseProgramInitialStore input).length ≀ bound := by + simp [denseProgramInitialStore, DenseOverlay.Snapshot.initial, + DenseOverlay.write, RegisterStore.write, bound] + have hentries : βˆ€ entry ∈ denseProgramInitialStore input, + entry.1.bits.length ≀ bound ∧ entry.2.bits.length ≀ bound := by + intro entry hentry + simp [denseProgramInitialStore, DenseOverlay.Snapshot.initial, + DenseOverlay.write, RegisterStore.write] at hentry + subst entry + exact ⟨by simp, htagBits⟩ + have habi := denseInitialAbiInstallTime_le tapes + (denseProgramInitialStore input) (input.length + 1) bound hbound + hstoreLength hentries htagBits + have hsuccZero := TM.binarySuccTime_le 0 + have hsuccZero' : TM.binarySuccTime 0 ≀ 2 := by + simpa using! hsuccZero + unfold denseProgramInitTime + dsimp only [bound] at hrewind habi htagBits hbound ⊒ + nlinarith + +private theorem denseProgramOutputTime_le_encoded {m : β„•} + (tapes : ControlInstructionTapes m) (input : List Bool) + (overlay : Store) (hvalid : DenseOverlay.Valid overlay) : + denseProgramOutputTime tapes input overlay ≀ + 2000000 * (encodedStoreLength overlay + input.length + 1) := by + have hlookup := denseOverlayLookupStaticTime_le_product + tapes.lifted.data.lhsLookup input.length overlay 0 0 0 hvalid + (by simp [bitlen]) (by simp) + unfold denseProgramOutputTime + nlinarith + +private theorem denseRunScale_initial_succ_le + (program : Program) (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) + (hfuel : fuel ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input)) : + denseRunScale program input (fuel + 1) + (DenseOverlay.Snapshot.initial input) ≀ + 10 * (programResourceMagnitude program + 1) * + (input.length + + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) := by + let initial := DenseOverlay.Snapshot.initial input + let cost := RAM.logTimeUpto program fuel (RAM.initCfg input) + let magnitude := programResourceMagnitude program + have hdecode : initial.decode input = RAM.initCfg input := by + simpa only [initial] using! DenseOverlay.Snapshot.initial_decode input + have hhaltedInitial : RAM.Halted program + (RAM.run program fuel (initial.decode input)) := by + rw [hdecode] + exact hhalted + have hcostSucc : + RAM.logTimeUpto program (fuel + 1) (initial.decode input) = cost := by + have hsame := RAM.logTimeUpto_eq_of_halted_le program + (Nat.le_succ fuel) hhaltedInitial + calc + RAM.logTimeUpto program (fuel + 1) (initial.decode input) = + RAM.logTimeUpto program fuel (initial.decode input) := by + simpa only [Nat.succ_eq_add_one] using! hsame + _ = cost := by rw [hdecode] + have hunit := RAM.unitTimeUpto_le_logTimeUpto program (fuel + 1) + (initial.decode input) + rw [hcostSucc] at hunit + have hstatic := programStaticWidth_le_resourceMagnitude program + have hmagnitude : 1 ≀ magnitude := by + simpa only [magnitude] using! programResourceMagnitude_pos program + have hencodedRaw := DenseOverlay.Snapshot.initial_encodedStoreLength_run_le + program input 0 + have hencoded : encodedStoreLength initial.overlay ≀ + 2 * bitlen (input.length + 1) + 2 := by + simpa only [initial, DenseOverlay.Snapshot.run, + RAM.unitTimeUpto_zero, RAM.logTimeUpto_zero, Nat.zero_mul, + Nat.zero_add, Nat.mul_zero, Nat.add_zero] using! hencodedRaw + have hbitlen : bitlen (input.length + 1) ≀ input.length + 1 := + size_le_self (input.length + 1) + have htime : fuel + 1 + + RAM.unitTimeUpto program (fuel + 1) (initial.decode input) ≀ + 2 * cost + 1 := by + dsimp only [cost] at hfuel ⊒ + omega + have hstatic' : programStaticWidth program + 1 ≀ magnitude + 1 := by + dsimp only [magnitude] + omega + have hproduct := Nat.mul_le_mul hstatic' htime + unfold denseRunScale + dsimp only [initial, cost, magnitude] at hcostSucc hencoded hbitlen hmagnitude hproduct ⊒ + rw [hcostSucc] + nlinarith + +private theorem denseFinalEncodedStoreLength_le + (program : Program) (input : List Bool) (fuel : β„•) : + encodedStoreLength + ((DenseOverlay.Snapshot.initial input).run program input fuel).overlay ≀ + 6 * (programResourceMagnitude program + 1) * + (input.length + + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) := by + let cost := RAM.logTimeUpto program fuel (RAM.initCfg input) + let magnitude := programResourceMagnitude program + have hencoded := DenseOverlay.Snapshot.initial_encodedStoreLength_run_le + program input fuel + have hunit := RAM.unitTimeUpto_le_logTimeUpto program fuel + (RAM.initCfg input) + have hstatic := programStaticWidth_le_resourceMagnitude program + have hbitlen : bitlen (input.length + 1) ≀ input.length + 1 := + size_le_self (input.length + 1) + have hproduct : + RAM.unitTimeUpto program fuel (RAM.initCfg input) * + (programStaticWidth program + 1) ≀ + cost * (magnitude + 1) := by + exact Nat.mul_le_mul hunit (by + dsimp only [magnitude] + omega) + dsimp only [cost, magnitude] at hproduct ⊒ + nlinarith +theorem denseProgramDecisionTime_le_envelope_internal {m : β„•} + (tapes : ControlInstructionTapes m) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) + (hfuel : fuel ≀ + RAM.logTimeUpto program fuel (RAM.initCfg input)) : + denseProgramDecisionTime tapes program input fuel ≀ + denseProgramDecisionEnvelope program input.length + (RAM.logTimeUpto program fuel (RAM.initCfg input)) := by + let initial := DenseOverlay.Snapshot.initial input + let final := initial.run program input fuel + let cost := RAM.logTimeUpto program fuel (RAM.initCfg input) + let magnitude := programResourceMagnitude program + let scale := input.length + cost + 1 + let fixed := (magnitude + 1) ^ 4 * scale ^ 2 + have hmagnitude : 1 ≀ magnitude := by + simpa only [magnitude] using! programResourceMagnitude_pos program + have hscale : 1 ≀ scale := by + dsimp only [scale] + omega + have hinitialValid : DenseOverlay.Valid initial.overlay := by + simpa only [initial] using! DenseOverlay.Snapshot.initial_valid input + have hinitialPc : initial.pc ≀ magnitude := by + dsimp only [initial, DenseOverlay.Snapshot.initial, magnitude] + omega + have hloopRaw := denseProgramLoopTime_le_envelope_internal tapes program + input (fuel + 1) initial hinitialValid hinitialPc + have hrunScale := denseRunScale_initial_succ_le program input fuel + hhalted hfuel + have hloop : denseProgramLoopTime tapes program input (fuel + 1) initial ≀ + 200000000000 * fixed := by + apply le_trans hloopRaw + unfold denseProgramLoopEnvelope + have hsquare := Nat.pow_le_pow_left hrunScale 2 + dsimp only [initial, cost, magnitude, scale, fixed] at hsquare ⊒ + nlinarith + have hinitRaw := denseProgramInitTime_le_quadratic tapes input + have hinit : denseProgramInitTime tapes input ≀ 9000 * fixed := by + apply le_trans hinitRaw + have hlength : input.length + 3 ≀ 3 * scale := by + dsimp only [scale] + omega + have hsquare := Nat.pow_le_pow_left hlength 2 + have hfixedOne : scale ^ 2 ≀ fixed := by + dsimp only [fixed] + have honePos : 0 < (magnitude + 1) ^ 4 := by positivity + have hone : 1 ≀ (magnitude + 1) ^ 4 := by omega + calc + scale ^ 2 = 1 * scale ^ 2 := by simp + _ ≀ (magnitude + 1) ^ 4 * scale ^ 2 := + Nat.mul_le_mul_right _ hone + nlinarith + have hfinalValid : DenseOverlay.Valid final.overlay := by + dsimp only [final, initial] + exact DenseOverlay.Snapshot.run_valid program input fuel + (DenseOverlay.Snapshot.initial input) + (DenseOverlay.Snapshot.initial_valid input) + have houtputRaw := denseProgramOutputTime_le_encoded tapes input + final.overlay hfinalValid + have hfinalEncoded := denseFinalEncodedStoreLength_le program input fuel + have houtput : denseProgramOutputTime tapes input final.overlay ≀ + 20000000 * fixed := by + apply le_trans houtputRaw + have hvolume : encodedStoreLength final.overlay + input.length + 1 ≀ + 7 * (magnitude + 1) * scale := by + dsimp only [final, initial, cost, magnitude, scale] at hfinalEncoded ⊒ + nlinarith + have hlinearFixed : (magnitude + 1) * scale ≀ fixed := by + dsimp only [fixed] + have hmagnitudePow : magnitude + 1 ≀ (magnitude + 1) ^ 4 := by + exact Nat.le_self_pow (by decide : (4 : β„•) β‰  0) (magnitude + 1) + have hscaleSq : scale ≀ scale ^ 2 := by + exact Nat.le_self_pow (by decide : (2 : β„•) β‰  0) scale + exact Nat.mul_le_mul hmagnitudePow hscaleSq + nlinarith + unfold denseProgramDecisionTime denseProgramDecisionEnvelope + dsimp only [initial, final, cost, magnitude, scale, fixed] at hloop hinit houtput ⊒ + have hfixedPos : 1 ≀ + (programResourceMagnitude program + 1) ^ 4 * + (input.length + + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) ^ 2 := by + have hpos : 0 < + (programResourceMagnitude program + 1) ^ 4 * + (input.length + + RAM.logTimeUpto program fuel (RAM.initCfg input) + 1) ^ 2 := by + positivity + omega + nlinarith +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecision.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecision.lean new file mode 100644 index 0000000000..900af587b0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecision.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionProof + +/-! +# Complete dense-overlay RAM decision machine +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- The complete dense machine realizes one halted overlay run and emits its +decoded `Rβ‚€` verdict. -/ +theorem denseProgramDecisionTM_hoareTime_run {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : ((DenseOverlay.Snapshot.initial input).run program input fuel).Halted + program) : + (denseProgramDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + let final := (DenseOverlay.Snapshot.initial input).run program input fuel + out = registerVerdictOutput + (DenseOverlay.read input final.overlay 0)) + (denseProgramDecisionTime tapes program input fuel) := + denseProgramDecisionTM_hoareTime_run_internal tapes program input fuel hhalted + +/-- The fixed dense machine realizes a halted executable RAM run and emits its +public `Rβ‚€` verdict. -/ +theorem denseProgramDecisionTM_hoareTime_ramRun {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) : + (denseProgramDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + out = registerVerdictOutput + (RAM.run program fuel (RAM.initCfg input)).verdict) + (denseProgramDecisionTime tapes program input fuel) := + denseProgramDecisionTM_hoareTime_ramRun_internal tapes program input fuel + hhalted + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionDefs.lean new file mode 100644 index 0000000000..4cc58adf15 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionDefs.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitDefs + +/-! +# Complete dense-overlay RAM decision machine -- definitions +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Initialize the immutable public-input bank and one-entry overlay, execute +one fixed program through its first halt, and extract decoded `Rβ‚€`. -/ +def denseProgramDecisionTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.seqTM (denseProgramInitTM tapes) + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)) + +/-- Exact compositional bound for one fuel-certified dense RAM decision run. -/ +noncomputable def denseProgramDecisionTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) : β„• := + let initial := DenseOverlay.Snapshot.initial input + let final := initial.run program input fuel + denseProgramInitTime tapes input + 1 + + (denseProgramLoopTime tapes program input (fuel + 1) initial + 1 + + denseProgramOutputTime tapes input final.overlay) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionProof.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionProof.lean new file mode 100644 index 0000000000..76b510c931 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDecisionProof.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDecisionDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitProof +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInternal + +/-! +# Complete dense-overlay RAM decision-machine proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +/-- The complete dense machine realizes one halted overlay run and emits its +decoded `Rβ‚€` verdict. -/ +theorem denseProgramDecisionTM_hoareTime_run_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : ((DenseOverlay.Snapshot.initial input).run program input fuel).Halted + program) : + (denseProgramDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + let final := (DenseOverlay.Snapshot.initial input).run program input fuel + out = registerVerdictOutput + (DenseOverlay.read input final.overlay 0)) + (denseProgramDecisionTime tapes program input fuel) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let initial := DenseOverlay.Snapshot.initial input + let final := initial.run program input fuel + have hinit := denseProgramInitTM_hoareTime_internal tapes input + obtain ⟨initDone, initTime, hinitTime, hinitReach, hinitHalt, + hinitInput, hinitWork, hinitOutput⟩ := + hinit _ _ _ ⟨rfl, rfl, rfl⟩ + have hinitialValid : DenseOverlay.Valid initial.overlay := by + simpa only [initial] using DenseOverlay.Snapshot.initial_valid input + let sparseInitial : Snapshot := + { pc := initial.pc, store := initial.overlay } + have hready : InstructionExecutionReady tapes initial.overlay initial.pc + initDone.work := by + rw [hinitWork] + simpa only [denseProgramSnapshotWork, sparseInitial] using + programSnapshotWork_ready_internal tapes sparseInitial hinitialValid.1 + have hinitInputParked : TM.Parked initDone.input := by + rw [hinitInput] + refine ⟨by simp [Tape.move], ?_⟩ + simpa using Tape.init_ofBool_move_right_cells_ne_start input + have hloop := denseProgramLoopTM_hoareTime_run_internal tapes program input + fuel initial initDone.work hinitialValid hready hhalted + obtain ⟨loopDone, loopTime, hloopTime, hloopReach, hloopHalt, + hloopInput, hloopReady, hloopOutput⟩ := + hloop _ _ _ ⟨rfl, rfl, by simpa [TM.resetBinaryBlank] using hinitOutput⟩ + have hloopInputParked : TM.Parked loopDone.input := by + rw [hloopInput] + rw [← hinitInput] + exact hinitInputParked + have hloopOutputHalt : loopDone.output = instructionHaltOutput .halt := by + change loopDone.output = instructionHaltOutput (final.curInstr program) + at hloopOutput + rw [show final.curInstr program = .halt from hhalted] at hloopOutput + exact hloopOutput + have hfinalValid : DenseOverlay.Valid final.overlay := by + simpa only [final, initial] using DenseOverlay.Snapshot.run_valid + program input fuel (DenseOverlay.Snapshot.initial input) + (DenseOverlay.Snapshot.initial_valid input) + have houtputRun := denseProgramOutputTM_hoareTime_haltOutput_internal tapes + input final.overlay final.pc loopDone.work hfinalValid hloopReady + obtain ⟨outputDone, outputTime, houtputTime, houtputReach, + houtputHalt, houtputInput, houtputVerdict⟩ := + houtputRun _ _ _ ⟨hloopInput, rfl, hloopOutputHalt⟩ + have hloopOutputParked : TM.Parked loopDone.output := by + rw [hloopOutputHalt] + refine ⟨?_, instructionHaltOutput_cells_ne_start_internal .halt⟩ + rw [instructionHaltOutput_head_internal] + have houtputReach' : (denseProgramOutputTM tapes).reachesIn outputTime + { state := (denseProgramOutputTM tapes).qstart + input := TM.transitionInput loopDone.input + work := fun i => TM.transitionTape (loopDone.work i) + output := TM.transitionTape loopDone.output } + outputDone := by + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hloopInputParked.read_ne_start + (fun i => (hloopReady.control.lookup.scanner.parked i).read_ne_start) + hloopOutputParked.read_ne_start + simpa only [hi, hw, ho] using houtputReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (denseProgramLoopTM tapes program) (denseProgramOutputTM tapes) + hloopReach hloopHalt houtputReach' + let tailDone := TM.phase2Wrap (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes) outputDone + have htailHalt : + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)).halted tailDone := by + rw [TM.phase2Wrap_halted_iff] + exact houtputHalt + have hinitWorkParked : βˆ€ i, TM.Parked (initDone.work i) := by + exact hready.control.lookup.scanner.parked + have hinitOutputParked : TM.Parked initDone.output := by + rw [hinitOutput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + exact ⟨by rw [hblankNat.2.1], + hblankNat.2.hasBinaryContent.cells_ne_start⟩ + have htailReach' : + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)).reachesIn + (loopTime + 1 + outputTime) + { state := (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)).qstart + input := TM.transitionInput initDone.input + work := fun i => TM.transitionTape (initDone.work i) + output := TM.transitionTape initDone.output } + tailDone := by + obtain ⟨hi, hw, ho⟩ := TM.phaseTransition_eq_self_of_reads_ne_start + hinitInputParked.read_ne_start + (fun i => (hinitWorkParked i).read_ne_start) + hinitOutputParked.read_ne_start + rw [hi, hw, ho] + simpa only [hinitInput] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (denseProgramInitTM tapes) + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)) + hinitReach hinitHalt htailReach' + let done := TM.phase2Wrap (denseProgramInitTM tapes) + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)) tailDone + refine ⟨done, initTime + 1 + (loopTime + 1 + outputTime), + ?_, hreach, ?_, ?_⟩ + Β· unfold denseProgramDecisionTime + dsimp only [initial, final] at hloopTime houtputTime ⊒ + omega + Β· change (denseProgramDecisionTM tapes program).halted done + unfold denseProgramDecisionTM + exact (TM.phase2Wrap_halted_iff (denseProgramInitTM tapes) + (TM.seqTM (denseProgramLoopTM tapes program) + (denseProgramOutputTM tapes)) tailDone).mpr htailHalt + Β· change outputDone.output = registerVerdictOutput + (DenseOverlay.read input final.overlay 0) + exact houtputVerdict + +/-- The complete dense machine realizes a halted executable RAM run, with its +verdict rewritten through the overlay decoding theorem. -/ +theorem denseProgramDecisionTM_hoareTime_ramRun_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (fuel : β„•) + (hhalted : RAM.Halted program + (RAM.run program fuel (RAM.initCfg input))) : + (denseProgramDecisionTM tapes program).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _inp _work out => + out = registerVerdictOutput + (RAM.run program fuel (RAM.initCfg input)).verdict) + (denseProgramDecisionTime tapes program input fuel) := by + let initial := DenseOverlay.Snapshot.initial input + let final := initial.run program input fuel + have hdecode : final.decode input = + RAM.run program fuel (RAM.initCfg input) := by + rw [show RAM.initCfg input = initial.decode input by + simpa only [initial] using (DenseOverlay.Snapshot.initial_decode input).symm] + simpa only [final] using DenseOverlay.Snapshot.decode_run + program input fuel initial (by + simpa only [initial] using DenseOverlay.Snapshot.initial_canonical input) + have hfinalHalted : final.Halted program := by + change RAM.Halted program (final.decode input) + rw [hdecode] + exact hhalted + have hrun := denseProgramDecisionTM_hoareTime_run_internal tapes program + input fuel hfinalHalted + apply hrun.consequence + Β· exact fun _ _ _ h => h + Β· intro inp work out hpost + change out = registerVerdictOutput + (DenseOverlay.read input final.overlay 0) at hpost + rw [hpost] + congr 1 + change (final.decode input).regs 0 = + (RAM.run program fuel (RAM.initCfg input)).regs 0 + rw [hdecode] + Β· exact le_rfl + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDefs.lean new file mode 100644 index 0000000000..47bbf294ea --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseDefs.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseSimDefs +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Dense-overlay RAM program controller -- definitions +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Recover dense register `Rβ‚€` through the overlay-aware lookup and emit its +Boolean verdict on the real output tape. -/ +def denseProgramOutputTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM (denseOverlayLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) + +/-- Exact dense final-verdict extraction bound. -/ +def denseProgramOutputTime {n : β„•} (tapes : ControlInstructionTapes n) + (input : List Bool) (overlay : Store) : β„• := + denseOverlayLookupStaticTime tapes.lifted.data.lhsLookup input.length + overlay 0 + 1 + 1 + +/-- Fixed halt-aware loop for one concrete RAM program using dense overlay +steps and the representation-independent halt test. -/ +def denseProgramLoopTM {n : β„•} (tapes : ControlInstructionTapes n) + (program : Program) : TM (n + 1) := + TM.loopTM (denseProgramStepTM tapes program) (programHaltTM tapes program) + +/-- Bound for one dense loop body, halt test, their seams, and the three-step +rewind/check tail. -/ +noncomputable def denseProgramLoopIterationTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) : β„• := + let next := snapshot.step program input + denseProgramStepTime tapes program input snapshot.pc snapshot.overlay + 1 + + programHaltTime tapes program next.pc + 1 + 3 + +/-- Sum of the first `fuel` dense loop-iteration bounds. -/ +noncomputable def denseProgramLoopTime {n : β„•} + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) : β„• β†’ DenseOverlay.Snapshot β†’ β„• + | 0, _ => 0 + | fuel + 1, snapshot => + denseProgramLoopIterationTime tapes program input snapshot + + denseProgramLoopTime tapes program input fuel + (snapshot.step program input) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInit.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInit.lean new file mode 100644 index 0000000000..3343f95841 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInit.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitProof + +/-! +# Dense-overlay public-input initialization + +The optimized initializer retains the public bits on the immutable input tape, +materializes only the positive-tagged length register, installs the reusable +program ABI, and rewinds the input for dense fallback reads. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Complete dense public-input initialization reaches the exact one-entry +snapshot image with the immutable input bank parked at cell one. -/ +theorem denseProgramInitTM_hoareTime {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) : + (denseProgramInitTM tapes).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = denseProgramSnapshotWork tapes + (DenseOverlay.Snapshot.initial input) ∧ + out = TM.resetBinaryBlank) + (denseProgramInitTime tapes input) := + denseProgramInitTM_hoareTime_internal tapes input + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitDefs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitDefs.lean new file mode 100644 index 0000000000..0068d986cf --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitDefs.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs + +/-! +# Dense-overlay public-input initialization -- definitions + +The optimized initializer counts the immutable input in binary but emits only +the tagged `Rβ‚€` overlay entry. It then installs the ordinary sparse scanner ABI +and rewinds the real input for dense fallback reads. +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +/-- Phases of the input-length counter. -/ +inductive DenseInitialLengthPhase where + | scan + | done + deriving DecidableEq + +instance : Fintype DenseInitialLengthPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- State space for input scanning with one binary-successor body. -/ +abbrev DenseInitialLengthQ {n : β„•} (tapes : ControlInstructionTapes n) := + DenseInitialLengthPhase βŠ• (initialZeroBitTM tapes).Q + +/-- Count every input symbol into the existing initialization address tape. -/ +def denseInitialLengthLoopTM {n : β„•} + (tapes : ControlInstructionTapes n) : TM (n + 1) where + Q := DenseInitialLengthQ tapes + qstart := .inl .scan + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .scan => + if iHead = Ξ“.blank then + TM.allReadBack (.inl .done) iHead wHeads oHead + else + TM.allReadBack (.inr (initialZeroBitTM tapes).qstart) + iHead wHeads oHead + | .inl .done => TM.allIdle (.inl .done) iHead wHeads oHead + | .inr state => + if state = (initialZeroBitTM tapes).qhalt then + (.inl .scan, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, Dir3.right, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + else + let action := (initialZeroBitTM tapes).Ξ΄ state iHead wHeads oHead + (.inr action.1, action.2.1, action.2.2.1, action.2.2.2.1, + action.2.2.2.2.1, action.2.2.2.2.2) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .scan => + dsimp only + split <;> exact TM.rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact TM.rightOfStart_allIdle iHead wHeads oHead + | .inr state => + dsimp only + split + Β· exact ⟨fun _ => rfl, fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + Β· exact (initialZeroBitTM tapes).Ξ΄_right_of_start state + iHead wHeads oHead + +/-- Exact recursive time budget for binary input-length counting. -/ +def denseInitialLengthLoopTime : β„• β†’ List Bool β†’ β„• + | _, [] => 1 + | address, _ :: rest => + 1 + TM.binarySuccTime address + 1 + + denseInitialLengthLoopTime (address + 1) rest + +/-- The lone positive-tag overlay installed for the public input. -/ +def denseProgramInitialStore (input : List Bool) : Store := + (DenseOverlay.Snapshot.initial input).overlay + +/-- Exact clean work image of a dense-overlay snapshot. -/ +def denseProgramSnapshotWork {n : β„•} (tapes : ControlInstructionTapes n) + (snapshot : DenseOverlay.Snapshot) : Fin (n + 1) β†’ Tape := + programSnapshotWork tapes { pc := snapshot.pc, store := snapshot.overlay } + +/-- Count the input, emit its positive `Rβ‚€` tag, install the sparse ABI, and +rewind the immutable input bank to cell one. -/ +def denseProgramInitTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM (initialSetupTM tapes) + (TM.seqTM (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM))) + +/-- Exact compositional time budget for dense-overlay initialization. -/ +def denseProgramInitTime {n : β„•} (tapes : ControlInstructionTapes n) + (input : List Bool) : β„• := + (1 + 1 + (TM.binarySuccTime 0 + 1 + TM.binarySuccTime 0)) + 1 + + (denseInitialLengthLoopTime 1 input + 1 + + ((rewindEntryEncodeRestoreTime (0, input.length + 1) + 1 + + TM.binarySuccTime 0) + 1 + + (initialAbiInstallTime tapes (denseProgramInitialStore input) + (input.length + 1) + 1 + + (input.length + 1 + 2)))) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitProof.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitProof.lean new file mode 100644 index 0000000000..11f6abc6ca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInitProof.lean @@ -0,0 +1,559 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseInitDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.DenseOverlay +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Internal + +/-! +# Dense-overlay public-input initialization -- proofs +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem parked_of_binaryNat {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private def denseInitialLengthWrap (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q) : + Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q := + { state := .inr c.state + input := c.input + work := c.work + output := c.output } + +private theorem denseInitialLengthLoopTM_body_step + (tapes : ControlInstructionTapes n) + {c c' : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q} + (hstep : (initialZeroBitTM tapes).step c = some c') : + (denseInitialLengthLoopTM tapes).step (denseInitialLengthWrap tapes c) = + some (denseInitialLengthWrap tapes c') := by + have hne : c.state β‰  (initialZeroBitTM tapes).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, + ite_eq_right (by simp [denseInitialLengthWrap, denseInitialLengthLoopTM])] + simp only [denseInitialLengthWrap, denseInitialLengthLoopTM, hne, + ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize (initialZeroBitTM tapes).Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨state, workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := + action + intro hstep + cases Option.some.inj hstep + rfl + +private theorem denseInitialLengthLoopTM_body_reachesIn + (tapes : ControlInstructionTapes n) + {time : β„•} {c c' : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q} + (hreach : (initialZeroBitTM tapes).reachesIn time c c') : + (denseInitialLengthLoopTM tapes).reachesIn time + (denseInitialLengthWrap tapes c) (denseInitialLengthWrap tapes c') := + TM.reachesIn_map (denseInitialLengthWrap tapes) + (fun _ _ => denseInitialLengthLoopTM_body_step tapes) hreach + +private theorem denseInitialLengthLoopTM_step_scan_data + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q) + (hstate : c.state = .inl .scan) (hblank : c.input.read β‰  Ξ“.blank) + (hstart : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (denseInitialLengthLoopTM tapes).step c = some + { state := .inr (initialZeroBitTM tapes).qstart + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, + ite_eq_right (by rw [hstate]; simp [denseInitialLengthLoopTM])] + simp only [denseInitialLengthLoopTM, hstate, hblank, TM.allReadBack, + ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [TM.idleDir, hstart, Tape.move] + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, ite_eq_right houtput] + rfl + +private theorem denseInitialLengthLoopTM_step_scan_blank + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q) + (hstate : c.state = .inl .scan) (hblank : c.input.read = Ξ“.blank) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (denseInitialLengthLoopTM tapes).step c = some + { state := .inl .done + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, + ite_eq_right (by rw [hstate]; simp [denseInitialLengthLoopTM])] + simp only [denseInitialLengthLoopTM, hstate, hblank, TM.allReadBack, + ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [TM.idleDir, Tape.move] + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, ite_eq_right houtput] + rfl + +private theorem denseInitialLengthLoopTM_step_body_halt + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q) + (hhalt : (initialZeroBitTM tapes).halted c) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (denseInitialLengthLoopTM tapes).step + (denseInitialLengthWrap tapes c) = some + { state := .inl .scan + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + rw [TM.step, + ite_eq_right (by simp [denseInitialLengthWrap, denseInitialLengthLoopTM])] + simp only [denseInitialLengthWrap, denseInitialLengthLoopTM, hhalt, + ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, ite_eq_right houtput] + rfl + +theorem denseInitialLengthLoopTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) + (address count : β„•) (entries : Store) + (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.HasBinarySuffix input) + (hready : InitialLoopReady tapes address count entries workβ‚€) + (houtput : outβ‚€ = TM.resetBinaryBlank) : + (denseInitialLengthLoopTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp.HasBinarySuffix [] ∧ + inp.head = inpβ‚€.head + input.length ∧ + InitialLoopReady tapes (address + input.length) count entries work ∧ + out = outβ‚€) + (denseInitialLengthLoopTime address input) := by + induction input generalizing address inpβ‚€ workβ‚€ outβ‚€ with + | nil => + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let done : Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q := + { state := .inl .done + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hstep := denseInitialLengthLoopTM_step_scan_blank tapes + ({ state := (denseInitialLengthLoopTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q) + rfl hinput.read_nil + (fun i => (hready.parked i).read_ne_start) + (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact (parked_of_binaryNat hblankNat).read_ne_start) + refine ⟨done, 1, by simp [denseInitialLengthLoopTime], + .step (by simpa [done] using! hstep) .zero, ?_, ?_⟩ + Β· rfl + Β· exact ⟨hinput, rfl, by simpa, rfl⟩ + | cons bit rest ih => + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let scan : Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q := + { state := (denseInitialLengthLoopTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + let bodyStart : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q := + { state := (initialZeroBitTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hinputParked : TM.Parked inpβ‚€ := parked_of_binarySuffix hinput + have houtputParked : TM.Parked outβ‚€ := by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hreadNonblank : inpβ‚€.read β‰  Ξ“.blank := by + rw [hinput.read_cons] + exact Ξ“.ofBool_ne_blank bit + have hreadNonstart : inpβ‚€.read β‰  Ξ“.start := by + rw [hinput.read_cons] + exact Ξ“.ofBool_ne_start bit + have hscanStep := denseInitialLengthLoopTM_step_scan_data tapes scan + rfl hreadNonblank hreadNonstart + (fun i => (hready.parked i).read_ne_start) + houtputParked.read_ne_start + have hscanReach : (denseInitialLengthLoopTM tapes).reachesIn 1 scan + (denseInitialLengthWrap tapes bodyStart) := + .step (by simpa [scan, bodyStart, denseInitialLengthWrap] using! + hscanStep) .zero + have hbody := initialZeroBitTM_hoareTime_internal tapes address count + entries inpβ‚€ workβ‚€ outβ‚€ hready hinputParked houtputParked + obtain ⟨bodyDone, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hbodyReady, hbodyOutput⟩ := + hbody inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hbodyLift := + denseInitialLengthLoopTM_body_reachesIn tapes hbodyReach + let nextScan : + Complexity.Cfg (n + 1) (denseInitialLengthLoopTM tapes).Q := + { state := .inl .scan + input := bodyDone.input.move Dir3.right + work := bodyDone.work + output := bodyDone.output } + have hseamStep := denseInitialLengthLoopTM_step_body_halt tapes bodyDone + hbodyHalt (fun i => (hbodyReady.parked i).read_ne_start) + (by rw [hbodyOutput]; exact houtputParked.read_ne_start) + have hseamReach : (denseInitialLengthLoopTM tapes).reachesIn 1 + (denseInitialLengthWrap tapes bodyDone) nextScan := + .step (by simpa [nextScan] using! hseamStep) .zero + have hnextInput : + (bodyDone.input.move Dir3.right).HasBinarySuffix rest := by + rw [hbodyInput] + exact hinput.move_right_cons + have hnextOutput : bodyDone.output = TM.resetBinaryBlank := + hbodyOutput.trans houtput + have htail := ih (address + 1) (bodyDone.input.move Dir3.right) + bodyDone.work bodyDone.output hnextInput hbodyReady hnextOutput + obtain ⟨tailDone, tailTime, htailTime, htailReach, htailHalt, + htailInput, htailHead, htailReady, htailOutput⟩ := + htail _ _ _ ⟨rfl, rfl, rfl⟩ + have hreach := TM.reachesIn_trans (denseInitialLengthLoopTM tapes) + hscanReach (TM.reachesIn_trans (denseInitialLengthLoopTM tapes) + hbodyLift (TM.reachesIn_trans (denseInitialLengthLoopTM tapes) + hseamReach htailReach)) + refine ⟨tailDone, 1 + bodyTime + 1 + tailTime, ?_, ?_, + htailHalt, ?_⟩ + Β· simp only [denseInitialLengthLoopTime] + omega + Β· simpa [Nat.add_assoc] using! hreach + Β· refine ⟨htailInput, ?_, ?_, htailOutput.trans hbodyOutput⟩ + Β· rw [htailHead, hbodyInput] + simp only [Tape.move, List.length_cons] + omega + Β· simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using! htailReady + +private theorem denseProgramInitialStore_eq (input : List Bool) : + denseProgramInitialStore input = [(0, input.length + 1)] := by + simp [denseProgramInitialStore, DenseOverlay.Snapshot.initial, + DenseOverlay.write, RegisterStore.write] + +/-- Compose initialization phases whose parked tapes are unchanged by the phase transition. -/ +private theorem denseInit_sequence_parked {tapeCount : β„•} + (first second : TM tapeCount) + {firstTime secondTime : β„•} + {initial middle : Complexity.Cfg tapeCount first.Q} + {final : Complexity.Cfg tapeCount second.Q} + (hfirst : first.reachesIn firstTime initial middle) + (hhalt : first.halted middle) + (hsecond : second.reachesIn secondTime + { state := second.qstart, input := middle.input, + work := middle.work, output := middle.output } final) + (hinput : TM.Parked middle.input) (hwork : βˆ€ i, TM.Parked (middle.work i)) + (houtput : TM.Parked middle.output) : + (TM.seqTM first second).reachesIn (firstTime + 1 + secondTime) + (TM.phase1Wrap first second initial) (TM.phase2Wrap first second final) := by + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start hinput.read_ne_start + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + apply TM.seqTM_reachesIn_of_reachesIn first second hfirst hhalt + simpa only [hinputTransition, hworkTransition, houtputTransition] using! hsecond + +/-- The installed dense snapshot provides the complete parked frame needed for input rewind. -/ +private theorem denseInitialRewind_preconditions + (tapes : ControlInstructionTapes n) (input : List Bool) + (abiInput : Tape) (abiWork : Fin (n + 1) β†’ Tape) (abiOutput emitOutput : Tape) + (habiInputCells : abiInput.cells = (Tape.init (input.map Ξ“.ofBool)).cells) + (habiInputHead : abiInput.head = input.length + 1) + (habiWork : abiWork = programSnapshotWork tapes + { pc := 0, store := denseProgramInitialStore input }) + (habiOutput : abiOutput = emitOutput) + (hemitOutputParked : TM.Parked emitOutput) + (hemitOutputBlank : emitOutput = TM.resetBinaryBlank) : + InstructionExecutionReady tapes (denseProgramInitialStore input) 0 + (programSnapshotWork tapes { pc := 0, store := denseProgramInitialStore input }) ∧ + (abiInput.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ abiInput.cells j β‰  Ξ“.start) ∧ + abiInput.head ≀ input.length + 1 ∧ + abiOutput.read β‰  Ξ“.start ∧ abiOutput.head β‰₯ 1 ∧ + (βˆ€ i, (abiWork i).read β‰  Ξ“.start ∧ + (abiWork i).head β‰₯ 1) ∧ + (abiInput.cells = (Tape.init (input.map Ξ“.ofBool)).cells ∧ + abiWork = denseProgramSnapshotWork tapes + (DenseOverlay.Snapshot.initial input) ∧ + abiOutput = TM.resetBinaryBlank)) := by + let sparseInitial : Snapshot := + { pc := 0, store := denseProgramInitialStore input } + have hsparseCanonical : Canonical sparseInitial.store := by + simpa [sparseInitial, denseProgramInitialStore] using! + DenseOverlay.Snapshot.initial_canonical input + have habiReady : InstructionExecutionReady tapes sparseInitial.store 0 + (programSnapshotWork tapes sparseInitial) := + programSnapshotWork_ready_internal tapes sparseInitial hsparseCanonical + refine ⟨habiReady, ?_⟩ + refine ⟨?_, ?_, by omega, ?_, ?_, ?_, habiInputCells, ?_, ?_⟩ + Β· rw [habiInputCells] + simp [Tape.init] + Β· intro j hj + rw [habiInputCells] + exact Tape.init_ofBool_cells_ne_start input j hj + Β· rw [habiOutput] + exact hemitOutputParked.read_ne_start + Β· rw [habiOutput] + exact hemitOutputParked.1 + Β· intro i + have hiParked := habiReady.control.lookup.scanner.parked i + have hworkEq : abiWork = programSnapshotWork tapes sparseInitial := + habiWork + rw [hworkEq] + exact ⟨hiParked.read_ne_start, hiParked.1⟩ + Β· simpa [denseProgramSnapshotWork, sparseInitial] using! habiWork + Β· exact habiOutput.trans hemitOutputBlank + +/-- Complete dense public-input initialization reaches the exact one-entry +snapshot image and rewinds the immutable input bank to cell one. -/ +theorem denseProgramInitTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) : + (denseProgramInitTM tapes).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = denseProgramSnapshotWork tapes + (DenseOverlay.Snapshot.initial input) ∧ + out = TM.resetBinaryBlank) + (denseProgramInitTime tapes input) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hsetup := initialSetupTM_hoareTime_internal tapes input + obtain ⟨setupDone, setupTime, hsetupTime, hsetupReach, hsetupHalt, + hsetupInput, hsetupInputEq, hsetupReady, hsetupOutput⟩ := + hsetup _ _ _ ⟨rfl, rfl, rfl⟩ + have hsetupBufferStart : + (setupDone.work tapes.buffer).cells 0 = Ξ“.start := by + apply TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hsetupReach + simp [Tape.init] + have hsetupInputParked : TM.Parked setupDone.input := + parked_of_binarySuffix hsetupInput + have hsetupOutputParked : TM.Parked setupDone.output := by + rw [hsetupOutput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hloop := denseInitialLengthLoopTM_hoareTime_internal tapes input + 1 0 [] setupDone.input setupDone.work setupDone.output hsetupInput + hsetupReady hsetupOutput + obtain ⟨loopDone, loopTime, hloopTime, hloopReach, hloopHalt, + hloopInput, hloopHead, hloopReadyRaw, hloopOutput⟩ := + hloop _ _ _ ⟨rfl, rfl, rfl⟩ + have hloopReady : InitialLoopReady tapes (input.length + 1) 0 [] + loopDone.work := by + simpa [Nat.add_comm] using! hloopReadyRaw + have hloopBufferStart : + (loopDone.work tapes.buffer).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hloopReach + hsetupBufferStart + have hloopInputParked : TM.Parked loopDone.input := + parked_of_binarySuffix hloopInput + have hloopOutputBlank : loopDone.output = TM.resetBinaryBlank := + hloopOutput.trans hsetupOutput + have hloopOutputParked : TM.Parked loopDone.output := by + rw [hloopOutputBlank] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hemit := initialLengthEmitTM_hoareTime_internal tapes + (input.length + 1) 0 [] loopDone.input loopDone.work loopDone.output + hloopReady hloopInputParked hloopOutputBlank + obtain ⟨emitDone, emitTime, hemitTime, hemitReach, hemitHalt, + hemitInput, hemitReadyRaw, hemitOutput⟩ := + hemit _ _ _ ⟨rfl, rfl, rfl⟩ + have hemitBufferStart : + (emitDone.work tapes.buffer).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hemitReach + hloopBufferStart + have hemitReady : InitialLoopReady tapes (input.length + 1) + (denseProgramInitialStore input).length + (denseProgramInitialStore input) emitDone.work := by + rw [denseProgramInitialStore_eq] + simpa using! hemitReadyRaw + have hemitInputParked : TM.Parked emitDone.input := by + rw [hemitInput] + exact hloopInputParked + have hemitOutputBlank : emitDone.output = TM.resetBinaryBlank := + hemitOutput.trans hloopOutputBlank + have hemitOutputParked : TM.Parked emitDone.output := by + rw [hemitOutputBlank] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have habi := initialAbiInstallTM_hoareTime_internal tapes + (denseProgramInitialStore input) (input.length + 1) emitDone.input + emitDone.work emitDone.output hemitReady hemitBufferStart + hemitInputParked hemitOutputBlank + obtain ⟨abiDone, abiTime, habiTime, habiReach, habiHalt, + habiInput, habiWork, habiOutput⟩ := + habi _ _ _ ⟨rfl, rfl, rfl⟩ + have habiInputCells : abiDone.input.cells = + (Tape.init (input.map Ξ“.ofBool)).cells := by + rw [habiInput, hemitInput, + TM.input_cells_eq_of_reachesIn hloopReach, hsetupInputEq] + rfl + have habiInputHead : abiDone.input.head = input.length + 1 := by + rw [habiInput, hemitInput, hloopHead, hsetupInputEq] + simp [Tape.move] + omega + let sparseInitial : Snapshot := + { pc := 0, store := denseProgramInitialStore input } + have hrewind := TM.rewindInputTM_hoareTime_frame + (n := n + 1) (input.length + 1) + (P := fun inp work out => + inp.cells = (Tape.init (input.map Ξ“.ofBool)).cells ∧ + work = denseProgramSnapshotWork tapes + (DenseOverlay.Snapshot.initial input) ∧ + out = TM.resetBinaryBlank) + (by + intro inp work out inp' work' out' hP hcells _hhead hwork' hout' + exact ⟨hcells.trans hP.1, + hwork'.trans hP.2.1, hout'.trans hP.2.2⟩) + obtain ⟨habiReady, hrewindPre⟩ := denseInitialRewind_preconditions + tapes input abiDone.input abiDone.work abiDone.output emitDone.output + habiInputCells habiInputHead habiWork habiOutput + hemitOutputParked hemitOutputBlank + obtain ⟨rewindDone, rewindTime, hrewindTime, hrewindReach, + hrewindHalt, hrewindHead, hrewindCells, hrewindWork, + hrewindOutput⟩ := hrewind _ _ _ hrewindPre + have habiInputParked : TM.Parked abiDone.input := + ⟨by omega, hrewindPre.2.1⟩ + have habiOutputParked : TM.Parked abiDone.output := by + rw [habiOutput] + exact hemitOutputParked + have habiWorkParked : βˆ€ i, TM.Parked (abiDone.work i) := by + intro i + rw [habiWork] + exact habiReady.control.lookup.scanner.parked i + have habiRewindReach := denseInit_sequence_parked + (initialAbiInstallTM tapes) TM.rewindInputTM habiReach habiHalt hrewindReach + habiInputParked habiWorkParked habiOutputParked + let abiRewindDone := TM.phase2Wrap (initialAbiInstallTM tapes) + TM.rewindInputTM rewindDone + have habiRewindHalt : + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM).halted + abiRewindDone := by + rw [TM.phase2Wrap_halted_iff] + exact hrewindHalt + have emitTailReach := denseInit_sequence_parked + (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM) + hemitReach hemitHalt habiRewindReach hemitInputParked + hemitReady.parked hemitOutputParked + let emitTailDone := TM.phase2Wrap (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM) + abiRewindDone + have emitTailHalt : + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM)).halted + emitTailDone := by + exact (TM.phase2Wrap_halted_iff + (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM) abiRewindDone).mpr + habiRewindHalt + have loopTailReach := denseInit_sequence_parked + (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM)) + hloopReach hloopHalt emitTailReach hloopInputParked + hloopReady.parked hloopOutputParked + let loopTailDone := TM.phase2Wrap (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM)) + emitTailDone + have loopTailHalt : + (TM.seqTM (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM))).halted + loopTailDone := by + exact (TM.phase2Wrap_halted_iff + (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM)) emitTailDone).mpr + emitTailHalt + have hreach := denseInit_sequence_parked + (initialSetupTM tapes) + (TM.seqTM (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM))) + hsetupReach hsetupHalt loopTailReach hsetupInputParked + hsetupReady.parked hsetupOutputParked + let finalCfg := TM.phase2Wrap (initialSetupTM tapes) + (TM.seqTM (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM))) + loopTailDone + refine ⟨finalCfg, + setupTime + 1 + + (loopTime + 1 + (emitTime + 1 + (abiTime + 1 + rewindTime))), + ?_, hreach, ?_, ?_⟩ + Β· unfold denseProgramInitTime + omega + Β· change (denseProgramInitTM tapes).halted finalCfg + unfold denseProgramInitTM + exact (TM.phase2Wrap_halted_iff + (initialSetupTM tapes) + (TM.seqTM (denseInitialLengthLoopTM tapes) + (TM.seqTM (initialLengthEmitTM tapes) + (TM.seqTM (initialAbiInstallTM tapes) TM.rewindInputTM))) loopTailDone).mpr + loopTailHalt + Β· refine ⟨?_, hrewindWork, hrewindOutput⟩ + change rewindDone.input = + (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + exact Tape.ext (by simpa [Tape.move] using! hrewindHead) + (by simpa [Tape.move] using! hrewindCells) + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInternal.lean new file mode 100644 index 0000000000..3f0e9ff6aa --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/DenseInternal.lean @@ -0,0 +1,521 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.DenseDefs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.DenseDispatch + +/-! +# Dense-overlay RAM program controller -- proof internals +-/ + + +@[expose] public section + +namespace Complexity +namespace RAM +namespace RegisterStore +namespace Machine + +variable {n : β„•} + +private theorem denseInput_parked (input : List Bool) : + TM.Parked ((Tape.init (input.map Ξ“.ofBool)).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + simpa using! Tape.init_ofBool_move_right_cells_ne_start input + +private theorem blankOutput_parked : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.init, Tape.move] + omega + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- Final dense lookup and Boolean emission recover the decoded RAM verdict +register. -/ +theorem denseProgramOutputTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseProgramOutputTM tapes).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp _work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + out = registerVerdictOutput (DenseOverlay.read input overlay 0)) + (denseProgramOutputTime tapes input overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let blank := (Tape.init []).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have hlookup := denseOverlayLookupStaticTM_hoareTime_frame + tapes.lifted.data.lhsLookup input overlay 0 initialWork blank hvalid + hready.control.lookup blankOutput_parked + let mid : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes.lifted.data.lhsLookup input + overlay 0 initialWork work ∧ + out = blank + have hverdict : (registerVerdictTM tapes.liftedLhs).HoareTime mid + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (DenseOverlay.read input overlay 0)) + 1 := by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hleaf := registerVerdictTM_hoareTime_frame_internal + tapes.liftedLhs (DenseOverlay.read input overlay 0) inpβ‚€ work + hresult.destination hinput hresult.parked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + _hfinalWork, hfinalOutput⟩ := + hleaf inp work out ⟨hinp, rfl, by simpa only [blank] using! hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, hfinalOutput⟩ + have hseq := TM.seqTM_hoareTime + (denseOverlayLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) hlookup + (by + rintro inp work out ⟨hinp, hresult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hresult.parked + (by simpa [hout, blank] using! blankOutput_parked) + rw [hi, hw, ho] + exact ⟨hinp, hresult, by simpa only [blank] using! hout⟩) + hverdict + simpa only [denseProgramOutputTM, denseProgramOutputTime, mid, inpβ‚€, + blank] using! hseq + +/-- Final dense lookup overwrites the loop's halt-test bit with the decoded +RAM verdict. -/ +theorem denseProgramOutputTM_hoareTime_haltOutput_internal + (tapes : ControlInstructionTapes n) (input : List Bool) + (overlay : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid overlay) + (hready : InstructionExecutionReady tapes overlay pcValue initialWork) : + (denseProgramOutputTM tapes).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = instructionHaltOutput .halt) + (fun inp _work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + out = registerVerdictOutput (DenseOverlay.read input overlay 0)) + (denseProgramOutputTime tapes input overlay) := by + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let haltOut := instructionHaltOutput .halt + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have hhaltOutParked : TM.Parked haltOut := by + refine ⟨?_, ?_⟩ + Β· simp [haltOut, instructionHaltOutput, instructionHaltVerdict, + TM.idleDir, Tape.writeAndMove, Tape.move, Tape.write, Tape.read, + Tape.init] + Β· intro j hj + exact instructionHaltOutput_cells_ne_start .halt j hj + have hlookup := denseOverlayLookupStaticTM_hoareTime_frame + tapes.lifted.data.lhsLookup input overlay 0 initialWork haltOut hvalid + hready.control.lookup hhaltOutParked + let mid : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + DenseOverlayLookupStaticResult tapes.lifted.data.lhsLookup input + overlay 0 initialWork work ∧ + out = haltOut + have hverdict : (registerVerdictTM tapes.liftedLhs).HoareTime mid + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (DenseOverlay.read input overlay 0)) + 1 := by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hleaf := registerVerdictTM_hoareTime_haltOutput_internal + tapes.liftedLhs (DenseOverlay.read input overlay 0) inpβ‚€ work + hresult.destination hinput hresult.parked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + _hfinalWork, hfinalOutput⟩ := + hleaf inp work out ⟨hinp, rfl, by simpa only [haltOut] using! hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, hfinalOutput⟩ + have hseq := TM.seqTM_hoareTime + (denseOverlayLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) hlookup + (by + rintro inp work out ⟨hinp, hresult, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) hresult.parked + (by simpa [hout, haltOut] using! hhaltOutParked) + rw [hi, hw, ho] + exact ⟨hinp, hresult, by simpa only [haltOut] using! hout⟩) + hverdict + simpa only [denseProgramOutputTM, denseProgramOutputTime, mid, inpβ‚€, + haltOut] using! hseq + +/-- One dense loop iteration realizes one overlay step and either halts on the +successor's selected instruction or returns to the body start. -/ +theorem denseProgramLoopTM_iteration_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) (snapshot : DenseOverlay.Snapshot) + (initialWork : Fin (n + 1) β†’ Tape) + (hvalid : DenseOverlay.Valid snapshot.overlay) + (hready : InstructionExecutionReady tapes snapshot.overlay snapshot.pc + initialWork) : + let next := snapshot.step program input + βˆƒ (nextWork : Fin (n + 1) β†’ Tape) (time : β„•), + time ≀ denseProgramLoopIterationTime tapes program input snapshot ∧ + InstructionExecutionReady tapes next.overlay next.pc nextWork ∧ + ((next.Halted program ∧ + (denseProgramLoopTM tapes program).reachesIn time + { state := (denseProgramLoopTM tapes program).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := nextWork + output := instructionHaltOutput (next.curInstr program) }) ∨ + (Β¬next.Halted program ∧ + (denseProgramLoopTM tapes program).reachesIn time + { state := (denseProgramLoopTM tapes program).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := (denseProgramLoopTM tapes program).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := nextWork + output := (Tape.init []).move Dir3.right })) := by + let next := snapshot.step program input + let body := denseProgramStepTM tapes program + let test := programHaltTM tapes program + let inpβ‚€ := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let blank := (Tape.init []).move Dir3.right + have hinput : TM.Parked inpβ‚€ := by + simpa only [inpβ‚€] using! denseInput_parked input + have hbody := denseProgramStepTM_hoareTime_frame tapes program input + snapshot.overlay snapshot.pc initialWork hvalid hready + obtain ⟨cbody, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hnextReadyRaw, hbodyOutput⟩ := + hbody inpβ‚€ initialWork blank ⟨rfl, rfl, rfl⟩ + have hnextReady : InstructionExecutionReady tapes next.overlay next.pc + cbody.work := by + simpa [next, DenseOverlay.Snapshot.step, + DenseOverlay.Snapshot.curInstr, denseInstructionStore, + denseInstructionPC, selectedInstruction_eq_getElem?_getD] using! + hnextReadyRaw + have hbodyInputParked : TM.Parked cbody.input := by + simpa [hbodyInput] using! hinput + have hbodyWorkParked : βˆ€ i, TM.Parked (cbody.work i) := + hnextReady.control.lookup.scanner.parked + have hbodyOutputParked : TM.Parked cbody.output := by + simpa [hbodyOutput, blank] using! blankOutput_parked + have hbodyLoop := TM.loopTM_body_simulation body test hbodyReach + have hbodyTransition : + (⟨test.qstart, TM.transitionInput cbody.input, + fun i => TM.transitionTape (cbody.work i), + TM.transitionTape cbody.output⟩ : Complexity.Cfg (n + 1) test.Q) = + ⟨test.qstart, inpβ‚€, cbody.work, blank⟩ := by + have hi : TM.transitionInput cbody.input = inpβ‚€ := by + rw [hbodyInput] + exact hinput.transitionInput_eq_self + have hw : (fun i => TM.transitionTape (cbody.work i)) = cbody.work := + funext fun i => (hbodyWorkParked i).transitionTape_eq_self + have ho : TM.transitionTape cbody.output = blank := by + rw [hbodyOutput] + exact blankOutput_parked.transitionTape_eq_self + rw [hi, hw, ho] + have hbodyToTest := TM.loopTM_body_to_test body test hbodyHalt + rw [hbodyTransition] at hbodyToTest + have htest := programHaltTM_hoareTime_frame_internal tapes program + next.overlay next.pc cbody.work inpβ‚€ hnextReady hinput + obtain ⟨ctest, testTime, htestTime, htestReach, htestHalt, + htestInput, htestWork, htestOutput⟩ := + htest inpβ‚€ cbody.work blank ⟨rfl, rfl, rfl⟩ + have hselected : + selectedInstruction program next.pc = next.curInstr program := + selectedInstruction_eq_getElem?_getD program next.pc + have htestOutput' : + ctest.output = instructionHaltOutput (next.curInstr program) := by + simpa only [hselected] using! htestOutput + have htestInputParked : TM.Parked ctest.input := by + simpa [htestInput] using! hinput + have htestWorkParked : βˆ€ i, TM.Parked (ctest.work i) := by + simpa [htestWork] using! hbodyWorkParked + have htestOutputParked : TM.Parked ctest.output := by + refine ⟨?_, ?_⟩ + Β· rw [htestOutput', instructionHaltOutput_head] + Β· rw [htestOutput'] + exact instructionHaltOutput_cells_ne_start _ + have htestTransition : + (⟨(Sum.inr (Sum.inl TM.LoopPhase.rewindOut) : + TM.LoopQ body.Q test.Q), + TM.transitionInput ctest.input, + fun i => TM.transitionTape (ctest.work i), + TM.transitionTape ctest.output⟩ : + Complexity.Cfg (n + 1) (TM.LoopQ body.Q test.Q)) = + ⟨Sum.inr (Sum.inl TM.LoopPhase.rewindOut), inpβ‚€, + cbody.work, ctest.output⟩ := by + have hi : TM.transitionInput ctest.input = inpβ‚€ := by + rw [htestInput] + exact hinput.transitionInput_eq_self + have hw : (fun i => TM.transitionTape (ctest.work i)) = cbody.work := by + funext i + rw [htestWork] + exact (hbodyWorkParked i).transitionTape_eq_self + have ho : TM.transitionTape ctest.output = ctest.output := + htestOutputParked.transitionTape_eq_self + rw [hi, hw, ho] + have htestToRewind := + (TM.loopTM_test_to_rewind body test htestHalt).trans + (congrArg some htestTransition) + obtain ⟨ctail, htailReach, htailState, htailInput, htailWork, + htailOutput⟩ := programLoop_rewind_check_internal body test + ⟨Sum.inr (Sum.inl TM.LoopPhase.rewindOut), inpβ‚€, + cbody.work, ctest.output⟩ rfl hinput.read_ne_start + (fun i => (hbodyWorkParked i).read_ne_start) + (by rw [htestOutput', instructionHaltOutput_head]) + (by rw [htestOutput', instructionHaltOutput_cells_zero]) + (by rw [htestOutput']; exact instructionHaltOutput_cells_ne_start _) + have hreach := TM.reachesIn_trans _ + (TM.reachesIn_trans _ + (TM.reachesIn_trans _ + (TM.reachesIn_trans _ hbodyLoop (.step hbodyToTest .zero)) + (TM.loopTM_test_simulation body test htestReach)) + (.step htestToRewind .zero)) htailReach + have htime : bodyTime + 1 + testTime + 1 + 3 ≀ + denseProgramLoopIterationTime tapes program input snapshot := by + dsimp only [next] at htestTime + simp only [denseProgramLoopIterationTime] + omega + refine ⟨cbody.work, bodyTime + 1 + testTime + 1 + 3, htime, + hnextReady, ?_⟩ + by_cases hhalted : next.Halted program + Β· left + refine ⟨hhalted, ?_⟩ + have hone : ctest.output.cells 1 = Ξ“.one := by + rw [htestOutput'] + exact instructionHaltOutput_cell_one_eq_one_iff _ |>.2 hhalted + have htailDone : ctail.state = + Sum.inr (Sum.inl TM.LoopPhase.done) := by + simpa [hone] using! htailState + have hcTail : ctail = + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := inpβ‚€ + work := cbody.work + output := instructionHaltOutput (next.curInstr program) } := by + cases ctail + apply Complexity.Cfg.ext + Β· exact htailDone + Β· exact htailInput + Β· exact htailWork + Β· exact htailOutput.trans htestOutput' + simpa only [denseProgramLoopTM, body, test, inpβ‚€, blank, hcTail] using! + hreach + Β· right + refine ⟨hhalted, ?_⟩ + have hcur : next.curInstr program β‰  .halt := hhalted + have hblankOutput : ctest.output = blank := by + rw [htestOutput'] + simpa only [blank] using! + instructionHaltOutput_eq_blank_of_ne_halt hcur + have hone : ctest.output.cells 1 β‰  Ξ“.one := by + rw [htestOutput'] + exact fun h => hhalted + (instructionHaltOutput_cell_one_eq_one_iff _ |>.1 h) + have htailStart : ctail.state = Sum.inl body.qstart := by + simpa [hone] using! htailState + have hcTail : ctail = + { state := Sum.inl body.qstart + input := inpβ‚€ + work := cbody.work + output := blank } := by + cases ctail + apply Complexity.Cfg.ext + Β· exact htailStart + Β· exact htailInput + Β· exact htailWork + Β· exact htailOutput.trans hblankOutput + simpa only [denseProgramLoopTM, body, test, inpβ‚€, blank, hcTail] using! + hreach + +/-- A halted dense snapshot is stationary under one selected step. -/ +theorem denseSnapshot_step_eq_self_of_halted_internal + (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) + (hhalted : snapshot.Halted program) : + snapshot.step program input = snapshot := by + change snapshot.curInstr program = .halt at hhalted + rw [DenseOverlay.Snapshot.step, hhalted] + rfl + +/-- Running a halted dense snapshot for arbitrary additional fuel is a no-op. -/ +theorem denseSnapshot_run_halted_internal + (program : Program) (input : List Bool) + (snapshot : DenseOverlay.Snapshot) + (hhalted : snapshot.Halted program) : + βˆ€ fuel, snapshot.run program input fuel = snapshot + | 0 => rfl + | fuel + 1 => by + rw [DenseOverlay.Snapshot.run, ite_eq_left hhalted] + +/-- A halted fuel-bounded dense run is realized by the fixed controller loop. +The extra iteration handles a snapshot already halted at fuel zero. -/ +theorem denseProgramLoopTM_hoareTime_run_internal + (tapes : ControlInstructionTapes n) (program : Program) + (input : List Bool) : + βˆ€ (fuel : β„•) (snapshot : DenseOverlay.Snapshot) + (initialWork : Fin (n + 1) β†’ Tape), + DenseOverlay.Valid snapshot.overlay β†’ + InstructionExecutionReady tapes snapshot.overlay snapshot.pc + initialWork β†’ + (snapshot.run program input fuel).Halted program β†’ + (denseProgramLoopTM tapes program).HoareTime + (fun inp work out => + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + work = initialWork ∧ out = (Tape.init []).move Dir3.right) + (fun inp work out => + let final := snapshot.run program input fuel + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + InstructionExecutionReady tapes final.overlay final.pc work ∧ + out = instructionHaltOutput (final.curInstr program)) + (denseProgramLoopTime tapes program input (fuel + 1) + snapshot) := by + intro fuel + induction fuel with + | zero => + intro snapshot initialWork hvalid hready hhalted + rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hsnapshotHalted : snapshot.Halted program := by + simpa [DenseOverlay.Snapshot.run] using! hhalted + have hstepSelf := denseSnapshot_step_eq_self_of_halted_internal + program input snapshot hsnapshotHalted + obtain ⟨nextWork, time, htime, hnextReady, hbranch⟩ := + denseProgramLoopTM_iteration_internal tapes program input snapshot + initialWork hvalid hready + rcases hbranch with ⟨hnextHalted, hreach⟩ | + ⟨hnextRunning, _⟩ + Β· have hready' : InstructionExecutionReady tapes snapshot.overlay + snapshot.pc nextWork := by + simpa only [hstepSelf] using! hnextReady + have hreach' : (denseProgramLoopTM tapes program).reachesIn time + { state := (denseProgramLoopTM tapes program).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := nextWork + output := instructionHaltOutput + (snapshot.curInstr program) } := by + simpa only [hstepSelf] using! hreach + refine ⟨_, time, ?_, hreach', rfl, rfl, ?_, ?_⟩ + Β· simpa [denseProgramLoopTime] using! htime + Β· simpa [DenseOverlay.Snapshot.run] using! hready' + Β· simp [DenseOverlay.Snapshot.run] + Β· exact (hnextRunning (by simpa only [hstepSelf] using! + hsnapshotHalted)).elim + | succ fuel ih => + intro snapshot initialWork hvalid hready hhalted + by_cases hsnapshotHalted : snapshot.Halted program + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hstepSelf := denseSnapshot_step_eq_self_of_halted_internal + program input snapshot hsnapshotHalted + obtain ⟨nextWork, time, htime, hnextReady, hbranch⟩ := + denseProgramLoopTM_iteration_internal tapes program input snapshot + initialWork hvalid hready + rcases hbranch with ⟨_, hreach⟩ | ⟨hnextRunning, _⟩ + Β· have hfinal : snapshot.run program input (fuel + 1) = snapshot := + denseSnapshot_run_halted_internal program input snapshot + hsnapshotHalted _ + have hready' : InstructionExecutionReady tapes snapshot.overlay + snapshot.pc nextWork := by + simpa only [hstepSelf] using! hnextReady + have hreach' : (denseProgramLoopTM tapes program).reachesIn time + { state := (denseProgramLoopTM tapes program).qstart + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + work := nextWork + output := instructionHaltOutput + (snapshot.curInstr program) } := by + simpa only [hstepSelf] using! hreach + refine ⟨_, time, ?_, hreach', rfl, rfl, ?_, ?_⟩ + Β· simp only [denseProgramLoopTime] + omega + Β· simpa only [hfinal] using! hready' + Β· simp only [hfinal] + Β· exact (hnextRunning (by simpa only [hstepSelf] using! + hsnapshotHalted)).elim + Β· have hrunHalted : + ((snapshot.step program input).run program input fuel).Halted + program := by + simpa [DenseOverlay.Snapshot.run, hsnapshotHalted] using! hhalted + have hiter := denseProgramLoopTM_iteration_internal tapes program + input snapshot initialWork hvalid hready + obtain ⟨nextWork, time₁, htime₁, hnextReady, hbranch⟩ := hiter + rcases hbranch with ⟨hnextHalted, hreachβ‚βŸ© | + ⟨hnextRunning, hreachβ‚βŸ© + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hfinal : + (snapshot.step program input).run program input fuel = + snapshot.step program input := + denseSnapshot_run_halted_internal program input + (snapshot.step program input) hnextHalted fuel + refine ⟨_, time₁, ?_, hreach₁, rfl, rfl, ?_, ?_⟩ + Β· simp only [denseProgramLoopTime] + omega + Β· simpa [DenseOverlay.Snapshot.run, hsnapshotHalted, hfinal] + using! hnextReady + Β· simp [DenseOverlay.Snapshot.run, hsnapshotHalted, hfinal] + Β· have hnextValid := DenseOverlay.Snapshot.step_valid program input + snapshot hvalid + have hrecursive := ih (snapshot.step program input) nextWork + hnextValid hnextReady hrunHalted + rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + obtain ⟨cfinal, timeβ‚‚, htimeβ‚‚, hreachβ‚‚, hhaltβ‚‚, + hfinalInput, hfinalReady, hfinalOutput⟩ := + hrecursive + ((Tape.init (input.map Ξ“.ofBool)).move Dir3.right) + nextWork ((Tape.init []).move Dir3.right) ⟨rfl, rfl, rfl⟩ + refine ⟨cfinal, time₁ + timeβ‚‚, ?_, + TM.reachesIn_trans _ hreach₁ hreachβ‚‚, hhaltβ‚‚, + hfinalInput, ?_, ?_⟩ + Β· change time₁ + timeβ‚‚ ≀ + denseProgramLoopIterationTime tapes program input snapshot + + denseProgramLoopTime tapes program input (fuel + 1) + (snapshot.step program input) + exact Nat.add_le_add htime₁ htimeβ‚‚ + Β· simpa [DenseOverlay.Snapshot.run, hsnapshotHalted] using! + hfinalReady + Β· simpa [DenseOverlay.Snapshot.run, hsnapshotHalted] using! + hfinalOutput + +end Machine +end RegisterStore +end RAM +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init.lean new file mode 100644 index 0000000000..bd11eb1dea --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Defs.lean new file mode 100644 index 0000000000..4af42069d0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Defs.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs + +/-! +# Sparse RAM public-input initialization definitions + +This layer constructs the reusable sparse-snapshot ABI from the standard TM +input tape. It emits nonzero bit registers in increasing address order, then +appends the nonzero length register `Rβ‚€`. The resulting order need not equal +`initialStore`; it is a canonical sparse store representing the same total +RAM register file. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Nonzero public-input bit registers, beginning at `address`. -/ +def inputBitStoreFrom : β„• β†’ List Bool β†’ Store + | _, [] => [] + | address, bit :: rest => + (if bit then [(address, 1)] else []) ++ + inputBitStoreFrom (address + 1) rest + +/-- Streaming-friendly public-input store: bit registers first and the +nonzero length register last. -/ +def programInitialStore (input : List Bool) : Store := + RegisterStore.write (inputBitStoreFrom 1 input) 0 input.length + +/-- Sparse initial snapshot used by the concrete initialization machine. -/ +def programInitialSnapshot (input : List Bool) : Snapshot := + { pc := 0, store := programInitialStore input } + +/-- Number of nonzero entries emitted by the bit-register prefix. -/ +def inputTrueCount : List Bool β†’ β„• + | [] => 0 + | bit :: rest => (if bit then 1 else 0) + inputTrueCount rest + +/-- Append-positioned binary tape for an emitted store prefix. -/ +def programBinaryPrefixTape (bits : List Bool) : Tape := + { head := bits.length + 1 + cells := (Tape.init (bits.map Ξ“.ofBool)).cells } + +/-- Exact work family at a streaming input-loop boundary. -/ +def initialLoopWork {n : β„•} (tapes : ControlInstructionTapes n) + (address count : β„•) (entries : Store) : Fin (n + 1) β†’ Tape := + Function.update + (Function.update + (Function.update + (Function.update + (Function.const (Fin (n + 1)) TM.resetBinaryBlank) + tapes.liftedLhs (programBinaryTape address.bits)) + tapes.lifted.data.rhs (programBinaryTape (1 : β„•).bits)) + tapes.lifted.data.update.remaining + (programBinaryTape count.bits)) + tapes.buffer + (programBinaryPrefixTape (entries.flatMap Entry.encode)) + +/-- Streaming input-loop invariant. Only the current address, fixed value one, +runtime entry count, and append buffer differ from the standard blank frame. -/ +structure InitialLoopReady {n : β„•} (tapes : ControlInstructionTapes n) + (address count : β„•) (entries : Store) + (work : Fin (n + 1) β†’ Tape) : Prop where + address : (work tapes.liftedLhs).HasBinaryNat address + value : (work tapes.lifted.data.rhs).HasBinaryNat 1 + count : (work tapes.lifted.data.update.remaining).HasBinaryNat count + buffer : (work tapes.buffer).HasBinaryPrefix + (entries.flatMap Entry.encode) + parked : βˆ€ i, TM.Parked (work i) + frame : βˆ€ i, i β‰  tapes.liftedLhs β†’ i β‰  tapes.lifted.data.rhs β†’ + i β‰  tapes.lifted.data.update.remaining β†’ i β‰  tapes.buffer β†’ + work i = TM.resetBinaryBlank + +/-- Recursive work-independent streaming-loop bound. -/ +def initialInputLoopTime {n : β„•} (tapes : ControlInstructionTapes n) : + β„• β†’ β„• β†’ List Bool β†’ β„• + | _, _, [] => 1 + | address, count, bit :: rest => + let bodyTime := if bit then + rewindEntryEncodeRestoreTime (address, 1) + 1 + + TM.binarySuccTime count + 1 + TM.binarySuccTime address + else TM.binarySuccTime address + 1 + bodyTime + 1 + + initialInputLoopTime tapes (address + 1) + (count + if bit then 1 else 0) rest + +/-- Dynamic address/value assignment for one nonzero input bit. -/ +def initialBitEntryTapes {n : β„•} (tapes : ControlInstructionTapes n) : + EntryEncodeTapes n where + address := tapes.data.lhs + value := tapes.data.rhs + ne := tapes.data.ne (by decide) + +/-- Address-zero/length assignment for the final `Rβ‚€` entry. -/ +def initialLengthEntryTapes {n : β„•} (tapes : ControlInstructionTapes n) : + EntryEncodeTapes n where + address := tapes.data.update.entry.query + value := tapes.data.lhs + ne := tapes.data.ne (by decide) + +/-- Emit one nonzero bit entry, restore both entry sources to cell one, then +increment the runtime entry count and current input address. -/ +def initialOneBitTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM + (rewindEntryEncodeRestoreTM (initialBitEntryTapes tapes)).retargetOutput + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)) + +/-- A zero input bit emits no entry and only advances the current address. -/ +def initialZeroBitTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.binarySuccTM tapes.liftedLhs + +/-- Driver phases for streaming over the real Boolean input. -/ +inductive InitialInputPhase where + | scan + | done + deriving DecidableEq + +instance : Fintype InitialInputPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- State space of the public-input bit loop. -/ +abbrev InitialInputQ {n : β„•} (tapes : ControlInstructionTapes n) := + InitialInputPhase βŠ• ((initialOneBitTM tapes).Q βŠ• (initialZeroBitTM tapes).Q) + +/-- Scan the real input without moving before body entry. Each `1` invokes the +entry-emitting body, each `0` invokes the address-only body, and the preserving +body seam advances the input by one cell. -/ +def initialInputLoopTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) where + Q := InitialInputQ tapes + qstart := .inl .scan + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .scan => + if iHead = Ξ“.blank then + TM.allReadBack (.inl .done) iHead wHeads oHead + else if iHead = Ξ“.one then + TM.allReadBack (.inr (.inl (initialOneBitTM tapes).qstart)) + iHead wHeads oHead + else + TM.allReadBack (.inr (.inr (initialZeroBitTM tapes).qstart)) + iHead wHeads oHead + | .inl .done => TM.allIdle (.inl .done) iHead wHeads oHead + | .inr (.inl state) => + if state = (initialOneBitTM tapes).qhalt then + (.inl .scan, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, Dir3.right, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + else + let action := (initialOneBitTM tapes).Ξ΄ state iHead wHeads oHead + (.inr (.inl action.1), action.2.1, action.2.2.1, + action.2.2.2.1, action.2.2.2.2.1, action.2.2.2.2.2) + | .inr (.inr state) => + if state = (initialZeroBitTM tapes).qhalt then + (.inl .scan, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, Dir3.right, + fun i => TM.idleDir (wHeads i), TM.idleDir oHead) + else + let action := (initialZeroBitTM tapes).Ξ΄ state iHead wHeads oHead + (.inr (.inr action.1), action.2.1, action.2.2.1, + action.2.2.2.1, action.2.2.2.2.1, action.2.2.2.2.2) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .scan => + dsimp only + split + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· split <;> exact TM.rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact TM.rightOfStart_allIdle iHead wHeads oHead + | .inr (.inl state) => + dsimp only + split + Β· exact ⟨fun _ => rfl, fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + Β· exact (initialOneBitTM tapes).Ξ΄_right_of_start state + iHead wHeads oHead + | .inr (.inr state) => + dsimp only + split + Β· exact ⟨fun _ => rfl, fun _ => TM.idleDir_right_of_start, + TM.idleDir_right_of_start⟩ + Β· exact (initialZeroBitTM tapes).Ξ΄_right_of_start state + iHead wHeads oHead + +/-- Emit the nonzero `Rβ‚€ = |input|` entry and increment the entry count. -/ +def initialLengthEmitTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM + (rewindEntryEncodeRestoreTM + (initialLengthEntryTapes tapes)).retargetOutput + (TM.binarySuccTM tapes.lifted.data.update.remaining) + +/-- Skip the length entry at zero; otherwise append it to the buffer. -/ +def initialLengthTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.branchWorkBlankTM tapes.liftedLhs TM.skipTM + (initialLengthEmitTM tapes) + +/-- Selected-branch bound for optional length-register emission. -/ +def initialLengthTime (length count : β„•) : β„• := + 1 + if length = 0 then 1 else + rewindEntryEncodeRestoreTime (0, length) + 1 + + TM.binarySuccTime count + +/-- Cleanup targets used after the complete input store has been copied into +the read-only source role. -/ +def initialCleanupTargets {n : β„•} + (tapes : ControlInstructionTapes n) : List (Fin (n + 1)) := + [tapes.liftedLhs, tapes.lifted.data.rhs] + +/-- Canonical contents reset by the final two-target cleanup. -/ +def initialCleanupBits {n : β„•} (tapes : ControlInstructionTapes n) + (length : β„•) (i : Fin (n + 1)) : List Bool := + if i = tapes.liftedLhs then length.bits + else if i = tapes.lifted.data.rhs then (1 : β„•).bits + else [] + +/-- Exact compositional bound for installing a completed store into the +program-loop ABI. -/ +def initialAbiInstallTime {n : β„•} (tapes : ControlInstructionTapes n) + (store : Store) (length : β„•) : β„• := + let encodedLength := (store.flatMap Entry.encode).length + TM.binaryCopyTime store.length 0 + 1 + + (encodedLength + 1 + 2) + 1 + + (encodedLength + 1) + 1 + + (encodedLength + 1 + 2) + 1 + + TM.resetBinaryWorkTime (encodedLength + 1) encodedLength + 1 + + TM.resetBinaryWorkManyTime (initialCleanupBits tapes length) + (fun _ => 1) (initialCleanupTargets tapes) + +/-- Park the standard initial tapes and seed the streaming address/value +sources with one. -/ +def initialSetupTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM TM.skipTM + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)) + +/-- Restore the address cursor from `|input| + 1` to `|input|`, then append +the optional nonzero length register. -/ +def initialLengthInstallTM {n : β„•} + (tapes : ControlInstructionTapes n) : TM (n + 1) := + TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (initialLengthTM tapes) + +/-- Copy the completed buffer into the reusable source/count roles and clear +the remaining initialization temporaries. -/ +def initialAbiInstallTM {n : β„•} + (tapes : ControlInstructionTapes n) : TM (n + 1) := + TM.seqTM + (TM.binaryCopyIntoTM + tapes.lifted.data.update.remaining + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.found) + (TM.seqTM (TM.rewindWorkTM tapes.buffer) + (TM.seqTM + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM + (initialCleanupTargets tapes)))))) + +/-- Install the length entry, source/count ABI, and clean loop temporaries. -/ +def initialFinalizeTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM (initialLengthInstallTM tapes) (initialAbiInstallTM tapes) + +/-- Complete public-input initialization. A leading skip parks every standard +initial tape, the streaming loop writes the sparse store into the last buffer, +and the tail installs the reusable source/count ABI and clears temporary roles. -/ +def programInitTM {n : β„•} (tapes : ControlInstructionTapes n) : + TM (n + 1) := + TM.seqTM (initialSetupTM tapes) + (TM.seqTM (initialInputLoopTM tapes) (initialFinalizeTM tapes)) + +/-- Exact compositional time bound for complete public-input initialization. -/ +def programInitTime {n : β„•} (tapes : ControlInstructionTapes n) + (input : List Bool) : β„• := + (1 + 1 + (TM.binarySuccTime 0 + 1 + TM.binarySuccTime 0)) + 1 + + (initialInputLoopTime tapes 1 0 input + 1 + + ((TM.binaryPredTime input.length + 1 + + initialLengthTime input.length (inputTrueCount input)) + 1 + + initialAbiInstallTime tapes (programInitialStore input) input.length)) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Internal.lean new file mode 100644 index 0000000000..b3e6a67c21 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Init/Internal.lean @@ -0,0 +1,2422 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.EntryEncode +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# Sparse RAM public-input initialization -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem programBinaryPrefixTape_hasBinaryPrefix (bits : List Bool) : + (programBinaryPrefixTape bits).HasBinaryPrefix bits := by + refine ⟨rfl, ?_, ?_⟩ + Β· intro i hi + exact Tape.init_ofBool_cells_lt bits i hi + Β· intro i hi + exact Tape.init_ofBool_cells_ge bits i hi + +private theorem programBinaryPrefixTape_parked (bits : List Bool) : + TM.Parked (programBinaryPrefixTape bits) := by + refine ⟨by simp [programBinaryPrefixTape], ?_⟩ + exact (show (programBinaryPrefixTape bits).HasBinaryContent bits from + (programBinaryPrefixTape_hasBinaryPrefix bits).2).cells_ne_start + +private theorem binaryTape_parked (bits : List Bool) : + TM.Parked (programBinaryTape bits) := by + have hstring : (programBinaryTape bits).HasBinaryString bits := by + simpa only [programBinaryTape] using! + Tape.init_move_right_hasBinaryString bits + exact ⟨by rw [hstring.1], hstring.hasBinaryContent.cells_ne_start⟩ + +private theorem initialLoopWork_lhs + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) : + initialLoopWork tapes address count entries tapes.liftedLhs = + programBinaryTape address.bits := by + have hlhsRhs : tapes.liftedLhs β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have hlhsCount : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := by + exact tapes.liftedData_ne_buffer 13 + unfold initialLoopWork + rw [Function.update_of_ne hlhsBuffer, + Function.update_of_ne hlhsCount, + Function.update_of_ne hlhsRhs, Function.update_self] + +private theorem initialLoopWork_rhs + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) : + initialLoopWork tapes address count entries tapes.lifted.data.rhs = + programBinaryTape (1 : β„•).bits := by + have hrhsCount : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := by + exact tapes.liftedData_ne_buffer 14 + unfold initialLoopWork + rw [Function.update_of_ne hrhsBuffer, + Function.update_of_ne hrhsCount, Function.update_self] + +private theorem initialLoopWork_count + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) : + initialLoopWork tapes address count entries + tapes.lifted.data.update.remaining = + programBinaryTape count.bits := by + have hcountBuffer : tapes.lifted.data.update.remaining β‰  tapes.buffer := by + exact tapes.liftedData_ne_buffer 9 + unfold initialLoopWork + rw [Function.update_of_ne hcountBuffer, + Function.update_self] + +private theorem initialLoopWork_buffer + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) : + initialLoopWork tapes address count entries tapes.buffer = + programBinaryPrefixTape (entries.flatMap Entry.encode) := by + simp [initialLoopWork] + +private theorem initialLoopWork_other + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) (i : Fin (n + 1)) + (hlhs : i β‰  tapes.liftedLhs) (hrhs : i β‰  tapes.lifted.data.rhs) + (hcount : i β‰  tapes.lifted.data.update.remaining) + (hbuffer : i β‰  tapes.buffer) : + initialLoopWork tapes address count entries i = TM.resetBinaryBlank := by + unfold initialLoopWork + rw [Function.update_of_ne hbuffer, Function.update_of_ne hcount, + Function.update_of_ne hrhs, Function.update_of_ne hlhs] + rfl + +theorem initialLoopWork_ready_internal + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) : + InitialLoopReady tapes address count entries + (initialLoopWork tapes address count entries) := by + have haddress := Tape.init_move_right_hasBinaryNat address + have hvalue := Tape.init_move_right_hasBinaryNat 1 + have hcount := Tape.init_move_right_hasBinaryNat count + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hblankParked : TM.Parked TM.resetBinaryBlank := + ⟨by rw [hblankNat.2.1], hblankNat.2.hasBinaryContent.cells_ne_start⟩ + refine + { address := by + rw [initialLoopWork_lhs] + simpa only [programBinaryTape] using! haddress + value := by + rw [initialLoopWork_rhs] + simpa only [programBinaryTape] using! hvalue + count := by + rw [initialLoopWork_count] + simpa only [programBinaryTape] using! hcount + buffer := by + rw [initialLoopWork_buffer] + exact programBinaryPrefixTape_hasBinaryPrefix _ + parked := ?_ + frame := initialLoopWork_other tapes address count entries } + intro i + by_cases hlhs : i = tapes.liftedLhs + Β· subst i + rw [initialLoopWork_lhs] + exact binaryTape_parked _ + by_cases hrhs : i = tapes.lifted.data.rhs + Β· subst i + rw [initialLoopWork_rhs] + exact binaryTape_parked _ + by_cases hcountIdx : i = tapes.lifted.data.update.remaining + Β· subst i + rw [initialLoopWork_count] + exact binaryTape_parked _ + by_cases hbuffer : i = tapes.buffer + Β· subst i + rw [initialLoopWork_buffer] + exact programBinaryPrefixTape_parked _ + Β· rw [initialLoopWork_other tapes address count entries i hlhs hrhs + hcountIdx hbuffer] + exact hblankParked + +private theorem parked_of_binaryNat {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private def initialInputOneWrap (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialOneBitTM tapes).Q) : + Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q := + { state := .inr (.inl c.state) + input := c.input + work := c.work + output := c.output } + +private def initialInputZeroWrap (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q) : + Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q := + { state := .inr (.inr c.state) + input := c.input + work := c.work + output := c.output } + +private theorem initialInputLoopTM_one_step + (tapes : ControlInstructionTapes n) + {c c' : Complexity.Cfg (n + 1) (initialOneBitTM tapes).Q} + (hstep : (initialOneBitTM tapes).step c = some c') : + (initialInputLoopTM tapes).step (initialInputOneWrap tapes c) = + some (initialInputOneWrap tapes c') := by + have hne : c.state β‰  (initialOneBitTM tapes).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [initialInputOneWrap, initialInputLoopTM])] + simp only [initialInputOneWrap, initialInputLoopTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize (initialOneBitTM tapes).Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨state, workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := + action + intro hstep + cases Option.some.inj hstep + rfl + +private theorem initialInputLoopTM_zero_step + (tapes : ControlInstructionTapes n) + {c c' : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q} + (hstep : (initialZeroBitTM tapes).step c = some c') : + (initialInputLoopTM tapes).step (initialInputZeroWrap tapes c) = + some (initialInputZeroWrap tapes c') := by + have hne : c.state β‰  (initialZeroBitTM tapes).qhalt := + TM.state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [initialInputZeroWrap, initialInputLoopTM])] + simp only [initialInputZeroWrap, initialInputLoopTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize (initialZeroBitTM tapes).Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨state, workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := + action + intro hstep + cases Option.some.inj hstep + rfl + +private theorem initialInputLoopTM_one_reachesIn + (tapes : ControlInstructionTapes n) + {time : β„•} {c c' : Complexity.Cfg (n + 1) (initialOneBitTM tapes).Q} + (hreach : (initialOneBitTM tapes).reachesIn time c c') : + (initialInputLoopTM tapes).reachesIn time + (initialInputOneWrap tapes c) (initialInputOneWrap tapes c') := + TM.reachesIn_map (initialInputOneWrap tapes) + (fun _ _ => initialInputLoopTM_one_step tapes) hreach + +private theorem initialInputLoopTM_zero_reachesIn + (tapes : ControlInstructionTapes n) + {time : β„•} {c c' : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q} + (hreach : (initialZeroBitTM tapes).reachesIn time c c') : + (initialInputLoopTM tapes).reachesIn time + (initialInputZeroWrap tapes c) (initialInputZeroWrap tapes c') := + TM.reachesIn_map (initialInputZeroWrap tapes) + (fun _ _ => initialInputLoopTM_zero_step tapes) hreach + +private theorem initialInputLoopTM_step_scan_one + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q) + (hstate : c.state = .inl .scan) (hone : c.input.read = Ξ“.one) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (initialInputLoopTM tapes).step c = some + { state := .inr (.inl (initialOneBitTM tapes).qstart) + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [initialInputLoopTM])] + simp only [initialInputLoopTM, hstate, hone, TM.allReadBack, + reduceCtorEq, ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [TM.idleDir, Tape.move] + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, + ite_eq_right houtput] + rfl + +private theorem initialInputLoopTM_step_scan_zero + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q) + (hstate : c.state = .inl .scan) (hzero : c.input.read = Ξ“.zero) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (initialInputLoopTM tapes).step c = some + { state := .inr (.inr (initialZeroBitTM tapes).qstart) + input := c.input + work := c.work + output := c.output } := by + have hstart : c.input.read β‰  Ξ“.start := by rw [hzero]; decide + have hblank : c.input.read β‰  Ξ“.blank := by rw [hzero]; decide + have hone : c.input.read β‰  Ξ“.one := by rw [hzero]; decide + rw [TM.step, ite_eq_right (by rw [hstate]; simp [initialInputLoopTM])] + simp only [initialInputLoopTM, hstate, hblank, hone, TM.allReadBack, + ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [TM.idleDir, hstart, Tape.move] + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, + ite_eq_right houtput] + rfl + +private theorem initialInputLoopTM_step_scan_blank + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q) + (hstate : c.state = .inl .scan) (hblank : c.input.read = Ξ“.blank) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (initialInputLoopTM tapes).step c = some + { state := .inl .done + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [initialInputLoopTM])] + simp only [initialInputLoopTM, hstate, hblank, TM.allReadBack, + ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [TM.idleDir, Tape.move] + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, + ite_eq_right houtput] + rfl + +private theorem initialInputLoopTM_step_one_halt + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialOneBitTM tapes).Q) + (hhalt : (initialOneBitTM tapes).halted c) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (initialInputLoopTM tapes).step (initialInputOneWrap tapes c) = some + { state := .inl .scan + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + rw [TM.step, + ite_eq_right (by simp [initialInputOneWrap, initialInputLoopTM])] + simp only [initialInputOneWrap, initialInputLoopTM, hhalt, ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· rfl + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, + ite_eq_right houtput] + rfl + +private theorem initialInputLoopTM_step_zero_halt + (tapes : ControlInstructionTapes n) + (c : Complexity.Cfg (n + 1) (initialZeroBitTM tapes).Q) + (hhalt : (initialZeroBitTM tapes).halted c) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (initialInputLoopTM tapes).step (initialInputZeroWrap tapes c) = some + { state := .inl .scan + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + rw [TM.step, + ite_eq_right (by simp [initialInputZeroWrap, initialInputLoopTM])] + simp only [initialInputZeroWrap, initialInputLoopTM, hhalt, ↓reduceIte] + refine congrArg some ((Complexity.Cfg.mk.injEq ..).mpr + ⟨rfl, ?_, ?_, ?_⟩) + Β· rfl + Β· funext i + rw [TM.writeAndMove_readBack _ (hwork i), TM.idleDir, + ite_eq_right (hwork i)] + rfl + Β· rw [TM.writeAndMove_readBack _ houtput, TM.idleDir, + ite_eq_right houtput] + rfl + +private theorem copyWorkToWorkTM_exact_hoareTime + (src dst : Fin n) (hne : src β‰  dst) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrc : workβ‚€ src = programBinaryTape bits) + (hdst : workβ‚€ dst = TM.resetBinaryBlank) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (TM.copyWorkToWorkTM src dst).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update + (Function.update workβ‚€ src (programBinaryPrefixTape bits)) + dst (programBinaryPrefixTape bits) ∧ + out = outβ‚€) + (bits.length + 1) := by + let P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop := + fun inp work out => + inp = inpβ‚€ ∧ out = outβ‚€ ∧ + βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i + have hraw := TM.copyWorkToWorkTM_hoareTime_frame_of_binaryString + src dst hne bits (P := P) (by + intro inp work out inp' work' out' hP _ _ _ _ hinp' hout' hframe + rcases hP with ⟨hinp, hout, hworkFrame⟩ + exact ⟨hinp'.trans hinp, hout'.trans hout, + fun i hisrc hidst => (hframe i hisrc hidst).trans + (hworkFrame i hisrc hidst)⟩) + apply hraw.consequence + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + refine ⟨?_, ?_, hinput.read_ne_start, houtput.read_ne_start, + houtput.1, ?_, rfl, rfl, ?_⟩ + Β· simpa only [programBinaryTape] using! hsrc + Β· simpa [TM.resetBinaryBlank] using! hdst + Β· intro i _ _ + exact ⟨(hwork i).read_ne_start, (hwork i).1⟩ + Β· intro i _ _ + rfl + Β· intro inp work out hpost + rcases hpost with ⟨hsrcCells, hsrcHead, hdstPrefix, hdstStart, + hinp, hout, hframe⟩ + have hsrcEq : work src = programBinaryPrefixTape bits := by + apply Tape.ext + Β· simpa [programBinaryPrefixTape] using! hsrcHead + Β· simpa [programBinaryPrefixTape] using! hsrcCells + have hdstEq : work dst = programBinaryPrefixTape bits := by + apply Tape.ext + Β· simpa [programBinaryPrefixTape] using! hdstPrefix.1 + Β· rw [programBinaryPrefixTape] + exact hdstPrefix.cells_eq_init hdstStart + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hidst : i = dst + Β· subst i + simp [hdstEq] + Β· by_cases hisrc : i = src + Β· subst i + simp [hne, hsrcEq] + Β· simp [hidst, hisrc, hframe i hisrc hidst] + Β· exact le_rfl + +private def initialAbiCountWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) (count : β„•) : Fin (n + 1) β†’ Tape := + Function.update work tapes.lifted.data.update.resultCount + (programBinaryTape count.bits) + +private def initialAbiBufferWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) (store : Store) : Fin (n + 1) β†’ Tape := + Function.update work tapes.buffer + (programBinaryTape (store.flatMap Entry.encode)) + +private def initialAbiCopiedWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) (store : Store) : Fin (n + 1) β†’ Tape := + Function.update + (Function.update work tapes.buffer + (programBinaryPrefixTape (store.flatMap Entry.encode))) + tapes.liftedSource + (programBinaryPrefixTape (store.flatMap Entry.encode)) + +private def initialAbiSourceWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) (store : Store) : Fin (n + 1) β†’ Tape := + Function.update work tapes.liftedSource + (programBinaryTape (store.flatMap Entry.encode)) + +private def initialAbiBufferResetWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) : Fin (n + 1) β†’ Tape := + Function.update work tapes.buffer TM.resetBinaryBlank + +private def initialAbiFinalWork (tapes : ControlInstructionTapes n) + (work : Fin (n + 1) β†’ Tape) : Fin (n + 1) β†’ Tape := + TM.resetBinaryWorkManyResult work (initialCleanupTargets tapes) + +private theorem eq_programBinaryPrefixTape_of_hasBinaryPrefix + {t : Tape} {bits : List Bool} (hprefix : t.HasBinaryPrefix bits) + (hstart : t.cells 0 = Ξ“.start) : + t = programBinaryPrefixTape bits := by + apply Tape.ext + Β· simpa [programBinaryPrefixTape] using! hprefix.1 + Β· rw [programBinaryPrefixTape] + exact hprefix.cells_eq_init hstart + +private theorem parked_update {work : Fin n β†’ Tape} {idx : Fin n} + {tape : Tape} (hwork : βˆ€ i, TM.Parked (work i)) + (htape : TM.Parked tape) : + βˆ€ i, TM.Parked (Function.update work idx tape i) := by + intro i + by_cases hi : i = idx + Β· subst i + simp [htape] + Β· simp [hi, hwork i] + +private theorem exact_phaseTransition_of_parked + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + TM.transitionInput inp = inpβ‚€ ∧ + (fun i => TM.transitionTape (work i)) = workβ‚€ ∧ + TM.transitionTape out = outβ‚€ := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact TM.phaseTransition_eq_self_of_reads_ne_start + hinput.read_ne_start (fun i => (hwork i).read_ne_start) + houtput.read_ne_start + +private theorem rewindPrefixWorkTM_exact_hoareTime + (idx : Fin n) (bits : List Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : workβ‚€ idx = programBinaryPrefixTape bits) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) + (houtput : TM.Parked outβ‚€) : + (TM.rewindWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx (programBinaryTape bits) ∧ + out = outβ‚€) + (bits.length + 1 + 2) := by + have hprefix := programBinaryPrefixTape_hasBinaryPrefix bits + have hraw := TM.rewindBinaryWorkTM_hoareTime_frame idx bits + (bits.length + 1) inpβ‚€ workβ‚€ outβ‚€ + (by rw [htarget]; exact hprefix.2) + (by rw [htarget]; simp [programBinaryPrefixTape]) + (by rw [htarget]; simp [programBinaryPrefixTape]) + hinput (fun i _ => hwork i) houtput + apply hraw.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hidx, hframe, hout⟩ + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hi : i = idx + Β· subst i + simp [hidx, programBinaryTape] + Β· simp [hi, hframe i hi] + Β· exact le_rfl + +private theorem initialAbiFinalWork_eq_programSnapshotWork + (tapes : ControlInstructionTapes n) (store : Store) (length : β„•) + (workβ‚€ : Fin (n + 1) β†’ Tape) + (hready : InitialLoopReady tapes length store.length store workβ‚€) : + initialAbiFinalWork tapes + (initialAbiBufferResetWork tapes + (initialAbiSourceWork tapes + (initialAbiCopiedWork tapes + (initialAbiBufferWork tapes + (initialAbiCountWork tapes workβ‚€ store.length) store) + store) + store)) = + programSnapshotWork tapes { pc := 0, store := store } := by + have hsourceLhs : tapes.liftedSource β‰  tapes.liftedLhs := + tapes.lifted.data.ne (by decide) + have hsourceRhs : tapes.liftedSource β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have hsourceRemaining : tapes.liftedSource β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hsourceResult : tapes.liftedSource β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hlhsRhs : tapes.liftedLhs β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have hlhsRemaining : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hlhsResult : tapes.liftedLhs β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hrhsRemaining : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hrhsResult : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hremainingResult : tapes.lifted.data.update.remaining β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hlhsSource := hsourceLhs.symm + have hrhsSource := hsourceRhs.symm + have hremainingSource := hsourceRemaining.symm + have hresultSource := hsourceResult.symm + have hrhsLhs := hlhsRhs.symm + have hremainingLhs := hlhsRemaining.symm + have hresultLhs := hlhsResult.symm + have hremainingRhs := hrhsRemaining.symm + have hresultRhs := hrhsResult.symm + have hresultRemaining := hremainingResult.symm + have hsourcePC : tapes.liftedSource β‰  tapes.liftedPC := + tapes.liftedPC_ne_source.symm + have hlhsPC : tapes.liftedLhs β‰  tapes.liftedPC := + tapes.lifted.lhs_ne_pc + have hrhsPC : tapes.lifted.data.rhs β‰  tapes.liftedPC := + tapes.lifted.data_ne_pc 14 + have hremainingPC : tapes.lifted.data.update.remaining β‰  + tapes.liftedPC := tapes.lifted.data_ne_pc 9 + have hresultPC : tapes.lifted.data.update.resultCount β‰  + tapes.liftedPC := tapes.lifted.data_ne_pc 12 + have hsourceBuffer : tapes.liftedSource β‰  tapes.buffer := + tapes.liftedSource_ne_buffer + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 13 + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 14 + have hremainingBuffer : tapes.lifted.data.update.remaining β‰  + tapes.buffer := tapes.liftedData_ne_buffer 9 + have hresultBuffer : tapes.lifted.data.update.resultCount β‰  + tapes.buffer := tapes.liftedData_ne_buffer 12 + have hpcBuffer : tapes.liftedPC β‰  tapes.buffer := + tapes.liftedPC_ne_buffer + have hcountEq : + workβ‚€ tapes.lifted.data.update.remaining = + programBinaryTape store.length.bits := by + simpa only [programBinaryTape] using! hready.count.eq_init_move_right + funext i + by_cases hlhs : i = tapes.liftedLhs + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork, + programBinaryTape, TM.resetBinaryBlank] + by_cases hrhs : i = tapes.lifted.data.rhs + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork, + programBinaryTape, TM.resetBinaryBlank] + by_cases hsource : i = tapes.liftedSource + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork] + by_cases hremaining : i = tapes.lifted.data.update.remaining + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork] + by_cases hresult : i = tapes.lifted.data.update.resultCount + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork] + by_cases hpc : i = tapes.liftedPC + Β· subst i + have hpcBlank : workβ‚€ tapes.liftedPC = TM.resetBinaryBlank := + hready.frame _ tapes.lifted.lhs_ne_pc.symm + (tapes.lifted.data_ne_pc 14).symm + (tapes.lifted.data_ne_pc 9).symm tapes.liftedPC_ne_buffer + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork, programBinaryTape, + TM.resetBinaryBlank] + by_cases hbuffer : i = tapes.buffer + Β· subst i + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork, + programBinaryTape, TM.resetBinaryBlank] + have hblank := hready.frame i hlhs hrhs hremaining hbuffer + simp_all [initialAbiFinalWork, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, initialCleanupTargets, + TM.resetBinaryWorkManyResult, programSnapshotWork] + +/-- A zero input bit preserves the streaming frame and advances only the +current register address. -/ +theorem initialZeroBitTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (outβ‚€ : Tape) (hready : InitialLoopReady tapes address count entries workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : TM.Parked outβ‚€) : + (initialZeroBitTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InitialLoopReady tapes (address + 1) count entries work ∧ + out = outβ‚€) + (TM.binarySuccTime address) := by + have hrun := TM.binarySuccTM_hoareTime_frame tapes.liftedLhs address + inpβ‚€ workβ‚€ outβ‚€ hready.address hinput.read_ne_start + (fun i _ => (hready.parked i).read_ne_start) houtput.read_ne_start + intro inp work out hpre + obtain ⟨c, time, htime, hreach, hhalt, hinputEq, hframe, + haddress, houtputEq⟩ := hrun inp work out hpre + refine ⟨c, time, htime, hreach, hhalt, hinputEq, ?_, houtputEq⟩ + refine + { address := haddress + value := by + rw [hframe tapes.lifted.data.rhs (tapes.lifted.data.ne (by decide))] + exact hready.value + count := by + rw [hframe tapes.lifted.data.update.remaining + (tapes.lifted.data.ne (by decide))] + exact hready.count + buffer := by + rw [hframe tapes.buffer (tapes.liftedData_ne_buffer 13).symm] + exact hready.buffer + parked := ?_ + frame := ?_ } + Β· intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + exact parked_of_binaryNat haddress + Β· rw [hframe i hi] + exact hready.parked i + Β· intro i hlhs hrhs hcount hbuffer + rw [hframe i hlhs] + exact hready.frame i hlhs hrhs hcount hbuffer + +/-- Emission followed by the two counter increments restores the complete input-loop ABI. -/ +private theorem initialOneBit_finalReady + (tapes : ControlInstructionTapes n) (address count : β„•) (entries : Store) + (workβ‚€ emittedWork countedWork advancedWork : Fin (n + 1) β†’ Tape) + (hready : InitialLoopReady tapes address count entries workβ‚€) + (hemitFrame : βˆ€ i, i β‰  tapes.buffer β†’ emittedWork i = workβ‚€ i) + (hemitBuffer : (emittedWork tapes.buffer).HasBinaryPrefix + (entries.flatMap Entry.encode ++ Entry.encode (address, 1))) + (hcountFrame : βˆ€ i, i β‰  tapes.lifted.data.update.remaining β†’ + countedWork i = emittedWork i) + (hcountValue : (countedWork tapes.lifted.data.update.remaining).HasBinaryNat (count + 1)) + (hcountWorkParked : βˆ€ i, TM.Parked (countedWork i)) + (haddressFrame : βˆ€ i, i β‰  tapes.liftedLhs β†’ advancedWork i = countedWork i) + (haddressValue : (advancedWork tapes.liftedLhs).HasBinaryNat (address + 1)) : + InitialLoopReady tapes (address + 1) (count + 1) + (entries ++ [(address, 1)]) advancedWork := by + have hremainingBuffer : tapes.lifted.data.update.remaining β‰  + tapes.buffer := tapes.liftedData_ne_buffer 9 + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 13 + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 14 + have hlhsRemaining : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hremainingLhs : tapes.lifted.data.update.remaining β‰  + tapes.liftedLhs := hlhsRemaining.symm + have hrhsLhs : tapes.lifted.data.rhs β‰  tapes.liftedLhs := + tapes.lifted.data.ne (by decide) + have hrhsRemaining : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + refine + { address := by + change (advancedWork tapes.liftedLhs).HasBinaryNat (address + 1) + exact haddressValue + value := ?_ + count := ?_ + buffer := ?_ + parked := ?_ + frame := ?_ } + Β· change (advancedWork tapes.lifted.data.rhs).HasBinaryNat 1 + rw [haddressFrame _ hrhsLhs, hcountFrame _ hrhsRemaining, + hemitFrame _ hrhsBuffer] + exact hready.value + Β· change (advancedWork + tapes.lifted.data.update.remaining).HasBinaryNat (count + 1) + rw [haddressFrame _ hremainingLhs] + exact hcountValue + Β· change (advancedWork tapes.buffer).HasBinaryPrefix + ((entries ++ [(address, 1)]).flatMap Entry.encode) + rw [haddressFrame _ hlhsBuffer.symm, + hcountFrame _ hremainingBuffer.symm] + simpa [List.flatMap_append] using! hemitBuffer + Β· intro i + change TM.Parked (advancedWork i) + by_cases hi : i = tapes.liftedLhs + Β· subst i + exact parked_of_binaryNat haddressValue + Β· rw [haddressFrame i hi] + exact hcountWorkParked i + Β· intro i hlhs hrhs hcountIdx hbuffer + change advancedWork i = TM.resetBinaryBlank + rw [haddressFrame i hlhs, hcountFrame i hcountIdx, + hemitFrame i hbuffer] + exact hready.frame i hlhs hrhs hcountIdx hbuffer + +/-- A one input bit appends the current `(address, 1)` entry and advances the +entry count and current address, restoring every reusable source cursor. -/ +theorem initialOneBitTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (address count : β„•) + (entries : Store) (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (outβ‚€ : Tape) (hready : InitialLoopReady tapes address count entries workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialOneBitTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InitialLoopReady tapes (address + 1) (count + 1) + (entries ++ [(address, 1)]) work ∧ + out = outβ‚€) + (rewindEntryEncodeRestoreTime (address, 1) + 1 + + (TM.binarySuccTime count + 1 + TM.binarySuccTime address)) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let baseWork : Fin n β†’ Tape := fun i => workβ‚€ (Fin.castSucc i) + have hbaseAddress : + (baseWork (initialBitEntryTapes tapes).address).HasBinaryNat address := by + exact hready.address + have hbaseValue : + (baseWork (initialBitEntryTapes tapes).value).HasBinaryNat 1 := by + exact hready.value + have hbase := rewindEntryEncodeRestoreTM_hoareTime_frame + (initialBitEntryTapes tapes) (address, 1) + (entries.flatMap Entry.encode) inpβ‚€ baseWork (workβ‚€ tapes.buffer) + hbaseAddress hbaseValue hinput + (fun i _ _ => hready.parked (Fin.castSucc i)) hready.buffer + have hlift := TM.retargetOutput_hoareTime + (rewindEntryEncodeRestoreTM (initialBitEntryTapes tapes)) hbase + obtain ⟨emitted, emitTime, hemitTime, hemitReach, hemitHalt, + hemitPost, hemitOutput⟩ := + hlift inpβ‚€ workβ‚€ outβ‚€ + ⟨⟨rfl, rfl, rfl⟩, by simpa [TM.resetBinaryBlank] using! houtput⟩ + rcases hemitPost with ⟨hemitInput, hemitBaseWork, hemitBuffer⟩ + have hemitOutput' : emitted.output = outβ‚€ := by + exact hemitOutput.trans (by simpa [TM.resetBinaryBlank] using! houtput.symm) + have hemitFrame (i : Fin (n + 1)) (hi : i β‰  tapes.buffer) : + emitted.work i = workβ‚€ i := by + have hil : i.val < n := by + have hle : i.val ≀ n := by omega + have hne : i.val β‰  n := by + intro hval + apply hi + apply Fin.ext + simpa [ControlInstructionTapes.buffer] using! hval + omega + let j : Fin n := ⟨i.val, hil⟩ + have hij : i = Fin.castSucc j := by + apply Fin.ext + rfl + rw [hij] + exact congrFun hemitBaseWork j + have hemitInputParked : TM.Parked emitted.input := by + rw [hemitInput] + exact hinput + have hemitOutputParked : TM.Parked emitted.output := by + rw [hemitOutput'] + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hemitWorkParked : βˆ€ i, TM.Parked (emitted.work i) := by + intro i + by_cases hi : i = tapes.buffer + Β· subst i + exact parked_of_binaryPrefix hemitBuffer + Β· rw [hemitFrame i hi] + exact hready.parked i + have hremainingBuffer : tapes.lifted.data.update.remaining β‰  + tapes.buffer := tapes.liftedData_ne_buffer 9 + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 13 + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 14 + have hlhsRemaining : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hremainingLhs : tapes.lifted.data.update.remaining β‰  + tapes.liftedLhs := hlhsRemaining.symm + have hrhsLhs : tapes.lifted.data.rhs β‰  tapes.liftedLhs := + tapes.lifted.data.ne (by decide) + have hrhsRemaining : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hemitCount : + (emitted.work tapes.lifted.data.update.remaining).HasBinaryNat count := by + rw [hemitFrame _ hremainingBuffer] + exact hready.count + have hcountRun := TM.binarySuccTM_hoareTime_frame + tapes.lifted.data.update.remaining count emitted.input emitted.work + emitted.output hemitCount hemitInputParked.read_ne_start + (fun i _ => (hemitWorkParked i).read_ne_start) + hemitOutputParked.read_ne_start + obtain ⟨counted, countTime, hcountTime, hcountReach, hcountHalt, + hcountInput, hcountFrame, hcountValue, hcountOutput⟩ := + hcountRun emitted.input emitted.work emitted.output ⟨rfl, rfl, rfl⟩ + have hcountInputParked : TM.Parked counted.input := by + rw [hcountInput] + exact hemitInputParked + have hcountOutputParked : TM.Parked counted.output := by + rw [hcountOutput] + exact hemitOutputParked + have hcountWorkParked : βˆ€ i, TM.Parked (counted.work i) := by + intro i + by_cases hi : i = tapes.lifted.data.update.remaining + Β· subst i + exact parked_of_binaryNat hcountValue + Β· rw [hcountFrame i hi] + exact hemitWorkParked i + have hcountAddress : + (counted.work tapes.liftedLhs).HasBinaryNat address := by + rw [hcountFrame _ hlhsRemaining] + rw [hemitFrame _ hlhsBuffer] + exact hready.address + have haddressRun := TM.binarySuccTM_hoareTime_frame tapes.liftedLhs + address counted.input counted.work counted.output hcountAddress + hcountInputParked.read_ne_start + (fun i _ => (hcountWorkParked i).read_ne_start) + hcountOutputParked.read_ne_start + obtain ⟨advanced, addressTime, haddressTime, haddressReach, + haddressHalt, haddressInput, haddressFrame, haddressValue, + haddressOutput⟩ := + haddressRun counted.input counted.work counted.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hcountInputTransition, hcountWorkTransition, + hcountOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hcountInputParked.read_ne_start + (fun i => (hcountWorkParked i).read_ne_start) + hcountOutputParked.read_ne_start + have haddressReach' : (TM.binarySuccTM tapes.liftedLhs).reachesIn + addressTime + { state := (TM.binarySuccTM tapes.liftedLhs).qstart + input := TM.transitionInput counted.input + work := fun i => TM.transitionTape (counted.work i) + output := TM.transitionTape counted.output } + advanced := by + simpa only [hcountInputTransition, hcountWorkTransition, + hcountOutputTransition] using! haddressReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs) hcountReach hcountHalt haddressReach' + let tailFinal := TM.phase2Wrap + (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs) advanced + have htailHalt : + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)).halted tailFinal := by + rw [TM.phase2Wrap_halted_iff] + exact haddressHalt + obtain ⟨hemitInputTransition, hemitWorkTransition, + hemitOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hemitInputParked.read_ne_start + (fun i => (hemitWorkParked i).read_ne_start) + hemitOutputParked.read_ne_start + have htailReach' : + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)).reachesIn + (countTime + 1 + addressTime) + { state := + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)).qstart + input := TM.transitionInput emitted.input + work := fun i => TM.transitionTape (emitted.work i) + output := TM.transitionTape emitted.output } + tailFinal := by + simpa only [hemitInputTransition, hemitWorkTransition, + hemitOutputTransition] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeRestoreTM (initialBitEntryTapes tapes)).retargetOutput + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)) + hemitReach hemitHalt htailReach' + let finalCfg := TM.phase2Wrap + (rewindEntryEncodeRestoreTM (initialBitEntryTapes tapes)).retargetOutput + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)) tailFinal + refine ⟨finalCfg, emitTime + 1 + (countTime + 1 + addressTime), + ?_, hreach, ?_, ?_⟩ + Β· omega + Β· change (initialOneBitTM tapes).halted finalCfg + unfold initialOneBitTM + exact (TM.phase2Wrap_halted_iff + (rewindEntryEncodeRestoreTM (initialBitEntryTapes tapes)).retargetOutput + (TM.seqTM (TM.binarySuccTM tapes.lifted.data.update.remaining) + (TM.binarySuccTM tapes.liftedLhs)) tailFinal).mpr htailHalt + Β· refine ⟨?_, ?_, ?_⟩ + Β· change advanced.input = inpβ‚€ + exact haddressInput.trans (hcountInput.trans hemitInput) + Β· exact initialOneBit_finalReady tapes address count entries + workβ‚€ emitted.work counted.work advanced.work hready hemitFrame + hemitBuffer hcountFrame hcountValue hcountWorkParked + haddressFrame haddressValue + Β· change advanced.output = outβ‚€ + exact haddressOutput.trans (hcountOutput.trans hemitOutput') + +/-- The custom scanner consumes exactly the advertised Boolean suffix, +streaming its nonzero entries into the sparse-store buffer. -/ +theorem initialInputLoopTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) + (address count : β„•) (entries : Store) + (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) (outβ‚€ : Tape) + (hinput : inpβ‚€.HasBinarySuffix input) + (hready : InitialLoopReady tapes address count entries workβ‚€) + (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialInputLoopTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp.HasBinarySuffix [] ∧ + InitialLoopReady tapes (address + input.length) + (count + inputTrueCount input) + (entries ++ inputBitStoreFrom address input) work ∧ + out = outβ‚€) + (initialInputLoopTime tapes address count input) := by + induction input generalizing address count entries inpβ‚€ workβ‚€ outβ‚€ with + | nil => + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let done : Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q := + { state := .inl .done + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hstep := initialInputLoopTM_step_scan_blank tapes + ({ state := (initialInputLoopTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q) + rfl hinput.read_nil + (fun i => (hready.parked i).read_ne_start) + (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! + Tape.init_move_right_hasBinaryNat 0 + exact (parked_of_binaryNat hblankNat).read_ne_start) + refine ⟨done, 1, by simp [initialInputLoopTime], + .step (by simpa [done] using! hstep) .zero, ?_, ?_⟩ + Β· change done.state = (initialInputLoopTM tapes).qhalt + rfl + Β· exact ⟨hinput, by simpa [inputTrueCount, inputBitStoreFrom], rfl⟩ + | cons bit rest ih => + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let scan : Complexity.Cfg (n + 1) (initialInputLoopTM tapes).Q := + { state := (initialInputLoopTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hinputParked : TM.Parked inpβ‚€ := parked_of_binarySuffix hinput + have houtputParked : TM.Parked outβ‚€ := by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + cases bit with + | false => + let bodyStart : Complexity.Cfg (n + 1) + (initialZeroBitTM tapes).Q := + { state := (initialZeroBitTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hread : inpβ‚€.read = Ξ“.zero := by + simpa [Ξ“.ofBool] using! hinput.read_cons + have hscanStep := initialInputLoopTM_step_scan_zero tapes scan + rfl hread (fun i => (hready.parked i).read_ne_start) + houtputParked.read_ne_start + have hscanReach : (initialInputLoopTM tapes).reachesIn 1 scan + (initialInputZeroWrap tapes bodyStart) := + .step (by simpa [scan, bodyStart, initialInputZeroWrap] using! + hscanStep) .zero + have hbody := initialZeroBitTM_hoareTime_internal tapes address + count entries inpβ‚€ workβ‚€ outβ‚€ hready hinputParked + houtputParked + obtain ⟨bodyDone, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hbodyReady, hbodyOutput⟩ := + hbody inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hbodyLift := initialInputLoopTM_zero_reachesIn tapes hbodyReach + let nextScan : Complexity.Cfg (n + 1) + (initialInputLoopTM tapes).Q := + { state := .inl .scan + input := bodyDone.input.move Dir3.right + work := bodyDone.work + output := bodyDone.output } + have hseamStep := initialInputLoopTM_step_zero_halt tapes bodyDone + hbodyHalt (fun i => (hbodyReady.parked i).read_ne_start) + (by rw [hbodyOutput]; exact houtputParked.read_ne_start) + have hseamReach : (initialInputLoopTM tapes).reachesIn 1 + (initialInputZeroWrap tapes bodyDone) nextScan := + .step (by simpa [nextScan] using! hseamStep) .zero + have hnextInput : + (bodyDone.input.move Dir3.right).HasBinarySuffix rest := by + rw [hbodyInput] + exact hinput.move_right_cons + have hnextOutput : bodyDone.output = TM.resetBinaryBlank := + hbodyOutput.trans houtput + have htail := ih (address + 1) count entries + (bodyDone.input.move Dir3.right) bodyDone.work bodyDone.output + hnextInput hbodyReady hnextOutput + obtain ⟨tailDone, tailTime, htailTime, htailReach, htailHalt, + htailInput, htailReady, htailOutput⟩ := + htail _ _ _ ⟨rfl, rfl, rfl⟩ + have hreach := TM.reachesIn_trans (initialInputLoopTM tapes) + hscanReach (TM.reachesIn_trans (initialInputLoopTM tapes) + hbodyLift (TM.reachesIn_trans (initialInputLoopTM tapes) + hseamReach htailReach)) + refine ⟨tailDone, 1 + bodyTime + 1 + tailTime, ?_, ?_, + htailHalt, ?_⟩ + Β· simp only [initialInputLoopTime, Bool.false_eq_true, + ite_false, Nat.add_zero] + omega + Β· simpa [Nat.add_assoc] using! hreach + Β· refine ⟨htailInput, ?_, htailOutput.trans hbodyOutput⟩ + simpa [inputTrueCount, inputBitStoreFrom, Nat.add_assoc, + Nat.add_comm, Nat.add_left_comm] using! htailReady + | true => + let bodyStart : Complexity.Cfg (n + 1) + (initialOneBitTM tapes).Q := + { state := (initialOneBitTM tapes).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hread : inpβ‚€.read = Ξ“.one := by + simpa [Ξ“.ofBool] using! hinput.read_cons + have hscanStep := initialInputLoopTM_step_scan_one tapes scan + rfl hread (fun i => (hready.parked i).read_ne_start) + houtputParked.read_ne_start + have hscanReach : (initialInputLoopTM tapes).reachesIn 1 scan + (initialInputOneWrap tapes bodyStart) := + .step (by simpa [scan, bodyStart, initialInputOneWrap] using! + hscanStep) .zero + have hbody := initialOneBitTM_hoareTime_internal tapes address + count entries inpβ‚€ workβ‚€ outβ‚€ hready hinputParked houtput + obtain ⟨bodyDone, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hbodyReady, hbodyOutput⟩ := + hbody inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hbodyLift := initialInputLoopTM_one_reachesIn tapes hbodyReach + let nextScan : Complexity.Cfg (n + 1) + (initialInputLoopTM tapes).Q := + { state := .inl .scan + input := bodyDone.input.move Dir3.right + work := bodyDone.work + output := bodyDone.output } + have hseamStep := initialInputLoopTM_step_one_halt tapes bodyDone + hbodyHalt (fun i => (hbodyReady.parked i).read_ne_start) + (by rw [hbodyOutput]; exact houtputParked.read_ne_start) + have hseamReach : (initialInputLoopTM tapes).reachesIn 1 + (initialInputOneWrap tapes bodyDone) nextScan := + .step (by simpa [nextScan] using! hseamStep) .zero + have hnextInput : + (bodyDone.input.move Dir3.right).HasBinarySuffix rest := by + rw [hbodyInput] + exact hinput.move_right_cons + have hnextOutput : bodyDone.output = TM.resetBinaryBlank := + hbodyOutput.trans houtput + have htail := ih (address + 1) (count + 1) + (entries ++ [(address, 1)]) + (bodyDone.input.move Dir3.right) bodyDone.work bodyDone.output + hnextInput hbodyReady hnextOutput + obtain ⟨tailDone, tailTime, htailTime, htailReach, htailHalt, + htailInput, htailReady, htailOutput⟩ := + htail _ _ _ ⟨rfl, rfl, rfl⟩ + have hreach := TM.reachesIn_trans (initialInputLoopTM tapes) + hscanReach (TM.reachesIn_trans (initialInputLoopTM tapes) + hbodyLift (TM.reachesIn_trans (initialInputLoopTM tapes) + hseamReach htailReach)) + refine ⟨tailDone, 1 + bodyTime + 1 + tailTime, ?_, ?_, + htailHalt, ?_⟩ + Β· simp only [initialInputLoopTime, if_true] + omega + Β· simpa [Nat.add_assoc] using! hreach + Β· refine ⟨htailInput, ?_, htailOutput.trans hbodyOutput⟩ + simpa [inputTrueCount, inputBitStoreFrom, List.append_assoc, + Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using! htailReady + +/-- The setup phase turns the standard all-heads-on-marker configuration into +the exact address-one/count-zero streaming boundary. -/ +theorem initialSetupTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) : + (initialSetupTM tapes).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => + inp.HasBinarySuffix input ∧ + inp = (Tape.init (input.map Ξ“.ofBool)).move Dir3.right ∧ + InitialLoopReady tapes 1 0 [] work ∧ + out = TM.resetBinaryBlank) + (1 + 1 + (TM.binarySuccTime 0 + 1 + TM.binarySuccTime 0)) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + let parkedInput := (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + let parkedWork : Fin (n + 1) β†’ Tape := fun _ => TM.resetBinaryBlank + let skipped : Complexity.Cfg (n + 1) (TM.skipTM (n := n + 1)).Q := + { state := (TM.skipTM (n := n + 1)).qhalt + input := parkedInput + work := parkedWork + output := TM.resetBinaryBlank } + have hskipStep : (TM.skipTM (n := n + 1)).step + { state := (TM.skipTM (n := n + 1)).qstart + input := Tape.init (input.map Ξ“.ofBool) + work := fun _ => Tape.init [] + output := Tape.init [] } = some skipped := by + rw [TM.step, ite_eq_right (by simp [TM.skipTM])] + simp only [TM.skipTM] + refine congrArg some (Complexity.Cfg.ext rfl ?_ ?_ ?_) + Β· simp [skipped, parkedInput, TM.idleDir, Tape.read, Tape.move] + Β· funext i + simp [skipped, parkedWork, TM.resetBinaryBlank, TM.idleDir, + TM.readBackWrite, Tape.read, Tape.write, Tape.move] + Β· simp [skipped, TM.resetBinaryBlank, TM.idleDir, + TM.readBackWrite, Tape.read, Tape.write, Tape.move] + have hskipReach : (TM.skipTM (n := n + 1)).reachesIn 1 + { state := (TM.skipTM (n := n + 1)).qstart + input := Tape.init (input.map Ξ“.ofBool) + work := fun _ => Tape.init [] + output := Tape.init [] } skipped := + .step hskipStep .zero + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hblankParked : TM.Parked TM.resetBinaryBlank := + parked_of_binaryNat hblankNat + have hparkedInput : TM.Parked parkedInput := + parked_of_binarySuffix (by + simpa only [parkedInput] using! Tape.init_move_right_hasBinarySuffix input) + have hlhsRun := TM.binarySuccTM_hoareTime_frame tapes.liftedLhs 0 + skipped.input skipped.work skipped.output + (by simpa [skipped, parkedWork] using! hblankNat) + (by simpa [skipped] using! hparkedInput.read_ne_start) + (fun i _ => by simpa [skipped, parkedWork] using! + hblankParked.read_ne_start) + (by simpa [skipped] using! hblankParked.read_ne_start) + obtain ⟨lhsDone, lhsTime, hlhsTime, hlhsReach, hlhsHalt, + hlhsInput, hlhsFrame, hlhsValue, hlhsOutput⟩ := + hlhsRun skipped.input skipped.work skipped.output ⟨rfl, rfl, rfl⟩ + have hlhsRhs : tapes.liftedLhs β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have hrhsZero : + (lhsDone.work tapes.lifted.data.rhs).HasBinaryNat 0 := by + rw [hlhsFrame _ hlhsRhs.symm] + simpa [skipped, parkedWork] using! hblankNat + have hlhsInputParked : TM.Parked lhsDone.input := by + rw [hlhsInput] + simpa [skipped] using! hparkedInput + have hlhsOutputParked : TM.Parked lhsDone.output := by + rw [hlhsOutput] + simpa [skipped] using! hblankParked + have hlhsWorkParked : βˆ€ i, TM.Parked (lhsDone.work i) := by + intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + exact parked_of_binaryNat hlhsValue + Β· rw [hlhsFrame i hi] + simpa [skipped, parkedWork] using! hblankParked + have hrhsRun := TM.binarySuccTM_hoareTime_frame + tapes.lifted.data.rhs 0 lhsDone.input lhsDone.work lhsDone.output + hrhsZero hlhsInputParked.read_ne_start + (fun i _ => (hlhsWorkParked i).read_ne_start) + hlhsOutputParked.read_ne_start + obtain ⟨rhsDone, rhsTime, hrhsTime, hrhsReach, hrhsHalt, + hrhsInput, hrhsFrame, hrhsValue, hrhsOutput⟩ := + hrhsRun lhsDone.input lhsDone.work lhsDone.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hlhsInputTransition, hlhsWorkTransition, + hlhsOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hlhsInputParked.read_ne_start + (fun i => (hlhsWorkParked i).read_ne_start) + hlhsOutputParked.read_ne_start + have hrhsReach' : (TM.binarySuccTM tapes.lifted.data.rhs).reachesIn + rhsTime + { state := (TM.binarySuccTM tapes.lifted.data.rhs).qstart + input := TM.transitionInput lhsDone.input + work := fun i => TM.transitionTape (lhsDone.work i) + output := TM.transitionTape lhsDone.output } + rhsDone := by + simpa only [hlhsInputTransition, hlhsWorkTransition, + hlhsOutputTransition] using! hrhsReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn + (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs) + hlhsReach hlhsHalt hrhsReach' + let tailDone := TM.phase2Wrap (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs) rhsDone + have htailHalt : + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)).halted tailDone := by + exact (TM.phase2Wrap_halted_iff (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs) rhsDone).mpr hrhsHalt + obtain ⟨hskipInputTransition, hskipWorkTransition, + hskipOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hparkedInput.read_ne_start (fun _ => hblankParked.read_ne_start) + hblankParked.read_ne_start + have hskipInputTransition' : + TM.transitionInput skipped.input = skipped.input := by + simpa [skipped] using! hskipInputTransition + have hskipWorkTransition' : + (fun i => TM.transitionTape (skipped.work i)) = skipped.work := by + simpa [skipped] using! hskipWorkTransition + have hskipOutputTransition' : + TM.transitionTape skipped.output = skipped.output := by + simpa [skipped] using! hskipOutputTransition + have htailReach' : + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)).reachesIn + (lhsTime + 1 + rhsTime) + { state := (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)).qstart + input := TM.transitionInput skipped.input + work := fun i => TM.transitionTape (skipped.work i) + output := TM.transitionTape skipped.output } + tailDone := by + simpa only [hskipInputTransition', hskipWorkTransition', + hskipOutputTransition'] using! htailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (TM.skipTM (n := n + 1)) + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)) + hskipReach rfl htailReach' + let finalCfg := TM.phase2Wrap (TM.skipTM (n := n + 1)) + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)) tailDone + have hrhsInputSuffix : rhsDone.input.HasBinarySuffix input := by + rw [hrhsInput, hlhsInput] + simpa [skipped, parkedInput] using! Tape.init_move_right_hasBinarySuffix input + have hrhsOutputBlank : rhsDone.output = TM.resetBinaryBlank := by + exact hrhsOutput.trans (hlhsOutput.trans (by rfl)) + have hrhsWorkParked : βˆ€ i, TM.Parked (rhsDone.work i) := by + intro i + by_cases hi : i = tapes.lifted.data.rhs + Β· subst i + exact parked_of_binaryNat hrhsValue + Β· rw [hrhsFrame i hi] + exact hlhsWorkParked i + have hrhsRemaining : tapes.lifted.data.update.remaining β‰  + tapes.lifted.data.rhs := tapes.lifted.data.ne (by decide) + have hlhsRemaining : tapes.lifted.data.update.remaining β‰  + tapes.liftedLhs := tapes.lifted.data.ne (by decide) + refine ⟨finalCfg, 1 + 1 + (lhsTime + 1 + rhsTime), ?_, hreach, + ?_, ?_⟩ + Β· omega + Β· change (initialSetupTM tapes).halted finalCfg + unfold initialSetupTM + exact (TM.phase2Wrap_halted_iff (TM.skipTM (n := n + 1)) + (TM.seqTM (TM.binarySuccTM tapes.liftedLhs) + (TM.binarySuccTM tapes.lifted.data.rhs)) tailDone).mpr htailHalt + Β· refine ⟨?_, ?_, ?_, ?_⟩ + Β· change rhsDone.input.HasBinarySuffix input + exact hrhsInputSuffix + Β· change rhsDone.input = + (Tape.init (input.map Ξ“.ofBool)).move Dir3.right + rw [hrhsInput, hlhsInput] + Β· refine + { address := ?_ + value := ?_ + count := ?_ + buffer := ?_ + parked := ?_ + frame := ?_ } + Β· change (rhsDone.work tapes.liftedLhs).HasBinaryNat 1 + rw [hrhsFrame _ hlhsRhs] + simpa using! hlhsValue + Β· change (rhsDone.work tapes.lifted.data.rhs).HasBinaryNat 1 + simpa using! hrhsValue + Β· change (rhsDone.work + tapes.lifted.data.update.remaining).HasBinaryNat 0 + rw [hrhsFrame _ hrhsRemaining, hlhsFrame _ hlhsRemaining] + simpa [skipped, parkedWork] using! hblankNat + Β· change (rhsDone.work tapes.buffer).HasBinaryPrefix [] + rw [hrhsFrame _ (tapes.liftedData_ne_buffer 14).symm, + hlhsFrame _ (tapes.liftedData_ne_buffer 13).symm] + have hblankString : TM.resetBinaryBlank.HasBinaryString [] := + hblankNat.2 + simpa [skipped, parkedWork] using! + (show TM.resetBinaryBlank.HasBinaryPrefix [] from + ⟨by simpa using! hblankString.1, hblankString.2⟩) + Β· intro i + change TM.Parked (rhsDone.work i) + exact hrhsWorkParked i + Β· intro i hlhs hrhs hcount hbuffer + change rhsDone.work i = TM.resetBinaryBlank + rw [hrhsFrame i hrhs, hlhsFrame i hlhs] + Β· change rhsDone.output = TM.resetBinaryBlank + exact hrhsOutputBlank + +/-- Emit the length register into the sparse buffer and increment the runtime +entry count, restoring both encoder sources exactly. -/ +theorem initialLengthEmitTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (length count : β„•) + (entries : Store) (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (outβ‚€ : Tape) (hready : InitialLoopReady tapes length count entries workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialLengthEmitTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InitialLoopReady tapes length (count + 1) + (entries ++ [(0, length)]) work ∧ + out = outβ‚€) + (rewindEntryEncodeRestoreTime (0, length) + 1 + + TM.binarySuccTime count) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hqueryLhs : tapes.lifted.data.update.entry.query β‰  + tapes.liftedLhs := tapes.lifted.data.ne (by decide) + have hqueryRhs : tapes.lifted.data.update.entry.query β‰  + tapes.lifted.data.rhs := tapes.lifted.data.ne (by decide) + have hqueryCount : tapes.lifted.data.update.entry.query β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hqueryBuffer : tapes.lifted.data.update.entry.query β‰  + tapes.buffer := tapes.liftedData_ne_buffer 7 + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hqueryZero : + (workβ‚€ tapes.lifted.data.update.entry.query).HasBinaryNat 0 := by + rw [hready.frame _ hqueryLhs hqueryRhs hqueryCount hqueryBuffer] + exact hblankNat + have haddress : + (workβ‚€ (Fin.castSucc (initialLengthEntryTapes tapes).address)).HasBinaryNat 0 := by + exact hqueryZero + have hvalue : + (workβ‚€ (Fin.castSucc (initialLengthEntryTapes tapes).value)).HasBinaryNat + length := by + exact hready.address + have hemit := + rewindEntryEncodeRestoreTM_retargetOutput_hoareTime_frame + (initialLengthEntryTapes tapes) (0, length) + (entries.flatMap Entry.encode) inpβ‚€ workβ‚€ haddress hvalue hinput + (fun i _ _ => hready.parked (Fin.castSucc i)) hready.buffer + obtain ⟨emitted, emitTime, hemitTime, hemitReach, hemitHalt, + hemitInput, hemitFrame, hemitBuffer, hemitOutput⟩ := + hemit inpβ‚€ workβ‚€ outβ‚€ + ⟨rfl, rfl, by simpa [TM.resetBinaryBlank] using! houtput⟩ + have hemitOutput' : emitted.output = outβ‚€ := by + exact hemitOutput.trans (by simpa [TM.resetBinaryBlank] using! houtput.symm) + have hemitInputParked : TM.Parked emitted.input := by + rw [hemitInput] + exact hinput + have hemitOutputParked : TM.Parked emitted.output := by + rw [hemitOutput'] + rw [houtput] + exact parked_of_binaryNat hblankNat + have hemitWorkParked : βˆ€ i, TM.Parked (emitted.work i) := by + intro i + by_cases hi : i = tapes.buffer + Β· subst i + exact parked_of_binaryPrefix hemitBuffer + Β· rw [hemitFrame i hi] + exact hready.parked i + have hcountBuffer : tapes.lifted.data.update.remaining β‰  tapes.buffer := + tapes.liftedData_ne_buffer 9 + have hemitCount : + (emitted.work tapes.lifted.data.update.remaining).HasBinaryNat count := by + rw [hemitFrame _ hcountBuffer] + exact hready.count + have hcountRun := TM.binarySuccTM_hoareTime_frame + tapes.lifted.data.update.remaining count emitted.input emitted.work + emitted.output hemitCount hemitInputParked.read_ne_start + (fun i _ => (hemitWorkParked i).read_ne_start) + hemitOutputParked.read_ne_start + obtain ⟨counted, countTime, hcountTime, hcountReach, hcountHalt, + hcountInput, hcountFrame, hcountValue, hcountOutput⟩ := + hcountRun emitted.input emitted.work emitted.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hemitInputTransition, hemitWorkTransition, + hemitOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hemitInputParked.read_ne_start + (fun i => (hemitWorkParked i).read_ne_start) + hemitOutputParked.read_ne_start + have hcountReach' : + (TM.binarySuccTM tapes.lifted.data.update.remaining).reachesIn + countTime + { state := (TM.binarySuccTM + tapes.lifted.data.update.remaining).qstart + input := TM.transitionInput emitted.input + work := fun i => TM.transitionTape (emitted.work i) + output := TM.transitionTape emitted.output } + counted := by + simpa only [hemitInputTransition, hemitWorkTransition, + hemitOutputTransition] using! hcountReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (rewindEntryEncodeRestoreTM + (initialLengthEntryTapes tapes)).retargetOutput + (TM.binarySuccTM tapes.lifted.data.update.remaining) + hemitReach hemitHalt hcountReach' + let finalCfg := TM.phase2Wrap + (rewindEntryEncodeRestoreTM + (initialLengthEntryTapes tapes)).retargetOutput + (TM.binarySuccTM tapes.lifted.data.update.remaining) counted + have hcountWorkParked : βˆ€ i, TM.Parked (counted.work i) := by + intro i + by_cases hi : i = tapes.lifted.data.update.remaining + Β· subst i + exact parked_of_binaryNat hcountValue + Β· rw [hcountFrame i hi] + exact hemitWorkParked i + have hlhsCount : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hrhsCount : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 13 + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 14 + refine ⟨finalCfg, emitTime + 1 + countTime, by omega, hreach, ?_, ?_⟩ + Β· change (initialLengthEmitTM tapes).halted finalCfg + unfold initialLengthEmitTM + exact (TM.phase2Wrap_halted_iff (rewindEntryEncodeRestoreTM + (initialLengthEntryTapes tapes)).retargetOutput + (TM.binarySuccTM tapes.lifted.data.update.remaining) counted).mpr hcountHalt + Β· refine ⟨?_, ?_, ?_⟩ + Β· change counted.input = inpβ‚€ + exact hcountInput.trans hemitInput + Β· refine + { address := ?_ + value := ?_ + count := hcountValue + buffer := ?_ + parked := ?_ + frame := ?_ } + Β· change (counted.work tapes.liftedLhs).HasBinaryNat length + rw [hcountFrame _ hlhsCount, hemitFrame _ hlhsBuffer] + exact hready.address + Β· change (counted.work tapes.lifted.data.rhs).HasBinaryNat 1 + rw [hcountFrame _ hrhsCount, hemitFrame _ hrhsBuffer] + exact hready.value + Β· change (counted.work tapes.buffer).HasBinaryPrefix + ((entries ++ [(0, length)]).flatMap Entry.encode) + rw [hcountFrame _ hcountBuffer.symm] + simpa [List.flatMap_append] using! hemitBuffer + Β· intro i + change TM.Parked (counted.work i) + exact hcountWorkParked i + Β· intro i hlhs hrhs hcount hbuffer + change counted.work i = TM.resetBinaryBlank + rw [hcountFrame i hcount, hemitFrame i hbuffer] + exact hready.frame i hlhs hrhs hcount hbuffer + Β· change counted.output = outβ‚€ + exact hcountOutput.trans hemitOutput' + +/-- Optional length emission skips zero and appends exactly one nonzero +`Rβ‚€` entry otherwise. -/ +theorem initialLengthTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (length count : β„•) + (entries : Store) (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (outβ‚€ : Tape) (hready : InitialLoopReady tapes length count entries workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialLengthTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InitialLoopReady tapes length + (count + if length = 0 then 0 else 1) + (entries ++ if length = 0 then [] else [(0, length)]) work ∧ + out = outβ‚€) + (initialLengthTime length count) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + by_cases hlength : length = 0 + Β· subst length + have hblank : (workβ‚€ tapes.liftedLhs).read = Ξ“.blank := + hready.address.read_eq_blank_iff.mpr rfl + have hskip := TM.skipTM_hoareTime_frame inpβ‚€ workβ‚€ outβ‚€ hinput + hready.parked (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat) + obtain ⟨skipDone, skipTime, hskipTime, hskipReach, hskipHalt, + hskipInput, hskipWork, hskipOutput⟩ := + hskip inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneWork, hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_blank_frame tapes.liftedLhs + (TM.skipTM (n := n + 1)) (initialLengthEmitTM tapes) + inpβ‚€ workβ‚€ outβ‚€ hblank hinput.read_ne_start + (fun i => (hready.parked i).read_ne_start) + (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact (parked_of_binaryNat hblankNat).read_ne_start) + hskipReach hskipHalt + refine ⟨done, skipTime + 1, ?_, hreach, hhalt, ?_⟩ + Β· simp [initialLengthTime] + omega + Β· refine ⟨?_, ?_, ?_⟩ + Β· exact hdoneInput.trans hskipInput + Β· simpa [hdoneWork, hskipWork] using! hready + Β· exact hdoneOutput.trans (hskipOutput.trans rfl) + Β· have hnonblank : (workβ‚€ tapes.liftedLhs).read β‰  Ξ“.blank := by + intro hblank + exact hlength (hready.address.read_eq_blank_iff.mp hblank) + have hemit := initialLengthEmitTM_hoareTime_internal tapes length count + entries inpβ‚€ workβ‚€ outβ‚€ hready hinput houtput + obtain ⟨emitDone, emitTime, hemitTime, hemitReach, hemitHalt, + hemitInput, hemitReady, hemitOutput⟩ := + hemit inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨done, hreach, hhalt, hdoneInput, hdoneWork, hdoneOutput⟩ := + TM.branchWorkBlankTM_reachesIn_nonblank_frame tapes.liftedLhs + (TM.skipTM (n := n + 1)) (initialLengthEmitTM tapes) + inpβ‚€ workβ‚€ outβ‚€ hnonblank hinput.read_ne_start + (fun i => (hready.parked i).read_ne_start) + (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact (parked_of_binaryNat hblankNat).read_ne_start) + hemitReach hemitHalt + refine ⟨done, emitTime + 1, ?_, hreach, hhalt, ?_⟩ + Β· simp [initialLengthTime, hlength] + omega + Β· refine ⟨?_, ?_, ?_⟩ + Β· exact hdoneInput.trans hemitInput + Β· simpa [hlength, hdoneWork] using! hemitReady + Β· exact hdoneOutput.trans hemitOutput + +/-- Restore the post-loop address and install the optional length entry. -/ +theorem initialLengthInstallTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (length count : β„•) + (entries : Store) (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) + (outβ‚€ : Tape) + (hready : InitialLoopReady tapes (length + 1) count entries workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialLengthInstallTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + InitialLoopReady tapes length + (count + if length = 0 then 0 else 1) + (entries ++ if length = 0 then [] else [(0, length)]) work ∧ + out = outβ‚€) + (TM.binaryPredTime length + 1 + initialLengthTime length count) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hpred := TM.binaryPredTM_hoareTime_frame tapes.liftedLhs length + inpβ‚€ workβ‚€ outβ‚€ hready.address hinput.read_ne_start + (fun i _ => (hready.parked i).read_ne_start) + (by + rw [houtput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact (parked_of_binaryNat hblankNat).read_ne_start) + obtain ⟨predDone, predTime, hpredTime, hpredReach, hpredHalt, + hpredInput, hpredFrame, hpredValue, hpredOutput⟩ := + hpred inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hpredInputParked : TM.Parked predDone.input := by + rw [hpredInput] + exact hinput + have hpredOutputBlank : predDone.output = TM.resetBinaryBlank := + hpredOutput.trans houtput + have hpredOutputParked : TM.Parked predDone.output := by + rw [hpredOutputBlank] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hpredWorkParked : βˆ€ i, TM.Parked (predDone.work i) := by + intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + exact parked_of_binaryNat hpredValue + Β· rw [hpredFrame i hi] + exact hready.parked i + have hrhsLhs : tapes.lifted.data.rhs β‰  tapes.liftedLhs := + tapes.lifted.data.ne (by decide) + have hcountLhs : tapes.lifted.data.update.remaining β‰  + tapes.liftedLhs := tapes.lifted.data.ne (by decide) + have hbufferLhs : tapes.buffer β‰  tapes.liftedLhs := + (tapes.liftedData_ne_buffer 13).symm + have hpredReady : InitialLoopReady tapes length count entries predDone.work := + { address := hpredValue + value := by + rw [hpredFrame _ hrhsLhs] + exact hready.value + count := by + rw [hpredFrame _ hcountLhs] + exact hready.count + buffer := by + rw [hpredFrame _ hbufferLhs] + exact hready.buffer + parked := hpredWorkParked + frame := by + intro i hlhs hrhs hcount hbuffer + rw [hpredFrame i hlhs] + exact hready.frame i hlhs hrhs hcount hbuffer } + have hlength := initialLengthTM_hoareTime_internal tapes length count entries + predDone.input predDone.work predDone.output hpredReady hpredInputParked + hpredOutputBlank + obtain ⟨lengthDone, lengthTime, hlengthTime, hlengthReach, + hlengthHalt, hlengthInput, hlengthReady, hlengthOutput⟩ := + hlength predDone.input predDone.work predDone.output ⟨rfl, rfl, rfl⟩ + obtain ⟨hpredInputTransition, hpredWorkTransition, + hpredOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hpredInputParked.read_ne_start + (fun i => (hpredWorkParked i).read_ne_start) + hpredOutputParked.read_ne_start + have hlengthReach' : (initialLengthTM tapes).reachesIn lengthTime + { state := (initialLengthTM tapes).qstart + input := TM.transitionInput predDone.input + work := fun i => TM.transitionTape (predDone.work i) + output := TM.transitionTape predDone.output } + lengthDone := by + simpa only [hpredInputTransition, hpredWorkTransition, + hpredOutputTransition] using! hlengthReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (TM.binaryPredTM tapes.liftedLhs) (initialLengthTM tapes) + hpredReach hpredHalt hlengthReach' + let finalCfg := TM.phase2Wrap (TM.binaryPredTM tapes.liftedLhs) + (initialLengthTM tapes) lengthDone + refine ⟨finalCfg, predTime + 1 + lengthTime, by omega, hreach, ?_, ?_⟩ + Β· change (initialLengthInstallTM tapes).halted finalCfg + unfold initialLengthInstallTM + exact (TM.phase2Wrap_halted_iff (TM.binaryPredTM tapes.liftedLhs) + (initialLengthTM tapes) lengthDone).mpr hlengthHalt + Β· refine ⟨?_, ?_, ?_⟩ + Β· change lengthDone.input = inpβ‚€ + exact hlengthInput.trans hpredInput + Β· change InitialLoopReady tapes length + (count + if length = 0 then 0 else 1) + (entries ++ if length = 0 then [] else [(0, length)]) + lengthDone.work + exact hlengthReady + Β· change lengthDone.output = outβ‚€ + exact hlengthOutput.trans hpredOutput + +/-- Copy the sparse entry count into the ABI result counter while preserving every other tape. -/ +private theorem initialAbiCount_hoareTime + (tapes : ControlInstructionTapes n) (store : Store) (length : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) (outβ‚€ : Tape) + (hready : InitialLoopReady tapes length store.length store workβ‚€) + (hinput : TM.Parked inpβ‚€) (houtputParked : TM.Parked outβ‚€) : + let W₁ := initialAbiCountWork tapes workβ‚€ store.length + (TM.binaryCopyIntoTM + tapes.lifted.data.update.remaining + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.found).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = outβ‚€) + (TM.binaryCopyTime store.length 0) := by + dsimp only + let W₁ := initialAbiCountWork tapes workβ‚€ store.length + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hremainingResult : tapes.lifted.data.update.remaining β‰  + tapes.lifted.data.update.resultCount := + tapes.lifted.data.ne (by decide) + have hremainingFound : tapes.lifted.data.update.remaining β‰  + tapes.lifted.data.update.found := tapes.lifted.data.ne (by decide) + have hresultFound : tapes.lifted.data.update.resultCount β‰  + tapes.lifted.data.update.found := tapes.lifted.data.ne (by decide) + have hresultLhs : tapes.lifted.data.update.resultCount β‰  + tapes.liftedLhs := tapes.lifted.data.ne (by decide) + have hresultRhs : tapes.lifted.data.update.resultCount β‰  + tapes.lifted.data.rhs := tapes.lifted.data.ne (by decide) + have hresultBuffer : tapes.lifted.data.update.resultCount β‰  + tapes.buffer := tapes.liftedData_ne_buffer 12 + have hfoundLhs : tapes.lifted.data.update.found β‰  + tapes.liftedLhs := tapes.lifted.data.ne (by decide) + have hfoundRhs : tapes.lifted.data.update.found β‰  + tapes.lifted.data.rhs := tapes.lifted.data.ne (by decide) + have hfoundRemaining : tapes.lifted.data.update.found β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hfoundBuffer : tapes.lifted.data.update.found β‰  tapes.buffer := + tapes.liftedData_ne_buffer 11 + have hresultZero : + (workβ‚€ tapes.lifted.data.update.resultCount).HasBinaryNat 0 := by + rw [hready.frame _ hresultLhs hresultRhs hremainingResult.symm + hresultBuffer] + exact hblankNat + have hfoundZero : + (workβ‚€ tapes.lifted.data.update.found).HasBinaryNat 0 := by + rw [hready.frame _ hfoundLhs hfoundRhs hfoundRemaining hfoundBuffer] + exact hblankNat + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame + tapes.lifted.data.update.remaining + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.found hremainingResult hremainingFound + hresultFound store.length 0 inpβ‚€ workβ‚€ outβ‚€ hready.count + hresultZero hfoundZero hinput + (fun i _ _ _ => hready.parked i) houtputParked + have hcopy' : + (TM.binaryCopyIntoTM + tapes.lifted.data.update.remaining + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.found).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = outβ‚€) + (TM.binaryCopyTime store.length 0) := by + simpa only [W₁, initialAbiCountWork] using! hcopy + exact hcopy' + +/-- Clear the initialization address and value tapes after installing the sparse store. -/ +private theorem initialAbiCleanup_hoareTime + (tapes : ControlInstructionTapes n) (store : Store) (length : β„•) + (inpβ‚€ : Tape) (workβ‚€ Wβ‚… : Fin (n + 1) β†’ Tape) (outβ‚€ : Tape) + (hready : InitialLoopReady tapes length store.length store workβ‚€) + (hWβ‚…Lhs : Wβ‚… tapes.liftedLhs = workβ‚€ tapes.liftedLhs) + (hWβ‚…Rhs : Wβ‚… tapes.lifted.data.rhs = workβ‚€ tapes.lifted.data.rhs) + (hinput : TM.Parked inpβ‚€) (hWβ‚…Parked : βˆ€ i, TM.Parked (Wβ‚… i)) + (houtputParked : TM.Parked outβ‚€) : + let W₆ := initialAbiFinalWork tapes Wβ‚… + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚… ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₆ ∧ out = outβ‚€) + (TM.resetBinaryWorkManyTime (initialCleanupBits tapes length) + (fun _ => 1) (initialCleanupTargets tapes)) := by + dsimp only + let W₆ := initialAbiFinalWork tapes Wβ‚… + have hlhsRhs : tapes.liftedLhs β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have htargetsNodup : (initialCleanupTargets tapes).Nodup := by + simp [initialCleanupTargets, hlhsRhs] + have htargetsContent : βˆ€ i, i ∈ initialCleanupTargets tapes β†’ + (Wβ‚… i).HasBinaryContent (initialCleanupBits tapes length i) := by + intro i hi + simp [initialCleanupTargets] at hi + rcases hi with rfl | rfl + Β· rw [hWβ‚…Lhs] + simpa [initialCleanupBits] using! hready.address.2.hasBinaryContent + Β· rw [hWβ‚…Rhs] + simpa [initialCleanupBits, hlhsRhs.symm] using! + hready.value.2.hasBinaryContent + have htargetsStart : βˆ€ i, i ∈ initialCleanupTargets tapes β†’ + (Wβ‚… i).cells 0 = Ξ“.start := by + intro i hi + simp [initialCleanupTargets] at hi + rcases hi with rfl | rfl + Β· rw [hWβ‚…Lhs] + exact hready.address.1 + Β· rw [hWβ‚…Rhs] + exact hready.value.1 + have htargetsHead : βˆ€ i, i ∈ initialCleanupTargets tapes β†’ + (Wβ‚… i).head ≀ 1 := by + intro i hi + simp [initialCleanupTargets] at hi + rcases hi with rfl | rfl + Β· rw [hWβ‚…Lhs, hready.address.2.1] + Β· rw [hWβ‚…Rhs, hready.value.2.1] + have hresetMany := TM.resetBinaryWorkManyTM_hoareTime_frame + (initialCleanupTargets tapes) (initialCleanupBits tapes length) + (fun _ => 1) inpβ‚€ Wβ‚… outβ‚€ htargetsNodup htargetsContent + htargetsStart htargetsHead hinput hWβ‚…Parked houtputParked + have hresetMany' : + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚… ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₆ ∧ out = outβ‚€) + (TM.resetBinaryWorkManyTime (initialCleanupBits tapes length) + (fun _ => 1) (initialCleanupTargets tapes)) := by + simpa only [W₆, initialAbiFinalWork] using! hresetMany + exact hresetMany' + +/-- Install the completed sparse buffer into the exact clean program-loop +snapshot image. -/ +theorem initialAbiInstallTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (store : Store) (length : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin (n + 1) β†’ Tape) (outβ‚€ : Tape) + (hready : InitialLoopReady tapes length store.length store workβ‚€) + (hbufferStart : (workβ‚€ tapes.buffer).cells 0 = Ξ“.start) + (hinput : TM.Parked inpβ‚€) (houtput : outβ‚€ = TM.resetBinaryBlank) : + (initialAbiInstallTM tapes).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = programSnapshotWork tapes { pc := 0, store := store } ∧ + out = outβ‚€) + (initialAbiInstallTime tapes store length) := by + let storeBits := store.flatMap Entry.encode + let W₁ := initialAbiCountWork tapes workβ‚€ store.length + let Wβ‚‚ := initialAbiBufferWork tapes W₁ store + let W₃ := initialAbiCopiedWork tapes Wβ‚‚ store + let Wβ‚„ := initialAbiSourceWork tapes W₃ store + let Wβ‚… := initialAbiBufferResetWork tapes Wβ‚„ + let W₆ := initialAbiFinalWork tapes Wβ‚… + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have houtputParked : TM.Parked outβ‚€ := by + rw [houtput] + exact parked_of_binaryNat hblankNat + have hresultBuffer : tapes.lifted.data.update.resultCount β‰  + tapes.buffer := tapes.liftedData_ne_buffer 12 + have hsourceLhs : tapes.liftedSource β‰  tapes.liftedLhs := + tapes.lifted.data.ne (by decide) + have hsourceRhs : tapes.liftedSource β‰  tapes.lifted.data.rhs := + tapes.lifted.data.ne (by decide) + have hsourceRemaining : tapes.liftedSource β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hsourceResult : tapes.liftedSource β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hsourceBuffer : tapes.liftedSource β‰  tapes.buffer := + tapes.liftedSource_ne_buffer + have hlhsRemaining : tapes.liftedLhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hlhsResult : tapes.liftedLhs β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hlhsSource := hsourceLhs.symm + have hlhsBuffer : tapes.liftedLhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 13 + have hrhsRemaining : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.remaining := tapes.lifted.data.ne (by decide) + have hrhsResult : tapes.lifted.data.rhs β‰  + tapes.lifted.data.update.resultCount := tapes.lifted.data.ne (by decide) + have hrhsSource := hsourceRhs.symm + have hrhsBuffer : tapes.lifted.data.rhs β‰  tapes.buffer := + tapes.liftedData_ne_buffer 14 + have hremainingBuffer : tapes.lifted.data.update.remaining β‰  + tapes.buffer := tapes.liftedData_ne_buffer 9 + have hcountEq : workβ‚€ tapes.lifted.data.update.remaining = + programBinaryTape store.length.bits := by + simpa only [programBinaryTape] using! hready.count.eq_init_move_right + have hbufferEq : workβ‚€ tapes.buffer = programBinaryPrefixTape storeBits := by + exact eq_programBinaryPrefixTape_of_hasBinaryPrefix hready.buffer + hbufferStart + have hcopy' := initialAbiCount_hoareTime tapes store length inpβ‚€ workβ‚€ outβ‚€ + hready hinput houtputParked + have hW₁Parked : βˆ€ i, TM.Parked (W₁ i) := by + exact parked_update hready.parked (binaryTape_parked store.length.bits) + have hW₁Buffer : W₁ tapes.buffer = programBinaryPrefixTape storeBits := by + simp [W₁, initialAbiCountWork, hresultBuffer.symm, hbufferEq] + have hrewindBuffer := rewindPrefixWorkTM_exact_hoareTime tapes.buffer + storeBits inpβ‚€ W₁ outβ‚€ hW₁Buffer hinput hW₁Parked houtputParked + have hrewindBuffer' : (TM.rewindWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚‚ ∧ out = outβ‚€) + (storeBits.length + 1 + 2) := by + simpa only [Wβ‚‚, initialAbiBufferWork] using! hrewindBuffer + have hWβ‚‚Parked : βˆ€ i, TM.Parked (Wβ‚‚ i) := by + exact parked_update hW₁Parked (binaryTape_parked storeBits) + have hWβ‚‚Buffer : Wβ‚‚ tapes.buffer = programBinaryTape storeBits := by + simp [Wβ‚‚, initialAbiBufferWork, storeBits] + have hsourceBlank : workβ‚€ tapes.liftedSource = TM.resetBinaryBlank := by + exact hready.frame _ hsourceLhs hsourceRhs hsourceRemaining hsourceBuffer + have hWβ‚‚Source : Wβ‚‚ tapes.liftedSource = TM.resetBinaryBlank := by + simp [Wβ‚‚, W₁, initialAbiBufferWork, initialAbiCountWork, + hsourceBuffer, hsourceResult, hsourceBlank] + have hcopyStore := copyWorkToWorkTM_exact_hoareTime tapes.buffer + tapes.liftedSource hsourceBuffer.symm storeBits inpβ‚€ Wβ‚‚ outβ‚€ + hWβ‚‚Buffer hWβ‚‚Source hinput hWβ‚‚Parked houtputParked + have hcopyStore' : + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚‚ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₃ ∧ out = outβ‚€) + (storeBits.length + 1) := by + simpa only [W₃, initialAbiCopiedWork] using! hcopyStore + have hprefixParked : TM.Parked (programBinaryPrefixTape storeBits) := + programBinaryPrefixTape_parked storeBits + have hW₃Parked : βˆ€ i, TM.Parked (W₃ i) := by + exact parked_update (parked_update hWβ‚‚Parked hprefixParked) + hprefixParked + have hW₃Source : + W₃ tapes.liftedSource = programBinaryPrefixTape storeBits := by + simp [W₃, initialAbiCopiedWork, storeBits] + have hrewindSource := rewindPrefixWorkTM_exact_hoareTime + tapes.liftedSource storeBits inpβ‚€ W₃ outβ‚€ hW₃Source + hinput hW₃Parked houtputParked + have hrewindSource' : (TM.rewindWorkTM tapes.liftedSource).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = W₃ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚„ ∧ out = outβ‚€) + (storeBits.length + 1 + 2) := by + simpa only [Wβ‚„, initialAbiSourceWork] using! hrewindSource + have hWβ‚„Parked : βˆ€ i, TM.Parked (Wβ‚„ i) := by + exact parked_update hW₃Parked (binaryTape_parked storeBits) + have hWβ‚„Buffer : + Wβ‚„ tapes.buffer = programBinaryPrefixTape storeBits := by + simp [Wβ‚„, W₃, initialAbiSourceWork, initialAbiCopiedWork, + hsourceBuffer.symm, storeBits] + have hresetBuffer := TM.resetBinaryWorkTM_hoareTime_frame tapes.buffer + storeBits (storeBits.length + 1) inpβ‚€ Wβ‚„ outβ‚€ + (by rw [hWβ‚„Buffer]; exact + (programBinaryPrefixTape_hasBinaryPrefix storeBits).2) + (by rw [hWβ‚„Buffer]; simp [programBinaryPrefixTape]) + (by rw [hWβ‚„Buffer]; simp [programBinaryPrefixTape]) + hinput (fun i _ => hWβ‚„Parked i) houtputParked + have hresetBuffer' : (TM.resetBinaryWorkTM tapes.buffer).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚„ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚… ∧ out = outβ‚€) + (TM.resetBinaryWorkTime (storeBits.length + 1) storeBits.length) := by + simpa only [Wβ‚…, initialAbiBufferResetWork, TM.resetBinaryBlank] + using! hresetBuffer + have hWβ‚…Parked : βˆ€ i, TM.Parked (Wβ‚… i) := by + exact parked_update hWβ‚„Parked (parked_of_binaryNat hblankNat) + have hWβ‚…Lhs : Wβ‚… tapes.liftedLhs = workβ‚€ tapes.liftedLhs := by + simp [Wβ‚…, Wβ‚„, W₃, Wβ‚‚, W₁, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, hlhsBuffer, hlhsSource, hlhsResult] + have hWβ‚…Rhs : + Wβ‚… tapes.lifted.data.rhs = workβ‚€ tapes.lifted.data.rhs := by + simp [Wβ‚…, Wβ‚„, W₃, Wβ‚‚, W₁, initialAbiBufferResetWork, + initialAbiSourceWork, initialAbiCopiedWork, initialAbiBufferWork, + initialAbiCountWork, hrhsBuffer, hrhsSource, hrhsResult] + have hresetMany' := initialAbiCleanup_hoareTime tapes store length inpβ‚€ workβ‚€ Wβ‚… outβ‚€ + hready hWβ‚…Lhs hWβ‚…Rhs hinput hWβ‚…Parked houtputParked + have htailβ‚… := TM.seqTM_hoareTime + (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes)) + hresetBuffer' + (exact_phaseTransition_of_parked inpβ‚€ Wβ‚… outβ‚€ hinput + hWβ‚…Parked houtputParked) + hresetMany' + have htailβ‚„ := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes))) + hrewindSource' + (exact_phaseTransition_of_parked inpβ‚€ Wβ‚„ outβ‚€ hinput + hWβ‚„Parked houtputParked) + htailβ‚… + have htail₃ := TM.seqTM_hoareTime + (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes)))) + hcopyStore' + (exact_phaseTransition_of_parked inpβ‚€ W₃ outβ‚€ hinput + hW₃Parked houtputParked) + htailβ‚„ + have htailβ‚‚ := TM.seqTM_hoareTime + (TM.rewindWorkTM tapes.buffer) + (TM.seqTM (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes))))) + hrewindBuffer' + (exact_phaseTransition_of_parked inpβ‚€ Wβ‚‚ outβ‚€ hinput + hWβ‚‚Parked houtputParked) + htail₃ + have hfull := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM + tapes.lifted.data.update.remaining + tapes.lifted.data.update.resultCount + tapes.lifted.data.update.found) + (TM.seqTM (TM.rewindWorkTM tapes.buffer) + (TM.seqTM (TM.copyWorkToWorkTM tapes.buffer tapes.liftedSource) + (TM.seqTM (TM.rewindWorkTM tapes.liftedSource) + (TM.seqTM (TM.resetBinaryWorkTM tapes.buffer) + (TM.resetBinaryWorkManyTM (initialCleanupTargets tapes)))))) + hcopy' + (exact_phaseTransition_of_parked inpβ‚€ W₁ outβ‚€ hinput + hW₁Parked houtputParked) + htailβ‚‚ + have hfinal : W₆ = + programSnapshotWork tapes { pc := 0, store := store } := by + exact initialAbiFinalWork_eq_programSnapshotWork tapes store length + workβ‚€ hready + apply hfull.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + exact ⟨hinp, hwork.trans hfinal, hout⟩ + Β· simp only [initialAbiInstallTime, storeBits] + omega + +private theorem inputBitStoreFrom_address_lower + {start : β„•} {input : List Bool} {entry : Entry} + (hentry : entry ∈ inputBitStoreFrom start input) : + start ≀ entry.1 := by + induction input generalizing start with + | nil => simp [inputBitStoreFrom] at hentry + | cons bit rest ih => + by_cases hbit : bit + Β· simp only [inputBitStoreFrom, hbit, if_true, List.singleton_append, + List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· simp + Β· exact le_trans (by omega) (ih hentry) + Β· simp only [inputBitStoreFrom, hbit] at hentry + exact le_trans (by omega) (ih hentry) + +private theorem inputBitStoreFrom_addressesNodup + (start : β„•) (input : List Bool) : + AddressesNodup (inputBitStoreFrom start input) := by + induction input generalizing start with + | nil => simp [inputBitStoreFrom, AddressesNodup] + | cons bit rest ih => + by_cases hbit : bit + Β· simp only [inputBitStoreFrom, hbit, if_true, List.singleton_append] + change (start :: (inputBitStoreFrom (start + 1) rest).map Prod.fst).Nodup + rw [List.nodup_cons] + refine ⟨?_, ih (start + 1)⟩ + intro hmem + obtain ⟨entry, hentry, heq⟩ := List.mem_map.mp hmem + have hlower := inputBitStoreFrom_address_lower hentry + change entry.1 = start at heq + omega + Β· simpa [inputBitStoreFrom, hbit] using! ih (start + 1) + +private theorem inputBitStoreFrom_valuesNonzero + (start : β„•) (input : List Bool) : + ValuesNonzero (inputBitStoreFrom start input) := by + induction input generalizing start with + | nil => simp [inputBitStoreFrom, ValuesNonzero] + | cons bit rest ih => + by_cases hbit : bit + Β· simp only [inputBitStoreFrom, hbit, if_true, List.singleton_append] + intro entry hentry + simp only [List.mem_cons] at hentry + rcases hentry with rfl | hentry + Β· exact Nat.one_ne_zero + Β· exact ih (start + 1) entry hentry + Β· simpa [inputBitStoreFrom, hbit] using! ih (start + 1) + +private theorem zero_not_mem_inputBitStoreFrom_addresses + (input : List Bool) : + 0 βˆ‰ (inputBitStoreFrom 1 input).map Prod.fst := by + intro hmem + obtain ⟨entry, hentry, heq⟩ := List.mem_map.mp hmem + have hlower := inputBitStoreFrom_address_lower hentry + change entry.1 = 0 at heq + omega + +private theorem write_eq_append_of_address_not_mem + (store : Store) (address value : β„•) + (haddress : address βˆ‰ store.map Prod.fst) : + RegisterStore.write store address value = + store ++ if value = 0 then [] else [(address, value)] := by + induction store with + | nil => simp [RegisterStore.write] + | cons entry rest ih => + have hhead : address β‰  entry.1 := by + intro heq + apply haddress + simp [heq] + have hrest : address βˆ‰ rest.map Prod.fst := by + intro hmem + exact haddress (by simp [hmem]) + simp [RegisterStore.write, hhead, ih hrest] + +theorem programInitialStore_eq_append_internal (input : List Bool) : + programInitialStore input = + inputBitStoreFrom 1 input ++ + if input.length = 0 then [] else [(0, input.length)] := by + unfold programInitialStore + exact write_eq_append_of_address_not_mem _ _ _ + (zero_not_mem_inputBitStoreFrom_addresses input) + +private theorem inputBitStoreFrom_length (start : β„•) (input : List Bool) : + (inputBitStoreFrom start input).length = inputTrueCount input := by + induction input generalizing start with + | nil => simp [inputBitStoreFrom, inputTrueCount] + | cons bit rest ih => + cases bit + Β· simp [inputBitStoreFrom, inputTrueCount, ih] + Β· simp [inputBitStoreFrom, inputTrueCount, ih] + omega + +theorem programInitialStore_length_internal (input : List Bool) : + (programInitialStore input).length = + inputTrueCount input + if input.length = 0 then 0 else 1 := by + rw [programInitialStore_eq_append_internal, List.length_append, + inputBitStoreFrom_length] + split <;> simp_all + +theorem programInitialStore_canonical_internal (input : List Bool) : + Canonical (programInitialStore input) := by + apply RegisterStore.write_canonical + exact ⟨inputBitStoreFrom_addressesNodup 1 input, + inputBitStoreFrom_valuesNonzero 1 input⟩ + +private theorem read_inputBitStoreFrom (start target : β„•) + (input : List Bool) : + read (inputBitStoreFrom start input) target = + if start ≀ target then + match input[target - start]? with + | some bit => if bit then 1 else 0 + | none => 0 + else 0 := by + induction input generalizing start target with + | nil => simp [inputBitStoreFrom, read] + | cons bit rest ih => + cases bit + Β· simp only [inputBitStoreFrom, Bool.false_eq_true, ite_false, + List.nil_append] + by_cases htarget : target = start + Β· subst target + rw [ih] + simp + Β· by_cases hlt : target < start + Β· rw [ih] + simp only [ite_eq_right (by omega : Β¬start + 1 ≀ target), + ite_eq_right (by omega : Β¬start ≀ target)] + Β· have hge : start + 1 ≀ target := by omega + have hsub : target - start = (target - (start + 1)) + 1 := by + omega + rw [ih, ite_eq_left hge, ite_eq_left (by omega : start ≀ target)] + simp [hsub] + Β· simp only [inputBitStoreFrom, if_true, List.singleton_append] + by_cases htarget : target = start + Β· subst target + simp [read] + Β· by_cases hlt : target < start + Β· rw [read, ite_eq_right htarget, ih] + simp only [ite_eq_right (by omega : Β¬start + 1 ≀ target), + ite_eq_right (by omega : Β¬start ≀ target)] + Β· have hge : start + 1 ≀ target := by omega + have hsub : target - start = (target - (start + 1)) + 1 := by + omega + rw [read, ite_eq_right htarget, ih, ite_eq_left hge, + ite_eq_left (by omega : start ≀ target)] + simp [hsub] + +private theorem read_inputBitStoreFrom_zero (input : List Bool) : + read (inputBitStoreFrom 1 input) 0 = 0 := by + simp [read_inputBitStoreFrom] + +private theorem read_programInitialStore (input : List Bool) (target : β„•) : + read (programInitialStore input) target = initRegs input target := by + rw [programInitialStore, RegisterStore.read_write] + by_cases htarget : target = 0 + Β· subst target + simp [initRegs] + Β· have hone : 1 ≀ target := Nat.one_le_iff_ne_zero.mpr htarget + simp [Function.update, htarget, read_inputBitStoreFrom, hone, initRegs] + rfl + exact inputBitStoreFrom_addressesNodup 1 input + +theorem programInitialSnapshot_represents_internal (input : List Bool) : + (programInitialSnapshot input).Represents (RAM.initCfg input) := by + refine ⟨programInitialStore_canonical_internal input, ?_⟩ + apply RAM.Cfg.ext + Β· rfl + Β· funext target + exact read_programInitialStore input target + +/-- Complete public-input initialization reaches the exact sparse snapshot +image consumed by the reusable program loop. -/ +theorem programInitTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (input : List Bool) : + (programInitTM tapes).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => + inp.HasBinarySuffix [] ∧ + work = programSnapshotWork tapes (programInitialSnapshot input) ∧ + out = TM.resetBinaryBlank) + (programInitTime tapes input) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hsetup := initialSetupTM_hoareTime_internal tapes input + obtain ⟨setupDone, setupTime, hsetupTime, hsetupReach, hsetupHalt, + hsetupInput, _hsetupInputEq, hsetupReady, hsetupOutput⟩ := + hsetup _ _ _ ⟨rfl, rfl, rfl⟩ + have hsetupBufferStart : + (setupDone.work tapes.buffer).cells 0 = Ξ“.start := by + apply TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hsetupReach + simp [Tape.init] + have hsetupInputParked : TM.Parked setupDone.input := + parked_of_binarySuffix hsetupInput + have hsetupOutputParked : TM.Parked setupDone.output := by + rw [hsetupOutput] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hloop := initialInputLoopTM_hoareTime_internal tapes input 1 0 [] + setupDone.input setupDone.work setupDone.output hsetupInput hsetupReady + hsetupOutput + obtain ⟨loopDone, loopTime, hloopTime, hloopReach, hloopHalt, + hloopInput, hloopReadyRaw, hloopOutput⟩ := + hloop _ _ _ ⟨rfl, rfl, rfl⟩ + have hloopBufferStart : + (loopDone.work tapes.buffer).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hloopReach + hsetupBufferStart + have hloopReady : InitialLoopReady tapes (input.length + 1) + (inputTrueCount input) (inputBitStoreFrom 1 input) loopDone.work := by + simpa [Nat.add_comm] using! hloopReadyRaw + have hloopInputParked : TM.Parked loopDone.input := + parked_of_binarySuffix hloopInput + have hloopOutputBlank : loopDone.output = TM.resetBinaryBlank := + hloopOutput.trans hsetupOutput + have hloopOutputParked : TM.Parked loopDone.output := by + rw [hloopOutputBlank] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have hlength := initialLengthInstallTM_hoareTime_internal tapes + input.length (inputTrueCount input) (inputBitStoreFrom 1 input) + loopDone.input loopDone.work loopDone.output hloopReady hloopInputParked + hloopOutputBlank + obtain ⟨lengthDone, lengthTime, hlengthTime, hlengthReach, + hlengthHalt, hlengthInput, hlengthReadyRaw, hlengthOutput⟩ := + hlength _ _ _ ⟨rfl, rfl, rfl⟩ + have hlengthBufferStart : + (lengthDone.work tapes.buffer).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn tapes.buffer hlengthReach + hloopBufferStart + have hlengthReady : InitialLoopReady tapes input.length + (programInitialStore input).length (programInitialStore input) + lengthDone.work := by + rw [programInitialStore_length_internal, + programInitialStore_eq_append_internal] + exact hlengthReadyRaw + have hlengthInputParked : TM.Parked lengthDone.input := by + rw [hlengthInput] + exact hloopInputParked + have hlengthOutputBlank : lengthDone.output = TM.resetBinaryBlank := + hlengthOutput.trans hloopOutputBlank + have hlengthOutputParked : TM.Parked lengthDone.output := by + rw [hlengthOutputBlank] + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + exact parked_of_binaryNat hblankNat + have habi := initialAbiInstallTM_hoareTime_internal tapes + (programInitialStore input) input.length lengthDone.input + lengthDone.work lengthDone.output hlengthReady hlengthBufferStart + hlengthInputParked hlengthOutputBlank + obtain ⟨abiDone, abiTime, habiTime, habiReach, habiHalt, + habiInput, habiWork, habiOutput⟩ := + habi _ _ _ ⟨rfl, rfl, rfl⟩ + obtain ⟨hlengthInputTransition, hlengthWorkTransition, + hlengthOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hlengthInputParked.read_ne_start + (fun i => (hlengthReady.parked i).read_ne_start) + hlengthOutputParked.read_ne_start + have habiReach' : (initialAbiInstallTM tapes).reachesIn abiTime + { state := (initialAbiInstallTM tapes).qstart + input := TM.transitionInput lengthDone.input + work := fun i => TM.transitionTape (lengthDone.work i) + output := TM.transitionTape lengthDone.output } + abiDone := by + simpa only [hlengthInputTransition, hlengthWorkTransition, + hlengthOutputTransition] using! habiReach + have hfinalizeReach := TM.seqTM_reachesIn_of_reachesIn + (initialLengthInstallTM tapes) (initialAbiInstallTM tapes) + hlengthReach hlengthHalt habiReach' + let finalizeDone := TM.phase2Wrap (initialLengthInstallTM tapes) + (initialAbiInstallTM tapes) abiDone + have hfinalizeHalt : (initialFinalizeTM tapes).halted finalizeDone := by + unfold initialFinalizeTM + exact (TM.phase2Wrap_halted_iff (initialLengthInstallTM tapes) + (initialAbiInstallTM tapes) abiDone).mpr habiHalt + have hloopInputTransition : + TM.transitionInput loopDone.input = loopDone.input := + TM.transitionInput_eq_self hloopInputParked.read_ne_start + have hloopWorkTransition : + (fun i => TM.transitionTape (loopDone.work i)) = loopDone.work := + funext fun i => TM.transitionTape_eq_self + (hloopReady.parked i).read_ne_start + have hloopOutputTransition : + TM.transitionTape loopDone.output = loopDone.output := + TM.transitionTape_eq_self hloopOutputParked.read_ne_start + have hfinalizeReach' : (initialFinalizeTM tapes).reachesIn + (lengthTime + 1 + abiTime) + { state := (initialFinalizeTM tapes).qstart + input := TM.transitionInput loopDone.input + work := fun i => TM.transitionTape (loopDone.work i) + output := TM.transitionTape loopDone.output } + finalizeDone := by + simpa only [hloopInputTransition, hloopWorkTransition, + hloopOutputTransition] using! hfinalizeReach + have hloopTailReach := TM.seqTM_reachesIn_of_reachesIn + (initialInputLoopTM tapes) (initialFinalizeTM tapes) + hloopReach hloopHalt hfinalizeReach' + let loopTailDone := TM.phase2Wrap (initialInputLoopTM tapes) + (initialFinalizeTM tapes) finalizeDone + have hloopTailHalt : + (TM.seqTM (initialInputLoopTM tapes) + (initialFinalizeTM tapes)).halted loopTailDone := by + exact (TM.phase2Wrap_halted_iff (initialInputLoopTM tapes) + (initialFinalizeTM tapes) finalizeDone).mpr hfinalizeHalt + have hsetupInputTransition : + TM.transitionInput setupDone.input = setupDone.input := + TM.transitionInput_eq_self hsetupInputParked.read_ne_start + have hsetupWorkTransition : + (fun i => TM.transitionTape (setupDone.work i)) = setupDone.work := + funext fun i => TM.transitionTape_eq_self + (hsetupReady.parked i).read_ne_start + have hsetupOutputTransition : + TM.transitionTape setupDone.output = setupDone.output := + TM.transitionTape_eq_self hsetupOutputParked.read_ne_start + have hloopTailReach' : + (TM.seqTM (initialInputLoopTM tapes) + (initialFinalizeTM tapes)).reachesIn + (loopTime + 1 + (lengthTime + 1 + abiTime)) + { state := (TM.seqTM (initialInputLoopTM tapes) + (initialFinalizeTM tapes)).qstart + input := TM.transitionInput setupDone.input + work := fun i => TM.transitionTape (setupDone.work i) + output := TM.transitionTape setupDone.output } + loopTailDone := by + simpa only [hsetupInputTransition, hsetupWorkTransition, + hsetupOutputTransition] using! hloopTailReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (initialSetupTM tapes) + (TM.seqTM (initialInputLoopTM tapes) (initialFinalizeTM tapes)) + hsetupReach hsetupHalt hloopTailReach' + let finalCfg := TM.phase2Wrap (initialSetupTM tapes) + (TM.seqTM (initialInputLoopTM tapes) (initialFinalizeTM tapes)) + loopTailDone + refine ⟨finalCfg, + setupTime + 1 + (loopTime + 1 + (lengthTime + 1 + abiTime)), + ?_, hreach, ?_, ?_⟩ + Β· unfold programInitTime + omega + Β· change (programInitTM tapes).halted finalCfg + unfold programInitTM + exact (TM.phase2Wrap_halted_iff (initialSetupTM tapes) + (TM.seqTM (initialInputLoopTM tapes) (initialFinalizeTM tapes)) + loopTailDone).mpr hloopTailHalt + Β· refine ⟨?_, ?_, ?_⟩ + Β· change abiDone.input.HasBinarySuffix [] + rw [habiInput, hlengthInput] + exact hloopInput + Β· change abiDone.work = + programSnapshotWork tapes (programInitialSnapshot input) + exact habiWork + Β· change abiDone.output = TM.resetBinaryBlank + exact habiOutput.trans hlengthOutputBlank + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Initialization.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Initialization.lean new file mode 100644 index 0000000000..a28c1a39df --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Initialization.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Init.Internal + +/-! +# Sparse RAM public-input initialization + +The concrete initializer streams nonzero public-input bits into a canonical +sparse store, installs the optional length register, and produces the exact +clean work-tape image consumed by the reusable RAM program controller. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- The concrete initializer's sparse store is the streamed nonzero input +entries followed by the optional nonzero length register. -/ +theorem programInitialStore_eq_append (input : List Bool) : + programInitialStore input = + inputBitStoreFrom 1 input ++ + if input.length = 0 then [] else [(0, input.length)] := + programInitialStore_eq_append_internal input + +/-- The concrete initializer emits one entry per true input bit and one more +exactly when the input is nonempty. -/ +theorem programInitialStore_length (input : List Bool) : + (programInitialStore input).length = + inputTrueCount input + if input.length = 0 then 0 else 1 := + programInitialStore_length_internal input + +/-- The sparse store produced from public input is canonical. -/ +theorem programInitialStore_canonical (input : List Bool) : + Canonical (programInitialStore input) := + programInitialStore_canonical_internal input + +/-- The initializer's pure sparse snapshot represents the RAM public-input +configuration exactly. -/ +theorem programInitialSnapshot_represents (input : List Bool) : + (programInitialSnapshot input).Represents (RAM.initCfg input) := + programInitialSnapshot_represents_internal input + +/-- Complete public-input initialization reaches the exact sparse snapshot +image consumed by the reusable program loop. -/ +theorem programInitTM_hoareTime {n : β„•} + (tapes : ControlInstructionTapes n) (input : List Bool) : + (programInitTM tapes).HoareTime + (fun inp work out => + inp = Tape.init (input.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => + inp.HasBinarySuffix [] ∧ + work = programSnapshotWork tapes (programInitialSnapshot input) ∧ + out = TM.resetBinaryBlank) + (programInitTime tapes input) := + programInitTM_hoareTime_internal tapes input + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Internal.lean new file mode 100644 index 0000000000..d43220af27 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/Program/Internal.lean @@ -0,0 +1,1439 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Program.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.Instruction.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Loop + +/-! +# Sparse RAM program controller -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private theorem blank_parked : + TM.Parked ((Tape.init []).move Dir3.right) := by + refine ⟨by simp [Tape.move], ?_⟩ + intro j hj + simp [Tape.move, Tape.init, show j β‰  0 by omega] + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : TM.Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem programBinaryTape_hasBinaryString (bits : List Bool) : + (programBinaryTape bits).HasBinaryString bits := by + simpa only [programBinaryTape] using! + Tape.init_move_right_hasBinaryString bits + +private theorem programBinaryTape_hasBinaryNat (value : β„•) : + (programBinaryTape value.bits).HasBinaryNat value := by + simpa only [programBinaryTape] using! + Tape.init_move_right_hasBinaryNat value + +private theorem programBinaryTape_parked (bits : List Bool) : + TM.Parked (programBinaryTape bits) := by + refine ⟨by rw [(programBinaryTape_hasBinaryString bits).1], ?_⟩ + exact (programBinaryTape_hasBinaryString bits).hasBinaryContent.cells_ne_start + +private theorem programSnapshotWork_source + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) : + programSnapshotWork tapes snapshot tapes.liftedSource = + programBinaryTape (snapshot.store.flatMap Entry.encode) := by + have hsourceRemaining : tapes.liftedSource β‰  + tapes.lifted.data.update.remaining := + tapes.lifted.data.ne (by decide) + have hsourceResult : tapes.liftedSource β‰  + tapes.lifted.data.update.resultCount := + tapes.lifted.data.ne (by decide) + unfold programSnapshotWork + rw [Function.update_of_ne tapes.liftedPC_ne_source.symm, + Function.update_of_ne hsourceResult, + Function.update_of_ne hsourceRemaining, + Function.update_self] + +private theorem programSnapshotWork_remaining + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) : + programSnapshotWork tapes snapshot + tapes.lifted.data.update.remaining = + programBinaryTape snapshot.store.length.bits := by + have hremainingSource : tapes.lifted.data.update.remaining β‰  + tapes.liftedSource := tapes.lifted.data.ne (by decide) + have hremainingResult : tapes.lifted.data.update.remaining β‰  + tapes.lifted.data.update.resultCount := + tapes.lifted.data.ne (by decide) + have hremainingPC : tapes.lifted.data.update.remaining β‰  + tapes.liftedPC := tapes.lifted.data_ne_pc 9 + unfold programSnapshotWork + rw [Function.update_of_ne hremainingPC, + Function.update_of_ne hremainingResult, + Function.update_self] + +private theorem programSnapshotWork_resultCount + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) : + programSnapshotWork tapes snapshot + tapes.lifted.data.update.resultCount = + programBinaryTape snapshot.store.length.bits := by + have hresultPC : tapes.lifted.data.update.resultCount β‰  + tapes.liftedPC := tapes.lifted.data_ne_pc 12 + unfold programSnapshotWork + rw [Function.update_of_ne hresultPC, Function.update_self] + +private theorem programSnapshotWork_pc + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) : + programSnapshotWork tapes snapshot tapes.liftedPC = + programBinaryTape snapshot.pc.bits := by + simp [programSnapshotWork] + +private theorem programSnapshotWork_other + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) + (i : Fin (n + 1)) + (hsource : i β‰  tapes.liftedSource) + (hremaining : i β‰  tapes.lifted.data.update.remaining) + (hresult : i β‰  tapes.lifted.data.update.resultCount) + (hpc : i β‰  tapes.liftedPC) : + programSnapshotWork tapes snapshot i = TM.resetBinaryBlank := by + unfold programSnapshotWork + rw [Function.update_of_ne hpc, + Function.update_of_ne hresult, + Function.update_of_ne hremaining, + Function.update_of_ne hsource] + rfl + +/-- The snapshot's source and blank scratch slots initialize the entry scanner. -/ +private theorem programSnapshotWork_scanner + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) + (work : Fin (n + 1) β†’ Tape) + (hsource : work tapes.liftedSource = + programBinaryTape (snapshot.store.flatMap Entry.encode)) + (hdataBlank : βˆ€ (slot : Fin 18), slot β‰  0 β†’ slot β‰  9 β†’ slot β‰  12 β†’ + work (tapes.lifted.data.idx slot) = TM.resetBinaryBlank) + (hparked : βˆ€ i, TM.Parked (work i)) : + EntryScanReady tapes.lifted.data.lhsLookup.scan.entry + (snapshot.store.flatMap Entry.encode) [] work work := by + let entry := tapes.lifted.data.lhsLookup.scan.entry + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hblankString : TM.resetBinaryBlank.HasBinaryString [] := hblankNat.2 + have hblankPrefix : TM.resetBinaryBlank.HasBinaryPrefix [] := + ⟨by simpa using! hblankString.1, hblankString.2⟩ + have hblankStart : TM.resetBinaryBlank.cells 0 = Ξ“.start := hblankNat.1 + have hslotOther (slot : Fin 9) (hslot : slot β‰  0) : + work (entry.idx slot) = TM.resetBinaryBlank := by + fin_cases slot + Β· exact (hslot rfl).elim + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 1 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 2 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 3 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 4 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 5 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 6 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 7 (by decide) (by decide) (by decide) + Β· simpa [entry, BinaryInstructionTapes.lhsLookup, + BinaryInstructionTapes.lhsLookupSlot] using! + hdataBlank 8 (by decide) (by decide) (by decide) + refine + { source := by + change (work tapes.liftedSource).HasBinarySuffix _ + rw [hsource] + exact Tape.init_move_right_hasBinarySuffix _ + address := by + rw [show work entry.address = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.address] using! + hslotOther 1 (by decide)] + exact hblankPrefix + addressStart := by + rw [show work entry.address = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.address] using! + hslotOther 1 (by decide)] + exact hblankStart + value := by + rw [show work entry.value = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.value] using! + hslotOther 2 (by decide)] + exact hblankPrefix + valueStart := by + rw [show work entry.value = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.value] using! + hslotOther 2 (by decide)] + exact hblankStart + addressCounter := by + rw [show work entry.addressCounter = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.addressCounter] using! + hslotOther 3 (by decide)] + exact hblankNat + addressWidth := by + rw [show work entry.addressWidth = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.addressWidth] using! + hslotOther 4 (by decide)] + exact hblankNat + valueCounter := by + rw [show work entry.valueCounter = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.valueCounter] using! + hslotOther 5 (by decide)] + exact hblankNat + valueWidth := by + rw [show work entry.valueWidth = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.valueWidth] using! + hslotOther 6 (by decide)] + exact hblankNat + query := by + rw [show work entry.query = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.query] using! + hslotOther 7 (by decide)] + exact hblankString + queryStart := by + rw [show work entry.query = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.query] using! + hslotOther 7 (by decide)] + exact hblankStart + result := by + rw [show work entry.result = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.result] using! + hslotOther 8 (by decide)] + exact hblankPrefix + resultStart := by + rw [show work entry.result = TM.resetBinaryBlank by + simpa only [EntryMatchTapes.result] using! + hslotOther 8 (by decide)] + exact hblankStart + parked := hparked + frame := by intros; rfl } + +/-- The exact snapshot work image satisfies the complete reusable instruction +ABI whenever its sparse store is canonical. -/ +theorem programSnapshotWork_ready_internal + (tapes : ControlInstructionTapes n) (snapshot : Snapshot) + (hcanonical : Canonical snapshot.store) : + InstructionExecutionReady tapes snapshot.store snapshot.pc + (programSnapshotWork tapes snapshot) := by + let work := programSnapshotWork tapes snapshot + let entry := tapes.lifted.data.lhsLookup.scan.entry + change InstructionExecutionReady tapes snapshot.store snapshot.pc work + have hblankNat : TM.resetBinaryBlank.HasBinaryNat 0 := by + simpa [TM.resetBinaryBlank] using! Tape.init_move_right_hasBinaryNat 0 + have hsource : work tapes.liftedSource = + programBinaryTape (snapshot.store.flatMap Entry.encode) := by + exact programSnapshotWork_source tapes snapshot + have hremaining : work tapes.lifted.data.update.remaining = + programBinaryTape snapshot.store.length.bits := by + exact programSnapshotWork_remaining tapes snapshot + have hresultCount : work tapes.lifted.data.update.resultCount = + programBinaryTape snapshot.store.length.bits := by + exact programSnapshotWork_resultCount tapes snapshot + have hpc : work tapes.liftedPC = programBinaryTape snapshot.pc.bits := by + exact programSnapshotWork_pc tapes snapshot + have hother (i : Fin (n + 1)) + (hsourceIdx : i β‰  tapes.liftedSource) + (hremainingIdx : i β‰  tapes.lifted.data.update.remaining) + (hresultIdx : i β‰  tapes.lifted.data.update.resultCount) + (hpcIdx : i β‰  tapes.liftedPC) : + work i = TM.resetBinaryBlank := by + exact programSnapshotWork_other tapes snapshot i hsourceIdx + hremainingIdx hresultIdx hpcIdx + have hdataBlank (slot : Fin 18) (hsourceSlot : slot β‰  0) + (hremainingSlot : slot β‰  9) (hresultSlot : slot β‰  12) : + work (tapes.lifted.data.idx slot) = TM.resetBinaryBlank := by + exact hother _ (tapes.lifted.data.ne hsourceSlot) + (tapes.lifted.data.ne hremainingSlot) + (tapes.lifted.data.ne hresultSlot) + (tapes.lifted.data_ne_pc slot) + have hparked : βˆ€ i, TM.Parked (work i) := by + intro i + by_cases hsi : i = tapes.liftedSource + Β· subst i + rw [hsource] + exact programBinaryTape_parked _ + by_cases hri : i = tapes.lifted.data.update.remaining + Β· subst i + rw [hremaining] + exact programBinaryTape_parked _ + by_cases hci : i = tapes.lifted.data.update.resultCount + Β· subst i + rw [hresultCount] + exact programBinaryTape_parked _ + by_cases hpi : i = tapes.liftedPC + Β· subst i + rw [hpc] + exact programBinaryTape_parked _ + Β· rw [hother i hsi hri hci hpi] + exact blank_parked + have hscanner : EntryScanReady entry + (snapshot.store.flatMap Entry.encode) [] work work := + programSnapshotWork_scanner tapes snapshot work hsource hdataBlank hparked + have hlookup : EntryLookupStaticReady tapes.lifted.data.lhsLookup + snapshot.store work := by + refine + { scanner := by + change EntryScanReady entry + (snapshot.store.flatMap Entry.encode) [] work work + exact hscanner + sourceStart := by + change (work tapes.liftedSource).cells 0 = Ξ“.start + rw [hsource] + simp [programBinaryTape, Tape.move, Tape.init] + sourceHead := by + change (work tapes.liftedSource).head = 1 + rw [hsource] + exact (programBinaryTape_hasBinaryString _).1 + count := by + change (work tapes.lifted.data.update.remaining).HasBinaryNat _ + rw [hremaining] + exact programBinaryTape_hasBinaryNat _ + countSource := by + change (work tapes.lifted.data.update.resultCount).HasBinaryNat _ + rw [hresultCount] + exact programBinaryTape_hasBinaryNat _ + querySource := by + change (work (tapes.lifted.data.idx 15)).HasBinaryNat 0 + rw [hdataBlank 15 (by decide) (by decide) (by decide)] + exact hblankNat + destination := by + change (work (tapes.lifted.data.idx 13)).HasBinaryNat 0 + rw [hdataBlank 13 (by decide) (by decide) (by decide)] + exact hblankNat + copyScratch := by + change (work (tapes.lifted.data.idx 11)).HasBinaryNat 0 + rw [hdataBlank 11 (by decide) (by decide) (by decide)] + exact hblankNat } + refine + { canonical := hcanonical + control := + { lookup := hlookup + pc := by + change (work tapes.liftedPC).HasBinaryNat snapshot.pc + rw [hpc] + exact programBinaryTape_hasBinaryNat _ } + sourceContent := by + rw [hsource] + exact (programBinaryTape_hasBinaryString _).hasBinaryContent + rhs := by + change (work (tapes.lifted.data.idx 14)).HasBinaryNat 0 + rw [hdataBlank 14 (by decide) (by decide) (by decide)] + exact hblankNat + replacement := by + change (work (tapes.lifted.data.idx 10)).HasBinaryNat 0 + rw [hdataBlank 10 (by decide) (by decide) (by decide)] + exact hblankNat + tmp := by + change (work (tapes.lifted.data.idx 16)).HasBinaryNat 0 + rw [hdataBlank 16 (by decide) (by decide) (by decide)] + exact hblankNat + dbl := by + change (work (tapes.lifted.data.idx 17)).HasBinaryNat 0 + rw [hdataBlank 17 (by decide) (by decide) (by decide)] + exact hblankNat + buffer := by + rw [hother tapes.buffer tapes.liftedSource_ne_buffer.symm + (tapes.liftedData_ne_buffer 9).symm + (tapes.liftedData_ne_buffer 12).symm + tapes.liftedPC_ne_buffer.symm] + rfl } + +theorem registerVerdictOutput_cell_one_internal (value : β„•) : + (registerVerdictOutput value).cells 1 = + if value = 0 then Ξ“.zero else Ξ“.one := by + by_cases hzero : value = 0 <;> + simp [registerVerdictOutput, registerVerdictSymbol, hzero, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + +theorem registerVerdictTM_hoareTime_frame_internal + (idx : Fin n) (value : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) : + (registerVerdictTM idx).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = registerVerdictOutput value) + 1 := by + intro inp work out hpre + obtain ⟨rfl, rfl, rfl⟩ := hpre + have hinp := hinput.move_idle + have hworkEq : + (fun i => (work i).writeAndMove + (TM.readBackWrite (work i).read) + (TM.idleDir (work i).read)) = work := by + funext i + exact (hwork i).writeAndMove_readBack_idle + have hsymbol : + (if (work idx).read = Ξ“.blank then Ξ“w.zero else Ξ“w.one) = + registerVerdictSymbol value := by + rw [registerVerdictSymbol] + exact if_congr hvalue.read_eq_blank_iff rfl rfl + have hout : + ((Tape.init []).move Dir3.right).writeAndMove + (if (work idx).read = Ξ“.blank then Ξ“w.zero else Ξ“w.one).toΞ“ + (TM.idleDir ((Tape.init []).move Dir3.right).read) = + registerVerdictOutput value := by + rw [hsymbol] + rfl + let final : Complexity.Cfg n (registerVerdictTM idx).Q := + { state := .done + input := inp + work := work + output := registerVerdictOutput value } + have hstep : + (registerVerdictTM idx).step + { state := (registerVerdictTM idx).qstart + input := inp + work := work + output := (Tape.init []).move Dir3.right } = some final := by + simp only [TM.step, registerVerdictTM, reduceCtorEq, ↓reduceIte, final] + rw [hinp, hworkEq, hout] + exact ⟨final, 1, le_rfl, .step hstep .zero, rfl, rfl, rfl, rfl⟩ + +/-- Final sparse lookup and Boolean emission recover the RAM verdict register. -/ +theorem programOutputTM_hoareTime_internal + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programOutputTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + (programOutputTime tapes store) := by + let blank := (Tape.init []).move Dir3.right + have hlookup := entryLookupStaticTM_hoareTime_frame + tapes.lifted.data.lhsLookup store 0 initialWork inpβ‚€ blank + hready.control.lookup hinput blank_parked + let mid : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.lifted.data.lhsLookup store 0 + initialWork work ∧ + out = blank + have hverdict : (registerVerdictTM tapes.liftedLhs).HoareTime mid + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + 1 := by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hleaf := registerVerdictTM_hoareTime_frame_internal + tapes.liftedLhs (RegisterStore.read store 0) inpβ‚€ work + hresult.destination hinput hresult.parked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + _hfinalWork, hfinalOutput⟩ := + hleaf inp work out ⟨hinp, rfl, by simpa only [blank] using! hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, hfinalOutput⟩ + have hseq := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) hlookup + (by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hi : TM.transitionInput inp = inp := + TM.transitionInput_eq_self + (by simpa [hinp] using! hinput.read_ne_start) + have hw : (fun i => TM.transitionTape (work i)) = work := by + funext i + exact TM.transitionTape_eq_self (hresult.parked i).read_ne_start + have ho : TM.transitionTape out = out := + TM.transitionTape_eq_self + (by rw [hout]; exact blank_parked.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hresult, by simpa only [blank] using! hout⟩) + hverdict + simpa only [programOutputTM, programOutputTime, mid, blank] using! hseq + +theorem registerVerdictTM_hoareTime_haltOutput_internal + (idx : Fin n) (value : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) : + (registerVerdictTM idx).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = instructionHaltOutput .halt) + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = registerVerdictOutput value) + 1 := by + intro inp work out hpre + obtain ⟨rfl, rfl, rfl⟩ := hpre + have hinp := hinput.move_idle + have hworkEq : + (fun i => (work i).writeAndMove + (TM.readBackWrite (work i).read) + (TM.idleDir (work i).read)) = work := by + funext i + exact (hwork i).writeAndMove_readBack_idle + have hsymbol : + (if (work idx).read = Ξ“.blank then Ξ“w.zero else Ξ“w.one) = + registerVerdictSymbol value := by + rw [registerVerdictSymbol] + exact if_congr hvalue.read_eq_blank_iff rfl rfl + have hout : + (instructionHaltOutput .halt).writeAndMove + (if (work idx).read = Ξ“.blank then Ξ“w.zero else Ξ“w.one).toΞ“ + (TM.idleDir (instructionHaltOutput .halt).read) = + registerVerdictOutput value := by + rw [hsymbol] + simp [instructionHaltOutput, instructionHaltVerdict, + registerVerdictOutput, TM.idleDir, Tape.writeAndMove, Tape.move, + Tape.write, Tape.read, Tape.init] + let final : Complexity.Cfg n (registerVerdictTM idx).Q := + { state := .done + input := inp + work := work + output := registerVerdictOutput value } + have hstep : + (registerVerdictTM idx).step + { state := (registerVerdictTM idx).qstart + input := inp + work := work + output := instructionHaltOutput .halt } = some final := by + simp only [TM.step, registerVerdictTM, reduceCtorEq, ↓reduceIte, final] + rw [hinp, hworkEq, hout] + exact ⟨final, 1, le_rfl, .step hstep .zero, rfl, rfl, rfl, rfl⟩ + +/-- Final sparse lookup overwrites the loop's halt-test bit with the RAM +verdict, so the controller and extractor compose without an output reset. -/ +theorem programOutputTM_hoareTime_haltOutput_internal + (tapes : ControlInstructionTapes n) (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programOutputTM tapes).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = instructionHaltOutput .halt) + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + (programOutputTime tapes store) := by + let haltOut := instructionHaltOutput .halt + have hhaltOutParked : TM.Parked haltOut := by + refine ⟨?_, ?_⟩ + Β· simp [haltOut, instructionHaltOutput, instructionHaltVerdict, + TM.idleDir, Tape.writeAndMove, Tape.move, Tape.write, Tape.read, + Tape.init] + Β· intro j hj + by_cases hjone : j = 1 + Β· subst j + simp [haltOut, instructionHaltOutput, instructionHaltVerdict, + TM.idleDir, Tape.writeAndMove, Tape.move, Tape.write, Tape.read, + Tape.init] + Β· have hjzero : j β‰  0 := by omega + simp [haltOut, instructionHaltOutput, instructionHaltVerdict, + TM.idleDir, Tape.writeAndMove, Tape.move, Tape.write, Tape.read, + Tape.init, Function.update, hjone, hjzero] + have hlookup := entryLookupStaticTM_hoareTime_frame + tapes.lifted.data.lhsLookup store 0 initialWork inpβ‚€ haltOut + hready.control.lookup hinput hhaltOutParked + let mid : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ + EntryLookupStaticResult tapes.lifted.data.lhsLookup store 0 + initialWork work ∧ + out = haltOut + have hverdict : (registerVerdictTM tapes.liftedLhs).HoareTime mid + (fun inp _work out => + inp = inpβ‚€ ∧ + out = registerVerdictOutput (RegisterStore.read store 0)) + 1 := by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hleaf := registerVerdictTM_hoareTime_haltOutput_internal + tapes.liftedLhs (RegisterStore.read store 0) inpβ‚€ work + hresult.destination hinput hresult.parked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + _hfinalWork, hfinalOutput⟩ := + hleaf inp work out ⟨hinp, rfl, by simpa only [haltOut] using! hout⟩ + exact ⟨final, time, htime, hreach, hhalt, hfinalInput, hfinalOutput⟩ + have hseq := TM.seqTM_hoareTime + (entryLookupStaticTM tapes.lifted.data.lhsLookup 0) + (registerVerdictTM tapes.liftedLhs) hlookup + (by + rintro inp work out ⟨hinp, hresult, hout⟩ + have hi : TM.transitionInput inp = inp := + TM.transitionInput_eq_self + (by simpa [hinp] using! hinput.read_ne_start) + have hw : (fun i => TM.transitionTape (work i)) = work := by + funext i + exact TM.transitionTape_eq_self (hresult.parked i).read_ne_start + have ho : TM.transitionTape out = out := + TM.transitionTape_eq_self + (by rw [hout]; exact hhaltOutParked.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hresult, by simpa only [haltOut] using! hout⟩) + hverdict + simpa only [programOutputTM, programOutputTime, mid, haltOut] using! hseq + +theorem instructionHaltOutput_head_internal (instruction : Instr) : + (instructionHaltOutput instruction).head = 1 := by + cases instruction <;> + simp [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + +theorem instructionHaltOutput_cells_zero_internal (instruction : Instr) : + (instructionHaltOutput instruction).cells 0 = Ξ“.start := by + cases instruction <;> + simp [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + +theorem instructionHaltOutput_cells_ne_start_internal + (instruction : Instr) : + βˆ€ j, j β‰₯ 1 β†’ (instructionHaltOutput instruction).cells j β‰  Ξ“.start := by + intro j hj + by_cases h1 : j = 1 + Β· subst j + cases instruction <;> + simp [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + Β· cases instruction <;> + simp [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init, h1, + show j β‰  0 by omega] + +theorem instructionHaltOutput_cell_one_eq_one_iff_internal + (instruction : Instr) : + (instructionHaltOutput instruction).cells 1 = Ξ“.one ↔ + instruction = .halt := by + cases instruction <;> + simp [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + +theorem instructionHaltOutput_eq_blank_of_ne_halt_internal + {instruction : Instr} (h : instruction β‰  .halt) : + instructionHaltOutput instruction = + (Tape.init []).move Dir3.right := by + cases instruction <;> + simp_all [instructionHaltOutput, instructionHaltVerdict, TM.idleDir, + Tape.writeAndMove, Tape.move, Tape.write, Tape.read, Tape.init] + +private theorem phaseTransition_of_parked + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : TM.Parked inp) (hwork : βˆ€ i, TM.Parked (work i)) + (houtput : TM.Parked out) : + TM.transitionInput inp = inp ∧ + (fun i => TM.transitionTape (work i)) = work ∧ + TM.transitionTape out = out := + TM.phaseTransition_of_parked hinput hwork houtput + +/-- The loop's fixed three-step rewind/check tail preserves every tape exactly. -/ +theorem programLoop_rewind_check_internal (tmBody tmTest : TM n) + (c : Complexity.Cfg n (TM.LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl TM.LoopPhase.rewindOut)) + (hin : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (hhead : c.output.head = 1) + (hstart : c.output.cells 0 = Ξ“.start) + (hnoStart : βˆ€ j, 1 ≀ j β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (TM.loopTM tmBody tmTest).reachesIn 3 c c' ∧ + c'.state = (if c.output.cells 1 = Ξ“.one then + (Sum.inr (Sum.inl TM.LoopPhase.done) : + TM.LoopQ tmBody.Q tmTest.Q) + else Sum.inl tmBody.qstart) ∧ + c'.input = c.input ∧ c'.work = c.work ∧ c'.output = c.output := by + have hread₁ : c.output.read β‰  Ξ“.start := by + rw [Tape.read, hhead] + exact hnoStart 1 le_rfl + obtain ⟨c₁, hstep₁, hstate₁, hinput₁, hwork₁, hhead₁, hcellsβ‚βŸ© : + βˆƒ c₁, (TM.loopTM tmBody tmTest).step c = some c₁ ∧ + c₁.state = Sum.inr (Sum.inl TM.LoopPhase.rewindOut) ∧ + c₁.input = c.input ∧ c₁.work = c.work ∧ + c₁.output.head = 0 ∧ c₁.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hstate, TM.loopTM, hread₁] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· exact TM.transitionInput_eq_self hin + Β· exact funext fun i => TM.transitionTape_eq_self (hwork i) + Β· simp [Tape.writeAndMove, Tape.move, Tape.write_head, hhead] + Β· exact TM.tape_readBackWrite_preserves _ _ (Or.inr hread₁) + have hreadβ‚‚ : c₁.output.read = Ξ“.start := by + rw [Tape.read, hhead₁, hcells₁] + exact hstart + obtain ⟨cβ‚‚, hstepβ‚‚, hstateβ‚‚, hinputβ‚‚, hworkβ‚‚, hheadβ‚‚, hcellsβ‚‚βŸ© : + βˆƒ cβ‚‚, (TM.loopTM tmBody tmTest).step c₁ = some cβ‚‚ ∧ + cβ‚‚.state = Sum.inr (Sum.inl TM.LoopPhase.check) ∧ + cβ‚‚.input = c₁.input ∧ cβ‚‚.work = c₁.work ∧ + cβ‚‚.output.head = 1 ∧ cβ‚‚.output.cells = c₁.output.cells := by + simp only [TM.step, ↓reduceIte, hstate₁, TM.loopTM, hreadβ‚‚] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· exact TM.transitionInput_eq_self (by rw [hinput₁]; exact hin) + Β· refine funext fun i => TM.transitionTape_eq_self ?_ + rw [hwork₁] + exact hwork i + Β· simp [Tape.writeAndMove, Tape.move, Tape.write_head, hhead₁] + Β· show ((c₁.output.write (Ξ“w.blank).toΞ“).move Dir3.right).cells = + c₁.output.cells + rw [Tape.move_cells] + simp only [Tape.write, hhead₁, ↓reduceIte] + have houtputβ‚‚ : cβ‚‚.output = c.output := + Tape.ext (by rw [hheadβ‚‚, hhead]) + (by rw [hcellsβ‚‚, hcells₁]) + by_cases hone : c.output.cells 1 = Ξ“.one + Β· have hread₃ : cβ‚‚.output.read = Ξ“.one := by + rw [Tape.read, hheadβ‚‚, hcellsβ‚‚, hcells₁] + exact hone + obtain ⟨c₃, hstep₃, hstate₃, hinput₃, hwork₃, houtputβ‚ƒβŸ© : + βˆƒ c₃, (TM.loopTM tmBody tmTest).step cβ‚‚ = some c₃ ∧ + c₃.state = Sum.inr (Sum.inl TM.LoopPhase.done) ∧ + c₃.input = cβ‚‚.input ∧ c₃.work = cβ‚‚.work ∧ + c₃.output = cβ‚‚.output := by + simp only [TM.step, ↓reduceIte, hstateβ‚‚, TM.loopTM, hread₃] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + Β· exact TM.transitionInput_eq_self + (by rw [hinputβ‚‚, hinput₁]; exact hin) + Β· refine funext fun i => TM.transitionTape_eq_self ?_ + rw [hworkβ‚‚, hwork₁] + exact hwork i + Β· rw [← hread₃] + exact TM.transitionTape_eq_self (by rw [hread₃]; simp) + refine ⟨c₃, .step hstep₁ (.step hstepβ‚‚ (.step hstep₃ .zero)), + ?_, ?_, ?_, ?_⟩ + Β· rw [hstate₃, ite_eq_left hone] + Β· rw [hinput₃, hinputβ‚‚, hinput₁] + Β· rw [hwork₃, hworkβ‚‚, hwork₁] + Β· rw [houtput₃, houtputβ‚‚] + Β· have hread₃ : cβ‚‚.output.read β‰  Ξ“.one := by + rw [Tape.read, hheadβ‚‚, hcellsβ‚‚, hcells₁] + exact hone + have hread₃Start : cβ‚‚.output.read β‰  Ξ“.start := by + rw [Tape.read, hheadβ‚‚, hcellsβ‚‚, hcells₁] + exact hnoStart 1 le_rfl + obtain ⟨c₃, hstep₃, hstate₃, hinput₃, hwork₃, houtputβ‚ƒβŸ© : + βˆƒ c₃, (TM.loopTM tmBody tmTest).step cβ‚‚ = some c₃ ∧ + c₃.state = Sum.inl tmBody.qstart ∧ + c₃.input = cβ‚‚.input ∧ c₃.work = cβ‚‚.work ∧ + c₃.output = cβ‚‚.output := by + simp only [TM.step, ↓reduceIte, hstateβ‚‚, TM.loopTM, hread₃] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + Β· exact TM.transitionInput_eq_self + (by rw [hinputβ‚‚, hinput₁]; exact hin) + Β· refine funext fun i => TM.transitionTape_eq_self ?_ + rw [hworkβ‚‚, hwork₁] + exact hwork i + Β· exact TM.transitionTape_eq_self hread₃Start + refine ⟨c₃, .step hstep₁ (.step hstepβ‚‚ (.step hstep₃ .zero)), + ?_, ?_, ?_, ?_⟩ + Β· rw [hstate₃, ite_eq_right hone] + Β· rw [hinput₃, hinputβ‚‚, hinput₁] + Β· rw [hwork₃, hworkβ‚‚, hwork₁] + Β· rw [houtput₃, houtputβ‚‚] + +/-- The verdict leaf has a literal one-step frame. -/ +theorem instructionHaltVerdictTM_hoareTime_frame_internal + (instruction : Instr) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (hinput : TM.Parked inpβ‚€) (hwork : βˆ€ i, TM.Parked (workβ‚€ i)) : + (instructionHaltVerdictTM instruction).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = instructionHaltOutput instruction) + 1 := by + intro inp work out hpre + obtain ⟨rfl, rfl, rfl⟩ := hpre + have hinp := hinput.move_idle + have hworkEq : + (fun i => (work i).writeAndMove + (TM.readBackWrite (work i).read) + (TM.idleDir (work i).read)) = work := by + funext i + exact (hwork i).writeAndMove_readBack_idle + have hout : + ((Tape.init []).move Dir3.right).writeAndMove + (instructionHaltVerdict instruction).toΞ“ + (TM.idleDir ((Tape.init []).move Dir3.right).read) = + instructionHaltOutput instruction := rfl + let final : Complexity.Cfg n + (instructionHaltVerdictTM (n := n) instruction).Q := + { state := .done + input := inp + work := work + output := instructionHaltOutput instruction } + have hstep : + (instructionHaltVerdictTM instruction).step + { state := (instructionHaltVerdictTM instruction).qstart + input := inp + work := work + output := (Tape.init []).move Dir3.right } = some final := by + simp only [TM.step, instructionHaltVerdictTM, reduceCtorEq, + ↓reduceIte, final] + rw [hinp, hworkEq, hout] + exact ⟨final, 1, le_rfl, .step hstep .zero, rfl, rfl, rfl, rfl⟩ + +/-- An empty dispatch program resets its selector and emits the halt verdict. -/ +private theorem dispatchHaltEmpty_hoareTime_frame + (tapes : ControlInstructionTapes n) + (store : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : DispatchReady tapes store pcValue selector cleanWork workβ‚€) + (hinput : TM.Parked inpβ‚€) : + (dispatchHaltTM tapes ([] : Program)).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ + out = instructionHaltOutput + (selectedInstruction ([] : Program) selector)) + (dispatchHaltTime tapes ([] : Program) selector) := by + let blankTape := (Tape.init []).move Dir3.right + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hcleanLhs : cleanWork tapes.liftedLhs = blankTape := by + have hzero := hready.1.control.lookup.destination + change (cleanWork tapes.liftedLhs).HasBinaryNat 0 at hzero + simpa only [blankTape] using! + Tape.HasBinaryNat.eq_init_move_right hzero + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + rw [hready.2] + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat selector) + Β· simp only [Function.update_of_ne hi] + exact hready.1.control.lookup.scanner.parked i + have hreset := TM.resetBinaryWorkTM_hoareTime_frame tapes.liftedLhs + selector.bits 1 inpβ‚€ workβ‚€ ((Tape.init []).move Dir3.right) + hselector.2.hasBinaryContent hselector.1 + ⟨by rw [hselector.2.1], by rw [hselector.2.1]⟩ + hinput (fun i _ => hworkβ‚€Parked i) blank_parked + have hreset' : (TM.resetBinaryWorkTM tapes.liftedLhs).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ + out = (Tape.init []).move Dir3.right) + (TM.resetBinaryWorkTime 1 selector.bits.length) := by + apply hreset.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + refine ⟨hinp, ?_, hout⟩ + rw [hworkEq, hready.2, Function.update_idem] + change Function.update cleanWork tapes.liftedLhs blankTape = cleanWork + rw [← hcleanLhs, Function.update_eq_self] + Β· exact le_rfl + have hverdict := instructionHaltVerdictTM_hoareTime_frame_internal + (.halt : Instr) inpβ‚€ cleanWork hinput + hready.1.control.lookup.scanner.parked + have hseq := TM.seqTM_hoareTime + (TM.resetBinaryWorkTM tapes.liftedLhs) + (instructionHaltVerdictTM (.halt : Instr)) hreset' + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) + (by simpa [hworkEq] using! + hready.1.control.lookup.scanner.parked) + (by simpa [hout] using! blank_parked) + rw [hi, hw, ho] + exact ⟨hinp, hworkEq, hout⟩) + hverdict + simpa only [dispatchHaltTM, dispatchHaltTime, + selectedInstruction] using! hseq + +/-- The decrementing selector emits the verdict of the selected instruction +and restores its scratch tape to the clean ABI. -/ +theorem dispatchHaltTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue selector : β„•) + (cleanWork workβ‚€ : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : DispatchReady tapes store pcValue selector cleanWork workβ‚€) + (hinput : TM.Parked inpβ‚€) : + (dispatchHaltTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ + out = instructionHaltOutput + (selectedInstruction program selector)) + (dispatchHaltTime tapes program selector) := by + induction program generalizing selector workβ‚€ with + | nil => + exact dispatchHaltEmpty_hoareTime_frame tapes store pcValue selector + cleanWork workβ‚€ inpβ‚€ hready hinput + | cons instruction program ih => + let pre : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ work = workβ‚€ ∧ + out = (Tape.init []).move Dir3.right + let post : TM.TapePred (n + 1) := fun inp work out => + inp = inpβ‚€ ∧ work = cleanWork ∧ + out = instructionHaltOutput + (selectedInstruction (instruction :: program) selector) + let blankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector = 0 + let nonblankPre : TM.TapePred (n + 1) := fun inp work out => + pre inp work out ∧ selector β‰  0 + have hselector : (workβ‚€ tapes.liftedLhs).HasBinaryNat selector := by + rw [hready.2] + simp only [Function.update_self] + exact Tape.init_move_right_hasBinaryNat selector + have hworkβ‚€Parked : βˆ€ i, TM.Parked (workβ‚€ i) := by + intro i + rw [hready.2] + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat selector) + Β· simp only [Function.update_of_ne hi] + exact hready.1.control.lookup.scanner.parked i + have hblank : (instructionHaltVerdictTM instruction).HoareTime + blankPre post 1 := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hzero⟩ + subst selector + have hcleanLhs := Tape.HasBinaryNat.eq_init_move_right + hready.1.control.lookup.destination + change cleanWork tapes.liftedLhs = + (Tape.init []).move Dir3.right at hcleanLhs + have hworkClean : work = cleanWork := by + rw [hworkEq, hready.2] + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [Function.update_self] + exact hcleanLhs.symm + Β· simp only [Function.update_of_ne hi] + have hverdict := instructionHaltVerdictTM_hoareTime_frame_internal + instruction inpβ‚€ cleanWork hinput + hready.1.control.lookup.scanner.parked + obtain ⟨final, time, htime, hreach, hhalt, hfinalInput, + hfinalWork, hfinalOutput⟩ := + hverdict inp cleanWork out ⟨hinp, rfl, hout⟩ + refine ⟨final, time, htime, ?_, hhalt, hfinalInput, hfinalWork, ?_⟩ + Β· simpa [hworkClean] using! hreach + Β· simpa only [selectedInstruction] using! hfinalOutput + have hnonblank : + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchHaltTM tapes program)).HoareTime + nonblankPre post + (TM.binaryPredTime (selector - 1) + 1 + + dispatchHaltTime tapes program (selector - 1)) := by + rintro inp work out ⟨⟨hinp, hworkEq, hout⟩, hnonzero⟩ + have hsucc : selector = (selector - 1) + 1 := by omega + have hvalue : (work tapes.liftedLhs).HasBinaryNat + ((selector - 1) + 1) := by + rw [hworkEq] + rw [hsucc] at hselector + exact hselector + have hinpParked : TM.Parked inp := by simpa [hinp] using! hinput + have houtParked : TM.Parked out := by simpa [hout] using! blank_parked + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + simpa [hworkEq] using! hworkβ‚€Parked i + have hpred := TM.binaryPredTM_hoareTime_frame tapes.liftedLhs + (selector - 1) inp work out hvalue hinpParked.read_ne_start + (fun i _ => (hworkParked i).read_ne_start) + houtParked.read_ne_start + let nextWork := Function.update cleanWork tapes.liftedLhs + ((Tape.init ((selector - 1).bits.map Ξ“.ofBool)).move Dir3.right) + have hpred' : (TM.binaryPredTM tapes.liftedLhs).HoareTime + (fun inp' work' out' => + inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => + inp' = inp ∧ work' = nextWork ∧ out' = out) + (TM.binaryPredTime (selector - 1)) := by + apply hpred.consequence + Β· exact fun _ _ _ h => h + Β· rintro inp' work' out' ⟨hinp', hframe, hvalue', hout'⟩ + refine ⟨hinp', ?_, hout'⟩ + funext i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact Tape.HasBinaryNat.eq_init_move_right hvalue' + Β· simp only [nextWork, Function.update_of_ne hi] + rw [hframe i hi, hworkEq, hready.2, + Function.update_of_ne hi] + Β· exact le_rfl + have hnextReady : DispatchReady tapes store pcValue (selector - 1) + cleanWork nextWork := ⟨hready.1, rfl⟩ + have hrecursive := ih (selector - 1) nextWork hnextReady + have hrecursive' : (dispatchHaltTM tapes program).HoareTime + (fun inp' work' out' => + inp' = inp ∧ work' = nextWork ∧ out' = out) + post + (dispatchHaltTime tapes program (selector - 1)) := by + apply hrecursive.consequence + Β· rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + exact ⟨hinp'.trans hinp, hwork', hout'.trans hout⟩ + Β· rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + have hselected : + selectedInstruction (instruction :: program) selector = + selectedInstruction program (selector - 1) := by + rw [hsucc] + rfl + exact ⟨hinp', hwork', by simpa only [hselected] using! hout'⟩ + Β· exact le_rfl + have hseq := TM.seqTM_hoareTime (TM.binaryPredTM tapes.liftedLhs) + (dispatchHaltTM tapes program) hpred' + (by + rintro inp' work' out' ⟨hinp', hwork', hout'⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp') (work := work') (out := out') + (by simpa [hinp', hinp] using! hinput) + (by + intro i + rw [hwork'] + by_cases hidx : i = tapes.liftedLhs + Β· subst i + simp only [nextWork, Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat (selector - 1)) + Β· simp only [nextWork, Function.update_of_ne hidx] + exact hready.1.control.lookup.scanner.parked i) + (by simpa [hout', hout] using! blank_parked) + rw [hi, hw, ho] + exact ⟨hinp', hwork', hout'⟩) + hrecursive' + exact hseq inp work out ⟨rfl, rfl, rfl⟩ + have hdispatch := TM.branchWorkBlankTM_hoareTime tapes.liftedLhs + (instructionHaltVerdictTM instruction) + (TM.seqTM (TM.binaryPredTM tapes.liftedLhs) + (dispatchHaltTM tapes program)) + (pre := pre) (blankPre := blankPre) (nonblankPre := nonblankPre) + (blankPost := post) (nonblankPost := post) + (fun inp work out hpre => by + have hinpParked : TM.Parked inp := by + simpa [hpre.1] using! hinput + have houtParked : TM.Parked out := by + simpa [hpre.2.2] using! blank_parked + have hworkParked : βˆ€ i, TM.Parked (work i) := by + intro i + simpa [hpre.2.1] using! hworkβ‚€Parked i + exact ⟨hinpParked.read_ne_start, + fun i => (hworkParked i).read_ne_start, + houtParked.read_ne_start⟩) + (fun _ work _ hpre hread => + ⟨hpre, hselector.read_eq_blank_iff.mp + (by simpa [hpre.2.1] using! hread)⟩) + (fun _ work _ hpre hread => + ⟨hpre, fun hzero => hread (by + rw [hpre.2.1] + exact hselector.read_eq_blank_iff.mpr hzero)⟩) + hblank hnonblank + simpa only [dispatchHaltTM, dispatchHaltTime, pre, post] using! + hdispatch.consequence (fun _ _ _ h => h) + (fun _ _ _ h => h.elim id id) le_rfl + +/-- Copy the canonical PC, select its fixed-program instruction, and emit its +halt verdict while restoring the complete instruction ABI. -/ +theorem programHaltTM_hoareTime_frame_internal + (tapes : ControlInstructionTapes n) (program : Program) + (store : Store) (pcValue : β„•) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes store pcValue initialWork) + (hinput : TM.Parked inpβ‚€) : + (programHaltTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = instructionHaltOutput + (selectedInstruction program pcValue)) + (programHaltTime tapes program pcValue) := by + let selectorTape := + (Tape.init (pcValue.bits.map Ξ“.ofBool)).move Dir3.right + let selectorWork := + Function.update initialWork tapes.liftedLhs selectorTape + have hcopy := TM.binaryCopyIntoTM_hoareTime_frame tapes.liftedPC + tapes.liftedLhs tapes.liftedFound tapes.lifted.pc_ne_lhs + (tapes.lifted.pc_ne 11) (tapes.lifted.data.ne (by decide)) pcValue 0 + inpβ‚€ initialWork ((Tape.init []).move Dir3.right) hready.control.pc + hready.control.lookup.destination hready.control.lookup.copyScratch hinput + (fun i _ _ _ => hready.control.lookup.scanner.parked i) blank_parked + have hselectorReady : DispatchReady tapes store pcValue pcValue initialWork + selectorWork := by + exact ⟨hready, rfl⟩ + have hdispatch := dispatchHaltTM_hoareTime_frame_internal tapes program store + pcValue pcValue initialWork selectorWork inpβ‚€ hselectorReady hinput + have hselectorParked : βˆ€ i, TM.Parked (selectorWork i) := by + intro i + by_cases hi : i = tapes.liftedLhs + Β· subst i + simp only [selectorWork, Function.update_self] + exact hasBinaryNat_parked + (Tape.init_move_right_hasBinaryNat pcValue) + Β· simp only [selectorWork, Function.update_of_ne hi] + exact hready.control.lookup.scanner.parked i + have hseq := TM.seqTM_hoareTime + (TM.binaryCopyIntoTM tapes.liftedPC tapes.liftedLhs tapes.liftedFound) + (dispatchHaltTM tapes program) hcopy + (by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + obtain ⟨hi, hw, ho⟩ := phaseTransition_of_parked + (inp := inp) (work := work) (out := out) + (by simpa [hinp] using! hinput) + (by simpa [hworkEq, selectorWork, selectorTape] using! hselectorParked) + (by simpa [hout] using! blank_parked) + rw [hi, hw, ho] + exact ⟨hinp, by simpa [selectorWork, selectorTape] using! hworkEq, hout⟩) + hdispatch + simpa only [programHaltTM, programHaltTime, selectorWork, + selectorTape] using! hseq + +/-- One loop iteration realizes one pure sparse step and either halts on the +successor's `halt` instruction or returns to the body start with blank output. -/ +theorem programLoopTM_iteration_internal + (tapes : ControlInstructionTapes n) (program : Program) + (snapshot : Snapshot) (initialWork : Fin (n + 1) β†’ Tape) + (inpβ‚€ : Tape) + (hready : InstructionExecutionReady tapes snapshot.store snapshot.pc + initialWork) + (hinput : TM.Parked inpβ‚€) : + let next := snapshot.step program + βˆƒ (nextWork : Fin (n + 1) β†’ Tape) (time : β„•), + time ≀ programLoopIterationTime tapes program snapshot ∧ + InstructionExecutionReady tapes next.store next.pc nextWork ∧ + ((next.Halted program ∧ + (programLoopTM tapes program).reachesIn time + { state := (programLoopTM tapes program).qstart + input := inpβ‚€ + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := inpβ‚€ + work := nextWork + output := instructionHaltOutput (next.curInstr program) }) ∨ + (Β¬next.Halted program ∧ + (programLoopTM tapes program).reachesIn time + { state := (programLoopTM tapes program).qstart + input := inpβ‚€ + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := (programLoopTM tapes program).qstart + input := inpβ‚€ + work := nextWork + output := (Tape.init []).move Dir3.right })) := by + let next := snapshot.step program + let body := programStepTM tapes program + let test := programHaltTM tapes program + let blank := (Tape.init []).move Dir3.right + have hbody := programStepTM_hoareTime_frame tapes program snapshot.store + snapshot.pc initialWork inpβ‚€ hready hinput + obtain ⟨cbody, bodyTime, hbodyTime, hbodyReach, hbodyHalt, + hbodyInput, hnextReady, hbodyOutput⟩ := + hbody inpβ‚€ initialWork blank ⟨rfl, rfl, rfl⟩ + have hbodyInputParked : TM.Parked cbody.input := by + simpa [hbodyInput] using! hinput + have hbodyWorkParked : βˆ€ i, TM.Parked (cbody.work i) := by + exact hnextReady.control.lookup.scanner.parked + have hbodyOutputParked : TM.Parked cbody.output := by + simpa [hbodyOutput, blank] using! blank_parked + have hbodyLoop := TM.loopTM_body_simulation body test hbodyReach + have hbodyTransition : + (⟨test.qstart, TM.transitionInput cbody.input, + fun i => TM.transitionTape (cbody.work i), + TM.transitionTape cbody.output⟩ : Complexity.Cfg (n + 1) test.Q) = + ⟨test.qstart, inpβ‚€, cbody.work, blank⟩ := by + have hi : TM.transitionInput cbody.input = inpβ‚€ := by + rw [hbodyInput] + exact hinput.transitionInput_eq_self + have hw : (fun i => TM.transitionTape (cbody.work i)) = cbody.work := + funext fun i => (hbodyWorkParked i).transitionTape_eq_self + have ho : TM.transitionTape cbody.output = blank := by + rw [hbodyOutput] + exact blank_parked.transitionTape_eq_self + rw [hi, hw, ho] + have hbodyToTest := TM.loopTM_body_to_test body test hbodyHalt + rw [hbodyTransition] at hbodyToTest + have htest := programHaltTM_hoareTime_frame_internal tapes program + next.store next.pc cbody.work inpβ‚€ hnextReady hinput + obtain ⟨ctest, testTime, htestTime, htestReach, htestHalt, + htestInput, htestWork, htestOutput⟩ := + htest inpβ‚€ cbody.work blank ⟨rfl, rfl, rfl⟩ + have hselected : + selectedInstruction program next.pc = next.curInstr program := + selectedInstruction_eq_getElem?_getD program next.pc + have htestOutput' : + ctest.output = instructionHaltOutput (next.curInstr program) := by + simpa only [hselected] using! htestOutput + have htestInputParked : TM.Parked ctest.input := by + simpa [htestInput] using! hinput + have htestWorkParked : βˆ€ i, TM.Parked (ctest.work i) := by + simpa [htestWork] using! hbodyWorkParked + have htestOutputParked : TM.Parked ctest.output := by + refine ⟨?_, ?_⟩ + Β· rw [htestOutput', instructionHaltOutput_head_internal] + Β· rw [htestOutput'] + exact instructionHaltOutput_cells_ne_start_internal _ + have htestTransition : + (⟨(Sum.inr (Sum.inl TM.LoopPhase.rewindOut) : + TM.LoopQ body.Q test.Q), + TM.transitionInput ctest.input, + fun i => TM.transitionTape (ctest.work i), + TM.transitionTape ctest.output⟩ : + Complexity.Cfg (n + 1) (TM.LoopQ body.Q test.Q)) = + ⟨Sum.inr (Sum.inl TM.LoopPhase.rewindOut), inpβ‚€, + cbody.work, ctest.output⟩ := by + have hi : TM.transitionInput ctest.input = inpβ‚€ := by + rw [htestInput] + exact hinput.transitionInput_eq_self + have hw : (fun i => TM.transitionTape (ctest.work i)) = cbody.work := by + funext i + rw [htestWork] + exact (hbodyWorkParked i).transitionTape_eq_self + have ho : TM.transitionTape ctest.output = ctest.output := + htestOutputParked.transitionTape_eq_self + rw [hi, hw, ho] + have htestToRewind := + (TM.loopTM_test_to_rewind body test htestHalt).trans + (congrArg some htestTransition) + obtain ⟨ctail, htailReach, htailState, htailInput, htailWork, + htailOutput⟩ := programLoop_rewind_check_internal body test + ⟨Sum.inr (Sum.inl TM.LoopPhase.rewindOut), inpβ‚€, + cbody.work, ctest.output⟩ rfl hinput.read_ne_start + (fun i => (hbodyWorkParked i).read_ne_start) + (by rw [htestOutput', instructionHaltOutput_head_internal]) + (by rw [htestOutput', instructionHaltOutput_cells_zero_internal]) + (by rw [htestOutput']; exact + instructionHaltOutput_cells_ne_start_internal _) + have hreach := TM.reachesIn_trans _ + (TM.reachesIn_trans _ + (TM.reachesIn_trans _ + (TM.reachesIn_trans _ hbodyLoop (.step hbodyToTest .zero)) + (TM.loopTM_test_simulation body test htestReach)) + (.step htestToRewind .zero)) htailReach + have htime : bodyTime + 1 + testTime + 1 + 3 ≀ + programLoopIterationTime tapes program snapshot := by + dsimp only [next] at htestTime + simp only [programLoopIterationTime] + omega + refine ⟨cbody.work, bodyTime + 1 + testTime + 1 + 3, htime, + hnextReady, ?_⟩ + by_cases hhalted : next.Halted program + Β· left + refine ⟨hhalted, ?_⟩ + have hone : ctest.output.cells 1 = Ξ“.one := by + rw [htestOutput'] + exact instructionHaltOutput_cell_one_eq_one_iff_internal _ |>.2 hhalted + have htailDone : ctail.state = Sum.inr (Sum.inl TM.LoopPhase.done) := by + simpa [hone] using! htailState + have hcTail : ctail = + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := inpβ‚€ + work := cbody.work + output := instructionHaltOutput (next.curInstr program) } := by + cases ctail + apply Complexity.Cfg.ext + Β· exact htailDone + Β· exact htailInput + Β· exact htailWork + Β· exact htailOutput.trans htestOutput' + simpa only [programLoopTM, body, test, blank, hcTail] using! hreach + Β· right + refine ⟨hhalted, ?_⟩ + have hcur : next.curInstr program β‰  .halt := hhalted + have hblankOutput : ctest.output = blank := by + rw [htestOutput'] + simpa only [blank] using! + instructionHaltOutput_eq_blank_of_ne_halt_internal hcur + have hone : ctest.output.cells 1 β‰  Ξ“.one := by + rw [htestOutput'] + exact fun h => hhalted + (instructionHaltOutput_cell_one_eq_one_iff_internal _ |>.1 h) + have htailStart : ctail.state = Sum.inl body.qstart := by + simpa [hone] using! htailState + have hcTail : ctail = + { state := Sum.inl body.qstart + input := inpβ‚€ + work := cbody.work + output := blank } := by + cases ctail + apply Complexity.Cfg.ext + Β· exact htailStart + Β· exact htailInput + Β· exact htailWork + Β· exact htailOutput.trans hblankOutput + simpa only [programLoopTM, body, test, blank, hcTail] using! hreach + +theorem snapshot_step_eq_self_of_halted_internal + (program : Program) (snapshot : Snapshot) + (hhalted : snapshot.Halted program) : + snapshot.step program = snapshot := by + change snapshot.curInstr program = .halt at hhalted + rw [Snapshot.step, hhalted] + rfl + +theorem snapshot_run_halted_internal + (program : Program) (snapshot : Snapshot) + (hhalted : snapshot.Halted program) : + βˆ€ fuel, snapshot.run program fuel = snapshot + | 0 => rfl + | fuel + 1 => by + rw [Snapshot.run, ite_eq_left hhalted] + +/-- A halted fuel-bounded sparse run is realized by the fixed controller loop. +The extra iteration handles a snapshot that is already halted at fuel zero. -/ +theorem programLoopTM_hoareTime_run_internal + (tapes : ControlInstructionTapes n) (program : Program) : + βˆ€ (fuel : β„•) (snapshot : Snapshot) + (initialWork : Fin (n + 1) β†’ Tape) (inpβ‚€ : Tape), + InstructionExecutionReady tapes snapshot.store snapshot.pc initialWork β†’ + TM.Parked inpβ‚€ β†’ + (snapshot.run program fuel).Halted program β†’ + (programLoopTM tapes program).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ work = initialWork ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + let final := snapshot.run program fuel + inp = inpβ‚€ ∧ + InstructionExecutionReady tapes final.store final.pc work ∧ + out = instructionHaltOutput (final.curInstr program)) + (programLoopTime tapes program (fuel + 1) snapshot) := by + intro fuel + induction fuel with + | zero => + intro snapshot initialWork inpβ‚€ hready hinput hhalted + rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hsnapshotHalted : snapshot.Halted program := by + simpa [Snapshot.run] using! hhalted + have hstepSelf := snapshot_step_eq_self_of_halted_internal program + snapshot hsnapshotHalted + obtain ⟨nextWork, time, htime, hnextReady, hbranch⟩ := + programLoopTM_iteration_internal tapes program snapshot initialWork + inpβ‚€ hready hinput + rcases hbranch with ⟨hnextHalted, hreach⟩ | + ⟨hnextRunning, _⟩ + Β· have hready' : InstructionExecutionReady tapes snapshot.store + snapshot.pc nextWork := by + simpa only [hstepSelf] using! hnextReady + have hreach' : (programLoopTM tapes program).reachesIn time + { state := (programLoopTM tapes program).qstart + input := inpβ‚€ + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := inpβ‚€ + work := nextWork + output := instructionHaltOutput + (snapshot.curInstr program) } := by + simpa only [hstepSelf] using! hreach + refine ⟨_, time, ?_, hreach', rfl, rfl, ?_, ?_⟩ + Β· simpa [programLoopTime] using! htime + Β· simpa [Snapshot.run] using! hready' + Β· simp [Snapshot.run] + Β· exact (hnextRunning (by simpa only [hstepSelf] using! + hsnapshotHalted)).elim + | succ fuel ih => + intro snapshot initialWork inpβ‚€ hready hinput hhalted + by_cases hsnapshotHalted : snapshot.Halted program + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hstepSelf := snapshot_step_eq_self_of_halted_internal program + snapshot hsnapshotHalted + obtain ⟨nextWork, time, htime, hnextReady, hbranch⟩ := + programLoopTM_iteration_internal tapes program snapshot initialWork + inpβ‚€ hready hinput + rcases hbranch with ⟨_, hreach⟩ | ⟨hnextRunning, _⟩ + Β· have hfinal : snapshot.run program (fuel + 1) = snapshot := + snapshot_run_halted_internal program snapshot hsnapshotHalted _ + have hready' : InstructionExecutionReady tapes snapshot.store + snapshot.pc nextWork := by + simpa only [hstepSelf] using! hnextReady + have hreach' : (programLoopTM tapes program).reachesIn time + { state := (programLoopTM tapes program).qstart + input := inpβ‚€ + work := initialWork + output := (Tape.init []).move Dir3.right } + { state := Sum.inr (Sum.inl TM.LoopPhase.done) + input := inpβ‚€ + work := nextWork + output := instructionHaltOutput + (snapshot.curInstr program) } := by + simpa only [hstepSelf] using! hreach + refine ⟨_, time, ?_, hreach', rfl, rfl, ?_, ?_⟩ + Β· simp only [programLoopTime] + omega + Β· simpa only [hfinal] using! hready' + Β· simp only [hfinal] + Β· exact (hnextRunning (by simpa only [hstepSelf] using! + hsnapshotHalted)).elim + Β· have hrunHalted : + ((snapshot.step program).run program fuel).Halted program := by + simpa [Snapshot.run, hsnapshotHalted] using! hhalted + have hiter := programLoopTM_iteration_internal tapes program snapshot + initialWork inpβ‚€ hready hinput + obtain ⟨nextWork, time₁, htime₁, hnextReady, hbranch⟩ := hiter + rcases hbranch with ⟨hnextHalted, hreachβ‚βŸ© | + ⟨hnextRunning, hreachβ‚βŸ© + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hfinal : + (snapshot.step program).run program fuel = + snapshot.step program := + snapshot_run_halted_internal program (snapshot.step program) + hnextHalted fuel + refine ⟨_, time₁, ?_, hreach₁, rfl, rfl, ?_, ?_⟩ + Β· simp only [programLoopTime] + omega + Β· simpa [Snapshot.run, hsnapshotHalted, hfinal] using! hnextReady + Β· simp [Snapshot.run, hsnapshotHalted, hfinal] + Β· have hrecursive := ih (snapshot.step program) nextWork inpβ‚€ + hnextReady hinput hrunHalted + rintro inp work out ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + obtain ⟨cfinal, timeβ‚‚, htimeβ‚‚, hreachβ‚‚, hhaltβ‚‚, + hfinalInput, hfinalReady, hfinalOutput⟩ := + hrecursive inpβ‚€ nextWork ((Tape.init []).move Dir3.right) + ⟨rfl, rfl, rfl⟩ + refine ⟨cfinal, time₁ + timeβ‚‚, ?_, + TM.reachesIn_trans _ hreach₁ hreachβ‚‚, hhaltβ‚‚, + hfinalInput, ?_, ?_⟩ + Β· change time₁ + timeβ‚‚ ≀ + programLoopIterationTime tapes program snapshot + + programLoopTime tapes program (fuel + 1) + (snapshot.step program) + exact Nat.add_le_add htime₁ htimeβ‚‚ + Β· simpa [Snapshot.run, hsnapshotHalted] using! hfinalReady + Β· simpa [Snapshot.run, hsnapshotHalted] using! hfinalOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode.lean new file mode 100644 index 0000000000..eafafa27c0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.LinearInternal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs + +/-! +# RAM snapshot word-width decoder + +This module exposes the exact framed semantics of the first concrete snapshot +decoder phase. Starting on a self-delimiting word, `wordWidthTM` stops on its +zero separator and leaves the unary-prefix length as a canonical binary +natural on a separate work tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Rewind a decoded append-position target to cell one without changing its +binary contents or any framed tape. This converts `HasBinaryPrefix` into the +read-position convention `HasBinaryString` in at most `|bits| + 3` steps. -/ +theorem wordTargetRewind_reachesIn_frame {n : β„•} + (targetIdx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix bits) + (htargetStart : (workβ‚€ targetIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  targetIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start ∧ 1 ≀ (workβ‚€ i).head) + (houtput : outβ‚€.read β‰  Ξ“.start) (houtputHead : 1 ≀ outβ‚€.head) : + βˆƒ c' t, + t ≀ bits.length + 3 ∧ + (TM.rewindWorkTM targetIdx).reachesIn t + { state := (TM.rewindWorkTM targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (TM.rewindWorkTM targetIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work targetIdx).HasBinaryString bits ∧ + (βˆ€ i, i β‰  targetIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordTargetRewind_reachesIn_frame_internal targetIdx bits inpβ‚€ workβ‚€ outβ‚€ + htarget htargetStart hinput hother houtput houtputHead + +/-- Exact framed execution of unary-width decoding. The source begins at the +first prefix bit, the width counter begins at canonical zero, and all unrelated +tapes are preserved exactly. -/ +theorem wordWidthTM_reachesIn_frame {n : β„•} + (sourceIdx widthIdx : Fin n) (hindices : sourceIdx β‰  widthIdx) + (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordWidthTM sourceIdx widthIdx).reachesIn (wordWidthTime width) + { state := (wordWidthTM sourceIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordWidthTM sourceIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix (false :: payload) ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordWidthTM_reachesIn_frame_internal sourceIdx widthIdx hindices width + payload inpβ‚€ workβ‚€ outβ‚€ hsource hwidth hinput hother houtput + +/-- Unary-width decoding is safe for one-way-output composition. -/ +theorem wordWidthTM_isTransducer {n : β„•} (sourceIdx widthIdx : Fin n) : + (wordWidthTM sourceIdx widthIdx).IsTransducer := + wordWidthTM_isTransducer_internal sourceIdx widthIdx + +/-- Exact one-step framed execution of the payload-copy leaf. It consumes one +source bit, appends it to the target, and preserves every unrelated tape. -/ +theorem payloadBitTM_reachesIn_frame {n : β„•} + (sourceIdx targetIdx : Fin n) (hindices : sourceIdx β‰  targetIdx) + (bit : Bool) (suffix pre : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (bit :: suffix)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix pre) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (payloadBitTM sourceIdx targetIdx).reachesIn 1 + { state := (payloadBitTM sourceIdx targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (payloadBitTM sourceIdx targetIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix suffix ∧ + (c'.work targetIdx).HasBinaryPrefix (pre ++ [bit]) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + payloadBitTM_reachesIn_frame_internal sourceIdx targetIdx hindices bit + suffix pre inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother houtput + +/-- The one-bit payload copier never moves the output head left. -/ +theorem payloadBitTM_isTransducer {n : β„•} (sourceIdx targetIdx : Fin n) : + (payloadBitTM sourceIdx targetIdx).IsTransducer := + payloadBitTM_isTransducer_internal sourceIdx targetIdx + +/-- The separator phase consumes one zero and otherwise preserves the frame. -/ +theorem wordSeparatorTM_reachesIn_frame {n : β„•} + (sourceIdx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (false :: bits)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordSeparatorTM sourceIdx).reachesIn 1 + { state := (wordSeparatorTM sourceIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordSeparatorTM sourceIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix bits ∧ + (βˆ€ i, i β‰  sourceIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordSeparatorTM_reachesIn_frame_internal sourceIdx bits inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hother houtput + +/-- Exact framed execution of the bounded payload loop. The source begins on +the first payload bit, the target is an empty appendable prefix, the counter is +zero, and the preserved width tape equals the payload length. The machine +copies the complete payload and leaves the source at the next encoded word. -/ +theorem wordPayloadTM_reachesIn_frame {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidthLength : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat width) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (wordPayloadTime width) + { state := (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work counterIdx).HasBinaryNat width ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordPayloadTM_reachesIn_frame_internal sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width hwidthLength inpβ‚€ workβ‚€ outβ‚€ hsource htarget + hcounter hwidth hinput hother houtput + +/-- The bounded payload loop preserves one-way-output safety. -/ +theorem wordPayloadTM_isTransducer {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).IsTransducer := + wordPayloadTM_isTransducer_internal sourceIdx targetIdx counterIdx widthIdx + +/-- Exact end-to-end decoding of one self-delimiting width/payload layout. +The source is left at the next word and the target contains the complete +payload as an appendable binary prefix. -/ +theorem wordDecodeTM_reachesIn_frame {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidthLength : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: (payload ++ rest))) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (wordDecodeTime width) + { state := (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work counterIdx).HasBinaryNat width ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordDecodeTM_reachesIn_frame_internal sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width hwidthLength inpβ‚€ workβ‚€ outβ‚€ hsource htarget + hcounter hwidth hinput hother houtput + +/-- Coarse all-prefix space envelope for complete word decoding. Starting from +auxiliary-space budget `initialSpace`, no prefix of the exact decoder run can +use more than `initialSpace + wordDecodeTime width`; this follows from the +one-cell-per-transition head-growth bound and is independent of endpoint +correctness. -/ +theorem wordDecodeTM_prefix_withinAuxSpace {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (width inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + time start current) + (htime : time ≀ wordDecodeTime width) : + current.WithinAuxSpace inputLength (initialSpace + wordDecodeTime width) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- A canonical `WordCode.encode` prefix decodes to the natural's canonical +little-endian bit string and leaves the following encoded stream untouched. -/ +theorem wordDecodeTM_reachesIn_frame_encode {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (value : β„•) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (WordCode.encode value ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (wordDecodeTime (bitlen value)) + { state := (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix value.bits ∧ + (c'.work counterIdx).HasBinaryNat (bitlen value) ∧ + (c'.work widthIdx).HasBinaryNat (bitlen value) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + have hsource' : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate (bitlen value) true ++ + false :: (Nat.toBitsLE (bitlen value) value ++ rest)) := by + simpa [WordCode.encode, List.append_assoc] using hsource + obtain ⟨c', hreach, hhalt, hinput', hsource'', htarget', hcounter', + hwidth', hframe, houtput'⟩ := + wordDecodeTM_reachesIn_frame sourceIdx targetIdx counterIdx widthIdx + hdistinct (Nat.toBitsLE (bitlen value) value) rest (bitlen value) + (by simp) inpβ‚€ workβ‚€ outβ‚€ hsource' htarget hcounter hwidth hinput hother houtput + refine ⟨c', hreach, hhalt, hinput', hsource'', ?_, hcounter', hwidth', + hframe, houtput'⟩ + simpa [bitlen, Nat.toBitsLE_size] using htarget' + +/-- The existing checked decoder is quasi-linear in the decoded word width. +This tightens the former quadratic charging by retaining the bit-width of the +binary loop limit instead of replacing it by the limit's numeric value. -/ +theorem wordDecodeTime_le_size (width : β„•) : + wordDecodeTime width ≀ + 8 * (width + 1) * (width.size + 2) := + wordDecodeTime_le_size_internal width + +/-- Complete word decoding preserves one-way-output safety. -/ +theorem wordDecodeTM_isTransducer {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).IsTransducer := + wordDecodeTM_isTransducer_internal sourceIdx targetIdx counterIdx widthIdx + +/-! ## Linear unary-marker decoder -/ + +/-- Exact framed execution of the optimized decoder. It uses one unary marker +instead of a binary width/counter pair and takes exactly `3 * width + 3` +transitions. -/ +theorem wordDecodeLinearTM_reachesIn_frame {n : β„•} + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: (payload ++ rest))) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hmarker : (workβ‚€ markerIdx).HasBinaryPrefix []) + (hmarkerStart : (workβ‚€ markerIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (wordDecodeLinearTime width) + { state := (wordDecodeLinearTM sourceIdx targetIdx markerIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work markerIdx).HasBinaryPrefix (List.replicate width true) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  markerIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + wordDecodeLinearTM_reachesIn_frame_internal sourceIdx targetIdx markerIdx + hdistinct payload rest width hwidth inpβ‚€ workβ‚€ outβ‚€ hsource htarget + hmarker hmarkerStart hinput hreads houtput + +/-- The optimized decoder handles a canonical natural-number word in time +linear in the encoded word width. -/ +theorem wordDecodeLinearTM_reachesIn_frame_encode {n : β„•} + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (value : β„•) (rest : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (WordCode.encode value ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hmarker : (workβ‚€ markerIdx).HasBinaryPrefix []) + (hmarkerStart : (workβ‚€ markerIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (wordDecodeLinearTime (bitlen value)) + { state := (wordDecodeLinearTM sourceIdx targetIdx markerIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix value.bits ∧ + (c'.work markerIdx).HasBinaryPrefix + (List.replicate (bitlen value) true) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  markerIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + have hsource' : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate (bitlen value) true ++ + false :: (Nat.toBitsLE (bitlen value) value ++ rest)) := by + simpa [WordCode.encode, List.append_assoc] using hsource + obtain ⟨c', hreach, hhalt, hinput', hsource'', htarget', hmarker', + hframe, houtput'⟩ := + wordDecodeLinearTM_reachesIn_frame sourceIdx targetIdx markerIdx hdistinct + (Nat.toBitsLE (bitlen value) value) rest (bitlen value) (by simp) + inpβ‚€ workβ‚€ outβ‚€ hsource' htarget hmarker hmarkerStart hinput hreads houtput + refine ⟨c', hreach, hhalt, hinput', hsource'', ?_, hmarker', hframe, houtput'⟩ + simpa [bitlen, Nat.toBitsLE_size] using htarget' + +/-- The optimized decoder never moves the output head left. -/ +theorem wordDecodeLinearTM_isTransducer {n : β„•} + (sourceIdx targetIdx markerIdx : Fin n) : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).IsTransducer := + wordDecodeLinearTM_isTransducer_internal sourceIdx targetIdx markerIdx + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Defs.lean new file mode 100644 index 0000000000..744990fabd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Defs.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs + +/-! +# RAM snapshot word-width decoder β€” definitions + +`RAM.RegisterStore.Machine.wordWidthTM` is the first concrete Turing-machine +phase of the reverse RAM simulation. It scans the unary-width prefix of one +self-delimiting snapshot word and increments a canonical binary counter once +per `1`. The source head stops on the zero separator, ready for the payload +copy phase. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Scan the unary prefix on work tape `sourceIdx` and store its length in +canonical little-endian binary on work tape `widthIdx`. The two indices must +be distinct for the semantic theorem. -/ +def wordWidthTM {n : β„•} (sourceIdx widthIdx : Fin n) : TM n := + TM.forWorkOnesTM sourceIdx (TM.binarySuccTM widthIdx) + +/-- Exact transition count for decoding a unary prefix of length `width`. -/ +def wordWidthTime (width : β„•) : β„• := + TM.forWorkOnesLoopTime TM.binarySuccTime 0 width + +/-- Control states for copying one fixed-width payload bit. -/ +inductive PayloadBitPhase where + | copy + | done + deriving DecidableEq + +/-- `PayloadBitPhase` has exactly two states. -/ +instance instFintypePayloadBitPhase : Fintype PayloadBitPhase where + elems := {.copy, .done} + complete := fun phase => by cases phase <;> simp + +/-- Copy the bit under `sourceIdx` to the append position on `targetIdx`, +advancing both heads once. The semantic theorem assumes distinct indices and +that the source reads a bit. -/ +def payloadBitTM {n : β„•} (sourceIdx targetIdx : Fin n) : TM n where + Q := PayloadBitPhase + qstart := .copy + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .copy => + match wHeads sourceIdx with + | .zero | .one => + (.done, + fun i => + if i = targetIdx then Ξ“w.ofBool (wHeads sourceIdx = Ξ“.one) + else TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, + TM.idleDir iHead, + fun i => + if i = sourceIdx then Dir3.right + else if i = targetIdx then Dir3.right + else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .blank => TM.allReadBack .done iHead wHeads oHead + | .start => TM.allIdle .copy iHead wHeads oHead + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | copy => + cases hsource : wHeads sourceIdx with + | zero | one => + refine ⟨TM.idleDir_right_of_start, ?_, TM.idleDir_right_of_start⟩ + intro i hi + by_cases his : i = sourceIdx + Β· simp [his] + Β· by_cases hit : i = targetIdx + Β· simp [hit] + Β· simp [his, hit, TM.idleDir_right_of_start hi] + | blank => exact TM.rightOfStart_allReadBack iHead wHeads oHead + | start => exact TM.rightOfStart_allIdle iHead wHeads oHead + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Pairwise distinct work tapes used by the bounded payload decoder. -/ +structure PayloadLoopDistinct {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : Prop where + /-- Source and target tapes are distinct. -/ + source_target : sourceIdx β‰  targetIdx + /-- Source and loop-counter tapes are distinct. -/ + source_counter : sourceIdx β‰  counterIdx + /-- Source and width-limit tapes are distinct. -/ + source_width : sourceIdx β‰  widthIdx + /-- Target and loop-counter tapes are distinct. -/ + target_counter : targetIdx β‰  counterIdx + /-- Target and width-limit tapes are distinct. -/ + target_width : targetIdx β‰  widthIdx + /-- Counter and width-limit tapes are distinct. -/ + counter_width : counterIdx β‰  widthIdx + +/-- Copy exactly the number of payload bits recorded on `widthIdx`. +`counterIdx` is the canonical binary loop counter and `targetIdx` is an +appendable binary prefix. -/ +def wordPayloadTM {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : TM n := + TM.binaryForTM (payloadBitTM sourceIdx targetIdx) counterIdx widthIdx + +/-- Exact transition count for a complete fixed-width payload copy. -/ +def wordPayloadTime (width : β„•) : β„• := + TM.binaryForLoopTime (fun _ => 1) width 0 width + +/-- Control states for consuming the zero separator between a word's unary +width and fixed-width payload. -/ +inductive WordSeparatorPhase where + | skip + | done + deriving DecidableEq + +/-- `WordSeparatorPhase` has exactly two states. -/ +instance instFintypeWordSeparatorPhase : Fintype WordSeparatorPhase where + elems := {.skip, .done} + complete := fun phase => by cases phase <;> simp + +/-- Consume exactly one zero separator on the selected source work tape. -/ +def wordSeparatorTM {n : β„•} (sourceIdx : Fin n) : TM n where + Q := WordSeparatorPhase + qstart := .skip + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .skip => + if wHeads sourceIdx = Ξ“.zero then + (.done, fun i => TM.readBackWrite (wHeads i), TM.readBackWrite oHead, + TM.idleDir iHead, + fun i => if i = sourceIdx then Dir3.right else TM.idleDir (wHeads i), + TM.idleDir oHead) + else if wHeads sourceIdx = Ξ“.start then + TM.allIdle .skip iHead wHeads oHead + else + TM.allReadBack .done iHead wHeads oHead + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | skip => + dsimp only + split + Β· refine ⟨TM.idleDir_right_of_start, ?_, TM.idleDir_right_of_start⟩ + intro i hi + by_cases his : i = sourceIdx + Β· simp [his] + Β· simp [his, TM.idleDir_right_of_start hi] + Β· split + Β· exact TM.rightOfStart_allIdle iHead wHeads oHead + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Decode one complete self-delimiting word by scanning its unary width, +consuming the separator, and copying exactly that many payload bits. -/ +def wordDecodeTM {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : TM n := + TM.seqTM (wordWidthTM sourceIdx widthIdx) + (TM.seqTM (wordSeparatorTM sourceIdx) + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx)) + +/-- Exact transition count for complete word decoding, including both +sequential-composition seams. -/ +def wordDecodeTime (width : β„•) : β„• := + wordWidthTime width + 1 + (1 + 1 + wordPayloadTime width) + +/-! ## Linear unary-marker decoder -/ + +/-- Pairwise-distinct source, target, and unary-marker tapes for the optimized +word decoder. -/ +structure LinearWordDistinct {n : β„•} + (sourceIdx targetIdx markerIdx : Fin n) : Prop where + /-- Source and target tapes are distinct. -/ + source_target : sourceIdx β‰  targetIdx + /-- Source and marker tapes are distinct. -/ + source_marker : sourceIdx β‰  markerIdx + /-- Target and marker tapes are distinct. -/ + target_marker : targetIdx β‰  markerIdx + +/-- Control phases of the optimized self-delimiting word decoder. -/ +inductive LinearWordPhase where + /-- Copy the unary width prefix to the marker tape. -/ + | mark + /-- Rewind the copied unary marker while parking the payload cursor. -/ + | rewind + /-- Consume one marker and copy one payload bit per transition. -/ + | copy + /-- Halt after the marker is exhausted. -/ + | done + deriving DecidableEq + +/-- `LinearWordPhase` has exactly four states. -/ +instance instFintypeLinearWordPhase : Fintype LinearWordPhase where + elems := {.mark, .rewind, .copy, .done} + complete := fun phase => by cases phase <;> simp + +/-- Decode one unary-width/fixed-payload word in a single linear pass. + +The prefix pass copies one unary marker per width bit. After rewinding that +marker tape, the payload pass advances source, target, and marker together. +This removes the old payload loop's repeated full binary-counter comparison. +The marker tape starts as an empty appendable prefix and finishes containing +`width` ones with its head on the following blank. -/ +def wordDecodeLinearTM {n : β„•} + (sourceIdx targetIdx markerIdx : Fin n) : TM n where + Q := LinearWordPhase + qstart := .mark + qhalt := .done + Ξ΄ := fun phase iHead wHeads oHead => + match phase with + | .mark => + match wHeads sourceIdx with + | .one => + (.mark, + fun i => + if i = markerIdx then Ξ“w.one else TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, + TM.idleDir iHead, + fun i => + if i = sourceIdx then Dir3.right + else if i = markerIdx then Dir3.right + else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .zero => + (.rewind, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => + if i = sourceIdx then Dir3.right + else if i = markerIdx then TM.moveLeftDir (wHeads i) + else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .blank => TM.allReadBack .done iHead wHeads oHead + | .start => TM.allIdle .mark iHead wHeads oHead + | .rewind => + if wHeads markerIdx = Ξ“.start then + (.copy, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => + if i = markerIdx then Dir3.right else TM.idleDir (wHeads i), + TM.idleDir oHead) + else + (.rewind, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => + if i = markerIdx then TM.moveLeftDir (wHeads i) + else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .copy => + match wHeads markerIdx with + | .one => + match wHeads sourceIdx with + | .zero | .one => + (.copy, + fun i => + if i = targetIdx then + Ξ“w.ofBool (wHeads sourceIdx = Ξ“.one) + else TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => + if i = sourceIdx then Dir3.right + else if i = targetIdx then Dir3.right + else if i = markerIdx then Dir3.right + else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .blank | .start => TM.allReadBack .done iHead wHeads oHead + | .start => + (.copy, fun i => TM.readBackWrite (wHeads i), + TM.readBackWrite oHead, TM.idleDir iHead, + fun i => + if i = markerIdx then Dir3.right else TM.idleDir (wHeads i), + TM.idleDir oHead) + | .zero | .blank => TM.allReadBack .done iHead wHeads oHead + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro phase iHead wHeads oHead + cases phase with + | mark => + cases hsource : wHeads sourceIdx with + | one => + refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases his : i = sourceIdx + Β· simp [his] + Β· by_cases him : i = markerIdx + Β· simp [him] + Β· simp [his, him, TM.idleDir_right_of_start hi] + | zero => + refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases his : i = sourceIdx + Β· simp [his] + Β· by_cases him : i = markerIdx + Β· subst i + simp [his, TM.moveLeftDir_right_of_start hi] + Β· simp [his, him, TM.idleDir_right_of_start hi] + | blank => exact TM.rightOfStart_allReadBack iHead wHeads oHead + | start => exact TM.rightOfStart_allIdle iHead wHeads oHead + | rewind => + dsimp only + split + Β· refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases him : i = markerIdx + Β· simp [him] + Β· simp [him, TM.idleDir_right_of_start hi] + Β· refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases him : i = markerIdx + Β· subst i + simpa only [ite_eq_left] using TM.moveLeftDir_right_of_start hi + Β· simp [him, TM.idleDir_right_of_start hi] + | copy => + cases hmarker : wHeads markerIdx with + | one => + cases hsource : wHeads sourceIdx with + | zero | one => + refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases his : i = sourceIdx + Β· simp [his] + Β· by_cases hit : i = targetIdx + Β· simp [hit] + Β· by_cases him : i = markerIdx + Β· simp [him] + Β· simp [his, hit, him, TM.idleDir_right_of_start hi] + | blank | start => exact TM.rightOfStart_allReadBack iHead wHeads oHead + | start => + refine ⟨TM.idleDir_right_of_start, ?_, + TM.idleDir_right_of_start⟩ + intro i hi + by_cases him : i = markerIdx + Β· simp [him] + Β· simp [him, TM.idleDir_right_of_start hi] + | zero | blank => exact TM.rightOfStart_allReadBack iHead wHeads oHead + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Exact transition count of the optimized decoder on a well-formed width +`width` word. -/ +def wordDecodeLinearTime (width : β„•) : β„• := + 3 * width + 3 + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Internal.lean new file mode 100644 index 0000000000..62df264e7e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/Internal.lean @@ -0,0 +1,1527 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Loop +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.Linarith.Frontend +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific + +/-! +# RAM snapshot word-width decoder β€” proof internals + +The proof constructs the exact scanner, successor-body, and loopback frames +needed by `TM.ForWorkOnesLoopSpec`. The only changed tapes are the source +cursor and the canonical binary width counter. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +theorem wordTargetRewind_reachesIn_frame_internal {n : β„•} + (targetIdx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix bits) + (htargetStart : (workβ‚€ targetIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  targetIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start ∧ 1 ≀ (workβ‚€ i).head) + (houtput : outβ‚€.read β‰  Ξ“.start) (houtputHead : 1 ≀ outβ‚€.head) : + βˆƒ c' t, + t ≀ bits.length + 3 ∧ + (TM.rewindWorkTM targetIdx).reachesIn t + { state := (TM.rewindWorkTM targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (TM.rewindWorkTM targetIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work targetIdx).HasBinaryString bits ∧ + (βˆ€ i, i β‰  targetIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let Frame : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + (work targetIdx).HasBinaryContent bits ∧ + (βˆ€ i, i β‰  targetIdx β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + have hrewind := TM.rewindWorkTM_hoareTime_frame targetIdx (bits.length + 1) + (P := Frame) (by + intro inp work out inp' work' out' hframe htargetCells htargetHead + hotherWork hinputEq houtputCells houtputHeadEq + rcases hframe with ⟨hframeInput, hframeTarget, hframeOther, hframeOutput⟩ + refine ⟨hinputEq.trans hframeInput, ?_, ?_, ?_⟩ + Β· simpa only [Tape.HasBinaryContent, htargetCells] using hframeTarget + Β· intro i hi + exact (hotherWork i hi).trans (hframeOther i hi) + Β· exact (Tape.ext houtputHeadEq houtputCells).trans hframeOutput) + obtain ⟨c', t, htime, hreach, hhalt, hhead, hframe⟩ := + hrewind inpβ‚€ workβ‚€ outβ‚€ (by + refine ⟨htargetStart, Tape.cells_ne_start_of_hasBinaryPrefix htarget, + ?_, hinput, houtput, houtputHead, hother, rfl, htarget.2, + (fun _ _ => rfl), rfl⟩ + rw [htarget.1]) + rcases hframe with ⟨hfinalInput, hfinalTarget, hfinalOther, hfinalOutput⟩ + exact ⟨c', t, by omega, hreach, hhalt, hfinalInput, + hfinalTarget.hasBinaryString hhead, hfinalOther, hfinalOutput⟩ + +private def advanceRight (tape : Tape) : β„• β†’ Tape + | 0 => tape + | steps + 1 => (advanceRight tape steps).move Dir3.right + +private def binaryNatTape (value : β„•) : Tape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + +private def wordWidthWork (sourceIdx widthIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) (sourceSteps value : β„•) : Fin n β†’ Tape := + Function.update + (Function.update workβ‚€ sourceIdx (advanceRight (workβ‚€ sourceIdx) sourceSteps)) + widthIdx (binaryNatTape value) + +private def scanCfg (sourceIdx widthIdx : Fin n) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (wordWidthTM sourceIdx widthIdx).Q := + { state := .inl .scan + input := inpβ‚€ + work := wordWidthWork sourceIdx widthIdx workβ‚€ value value + output := outβ‚€ } + +private def bodyStartCfg (sourceIdx widthIdx : Fin n) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (TM.binarySuccTM widthIdx).Q := + { state := (TM.binarySuccTM widthIdx).qstart + input := inpβ‚€ + work := wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) value + output := outβ‚€ } + +private def bodyDoneCfg (sourceIdx widthIdx : Fin n) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (TM.binarySuccTM widthIdx).Q := + { state := (TM.binarySuccTM widthIdx).qhalt + input := inpβ‚€ + work := wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) (value + 1) + output := outβ‚€ } + +private def doneCfg (sourceIdx widthIdx : Fin n) (width : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : + Cfg n (wordWidthTM sourceIdx widthIdx).Q := + { state := .inl .done + input := inpβ‚€ + work := wordWidthWork sourceIdx widthIdx workβ‚€ width width + output := outβ‚€ } + +private theorem advanceRight_add (tape : Tape) (first second : β„•) : + advanceRight tape (first + second) = + advanceRight (advanceRight tape first) second := by + induction second with + | zero => simp [advanceRight] + | succ second ih => + simpa [advanceRight, Nat.add_assoc] using + congrArg (fun t => t.move Dir3.right) ih + +private theorem advanceRight_hasBinarySuffix_append (tape : Tape) + (pre suffix : List Bool) + (h : tape.HasBinarySuffix (pre ++ suffix)) : + (advanceRight tape pre.length).HasBinarySuffix suffix := by + induction pre generalizing tape with + | nil => simpa [advanceRight] using h + | cons bit pre ih => + have hmove : (tape.move Dir3.right).HasBinarySuffix (pre ++ suffix) := + h.move_right_cons + have htail := ih (tape := tape.move Dir3.right) hmove + change (advanceRight tape (pre.length + 1)).HasBinarySuffix suffix + rw [Nat.add_comm pre.length 1, advanceRight_add tape 1 pre.length] + simpa [advanceRight] using htail + +private theorem replicate_split (width value : β„•) (hvalue : value ≀ width) : + List.replicate width true = + List.replicate value true ++ List.replicate (width - value) true := by + rw [← List.replicate_add] + congr + omega + +private theorem source_suffix (sourceIdx : Fin n) (workβ‚€ : Fin n β†’ Tape) + (width value : β„•) (payload : List Bool) (hvalue : value ≀ width) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) : + (advanceRight (workβ‚€ sourceIdx) value).HasBinarySuffix + (List.replicate (width - value) true ++ false :: payload) := by + have hsplit : + List.replicate width true ++ false :: payload = + List.replicate value true ++ + (List.replicate (width - value) true ++ false :: payload) := by + rw [replicate_split width value hvalue, List.append_assoc] + rw [hsplit] at hsource + simpa using advanceRight_hasBinarySuffix_append + (workβ‚€ sourceIdx) (List.replicate value true) + (List.replicate (width - value) true ++ false :: payload) hsource + +private theorem source_read_one (sourceIdx : Fin n) (workβ‚€ : Fin n β†’ Tape) + (width value : β„•) (payload : List Bool) (hvalue : value < width) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) : + (advanceRight (workβ‚€ sourceIdx) value).read = Ξ“.one := by + have hsuffix := source_suffix sourceIdx workβ‚€ width value payload + (Nat.le_of_lt hvalue) hsource + have hpositive : 0 < width - value := by omega + have hshape : List.replicate (width - value) true = + true :: List.replicate (width - value - 1) true := by + cases hremaining : width - value with + | zero => omega + | succ remaining => + simp [List.replicate_succ] + rw [hshape, List.cons_append] at hsuffix + exact hsuffix.read_cons + +private theorem source_final_suffix (sourceIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) (width : β„•) (payload : List Bool) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) : + (advanceRight (workβ‚€ sourceIdx) width).HasBinarySuffix + (false :: payload) := by + simpa using source_suffix sourceIdx workβ‚€ width width payload le_rfl hsource + +private theorem binaryNatTape_hasBinaryNat (value : β„•) : + (binaryNatTape value).HasBinaryNat value := + Tape.init_move_right_hasBinaryNat value + +private theorem wordWidthWork_source (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (workβ‚€ : Fin n β†’ Tape) + (sourceSteps value : β„•) : + wordWidthWork sourceIdx widthIdx workβ‚€ sourceSteps value sourceIdx = + advanceRight (workβ‚€ sourceIdx) sourceSteps := by + simp [wordWidthWork, hindices] + +private theorem wordWidthWork_width (sourceIdx widthIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) (sourceSteps value : β„•) : + wordWidthWork sourceIdx widthIdx workβ‚€ sourceSteps value widthIdx = + binaryNatTape value := by + simp [wordWidthWork] + +private theorem wordWidthWork_other (sourceIdx widthIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) (sourceSteps value : β„•) (i : Fin n) + (hsourceIdx : i β‰  sourceIdx) (hwidthIdx : i β‰  widthIdx) : + wordWidthWork sourceIdx widthIdx workβ‚€ sourceSteps value i = workβ‚€ i := by + simp [wordWidthWork, hsourceIdx, hwidthIdx] + +private theorem wordWidthWork_read_ne_start (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (workβ‚€ : Fin n β†’ Tape) + (sourceSteps value : β„•) (suffix : List Bool) + (hsource : (advanceRight (workβ‚€ sourceIdx) sourceSteps).HasBinarySuffix suffix) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) : + βˆ€ i, (wordWidthWork sourceIdx widthIdx workβ‚€ sourceSteps value i).read β‰  + Ξ“.start := by + intro i + by_cases hiSource : i = sourceIdx + Β· subst i + rw [wordWidthWork_source sourceIdx widthIdx hindices] + exact hsource.read_ne_start + Β· by_cases hiWidth : i = widthIdx + Β· subst i + rw [wordWidthWork_width] + exact Tape.init_ofBool_move_right_read_ne_start value.bits + Β· rw [wordWidthWork_other sourceIdx widthIdx workβ‚€ sourceSteps value i + hiSource hiWidth] + exact hother i hiSource hiWidth + +private theorem scan_step (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (wordWidthTM sourceIdx widthIdx).step + (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) = + some (TM.forWorkOnesBodyWrap sourceIdx (TM.binarySuccTM widthIdx) + (bodyStartCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value)) := by + have hsuffix := source_suffix sourceIdx workβ‚€ width value payload + (Nat.le_of_lt hvalue) hsource + have hone := source_read_one sourceIdx workβ‚€ width value payload hvalue hsource + have hstep := TM.forWorkOnesTM_step_scan_one_internal sourceIdx + (TM.binarySuccTM widthIdx) + (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) rfl + (by + change + (wordWidthWork sourceIdx widthIdx workβ‚€ value value sourceIdx).read = Ξ“.one + rw [wordWidthWork_source sourceIdx widthIdx hindices] + exact hone) + hinput + (wordWidthWork_read_ne_start sourceIdx widthIdx hindices workβ‚€ value value + (List.replicate (width - value) true ++ false :: payload) hsuffix hother) + houtput + change + (TM.forWorkOnesTM sourceIdx (TM.binarySuccTM widthIdx)).step + (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) = _ + rw [hstep] + congr 2 + funext i + by_cases hi : i = sourceIdx + Β· subst i + simp [bodyStartCfg, scanCfg, wordWidthWork, + hindices, advanceRight] + Β· by_cases hiWidth : i = widthIdx + Β· subst i + simp [bodyStartCfg, scanCfg, wordWidthWork, hi] + Β· simp [bodyStartCfg, scanCfg, wordWidthWork, hi, hiWidth] + +private theorem body_run (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (TM.binarySuccTM widthIdx).reachesIn (TM.binarySuccTime value) + (bodyStartCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) + (bodyDoneCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) := by + have hsuffix := source_suffix sourceIdx workβ‚€ width (value + 1) payload + (by omega) hsource + let work := wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) value + obtain ⟨c', hreach, hhalt, hinput', hwork, hvalue', houtput'⟩ := + TM.binarySuccTM_reachesIn_frame widthIdx value inpβ‚€ work outβ‚€ + (by + change (wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) value + widthIdx).HasBinaryNat value + rw [wordWidthWork_width] + exact binaryNatTape_hasBinaryNat value) + hinput + (by + intro i hi + exact wordWidthWork_read_ne_start sourceIdx widthIdx hindices workβ‚€ + (value + 1) value + (List.replicate (width - (value + 1)) true ++ false :: payload) + hsuffix hother i) + houtput + have hc' : c' = bodyDoneCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value := by + refine Cfg.ext hhalt hinput' ?_ houtput' + funext i + by_cases hi : i = widthIdx + Β· subst i + change c'.work widthIdx = + wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) (value + 1) widthIdx + rw [wordWidthWork_width] + exact hvalue'.eq_init_move_right + Β· change c'.work i = + wordWidthWork sourceIdx widthIdx workβ‚€ (value + 1) (value + 1) i + rw [hwork i hi] + dsimp [work] + by_cases his : i = sourceIdx + Β· subst i + rw [wordWidthWork_source sourceIdx widthIdx hindices, + wordWidthWork_source sourceIdx widthIdx hindices] + Β· rw [wordWidthWork_other sourceIdx widthIdx workβ‚€ (value + 1) value i + his hi, + wordWidthWork_other sourceIdx widthIdx workβ‚€ (value + 1) (value + 1) i + his hi] + rw [← hc'] + simpa [bodyStartCfg, work] using hreach + +private theorem loopback_step (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (wordWidthTM sourceIdx widthIdx).step + (TM.forWorkOnesBodyWrap sourceIdx (TM.binarySuccTM widthIdx) + (bodyDoneCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value)) = + some (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ (value + 1)) := by + have hsuffix := source_suffix sourceIdx workβ‚€ width (value + 1) payload + (by omega) hsource + have hstep := TM.forWorkOnesTM_step_body_halt_internal sourceIdx + (TM.binarySuccTM widthIdx) + (bodyDoneCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) rfl hinput + (wordWidthWork_read_ne_start sourceIdx widthIdx hindices workβ‚€ + (value + 1) (value + 1) + (List.replicate (width - (value + 1)) true ++ false :: payload) + hsuffix hother) + houtput + simpa [wordWidthTM, bodyDoneCfg, scanCfg, TM.forWorkOnesBodyWrap] using hstep + +private theorem stop_step (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (wordWidthTM sourceIdx widthIdx).step + (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ width) = + some (doneCfg sourceIdx widthIdx width inpβ‚€ workβ‚€ outβ‚€) := by + have hsuffix := source_final_suffix sourceIdx workβ‚€ width payload hsource + have hstep := TM.forWorkOnesTM_step_scan_zero_internal sourceIdx + (TM.binarySuccTM widthIdx) + (scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ width) rfl + (by + change + (wordWidthWork sourceIdx widthIdx workβ‚€ width width sourceIdx).read = Ξ“.zero + rw [wordWidthWork_source sourceIdx widthIdx hindices] + exact hsuffix.read_cons) + hinput + (wordWidthWork_read_ne_start sourceIdx widthIdx hindices workβ‚€ width width + (false :: payload) hsuffix hother) + houtput + simpa [wordWidthTM, scanCfg, doneCfg] using hstep + +private def loopSpec (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + TM.ForWorkOnesLoopSpec sourceIdx (TM.binarySuccTM widthIdx) + TM.binarySuccTime width where + scanCfg := scanCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ + bodyStartCfg := fun value => + TM.forWorkOnesBodyWrap sourceIdx (TM.binarySuccTM widthIdx) + (bodyStartCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) + bodyDoneCfg := fun value => + TM.forWorkOnesBodyWrap sourceIdx (TM.binarySuccTM widthIdx) + (bodyDoneCfg sourceIdx widthIdx inpβ‚€ workβ‚€ outβ‚€ value) + doneCfg := doneCfg sourceIdx widthIdx width inpβ‚€ workβ‚€ outβ‚€ + scanStep := scan_step sourceIdx widthIdx hindices width payload inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hother houtput + bodyRun := fun value hvalue => + TM.forWorkOnesTM_body_reachesIn_internal sourceIdx (TM.binarySuccTM widthIdx) + (body_run sourceIdx widthIdx hindices width payload inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hother houtput value hvalue) + loopbackStep := loopback_step sourceIdx widthIdx hindices width payload inpβ‚€ workβ‚€ + outβ‚€ hsource hinput hother houtput + stopStep := stop_step sourceIdx widthIdx hindices width payload inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hother houtput + +private theorem initial_work (sourceIdx widthIdx : Fin n) + (hindices : sourceIdx β‰  widthIdx) (workβ‚€ : Fin n β†’ Tape) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) : + wordWidthWork sourceIdx widthIdx workβ‚€ 0 0 = workβ‚€ := by + funext i + by_cases hiWidth : i = widthIdx + Β· subst i + rw [wordWidthWork_width] + exact (hwidth.eq_init_move_right).symm + Β· by_cases hiSource : i = sourceIdx + Β· subst i + rw [wordWidthWork_source sourceIdx widthIdx hindices] + rfl + Β· exact wordWidthWork_other sourceIdx widthIdx workβ‚€ 0 0 i hiSource hiWidth + +private def payloadBitWork (sourceIdx targetIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) (bit : Bool) : Fin n β†’ Tape := + fun i => + if i = sourceIdx then (workβ‚€ i).move Dir3.right + else if i = targetIdx then + (workβ‚€ i).writeAndMove (Ξ“w.ofBool bit) Dir3.right + else workβ‚€ i + +private theorem payloadBitTM_step (sourceIdx targetIdx : Fin n) + (hindices : sourceIdx β‰  targetIdx) (bit : Bool) {suffix : List Bool} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (bit :: suffix)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hwork : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (payloadBitTM sourceIdx targetIdx).step + { state := (payloadBitTM sourceIdx targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = + some + { state := (payloadBitTM sourceIdx targetIdx).qhalt + input := inpβ‚€ + work := payloadBitWork sourceIdx targetIdx workβ‚€ bit + output := outβ‚€ } := by + have hread := hsource.read_cons + rw [TM.step, ite_eq_right (by simp [payloadBitTM])] + cases bit <;> + simp only [payloadBitTM, hread, Ξ“.ofBool, reduceCtorEq] + all_goals + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· dsimp only + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only + funext i + by_cases his : i = sourceIdx + Β· subst i + simpa [payloadBitWork, hindices] using + TM.writeAndMove_readBack (workβ‚€ sourceIdx) (hwork sourceIdx) Dir3.right + Β· by_cases hit : i = targetIdx + Β· subst i + simp [payloadBitWork, his] + Β· simpa [payloadBitWork, his, hit, TM.idleDir, hwork i, Tape.move] using + TM.writeAndMove_readBack (workβ‚€ i) (hwork i) Dir3.stay + Β· dsimp only + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack outβ‚€ houtput Dir3.stay + +theorem payloadBitTM_reachesIn_frame_internal {n : β„•} + (sourceIdx targetIdx : Fin n) (hindices : sourceIdx β‰  targetIdx) + (bit : Bool) (suffix pre : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (bit :: suffix)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix pre) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (payloadBitTM sourceIdx targetIdx).reachesIn 1 + { state := (payloadBitTM sourceIdx targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (payloadBitTM sourceIdx targetIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix suffix ∧ + (c'.work targetIdx).HasBinaryPrefix (pre ++ [bit]) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let work' := payloadBitWork sourceIdx targetIdx workβ‚€ bit + have hwork : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hsource.read_ne_start + Β· by_cases hit : i = targetIdx + Β· subst i + rw [htarget.read_blank] + decide + Β· exact hother i his hit + have hstep : + (payloadBitTM sourceIdx targetIdx).step + { state := (payloadBitTM sourceIdx targetIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = + some + { state := (payloadBitTM sourceIdx targetIdx).qhalt + input := inpβ‚€ + work := work' + output := outβ‚€ } := by + apply payloadBitTM_step sourceIdx targetIdx hindices bit inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hwork houtput + refine ⟨({ state := (payloadBitTM sourceIdx targetIdx).qhalt + input := inpβ‚€ + work := work' + output := outβ‚€ } : Cfg n (payloadBitTM sourceIdx targetIdx).Q), + .step hstep .zero, rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· change (payloadBitWork sourceIdx targetIdx workβ‚€ bit sourceIdx).HasBinarySuffix suffix + simp [payloadBitWork] + exact hsource.move_right_cons + Β· change (payloadBitWork sourceIdx targetIdx workβ‚€ bit targetIdx).HasBinaryPrefix + (pre ++ [bit]) + simp [payloadBitWork, Ne.symm hindices] + cases bit with + | false => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit (t := workβ‚€ targetIdx) false htarget + | true => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit (t := workβ‚€ targetIdx) true htarget + Β· intro i his hit + change payloadBitWork sourceIdx targetIdx workβ‚€ bit i = workβ‚€ i + simp [payloadBitWork, his, hit] + +private def wordSeparatorWork (sourceIdx : Fin n) + (workβ‚€ : Fin n β†’ Tape) : Fin n β†’ Tape := + Function.update workβ‚€ sourceIdx ((workβ‚€ sourceIdx).move Dir3.right) + +private theorem wordSeparatorTM_step (sourceIdx : Fin n) + (bits : List Bool) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (false :: bits)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hwork : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (wordSeparatorTM sourceIdx).step + { state := (wordSeparatorTM sourceIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = + some + { state := (wordSeparatorTM sourceIdx).qhalt + input := inpβ‚€ + work := wordSeparatorWork sourceIdx workβ‚€ + output := outβ‚€ } := by + have hread := hsource.read_cons + have hzero : (workβ‚€ sourceIdx).read = Ξ“.zero := by + simpa [Ξ“.ofBool] using hread + rw [TM.step, ite_eq_right (by simp [wordSeparatorTM])] + simp only [wordSeparatorTM, hzero, ↓reduceIte] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· dsimp only + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only + funext i + by_cases his : i = sourceIdx + Β· subst i + simpa [wordSeparatorWork] using + TM.writeAndMove_readBack (workβ‚€ sourceIdx) (hwork sourceIdx) Dir3.right + Β· simpa [wordSeparatorWork, his, TM.idleDir, hwork i, Tape.move] using + TM.writeAndMove_readBack (workβ‚€ i) (hwork i) Dir3.stay + Β· dsimp only + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack outβ‚€ houtput Dir3.stay + +theorem wordSeparatorTM_reachesIn_frame_internal {n : β„•} + (sourceIdx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (false :: bits)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordSeparatorTM sourceIdx).reachesIn 1 + { state := (wordSeparatorTM sourceIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordSeparatorTM sourceIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix bits ∧ + (βˆ€ i, i β‰  sourceIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + have hwork : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hsource.read_ne_start + Β· exact hother i his + let c' : Cfg n (wordSeparatorTM sourceIdx).Q := + { state := (wordSeparatorTM sourceIdx).qhalt + input := inpβ‚€ + work := wordSeparatorWork sourceIdx workβ‚€ + output := outβ‚€ } + have hstep := wordSeparatorTM_step sourceIdx bits inpβ‚€ workβ‚€ outβ‚€ hsource + hinput hwork houtput + refine ⟨c', .step hstep .zero, rfl, rfl, ?_, ?_, rfl⟩ + Β· change (wordSeparatorWork sourceIdx workβ‚€ sourceIdx).HasBinarySuffix bits + simp [wordSeparatorWork] + exact hsource.move_right_cons + Β· intro i his + change wordSeparatorWork sourceIdx workβ‚€ i = workβ‚€ i + simp [wordSeparatorWork, his] + +private def appendPayload (tape : Tape) : List Bool β†’ Tape + | [] => tape + | bit :: bits => + appendPayload (tape.writeAndMove (Ξ“w.ofBool bit) Dir3.right) bits + +private theorem appendPayload_append (tape : Tape) (first second : List Bool) : + appendPayload tape (first ++ second) = + appendPayload (appendPayload tape first) second := by + induction first generalizing tape with + | nil => rfl + | cons bit bits ih => + simp only [List.cons_append, appendPayload] + exact ih _ + +private theorem appendPayload_hasBinaryPrefix (tape : Tape) + (pre bits : List Bool) (hpre : tape.HasBinaryPrefix pre) : + (appendPayload tape bits).HasBinaryPrefix (pre ++ bits) := by + induction bits generalizing tape pre with + | nil => simpa [appendPayload] + | cons bit bits ih => + have hbit : + (tape.writeAndMove (Ξ“w.ofBool bit) Dir3.right).HasBinaryPrefix + (pre ++ [bit]) := by + cases bit with + | false => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit (t := tape) false hpre + | true => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit (t := tape) true hpre + simpa [appendPayload, List.append_assoc] using + ih (tape.writeAndMove (Ξ“w.ofBool bit) Dir3.right) (pre ++ [bit]) hbit + +private theorem appendPayload_take_succ (tape : Tape) (bits : List Bool) + (value : β„•) (hvalue : value < bits.length) : + appendPayload tape (bits.take (value + 1)) = + (appendPayload tape (bits.take value)).writeAndMove + (Ξ“w.ofBool bits[value]) Dir3.right := by + rw [List.take_succ_eq_append_getElem hvalue, appendPayload_append] + rfl + +private def payloadLoopWork (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) : Fin n β†’ Tape := + fun i => + if i = sourceIdx then advanceRight (workβ‚€ i) copied + else if i = targetIdx then appendPayload (workβ‚€ i) (payload.take copied) + else if i = counterIdx then binaryNatTape counterValue + else if i = widthIdx then binaryNatTape width + else workβ‚€ i + +private theorem payloadLoopWork_source + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + copied counterValue sourceIdx = advanceRight (workβ‚€ sourceIdx) copied := by + simp [payloadLoopWork] + +private theorem payloadLoopWork_target + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + copied counterValue targetIdx = + appendPayload (workβ‚€ targetIdx) (payload.take copied) := by + simp [payloadLoopWork, Ne.symm hdistinct.source_target] + +private theorem payloadLoopWork_counter + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + copied counterValue counterIdx = binaryNatTape counterValue := by + simp [payloadLoopWork, Ne.symm hdistinct.source_counter, + Ne.symm hdistinct.target_counter] + +private theorem payloadLoopWork_width + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + copied counterValue widthIdx = binaryNatTape width := by + simp [payloadLoopWork, Ne.symm hdistinct.source_width, + Ne.symm hdistinct.target_width, Ne.symm hdistinct.counter_width] + +private theorem payloadLoopWork_other + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) (i : Fin n) + (his : i β‰  sourceIdx) (hit : i β‰  targetIdx) + (hic : i β‰  counterIdx) (hiw : i β‰  widthIdx) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + copied counterValue i = workβ‚€ i := by + simp [payloadLoopWork, his, hit, hic, hiw] + +private theorem payloadSource_suffix (sourceIdx : Fin n) + (payload rest : List Bool) (workβ‚€ : Fin n β†’ Tape) (value : β„•) + (hvalue : value ≀ payload.length) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) : + (advanceRight (workβ‚€ sourceIdx) value).HasBinarySuffix + (payload.drop value ++ rest) := by + have hsplit : payload ++ rest = + payload.take value ++ (payload.drop value ++ rest) := by + rw [← List.append_assoc, List.take_append_drop] + rw [hsplit] at hsource + have h := advanceRight_hasBinarySuffix_append (workβ‚€ sourceIdx) + (payload.take value) (payload.drop value ++ rest) hsource + simpa [List.length_take, Nat.min_eq_left hvalue] using h + +private theorem payloadTarget_prefix (targetIdx : Fin n) + (payload : List Bool) (workβ‚€ : Fin n β†’ Tape) (value : β„•) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) : + (appendPayload (workβ‚€ targetIdx) (payload.take value)).HasBinaryPrefix + (payload.take value) := by + simpa using appendPayload_hasBinaryPrefix (workβ‚€ targetIdx) [] + (payload.take value) htarget + +private theorem payloadLoopWork_read_ne_start + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) (hcopied : copied ≀ payload.length) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) : + βˆ€ i, (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ copied counterValue i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + rw [payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx] + exact (payloadSource_suffix sourceIdx payload rest workβ‚€ copied hcopied hsource).read_ne_start + Β· by_cases hit : i = targetIdx + Β· subst i + rw [payloadLoopWork_target sourceIdx targetIdx counterIdx widthIdx hdistinct] + rw [(payloadTarget_prefix targetIdx payload workβ‚€ copied htarget).read_blank] + decide + Β· by_cases hic : i = counterIdx + Β· subst i + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact Tape.init_ofBool_move_right_read_ne_start counterValue.bits + Β· by_cases hiw : i = widthIdx + Β· subst i + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact Tape.init_ofBool_move_right_read_ne_start width.bits + Β· rw [payloadLoopWork_other sourceIdx targetIdx counterIdx widthIdx payload + width workβ‚€ copied counterValue i his hit hic hiw] + exact hother i his hit hic hiw + +private def payloadScanCfg + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).Q := + { state := .inl (.scan true) + input := inpβ‚€ + work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ value value + output := outβ‚€ } + +private def payloadIterationStartCfg + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).Q := + { state := .inr + (TM.binaryForIterationTM (payloadBitTM sourceIdx targetIdx) counterIdx).qstart + input := inpβ‚€ + work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ value value + output := outβ‚€ } + +private def payloadIterationDoneCfg + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (value : β„•) : + Cfg n (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).Q := + { state := .inr + (TM.binaryForIterationTM (payloadBitTM sourceIdx targetIdx) counterIdx).qhalt + input := inpβ‚€ + work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ (value + 1) (value + 1) + output := outβ‚€ } + +private def payloadDoneCfg + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (payload : List Bool) (width : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : + Cfg n (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).Q := + { state := .inl .done + input := inpβ‚€ + work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width + output := outβ‚€ } + +private theorem payloadBitWork_eq_next + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (copied counterValue : β„•) (hcopied : copied < payload.length) : + payloadBitWork sourceIdx targetIdx + (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ copied counterValue) payload[copied] = + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ (copied + 1) counterValue := by + funext i + by_cases his : i = sourceIdx + Β· subst i + simp only [payloadBitWork, ↓reduceIte] + rw [payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx, + payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx] + rfl + Β· by_cases hit : i = targetIdx + Β· subst i + simp only [payloadBitWork, his, ↓reduceIte] + rw [payloadLoopWork_target sourceIdx targetIdx counterIdx widthIdx hdistinct, + payloadLoopWork_target sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact (appendPayload_take_succ (workβ‚€ targetIdx) payload copied hcopied).symm + Β· by_cases hic : i = counterIdx + Β· subst i + simp only [payloadBitWork, his, hit, ↓reduceIte] + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct, + payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + Β· by_cases hiw : i = widthIdx + Β· subst i + simp only [payloadBitWork, his, hit, ↓reduceIte] + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct, + payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + Β· simp only [payloadBitWork, his, hit, ↓reduceIte] + rw [payloadLoopWork_other sourceIdx targetIdx counterIdx widthIdx payload + width workβ‚€ copied counterValue i his hit hic hiw, + payloadLoopWork_other sourceIdx targetIdx counterIdx widthIdx payload + width workβ‚€ (copied + 1) counterValue i his hit hic hiw] + +private theorem payloadTestRun + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (TM.binaryForCompareTime width) + (payloadScanCfg sourceIdx targetIdx counterIdx widthIdx payload width inpβ‚€ + workβ‚€ outβ‚€ value) + (payloadIterationStartCfg sourceIdx targetIdx counterIdx widthIdx payload + width inpβ‚€ workβ‚€ outβ‚€ value) := by + let work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ value value + have hwork := payloadLoopWork_read_ne_start sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width workβ‚€ value value (by omega) hsource htarget hother + have hrun := TM.binaryForTM_compare_reachesIn_frame_of_lt_internal + (payloadBitTM sourceIdx targetIdx) counterIdx widthIdx hdistinct.counter_width + value width hvalue inpβ‚€ work outβ‚€ + (by + dsimp only [work] + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat value) + (by + dsimp only [work] + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat width) + hinput + (by + intro i _ _ + exact hwork i) + houtput + simpa [wordPayloadTM, payloadScanCfg, payloadIterationStartCfg, work] using hrun + +private theorem payloadDoneRun + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (TM.binaryForCompareTime width) + (payloadScanCfg sourceIdx targetIdx counterIdx widthIdx payload width inpβ‚€ + workβ‚€ outβ‚€ width) + (payloadDoneCfg sourceIdx targetIdx counterIdx widthIdx payload width inpβ‚€ + workβ‚€ outβ‚€) := by + let work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width + have hwork := payloadLoopWork_read_ne_start sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width workβ‚€ width width (by omega) hsource htarget hother + have hrun := TM.binaryForTM_compare_reachesIn_frame_of_eq_internal + (payloadBitTM sourceIdx targetIdx) counterIdx widthIdx hdistinct.counter_width + width inpβ‚€ work outβ‚€ + (by + dsimp only [work] + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat width) + (by + dsimp only [work] + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat width) + hinput + (by + intro i _ _ + exact hwork i) + houtput + simpa [wordPayloadTM, payloadScanCfg, payloadDoneCfg, work] using hrun + +private theorem payloadIterationRun + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (TM.binaryForIterationTime (fun _ => 1) value) + (payloadIterationStartCfg sourceIdx targetIdx counterIdx widthIdx payload + width inpβ‚€ workβ‚€ outβ‚€ value) + (payloadIterationDoneCfg sourceIdx targetIdx counterIdx widthIdx payload + width inpβ‚€ workβ‚€ outβ‚€ value) := by + let body := payloadBitTM sourceIdx targetIdx + let beforeWork := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx + payload width workβ‚€ value value + let afterBodyWork := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx + payload width workβ‚€ (value + 1) value + let afterWork := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx + payload width workβ‚€ (value + 1) (value + 1) + have hvaluePayload : value < payload.length := by omega + have hsourceAt := payloadSource_suffix sourceIdx payload rest workβ‚€ value + (Nat.le_of_lt hvaluePayload) hsource + have hsourceShape : payload.drop value ++ rest = + payload[value] :: (payload.drop (value + 1) ++ rest) := by + rw [← List.cons_append, List.getElem_cons_drop hvaluePayload] + rw [hsourceShape] at hsourceAt + have hworkBefore := payloadLoopWork_read_ne_start sourceIdx targetIdx counterIdx + widthIdx hdistinct payload rest width workβ‚€ value value + (Nat.le_of_lt hvaluePayload) hsource htarget hother + have hbodyStep := payloadBitTM_step sourceIdx targetIdx hdistinct.source_target + payload[value] inpβ‚€ beforeWork outβ‚€ + (by + dsimp only [beforeWork] + rw [payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx] + exact hsourceAt) + hinput hworkBefore houtput + have hbodyWork : payloadBitWork sourceIdx targetIdx beforeWork payload[value] = + afterBodyWork := by + dsimp only [beforeWork, afterBodyWork] + exact payloadBitWork_eq_next sourceIdx targetIdx counterIdx widthIdx hdistinct + payload width workβ‚€ value value hvaluePayload + have hbodyReach : body.reachesIn 1 + { state := body.qstart + input := inpβ‚€ + work := beforeWork + output := outβ‚€ } + { state := body.qhalt + input := inpβ‚€ + work := afterBodyWork + output := outβ‚€ } := by + apply TM.reachesIn.step + Β· simpa [body, hbodyWork] using hbodyStep + Β· exact .zero + have hworkAfterBody := payloadLoopWork_read_ne_start sourceIdx targetIdx counterIdx + widthIdx hdistinct payload rest width workβ‚€ (value + 1) value + (by omega) hsource htarget hother + obtain ⟨succDone, hsuccReach, hsuccHalt, hsuccInput, hsuccOther, + hsuccCounter, hsuccOutput⟩ := + TM.binarySuccTM_reachesIn_frame counterIdx value inpβ‚€ afterBodyWork outβ‚€ + (by + dsimp only [afterBodyWork] + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat value) + hinput (fun i _ => hworkAfterBody i) houtput + have hsuccDoneEq : succDone = + { state := (TM.binarySuccTM counterIdx).qhalt + input := inpβ‚€ + work := afterWork + output := outβ‚€ } := by + refine Cfg.ext hsuccHalt hsuccInput ?_ hsuccOutput + funext i + by_cases hic : i = counterIdx + Β· subst i + change succDone.work counterIdx = afterWork counterIdx + dsimp only [afterWork] + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact hsuccCounter.eq_init_move_right + Β· rw [hsuccOther i hic] + dsimp only [afterBodyWork, afterWork] + simp [payloadLoopWork, hic] + have htransitionInput : TM.transitionInput inpβ‚€ = inpβ‚€ := + TM.transitionInput_eq_self hinput + have htransitionWork : (fun i => TM.transitionTape (afterBodyWork i)) = + afterBodyWork := by + funext i + exact TM.transitionTape_eq_self (hworkAfterBody i) + have htransitionOutput : TM.transitionTape outβ‚€ = outβ‚€ := + TM.transitionTape_eq_self houtput + have hsuccReach' : (TM.binarySuccTM counterIdx).reachesIn + (TM.binarySuccTime value) + { state := (TM.binarySuccTM counterIdx).qstart + input := TM.transitionInput inpβ‚€ + work := fun i => TM.transitionTape (afterBodyWork i) + output := TM.transitionTape outβ‚€ } + { state := (TM.binarySuccTM counterIdx).qhalt + input := inpβ‚€ + work := afterWork + output := outβ‚€ } := by + rw [htransitionInput, htransitionWork, htransitionOutput] + simpa [hsuccDoneEq] using hsuccReach + have hseq := TM.seqTM_reachesIn_of_reachesIn body + (TM.binarySuccTM counterIdx) hbodyReach rfl hsuccReach' + have hlift := TM.binaryForTM_iteration_reachesIn_internal body counterIdx + widthIdx hseq + simpa [body, wordPayloadTM, payloadIterationStartCfg, + payloadIterationDoneCfg, TM.binaryForIterationTime, + TM.binaryForIterationTM, TM.binaryForIterationWrap, TM.phase1Wrap, + TM.phase2Wrap, beforeWork, afterWork] using! hlift + +private theorem payloadLoopbackStep + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) (value : β„•) (hvalue : value < width) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).step + (payloadIterationDoneCfg sourceIdx targetIdx counterIdx widthIdx payload + width inpβ‚€ workβ‚€ outβ‚€ value) = + some (payloadScanCfg sourceIdx targetIdx counterIdx widthIdx payload width + inpβ‚€ workβ‚€ outβ‚€ (value + 1)) := by + let body := payloadBitTM sourceIdx targetIdx + let work := payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ (value + 1) (value + 1) + let cfg : Cfg n (TM.binaryForIterationTM body counterIdx).Q := + { state := (TM.binaryForIterationTM body counterIdx).qhalt + input := inpβ‚€ + work := work + output := outβ‚€ } + have hwork := payloadLoopWork_read_ne_start sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width workβ‚€ (value + 1) (value + 1) + (by omega) hsource htarget hother + have hstep := TM.binaryForTM_step_iteration_halt_internal body counterIdx widthIdx + cfg rfl hinput hwork houtput + simpa [body, cfg, work, wordPayloadTM, payloadIterationDoneCfg, + payloadScanCfg, TM.binaryForIterationWrap] using hstep + +private def payloadLoopSpec + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + TM.BinaryForLoopSpec (payloadBitTM sourceIdx targetIdx) counterIdx widthIdx + (fun _ => 1) width where + counter_ne_limit := hdistinct.counter_width + scanCfg := payloadScanCfg sourceIdx targetIdx counterIdx widthIdx payload width + inpβ‚€ workβ‚€ outβ‚€ + iterationStartCfg := payloadIterationStartCfg sourceIdx targetIdx counterIdx + widthIdx payload width inpβ‚€ workβ‚€ outβ‚€ + iterationDoneCfg := payloadIterationDoneCfg sourceIdx targetIdx counterIdx + widthIdx payload width inpβ‚€ workβ‚€ outβ‚€ + doneCfg := payloadDoneCfg sourceIdx targetIdx counterIdx widthIdx payload width + inpβ‚€ workβ‚€ outβ‚€ + testRun := payloadTestRun sourceIdx targetIdx counterIdx widthIdx hdistinct + payload rest width hwidth inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother houtput + iterationRun := payloadIterationRun sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width hwidth inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother + houtput + loopbackStep := payloadLoopbackStep sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width hwidth inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother + houtput + doneRun := payloadDoneRun sourceIdx targetIdx counterIdx widthIdx hdistinct + payload rest width hwidth inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother houtput + +private theorem payloadInitialWork + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload : List Bool) (width : β„•) (workβ‚€ : Fin n β†’ Tape) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat width) : + payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width workβ‚€ + 0 0 = workβ‚€ := by + funext i + by_cases his : i = sourceIdx + Β· subst i + rw [payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx] + rfl + Β· by_cases hit : i = targetIdx + Β· subst i + rw [payloadLoopWork_target sourceIdx targetIdx counterIdx widthIdx hdistinct] + rfl + Β· by_cases hic : i = counterIdx + Β· subst i + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact (hcounter.eq_init_move_right).symm + Β· by_cases hiw : i = widthIdx + Β· subst i + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact (hwidth.eq_init_move_right).symm + Β· exact payloadLoopWork_other sourceIdx targetIdx counterIdx widthIdx + payload width workβ‚€ 0 0 i his hit hic hiw + +theorem wordPayloadTM_reachesIn_frame_internal {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidthLength : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix (payload ++ rest)) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat width) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (wordPayloadTime width) + { state := (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work counterIdx).HasBinaryNat width ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let spec := payloadLoopSpec sourceIdx targetIdx counterIdx widthIdx hdistinct + payload rest width hwidthLength inpβ‚€ workβ‚€ outβ‚€ hsource htarget hinput hother houtput + have hreach := spec.reachesIn_internal width 0 (by omega) + have hinitial := payloadInitialWork sourceIdx targetIdx counterIdx widthIdx + hdistinct payload width workβ‚€ hcounter hwidth + refine ⟨payloadDoneCfg sourceIdx targetIdx counterIdx widthIdx payload width + inpβ‚€ workβ‚€ outβ‚€, ?_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, rfl⟩ + Β· simpa [spec, payloadLoopSpec, wordPayloadTime, wordPayloadTM, + payloadScanCfg, hinitial] using! hreach + Β· change (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width sourceIdx).HasBinarySuffix rest + rw [payloadLoopWork_source sourceIdx targetIdx counterIdx widthIdx] + have hsuffix := payloadSource_suffix sourceIdx payload rest workβ‚€ width + (by omega) hsource + simpa [← hwidthLength] using hsuffix + Β· change (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width targetIdx).HasBinaryPrefix payload + rw [payloadLoopWork_target sourceIdx targetIdx counterIdx widthIdx hdistinct] + have hprefix := payloadTarget_prefix targetIdx payload workβ‚€ width htarget + simpa [← hwidthLength] using hprefix + Β· change (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width counterIdx).HasBinaryNat width + rw [payloadLoopWork_counter sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat width + Β· change (payloadLoopWork sourceIdx targetIdx counterIdx widthIdx payload width + workβ‚€ width width widthIdx).HasBinaryNat width + rw [payloadLoopWork_width sourceIdx targetIdx counterIdx widthIdx hdistinct] + exact binaryNatTape_hasBinaryNat width + Β· intro i his hit hic hiw + exact payloadLoopWork_other sourceIdx targetIdx counterIdx widthIdx payload + width workβ‚€ width width i his hit hic hiw + +theorem wordWidthTM_reachesIn_frame_internal {n : β„•} + (sourceIdx widthIdx : Fin n) (hindices : sourceIdx β‰  widthIdx) + (width : β„•) (payload : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: payload)) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordWidthTM sourceIdx widthIdx).reachesIn (wordWidthTime width) + { state := (wordWidthTM sourceIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordWidthTM sourceIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix (false :: payload) ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let spec := loopSpec sourceIdx widthIdx hindices width payload inpβ‚€ workβ‚€ outβ‚€ + hsource hinput hother houtput + have hreach := spec.reachesIn_internal width 0 (by omega) + have hinit := initial_work sourceIdx widthIdx hindices workβ‚€ hwidth + refine ⟨doneCfg sourceIdx widthIdx width inpβ‚€ workβ‚€ outβ‚€, ?_, rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· simpa [spec, loopSpec, wordWidthTime, scanCfg, hinit] using! hreach + Β· change + (wordWidthWork sourceIdx widthIdx workβ‚€ width width sourceIdx).HasBinarySuffix + (false :: payload) + rw [wordWidthWork_source sourceIdx widthIdx hindices] + exact source_final_suffix sourceIdx workβ‚€ width payload hsource + Β· change + (wordWidthWork sourceIdx widthIdx workβ‚€ width width widthIdx).HasBinaryNat width + rw [wordWidthWork_width] + exact binaryNatTape_hasBinaryNat width + Β· intro i hiSource hiWidth + exact wordWidthWork_other sourceIdx widthIdx workβ‚€ width width i hiSource hiWidth + +theorem wordDecodeTM_reachesIn_frame_internal {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) + (hdistinct : PayloadLoopDistinct sourceIdx targetIdx counterIdx widthIdx) + (payload rest : List Bool) (width : β„•) (hwidthLength : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: (payload ++ rest))) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hwidth : (workβ‚€ widthIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).reachesIn + (wordDecodeTime width) + { state := (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work counterIdx).HasBinaryNat width ∧ + (c'.work widthIdx).HasBinaryNat width ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  counterIdx β†’ + i β‰  widthIdx β†’ c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + let widthTM := wordWidthTM sourceIdx widthIdx + let separatorTM := wordSeparatorTM sourceIdx + let payloadTM := wordPayloadTM sourceIdx targetIdx counterIdx widthIdx + let tailTM := TM.seqTM separatorTM payloadTM + have hwidthOther : βˆ€ i, i β‰  sourceIdx β†’ i β‰  widthIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start := by + intro i his hiw + by_cases hit : i = targetIdx + Β· subst i + rw [htarget.read_blank] + decide + Β· by_cases hic : i = counterIdx + Β· subst i + rw [hcounter.eq_init_move_right] + exact Tape.init_ofBool_move_right_read_ne_start (0 : β„•).bits + Β· exact hother i his hit hic hiw + obtain ⟨widthDone, hwidthReach, hwidthHalt, hwidthInput, + hwidthSource, hwidthValue, hwidthFrame, hwidthOutput⟩ := + wordWidthTM_reachesIn_frame_internal sourceIdx widthIdx + hdistinct.source_width width (payload ++ rest) inpβ‚€ workβ‚€ outβ‚€ hsource + hwidth hinput hwidthOther houtput + have hwidthWork : βˆ€ i, (widthDone.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hwidthSource.read_ne_start + Β· by_cases hiw : i = widthIdx + Β· subst i + rw [hwidthValue.eq_init_move_right] + exact Tape.init_ofBool_move_right_read_ne_start width.bits + Β· rw [hwidthFrame i his hiw] + exact hwidthOther i his hiw + obtain ⟨separatorDone, hseparatorReach, hseparatorHalt, hseparatorInput, + hseparatorSource, hseparatorFrame, hseparatorOutput⟩ := + wordSeparatorTM_reachesIn_frame_internal sourceIdx (payload ++ rest) + widthDone.input widthDone.work widthDone.output hwidthSource + (by rw [hwidthInput]; exact hinput) + (fun i _ => hwidthWork i) + (by rw [hwidthOutput]; exact houtput) + have hseparatorTarget : + (separatorDone.work targetIdx).HasBinaryPrefix [] := by + rw [hseparatorFrame targetIdx (Ne.symm hdistinct.source_target), + hwidthFrame targetIdx (Ne.symm hdistinct.source_target) + hdistinct.target_width] + exact htarget + have hseparatorCounter : + (separatorDone.work counterIdx).HasBinaryNat 0 := by + rw [hseparatorFrame counterIdx (Ne.symm hdistinct.source_counter), + hwidthFrame counterIdx (Ne.symm hdistinct.source_counter) + hdistinct.counter_width] + exact hcounter + have hseparatorWidth : + (separatorDone.work widthIdx).HasBinaryNat width := by + rw [hseparatorFrame widthIdx (Ne.symm hdistinct.source_width)] + exact hwidthValue + have hseparatorOther : βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ + i β‰  counterIdx β†’ i β‰  widthIdx β†’ (separatorDone.work i).read β‰  Ξ“.start := by + intro i his hit hic hiw + rw [hseparatorFrame i his, hwidthFrame i his hiw] + exact hother i his hit hic hiw + obtain ⟨payloadDone, hpayloadReach, hpayloadHalt, hpayloadInput, + hpayloadSource, hpayloadTarget, hpayloadCounter, hpayloadWidth, + hpayloadFrame, hpayloadOutput⟩ := + wordPayloadTM_reachesIn_frame_internal sourceIdx targetIdx counterIdx widthIdx + hdistinct payload rest width hwidthLength separatorDone.input + separatorDone.work separatorDone.output hseparatorSource hseparatorTarget + hseparatorCounter hseparatorWidth + (by rw [hseparatorInput, hwidthInput]; exact hinput) + hseparatorOther + (by rw [hseparatorOutput, hwidthOutput]; exact houtput) + have hseparatorWork : βˆ€ i, (separatorDone.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hseparatorSource.read_ne_start + Β· exact hseparatorFrame i his β–Έ hwidthWork i + have hsepTransitionInput : TM.transitionInput separatorDone.input = + separatorDone.input := + TM.transitionInput_eq_self (by rw [hseparatorInput, hwidthInput]; exact hinput) + have hsepTransitionWork : + (fun i => TM.transitionTape (separatorDone.work i)) = separatorDone.work := by + funext i + exact TM.transitionTape_eq_self (hseparatorWork i) + have hsepTransitionOutput : TM.transitionTape separatorDone.output = + separatorDone.output := + TM.transitionTape_eq_self + (by rw [hseparatorOutput, hwidthOutput]; exact houtput) + have hpayloadReach' : payloadTM.reachesIn (wordPayloadTime width) + { state := payloadTM.qstart + input := TM.transitionInput separatorDone.input + work := fun i => TM.transitionTape (separatorDone.work i) + output := TM.transitionTape separatorDone.output } + payloadDone := by + rw [hsepTransitionInput, hsepTransitionWork, hsepTransitionOutput] + simpa [payloadTM] using hpayloadReach + have htailReach := TM.seqTM_reachesIn_of_reachesIn separatorTM payloadTM + (by simpa [separatorTM] using hseparatorReach) hseparatorHalt hpayloadReach' + have hwidthTransitionInput : TM.transitionInput widthDone.input = widthDone.input := + TM.transitionInput_eq_self (by rw [hwidthInput]; exact hinput) + have hwidthTransitionWork : + (fun i => TM.transitionTape (widthDone.work i)) = widthDone.work := by + funext i + exact TM.transitionTape_eq_self (hwidthWork i) + have hwidthTransitionOutput : TM.transitionTape widthDone.output = + widthDone.output := + TM.transitionTape_eq_self (by rw [hwidthOutput]; exact houtput) + have htailReach' : tailTM.reachesIn (1 + 1 + wordPayloadTime width) + { state := tailTM.qstart + input := TM.transitionInput widthDone.input + work := fun i => TM.transitionTape (widthDone.work i) + output := TM.transitionTape widthDone.output } + (TM.phase2Wrap separatorTM payloadTM payloadDone) := by + rw [hwidthTransitionInput, hwidthTransitionWork, hwidthTransitionOutput] + simpa [tailTM, separatorTM, payloadTM, TM.phase1Wrap] using! htailReach + have hfull := TM.seqTM_reachesIn_of_reachesIn widthTM tailTM + (by simpa [widthTM] using hwidthReach) hwidthHalt htailReach' + let finalCfg := TM.phase2Wrap widthTM tailTM + (TM.phase2Wrap separatorTM payloadTM payloadDone) + refine ⟨finalCfg, ?_, ?_, hpayloadInput.trans (hseparatorInput.trans hwidthInput), + hpayloadSource, hpayloadTarget, hpayloadCounter, hpayloadWidth, ?_, + hpayloadOutput.trans (hseparatorOutput.trans hwidthOutput)⟩ + Β· simpa [finalCfg, wordDecodeTM, wordDecodeTime, widthTM, tailTM, + separatorTM, payloadTM] using! hfull + Β· change finalCfg.state = + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).qhalt + change Sum.inr (Sum.inr payloadDone.state) = + Sum.inr (Sum.inr (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).qhalt) + exact congrArg (fun q => Sum.inr (Sum.inr q)) hpayloadHalt + Β· intro i his hit hic hiw + change payloadDone.work i = workβ‚€ i + rw [hpayloadFrame i his hit hic hiw, + hseparatorFrame i his, hwidthFrame i his hiw] + +private theorem forWorkOnesLoopTime_succ_le_size + (limit value count : β„•) (hsum : value + count ≀ limit) : + TM.forWorkOnesLoopTime TM.binarySuccTime value count ≀ + 1 + count * (2 * limit.size + 4) := by + induction count generalizing value with + | zero => simp [TM.forWorkOnesLoopTime] + | succ count ih => + rw [TM.forWorkOnesLoopTime] + have hvalue : value ≀ limit := by omega + have hsize : value.size ≀ limit.size := Nat.size_le_size hvalue + have hsucc := TM.binarySuccTime_le value + have htail := ih (value + 1) (by omega) + rw [Nat.succ_mul] + omega + +private theorem binaryForLoopTime_one_le_size + (limit value count : β„•) (hsum : value + count ≀ limit) : + TM.binaryForLoopTime (fun _ => 1) limit value count ≀ + (count + 1) * (4 * limit.size + 8) := by + induction count generalizing value with + | zero => + simp only [TM.binaryForLoopTime, TM.binaryForCompareTime] + omega + | succ count ih => + rw [TM.binaryForLoopTime] + have hvalue : value ≀ limit := by omega + have hsize : value.size ≀ limit.size := Nat.size_le_size hvalue + have hsucc := TM.binarySuccTime_le value + have htail := ih (value + 1) (by omega) + simp only [TM.binaryForCompareTime, TM.binaryForIterationTime] + nlinarith + +theorem wordDecodeTime_le_size_internal (width : β„•) : + wordDecodeTime width ≀ + 8 * (width + 1) * (width.size + 2) := by + have hwidthLoop := forWorkOnesLoopTime_succ_le_size width 0 width (by omega) + have hpayloadLoop := binaryForLoopTime_one_le_size width 0 width (by omega) + have hwidth : wordWidthTime width ≀ + (width + 1) * (2 * width.size + 4) := by + unfold wordWidthTime + nlinarith + have hpayload : wordPayloadTime width ≀ + (width + 1) * (4 * width.size + 8) := by + unfold wordPayloadTime + simpa only [Nat.zero_add] using hpayloadLoop + unfold wordDecodeTime + nlinarith + +theorem wordWidthTM_isTransducer_internal {n : β„•} + (sourceIdx widthIdx : Fin n) : + (wordWidthTM sourceIdx widthIdx).IsTransducer := by + exact TM.IsTransducer.forWorkOnesTM_internal + (TM.binarySuccTM_isTransducer widthIdx) + +theorem payloadBitTM_isTransducer_internal {n : β„•} + (sourceIdx targetIdx : Fin n) : + (payloadBitTM sourceIdx targetIdx).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | copy => + cases hsource : wHeads sourceIdx <;> + cases oHead <;> + simp [payloadBitTM, hsource, TM.allReadBack, TM.allIdle, TM.idleDir] + | done => + cases oHead <;> simp [payloadBitTM, TM.allIdle, TM.idleDir] + +theorem wordSeparatorTM_isTransducer_internal {n : β„•} (sourceIdx : Fin n) : + (wordSeparatorTM sourceIdx).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | skip => + by_cases hzero : wHeads sourceIdx = Ξ“.zero + Β· cases oHead <;> simp [wordSeparatorTM, hzero, TM.idleDir] + Β· by_cases hstart : wHeads sourceIdx = Ξ“.start + Β· cases oHead <;> + simp [wordSeparatorTM, hstart, TM.allIdle, TM.idleDir] + Β· cases oHead <;> + simp [wordSeparatorTM, hzero, hstart, TM.allReadBack, TM.idleDir] + | done => + cases oHead <;> simp [wordSeparatorTM, TM.allIdle, TM.idleDir] + +theorem wordPayloadTM_isTransducer_internal {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : + (wordPayloadTM sourceIdx targetIdx counterIdx widthIdx).IsTransducer := by + exact TM.IsTransducer.binaryForTM_internal + (payloadBitTM_isTransducer_internal sourceIdx targetIdx) counterIdx widthIdx + +theorem wordDecodeTM_isTransducer_internal {n : β„•} + (sourceIdx targetIdx counterIdx widthIdx : Fin n) : + (wordDecodeTM sourceIdx targetIdx counterIdx widthIdx).IsTransducer := by + exact TM.IsTransducer.seqTM_internal + (wordWidthTM_isTransducer_internal sourceIdx widthIdx) + (TM.IsTransducer.seqTM_internal + (wordSeparatorTM_isTransducer_internal sourceIdx) + (wordPayloadTM_isTransducer_internal sourceIdx targetIdx counterIdx widthIdx)) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/LinearInternal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/LinearInternal.lean new file mode 100644 index 0000000000..16c71f4382 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordDecode/LinearInternal.lean @@ -0,0 +1,837 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Linear RAM snapshot word decoder β€” proof internals + +This file proves the exact three-pass behavior of `wordDecodeLinearTM`: copy +the unary width to a marker tape, rewind those markers, then consume one marker +while copying one payload bit. Each pass is linear in the encoded word width. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private def linearMarkWork (sourceIdx markerIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := fun i => + if i = sourceIdx then (work i).move Dir3.right + else if i = markerIdx then + (work i).writeAndMove Ξ“.one Dir3.right + else work i + +private theorem linearMarkStep + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (suffix pre : List Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hsource : (work sourceIdx).HasBinarySuffix (true :: suffix)) + (hmarker : (work markerIdx).HasBinaryPrefix pre) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let work' := linearMarkWork sourceIdx markerIdx work + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .mark, input := inp, work := work, output := out } = some c' ∧ + c'.state = .mark ∧ c'.input = inp ∧ + (c'.work sourceIdx).HasBinarySuffix suffix ∧ + (c'.work markerIdx).HasBinaryPrefix (pre ++ [true]) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.work = work' ∧ c'.output = out := by + dsimp only + let work' := linearMarkWork sourceIdx markerIdx work + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .mark, input := inp, work := work', output := out } + have hread : (work sourceIdx).read = Ξ“.one := hsource.read_cons + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .mark, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + simp only [wordDecodeLinearTM, hread] + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c', work'] + funext i + by_cases his : i = sourceIdx + Β· subst i + simpa [linearMarkWork, hdistinct.source_marker] using + TM.writeAndMove_readBack (work sourceIdx) (hreads sourceIdx) Dir3.right + Β· by_cases him : i = markerIdx + Β· subst i + simp [linearMarkWork, his] + Β· simpa [linearMarkWork, his, him, TM.idleDir, hreads i, + Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + refine ⟨c', hstep, rfl, rfl, ?_, ?_, ?_, rfl, rfl⟩ + Β· dsimp only [c', work', linearMarkWork] + rw [ite_eq_left rfl] + exact hsource.move_right_cons + Β· dsimp only [c', work', linearMarkWork] + rw [ite_eq_right (Ne.symm hdistinct.source_marker), ite_eq_left rfl] + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit true hmarker + Β· intro i his him + simp [c', work', linearMarkWork, his, him] + +private theorem linearMarkLoop + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (width : β„•) (payload rest pre : List Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hsource : (work sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: (payload ++ rest))) + (hmarker : (work markerIdx).HasBinaryPrefix pre) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn width + { state := .mark, input := inp, work := work, output := out } c' ∧ + c'.state = .mark ∧ c'.input = inp ∧ + (c'.work sourceIdx).HasBinarySuffix (false :: (payload ++ rest)) ∧ + (c'.work markerIdx).HasBinaryPrefix + (pre ++ List.replicate width true) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.output = out := by + induction width generalizing inp work out pre with + | zero => + refine ⟨_, .zero, rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· simpa using hsource + Β· simpa using hmarker + Β· intro i _ _ + rfl + | succ width ih => + have hshape : + List.replicate (width + 1) true ++ false :: (payload ++ rest) = + true :: (List.replicate width true ++ false :: (payload ++ rest)) := by + simp [List.replicate_succ] + rw [hshape] at hsource + obtain ⟨first, hfirstStep, hfirstState, hfirstInput, hfirstSource, + hfirstMarker, hfirstFrame, hfirstWork, hfirstOutput⟩ := + linearMarkStep sourceIdx targetIdx markerIdx hdistinct + (List.replicate width true ++ false :: (payload ++ rest)) pre + inp work out hsource hmarker hinput hreads houtput + have hfirstReads : βˆ€ i, (first.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hfirstSource.read_ne_start + Β· by_cases him : i = markerIdx + Β· subst i + rw [hfirstMarker.read_blank] + decide + Β· rw [hfirstFrame i his him] + exact hreads i + obtain ⟨done, htailReach, hdoneState, hdoneInput, hdoneSource, + hdoneMarker, hdoneFrame, hdoneOutput⟩ := + ih (pre ++ [true]) first.input first.work first.output hfirstSource + hfirstMarker (by rw [hfirstInput]; exact hinput) hfirstReads + (by rw [hfirstOutput]; exact houtput) + refine ⟨done, TM.reachesIn.step hfirstStep ?_, hdoneState, + hdoneInput.trans hfirstInput, hdoneSource, ?_, ?_, + hdoneOutput.trans hfirstOutput⟩ + Β· have hfirstEq : first = + { state := LinearWordPhase.mark + input := first.input + work := first.work + output := first.output } := + Cfg.ext hfirstState rfl rfl rfl + rw [hfirstEq] + exact htailReach + Β· simpa [List.replicate_succ, List.append_assoc] using hdoneMarker + Β· intro i his him + rw [hdoneFrame i his him, hfirstFrame i his him] + +private def linearSeparatorWork (sourceIdx markerIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := fun i => + if i = sourceIdx then (work i).move Dir3.right + else if i = markerIdx then (work i).move Dir3.left + else work i + +private theorem linearSeparatorStep + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (payload rest : List Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hsource : (work sourceIdx).HasBinarySuffix (false :: (payload ++ rest))) + (hmarker : (work markerIdx).HasBinaryPrefix (List.replicate payload.length true)) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .mark, input := inp, work := work, output := out } = some c' ∧ + c'.state = .rewind ∧ c'.input = inp ∧ + (c'.work sourceIdx).HasBinarySuffix (payload ++ rest) ∧ + (c'.work markerIdx).head = payload.length ∧ + (c'.work markerIdx).cells = (work markerIdx).cells ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.output = out := by + let work' := linearSeparatorWork sourceIdx markerIdx work + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .rewind, input := inp, work := work', output := out } + have hread : (work sourceIdx).read = Ξ“.zero := hsource.read_cons + have hmarkerRead : (work markerIdx).read = Ξ“.blank := hmarker.read_blank + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .mark, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + simp only [wordDecodeLinearTM, hread] + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c', work'] + funext i + by_cases his : i = sourceIdx + Β· subst i + simpa [linearSeparatorWork, hdistinct.source_marker] using + TM.writeAndMove_readBack (work sourceIdx) (hreads sourceIdx) Dir3.right + Β· by_cases him : i = markerIdx + Β· subst i + have hmarkerNe : (work markerIdx).read β‰  Ξ“.start := by + rw [hmarkerRead] + decide + simpa [linearSeparatorWork, his, hmarkerRead, TM.moveLeftDir] using + TM.writeAndMove_readBack (work markerIdx) hmarkerNe Dir3.left + Β· simpa [linearSeparatorWork, his, him, TM.idleDir, hreads i, + Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + refine ⟨c', hstep, rfl, rfl, ?_, ?_, ?_, ?_, rfl⟩ + Β· dsimp only [c', work', linearSeparatorWork] + rw [ite_eq_left rfl] + exact hsource.move_right_cons + Β· dsimp only [c', work', linearSeparatorWork] + rw [ite_eq_right (Ne.symm hdistinct.source_marker), ite_eq_left rfl] + simp only [Tape.move] + rw [hmarker.1] + simp + Β· dsimp only [c', work', linearSeparatorWork] + rw [ite_eq_right (Ne.symm hdistinct.source_marker), ite_eq_left rfl, + Tape.move_cells] + Β· intro i his him + simp [c', work', linearSeparatorWork, his, him] + +private def linearRewindLeftWork (markerIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := fun i => + if i = markerIdx then (work i).move Dir3.left else work i + +private theorem linearRewindLeftStep + (sourceIdx targetIdx markerIdx : Fin n) (head : β„•) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hmarker : (work markerIdx).StartInvariant) + (hhead : (work markerIdx).head = head + 1) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, i β‰  markerIdx β†’ (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let work' := linearRewindLeftWork markerIdx work + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .rewind, input := inp, work := work, output := out } = some c' ∧ + c'.state = .rewind ∧ c'.input = inp ∧ + (c'.work markerIdx).head = head ∧ + (c'.work markerIdx).cells = (work markerIdx).cells ∧ + (βˆ€ i, i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.work = work' ∧ c'.output = out := by + dsimp only + let work' := linearRewindLeftWork markerIdx work + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .rewind, input := inp, work := work', output := out } + have hmarkerRead : (work markerIdx).read β‰  Ξ“.start := + hmarker.read_ne_start (by omega) + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .rewind, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + simp only [wordDecodeLinearTM, hmarkerRead, ↓reduceIte] + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c', work'] + funext i + by_cases him : i = markerIdx + Β· subst i + simpa [linearRewindLeftWork, hmarkerRead, TM.moveLeftDir] using + TM.writeAndMove_readBack (work markerIdx) hmarkerRead Dir3.left + Β· simpa [linearRewindLeftWork, him, TM.idleDir, hreads i him, + Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i him) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + refine ⟨c', hstep, rfl, rfl, ?_, ?_, ?_, rfl, rfl⟩ + Β· simp [c', work', linearRewindLeftWork, Tape.move, hhead] + Β· simp [c', work', linearRewindLeftWork, Tape.move_cells] + Β· intro i him + simp [c', work', linearRewindLeftWork, him] + +private def linearRewindBaseWork (markerIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := fun i => + if i = markerIdx then (work i).move Dir3.right else work i + +private theorem linearRewindBaseStep + (sourceIdx targetIdx markerIdx : Fin n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hmarker : (work markerIdx).StartInvariant) + (hhead : (work markerIdx).head = 0) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, i β‰  markerIdx β†’ (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let work' := linearRewindBaseWork markerIdx work + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .rewind, input := inp, work := work, output := out } = some c' ∧ + c'.state = .copy ∧ c'.input = inp ∧ + (c'.work markerIdx).head = 1 ∧ + (c'.work markerIdx).cells = (work markerIdx).cells ∧ + (βˆ€ i, i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.work = work' ∧ c'.output = out := by + dsimp only + let work' := linearRewindBaseWork markerIdx work + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .copy, input := inp, work := work', output := out } + have hmarkerRead : (work markerIdx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hmarker.1 + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .rewind, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + simp only [wordDecodeLinearTM, hmarkerRead, ↓reduceIte] + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c', work'] + funext i + by_cases him : i = markerIdx + Β· subst i + simp [linearRewindBaseWork, Tape.writeAndMove, Tape.write, + Tape.move, hhead] + Β· simpa [linearRewindBaseWork, him, TM.idleDir, hreads i him, + Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i him) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + refine ⟨c', hstep, rfl, rfl, ?_, ?_, ?_, rfl, rfl⟩ + Β· simp [c', work', linearRewindBaseWork, Tape.move, hhead] + Β· simp [c', work', linearRewindBaseWork, Tape.move_cells] + Β· intro i him + simp [c', work', linearRewindBaseWork, him] + +private theorem linearRewindLoop + (sourceIdx targetIdx markerIdx : Fin n) (head : β„•) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hmarker : (work markerIdx).StartInvariant) + (hhead : (work markerIdx).head = head) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, i β‰  markerIdx β†’ (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn (head + 1) + { state := .rewind, input := inp, work := work, output := out } c' ∧ + c'.state = .copy ∧ c'.input = inp ∧ + (c'.work markerIdx).head = 1 ∧ + (c'.work markerIdx).cells = (work markerIdx).cells ∧ + (βˆ€ i, i β‰  markerIdx β†’ c'.work i = work i) ∧ + c'.output = out := by + induction head generalizing inp work out with + | zero => + obtain ⟨done, hstep, hstate, hdoneInput, hdoneHead, hdoneCells, + hdoneFrame, _, hdoneOutput⟩ := + linearRewindBaseStep sourceIdx targetIdx markerIdx inp work out hmarker + hhead hinput hreads houtput + exact ⟨done, TM.reachesIn.step hstep .zero, hstate, hdoneInput, + hdoneHead, hdoneCells, hdoneFrame, hdoneOutput⟩ + | succ head ih => + obtain ⟨first, hstep, hfirstState, hfirstInput, hfirstHead, + hfirstCells, hfirstFrame, hfirstWork, hfirstOutput⟩ := + linearRewindLeftStep sourceIdx targetIdx markerIdx head inp work out + hmarker hhead hinput hreads houtput + have hfirstMarker : (first.work markerIdx).StartInvariant := by + simpa only [Tape.StartInvariant, hfirstCells] using hmarker + have hfirstReads : βˆ€ i, i β‰  markerIdx β†’ + (first.work i).read β‰  Ξ“.start := by + intro i him + rw [hfirstFrame i him] + exact hreads i him + obtain ⟨done, htail, hdoneState, hdoneInput, hdoneHead, hdoneCells, + hdoneFrame, hdoneOutput⟩ := + ih first.input first.work first.output hfirstMarker hfirstHead + (by rw [hfirstInput]; exact hinput) hfirstReads + (by rw [hfirstOutput]; exact houtput) + have hfirstEq : first = + { state := LinearWordPhase.rewind + input := first.input + work := first.work + output := first.output } := + Cfg.ext hfirstState rfl rfl rfl + refine ⟨done, TM.reachesIn.step hstep ?_, hdoneState, + hdoneInput.trans hfirstInput, hdoneHead, hdoneCells.trans hfirstCells, + ?_, hdoneOutput.trans hfirstOutput⟩ + Β· rw [hfirstEq] + exact htail + Β· intro i him + rw [hdoneFrame i him, hfirstFrame i him] + +private def linearCopyWork (sourceIdx targetIdx markerIdx : Fin n) + (bit : Bool) (work : Fin n β†’ Tape) : Fin n β†’ Tape := fun i => + if i = sourceIdx then (work i).move Dir3.right + else if i = targetIdx then + (work i).writeAndMove (Ξ“w.ofBool bit) Dir3.right + else if i = markerIdx then (work i).move Dir3.right + else work i + +private theorem linearCopyStep + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (bit : Bool) (payload markers pre : List Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hsource : (work sourceIdx).HasBinarySuffix (bit :: payload)) + (hmarker : (work markerIdx).HasBinarySuffix (true :: markers)) + (htarget : (work targetIdx).HasBinaryPrefix pre) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let work' := linearCopyWork sourceIdx targetIdx markerIdx bit work + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .copy, input := inp, work := work, output := out } = some c' ∧ + c'.state = .copy ∧ c'.input = inp ∧ + (c'.work sourceIdx).HasBinarySuffix payload ∧ + (c'.work markerIdx).HasBinarySuffix markers ∧ + (c'.work targetIdx).HasBinaryPrefix (pre ++ [bit]) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  markerIdx β†’ + c'.work i = work i) ∧ + c'.work = work' ∧ c'.output = out := by + dsimp only + let work' := linearCopyWork sourceIdx targetIdx markerIdx bit work + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .copy, input := inp, work := work', output := out } + have hsourceRead : (work sourceIdx).read = Ξ“.ofBool bit := hsource.read_cons + have hmarkerRead : (work markerIdx).read = Ξ“.one := hmarker.read_cons + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .copy, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + cases bit <;> + simp only [wordDecodeLinearTM, hmarkerRead, hsourceRead, Ξ“.ofBool, + reduceCtorEq] + all_goals + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c', work'] + funext i + by_cases his : i = sourceIdx + Β· subst i + simpa [linearCopyWork, hdistinct.source_target, + hdistinct.source_marker] using + TM.writeAndMove_readBack (work sourceIdx) (hreads sourceIdx) + Dir3.right + Β· by_cases hit : i = targetIdx + Β· subst i + simp [linearCopyWork, his] + Β· by_cases him : i = markerIdx + Β· subst i + simpa [linearCopyWork, his, Ne.symm hdistinct.target_marker] using + TM.writeAndMove_readBack (work markerIdx) (hreads markerIdx) + Dir3.right + Β· simpa [linearCopyWork, his, hit, him, TM.idleDir, hreads i, + Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + refine ⟨c', hstep, rfl, rfl, ?_, ?_, ?_, ?_, rfl, rfl⟩ + Β· dsimp only [c', work', linearCopyWork] + rw [ite_eq_left rfl] + exact hsource.move_right_cons + Β· dsimp only [c', work', linearCopyWork] + rw [ite_eq_right (Ne.symm hdistinct.source_marker), + ite_eq_right (Ne.symm hdistinct.target_marker), ite_eq_left rfl] + exact hmarker.move_right_cons + Β· dsimp only [c', work', linearCopyWork] + rw [ite_eq_right (Ne.symm hdistinct.source_target), ite_eq_left rfl] + cases bit with + | false => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit false htarget + | true => + simpa [Ξ“w.ofBool, Ξ“.ofBool, Ξ“w.toΞ“] using + Tape.hasBinaryPrefix_write_bit true htarget + Β· intro i his hit him + simp [c', work', linearCopyWork, his, hit, him] + +private theorem linearCopyDoneStep + (sourceIdx targetIdx markerIdx : Fin n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hmarker : (work markerIdx).HasBinarySuffix []) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .copy, input := inp, work := work, output := out } = some c' ∧ + c'.state = .done ∧ c'.input = inp ∧ c'.work = work ∧ + c'.output = out := by + let c' : Cfg n (wordDecodeLinearTM sourceIdx targetIdx markerIdx).Q := + { state := .done, input := inp, work := work, output := out } + have hmarkerRead : (work markerIdx).read = Ξ“.blank := hmarker.read_nil + have hstep : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).step + { state := .copy, input := inp, work := work, output := out } = some c' := by + rw [TM.step, ite_eq_right (by simp [wordDecodeLinearTM])] + simp only [wordDecodeLinearTM, hmarkerRead, TM.allReadBack] + apply congrArg some + refine Cfg.ext rfl ?_ ?_ ?_ + Β· dsimp only [c'] + simp [TM.idleDir, hinput, Tape.move] + Β· dsimp only [c'] + funext i + simpa [TM.idleDir, hreads i, Tape.move] using + TM.writeAndMove_readBack (work i) (hreads i) Dir3.stay + Β· dsimp only [c'] + simpa [TM.idleDir, houtput, Tape.move] using + TM.writeAndMove_readBack out houtput Dir3.stay + exact ⟨c', hstep, rfl, rfl, rfl, rfl⟩ + +private theorem linearCopyLoop + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (payload rest pre : List Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hsource : (work sourceIdx).HasBinarySuffix (payload ++ rest)) + (hmarker : (work markerIdx).HasBinarySuffix + (List.replicate payload.length true)) + (htarget : (work targetIdx).HasBinaryPrefix pre) + (hinput : inp.read β‰  Ξ“.start) + (hreads : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (payload.length + 1) + { state := .copy, input := inp, work := work, output := out } c' ∧ + c'.state = .done ∧ c'.input = inp ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work markerIdx).HasBinarySuffix [] ∧ + (c'.work markerIdx).head = (work markerIdx).head + payload.length ∧ + (c'.work markerIdx).cells = (work markerIdx).cells ∧ + (c'.work targetIdx).HasBinaryPrefix (pre ++ payload) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  markerIdx β†’ + c'.work i = work i) ∧ + c'.output = out := by + induction payload generalizing inp work out pre with + | nil => + have hsource' : (work sourceIdx).HasBinarySuffix rest := by + simpa using hsource + have hmarker' : (work markerIdx).HasBinarySuffix [] := by + simpa using hmarker + obtain ⟨done, hstep, hstate, hdoneInput, hdoneWork, hdoneOutput⟩ := + linearCopyDoneStep sourceIdx targetIdx markerIdx inp work out hmarker' + hinput hreads houtput + refine ⟨done, TM.reachesIn.step hstep .zero, hstate, hdoneInput, + ?_, ?_, ?_, ?_, ?_, ?_, hdoneOutput⟩ + Β· rw [hdoneWork] + exact hsource' + Β· rw [hdoneWork] + exact hmarker' + Β· rw [hdoneWork] + simp + Β· rw [hdoneWork] + Β· simpa [hdoneWork] using htarget + Β· intro i _ _ _ + rw [hdoneWork] + | cons bit payload ih => + have hsourceShape : (work sourceIdx).HasBinarySuffix + (bit :: (payload ++ rest)) := by + simpa [List.cons_append] using hsource + have hmarkerShape : (work markerIdx).HasBinarySuffix + (true :: List.replicate payload.length true) := by + simpa [List.replicate_succ] using hmarker + obtain ⟨first, hstep, hfirstState, hfirstInput, hfirstSource, + hfirstMarker, hfirstTarget, hfirstFrame, hfirstWork, hfirstOutput⟩ := + linearCopyStep sourceIdx targetIdx markerIdx hdistinct bit + (payload ++ rest) + (List.replicate payload.length true) pre inp work out hsourceShape + hmarkerShape htarget hinput hreads houtput + have hfirstReads : βˆ€ i, (first.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hfirstSource.read_ne_start + Β· by_cases hit : i = targetIdx + Β· subst i + rw [hfirstTarget.read_blank] + decide + Β· by_cases him : i = markerIdx + Β· subst i + exact hfirstMarker.read_ne_start + Β· rw [hfirstFrame i his hit him] + exact hreads i + obtain ⟨done, htail, hdoneState, hdoneInput, hdoneSource, + hdoneMarker, hdoneMarkerHead, hdoneMarkerCells, hdoneTarget, + hdoneFrame, hdoneOutput⟩ := + ih (pre ++ [bit]) first.input first.work first.output hfirstSource + hfirstMarker hfirstTarget (by rw [hfirstInput]; exact hinput) + hfirstReads (by rw [hfirstOutput]; exact houtput) + have hfirstEq : first = + { state := LinearWordPhase.copy + input := first.input + work := first.work + output := first.output } := + Cfg.ext hfirstState rfl rfl rfl + refine ⟨done, TM.reachesIn.step hstep ?_, hdoneState, + hdoneInput.trans hfirstInput, hdoneSource, hdoneMarker, ?_, ?_, ?_, + ?_, hdoneOutput.trans hfirstOutput⟩ + Β· rw [hfirstEq] + exact htail + Β· rw [hdoneMarkerHead] + rw [hfirstWork] + simp [linearCopyWork, Ne.symm hdistinct.source_marker, + Ne.symm hdistinct.target_marker, Tape.move] + omega + Β· rw [hdoneMarkerCells] + rw [hfirstWork] + simp [linearCopyWork, Ne.symm hdistinct.source_marker, + Ne.symm hdistinct.target_marker, Tape.move_cells] + Β· simpa [List.append_assoc] using hdoneTarget + Β· intro i his hit him + rw [hdoneFrame i his hit him, hfirstFrame i his hit him] + +theorem wordDecodeLinearTM_reachesIn_frame_internal + (sourceIdx targetIdx markerIdx : Fin n) + (hdistinct : LinearWordDistinct sourceIdx targetIdx markerIdx) + (payload rest : List Bool) (width : β„•) (hwidth : payload.length = width) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ sourceIdx).HasBinarySuffix + (List.replicate width true ++ false :: (payload ++ rest))) + (htarget : (workβ‚€ targetIdx).HasBinaryPrefix []) + (hmarker : (workβ‚€ markerIdx).HasBinaryPrefix []) + (hmarkerStart : (workβ‚€ markerIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hreads : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (wordDecodeLinearTime width) + { state := (wordDecodeLinearTM sourceIdx targetIdx markerIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work sourceIdx).HasBinarySuffix rest ∧ + (c'.work targetIdx).HasBinaryPrefix payload ∧ + (c'.work markerIdx).HasBinaryPrefix (List.replicate width true) ∧ + (βˆ€ i, i β‰  sourceIdx β†’ i β‰  targetIdx β†’ i β‰  markerIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + obtain ⟨marked, hmarkReach, hmarkedState, hmarkedInput, hmarkedSource, + hmarkedMarker, hmarkedFrame, hmarkedOutput⟩ := + linearMarkLoop sourceIdx targetIdx markerIdx hdistinct width payload rest [] + inpβ‚€ workβ‚€ outβ‚€ hsource hmarker hinput hreads houtput + have hmarkedMarker' : (marked.work markerIdx).HasBinaryPrefix + (List.replicate payload.length true) := by + simpa [hwidth] using hmarkedMarker + have hmarkedReads : βˆ€ i, (marked.work i).read β‰  Ξ“.start := by + intro i + by_cases his : i = sourceIdx + Β· subst i + exact hmarkedSource.read_ne_start + Β· by_cases him : i = markerIdx + Β· subst i + rw [hmarkedMarker.read_blank] + decide + Β· rw [hmarkedFrame i his him] + exact hreads i + obtain ⟨separated, hseparatorStep, hseparatedState, hseparatedInput, + hseparatedSource, hseparatedMarkerHead, hseparatedMarkerCells, + hseparatedFrame, hseparatedOutput⟩ := + linearSeparatorStep sourceIdx targetIdx markerIdx hdistinct payload rest + marked.input marked.work marked.output hmarkedSource hmarkedMarker' + (by rw [hmarkedInput]; exact hinput) hmarkedReads + (by rw [hmarkedOutput]; exact houtput) + have hmarkedEq : marked = + { state := LinearWordPhase.mark + input := marked.input + work := marked.work + output := marked.output } := + Cfg.ext hmarkedState rfl rfl rfl + have hseparatorReach : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn 1 marked + separated := by + rw [hmarkedEq] + exact TM.reachesIn.step hseparatorStep .zero + have hmarkedMarkerStart : (marked.work markerIdx).cells 0 = Ξ“.start := + TM.work_cells_zero_eq_start_of_reachesIn markerIdx hmarkReach hmarkerStart + have hseparatedMarkerInv : (separated.work markerIdx).StartInvariant := by + constructor + Β· rw [hseparatedMarkerCells] + exact hmarkedMarkerStart + Β· intro j hj + rw [hseparatedMarkerCells] + exact Tape.cells_ne_start_of_hasBinaryPrefix hmarkedMarker j hj + have hseparatedReads : βˆ€ i, i β‰  markerIdx β†’ + (separated.work i).read β‰  Ξ“.start := by + intro i him + by_cases his : i = sourceIdx + Β· subst i + exact hseparatedSource.read_ne_start + Β· rw [hseparatedFrame i his him] + exact hmarkedReads i + obtain ⟨rewound, hrewindReach, hrewoundState, hrewoundInput, + hrewoundMarkerHead, hrewoundMarkerCells, hrewoundFrame, + hrewoundOutput⟩ := + linearRewindLoop sourceIdx targetIdx markerIdx payload.length + separated.input separated.work separated.output hseparatedMarkerInv + hseparatedMarkerHead + (by rw [hseparatedInput, hmarkedInput]; exact hinput) + hseparatedReads + (by rw [hseparatedOutput, hmarkedOutput]; exact houtput) + have hseparatedEq : separated = + { state := LinearWordPhase.rewind + input := separated.input + work := separated.work + output := separated.output } := + Cfg.ext hseparatedState rfl rfl rfl + have hrewindReach' : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (payload.length + 1) separated rewound := by + rw [hseparatedEq] + exact hrewindReach + have hrewoundSource : (rewound.work sourceIdx).HasBinarySuffix + (payload ++ rest) := by + rw [hrewoundFrame sourceIdx hdistinct.source_marker] + exact hseparatedSource + have hrewoundTarget : (rewound.work targetIdx).HasBinaryPrefix [] := by + rw [hrewoundFrame targetIdx hdistinct.target_marker, + hseparatedFrame targetIdx (Ne.symm hdistinct.source_target) + hdistinct.target_marker, + hmarkedFrame targetIdx (Ne.symm hdistinct.source_target) + hdistinct.target_marker] + exact htarget + have hrewoundMarkerString : (rewound.work markerIdx).HasBinaryString + (List.replicate width true) := by + apply Tape.hasBinaryString_of_hasBinaryPrefix hmarkedMarker hrewoundMarkerHead + exact hrewoundMarkerCells.trans hseparatedMarkerCells + have hrewoundMarkerSuffix := hrewoundMarkerString.hasBinarySuffix + have hrewoundReads : βˆ€ i, (rewound.work i).read β‰  Ξ“.start := by + intro i + by_cases him : i = markerIdx + Β· subst i + exact hrewoundMarkerSuffix.read_ne_start + Β· rw [hrewoundFrame i him] + exact hseparatedReads i him + obtain ⟨done, hcopyReach, hdoneState, hdoneInput, hdoneSource, + hdoneMarkerSuffix, hdoneMarkerHead, hdoneMarkerCells, hdoneTarget, + hdoneFrame, hdoneOutput⟩ := + linearCopyLoop sourceIdx targetIdx markerIdx hdistinct payload rest [] + rewound.input rewound.work rewound.output hrewoundSource + (by simpa [hwidth] using hrewoundMarkerSuffix) hrewoundTarget + (by rw [hrewoundInput, hseparatedInput, hmarkedInput]; exact hinput) + hrewoundReads + (by rw [hrewoundOutput, hseparatedOutput, hmarkedOutput]; exact houtput) + have hrewoundEq : rewound = + { state := LinearWordPhase.copy + input := rewound.input + work := rewound.work + output := rewound.output } := + Cfg.ext hrewoundState rfl rfl rfl + have hcopyReach' : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).reachesIn + (payload.length + 1) rewound done := by + rw [hrewoundEq] + exact hcopyReach + let tm := wordDecodeLinearTM sourceIdx targetIdx markerIdx + have hfull := TM.reachesIn_trans tm + (TM.reachesIn_trans tm (TM.reachesIn_trans tm hmarkReach hseparatorReach) + hrewindReach') hcopyReach' + have htime : + width + 1 + (payload.length + 1) + (payload.length + 1) = + wordDecodeLinearTime width := by + simp only [wordDecodeLinearTime, hwidth] + omega + have hdoneMarker : (done.work markerIdx).HasBinaryPrefix + (List.replicate width true) := by + apply Tape.hasBinaryPrefix_of_hasBinaryString hrewoundMarkerString + Β· rw [hdoneMarkerHead, hrewoundMarkerHead, hwidth] + simp + omega + Β· exact hdoneMarkerCells + refine ⟨done, ?_, hdoneState, ?_, hdoneSource, ?_, hdoneMarker, ?_, ?_⟩ + Β· rw [← htime] + exact hfull + Β· exact hdoneInput.trans + (hrewoundInput.trans (hseparatedInput.trans hmarkedInput)) + Β· simpa using hdoneTarget + Β· intro i his hit him + rw [hdoneFrame i his hit him, hrewoundFrame i him, + hseparatedFrame i his him, hmarkedFrame i his him] + Β· exact hdoneOutput.trans + (hrewoundOutput.trans (hseparatedOutput.trans hmarkedOutput)) + +theorem wordDecodeLinearTM_isTransducer_internal + (sourceIdx targetIdx markerIdx : Fin n) : + (wordDecodeLinearTM sourceIdx targetIdx markerIdx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | mark => + cases hsource : wHeads sourceIdx <;> + cases oHead <;> + simp [wordDecodeLinearTM, hsource, TM.allReadBack, TM.allIdle, + TM.idleDir] + | rewind => + by_cases hmarker : wHeads markerIdx = Ξ“.start <;> + cases oHead <;> + simp [wordDecodeLinearTM, hmarker, TM.idleDir] + | copy => + cases hmarker : wHeads markerIdx with + | one => + cases hsource : wHeads sourceIdx <;> + cases oHead <;> + simp [wordDecodeLinearTM, hmarker, hsource, TM.allReadBack, + TM.idleDir] + | zero | blank => + cases oHead <;> + simp [wordDecodeLinearTM, hmarker, TM.allReadBack, TM.idleDir] + | start => + cases oHead <;> + simp [wordDecodeLinearTM, hmarker, TM.idleDir] + | done => + cases oHead <;> simp [wordDecodeLinearTM, TM.allIdle, TM.idleDir] + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode.lean new file mode 100644 index 0000000000..85d374352c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Internal + +/-! +# Self-delimiting word emission +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- One generic work-tape pass appends either the unary width header or the +payload bits while preserving input and every unrelated work tape exactly. -/ +theorem workEmitTM_hoareTime_frame {n : β„•} + (idx : Fin n) (mode : WorkEmitMode) (bits emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ idx).HasBinarySuffix bits) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (workEmitTM idx mode).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = (workβ‚€ idx).head + bits.length ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ workEmitBits mode bits)) + (workEmitTime bits) := + workEmitTM_hoareTime_frame_internal idx mode bits emitted inpβ‚€ workβ‚€ + outβ‚€ hsource hinput hother houtput + +/-- Emit `WordCode.encode value` from a canonical natural-number work tape, +preserving the input, source cells, and every unrelated work tape exactly. -/ +theorem wordEncodeTM_hoareTime_frame {n : β„•} + (idx : Fin n) (value : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (wordEncodeTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = value.bits.length + 1 ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ WordCode.encode value)) + (wordEncodeTime value) := + wordEncodeTM_hoareTime_frame_internal idx value emitted inpβ‚€ workβ‚€ outβ‚€ + hvalue hinput hother houtput + +/-- Rewind any bounded cursor over canonical binary contents and emit the +complete self-delimiting word, retaining a literal external frame. -/ +theorem rewindWordEncodeTM_hoareTime_frame {n : β„•} + (idx : Fin n) (value headBound : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hcontent : (workβ‚€ idx).HasBinaryContent value.bits) + (hstart : (workβ‚€ idx).cells 0 = Ξ“.start) + (hhead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindWordEncodeTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = value.bits.length + 1 ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ WordCode.encode value)) + (rewindWordEncodeTime value headBound) := + rewindWordEncodeTM_hoareTime_frame_internal idx value headBound emitted + inpβ‚€ workβ‚€ outβ‚€ hcontent hstart hhead hinput hother houtput + +/-- Each emission pass is append-only on the output tape. -/ +theorem workEmitTM_isTransducer {n : β„•} + (idx : Fin n) (mode : WorkEmitMode) : + (workEmitTM idx mode).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | scan => + cases hread : wHeads idx <;> + simp [workEmitTM, hread, TM.allReadBack, TM.idleDir] <;> + split <;> cases oHead <;> simp + | done => + cases oHead <;> simp [workEmitTM, TM.allIdle, TM.idleDir] + +/-- Complete word emission is append-only on the output tape. -/ +theorem wordEncodeTM_isTransducer {n : β„•} (idx : Fin n) : + (wordEncodeTM idx).IsTransducer := + (workEmitTM_isTransducer idx .width).seqTM + ((TM.rewindWorkTM_isTransducer idx).seqTM + (workEmitTM_isTransducer idx .payload)) + +/-- Rewind-and-emit word encoding is append-only on the output tape. -/ +theorem rewindWordEncodeTM_isTransducer {n : β„•} (idx : Fin n) : + (rewindWordEncodeTM idx).IsTransducer := + (TM.rewindWorkTM_isTransducer idx).seqTM + (wordEncodeTM_isTransducer idx) + +/-- Coarse all-prefix auxiliary-space envelope for one emission pass. -/ +theorem workEmitTM_prefix_withinAuxSpace {n : β„•} + (idx : Fin n) (mode : WorkEmitMode) (bits : List Bool) + (inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (workEmitTM idx mode).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (workEmitTM idx mode).reachesIn time start current) + (htime : time ≀ workEmitTime bits) : + current.WithinAuxSpace inputLength + (initialSpace + workEmitTime bits) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Coarse all-prefix auxiliary-space envelope for complete word emission. -/ +theorem wordEncodeTM_prefix_withinAuxSpace {n : β„•} + (idx : Fin n) (value inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (wordEncodeTM idx).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (wordEncodeTM idx).reachesIn time start current) + (htime : time ≀ wordEncodeTime value) : + current.WithinAuxSpace inputLength + (initialSpace + wordEncodeTime value) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Coarse all-prefix envelope for rewind followed by word emission. -/ +theorem rewindWordEncodeTM_prefix_withinAuxSpace {n : β„•} + (idx : Fin n) (value headBound inputLength initialSpace time : β„•) + (start current : Complexity.Cfg n (rewindWordEncodeTM idx).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (rewindWordEncodeTM idx).reachesIn time start current) + (htime : time ≀ rewindWordEncodeTime value headBound) : + current.WithinAuxSpace inputLength + (initialSpace + rewindWordEncodeTime value headBound) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Defs.lean new file mode 100644 index 0000000000..ff612cef46 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Defs.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import Mathlib.Data.Nat.Bits +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Self-delimiting word emission β€” definitions + +The encoded-store update path needs to re-emit decoded entries. A generic +work-tape pass either emits one unary width mark per source bit or copies the +payload bits themselves. `wordEncodeTM` composes those passes around a rewind. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +/-- Which half of a self-delimiting word a work-tape pass emits. -/ +inductive WorkEmitMode where + | width + | payload + deriving DecidableEq + +/-- `WorkEmitMode` is a finite controller parameter. -/ +instance instFintypeWorkEmitMode : Fintype WorkEmitMode where + elems := {.width, .payload} + complete := fun mode => by cases mode <;> simp + +/-- Finite phases of one work-tape emission pass. -/ +inductive WorkEmitPhase where + | scan + | done + deriving DecidableEq + +/-- `WorkEmitPhase` has exactly two states. -/ +instance instFintypeWorkEmitPhase : Fintype WorkEmitPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- Bits emitted by one complete pass. Width mode emits unary length followed +by its zero separator; payload mode copies the source bits verbatim. -/ +def workEmitBits : WorkEmitMode β†’ List Bool β†’ List Bool + | .width, bits => List.replicate bits.length true ++ [false] + | .payload, bits => bits + +/-- Scan one canonical Boolean work tape and append either its unary-width +header or its payload to the output. -/ +def workEmitTM {n : β„•} (idx : Fin n) (mode : WorkEmitMode) : TM n where + Q := WorkEmitPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun phase iHead wHeads oHead => + match phase with + | .scan => + match wHeads idx with + | .zero => + (.scan, fun i => TM.readBackWrite (wHeads i), + if mode = .width then .one else .zero, + TM.idleDir iHead, + fun i => if i = idx then .right else TM.idleDir (wHeads i), + .right) + | .one => + (.scan, fun i => TM.readBackWrite (wHeads i), .one, + TM.idleDir iHead, + fun i => if i = idx then .right else TM.idleDir (wHeads i), + .right) + | .blank => + if mode = .width then + (.done, fun i => TM.readBackWrite (wHeads i), .zero, + TM.idleDir iHead, fun i => TM.idleDir (wHeads i), .right) + else + TM.allReadBack .done iHead wHeads oHead + | .start => TM.allReadBack .scan iHead wHeads oHead + | .done => TM.allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro phase iHead wHeads oHead + cases phase with + | scan => + cases hread : wHeads idx + Β· exact ⟨TM.idleDir_right_of_start, by + intro i hi + by_cases hidx : i = idx + Β· simp [hidx] + Β· simp [hidx, TM.idleDir_right_of_start hi], fun _ => rfl⟩ + Β· exact ⟨TM.idleDir_right_of_start, by + intro i hi + by_cases hidx : i = idx + Β· simp [hidx] + Β· simp [hidx, TM.idleDir_right_of_start hi], fun _ => rfl⟩ + Β· dsimp only + split + Β· exact ⟨TM.idleDir_right_of_start, + fun _ => TM.idleDir_right_of_start, fun _ => rfl⟩ + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + Β· exact TM.rightOfStart_allReadBack iHead wHeads oHead + | done => exact TM.rightOfStart_allIdle iHead wHeads oHead + +/-- Exact time of one work-tape emission pass. -/ +def workEmitTime (bits : List Bool) : β„• := bits.length + 1 + +/-- Emit one complete self-delimiting word from a canonical binary work tape. -/ +def wordEncodeTM {n : β„•} (idx : Fin n) : TM n := + TM.seqTM (workEmitTM idx .width) + (TM.seqTM (TM.rewindWorkTM idx) (workEmitTM idx .payload)) + +/-- Conservative exact-composition bound for one emitted natural. -/ +def wordEncodeTime (value : β„•) : β„• := + 3 * value.bits.length + 7 + +/-- Rewind an arbitrary positive cursor over canonical binary contents, then +emit the complete self-delimiting word. -/ +def rewindWordEncodeTM {n : β„•} (idx : Fin n) : TM n := + TM.seqTM (TM.rewindWorkTM idx) (wordEncodeTM idx) + +/-- Composition bound for rewind followed by complete word emission. -/ +def rewindWordEncodeTime (value headBound : β„•) : β„• := + headBound + 2 + 1 + wordEncodeTime value + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Internal.lean new file mode 100644 index 0000000000..2809b626f2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/RegisterStore/Machine/WordEncode/Internal.lean @@ -0,0 +1,496 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Machine.WordEncode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.RegisterStore.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs + +/-! +# Self-delimiting word emission β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace RegisterStore + +namespace Machine + +variable {n : β„•} + +private def workEmitBit (mode : WorkEmitMode) (bit : Bool) : Bool := + match mode with + | .width => true + | .payload => bit + +private theorem workEmitBits_cons (mode : WorkEmitMode) + (bit : Bool) (bits : List Bool) : + workEmitBits mode (bit :: bits) = + workEmitBit mode bit :: workEmitBits mode bits := by + cases mode <;> simp [workEmitBits, workEmitBit, List.replicate_succ] + +private theorem parked_of_binarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : TM.Parked t := + ⟨h.1, h.2.2.2⟩ + +private theorem parked_of_binaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : TM.Parked t := + ⟨by rw [h.1]; omega, + (show t.HasBinaryContent bits from h.2).cells_ne_start⟩ + +private theorem cells_eq_init_of_binaryContent {t : Tape} {bits : List Bool} + (h : t.HasBinaryContent bits) (hstart : t.cells 0 = Ξ“.start) : + t.cells = (Tape.init (bits.map Ξ“.ofBool)).cells := by + let parked : Tape := { head := bits.length + 1, cells := t.cells } + have hprefix : parked.HasBinaryPrefix bits := ⟨rfl, h⟩ + simpa [parked] using hprefix.cells_eq_init hstart + +theorem workEmitTM_reachesIn_frame_internal + (idx : Fin n) (mode : WorkEmitMode) : + βˆ€ (bits emitted : List Bool) + (c : Complexity.Cfg n (workEmitTM idx mode).Q), + c.state = WorkEmitPhase.scan β†’ + (c.work idx).HasBinarySuffix bits β†’ + TM.Parked c.input β†’ + (βˆ€ i, i β‰  idx β†’ TM.Parked (c.work i)) β†’ + c.output.HasBinaryPrefix emitted β†’ + βˆƒ c', + (workEmitTM idx mode).reachesIn (workEmitTime bits) c c' ∧ + (workEmitTM idx mode).halted c' ∧ + c'.input = c.input ∧ + (c'.work idx).HasBinarySuffix [] ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (c'.work idx).head = (c.work idx).head + bits.length ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = c.work i) ∧ + c'.output.HasBinaryPrefix (emitted ++ workEmitBits mode bits) := by + intro bits + induction bits with + | nil => + intro emitted c hstate hsource hinput hother houtput + have hsourceRead : (c.work idx).read = Ξ“.blank := hsource.read_nil + cases mode with + | width => + let c' : Complexity.Cfg n (workEmitTM idx .width).Q := + { state := WorkEmitPhase.done + input := TM.transitionInput c.input + work := fun i => TM.transitionTape (c.work i) + output := c.output.writeAndMove Ξ“.zero Dir3.right } + have hstep : (workEmitTM idx .width).step c = some c' := by + simp [TM.step, hstate, workEmitTM, hsourceRead, c', + TM.transitionInput, TM.transitionTape] + have hinputKeep : c'.input = c.input := by + simpa [c'] using TM.transitionInput_eq_self hinput.read_ne_start + have hsourceKeep : c'.work idx = c.work idx := by + simpa [c'] using TM.transitionTape_eq_self (by + rw [hsourceRead] + decide) + have hotherKeep (i) (hi : i β‰  idx) : c'.work i = c.work i := by + simpa [c'] using TM.transitionTape_eq_self (hother i hi).read_ne_start + have houtput' : + c'.output.HasBinaryPrefix (emitted ++ [false]) := by + simpa [c'] using! Tape.hasBinaryPrefix_write_bit false houtput + refine ⟨c', .step hstep .zero, rfl, hinputKeep, ?_, ?_, ?_, + hotherKeep, ?_⟩ + Β· rw [hsourceKeep] + exact hsource + Β· rw [hsourceKeep] + Β· rw [hsourceKeep] + simp + Β· simpa [workEmitBits] using houtput' + | payload => + let c' : Complexity.Cfg n (workEmitTM idx .payload).Q := + { state := WorkEmitPhase.done + input := TM.transitionInput c.input + work := fun i => TM.transitionTape (c.work i) + output := TM.transitionTape c.output } + have hstep : (workEmitTM idx .payload).step c = some c' := by + simp [TM.step, hstate, workEmitTM, hsourceRead, c', + TM.allReadBack, TM.transitionInput, TM.transitionTape] + have hinputKeep : c'.input = c.input := by + simpa [c'] using TM.transitionInput_eq_self hinput.read_ne_start + have hsourceKeep : c'.work idx = c.work idx := by + simpa [c'] using TM.transitionTape_eq_self (by + rw [hsourceRead] + decide) + have hotherKeep (i) (hi : i β‰  idx) : c'.work i = c.work i := by + simpa [c'] using TM.transitionTape_eq_self (hother i hi).read_ne_start + have houtputKeep : c'.output = c.output := by + simpa [c'] using TM.transitionTape_eq_self (by + rw [houtput.read_blank] + decide) + refine ⟨c', .step hstep .zero, rfl, hinputKeep, ?_, ?_, ?_, + hotherKeep, ?_⟩ + Β· rw [hsourceKeep] + exact hsource + Β· rw [hsourceKeep] + Β· rw [hsourceKeep] + simp + Β· rw [houtputKeep] + simpa [workEmitBits] + | cons bit bits ih => + intro emitted c hstate hsource hinput hother houtput + have hsourceRead : (c.work idx).read = Ξ“.ofBool bit := + hsource.read_cons + let c₁ : Complexity.Cfg n (workEmitTM idx mode).Q := + { state := WorkEmitPhase.scan + input := TM.transitionInput c.input + work := fun i => + (c.work i).writeAndMove (TM.readBackWrite (c.work i).read) + (if i = idx then Dir3.right else TM.idleDir (c.work i).read) + output := c.output.writeAndMove + (Ξ“.ofBool (workEmitBit mode bit)) Dir3.right } + have hstep : (workEmitTM idx mode).step c = some c₁ := by + cases mode <;> cases bit <;> + simp [TM.step, hstate, workEmitTM, hsourceRead, c₁, + TM.transitionInput, workEmitBit, Ξ“.ofBool] + have hinputKeep : c₁.input = c.input := by + simpa [c₁] using TM.transitionInput_eq_self hinput.read_ne_start + have hsourceMove : c₁.work idx = (c.work idx).move Dir3.right := by + rw [show c₁.work idx = + (c.work idx).writeAndMove (TM.readBackWrite (c.work idx).read) + Dir3.right by simp [c₁]] + exact TM.writeAndMove_readBack _ hsource.read_ne_start Dir3.right + have hotherKeep (i) (hi : i β‰  idx) : c₁.work i = c.work i := by + have htransition : c₁.work i = TM.transitionTape (c.work i) := by + simp [c₁, hi, TM.transitionTape] + rw [htransition] + exact TM.transitionTape_eq_self (hother i hi).read_ne_start + have hsource₁ : (c₁.work idx).HasBinarySuffix bits := by + rw [hsourceMove] + exact hsource.move_right_cons + have houtput₁ : c₁.output.HasBinaryPrefix + (emitted ++ [workEmitBit mode bit]) := by + simpa [c₁] using Tape.hasBinaryPrefix_write_bit + (workEmitBit mode bit) houtput + obtain ⟨c', hreach, hhalt, hinput', hsource', hsourceCells, + hsourceHead, hother', houtput'⟩ := + ih (emitted ++ [workEmitBit mode bit]) c₁ rfl hsource₁ + (hinputKeep β–Έ hinput) + (fun i hi => hotherKeep i hi β–Έ hother i hi) houtput₁ + refine ⟨c', ?_, hhalt, hinput'.trans hinputKeep, hsource', ?_, ?_, + ?_, ?_⟩ + Β· simpa [workEmitTime] using TM.reachesIn.step hstep hreach + Β· rw [hsourceCells, hsourceMove, Tape.move_cells] + Β· rw [hsourceHead, hsourceMove] + simp [Tape.move] + omega + Β· intro i hi + exact (hother' i hi).trans (hotherKeep i hi) + Β· rw [workEmitBits_cons] + simpa [List.append_assoc] using houtput' + +theorem workEmitTM_hoareTime_frame_internal + (idx : Fin n) (mode : WorkEmitMode) (bits emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsource : (workβ‚€ idx).HasBinarySuffix bits) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (workEmitTM idx mode).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = (workβ‚€ idx).head + bits.length ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ workEmitBits mode bits)) + (workEmitTime bits) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + obtain ⟨c', hreach, hhalt, hinput', hsource', hcells, hhead, + hframe, houtput'⟩ := + workEmitTM_reachesIn_frame_internal idx mode bits emitted + { state := WorkEmitPhase.scan + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + rfl hsource hinput hother houtput + exact ⟨c', workEmitTime bits, le_rfl, hreach, hhalt, hinput', + hsource', hcells, hhead, hframe, houtput'⟩ + +theorem wordEncodeTM_hoareTime_frame_internal + (idx : Fin n) (value : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (wordEncodeTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = value.bits.length + 1 ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ WordCode.encode value)) + (wordEncodeTime value) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hwidthContract := workEmitTM_hoareTime_frame_internal idx .width + value.bits emitted inpβ‚€ workβ‚€ outβ‚€ hvalue.2.hasBinarySuffix hinput + hother houtput + obtain ⟨widthDone, widthTime, hwidthTime, hwidthReach, hwidthHalt, + hwidthInput, hwidthSuffix, hwidthCells, hwidthHead, + hwidthFrame, hwidthOutput⟩ := + hwidthContract inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hwidthSourceParked : TM.Parked (widthDone.work idx) := + parked_of_binarySuffix hwidthSuffix + have hwidthWorkParked : βˆ€ i, TM.Parked (widthDone.work i) := by + intro i + by_cases hi : i = idx + Β· subst i + exact hwidthSourceParked + Β· rw [hwidthFrame i hi] + exact hother i hi + have hwidthOutputParked : TM.Parked widthDone.output := + parked_of_binaryPrefix hwidthOutput + obtain ⟨hwidthInputTransition, hwidthWorkTransition, + hwidthOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + (hwidthInput β–Έ hinput.read_ne_start) + (fun i => (hwidthWorkParked i).read_ne_start) + hwidthOutputParked.read_ne_start + have hwidthContent : + (widthDone.work idx).HasBinaryContent value.bits := by + simpa only [Tape.HasBinaryContent, hwidthCells] using + hvalue.2.hasBinaryContent + have hwidthStart : (widthDone.work idx).cells 0 = Ξ“.start := by + rw [hwidthCells] + exact hvalue.1 + have hwidthHeadBound : + 1 ≀ (widthDone.work idx).head ∧ + (widthDone.work idx).head ≀ value.bits.length + 1 := by + rw [hwidthHead, hvalue.2.1] + omega + have hrewindContract := TM.rewindBinaryWorkTM_hoareTime_frame idx + value.bits (value.bits.length + 1) widthDone.input widthDone.work + widthDone.output hwidthContent hwidthStart hwidthHeadBound + (hwidthInput β–Έ hinput) (fun i hi => hwidthWorkParked i) + hwidthOutputParked + obtain ⟨rewindDone, rewindTime, hrewindTime, hrewindReach, + hrewindHalt, hrewindInput, hrewindTarget, hrewindFrame, + hrewindOutput⟩ := + hrewindContract widthDone.input widthDone.work widthDone.output + ⟨rfl, rfl, rfl⟩ + have hrewindSourceString : + (rewindDone.work idx).HasBinaryString value.bits := by + rw [hrewindTarget] + exact Tape.init_move_right_hasBinaryString value.bits + have hrewindWorkParked : βˆ€ i, TM.Parked (rewindDone.work i) := by + intro i + by_cases hi : i = idx + Β· subst i + exact ⟨by rw [hrewindSourceString.1], + hrewindSourceString.hasBinaryContent.cells_ne_start⟩ + Β· rw [hrewindFrame i hi] + exact hwidthWorkParked i + have hrewindOutputPrefix : rewindDone.output.HasBinaryPrefix + (emitted ++ workEmitBits .width value.bits) := by + rw [hrewindOutput] + exact hwidthOutput + have hrewindOutputParked : TM.Parked rewindDone.output := + parked_of_binaryPrefix hrewindOutputPrefix + have hrewindInputParked : TM.Parked rewindDone.input := by + rw [hrewindInput, hwidthInput] + exact hinput + obtain ⟨hrewindInputTransition, hrewindWorkTransition, + hrewindOutputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hrewindInputParked.read_ne_start + (fun i => (hrewindWorkParked i).read_ne_start) + hrewindOutputParked.read_ne_start + have hpayloadContract := workEmitTM_hoareTime_frame_internal idx .payload + value.bits (emitted ++ workEmitBits .width value.bits) + rewindDone.input rewindDone.work rewindDone.output + hrewindSourceString.hasBinarySuffix + (by rw [hrewindInput, hwidthInput]; exact hinput) + (fun i hi => hrewindWorkParked i) hrewindOutputPrefix + obtain ⟨payloadDone, payloadTime, hpayloadTime, hpayloadReach, + hpayloadHalt, hpayloadInput, hpayloadSuffix, hpayloadCells, + hpayloadHead, hpayloadFrame, hpayloadOutput⟩ := + hpayloadContract rewindDone.input rewindDone.work rewindDone.output + ⟨rfl, rfl, rfl⟩ + have hpayloadReach' : (workEmitTM idx .payload).reachesIn payloadTime + { state := (workEmitTM idx .payload).qstart + input := TM.transitionInput rewindDone.input + work := fun i => TM.transitionTape (rewindDone.work i) + output := TM.transitionTape rewindDone.output } + payloadDone := by + simpa [hrewindInputTransition, hrewindWorkTransition, + hrewindOutputTransition] using hpayloadReach + have hrestReach := TM.seqTM_reachesIn_of_reachesIn + (TM.rewindWorkTM idx) (workEmitTM idx .payload) + hrewindReach hrewindHalt hpayloadReach' + have hrestReach' : + (TM.seqTM (TM.rewindWorkTM idx) (workEmitTM idx .payload)).reachesIn + (rewindTime + 1 + payloadTime) + { state := + (TM.seqTM (TM.rewindWorkTM idx) + (workEmitTM idx .payload)).qstart + input := TM.transitionInput widthDone.input + work := fun i => TM.transitionTape (widthDone.work i) + output := TM.transitionTape widthDone.output } + (TM.phase2Wrap (TM.rewindWorkTM idx) + (workEmitTM idx .payload) payloadDone) := by + simpa [hwidthInputTransition, hwidthWorkTransition, + hwidthOutputTransition] using! hrestReach + have hfullReach := TM.seqTM_reachesIn_of_reachesIn + (workEmitTM idx .width) + (TM.seqTM (TM.rewindWorkTM idx) (workEmitTM idx .payload)) + hwidthReach hwidthHalt hrestReach' + let finalCfg := TM.phase2Wrap (workEmitTM idx .width) + (TM.seqTM (TM.rewindWorkTM idx) (workEmitTM idx .payload)) + (TM.phase2Wrap (TM.rewindWorkTM idx) + (workEmitTM idx .payload) payloadDone) + refine ⟨finalCfg, + widthTime + 1 + (rewindTime + 1 + payloadTime), ?_, ?_, ?_, ?_⟩ + Β· unfold wordEncodeTime workEmitTime at * + omega + Β· exact hfullReach + Β· change + (TM.seqTM (workEmitTM idx .width) + (TM.seqTM (TM.rewindWorkTM idx) + (workEmitTM idx .payload))).halted finalCfg + exact (TM.phase2Wrap_halted_iff (workEmitTM idx .width) + (TM.seqTM (TM.rewindWorkTM idx) (workEmitTM idx .payload)) _).mpr + ((TM.phase2Wrap_halted_iff (TM.rewindWorkTM idx) + (workEmitTM idx .payload) payloadDone).mpr hpayloadHalt) + Β· refine ⟨?_, hpayloadSuffix, ?_, ?_, ?_, ?_⟩ + Β· simpa [finalCfg] using! + hpayloadInput.trans (hrewindInput.trans hwidthInput) + Β· have hcanonical := + Tape.eq_init_move_right_of_hasBinaryString hvalue.2 hvalue.1 + change (payloadDone.work idx).cells = (workβ‚€ idx).cells + rw [hpayloadCells, hrewindTarget] + exact congrArg Tape.cells hcanonical.symm + Β· have hrewindHead : (rewindDone.work idx).head = 1 := by + rw [hrewindTarget] + simp [Tape.move] + simpa [finalCfg, hrewindHead, Nat.add_comm] using! hpayloadHead + Β· intro i hi + simpa [finalCfg] using! + (hpayloadFrame i hi).trans + ((hrewindFrame i hi).trans (hwidthFrame i hi)) + Β· simpa [finalCfg, WordCode.encode, workEmitBits, bitlen, + Nat.toBitsLE_size, Nat.size_eq_bits_len, List.append_assoc] using! + hpayloadOutput + +theorem rewindWordEncodeTM_hoareTime_frame_internal + (idx : Fin n) (value headBound : β„•) (emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hcontent : (workβ‚€ idx).HasBinaryContent value.bits) + (hstart : (workβ‚€ idx).cells 0 = Ξ“.start) + (hhead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : TM.Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ TM.Parked (workβ‚€ i)) + (houtput : outβ‚€.HasBinaryPrefix emitted) : + (rewindWordEncodeTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinarySuffix [] ∧ + (work idx).cells = (workβ‚€ idx).cells ∧ + (work idx).head = value.bits.length + 1 ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out.HasBinaryPrefix (emitted ++ WordCode.encode value)) + (rewindWordEncodeTime value headBound) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hwork, hout⟩ + subst inp + subst work + subst out + have hrewindContract := TM.rewindBinaryWorkTM_hoareTime_frame idx + value.bits headBound inpβ‚€ workβ‚€ outβ‚€ hcontent hstart hhead hinput + hother (parked_of_binaryPrefix houtput) + obtain ⟨rewindDone, rewindTime, hrewindTime, hrewindReach, + hrewindHalt, hrewindInput, hrewindTarget, hrewindFrame, + hrewindOutput⟩ := + hrewindContract inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + have hrewindString : + (rewindDone.work idx).HasBinaryString value.bits := by + rw [hrewindTarget] + exact Tape.init_move_right_hasBinaryString value.bits + have hrewindWorkParked : βˆ€ i, TM.Parked (rewindDone.work i) := by + intro i + by_cases hi : i = idx + Β· subst i + exact ⟨by rw [hrewindString.1], + hrewindString.hasBinaryContent.cells_ne_start⟩ + Β· rw [hrewindFrame i hi] + exact hother i hi + have hrewindOutputPrefix : rewindDone.output.HasBinaryPrefix emitted := by + rw [hrewindOutput] + exact houtput + have hrewindInputParked : TM.Parked rewindDone.input := by + rw [hrewindInput] + exact hinput + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + TM.phaseTransition_eq_self_of_reads_ne_start + hrewindInputParked.read_ne_start + (fun i => (hrewindWorkParked i).read_ne_start) + (parked_of_binaryPrefix hrewindOutputPrefix).read_ne_start + have hencodeContract := wordEncodeTM_hoareTime_frame_internal idx value emitted + rewindDone.input rewindDone.work rewindDone.output + ⟨by rw [hrewindTarget]; simp [Tape.init, Tape.move], hrewindString⟩ + (by rw [hrewindInput]; exact hinput) + (fun i _ => hrewindWorkParked i) hrewindOutputPrefix + obtain ⟨encodeDone, encodeTime, hencodeTime, hencodeReach, + hencodeHalt, hencodeInput, hencodeSuffix, hencodeCells, + hencodeHead, hencodeFrame, hencodeOutput⟩ := + hencodeContract rewindDone.input rewindDone.work rewindDone.output + ⟨rfl, rfl, rfl⟩ + have hencodeReach' : (wordEncodeTM idx).reachesIn encodeTime + { state := (wordEncodeTM idx).qstart + input := TM.transitionInput rewindDone.input + work := fun i => TM.transitionTape (rewindDone.work i) + output := TM.transitionTape rewindDone.output } + encodeDone := by + simpa [hinputTransition, hworkTransition, houtputTransition] using + hencodeReach + have hreach := TM.seqTM_reachesIn_of_reachesIn + (TM.rewindWorkTM idx) (wordEncodeTM idx) + hrewindReach hrewindHalt hencodeReach' + let finalCfg := TM.phase2Wrap (TM.rewindWorkTM idx) + (wordEncodeTM idx) encodeDone + refine ⟨finalCfg, rewindTime + 1 + encodeTime, ?_, hreach, ?_, ?_⟩ + Β· unfold rewindWordEncodeTime + omega + Β· change (rewindWordEncodeTM idx).halted finalCfg + unfold rewindWordEncodeTM + rw [TM.phase2Wrap_halted_iff] + exact hencodeHalt + Β· refine ⟨?_, hencodeSuffix, ?_, ?_, ?_, ?_⟩ + Β· simpa [finalCfg] using! hencodeInput.trans hrewindInput + Β· change (encodeDone.work idx).cells = (workβ‚€ idx).cells + rw [hencodeCells, hrewindTarget] + exact (cells_eq_init_of_binaryContent hcontent hstart).symm + Β· simpa [finalCfg] using! hencodeHead + Β· intro i hi + change encodeDone.work i = workβ‚€ i + exact (hencodeFrame i hi).trans (hrewindFrame i hi) + Β· simpa [finalCfg] using! hencodeOutput + +end Machine + +end RegisterStore + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig.lean new file mode 100644 index 0000000000..dacae9dd64 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Internal + +/-! +# Bounded Turing-machine configurations in RAM registers + +This module exposes the first representation layer of the Turing-machine to RAM +simulation. The register layout is explicit, blank cells use value zero, and +`decode_encode` states the exact condition under which bounded decoding loses no +information. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} + +/-- The state field is register zero. -/ +@[simp] theorem fieldReg_state : + fieldReg (stateField (n := n) (bound := bound)) = 0 := + fieldReg_state_internal + +/-- Head registers immediately follow the state, in input/work/output order. -/ +@[simp] theorem fieldReg_head (tape : Fin (n + 2)) : + fieldReg (headField (bound := bound) tape) = 1 + tape.val := + fieldReg_head_internal tape + +/-- Cell blocks follow all head registers, ordered by tape and position. -/ +@[simp] theorem fieldReg_cell (tape : Fin (n + 2)) + (position : Fin (bound + 1)) : + fieldReg (cellField tape position) = + 1 + (n + 2) + tape.val * (bound + 1) + position.val := + fieldReg_cell_internal tape position + +/-- Symbol coding is lossless on the four-symbol tape alphabet. -/ +theorem symbolDecode_code (symbol : Ξ“) : + symbolDecode (symbolCode symbol) = symbol := + symbolDecode_code_internal symbol + +/-- Canonical finite-state coding is lossless. -/ +theorem stateDecode_code (tm : TM n) (state : tm.Q) : + stateDecode tm (stateCode tm state) = state := + stateDecode_code_internal tm state + +/-- Reading an encoded field returns exactly that field's value. -/ +theorem encodeRegs_field (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (field : Field n bound) : + encodeRegs tm bound cfg (fieldReg field) = fieldValue tm bound cfg field := + encodeRegs_field_internal tm bound cfg field + +/-- Every field address lies inside the explicit configuration prefix. -/ +theorem fieldReg_lt (field : Field n bound) : + fieldReg field < registerCount n bound := + fieldReg_lt_internal field + +/-- Distinct configuration fields occupy distinct registers. -/ +theorem fieldReg_injective : Function.Injective (@fieldReg n bound) := + fieldReg_injective_internal + +/-- Updating a scratch register beyond the configuration prefix preserves every +represented field. -/ +theorem Represents.update_outside {tm : TM n} {bound reg value : β„•} + {cfg : Complexity.Cfg n tm.Q} {regs : β„• β†’ β„•} + (hrepresents : Represents tm bound cfg regs) + (hreg : registerCount n bound ≀ reg) : + Represents tm bound cfg (Function.update regs reg value) := + hrepresents.update_outside_internal hreg + +/-- The canonical bounded encoding represents every one of its fields. -/ +theorem encodeRegs_represents (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : + Represents tm bound cfg (encodeRegs tm bound cfg) := + encodeRegs_represents_internal tm bound cfg + +/-- Any representing store decodes to its configuration when the omitted tape +suffixes are blank. Scratch registers do not affect decoding. -/ +theorem decode_of_represents (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (regs : β„• β†’ β„•) + (hrepresents : Represents tm bound cfg regs) + (hbounded : Bounded cfg bound) : decode tm bound regs = cfg := + decode_of_represents_internal tm bound cfg regs hrepresents hbounded + +/-- Decoding an encoded bounded configuration recovers it exactly. -/ +theorem decode_encode (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (hbounded : Bounded cfg bound) : + decode tm bound (encode tm bound cfg).regs = cfg := + decode_encode_internal tm bound cfg hbounded + +/-- Registers beyond the explicit bounded layout are zero. -/ +theorem encodeRegs_outside (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) {reg : β„•} + (hreg : registerCount n bound ≀ reg) : + encodeRegs tm bound cfg reg = 0 := + encodeRegs_outside_internal tm bound cfg hreg + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Defs.lean new file mode 100644 index 0000000000..62d8928874 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Defs.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs +public import Mathlib.Logic.Equiv.Fin.Basic + +/-! +# Bounded Turing-machine configurations in RAM registers + +This file fixes the register representation used by the Turing-machine to RAM +simulation. Register zero stores the finite-state code, the next `n + 2` +registers store the input/work/output head positions, and the remaining +registers store a dense bounded window of every named tape. + +Blank symbols use code zero. Consequently registers outside the representation +and blank cells inside it agree with the RAM's finite-support convention. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} + +/-- A field in a bounded configuration: state, a named tape head, or a named +tape cell. Named tapes use input/work/output indices `0, 1..n, n+1`. -/ +abbrev Field (n bound : β„•) := + Fin 1 βŠ• (Fin (n + 2) βŠ• (Fin (n + 2) Γ— Fin (bound + 1))) + +/-- Number of registers occupied by a configuration with cells `0..bound`. -/ +def registerCount (n bound : β„•) : β„• := + 1 + ((n + 2) + (n + 2) * (bound + 1)) + +/-- Explicit contiguous ordering of all fields in the bounded representation. -/ +noncomputable def fieldEquiv (n bound : β„•) : + Field n bound ≃ Fin (registerCount n bound) := + (Equiv.sumCongr (Equiv.refl (Fin 1)) + ((Equiv.sumCongr (Equiv.refl (Fin (n + 2))) finProdFinEquiv).trans + finSumFinEquiv)).trans + finSumFinEquiv + +/-- The field holding the Turing-machine state. -/ +def stateField : Field n bound := Sum.inl ⟨0, by omega⟩ + +/-- The field holding one named tape's head position. -/ +def headField (tape : Fin (n + 2)) : Field n bound := + Sum.inr (Sum.inl tape) + +/-- The field holding one cell of one named tape. -/ +def cellField (tape : Fin (n + 2)) (position : Fin (bound + 1)) : + Field n bound := + Sum.inr (Sum.inr (tape, position)) + +/-- Concrete register address of a bounded-configuration field. -/ +noncomputable def fieldReg (field : Field n bound) : β„• := + (fieldEquiv n bound field).val + +/-- Code the tape alphabet with blank represented by zero. -/ +def symbolCode : Ξ“ β†’ β„• + | .blank => 0 + | .zero => 1 + | .one => 2 + | .start => 3 + +/-- Decode a RAM word as a tape symbol; invalid words decode to blank. -/ +def symbolDecode : β„• β†’ Ξ“ + | 1 => .zero + | 2 => .one + | 3 => .start + | _ => .blank + +/-- Canonical numeric code of a finite Turing-machine state. -/ +noncomputable def stateCode (tm : TM n) (state : tm.Q) : β„• := + (Fintype.equivFin tm.Q state).val + +/-- Decode a valid state code, using the start state as the default for an +invalid RAM word. -/ +noncomputable def stateDecode (tm : TM n) (code : β„•) : tm.Q := + if h : code < Fintype.card tm.Q then + (Fintype.equivFin tm.Q).symm ⟨code, h⟩ + else tm.qstart + +/-- Select a named tape by its input/work/output index. -/ +def tapeAt (cfg : Complexity.Cfg n Q) (tape : Fin (n + 2)) : Tape := + if hinput : tape.val = 0 then cfg.input + else if houtput : tape.val = n + 1 then cfg.output + else cfg.work ⟨tape.val - 1, by omega⟩ + +/-- A tape is contained in the encoded window when every later cell is blank. -/ +def TapeBounded (tape : Tape) (bound : β„•) : Prop := + βˆ€ position, bound < position β†’ tape.cells position = Ξ“.blank + +/-- Every named tape in a configuration is contained in the encoded window. -/ +def Bounded (cfg : Complexity.Cfg n Q) (bound : β„•) : Prop := + βˆ€ tape, TapeBounded (tapeAt cfg tape) bound + +/-- Every named head lies inside the encoded cell window. -/ +def HeadsBounded (cfg : Complexity.Cfg n Q) (bound : β„•) : Prop := + βˆ€ tape, (tapeAt cfg tape).head ≀ bound + +/-- A configuration can be stepped inside a bounded representation when both +its nonblank cells and every named head lie in the represented window. -/ +def WithinWindow (cfg : Complexity.Cfg n Q) (bound : β„•) : Prop := + Bounded cfg bound ∧ HeadsBounded cfg bound + +/-- Natural-number value stored for one representation field. -/ +noncomputable def fieldValue (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : Field n bound β†’ β„• + | Sum.inl _ => stateCode tm cfg.state + | Sum.inr (Sum.inl tape) => (tapeAt cfg tape).head + | Sum.inr (Sum.inr (tape, position)) => + symbolCode ((tapeAt cfg tape).cells position.val) + +/-- Register store containing a bounded Turing-machine configuration. -/ +noncomputable def encodeRegs (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• β†’ β„• := + fun reg => + if h : reg < registerCount n bound then + fieldValue tm bound cfg ((fieldEquiv n bound).symm ⟨reg, h⟩) + else 0 + +/-- A RAM store represents a bounded TM configuration when every state/head/cell +field has its prescribed value. Scratch registers outside this interface are +deliberately unconstrained, allowing successive simulation blocks to compose. -/ +def Represents (tm : TM n) (bound : β„•) (cfg : Complexity.Cfg n tm.Q) + (regs : β„• β†’ β„•) : Prop := + βˆ€ field, regs (fieldReg field) = fieldValue tm bound cfg field + +/-- RAM configuration positioned at the beginning of a simulation block. -/ +noncomputable def encode (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : RAM.Cfg := + { pc := 0, regs := encodeRegs tm bound cfg } + +/-- Decode one tape from its head register and bounded cell block. -/ +noncomputable def decodeTape (bound : β„•) (regs : β„• β†’ β„•) + (tape : Fin (n + 2)) : Tape where + head := regs (fieldReg (headField (bound := bound) tape)) + cells := fun position => + if h : position < bound + 1 then + symbolDecode (regs (fieldReg (cellField tape ⟨position, h⟩))) + else Ξ“.blank + +/-- Decode a bounded register layout into a Turing-machine configuration. -/ +noncomputable def decode (tm : TM n) (bound : β„•) (regs : β„• β†’ β„•) : + Complexity.Cfg n tm.Q where + state := stateDecode tm (regs (fieldReg (stateField (n := n) (bound := bound)))) + input := decodeTape (n := n) bound regs ⟨0, by omega⟩ + work := fun i => decodeTape (n := n) bound regs ⟨i.val + 1, by omega⟩ + output := decodeTape (n := n) bound regs ⟨n + 1, by omega⟩ + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Internal.lean new file mode 100644 index 0000000000..cc8ca1dc22 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Internal.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs + +/-! +# Bounded Turing-machine configuration encoding -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} + +theorem fieldReg_state_internal : + fieldReg (stateField (n := n) (bound := bound)) = 0 := by + rfl + +theorem fieldReg_head_internal (tape : Fin (n + 2)) : + fieldReg (headField (bound := bound) tape) = 1 + tape.val := by + rfl + +theorem fieldReg_cell_internal (tape : Fin (n + 2)) + (position : Fin (bound + 1)) : + fieldReg (cellField tape position) = + 1 + (n + 2) + tape.val * (bound + 1) + position.val := by + simp [fieldReg, cellField, fieldEquiv, finProdFinEquiv, Nat.mul_comm] + simp [finSumFinEquiv] + change 1 + (n + 2 + (position.val + tape.val * (bound + 1))) = _ + omega + +theorem symbolDecode_code_internal (symbol : Ξ“) : + symbolDecode (symbolCode symbol) = symbol := by + cases symbol <;> rfl + +theorem stateDecode_code_internal (tm : TM n) (state : tm.Q) : + stateDecode tm (stateCode tm state) = state := by + simp [stateDecode, stateCode] + +theorem tapeAt_input_internal (cfg : Complexity.Cfg n Q) : + tapeAt cfg ⟨0, by omega⟩ = cfg.input := by + simp [tapeAt] + +theorem tapeAt_work_internal (cfg : Complexity.Cfg n Q) (i : Fin n) : + tapeAt cfg ⟨i.val + 1, by omega⟩ = cfg.work i := by + simp only [tapeAt] + rw [dite_eq_right (by omega), dite_eq_right (by omega)] + congr 1 + +theorem tapeAt_output_internal (cfg : Complexity.Cfg n Q) : + tapeAt cfg ⟨n + 1, by omega⟩ = cfg.output := by + simp [tapeAt] + +theorem encodeRegs_field_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (field : Field n bound) : + encodeRegs tm bound cfg (fieldReg field) = fieldValue tm bound cfg field := by + have hreg : fieldReg field < registerCount n bound := + (fieldEquiv n bound field).isLt + unfold encodeRegs + rw [dif_pos hreg] + have hfield : + (⟨fieldReg field, hreg⟩ : Fin (registerCount n bound)) = + fieldEquiv n bound field := by + apply Fin.ext + rfl + rw [hfield, Equiv.symm_apply_apply] + +theorem fieldReg_lt_internal (field : Field n bound) : + fieldReg field < registerCount n bound := + (fieldEquiv n bound field).isLt + +theorem fieldReg_injective_internal : + Function.Injective (@fieldReg n bound) := by + intro first second heq + apply (fieldEquiv n bound).injective + exact Fin.ext heq + +theorem Represents.update_outside_internal {tm : TM n} {bound reg value : β„•} + {cfg : Complexity.Cfg n tm.Q} {regs : β„• β†’ β„•} + (hrepresents : Represents tm bound cfg regs) + (hreg : registerCount n bound ≀ reg) : + Represents tm bound cfg (Function.update regs reg value) := by + intro field + rw [Function.update_of_ne] + Β· exact hrepresents field + Β· exact fun heq => (not_lt_of_ge hreg) (heq β–Έ fieldReg_lt_internal field) + +theorem encodeRegs_represents_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : + Represents tm bound cfg (encodeRegs tm bound cfg) := + encodeRegs_field_internal tm bound cfg + +private theorem decodeTape_of_represents (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (regs : β„• β†’ β„•) + (hrepresents : Represents tm bound cfg regs) + (hbounded : Bounded cfg bound) (tape : Fin (n + 2)) : + decodeTape bound regs tape = tapeAt cfg tape := by + apply Tape.ext + Β· simp only [decodeTape] + rw [hrepresents (headField (bound := bound) tape)] + rfl + Β· funext position + by_cases hposition : position < bound + 1 + Β· simp only [decodeTape, hposition, dif_pos] + rw [hrepresents (cellField tape ⟨position, hposition⟩)] + exact symbolDecode_code_internal _ + Β· simp only [decodeTape, hposition] + exact (hbounded tape position (by omega)).symm + +theorem decode_of_represents_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (regs : β„• β†’ β„•) + (hrepresents : Represents tm bound cfg regs) + (hbounded : Bounded cfg bound) : decode tm bound regs = cfg := by + apply Complexity.Cfg.ext + Β· simp only [decode] + rw [hrepresents (stateField (n := n) (bound := bound))] + exact stateDecode_code_internal tm cfg.state + Β· simpa [decode, tapeAt_input_internal] using! + decodeTape_of_represents tm bound cfg regs hrepresents hbounded + ⟨0, by omega⟩ + Β· funext i + simpa [decode, tapeAt_work_internal] using + decodeTape_of_represents tm bound cfg regs hrepresents hbounded + ⟨i.val + 1, by omega⟩ + Β· simpa [decode, tapeAt_output_internal] using + decodeTape_of_represents tm bound cfg regs hrepresents hbounded + ⟨n + 1, by omega⟩ + +theorem decode_encode_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (hbounded : Bounded cfg bound) : + decode tm bound (encode tm bound cfg).regs = cfg := by + exact decode_of_represents_internal tm bound cfg (encode tm bound cfg).regs + (encodeRegs_represents_internal tm bound cfg) hbounded + +theorem encodeRegs_outside_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) {reg : β„•} + (hreg : registerCount n bound ≀ reg) : + encodeRegs tm bound cfg reg = 0 := by + simp [encodeRegs, Nat.not_lt.mpr hreg] + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse.lean new file mode 100644 index 0000000000..59c7a2d53f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Internal + +/-! +# Sparse unbounded TM configurations in RAM registers + +This is the fixed-layout representation used for the uniform TM-to-RAM +simulation. Unlike the bounded dense layout, its addresses do not depend on an +input length or running-time bound. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Distinct sparse fields occupy distinct RAM registers. -/ +theorem fieldReg_injective : Function.Injective (@fieldReg n) := + fieldReg_injective_internal + +/-- The canonical sparse encoding represents every state, head, and cell. -/ +theorem encodeRegs_represents (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + Represents tm cfg (encodeRegs tm cfg) := + encodeRegs_represents_internal tm cfg + +/-- Any representing sparse store decodes to its complete configuration; no +external cell-window premise is needed. -/ +theorem decode_of_represents (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (store : Structured.Store) (hrepresents : Represents tm cfg store) : + decode tm store = cfg := + decode_of_represents_internal tm cfg store hrepresents + +/-- Sparse encoding followed by decoding is exact for every configuration. -/ +theorem decode_encode (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + decode tm (encodeRegs tm cfg) = cfg := + decode_encode_internal tm cfg + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI.lean new file mode 100644 index 0000000000..8be9b01f00 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Resources + +/-! +# Public RAM ABI for the fixed sparse TM simulator + +The public RAM convention stores the input length in `Rβ‚€` and its raw bits in +`R₁, …, Rβ‚™`. The fixed marshaller relocates that unbounded prefix into the +sparse TM layout without assuming a length bound, despite its scratch registers +potentially overlapping the raw input. The complete decision program then runs +the fixed sparse simulator to a halted TM configuration and returns a public +Boolean verdict in `Rβ‚€`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- The fixed marshaller converts the public RAM input store into a complete +sparse representation of the TM's initial configuration. -/ +theorem marshalInput_correct (tm : TM n) (x : List Bool) : + βˆƒ final steps cost space, + Structured.Exec (marshalInput tm) (initRegs x) final steps cost space ∧ + Represents tm (tm.initCfg x) final := + marshalInput_exec_internal tm x + +/-- The complete fixed source program follows any exact halting TM run and +returns its output bit using the public RAM verdict convention `0/1`. -/ +theorem decisionProgram_correct {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := + decisionProgram_exec_internal hreach hhalted + +/-- Exact concrete-RAM transfer for the complete public-ABI simulator. Source +and target agree on final registers, logarithmic cost, and peak space. -/ +theorem compiledDecision_correct {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + run (compiledDecision tm) sourceSteps (initCfg x) = + { pc := (decisionProgram tm).codeSize, regs := final } ∧ + Halted (compiledDecision tm) + (run (compiledDecision tm) sourceSteps (initCfg x)) ∧ + logTimeUpto (compiledDecision tm) sourceSteps (initCfg x) = cost ∧ + spaceUpto (compiledDecision tm) sourceSteps (initCfg x) = space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := + compiledDecision_exec_internal hreach hhalted + +/-- Concrete end-to-end resource transfer from the public RAM input ABI. The +program depends only on `tm`; a `steps`-step halting TM run determines bounded +RAM fuel, logarithmic cost, sparse-store space, and the same verdict. -/ +theorem compiledDecision_resourceBound {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + cost ≀ decisionTimeBound tm x.length steps ∧ + space ≀ spaceBound tm (marshalBound n x.length + steps) ∧ + run (compiledDecision tm) sourceSteps (initCfg x) = + { pc := (decisionProgram tm).codeSize, regs := final } ∧ + Halted (compiledDecision tm) + (run (compiledDecision tm) sourceSteps (initCfg x)) ∧ + logTimeUpto (compiledDecision tm) sourceSteps (initCfg x) = cost ∧ + spaceUpto (compiledDecision tm) sourceSteps (initCfg x) = space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := + compiledDecision_resourceBound_internal hreach hhalted + +/-- Increasing the simulated TM step budget only increases the advertised +end-to-end public-ABI cost bound. -/ +theorem decisionTimeBound_mono_steps (tm : TM n) (inputLength : β„•) + {steps larger : β„•} (hle : steps ≀ larger) : + decisionTimeBound tm inputLength steps ≀ + decisionTimeBound tm inputLength larger := + decisionTimeBound_mono_steps_internal tm inputLength hle + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Defs.lean new file mode 100644 index 0000000000..175130f67f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Defs.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Defs + +/-! +# Public RAM input/output ABI for the sparse TM simulator + +The public RAM input occupies the unbounded prefix `R₁, …, Rβ‚™`, so no fixed +scratch register is initially disjoint from every input. The marshaller first +captures the six registers it must clobber in finite control flow. Each leaf +then copies the raw input backward into the sparse input tape while clearing the +old prefix, repairs those six statically remembered bits, and initializes the +state, heads, and left-end markers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Fixed registers clobbered before the backward input-copy loop reaches them. -/ +def captureRegs (n : β„•) : List β„• := + [zeroReg n, oneReg n, tapeCountReg n, stateScratchReg n, + addressReg n, valueReg n] + +/-- Constants needed by each backward-copy iteration. They are restored inside +the loop because clearing the raw prefix eventually visits these registers. -/ +def marshalConstants (n : β„•) : List Structured.Basic := + [.imm (zeroReg n) 0, + .imm (oneReg n) 1, + .imm (tapeCountReg n) (n + 2), + .imm (stateScratchReg n) (cellBase n)] + +/-- Copy and clear the raw input cell selected by the cursor in `Rβ‚€`, convert +its public-ABI Boolean code `0/1` to the sparse tape-symbol code `1/2`, write it +to the sparse input-tape address, and decrement the cursor. -/ +def marshalLoopOps (n : β„•) : List Structured.Basic := + [.add (addressReg n) stateReg (zeroReg n), + .load (valueReg n) (addressReg n), + .store (addressReg n) (zeroReg n), + .imm (zeroReg n) 0, + .imm (oneReg n) 1, + .imm (tapeCountReg n) (n + 2), + .imm (stateScratchReg n) (cellBase n), + .add (valueReg n) (valueReg n) (oneReg n), + .mul (addressReg n) stateReg (tapeCountReg n), + .add (addressReg n) (addressReg n) (stateScratchReg n), + .store (addressReg n) (valueReg n), + .sub stateReg stateReg (oneReg n)] + +/-- Backward raw-input copy. -/ +def marshalLoop (n : β„•) : Structured.Cmd := + .whileNonzero stateReg (.basics (marshalLoopOps n)) + +/-- Exact source/compiled instruction count of the backward-copy loop. -/ +def marshalLoopSteps (n inputLength : β„•) : β„• := + inputLength * ((marshalLoopOps n).length + 2) + 1 + +/-- Initial numeric allowance for public-input marshalling. It contains every +raw input register and every sparse destination address used by the copy. -/ +def marshalBaseBound (n inputLength : β„•) : β„• := + registerBound n (inputLength + 1) + +/-- Common sparse position/resource bound used after marshalling. The additive +input-length slack absorbs the one-unit value growth of every loop body. -/ +def marshalBound (n inputLength : β„•) : β„• := + marshalBaseBound n inputLength + inputLength + +/-- Logarithmic-cost width used by the public-input marshaller. -/ +def marshalWidth (n inputLength : β„•) : β„• := + bitlen (marshalBound n inputLength) + 1 + +/-- Width of the smaller envelope used before the copy loop starts. -/ +def marshalBaseWidth (n inputLength : β„•) : β„• := + bitlen (marshalBaseBound n inputLength) + 1 + +/-- Sparse-store space envelope used throughout public-input marshalling. -/ +def marshalSpaceBound (n inputLength : β„•) : β„• := + registerBound n (marshalBound n inputLength + 1) * + (bitlen (registerBound n (marshalBound n inputLength + 1)) + + bitlen (marshalBound n inputLength)) + +/-- Concrete logarithmic-cost bound for the backward-copy loop. -/ +def marshalLoopTimeBound (n inputLength : β„•) : β„• := + (inputLength * (3 + 4 * (marshalLoopOps n).length) + 1) * + marshalWidth n inputLength + +/-- Restore one input bit remembered in the capture tree, but only when the +copy loop actually visited that position. A visited destination is necessarily +positive because the loop writes `rawBit + 1`; an absent position remains the +initial zero beyond the raw input prefix. -/ +def repairBit (n : β„•) (captured : β„• Γ— β„•) : Structured.Cmd := + .seq + (.basics + [.imm (addressReg n) (cellReg n (inputTape n) captured.1), + .load (valueReg n) (addressReg n)]) + (.ifZero (valueReg n) .skip + (.basics + [.imm (valueReg n) (captured.2 + 1), + .store (addressReg n) (valueReg n)])) + +/-- Restore all visited scratch-position input bits remembered by a +capture-tree leaf. -/ +def repairCaptured (n : β„•) (captured : List (β„• Γ— β„•)) : + Structured.Cmd := + match captured with + | [] => .skip + | entry :: rest => .seq (repairBit n entry) (repairCaptured n rest) + +/-- Values accumulated by the capture tree, in the same reverse order used by +`captureInput`. -/ +def captureValues (store : Structured.Store) : + List β„• β†’ List (β„• Γ— β„•) β†’ List (β„• Γ— β„•) + | [], captured => captured + | reg :: rest, captured => + captureValues store rest ((reg, store reg) :: captured) + +/-- Immediate writes that initialize the semantic fields of `tm.initCfg` after +the raw input prefix has been relocated and cleared. -/ +noncomputable def initializeConfigWrites (tm : TM n) : List (β„• Γ— β„•) := + [(stateReg, stateCode tm tm.qstart)] ++ + (List.finRange (n + 2)).map (fun tape => (headReg tape, 0)) ++ + (List.finRange (n + 2)).map (fun tape => + (cellReg n tape 0, symbolCode Ξ“.start)) + +/-- Straight-line realization of the initial-configuration writes. -/ +noncomputable def initializeConfigOps (tm : TM n) : List Structured.Basic := + (initializeConfigWrites tm).map fun write => + .imm write.1 write.2 + +/-- Concrete cost bound for one selected capture-tree leaf. -/ +noncomputable def marshalLeafTimeBound (tm : TM n) (inputLength : β„•) : β„• := + 4 * (marshalConstants n).length * marshalBaseWidth n inputLength + + marshalLoopTimeBound n inputLength + + (captureRegs n).length * (27 * wordWidth tm (marshalBound n inputLength)) + + 4 * (initializeConfigOps tm).length * + wordWidth tm (marshalBound n inputLength) + +/-- Concrete cost bound for the full public-input marshaller, including the +fixed capture tree. -/ +noncomputable def marshalTimeBound (tm : TM n) (inputLength : β„•) : β„• := + 3 * (captureRegs n).length * wordWidth tm (marshalBound n inputLength) + + marshalLeafTimeBound tm inputLength + +/-- One capture-tree leaf: initialize scratch constants, copy backward, repair +captured positions, and establish the sparse initial configuration. -/ +noncomputable def marshalLeaf (tm : TM n) + (captured : List (β„• Γ— β„•)) : Structured.Cmd := + .seq (.basics (marshalConstants n)) + (.seq (marshalLoop n) + (.seq (repairCaptured n captured) + (.basics (initializeConfigOps tm)))) + +/-- Capture the initial Boolean contents of a finite register list in control +flow. The zero/nonzero branches record canonical numeric values `0` and `1`. -/ +noncomputable def captureInput (tm : TM n) : + List β„• β†’ List (β„• Γ— β„•) β†’ Structured.Cmd + | [], captured => marshalLeaf tm captured + | reg :: rest, captured => + .ifZero reg + (captureInput tm rest ((reg, 0) :: captured)) + (captureInput tm rest ((reg, 1) :: captured)) + +/-- Fixed public-ABI marshaller for `tm`. -/ +noncomputable def marshalInput (tm : TM n) : Structured.Cmd := + captureInput tm (captureRegs n) [] + +/-- Copy the halted TM output symbol at cell one into public verdict register +`Rβ‚€` and shift the sparse symbol codes `1/2` back to public verdicts `0/1`. +This intentionally destroys the final sparse state code. -/ +def extractVerdictOps (n : β„•) : List Structured.Basic := + [.imm (addressReg n) (cellReg n (outputTape n) 1), + .load stateReg (addressReg n), + .imm (oneReg n) 1, + .sub stateReg stateReg (oneReg n)] + +/-- End-to-end logarithmic-cost bound from the public ABI through verdict +extraction for a halting run of the given length. -/ +noncomputable def decisionTimeBound (tm : TM n) + (inputLength steps : β„•) : β„• := + marshalTimeBound tm inputLength + + ((steps + 1) * runFactor tm) * + wordWidth tm (marshalBound n inputLength + steps) + + 4 * (extractVerdictOps n).length * + wordWidth tm (marshalBound n inputLength + steps) + +/-- Complete fixed source program from the public RAM input ABI to verdict +register `Rβ‚€`. -/ +noncomputable def decisionProgram (tm : TM n) : Structured.Cmd := + .seq (marshalInput tm) + (.seq (runUntilHalt tm) (.basics (extractVerdictOps n))) + +/-- Concrete compiled public-ABI simulator. -/ +noncomputable def compiledDecision (tm : TM n) : Program := + (decisionProgram tm).compile + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal.lean new file mode 100644 index 0000000000..43a7810c39 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Capture +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Marshal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Resources + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Capture.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Capture.lean new file mode 100644 index 0000000000..3420c82ad5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Capture.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Defs +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Capturing raw-input scratch bits in finite control -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +theorem initRegs_bool_of_pos_internal (x : List Bool) {reg : β„•} + (hpos : 0 < reg) : initRegs x reg = 0 ∨ initRegs x reg = 1 := by + rw [initRegs, ite_eq_right (by omega)] + cases hbit : x[reg - 1]? with + | none => simp + | some bit => + cases bit <;> simp + +theorem captureRegs_positive_internal (n : β„•) {reg : β„•} + (hmem : reg ∈ captureRegs n) : 0 < reg := by + simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg] at hmem + rcases hmem with h | h | h | h | h | h <;> omega + +/-- If the selected leaf executes, the generated capture tree executes that +same leaf without changing the store. Branch costs are left existential here; +the later resource layer assigns their common envelope. -/ +theorem captureInput_exec_of_leaf_internal (tm : TM n) + (store : Structured.Store) (regs : List β„•) + (captured : List (β„• Γ— β„•)) {final : Structured.Store} + (hbits : βˆ€ reg, reg ∈ regs β†’ store reg = 0 ∨ store reg = 1) + (hleaf : βˆƒ steps cost space, + Structured.Exec (marshalLeaf tm (captureValues store regs captured)) + store final steps cost space) : + βˆƒ steps cost space, + Structured.Exec (captureInput tm regs captured) + store final steps cost space := by + induction regs generalizing captured with + | nil => + simpa [captureInput, captureValues] using hleaf + | cons reg rest ih => + have hreg := hbits reg (by simp) + have hrest : βˆ€ candidate, candidate ∈ rest β†’ + store candidate = 0 ∨ store candidate = 1 := by + intro candidate hmem + exact hbits candidate (by simp [hmem]) + simp only [captureValues] at hleaf + obtain ⟨steps, cost, space, hbranch⟩ := + ih ((reg, store reg) :: captured) hrest hleaf + rcases hreg with hzero | hone + Β· refine ⟨steps + 1, bitlen (store reg) + 1 + cost, + max store.space space, ?_⟩ + simpa [captureInput, hzero] using + (Structured.Exec.ifZero (onNonzero := + captureInput tm rest ((reg, 1) :: captured)) hzero hbranch) + Β· have hnonzero : store reg β‰  0 := by omega + refine ⟨steps + 2, bitlen (store reg) + 1 + cost + 1, + max store.space space, ?_⟩ + simpa [captureInput, hone] using + (Structured.Exec.ifNonzero (onZero := + captureInput tm rest ((reg, 0) :: captured)) hnonzero hbranch) + +/-- Specialization of finite capture to the public RAM input store. -/ +theorem marshalInput_exec_of_leaf_internal (tm : TM n) (x : List Bool) + {final : Structured.Store} + (hleaf : βˆƒ steps cost space, + Structured.Exec + (marshalLeaf tm (captureValues (initRegs x) (captureRegs n) [])) + (initRegs x) final steps cost space) : + βˆƒ steps cost space, + Structured.Exec (marshalInput tm) (initRegs x) final steps cost space := by + apply captureInput_exec_of_leaf_internal tm (initRegs x) (captureRegs n) [] + Β· intro reg hmem + exact initRegs_bool_of_pos_internal x + (captureRegs_positive_internal n hmem) + Β· exact hleaf + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Decision.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Decision.lean new file mode 100644 index 0000000000..86afa77322 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Decision.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Marshal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Iteration +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# End-to-end public-ABI sparse simulation -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- The verdict extractor copies the represented halted output cell one into +the public verdict register. -/ +theorem extractVerdict_exec_internal {tm : TM n} + {halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm halted store) : + let final := Structured.Basic.execList (extractVerdictOps n) store + βˆƒ cost space, + Structured.Exec (.basics (extractVerdictOps n)) store final + (extractVerdictOps n).length cost space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + let final := Structured.Basic.execList (extractVerdictOps n) store + obtain ⟨cost, space, hexec⟩ := + Structured.Internal.exec_basics_exists (extractVerdictOps n) store + have hcell : store (cellReg n (outputTape n) 1) = + symbolCode (halted.output.cells 1) := by + have hfield := hrepresents + (Sum.inr (Sum.inr (outputTape n, 1))) + simpa [fieldReg, fieldValue, tapeAt, outputTape] using hfield + refine ⟨cost, space, hexec, ?_⟩ + let addressed := + (Structured.Basic.imm (addressReg n) + (cellReg n (outputTape n) 1)).exec store + have haddress : addressed (addressReg n) = + cellReg n (outputTape n) 1 := by + simp [addressed, Structured.Basic.exec] + have hsource : addressed (cellReg n (outputTape n) 1) = + store (cellReg n (outputTape n) 1) := by + simp only [addressed, Structured.Basic.exec] + rw [Function.update_of_ne] + simp [cellReg, outputTape, cellBase, addressReg] + omega + let loaded := + (Structured.Basic.load stateReg (addressReg n)).exec addressed + let oned := (Structured.Basic.imm (oneReg n) 1).exec loaded + have hloadedState : loaded stateReg = + symbolCode (halted.output.cells 1) := by + simp only [loaded, Structured.Basic.exec, Function.update_self] + rw [haddress, hsource, hcell] + have honedState : oned stateReg = symbolCode (halted.output.cells 1) := by + simp only [oned, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, oneReg])] + exact hloadedState + have honedOne : oned (oneReg n) = 1 := by + simp [oned, Structured.Basic.exec] + change (Structured.Basic.sub stateReg stateReg (oneReg n)).exec + oned stateReg = _ + simp [Structured.Basic.exec, honedState, honedOne] + +/-- From the public RAM input store, the complete fixed source program follows +any exact halting TM run and returns the halted output symbol in `Rβ‚€`. -/ +theorem decisionProgram_exec_internal {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + obtain ⟨marshaled, marshalSteps, marshalCost, marshalSpace, + hmarshal, hrepresents⟩ := marshalInput_exec_internal tm x + obtain ⟨simulated, simulationCost, simulationSpace, + hsimulation, hhaltedRepresents⟩ := + runUntilHalt_exec_internal hreach hhalted hrepresents + (fun _ => rfl) rfl + let extracted := Structured.Basic.execList (extractVerdictOps n) simulated + obtain ⟨extractCost, extractSpace, hextract, hverdict⟩ := + extractVerdict_exec_internal hhaltedRepresents + have htail := Structured.Exec.seq hsimulation hextract + have hexec := Structured.Exec.seq hmarshal htail + refine ⟨extracted, + marshalSteps + (runSteps tm steps (tm.initCfg x) + + (extractVerdictOps n).length), + marshalCost + (simulationCost + extractCost), + max marshalSpace (max simulationSpace extractSpace), ?_, hverdict⟩ + simpa [decisionProgram, extracted] using hexec + +/-- Exact transfer of the public-ABI decision program to its concrete compiled +RAM, including source/target store agreement, cost, and space. -/ +theorem compiledDecision_exec_internal {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + run (compiledDecision tm) sourceSteps (initCfg x) = + { pc := (decisionProgram tm).codeSize, regs := final } ∧ + Halted (compiledDecision tm) + (run (compiledDecision tm) sourceSteps (initCfg x)) ∧ + logTimeUpto (compiledDecision tm) sourceSteps (initCfg x) = cost ∧ + spaceUpto (compiledDecision tm) sourceSteps (initCfg x) = space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + obtain ⟨final, sourceSteps, cost, space, hexec, hverdict⟩ := + decisionProgram_exec_internal hreach hhalted + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, sourceSteps, cost, space, hexec, ?_, ?_, ?_, ?_, hverdict⟩ + Β· simpa [compiledDecision, initCfg] using hcompiled.1 + Β· simpa [compiledDecision, initCfg] using + Structured.Exec.compile_halted hexec + Β· simpa [compiledDecision, initCfg] using hcompiled.2.1 + Β· simpa [compiledDecision, initCfg] using hcompiled.2.2 + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Loop.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Loop.lean new file mode 100644 index 0000000000..ccba2bb106 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Loop.lean @@ -0,0 +1,717 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Defs + +/-! +# Backward public-input copy -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- The final subtraction decrements the cursor while retaining constants and destination data. -/ +private theorem marshalLoop_final_controls (n : β„•) (destinationStored : Structured.Store) + (cursor value : β„•) + (hstoredState : destinationStored stateReg = cursor) + (hstoredZero : destinationStored (zeroReg n) = 0) + (hstoredOne : destinationStored (oneReg n) = 1) + (hstoredCount : destinationStored (tapeCountReg n) = n + 2) + (hstoredBase : destinationStored (stateScratchReg n) = cellBase n) + (hstoredDestination : destinationStored (cellReg n (inputTape n) cursor) = value + 1) : + let final := (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + final stateReg = cursor - 1 ∧ final (zeroReg n) = 0 ∧ final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ final (stateScratchReg n) = cellBase n ∧ + 0 < final (cellReg n (inputTape n) cursor) := by + let final := (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + have hfinalState : final stateReg = cursor - 1 := by + simp [final, Structured.Basic.exec, hstoredState, hstoredOne] + have hfinalZero : final (zeroReg n) = 0 := by + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, stateReg])] + exact hstoredZero + have hfinalOne : final (oneReg n) = 1 := by + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [oneReg, stateReg])] + exact hstoredOne + have hfinalCount : final (tapeCountReg n) = n + 2 := by + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, stateReg])] + exact hstoredCount + have hfinalBase : final (stateScratchReg n) = cellBase n := by + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, stateReg])] + exact hstoredBase + have hfinalDestination : 0 < + final (cellReg n (inputTape n) (cursor)) := by + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· rw [hstoredDestination] + omega + Β· simp [stateReg, cellReg, inputTape, cellBase] + exact ⟨hfinalState, hfinalZero, hfinalOne, hfinalCount, hfinalBase, hfinalDestination⟩ + +/-- The backward-copy body always decrements its cursor and restores all four +loop constants, even when the cursor itself visits one of their registers. -/ +theorem marshalLoopOps_control_internal (n : β„•) (store : Structured.Store) + (hcursor : 0 < store stateReg) + (hzero : store (zeroReg n) = 0) : + let final := Structured.Basic.execList (marshalLoopOps n) store + final stateReg = store stateReg - 1 ∧ + final (zeroReg n) = 0 ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ + final (stateScratchReg n) = cellBase n ∧ + 0 < final (cellReg n (inputTape n) (store stateReg)) := by + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + let multiplied := + (Structured.Basic.mul (addressReg n) stateReg (tapeCountReg n)).exec encoded + let destinationAddressed := + (Structured.Basic.add (addressReg n) (addressReg n) + (stateScratchReg n)).exec multiplied + let destinationStored := + (Structured.Basic.store (addressReg n) (valueReg n)).exec + destinationAddressed + let final := + (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + have hsourceAddress : sourceAddressed (addressReg n) = store stateReg := by + simp [sourceAddressed, Structured.Basic.exec, hzero] + have hsourceAddressZero : sourceAddressed (zeroReg n) = 0 := by + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hzero + have hloadedAddress : sourceLoaded (addressReg n) = store stateReg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact hsourceAddress + have hloadedZero : sourceLoaded (zeroReg n) = 0 := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, valueReg])] + exact hsourceAddressZero + have hloadedState : sourceLoaded stateReg = store stateReg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + have hclearedState : sourceCleared stateReg = store stateReg := by + simp only [sourceCleared, Structured.Basic.exec] + have hne : stateReg β‰  sourceLoaded (addressReg n) := by + have hpositive : 0 < sourceLoaded (addressReg n) := by + rw [hloadedAddress] + exact hcursor + simp only [stateReg] + omega + rw [Function.update_of_ne hne] + exact hloadedState + have hbasedState : based stateReg = store stateReg := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, stateScratchReg]), + Function.update_of_ne (by simp [stateReg, tapeCountReg]), + Function.update_of_ne (by simp [stateReg, oneReg]), + Function.update_of_ne (by simp [stateReg, zeroReg])] + exact hclearedState + have hbasedZero : based (zeroReg n) = 0 := by + simp [based, counted, oned, zeroed, Structured.Basic.exec, zeroReg, + oneReg, tapeCountReg, stateScratchReg, Function.update_of_ne] + have hbasedOne : based (oneReg n) = 1 := by + simp [based, counted, oned, Structured.Basic.exec, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hbasedCount : based (tapeCountReg n) = n + 2 := by + simp [based, counted, Structured.Basic.exec, tapeCountReg, + stateScratchReg, Function.update_of_ne] + have hbasedBase : based (stateScratchReg n) = cellBase n := by + simp [based, Structured.Basic.exec] + have hencodedState : encoded stateReg = store stateReg := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + exact hbasedState + have hencodedZero : encoded (zeroReg n) = 0 := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, valueReg])] + exact hbasedZero + have hencodedOne : encoded (oneReg n) = 1 := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [oneReg, valueReg])] + exact hbasedOne + have hencodedCount : encoded (tapeCountReg n) = n + 2 := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, valueReg])] + exact hbasedCount + have hencodedBase : encoded (stateScratchReg n) = cellBase n := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, valueReg])] + exact hbasedBase + have hencodedValue : encoded (valueReg n) = based (valueReg n) + 1 := by + simp [encoded, Structured.Basic.exec, hbasedOne] + have hmultipliedAddress : multiplied (addressReg n) = + store stateReg * (n + 2) := by + simp [multiplied, Structured.Basic.exec, hencodedState, hencodedCount] + have hmultipliedBase : multiplied (stateScratchReg n) = cellBase n := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, addressReg])] + exact hencodedBase + have hmultipliedValue : multiplied (valueReg n) = + based (valueReg n) + 1 := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [valueReg, addressReg])] + exact hencodedValue + have hdestinationAddress : destinationAddressed (addressReg n) = + store stateReg * (n + 2) + cellBase n := by + simp [destinationAddressed, Structured.Basic.exec, hmultipliedAddress, + hmultipliedBase] + have htargetHigh : stateScratchReg n < + store stateReg * (n + 2) + cellBase n := by + simp [stateScratchReg, cellBase] + omega + have hstoredApply (reg : β„•) + (hreg : reg ≀ stateScratchReg n) : + destinationStored reg = destinationAddressed reg := by + simp only [destinationStored, Structured.Basic.exec] + rw [Function.update_of_ne] + intro heq + rw [hdestinationAddress] at heq + omega + have hmultipliedState : multiplied stateReg = store stateReg := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + exact hencodedState + have hmultipliedZero : multiplied (zeroReg n) = 0 := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hencodedZero + have hmultipliedOne : multiplied (oneReg n) = 1 := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [oneReg, addressReg])] + exact hencodedOne + have hmultipliedCount : multiplied (tapeCountReg n) = n + 2 := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, addressReg])] + exact hencodedCount + have haddressedState : destinationAddressed stateReg = store stateReg := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + exact hmultipliedState + have haddressedZero : destinationAddressed (zeroReg n) = 0 := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hmultipliedZero + have haddressedOne : destinationAddressed (oneReg n) = 1 := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [oneReg, addressReg])] + exact hmultipliedOne + have haddressedCount : destinationAddressed (tapeCountReg n) = n + 2 := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, addressReg])] + exact hmultipliedCount + have haddressedBase : destinationAddressed (stateScratchReg n) = cellBase n := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, addressReg])] + exact hmultipliedBase + have haddressedValue : destinationAddressed (valueReg n) = + based (valueReg n) + 1 := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [valueReg, addressReg])] + exact hmultipliedValue + have hstoredState : destinationStored stateReg = store stateReg := by + rw [hstoredApply stateReg (by simp [stateReg, stateScratchReg]), + haddressedState] + have hstoredZero : destinationStored (zeroReg n) = 0 := by + rw [hstoredApply (zeroReg n) (by simp [zeroReg, stateScratchReg]), + haddressedZero] + have hstoredOne : destinationStored (oneReg n) = 1 := by + rw [hstoredApply (oneReg n) (by simp [oneReg, stateScratchReg]), + haddressedOne] + have hstoredCount : destinationStored (tapeCountReg n) = n + 2 := by + rw [hstoredApply (tapeCountReg n) (by simp [tapeCountReg, stateScratchReg]), + haddressedCount] + have hstoredBase : destinationStored (stateScratchReg n) = cellBase n := by + rw [hstoredApply (stateScratchReg n) le_rfl, haddressedBase] + have hdestinationAddress' : destinationAddressed (addressReg n) = + cellReg n (inputTape n) (store stateReg) := by + rw [hdestinationAddress] + simp [cellReg, inputTape] + omega + have hstoredDestination : destinationStored + (cellReg n (inputTape n) (store stateReg)) = + based (valueReg n) + 1 := by + simp only [destinationStored, Structured.Basic.exec] + rw [hdestinationAddress', Function.update_self, haddressedValue] + have hfinalResult := marshalLoop_final_controls n destinationStored (store stateReg) + (based (valueReg n)) hstoredState hstoredZero hstoredOne hstoredCount + hstoredBase hstoredDestination + simpa [marshalLoopOps, sourceAddressed, sourceLoaded, sourceCleared, + zeroed, oned, counted, based, encoded, multiplied, destinationAddressed, + destinationStored, final] using! + hfinalResult + +/-- One backward-copy body has an exact structured execution. -/ +theorem marshalLoopOps_exec_internal (n : β„•) (store : Structured.Store) : + βˆƒ cost space, + Structured.Exec (.basics (marshalLoopOps n)) store + (Structured.Basic.execList (marshalLoopOps n) store) + (marshalLoopOps n).length cost space := + Structured.Internal.exec_basics_exists (marshalLoopOps n) store + +/-- Data-region registers are disjoint from the cursor and all loop scratch registers. -/ +private theorem dataReg_ne_loopControls (n reg : β„•) (hdata : cellBase n ≀ reg) : + reg β‰  stateReg ∧ reg β‰  addressReg n ∧ reg β‰  valueReg n ∧ + reg β‰  zeroReg n ∧ reg β‰  oneReg n ∧ reg β‰  tapeCountReg n ∧ + reg β‰  stateScratchReg n := by + have hregState : reg β‰  stateReg := by + intro heq + rw [heq] at hdata + simp [stateReg, cellBase] at hdata + have hregAddress : reg β‰  addressReg n := by + intro heq + rw [heq] at hdata + simp [addressReg, cellBase] at hdata + omega + have hregValue : reg β‰  valueReg n := by + intro heq + rw [heq] at hdata + simp [valueReg, cellBase] at hdata + omega + have hregZero : reg β‰  zeroReg n := by + intro heq + rw [heq] at hdata + simp [zeroReg, cellBase] at hdata + omega + have hregOne : reg β‰  oneReg n := by + intro heq + rw [heq] at hdata + simp [oneReg, cellBase] at hdata + omega + have hregCount : reg β‰  tapeCountReg n := by + intro heq + rw [heq] at hdata + simp [tapeCountReg, cellBase] at hdata + omega + have hregBase : reg β‰  stateScratchReg n := by + intro heq + rw [heq] at hdata + simp [stateScratchReg, cellBase] at hdata + omega + exact ⟨hregState, hregAddress, hregValue, hregZero, hregOne, hregCount, hregBase⟩ + +/-- Away from the six captured scratch positions, one loop body clears the raw +source cell and writes its Boolean value, shifted to the sparse symbol code, to +the corresponding input cell. This is the relocation induction step. -/ +theorem marshalLoopOps_data_internal (n : β„•) (store : Structured.Store) + (reg : β„•) (hcursor : 0 < store stateReg) + (hzero : store (zeroReg n) = 0) + (hfree : store stateReg βˆ‰ captureRegs n) + (hdata : cellBase n ≀ reg) : + Structured.Basic.execList (marshalLoopOps n) store reg = + Function.update + (Function.update store (store stateReg) 0) + (cellReg n (inputTape n) (store stateReg)) + (store (store stateReg) + 1) reg := by + have hcursorAddress : store stateReg β‰  addressReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hcursorValue : store stateReg β‰  valueReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + let multiplied := + (Structured.Basic.mul (addressReg n) stateReg (tapeCountReg n)).exec encoded + let destinationAddressed := + (Structured.Basic.add (addressReg n) (addressReg n) + (stateScratchReg n)).exec multiplied + let destinationStored := + (Structured.Basic.store (addressReg n) (valueReg n)).exec + destinationAddressed + let final := + (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + have hsourceAddress : sourceAddressed (addressReg n) = store stateReg := by + simp [sourceAddressed, Structured.Basic.exec, hzero] + have hsourceCursor : sourceAddressed (store stateReg) = + store (store stateReg) := by + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne hcursorAddress] + have hloadedValue : sourceLoaded (valueReg n) = store (store stateReg) := by + simp [sourceLoaded, Structured.Basic.exec, hsourceAddress, hsourceCursor] + have hloadedAddress : sourceLoaded (addressReg n) = store stateReg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact hsourceAddress + have hloadedZero : sourceLoaded (zeroReg n) = 0 := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hzero + have hclearedState : sourceCleared stateReg = store stateReg := by + simp only [sourceCleared, Structured.Basic.exec] + have hne : stateReg β‰  sourceLoaded (addressReg n) := by + rw [hloadedAddress] + simpa [stateReg] using (Nat.ne_of_lt hcursor) + rw [Function.update_of_ne hne] + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + have hclearedValue : sourceCleared (valueReg n) = + store (store stateReg) := by + simp only [sourceCleared, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· exact hloadedValue + Β· rw [hloadedAddress] + exact Ne.symm hcursorValue + have hbasedState : based stateReg = store stateReg := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, stateScratchReg]), + Function.update_of_ne (by simp [stateReg, tapeCountReg]), + Function.update_of_ne (by simp [stateReg, oneReg]), + Function.update_of_ne (by simp [stateReg, zeroReg])] + exact hclearedState + have hbasedCount : based (tapeCountReg n) = n + 2 := by + simp [based, counted, Structured.Basic.exec, tapeCountReg, + stateScratchReg, Function.update_of_ne] + have hbasedBase : based (stateScratchReg n) = cellBase n := by + simp [based, Structured.Basic.exec] + have hbasedOne : based (oneReg n) = 1 := by + simp [based, counted, oned, Structured.Basic.exec, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hbasedValue : based (valueReg n) = store (store stateReg) := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [valueReg, stateScratchReg]), + Function.update_of_ne (by simp [valueReg, tapeCountReg]), + Function.update_of_ne (by simp [valueReg, oneReg]), + Function.update_of_ne (by simp [valueReg, zeroReg])] + exact hclearedValue + have hencodedState : encoded stateReg = store stateReg := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + exact hbasedState + have hencodedCount : encoded (tapeCountReg n) = n + 2 := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, valueReg])] + exact hbasedCount + have hencodedBase : encoded (stateScratchReg n) = cellBase n := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, valueReg])] + exact hbasedBase + have hencodedValue : encoded (valueReg n) = + store (store stateReg) + 1 := by + simp [encoded, Structured.Basic.exec, hbasedValue, hbasedOne] + have hmultipliedAddress : multiplied (addressReg n) = + store stateReg * (n + 2) := by + simp [multiplied, Structured.Basic.exec, hencodedState, hencodedCount] + have hmultipliedBase : multiplied (stateScratchReg n) = cellBase n := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, addressReg])] + exact hencodedBase + have hmultipliedValue : multiplied (valueReg n) = + store (store stateReg) + 1 := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [valueReg, addressReg])] + exact hencodedValue + have hdestinationAddress : destinationAddressed (addressReg n) = + cellReg n (inputTape n) (store stateReg) := by + simp [destinationAddressed, Structured.Basic.exec, hmultipliedAddress, + hmultipliedBase, cellReg, inputTape] + omega + have hdestinationValue : destinationAddressed (valueReg n) = + store (store stateReg) + 1 := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [valueReg, addressReg])] + exact hmultipliedValue + obtain ⟨hregState, hregAddress, hregValue, hregZero, hregOne, hregCount, hregBase⟩ := + dataReg_ne_loopControls n reg hdata + have hloadedData : sourceLoaded reg = store reg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + have hclearedData : sourceCleared reg = + Function.update store (store stateReg) 0 reg := by + simp only [sourceCleared, Structured.Basic.exec] + rw [hloadedAddress, hloadedZero] + by_cases heq : reg = store stateReg + Β· subst reg + rw [Function.update_self, Function.update_self] + Β· rw [Function.update_of_ne heq, Function.update_of_ne heq] + exact hloadedData + have hbasedData : based reg = + Function.update store (store stateReg) 0 reg := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne hregBase, Function.update_of_ne hregCount, + Function.update_of_ne hregOne, Function.update_of_ne hregZero] + exact hclearedData + have hencodedData : encoded reg = + Function.update store (store stateReg) 0 reg := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + exact hbasedData + have hmultipliedData : multiplied reg = + Function.update store (store stateReg) 0 reg := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + exact hencodedData + have haddressedData : destinationAddressed reg = + Function.update store (store stateReg) 0 reg := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + exact hmultipliedData + change final reg = _ + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne hregState] + simp only [destinationStored, Structured.Basic.exec] + rw [hdestinationAddress, hdestinationValue] + by_cases heq : reg = cellReg n (inputTape n) (store stateReg) + Β· subst reg + rw [Function.update_self, Function.update_self] + Β· rw [Function.update_of_ne heq, Function.update_of_ne heq] + exact haddressedData + +/-- Apart from the raw source, sparse destination, state, and six scratch +registers, a loop body preserves every register. This form does not assume that +the cursor avoids scratch, so it carries both future raw sources and previously +relocated cells across captured iterations. -/ +theorem marshalLoopOps_of_ne_internal (n : β„•) + (store : Structured.Store) (reg : β„•) + (hcursor : 0 < store stateReg) + (hzero : store (zeroReg n) = 0) + (hstate : reg β‰  stateReg) + (hfree : reg βˆ‰ captureRegs n) + (hsource : reg β‰  store stateReg) + (hdestination : + reg β‰  cellReg n (inputTape n) (store stateReg)) : + Structured.Basic.execList (marshalLoopOps n) store reg = store reg := by + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + let multiplied := + (Structured.Basic.mul (addressReg n) stateReg (tapeCountReg n)).exec encoded + let destinationAddressed := + (Structured.Basic.add (addressReg n) (addressReg n) + (stateScratchReg n)).exec multiplied + let destinationStored := + (Structured.Basic.store (addressReg n) (valueReg n)).exec + destinationAddressed + let final := + (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + have hsourceAddress : sourceAddressed (addressReg n) = store stateReg := by + simp [sourceAddressed, Structured.Basic.exec, hzero] + have hloadedAddress : sourceLoaded (addressReg n) = store stateReg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact hsourceAddress + have hloadedZero : sourceLoaded (zeroReg n) = 0 := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hzero + have hclearedState : sourceCleared stateReg = store stateReg := by + simp only [sourceCleared, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + Β· rw [hloadedAddress] + simpa [stateReg] using (Nat.ne_of_lt hcursor) + have hbasedState : based stateReg = store stateReg := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, stateScratchReg]), + Function.update_of_ne (by simp [stateReg, tapeCountReg]), + Function.update_of_ne (by simp [stateReg, oneReg]), + Function.update_of_ne (by simp [stateReg, zeroReg])] + exact hclearedState + have hbasedCount : based (tapeCountReg n) = n + 2 := by + simp [based, counted, Structured.Basic.exec, tapeCountReg, + stateScratchReg, Function.update_of_ne] + have hbasedBase : based (stateScratchReg n) = cellBase n := by + simp [based, Structured.Basic.exec] + have hencodedState : encoded stateReg = store stateReg := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + exact hbasedState + have hencodedCount : encoded (tapeCountReg n) = n + 2 := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [tapeCountReg, valueReg])] + exact hbasedCount + have hencodedBase : encoded (stateScratchReg n) = cellBase n := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, valueReg])] + exact hbasedBase + have hmultipliedAddress : multiplied (addressReg n) = + store stateReg * (n + 2) := by + simp [multiplied, Structured.Basic.exec, hencodedState, hencodedCount] + have hmultipliedBase : multiplied (stateScratchReg n) = cellBase n := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateScratchReg, addressReg])] + exact hencodedBase + have hdestinationAddress : destinationAddressed (addressReg n) = + cellReg n (inputTape n) (store stateReg) := by + simp [destinationAddressed, Structured.Basic.exec, hmultipliedAddress, + hmultipliedBase, cellReg, inputTape] + omega + have hregState : reg β‰  stateReg := hstate + have hregAddress : reg β‰  addressReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hregValue : reg β‰  valueReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hregZero : reg β‰  zeroReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hregOne : reg β‰  oneReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hregCount : reg β‰  tapeCountReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hregBase : reg β‰  stateScratchReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hloadedData : sourceLoaded reg = store reg := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + have hclearedData : sourceCleared reg = store reg := by + simp only [sourceCleared, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· exact hloadedData + Β· rw [hloadedAddress] + exact hsource + have hbasedData : based reg = store reg := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne hregBase, Function.update_of_ne hregCount, + Function.update_of_ne hregOne, Function.update_of_ne hregZero] + exact hclearedData + have hencodedData : encoded reg = store reg := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + exact hbasedData + have hmultipliedData : multiplied reg = store reg := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + exact hencodedData + have haddressedData : destinationAddressed reg = store reg := by + simp only [destinationAddressed, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + exact hmultipliedData + change final reg = store reg + simp only [final, Structured.Basic.exec] + rw [Function.update_of_ne hregState] + simp only [destinationStored, Structured.Basic.exec] + rw [hdestinationAddress, Function.update_of_ne hdestination] + exact haddressedData + +/-- The backward-copy loop executes exactly once per raw input cell and exits +with cursor zero and all constants restored. -/ +theorem marshalLoop_exec_internal (n cursor : β„•) + (store : Structured.Store) + (hcursor : store stateReg = cursor) + (hzero : store (zeroReg n) = 0) + (hone : store (oneReg n) = 1) + (hcount : store (tapeCountReg n) = n + 2) + (hbase : store (stateScratchReg n) = cellBase n) : + βˆƒ final cost space, + Structured.Exec (marshalLoop n) store final + (marshalLoopSteps n cursor) cost space ∧ + final stateReg = 0 ∧ + final (zeroReg n) = 0 ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ + final (stateScratchReg n) = cellBase n := by + induction cursor generalizing store with + | zero => + have hcursorZero : store stateReg = 0 := by simpa using hcursor + refine ⟨store, bitlen (store stateReg) + 1, store.space, ?_, + hcursorZero, hzero, hone, hcount, hbase⟩ + simpa [marshalLoop, marshalLoopSteps] using + (Structured.Exec.whileZero + (body := .basics (marshalLoopOps n)) hcursorZero) + | succ cursor ih => + have hpositive : 0 < store stateReg := by omega + have hnonzero : store stateReg β‰  0 := by omega + let middle := Structured.Basic.execList (marshalLoopOps n) store + obtain ⟨bodyCost, bodySpace, hbody⟩ := + marshalLoopOps_exec_internal n store + have hcontrol := marshalLoopOps_control_internal n store hpositive hzero + have hmiddleCursor : middle stateReg = cursor := by + change Structured.Basic.execList (marshalLoopOps n) store stateReg = cursor + rw [hcontrol.1, hcursor] + omega + obtain ⟨final, loopCost, loopSpace, hloop, hfinalCursor, + hfinalZero, hfinalOne, hfinalCount, hfinalBase⟩ := + ih middle hmiddleCursor hcontrol.2.1 hcontrol.2.2.1 + hcontrol.2.2.2.1 hcontrol.2.2.2.2.1 + refine ⟨final, + bitlen (store stateReg) + 1 + bodyCost + 1 + loopCost, + max bodySpace loopSpace, ?_, hfinalCursor, hfinalZero, hfinalOne, + hfinalCount, hfinalBase⟩ + have hexec := Structured.Exec.whileNonzero hnonzero hbody hloop + convert! hexec using 1 + simp [marshalLoopSteps, Nat.succ_mul] + omega + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Marshal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Marshal.lean new file mode 100644 index 0000000000..f81f6174f7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Marshal.lean @@ -0,0 +1,939 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Capture +public import Mathlib.Algebra.Order.Sub.Basic + +/-! +# Public-input marshalling correctness -- proof internals + +This file lifts the pointwise backward-copy facts to a loop invariant, repairs +the finitely many captured scratch positions, and establishes the complete +sparse representation of the Turing machine's initial configuration. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Store after installing the constants used by the backward-copy loop. -/ +def marshalStart (n : β„•) (x : List Bool) : Structured.Store := + Structured.Basic.execList (marshalConstants n) (initRegs x) + +/-- Semantic invariant after relocating positions `|x|, …, cursor + 1`. +Uncaptured destinations are exact, captured destinations are at least marked +positive, future uncaptured raw sources retain their public-ABI value, and all +other data registers have their expected raw-or-zero contents. -/ +def MarshalInvariant (n : β„•) (x : List Bool) (cursor : β„•) + (store : Structured.Store) : Prop := + store stateReg = cursor ∧ + cursor ≀ x.length ∧ + store (zeroReg n) = 0 ∧ + store (oneReg n) = 1 ∧ + store (tapeCountReg n) = n + 2 ∧ + store (stateScratchReg n) = cellBase n ∧ + (βˆ€ position, 0 < position β†’ position ≀ cursor β†’ + position βˆ‰ captureRegs n β†’ store position = initRegs x position) ∧ + (βˆ€ position, cursor < position β†’ position ≀ x.length β†’ + position βˆ‰ captureRegs n β†’ + store (cellReg n (inputTape n) position) = + initRegs x position + 1) ∧ + (βˆ€ position, cursor < position β†’ position ≀ x.length β†’ + 0 < store (cellReg n (inputTape n) position)) ∧ + (βˆ€ reg, cellBase n ≀ reg β†’ + (βˆ€ position, cursor < position β†’ position ≀ x.length β†’ + reg β‰  cellReg n (inputTape n) position) β†’ + store reg = if reg ≀ cursor then initRegs x reg else 0) + +private theorem marshalStart_of_not_captured (n : β„•) (x : List Bool) + {reg : β„•} (hfree : reg βˆ‰ captureRegs n) : + marshalStart n x reg = initRegs x reg := by + simp only [marshalStart, marshalConstants, Structured.Basic.execList, + Structured.Basic.exec] + have hzero : reg β‰  zeroReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hone : reg β‰  oneReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hcount : reg β‰  tapeCountReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + have hbase : reg β‰  stateScratchReg n := by + intro heq + apply hfree + simp [captureRegs, heq] + rw [Function.update_of_ne hbase, Function.update_of_ne hcount, + Function.update_of_ne hone, Function.update_of_ne hzero] + +private theorem initRegs_eq_zero_of_length_lt (x : List Bool) {reg : β„•} + (hreg : x.length < reg) : initRegs x reg = 0 := by + rw [initRegs, ite_eq_right (by omega)] + rw [List.getElem?_eq_none (by omega)] + +/-- Installing loop constants establishes the invariant before any input +position has been relocated. -/ +theorem marshalStart_invariant_internal (n : β„•) (x : List Bool) : + MarshalInvariant n x x.length (marshalStart n x) := by + have hstate : marshalStart n x stateReg = x.length := by + rw [marshalStart_of_not_captured] + Β· simp [initRegs, stateReg] + Β· simp [captureRegs, stateReg, zeroReg, oneReg, tapeCountReg, + stateScratchReg, addressReg, valueReg] + have hzero : marshalStart n x (zeroReg n) = 0 := by + simp [marshalStart, marshalConstants, Structured.Basic.execList, + Structured.Basic.exec, zeroReg, oneReg, tapeCountReg, stateScratchReg, + Function.update_of_ne] + have hone : marshalStart n x (oneReg n) = 1 := by + simp [marshalStart, marshalConstants, Structured.Basic.execList, + Structured.Basic.exec, oneReg, tapeCountReg, stateScratchReg, + Function.update_of_ne] + have hcount : marshalStart n x (tapeCountReg n) = n + 2 := by + simp [marshalStart, marshalConstants, Structured.Basic.execList, + Structured.Basic.exec, tapeCountReg, stateScratchReg, + Function.update_of_ne] + have hbase : marshalStart n x (stateScratchReg n) = cellBase n := by + simp [marshalStart, marshalConstants, Structured.Basic.execList, + Structured.Basic.exec] + refine ⟨hstate, le_rfl, hzero, hone, hcount, hbase, ?_, ?_, ?_, ?_⟩ + Β· intro position _ _ hfree + exact marshalStart_of_not_captured n x hfree + Β· intro position hposition _ _ + omega + Β· intro position hposition _ + omega + Β· intro reg hdata _ + rw [marshalStart_of_not_captured] + Β· by_cases hreg : reg ≀ x.length + Β· simp [hreg] + Β· have hz : initRegs x reg = 0 := + initRegs_eq_zero_of_length_lt x (reg := reg) (by omega) + simp [hreg, hz] + Β· simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg, cellBase] at * + omega + +private theorem position_lt_inputCell (n position : β„•) : + position < cellReg n (inputTape n) position := by + simp [cellReg, inputTape, cellBase, Nat.mul_add] + omega + +private theorem inputCell_injective (n : β„•) : + Function.Injective (cellReg n (inputTape n)) := by + intro left right heq + simp [cellReg, inputTape] at heq + omega + +private theorem inputCell_not_captured (n position : β„•) : + cellReg n (inputTape n) position βˆ‰ captureRegs n := by + simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg, cellReg, inputTape, cellBase] + omega + +private theorem inputCell_data (n position : β„•) : + cellBase n ≀ cellReg n (inputTape n) position := by + simp [cellReg, inputTape] + +/-- One positive-cursor body advances the complete relocation invariant by one +position, including an exact value for ordinary sources and a positive visited +marker for captured scratch sources. -/ +theorem marshalLoopOps_invariant_internal (n : β„•) (x : List Bool) + (cursor : β„•) (store : Structured.Store) (hcursor : 0 < cursor) + (hinvariant : MarshalInvariant n x cursor store) : + MarshalInvariant n x (cursor - 1) + (Structured.Basic.execList (marshalLoopOps n) store) := by + rcases hinvariant with + ⟨hstate, hcursorLength, hzero, hone, hcount, hbase, hsource, hexact, + hpositive, hother⟩ + let middle := Structured.Basic.execList (marshalLoopOps n) store + have hstorePositive : 0 < store stateReg := by omega + have hcontrol := + marshalLoopOps_control_internal n store hstorePositive hzero + have hmiddleState : middle stateReg = cursor - 1 := by + change Structured.Basic.execList (marshalLoopOps n) store stateReg = _ + rw [hcontrol.1, hstate] + refine ⟨hmiddleState, by omega, hcontrol.2.1, hcontrol.2.2.1, + hcontrol.2.2.2.1, hcontrol.2.2.2.2.1, ?_, ?_, ?_, ?_⟩ + Β· intro position hposition hpositionCursor hfree + have hpositionState : position β‰  stateReg := by + simp [stateReg] + omega + have hpositionSource : position β‰  store stateReg := by + rw [hstate] + omega + have hpositionDestination : + position β‰  cellReg n (inputTape n) (store stateReg) := by + rw [hstate] + have hhigh := position_lt_inputCell n cursor + omega + change Structured.Basic.execList (marshalLoopOps n) store position = _ + rw [marshalLoopOps_of_ne_internal n store position hstorePositive + hzero hpositionState hfree hpositionSource hpositionDestination] + exact hsource position hposition (by omega) hfree + Β· intro position hposition hlength hfree + by_cases heq : position = cursor + Β· subst position + have hfreeStore : store stateReg βˆ‰ captureRegs n := by + simpa [hstate] using hfree + have hbody := marshalLoopOps_data_internal n store + (cellReg n (inputTape n) cursor) hstorePositive hzero hfreeStore + (inputCell_data n cursor) + change Structured.Basic.execList (marshalLoopOps n) store + (cellReg n (inputTape n) cursor) = _ + rw [hbody, hstate, Function.update_self, + hsource cursor hcursor le_rfl hfree] + Β· have hcursorPosition : cursor < position := by omega + have hregState : cellReg n (inputTape n) position β‰  stateReg := by + simp [stateReg, cellReg, inputTape, cellBase] + have hregSource : + cellReg n (inputTape n) position β‰  store stateReg := by + rw [hstate] + have hhigh := position_lt_inputCell n position + omega + have hregDestination : cellReg n (inputTape n) position β‰  + cellReg n (inputTape n) (store stateReg) := by + intro hcells + have := inputCell_injective n hcells + rw [hstate] at this + omega + change Structured.Basic.execList (marshalLoopOps n) store + (cellReg n (inputTape n) position) = _ + rw [marshalLoopOps_of_ne_internal n store + (cellReg n (inputTape n) position) hstorePositive hzero hregState + (inputCell_not_captured n position) hregSource hregDestination] + exact hexact position hcursorPosition hlength hfree + Β· intro position hposition hlength + by_cases heq : position = cursor + Β· subst position + simpa [hstate] using hcontrol.2.2.2.2.2 + Β· have hcursorPosition : cursor < position := by omega + have hregState : cellReg n (inputTape n) position β‰  stateReg := by + simp [stateReg, cellReg, inputTape, cellBase] + have hregSource : + cellReg n (inputTape n) position β‰  store stateReg := by + rw [hstate] + have hhigh := position_lt_inputCell n position + omega + have hregDestination : cellReg n (inputTape n) position β‰  + cellReg n (inputTape n) (store stateReg) := by + intro hcells + have := inputCell_injective n hcells + rw [hstate] at this + omega + change 0 < Structured.Basic.execList (marshalLoopOps n) store + (cellReg n (inputTape n) position) + rw [marshalLoopOps_of_ne_internal n store + (cellReg n (inputTape n) position) hstorePositive hzero hregState + (inputCell_not_captured n position) hregSource hregDestination] + exact hpositive position hcursorPosition hlength + Β· intro reg hdata hnotDestination + have hregState : reg β‰  stateReg := by + intro heq + rw [heq] at hdata + simp [stateReg, cellBase] at hdata + have hregFree : reg βˆ‰ captureRegs n := by + intro hmem + simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg] at hmem + rcases hmem with h | h | h | h | h | h <;> + rw [h] at hdata <;> simp [cellBase] at hdata <;> omega + have hregDestination : + reg β‰  cellReg n (inputTape n) (store stateReg) := by + rw [hstate] + apply hnotDestination cursor + Β· omega + Β· omega + by_cases hregSource : reg = cursor + Β· subst reg + have hfreeStore : store stateReg βˆ‰ captureRegs n := by + simpa [hstate] using hregFree + have hbody := marshalLoopOps_data_internal n store cursor + hstorePositive hzero hfreeStore hdata + have hregDestinationCursor : + cursor β‰  cellReg n (inputTape n) cursor := by + exact Nat.ne_of_lt (position_lt_inputCell n cursor) + change Structured.Basic.execList (marshalLoopOps n) store cursor = _ + rw [hbody, hstate, Function.update_of_ne hregDestinationCursor, + Function.update_self] + simp [hcursor] + Β· have hregSource' : reg β‰  store stateReg := by + rw [hstate] + exact hregSource + have hpreserved := marshalLoopOps_of_ne_internal n store reg + hstorePositive hzero hregState hregFree hregSource' + hregDestination + change Structured.Basic.execList (marshalLoopOps n) store reg = _ + rw [hpreserved] + have holdNotDestination : βˆ€ position, cursor < position β†’ + position ≀ x.length β†’ + reg β‰  cellReg n (inputTape n) position := by + intro position hposition hlength + exact hnotDestination position (by omega) hlength + rw [hother reg hdata holdNotDestination] + by_cases hregLow : reg ≀ cursor - 1 + Β· simp [hregLow, show reg ≀ cursor by omega] + Β· simp [hregLow, show Β¬ reg ≀ cursor by omega] + +/-- The complete backward loop executes once per input position and leaves the +relocation invariant at cursor zero. -/ +theorem marshalLoop_invariant_exec_internal (n : β„•) (x : List Bool) + (cursor : β„•) (store : Structured.Store) + (hinvariant : MarshalInvariant n x cursor store) : + βˆƒ final cost space, + Structured.Exec (marshalLoop n) store final + (marshalLoopSteps n cursor) cost space ∧ + MarshalInvariant n x 0 final := by + induction cursor generalizing store with + | zero => + have hstateZero : store stateReg = 0 := hinvariant.1 + refine ⟨store, bitlen (store stateReg) + 1, store.space, ?_, ?_⟩ + Β· simpa [marshalLoop, marshalLoopSteps] using + (Structured.Exec.whileZero + (body := .basics (marshalLoopOps n)) hstateZero) + Β· exact hinvariant + | succ cursor ih => + have hpositive : 0 < cursor + 1 := by omega + have hstoreNonzero : store stateReg β‰  0 := by + rw [hinvariant.1] + omega + let middle := Structured.Basic.execList (marshalLoopOps n) store + obtain ⟨bodyCost, bodySpace, hbody⟩ := + marshalLoopOps_exec_internal n store + have hmiddleInvariant : MarshalInvariant n x cursor middle := by + have hstep := marshalLoopOps_invariant_internal n x (cursor + 1) + store hpositive hinvariant + simpa [middle] using hstep + obtain ⟨final, loopCost, loopSpace, hloop, hfinalInvariant⟩ := + ih middle hmiddleInvariant + refine ⟨final, + bitlen (store stateReg) + 1 + bodyCost + 1 + loopCost, + max bodySpace loopSpace, ?_, hfinalInvariant⟩ + have hexec := Structured.Exec.whileNonzero hstoreNonzero hbody hloop + convert! hexec using 1 + simp [marshalLoopSteps, Nat.succ_mul] + omega + +/-- Exact store selected by one captured-position repair command. -/ +def repairBitStore (n : β„•) (entry : β„• Γ— β„•) + (store : Structured.Store) : Structured.Store := + let loaded := Structured.Basic.execList + [.imm (addressReg n) (cellReg n (inputTape n) entry.1), + .load (valueReg n) (addressReg n)] store + if loaded (valueReg n) = 0 then loaded + else Structured.Basic.execList + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] loaded + +/-- Exact store selected by the recursive captured-position repair pass. -/ +def repairStore (n : β„•) : + List (β„• Γ— β„•) β†’ Structured.Store β†’ Structured.Store + | [], store => store + | entry :: rest, store => + repairStore n rest (repairBitStore n entry store) + +private theorem repairBit_exec_internal (n : β„•) (entry : β„• Γ— β„•) + (store : Structured.Store) : + βˆƒ steps cost space, + Structured.Exec (repairBit n entry) store + (repairBitStore n entry store) steps cost space := by + let setup : List Structured.Basic := + [.imm (addressReg n) (cellReg n (inputTape n) entry.1), + .load (valueReg n) (addressReg n)] + let loaded := Structured.Basic.execList setup store + obtain ⟨setupCost, setupSpace, hsetup⟩ := + Structured.Internal.exec_basics_exists setup store + by_cases hzero : loaded (valueReg n) = 0 + Β· have hbranch := Structured.Exec.ifZero + (onNonzero := .basics + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)]) + hzero (Structured.Exec.skip loaded) + refine ⟨setup.length + 1, setupCost + (bitlen (loaded (valueReg n)) + 1), + max setupSpace loaded.space, ?_⟩ + have hexec := Structured.Exec.seq hsetup hbranch + simpa [repairBit, repairBitStore, setup, loaded, hzero, + Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using hexec + Β· let writes : List Structured.Basic := + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] + let final := Structured.Basic.execList writes loaded + obtain ⟨writeCost, writeSpace, hwrites⟩ := + Structured.Internal.exec_basics_exists writes loaded + have hbranch := Structured.Exec.ifNonzero + (onZero := Structured.Cmd.skip) hzero hwrites + refine ⟨setup.length + (writes.length + 2), + setupCost + (bitlen (loaded (valueReg n)) + 1 + writeCost + 1), + max setupSpace (max loaded.space writeSpace), ?_⟩ + have hexec := Structured.Exec.seq hsetup hbranch + simpa [repairBit, repairBitStore, setup, loaded, writes, final, hzero, + Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using hexec + +/-- The recursive repair command has an exact structured execution. -/ +theorem repairCaptured_exec_internal (n : β„•) + (captured : List (β„• Γ— β„•)) (store : Structured.Store) : + βˆƒ steps cost space, + Structured.Exec (repairCaptured n captured) store + (repairStore n captured store) steps cost space := by + induction captured generalizing store with + | nil => + exact ⟨0, 0, store.space, Structured.Exec.skip store⟩ + | cons entry rest ih => + obtain ⟨firstSteps, firstCost, firstSpace, hfirst⟩ := + repairBit_exec_internal n entry store + obtain ⟨restSteps, restCost, restSpace, hrest⟩ := + ih (repairBitStore n entry store) + exact ⟨firstSteps + restSteps, firstCost + restCost, + max firstSpace restSpace, Structured.Exec.seq hfirst hrest⟩ + +/-- On data registers, one repair either preserves the store or updates exactly +the selected input-cell destination. -/ +theorem repairBitStore_data_internal (n : β„•) (entry : β„• Γ— β„•) + (store : Structured.Store) (reg : β„•) (hdata : cellBase n ≀ reg) : + repairBitStore n entry store reg = + if store (cellReg n (inputTape n) entry.1) = 0 then store reg + else Function.update store (cellReg n (inputTape n) entry.1) + (entry.2 + 1) reg := by + let addressed := + (Structured.Basic.imm (addressReg n) + (cellReg n (inputTape n) entry.1)).exec store + let loaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec addressed + have haddress : addressed (addressReg n) = + cellReg n (inputTape n) entry.1 := by + simp [addressed, Structured.Basic.exec] + have hloadedValue : loaded (valueReg n) = + store (cellReg n (inputTape n) entry.1) := by + have hdestinationAddress : + cellReg n (inputTape n) entry.1 β‰  addressReg n := by + simp [cellReg, inputTape, cellBase, addressReg] + omega + have haddressedDestination : addressed + (cellReg n (inputTape n) entry.1) = + store (cellReg n (inputTape n) entry.1) := by + simp only [addressed, Structured.Basic.exec] + rw [Function.update_of_ne hdestinationAddress] + simp only [loaded, Structured.Basic.exec, Function.update_self] + rw [haddress, haddressedDestination] + have hloadedAddress : loaded (addressReg n) = + cellReg n (inputTape n) entry.1 := by + simp only [loaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact haddress + have hregAddress : reg β‰  addressReg n := by + intro heq + rw [heq] at hdata + simp [addressReg, cellBase] at hdata + omega + have hregValue : reg β‰  valueReg n := by + intro heq + rw [heq] at hdata + simp [valueReg, cellBase] at hdata + omega + have hloadedData : loaded reg = store reg := by + simp only [loaded, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + simp only [addressed, Structured.Basic.exec] + rw [Function.update_of_ne hregAddress] + unfold repairBitStore + change (if loaded (valueReg n) = 0 then loaded else + Structured.Basic.execList + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] loaded) reg = _ + rw [hloadedValue] + by_cases hzero : store (cellReg n (inputTape n) entry.1) = 0 + Β· simp [hzero, hloadedData] + Β· simp only [hzero, ite_false] + let valued := + (Structured.Basic.imm (valueReg n) (entry.2 + 1)).exec loaded + have hvaluedAddress : valued (addressReg n) = + cellReg n (inputTape n) entry.1 := by + simp only [valued, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact hloadedAddress + have hvaluedValue : valued (valueReg n) = entry.2 + 1 := by + simp [valued, Structured.Basic.exec] + change (Structured.Basic.store (addressReg n) (valueReg n)).exec + valued reg = _ + simp only [Structured.Basic.exec] + rw [hvaluedAddress, hvaluedValue] + by_cases heq : reg = cellReg n (inputTape n) entry.1 + Β· subst reg + rw [Function.update_self, Function.update_self] + Β· rw [Function.update_of_ne heq, Function.update_of_ne heq] + simp only [valued, Structured.Basic.exec] + rw [Function.update_of_ne hregValue] + exact hloadedData + +/-- A repair list preserves a data register that is not one of its selected +input-cell destinations. -/ +theorem repairStore_data_of_not_mem_internal (n : β„•) + (captured : List (β„• Γ— β„•)) (store : Structured.Store) (reg : β„•) + (hdata : cellBase n ≀ reg) + (hnot : βˆ€ entry, entry ∈ captured β†’ + reg β‰  cellReg n (inputTape n) entry.1) : + repairStore n captured store reg = store reg := by + induction captured generalizing store with + | nil => rfl + | cons entry rest ih => + have hhead : reg β‰  cellReg n (inputTape n) entry.1 := + hnot entry (by simp) + have hrest : βˆ€ candidate, candidate ∈ rest β†’ + reg β‰  cellReg n (inputTape n) candidate.1 := by + intro candidate hmem + exact hnot candidate (by simp [hmem]) + simp only [repairStore] + rw [ih (repairBitStore n entry store) hrest, + repairBitStore_data_internal n entry store reg hdata] + by_cases hzero : store (cellReg n (inputTape n) entry.1) = 0 + Β· simp [hzero] + Β· simp [hzero, Function.update_of_ne hhead] + +/-- A visited destination selected exactly once by a repair list receives its +captured Boolean value shifted to the sparse symbol code. -/ +theorem repairStore_selected_internal (n : β„•) + (captured : List (β„• Γ— β„•)) (store : Structured.Store) + (position value : β„•) (hmem : (position, value) ∈ captured) + (hnodup : (captured.map Prod.fst).Nodup) + (hpositive : 0 < store (cellReg n (inputTape n) position)) : + repairStore n captured store (cellReg n (inputTape n) position) = + value + 1 := by + induction captured generalizing store with + | nil => simp at hmem + | cons entry rest ih => + simp only [List.map_cons, List.nodup_cons] at hnodup + rcases hnodup with ⟨hheadFresh, hrestNodup⟩ + simp only [List.mem_cons] at hmem + rcases hmem with heq | hmem + Β· cases heq + have hupdated : repairBitStore n (position, value) store + (cellReg n (inputTape n) position) = value + 1 := by + rw [repairBitStore_data_internal n (position, value) store + (cellReg n (inputTape n) position) (inputCell_data n position)] + simp [show store (cellReg n (inputTape n) position) β‰  0 by omega] + have hrestPreserves := repairStore_data_of_not_mem_internal n rest + (repairBitStore n (position, value) store) + (cellReg n (inputTape n) position) (inputCell_data n position) + (by + intro candidate hcandidate heqCell + apply hheadFresh + rw [List.mem_map] + refine ⟨candidate, hcandidate, ?_⟩ + exact (inputCell_injective n heqCell).symm) + simp only [repairStore] + rw [hrestPreserves, hupdated] + Β· have hentryDifferent : position β‰  entry.1 := by + intro heq + subst position + apply hheadFresh + rw [List.mem_map] + exact ⟨(entry.1, value), hmem, rfl⟩ + have hheadPreserves : repairBitStore n entry store + (cellReg n (inputTape n) position) = + store (cellReg n (inputTape n) position) := by + rw [repairBitStore_data_internal n entry store + (cellReg n (inputTape n) position) (inputCell_data n position)] + by_cases hzero : store (cellReg n (inputTape n) entry.1) = 0 + Β· simp [hzero] + Β· have hcells : cellReg n (inputTape n) position β‰  + cellReg n (inputTape n) entry.1 := by + intro heqCell + exact hentryDifferent (inputCell_injective n heqCell) + simp [hzero, Function.update_of_ne hcells] + have hnextPositive : 0 < repairBitStore n entry store + (cellReg n (inputTape n) position) := by + rw [hheadPreserves] + exact hpositive + simp only [repairStore] + exact ih (repairBitStore n entry store) hmem hrestNodup hnextPositive + +/-- A zero data register stays zero throughout every conditional repair, +including when it is an unvisited captured destination. -/ +theorem repairStore_data_zero_internal (n : β„•) + (captured : List (β„• Γ— β„•)) (store : Structured.Store) (reg : β„•) + (hdata : cellBase n ≀ reg) (hzero : store reg = 0) : + repairStore n captured store reg = 0 := by + induction captured generalizing store with + | nil => exact hzero + | cons entry rest ih => + have hnextZero : repairBitStore n entry store reg = 0 := by + rw [repairBitStore_data_internal n entry store reg hdata] + by_cases hentryZero : + store (cellReg n (inputTape n) entry.1) = 0 + Β· simp [hentryZero, hzero] + Β· have hne : reg β‰  cellReg n (inputTape n) entry.1 := by + intro heq + subst reg + exact hentryZero hzero + simp [hentryZero, Function.update_of_ne hne, hzero] + simp only [repairStore] + exact ih (repairBitStore n entry store) hnextZero + +/-- Closed form of the accumulator-style capture traversal. -/ +private theorem captureValues_eq_reverse_append (store : Structured.Store) + (regs : List β„•) (captured : List (β„• Γ— β„•)) : + captureValues store regs captured = + (regs.map (fun reg => (reg, store reg))).reverse ++ captured := by + induction regs generalizing captured with + | nil => simp [captureValues] + | cons reg rest ih => + rw [captureValues, ih] + simp [List.reverse_cons, List.append_assoc] + +/-- Captured values selected for a public input. -/ +def capturedInput (n : β„•) (x : List Bool) : List (β„• Γ— β„•) := + captureValues (initRegs x) (captureRegs n) [] + +private theorem capturedInput_mem_iff (n : β„•) (x : List Bool) + (position : β„•) : + (position, initRegs x position) ∈ capturedInput n x ↔ + position ∈ captureRegs n := by + rw [capturedInput, captureValues_eq_reverse_append] + simp + +private theorem capturedInput_fst_nodup (n : β„•) (x : List Bool) : + ((capturedInput n x).map Prod.fst).Nodup := by + have hregs : (captureRegs n).Nodup := by + simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg] + rw [capturedInput, captureValues_eq_reverse_append] + simp only [List.append_nil, List.map_reverse, List.map_map] + simpa [Function.comp_def] using hregs + +private theorem capturedInput_positions (n : β„•) (x : List Bool) + {entry : β„• Γ— β„•} (hmem : entry ∈ capturedInput n x) : + entry.1 ∈ captureRegs n ∧ entry.2 = initRegs x entry.1 := by + rw [capturedInput, captureValues_eq_reverse_append] at hmem + simp only [List.append_nil, List.mem_reverse, List.mem_map] at hmem + obtain ⟨position, hposition, rfl⟩ := hmem + exact ⟨hposition, rfl⟩ + +private theorem initRegs_add_one_eq_input_symbol (x : List Bool) + {position : β„•} (hpositive : 0 < position) + (hlength : position ≀ x.length) : + initRegs x position + 1 = + symbolCode ((Tape.init (x.map Ξ“.ofBool)).cells position) := by + obtain ⟨index, rfl⟩ : βˆƒ index, position = index + 1 := + ⟨position - 1, by omega⟩ + have hindex : index < x.length := by omega + rw [Tape.init_ofBool_cells_lt x index hindex] + simp only [initRegs, show index + 1 β‰  0 by omega, ite_false] + rw [show index + 1 - 1 = index by omega, + List.getElem?_eq_getElem hindex] + cases x[index] <;> simp [Ξ“.ofBool, symbolCode] + +/-- After captured-position repair, every positive input cell has its exact TM +symbol code, cell zero is still temporarily blank, and all non-input tapes are +still blank. -/ +theorem repairStore_cells_internal (n : β„•) (x : List Bool) + (store : Structured.Store) + (hinvariant : MarshalInvariant n x 0 store) : + let repaired := repairStore n (capturedInput n x) store + (βˆ€ position, 0 < position β†’ + repaired (cellReg n (inputTape n) position) = + symbolCode ((Tape.init (x.map Ξ“.ofBool)).cells position)) ∧ + repaired (cellReg n (inputTape n) 0) = 0 ∧ + (βˆ€ (tape : Fin (n + 2)) (position : β„•), tape β‰  inputTape n β†’ + repaired (cellReg n tape position) = 0) := by + rcases hinvariant with + ⟨_, _, _, _, _, _, _, hexact, hpositive, hother⟩ + let captured := capturedInput n x + let repaired := repairStore n captured store + have hcapturedNodup : (captured.map Prod.fst).Nodup := by + exact capturedInput_fst_nodup n x + refine ⟨?_, ?_, ?_⟩ + Β· intro position hposition + by_cases hlength : position ≀ x.length + Β· by_cases hcaptured : position ∈ captureRegs n + Β· have hmem : (position, initRegs x position) ∈ captured := by + exact (capturedInput_mem_iff n x position).2 hcaptured + have hrepaired := repairStore_selected_internal n captured store + position (initRegs x position) hmem hcapturedNodup + (hpositive position hposition hlength) + exact hrepaired.trans + (initRegs_add_one_eq_input_symbol x hposition hlength) + Β· have hnot : βˆ€ entry, entry ∈ captured β†’ + cellReg n (inputTape n) position β‰  + cellReg n (inputTape n) entry.1 := by + intro entry hentry heq + have hentryInfo := capturedInput_positions n x hentry + apply hcaptured + rw [inputCell_injective n heq] + exact hentryInfo.1 + have hpreserved := repairStore_data_of_not_mem_internal n captured + store (cellReg n (inputTape n) position) + (inputCell_data n position) hnot + rw [hpreserved, hexact position hposition hlength hcaptured] + exact initRegs_add_one_eq_input_symbol x hposition hlength + Β· have hloopZero : store (cellReg n (inputTape n) position) = 0 := by + have hnot : βˆ€ candidate, 0 < candidate β†’ + candidate ≀ x.length β†’ + cellReg n (inputTape n) position β‰  + cellReg n (inputTape n) candidate := by + intro candidate _ hcandidate heq + have := inputCell_injective n heq + omega + rw [hother (cellReg n (inputTape n) position) + (inputCell_data n position) hnot] + have hpositiveReg : 0 < cellReg n (inputTape n) position := by + simp [cellReg, inputTape, cellBase] + simp [show Β¬ cellReg n (inputTape n) position ≀ 0 by omega] + have hrepaired := repairStore_data_zero_internal n captured store + (cellReg n (inputTape n) position) (inputCell_data n position) + hloopZero + rw [hrepaired] + obtain ⟨index, rfl⟩ : βˆƒ index, position = index + 1 := + ⟨position - 1, by omega⟩ + rw [Tape.init_ofBool_cells_ge x index (by omega)] + rfl + Β· have hloopZero : store (cellReg n (inputTape n) 0) = 0 := by + have hnot : βˆ€ candidate, 0 < candidate β†’ + candidate ≀ x.length β†’ + cellReg n (inputTape n) 0 β‰  + cellReg n (inputTape n) candidate := by + intro candidate hcandidate _ heq + have := inputCell_injective n heq + omega + rw [hother (cellReg n (inputTape n) 0) (inputCell_data n 0) hnot] + simp [cellReg, inputTape, cellBase] + exact repairStore_data_zero_internal n captured store + (cellReg n (inputTape n) 0) (inputCell_data n 0) hloopZero + Β· intro tape position htape + have hdata : cellBase n ≀ cellReg n tape position := by + unfold cellReg + omega + have hnot : βˆ€ candidate, 0 < candidate β†’ + candidate ≀ x.length β†’ + cellReg n tape position β‰  + cellReg n (inputTape n) candidate := by + intro candidate _ _ heq + have hpairs : (tape, position) = (inputTape n, candidate) := + cellReg_injective_internal (n := n) heq + exact htape (congrArg Prod.fst hpairs) + have hloopZero : store (cellReg n tape position) = 0 := by + rw [hother (cellReg n tape position) hdata hnot] + have hpositiveReg : 0 < cellReg n tape position := by + simp [cellReg, cellBase] + simp [show Β¬ cellReg n tape position ≀ 0 by omega] + exact repairStore_data_zero_internal n captured store + (cellReg n tape position) hdata hloopZero + +/-- Exact store after initializing state, heads, and all cell-zero markers. -/ +noncomputable def initializeStore (tm : TM n) + (store : Structured.Store) : Structured.Store := + Structured.Basic.execList (initializeConfigOps tm) store + +private theorem initializeConfigWrites_fst_nodup (tm : TM n) : + ((initializeConfigWrites tm).map Prod.fst).Nodup := by + let heads := (List.finRange (n + 2)).map headReg + let starts := (List.finRange (n + 2)).map fun tape => cellReg n tape 0 + have hheadInjective : Function.Injective (@headReg n) := by + intro left right heq + apply Fin.ext + simp [headReg] at heq + omega + have hstartInjective : Function.Injective + (fun tape : Fin (n + 2) => cellReg n tape 0) := by + intro left right heq + have hpairs : (left, 0) = (right, 0) := + cellReg_injective_internal (n := n) heq + exact congrArg Prod.fst hpairs + have hheads : heads.Nodup := + List.Nodup.map hheadInjective (List.nodup_finRange (n + 2)) + have hstarts : starts.Nodup := + List.Nodup.map hstartInjective (List.nodup_finRange (n + 2)) + have hdisjoint : βˆ€ head ∈ heads, βˆ€ start ∈ starts, head β‰  start := by + intro head hhead start hstart heq + simp only [heads, List.mem_map] at hhead + simp only [starts, List.mem_map] at hstart + obtain ⟨headTape, _, rfl⟩ := hhead + obtain ⟨startTape, _, rfl⟩ := hstart + simp [headReg, cellReg, cellBase] at heq + omega + have hcontrol : stateReg βˆ‰ heads ++ starts := by + intro hmem + rw [List.mem_append] at hmem + rcases hmem with hmem | hmem + Β· simp only [heads, List.mem_map] at hmem + obtain ⟨tape, _, heq⟩ := hmem + simp [stateReg, headReg] at heq + Β· simp only [starts, List.mem_map] at hmem + obtain ⟨tape, _, heq⟩ := hmem + simp [stateReg, cellReg, cellBase] at heq + have hresult : (stateReg :: heads ++ starts).Nodup := + List.nodup_cons.mpr + ⟨hcontrol, List.nodup_append.mpr ⟨hheads, hstarts, hdisjoint⟩⟩ + simpa [initializeConfigWrites, heads, starts, Function.comp_def] using hresult + +private theorem initializeConfigWrites_cell_pos_not_mem (tm : TM n) + (tape : Fin (n + 2)) (position : β„•) (hposition : 0 < position) : + cellReg n tape position βˆ‰ (initializeConfigWrites tm).map Prod.fst := by + intro hmem + rw [List.mem_map] at hmem + obtain ⟨write, hwrite, heq⟩ := hmem + simp only [initializeConfigWrites, List.mem_append, List.mem_cons, + List.not_mem_nil, or_false, List.mem_map] at hwrite + rcases hwrite with hstateOrHead | hstart + Β· rcases hstateOrHead with heqState | hhead + Β· subst write + simp [stateReg, cellReg, cellBase] at heq + omega + Β· obtain ⟨headTape, _, rfl⟩ := hhead + simp [headReg, cellReg, cellBase] at heq + omega + Β· obtain ⟨startTape, _, rfl⟩ := hstart + have hpairs : (tape, position) = (startTape, 0) := + cellReg_injective_internal (n := n) heq.symm + have := congrArg Prod.snd hpairs + omega + +/-- State, head, and left-marker initialization turns repaired tape data into +the complete sparse representation of `tm.initCfg x`. -/ +theorem initializeStore_represents_internal (tm : TM n) (x : List Bool) + (store : Structured.Store) + (hinvariant : MarshalInvariant n x 0 store) : + Represents tm (tm.initCfg x) + (initializeStore tm (repairStore n (capturedInput n x) store)) := by + let repaired := repairStore n (capturedInput n x) store + have hcells := repairStore_cells_internal n x store hinvariant + have hnodup := initializeConfigWrites_fst_nodup tm + intro field + rcases field with state | headOrCell + Β· rcases state with ⟨state, hstate⟩ + have hstateZero : state = 0 := by omega + subst state + change initializeStore tm repaired stateReg = stateCode tm tm.qstart + unfold initializeStore initializeConfigOps + apply Structured.Internal.Basic.execList_imm_apply_of_mem + (initializeConfigWrites tm) repaired hnodup + simp [initializeConfigWrites] + Β· rcases headOrCell with tape | cell + Β· change initializeStore tm repaired (headReg tape) = + (tapeAt (tm.initCfg x) tape).head + have hwrite : initializeStore tm repaired (headReg tape) = 0 := by + unfold initializeStore initializeConfigOps + apply Structured.Internal.Basic.execList_imm_apply_of_mem + (initializeConfigWrites tm) repaired hnodup + simp [initializeConfigWrites] + rw [hwrite] + unfold tapeAt + split + Β· rfl + Β· split <;> rfl + Β· rcases cell with ⟨tape, position⟩ + change initializeStore tm repaired (cellReg n tape position) = + symbolCode ((tapeAt (tm.initCfg x) tape).cells position) + by_cases hposition : position = 0 + Β· subst position + have hwrite : initializeStore tm repaired (cellReg n tape 0) = + symbolCode Ξ“.start := by + unfold initializeStore initializeConfigOps + apply Structured.Internal.Basic.execList_imm_apply_of_mem + (initializeConfigWrites tm) repaired hnodup + simp [initializeConfigWrites] + rw [hwrite] + unfold tapeAt + split <;> simp [Tape.init] + Β· have hpositive : 0 < position := by omega + have hpreserved : initializeStore tm repaired + (cellReg n tape position) = repaired (cellReg n tape position) := by + unfold initializeStore initializeConfigOps + exact Structured.Internal.Basic.execList_imm_apply_of_not_mem + (initializeConfigWrites tm) repaired (cellReg n tape position) + (initializeConfigWrites_cell_pos_not_mem tm tape position hpositive) + rw [hpreserved] + by_cases htape : tape = inputTape n + Β· subst tape + have hinput := hcells.1 position hpositive + change repaired (cellReg n (inputTape n) position) = _ at hinput + rw [hinput] + simp [tapeAt, inputTape] + Β· have hblank := hcells.2.2 tape position htape + change repaired (cellReg n tape position) = 0 at hblank + rw [hblank] + unfold tapeAt + split + Β· rename_i hinput + exfalso + apply htape + apply Fin.ext + simpa [inputTape] using hinput + Β· split <;> simp [Tape.init, hposition, symbolCode] + +/-- The selected capture-tree leaf executes the constant setup, exact backward +copy, conditional repair, and semantic initialization, ending in a complete +sparse representation of the TM's initial configuration. -/ +theorem marshalLeaf_exec_internal (tm : TM n) (x : List Bool) : + βˆƒ final steps cost space, + Structured.Exec (marshalLeaf tm (capturedInput n x)) + (initRegs x) final steps cost space ∧ + Represents tm (tm.initCfg x) final := by + obtain ⟨setupCost, setupSpace, hsetup⟩ := + Structured.Internal.exec_basics_exists (marshalConstants n) (initRegs x) + have hstartInvariant := marshalStart_invariant_internal n x + obtain ⟨looped, loopCost, loopSpace, hloop, hloopInvariant⟩ := + marshalLoop_invariant_exec_internal n x x.length (marshalStart n x) + hstartInvariant + obtain ⟨repairSteps, repairCost, repairSpace, hrepair⟩ := + repairCaptured_exec_internal n (capturedInput n x) looped + obtain ⟨initializeCost, initializeSpace, hinitialize⟩ := + Structured.Internal.exec_basics_exists (initializeConfigOps tm) + (repairStore n (capturedInput n x) looped) + have hrepresents := initializeStore_represents_internal tm x looped + hloopInvariant + let repaired := repairStore n (capturedInput n x) looped + let final := initializeStore tm repaired + have htail := Structured.Exec.seq hrepair hinitialize + have hcopy := Structured.Exec.seq hloop htail + have hexec := Structured.Exec.seq hsetup hcopy + refine ⟨final, + (marshalConstants n).length + + (marshalLoopSteps n x.length + + (repairSteps + (initializeConfigOps tm).length)), + setupCost + (loopCost + (repairCost + initializeCost)), + max setupSpace (max loopSpace (max repairSpace initializeSpace)), ?_, ?_⟩ + Β· simpa [marshalLeaf, capturedInput, marshalStart, repaired, final, + initializeStore] using hexec + Β· simpa [repaired, final] using hrepresents + +/-- The fixed public-ABI marshaller follows the unique capture-tree path for +the input and establishes the sparse initial TM configuration. -/ +theorem marshalInput_exec_internal (tm : TM n) (x : List Bool) : + βˆƒ final steps cost space, + Structured.Exec (marshalInput tm) (initRegs x) final steps cost space ∧ + Represents tm (tm.initCfg x) final := by + obtain ⟨final, leafSteps, leafCost, leafSpace, hleaf, hrepresents⟩ := + marshalLeaf_exec_internal tm x + have hselected : βˆƒ steps cost space, + Structured.Exec + (marshalLeaf tm + (captureValues (initRegs x) (captureRegs n) [])) + (initRegs x) final steps cost space := by + exact ⟨leafSteps, leafCost, leafSpace, by simpa [capturedInput] using hleaf⟩ + obtain ⟨steps, cost, space, hexec⟩ := + marshalInput_exec_of_leaf_internal tm x hselected + exact ⟨final, steps, cost, space, hexec, hrepresents⟩ + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Resources.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Resources.lean new file mode 100644 index 0000000000..30bbaa69a1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/ABI/Internal/Resources.lean @@ -0,0 +1,1266 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI.Internal.Decision +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Resources + +/-! +# Resource bounds for the public sparse-simulator ABI -- proof internals + +The simulation core uses `StepEnvelope`. During the backward input copy only +the writable value scratch register can temporarily exceed the core word bound; +`MarshalEnvelope` records that exception while retaining the same finite index +support. The first captured-position repair reloads that scratch register from +the sparse data region, returning to the core envelope before simulation. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Temporary marshalling envelope. Every register except `valueReg` already +fits the core word bound; the value scratch may use the larger `valueLimit`. -/ +structure MarshalEnvelope (tm : TM n) (bound valueLimit : β„•) + (store : Structured.Store) : Prop where + index_lt : βˆ€ index, store index β‰  0 β†’ index < registerBound n (bound + 1) + value_le : βˆ€ index, store index ≀ valueLimit + value_le_of_ne : βˆ€ index, index β‰  valueReg n β†’ + store index ≀ wordBound tm bound + +theorem MarshalEnvelope.storeEnvelope {tm : TM n} {bound valueLimit : β„•} + {store : Structured.Store} (henvelope : MarshalEnvelope tm bound valueLimit store) : + Structured.Internal.StoreEnvelope (registerBound n (bound + 1)) + valueLimit store := + ⟨henvelope.index_lt, henvelope.value_le⟩ + +theorem StepEnvelope.toMarshalEnvelope {tm : TM n} {bound valueLimit : β„•} + {store : Structured.Store} (henvelope : StepEnvelope tm bound store) + (hlimit : wordBound tm bound ≀ valueLimit) : + MarshalEnvelope tm bound valueLimit store where + index_lt := henvelope.index_lt + value_le index := le_trans (henvelope.value_le index) hlimit + value_le_of_ne index _ := henvelope.value_le index + +private theorem control_lt_registerBound (n bound : β„•) : + cellBase n < registerBound n (bound + 1) := + control_lt_registerBound_internal n bound + +private theorem smallValue_le_wordBound (tm : TM n) (bound value : β„•) + (hvalue : value ≀ 4) : value ≀ wordBound tm bound := by + have hfour : 4 ≀ registerBound n (bound + 1) := by + have hcontrol := control_lt_registerBound n bound + simp [cellBase] at hcontrol + omega + exact le_trans hvalue + (le_trans hfour (registerBound_le_wordBound_internal tm bound)) + +private theorem cellReg_le_wordBound (tm : TM n) (bound : β„•) + (tape : Fin (n + 2)) {position : β„•} (hposition : position ≀ bound + 1) : + cellReg n tape position ≀ wordBound tm bound := + le_trans (Nat.le_of_lt + (cellReg_lt_registerBound_internal tape (bound := bound) hposition)) + (registerBound_le_wordBound_internal tm bound) + +private theorem registerBound_mono (n : β„•) {bound larger : β„•} + (hle : bound ≀ larger) : + registerBound n bound ≀ registerBound n larger := by + have hmul := Nat.mul_le_mul_right (n + 2) hle + simp only [registerBound, cellReg, outputTape, Fin.val_mk] + omega + +private theorem wordBound_mono (tm : TM n) {bound larger : β„•} + (hle : bound ≀ larger) : wordBound tm bound ≀ wordBound tm larger := by + simp only [wordBound] + apply Nat.max_le.mpr + constructor + Β· exact le_trans (registerBound_mono n (Nat.add_le_add_right hle 1)) + (Nat.le_max_left _ _) + Β· apply Nat.max_le.mpr + constructor + Β· exact le_trans (Nat.le_max_left _ _) (Nat.le_max_right _ _) + Β· exact le_trans (Nat.add_le_add_right hle 1) + (le_trans (Nat.le_max_right _ _) (Nat.le_max_right _ _)) + +private theorem StepEnvelope.monoBound {tm : TM n} {bound larger : β„•} + {store : Structured.Store} (henvelope : StepEnvelope tm bound store) + (hle : bound ≀ larger) : StepEnvelope tm larger store := + henvelope.mono + (registerBound_mono n (Nat.add_le_add_right hle 1)) + (wordBound_mono tm hle) + +private theorem spaceBound_mono (tm : TM n) {bound larger : β„•} + (hle : bound ≀ larger) : spaceBound tm bound ≀ spaceBound tm larger := by + have hregister := registerBound_mono n (Nat.add_le_add_right hle 1) + have hword := wordBound_mono tm hle + have hregisterSize := Nat.size_le_size hregister + have hwordSize := Nat.size_le_size hword + simp only [spaceBound, bitlen] + exact Nat.mul_le_mul hregister + (Nat.add_le_add hregisterSize hwordSize) + +theorem decisionTimeBound_mono_steps_internal (tm : TM n) + (inputLength : β„•) {steps larger : β„•} (hle : steps ≀ larger) : + decisionTimeBound tm inputLength steps ≀ + decisionTimeBound tm inputLength larger := by + have hbound : marshalBound n inputLength + steps ≀ + marshalBound n inputLength + larger := Nat.add_le_add_left hle _ + have hword := wordBound_mono tm hbound + have hwidth : wordWidth tm (marshalBound n inputLength + steps) ≀ + wordWidth tm (marshalBound n inputLength + larger) := by + have hsize := Nat.size_le_size hword + simpa [wordWidth, bitlen] using! Nat.add_le_add_right hsize 1 + have hfactor : (steps + 1) * runFactor tm ≀ + (larger + 1) * runFactor tm := + Nat.mul_le_mul_right _ (Nat.add_le_add_right hle 1) + simp only [decisionTimeBound] + exact Nat.add_le_add + (Nat.add_le_add_left (Nat.mul_le_mul hfactor hwidth) _) + (Nat.mul_le_mul_left (4 * (extractVerdictOps n).length) hwidth) + +private theorem inputLength_succ_le_marshalBaseBound (n inputLength : β„•) : + inputLength + 1 ≀ marshalBaseBound n inputLength := by + have hmul : inputLength + 1 ≀ (inputLength + 1) * (n + 2) := + le_mul_of_one_le_right (Nat.zero_le _) (by omega) + simp only [marshalBaseBound, registerBound, cellReg, outputTape, + Fin.val_mk] + omega + +private theorem cellBase_le_marshalBaseBound (n inputLength : β„•) : + cellBase n ≀ marshalBaseBound n inputLength := by + simp only [marshalBaseBound, registerBound, cellReg, outputTape, + Fin.val_mk] + omega + +private theorem marshalBaseBound_le_wordBound (tm : TM n) + (inputLength : β„•) : + marshalBaseBound n inputLength ≀ wordBound tm (marshalBound n inputLength) := by + apply le_trans (show marshalBaseBound n inputLength ≀ + marshalBound n inputLength + 1 by simp [marshalBound]; omega) + exact bound_succ_le_wordBound_internal tm (marshalBound n inputLength) + +private theorem marshalValue_le_wordBound (tm : TM n) + {inputLength processed : β„•} (hprocessed : processed ≀ inputLength) : + marshalBaseBound n inputLength + processed ≀ + wordBound tm (marshalBound n inputLength) := by + apply le_trans (show marshalBaseBound n inputLength + processed ≀ + marshalBound n inputLength + 1 by simp [marshalBound]; omega) + exact bound_succ_le_wordBound_internal tm (marshalBound n inputLength) + +private theorem initRegs_marshalEnvelope (n : β„•) (x : List Bool) : + Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length) (initRegs x) := by + have hinput := Structured.Internal.Input.bitStoreEnvelope + (lengthReg := 0) (inputBase := 1) + (indexBound := registerBound n (marshalBound n x.length + 1)) + (valueBound := marshalBaseBound n x.length) x + (by + have hbound := bound_lt_registerBound_internal n + (marshalBound n x.length) + omega) + (by + have hlength := inputLength_succ_le_marshalBaseBound n x.length + have hbound := bound_lt_registerBound_internal n + (marshalBound n x.length) + have hmarshal : 1 + x.length ≀ marshalBound n x.length := by + simp only [marshalBound] + omega + exact Nat.le_of_lt (lt_of_le_of_lt hmarshal hbound)) + (by + have := inputLength_succ_le_marshalBaseBound n x.length + omega) + (by + have := inputLength_succ_le_marshalBaseBound n x.length + omega) + have hinit : initRegs x = Structured.Input.bitStore 0 1 x := by + funext index + by_cases hzero : index = 0 + Β· subst index + simp [initRegs, Structured.Input.bitStore] + Β· have hone : 1 ≀ index := Nat.one_le_iff_ne_zero.mpr hzero + simp [initRegs, Structured.Input.bitStore, Structured.Input.bitValue, + hzero, hone] + rfl + rw [hinit] + exact hinput + +/-- Installing the four copy-loop constants has a uniform marshalling +envelope and establishes the semantic loop invariant. -/ +theorem marshalConstants_measured_internal (tm : TM n) (x : List Bool) : + Structured.Internal.MeasuredRuns (.basics (marshalConstants n)) + (initRegs x) (marshalStart n x) (marshalConstants n).length + (4 * (marshalConstants n).length * + Structured.Internal.valueWidth (marshalBaseBound n x.length)) + (Structured.Internal.envelopeSpace + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length)) ∧ + MarshalEnvelope tm (marshalBound n x.length) + (marshalBaseBound n x.length) (marshalStart n x) ∧ + MarshalInvariant n x x.length (marshalStart n x) := by + have hinitial := initRegs_marshalEnvelope n x + have hpreserve : βˆ€ op, op ∈ marshalConstants n β†’ + βˆ€ store, Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length) store β†’ + Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length) (op.exec store) := by + intro op hop store henvelope + simp [marshalConstants] at hop + rcases hop with rfl | rfl | rfl | rfl + Β· apply henvelope.execBasic + Β· exact lt_trans (scratch_range_internal n).1.2 + (control_lt_registerBound n (marshalBound n x.length)) + Β· simp + Β· apply henvelope.execBasic + Β· exact lt_trans (scratch_range_internal n).2.1.2 + (control_lt_registerBound n (marshalBound n x.length)) + Β· have hbase := cellBase_le_marshalBaseBound n x.length + simp [cellBase] at hbase ⊒ + omega + Β· apply henvelope.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.1.2 + (control_lt_registerBound n (marshalBound n x.length)) + Β· exact le_trans (by simp [cellBase]; omega) + (cellBase_le_marshalBaseBound n x.length) + Β· apply henvelope.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.1.2 + (control_lt_registerBound n (marshalBound n x.length)) + Β· exact cellBase_le_marshalBaseBound n x.length + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelope + (marshalConstants n) (initRegs x) hinitial hpreserve + have hbaseWord := marshalBaseBound_le_wordBound tm x.length + have hmarshal : MarshalEnvelope tm (marshalBound n x.length) + (marshalBaseBound n x.length) (marshalStart n x) := by + have hfinal := hmeasured.2 + exact ⟨hfinal.index_lt, hfinal.value_le, + fun index _ => le_trans (hfinal.value_le index) hbaseWord⟩ + simpa [marshalStart] using! And.intro hmeasured.1 + (And.intro hmarshal (marshalStart_invariant_internal n x)) + +/-- Loading, clearing, and encoding a positive source cursor retain the cursor register. -/ +private theorem marshalLoop_encodedState (n : β„•) (store : Structured.Store) (cursor : β„•) + (hcursor : 0 < cursor) (hstate : store stateReg = cursor) : + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := + (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + sourceLoaded (addressReg n) = cursor β†’ encoded stateReg = cursor := by + dsimp only + intro hloadedAddress + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := + (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + have hsourceAddressedState : sourceAddressed stateReg = cursor := by + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, addressReg])] + exact hstate + have hsourceLoadedState : sourceLoaded stateReg = cursor := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + exact hsourceAddressedState + have hsourceClearedState : sourceCleared stateReg = cursor := by + simp only [sourceCleared, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· exact hsourceLoadedState + Β· rw [show sourceLoaded (addressReg n) = cursor from hloadedAddress] + simp [stateReg] + omega + have hbasedState : based stateReg = cursor := by + simp only [based, counted, oned, zeroed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, stateScratchReg]), + Function.update_of_ne (by simp [stateReg, tapeCountReg]), + Function.update_of_ne (by simp [stateReg, oneReg]), + Function.update_of_ne (by simp [stateReg, zeroReg])] + exact hsourceClearedState + have hencodedState : encoded stateReg = cursor := by + simp only [encoded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [stateReg, valueReg])] + exact hbasedState + exact hencodedState + +private theorem marshalLoopOps_envelopeChain (n : β„•) (x : List Bool) + {cursor processed : β„•} {store : Structured.Store} + (hcursor : 0 < cursor) + (hinvariant : MarshalInvariant n x cursor store) + (henvelope : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) store) : + Structured.Internal.Basic.EnvelopeChain + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed + 1) + (marshalLoopOps n) store := by + let limit := marshalBaseBound n x.length + processed + 1 + let sourceAddressed := + (Structured.Basic.add (addressReg n) stateReg (zeroReg n)).exec store + let sourceLoaded := + (Structured.Basic.load (valueReg n) (addressReg n)).exec sourceAddressed + let sourceCleared := + (Structured.Basic.store (addressReg n) (zeroReg n)).exec sourceLoaded + let zeroed := (Structured.Basic.imm (zeroReg n) 0).exec sourceCleared + let oned := (Structured.Basic.imm (oneReg n) 1).exec zeroed + let counted := + (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec oned + let based := + (Structured.Basic.imm (stateScratchReg n) (cellBase n)).exec counted + let encoded := + (Structured.Basic.add (valueReg n) (valueReg n) (oneReg n)).exec based + let multiplied := + (Structured.Basic.mul (addressReg n) stateReg (tapeCountReg n)).exec encoded + let destinationAddressed := + (Structured.Basic.add (addressReg n) (addressReg n) + (stateScratchReg n)).exec multiplied + let destinationStored := + (Structured.Basic.store (addressReg n) (valueReg n)).exec + destinationAddressed + let final := + (Structured.Basic.sub stateReg stateReg (oneReg n)).exec destinationStored + have hindexControl := control_lt_registerBound n (marshalBound n x.length) + have hstore : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit store := + henvelope.mono le_rfl (by omega) + have hstate : store stateReg = cursor := hinvariant.1 + have hcursorLength : cursor ≀ x.length := hinvariant.2.1 + have hzero : store (zeroReg n) = 0 := hinvariant.2.2.1 + have hsourceAddressedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) + sourceAddressed := by + apply henvelope.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.2.1.2 hindexControl + Β· simp [Structured.Internal.Basic.writeValue, hstate, hzero] + exact le_trans hcursorLength + (le_trans (show x.length ≀ marshalBaseBound n x.length by + have := inputLength_succ_le_marshalBaseBound n x.length + omega) (by omega)) + have hsourceAddress : sourceAddressed (addressReg n) = cursor := by + simp [sourceAddressed, Structured.Basic.exec, hstate, hzero] + have hsourceAddressed : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit sourceAddressed := + hsourceAddressedCurrent.mono le_rfl (by omega) + have hsourceLoadedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) + sourceLoaded := by + apply hsourceAddressedCurrent.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.2.2.1.2 hindexControl + Β· exact hsourceAddressedCurrent.value_le _ + have hsourceLoaded : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit sourceLoaded := + hsourceLoadedCurrent.mono le_rfl (by omega) + have hloadedAddress : sourceLoaded (addressReg n) = cursor := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [addressReg, valueReg])] + exact hsourceAddress + have hloadedZero : sourceLoaded (zeroReg n) = 0 := by + simp only [sourceLoaded, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, valueReg])] + simp only [sourceAddressed, Structured.Basic.exec] + rw [Function.update_of_ne (by simp [zeroReg, addressReg])] + exact hzero + have hsourceClearedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) + sourceCleared := by + apply hsourceLoadedCurrent.execBasic + Β· simp only [Structured.Internal.Basic.writeIndex] + rw [hloadedAddress] + apply lt_of_le_of_lt hcursorLength + apply lt_of_le_of_lt (show x.length ≀ marshalBound n x.length by + simp [marshalBound]) + exact bound_lt_registerBound_internal n (marshalBound n x.length) + Β· simp [Structured.Internal.Basic.writeValue, hloadedZero] + have hsourceCleared : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit sourceCleared := + hsourceClearedCurrent.mono le_rfl (by omega) + have hzeroedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) zeroed := by + apply hsourceClearedCurrent.execBasic + Β· exact lt_trans (scratch_range_internal n).1.2 hindexControl + Β· simp + have hzeroed : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit zeroed := + hzeroedCurrent.mono le_rfl (by omega) + have honedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) oned := by + apply hzeroedCurrent.execBasic + Β· exact lt_trans (scratch_range_internal n).2.1.2 hindexControl + Β· have hbase := inputLength_succ_le_marshalBaseBound n x.length + simp + omega + have honed : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit oned := + honedCurrent.mono le_rfl (by omega) + have hcountedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) counted := by + apply honedCurrent.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.1.2 hindexControl + Β· have hbase := cellBase_le_marshalBaseBound n x.length + simp [Structured.Internal.Basic.writeValue, cellBase] at hbase ⊒ + omega + have hcounted : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit counted := + hcountedCurrent.mono le_rfl (by omega) + have hbasedCurrent : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) based := by + apply hcountedCurrent.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.1.2 hindexControl + Β· exact le_trans (cellBase_le_marshalBaseBound n x.length) (by + simp) + have hbased : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit based := + hbasedCurrent.mono le_rfl (by omega) + have hbasedValue : based (valueReg n) ≀ + marshalBaseBound n x.length + processed := + hbasedCurrent.value_le _ + have hbasedOne : based (oneReg n) = 1 := by + simp [based, counted, oned, Structured.Basic.exec, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hencoded : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit encoded := by + apply hbased.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.2.2.1.2 hindexControl + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hbasedOne] + exact Nat.add_le_add_right hbasedValue 1 + have hencodedState : encoded stateReg = cursor := + marshalLoop_encodedState n store cursor hcursor hstate hloadedAddress + have hencodedCount : encoded (tapeCountReg n) = n + 2 := by + simp [encoded, based, counted, Structured.Basic.exec, tapeCountReg, + stateScratchReg, valueReg, Function.update_of_ne] + have hcursorCellBase : cursor * (n + 2) + cellBase n ≀ + marshalBaseBound n x.length := by + have hmul := Nat.mul_le_mul_right (n + 2) hcursorLength + have hmulSucc := Nat.mul_le_mul_right (n + 2) + (show x.length ≀ x.length + 1 by omega) + simp only [marshalBaseBound, registerBound, cellReg, outputTape, + Fin.val_mk] + omega + have hmultiplied : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit multiplied := by + apply hencoded.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.2.1.2 hindexControl + Β· change encoded stateReg * encoded (tapeCountReg n) ≀ limit + rw [hencodedState, hencodedCount] + exact le_trans (show cursor * (n + 2) ≀ + cursor * (n + 2) + cellBase n by omega) + (le_trans hcursorCellBase (by omega)) + have hmultipliedAddress : multiplied (addressReg n) = cursor * (n + 2) := by + simp [multiplied, Structured.Basic.exec, hencodedState, hencodedCount] + have hmultipliedBase : multiplied (stateScratchReg n) = cellBase n := by + simp [multiplied, encoded, based, Structured.Basic.exec, + stateScratchReg, addressReg, valueReg, Function.update_of_ne] + have hdestinationAddressed : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit + destinationAddressed := by + apply hmultiplied.execBasic + Β· exact lt_trans (scratch_range_internal n).2.2.2.2.1.2 hindexControl + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hmultipliedAddress, hmultipliedBase] + exact le_trans hcursorCellBase (by omega) + have hdestinationAddress : destinationAddressed (addressReg n) = + cellReg n (inputTape n) cursor := by + simp [destinationAddressed, Structured.Basic.exec, hmultipliedAddress, + hmultipliedBase, cellReg, inputTape, Nat.add_comm] + have hdestinationStored : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit + destinationStored := by + apply hdestinationAddressed.execBasic + Β· simp only [Structured.Internal.Basic.writeIndex] + rw [hdestinationAddress] + exact cellReg_lt_registerBound_internal (inputTape n) + (show cursor ≀ marshalBound n x.length + 1 by + simp [marshalBound] + omega) + Β· exact hdestinationAddressed.value_le _ + have hfinal : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) limit final := by + apply hdestinationStored.execBasic + Β· simp [stateReg, registerBound, cellReg, outputTape, cellBase] + Β· exact le_trans (Nat.sub_le _ _) + (hdestinationStored.value_le stateReg) + simp only [marshalLoopOps, Structured.Internal.Basic.EnvelopeChain] + exact ⟨hstore, hsourceAddressed, hsourceLoaded, hsourceCleared, hzeroed, + honed, hcounted, hbased, hencoded, hmultiplied, + hdestinationAddressed, hdestinationStored, hfinal⟩ + +private theorem envelopeChain_monoValue {indexBound valueBound largerValue : β„•} + {ops : List Structured.Basic} {store : Structured.Store} + (hchain : Structured.Internal.Basic.EnvelopeChain + indexBound valueBound ops store) + (hvalue : valueBound ≀ largerValue) : + Structured.Internal.Basic.EnvelopeChain + indexBound largerValue ops store := by + induction ops generalizing store with + | nil => exact hchain.mono le_rfl hvalue + | cons op rest ih => + exact ⟨hchain.1.mono le_rfl hvalue, ih hchain.2⟩ + +private theorem marshalLoop_measured_aux (n : β„•) (x : List Bool) + {cursor processed : β„•} {store : Structured.Store} + (hbalance : processed + cursor = x.length) + (hinvariant : MarshalInvariant n x cursor store) + (henvelope : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed) store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (marshalLoop n) store final + (marshalLoopSteps n cursor) + ((cursor * (3 + 4 * (marshalLoopOps n).length) + 1) * + marshalWidth n x.length) + (marshalSpaceBound n x.length) ∧ + MarshalInvariant n x 0 final ∧ + Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + processed + cursor) final := by + induction cursor generalizing processed store with + | zero => + have hzero : store stateReg = 0 := hinvariant.1 + have hglobal : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBound n x.length) store := by + have hp : processed = x.length := by omega + simpa [marshalBound, hp] using! henvelope + have hrun := Structured.Internal.MeasuredRuns.whileZeroEnvelope + (body := .basics (marshalLoopOps n)) hzero hglobal + refine ⟨store, ?_, hinvariant, ?_⟩ + Β· simpa [marshalLoop, marshalLoopSteps, marshalLoopTimeBound, + marshalWidth, marshalSpaceBound, + Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using! hrun + Β· simpa using! henvelope + | succ cursor ih => + have hpositive : 0 < cursor + 1 := by omega + have hnonzero : store stateReg β‰  0 := by + rw [hinvariant.1] + omega + have hprocessed : processed + 1 ≀ x.length := by omega + have hchain := marshalLoopOps_envelopeChain n x hpositive hinvariant + henvelope + have hchainGlobal := envelopeChain_monoValue hchain + (show marshalBaseBound n x.length + processed + 1 ≀ + marshalBound n x.length by + simp [marshalBound] + omega) + let middle := Structured.Basic.execList (marshalLoopOps n) store + have hbody := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (marshalLoopOps n) store hchainGlobal |>.1 + have hmiddleInvariant : MarshalInvariant n x cursor middle := by + have hstep := marshalLoopOps_invariant_internal n x (cursor + 1) + store hpositive hinvariant + simpa [middle] using! hstep + have hmiddleEnvelope : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBaseBound n x.length + (processed + 1)) middle := by + have hfinal := hchain.final + simpa [middle, Nat.add_assoc] using! hfinal + obtain ⟨final, hloop, hfinalInvariant, hfinalEnvelope⟩ := + ih (processed := processed + 1) (store := middle) + (by omega) hmiddleInvariant hmiddleEnvelope + have hinitialGlobal : Structured.Internal.StoreEnvelope + (registerBound n (marshalBound n x.length + 1)) + (marshalBound n x.length) store := + henvelope.mono le_rfl (by simp [marshalBound]; omega) + have hrun := Structured.Internal.MeasuredRuns.whileNonzeroEnvelope + hnonzero hinitialGlobal hbody hloop + refine ⟨final, ?_, hfinalInvariant, ?_⟩ + Β· convert! hrun using 1 + all_goals simp [marshalLoopSteps, marshalWidth, + Structured.Internal.valueWidth, Nat.succ_mul] + all_goals ring + Β· convert! hfinalEnvelope using 1 + omega + +/-- The backward-copy loop has an exact source-step count, linear logarithmic +cost, and a finite sparse-store envelope. -/ +theorem marshalLoop_measured_internal {tm : TM n} (x : List Bool) : + βˆƒ final, + Structured.Internal.MeasuredRuns (marshalLoop n) (marshalStart n x) final + (marshalLoopSteps n x.length) (marshalLoopTimeBound n x.length) + (marshalSpaceBound n x.length) ∧ + MarshalInvariant n x 0 final ∧ + StepEnvelope tm (marshalBound n x.length) final := by + obtain ⟨_hconstants, hmarshal, hinvariant⟩ := + marshalConstants_measured_internal tm x + obtain ⟨final, hrun, hfinalInvariant, hfinalEnvelope⟩ := + marshalLoop_measured_aux n x (processed := 0) (store := marshalStart n x) + (by simp) hinvariant hmarshal.storeEnvelope + refine ⟨final, ?_, hfinalInvariant, ?_⟩ + Β· simpa using! hrun + Β· apply hfinalEnvelope.mono le_rfl + (show marshalBaseBound n x.length + 0 + x.length ≀ + wordBound tm (marshalBound n x.length) by + simpa [marshalBound] using! + (marshalValue_le_wordBound tm (processed := x.length) le_rfl)) + +/-- The verdict extractor stays in the core envelope and has the standard +four-width-per-basic-instruction cost bound. -/ +theorem extractVerdict_measured_internal {tm : TM n} {bound : β„•} + {halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm halted store) + (henvelope : StepEnvelope tm bound store) : + let final := Structured.Basic.execList (extractVerdictOps n) store + Structured.Internal.MeasuredRuns (.basics (extractVerdictOps n)) store final + (extractVerdictOps n).length + (4 * (extractVerdictOps n).length * wordWidth tm bound) + (spaceBound tm bound) ∧ + StepEnvelope tm bound final ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + let addressed := (Structured.Basic.imm (addressReg n) + (cellReg n (outputTape n) 1)).exec store + let loaded := (Structured.Basic.load stateReg (addressReg n)).exec addressed + let oned := (Structured.Basic.imm (oneReg n) 1).exec loaded + let final := (Structured.Basic.sub stateReg stateReg (oneReg n)).exec oned + have hrange := scratch_range_internal n + have haddressValue := cellReg_le_wordBound tm bound (outputTape n) + (position := 1) (by omega) + have haddressed : StepEnvelope tm bound addressed := by + apply henvelope.execBasic + Β· exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using! haddressValue + have hloaded : StepEnvelope tm bound loaded := by + apply haddressed.execBasic + Β· simp [stateReg, registerBound, cellReg, outputTape, cellBase] + Β· exact haddressed.value_le (addressed (addressReg n)) + have honeBound : 1 ≀ wordBound tm bound := + smallValue_le_wordBound tm bound 1 (by omega) + have honed : StepEnvelope tm bound oned := by + apply hloaded.execBasic + Β· exact lt_trans hrange.2.1.2 (control_lt_registerBound n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using! honeBound + have hfinal : StepEnvelope tm bound final := by + apply honed.execBasic + Β· simp [stateReg, registerBound, cellReg, outputTape, cellBase] + Β· exact le_trans (Nat.sub_le _ _) (honed.value_le stateReg) + have hchain : Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (extractVerdictOps n) store := by + simpa [extractVerdictOps, addressed, loaded, oned, final] using! + And.intro henvelope + (And.intro haddressed (And.intro hloaded (And.intro honed hfinal))) + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (extractVerdictOps n) store hchain + have hverdict := extractVerdict_exec_internal hrepresents + refine ⟨?_, hfinal, ?_⟩ + Β· simpa [wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using! hmeasured.1 + Β· obtain ⟨_cost, _space, _hexec, hvalue⟩ := hverdict + simpa [final] using! hvalue + +private theorem repairBit_measured_internal {tm : TM n} {bound valueLimit : β„•} + {entry : β„• Γ— β„•} {store : Structured.Store} + (hposition : entry.1 ≀ bound + 1) (hvalue : entry.2 ≀ 1) + (henvelope : MarshalEnvelope tm bound valueLimit store) + (hwordLimit : wordBound tm bound ≀ valueLimit) : + βˆƒ steps, + Structured.Internal.MeasuredRuns (repairBit n entry) store + (repairBitStore n entry store) steps + (27 * (bitlen valueLimit + 1)) + (Structured.Internal.envelopeSpace + (registerBound n (bound + 1)) valueLimit) ∧ + StepEnvelope tm bound (repairBitStore n entry store) := by + let addressed := (Structured.Basic.imm (addressReg n) + (cellReg n (inputTape n) entry.1)).exec store + let loaded := (Structured.Basic.load (valueReg n) (addressReg n)).exec addressed + have hrange := scratch_range_internal n + have haddressBound := cellReg_le_wordBound tm bound (inputTape n) hposition + have haddressedMarshal : MarshalEnvelope tm bound valueLimit addressed := by + refine ⟨?_, ?_, ?_⟩ + Β· intro index hnonzero + by_cases heq : index = addressReg n + Β· subst index + exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· exact henvelope.index_lt index (by + simpa [addressed, Structured.Basic.exec, + Function.update_of_ne heq] using! hnonzero) + Β· intro index + by_cases heq : index = addressReg n + Β· subst index + simpa [addressed, Structured.Basic.exec] using! + le_trans haddressBound hwordLimit + Β· simpa [addressed, Structured.Basic.exec, + Function.update_of_ne heq] using! henvelope.value_le index + Β· intro index hne + by_cases heq : index = addressReg n + Β· subst index + simpa [addressed, Structured.Basic.exec] using! haddressBound + Β· simpa [addressed, Structured.Basic.exec, + Function.update_of_ne heq] using! henvelope.value_le_of_ne index hne + have haddressedStore := haddressedMarshal.storeEnvelope + have haddress : addressed (addressReg n) = + cellReg n (inputTape n) entry.1 := by + simp [addressed, Structured.Basic.exec] + have haddressNeValue : addressed (addressReg n) β‰  valueReg n := by + rw [haddress] + simp [cellReg, inputTape, cellBase, valueReg] + omega + have hloadedEnvelope : StepEnvelope tm bound loaded := by + constructor + Β· intro index hnonzero + by_cases heq : index = valueReg n + Β· subst index + exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· exact haddressedMarshal.index_lt index (by + simpa [loaded, Structured.Basic.exec, + Function.update_of_ne heq] using! hnonzero) + Β· intro index + by_cases heq : index = valueReg n + Β· subst index + simp only [loaded, Structured.Basic.exec, Function.update_self] + exact haddressedMarshal.value_le_of_ne + (addressed (addressReg n)) haddressNeValue + Β· simpa [loaded, Structured.Basic.exec, + Function.update_of_ne heq] using! + haddressedMarshal.value_le_of_ne index heq + have hloadedLarge := hloadedEnvelope.mono le_rfl hwordLimit + have hsetupChain : Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) valueLimit + [.imm (addressReg n) (cellReg n (inputTape n) entry.1), + .load (valueReg n) (addressReg n)] store := by + exact ⟨henvelope.storeEnvelope, haddressedStore, hloadedLarge⟩ + have hsetup := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + [.imm (addressReg n) (cellReg n (inputTape n) entry.1), + .load (valueReg n) (addressReg n)] store hsetupChain |>.1 + by_cases hzero : loaded (valueReg n) = 0 + Β· have hskip := Structured.Internal.MeasuredRuns.skipEnvelope hloadedLarge + have hbranch := Structured.Internal.MeasuredRuns.ifZeroEnvelope + (onNonzero := .basics + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)]) + hzero hloadedLarge hskip + have hrun := hsetup.seq hbranch + have hrun' := hrun.weakenCost (show + 8 * (bitlen valueLimit + 1) + (bitlen valueLimit + 1) ≀ + 27 * (bitlen valueLimit + 1) by omega) + have hrepairStore : repairBitStore n entry store = loaded := by + unfold repairBitStore + change (if loaded (valueReg n) = 0 then loaded else _) = loaded + rw [ite_eq_left hzero] + refine ⟨3, ?_, ?_⟩ + Β· rw [hrepairStore] + simpa [repairBit] using! hrun' + Β· rw [hrepairStore] + exact hloadedEnvelope + Β· let valued := (Structured.Basic.imm (valueReg n) (entry.2 + 1)).exec loaded + let final := (Structured.Basic.store (addressReg n) (valueReg n)).exec valued + have hsmall : entry.2 + 1 ≀ wordBound tm bound := by + apply smallValue_le_wordBound tm bound + omega + have hvalued : StepEnvelope tm bound valued := by + apply hloadedEnvelope.execBasic + Β· exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using! hsmall + have hvaluedAddress : valued (addressReg n) = + cellReg n (inputTape n) entry.1 := by + simp [valued, loaded, addressed, Structured.Basic.exec, addressReg, + valueReg, Function.update_of_ne] + have hvaluedValue : valued (valueReg n) = entry.2 + 1 := by + simp [valued, Structured.Basic.exec] + have hfinal : StepEnvelope tm bound final := by + apply hvalued.execBasic + Β· simp only [Structured.Internal.Basic.writeIndex] + rw [hvaluedAddress] + exact cellReg_lt_registerBound_internal (inputTape n) hposition + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hvaluedValue] + exact hsmall + have hwritesChain : Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) valueLimit + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] loaded := by + exact ⟨hloadedLarge, hvalued.mono le_rfl hwordLimit, + hfinal.mono le_rfl hwordLimit⟩ + have hwrites := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] loaded hwritesChain |>.1 + have hbranch := Structured.Internal.MeasuredRuns.ifNonzeroEnvelope + (onZero := .skip) hzero hloadedLarge hwrites + have hrun := hsetup.seq hbranch + have hrun' := hrun.weakenCost (show + 8 * (bitlen valueLimit + 1) + + (3 * (bitlen valueLimit + 1) + + 8 * (bitlen valueLimit + 1)) ≀ + 27 * (bitlen valueLimit + 1) by omega) + have hrepairStore : repairBitStore n entry store = final := by + unfold repairBitStore + change (if loaded (valueReg n) = 0 then loaded else + Structured.Basic.execList + [.imm (valueReg n) (entry.2 + 1), + .store (addressReg n) (valueReg n)] loaded) = final + rw [ite_eq_right hzero] + rfl + refine ⟨6, ?_, ?_⟩ + Β· rw [hrepairStore] + simpa [repairBit] using! hrun' + Β· rw [hrepairStore] + exact hfinal + +private theorem repairCaptured_fromStep_measured {tm : TM n} + {bound valueLimit : β„•} (captured : List (β„• Γ— β„•)) + {store : Structured.Store} + (hentries : βˆ€ entry, entry ∈ captured β†’ + entry.1 ≀ bound + 1 ∧ entry.2 ≀ 1) + (henvelope : StepEnvelope tm bound store) + (hwordLimit : wordBound tm bound ≀ valueLimit) : + βˆƒ final steps, + Structured.Internal.MeasuredRuns (repairCaptured n captured) store final + steps (captured.length * (27 * (bitlen valueLimit + 1))) + (Structured.Internal.envelopeSpace + (registerBound n (bound + 1)) valueLimit) ∧ + final = repairStore n captured store ∧ StepEnvelope tm bound final := by + induction captured generalizing store with + | nil => + have hskip := Structured.Internal.MeasuredRuns.skipEnvelope + (henvelope.mono le_rfl hwordLimit) + exact ⟨store, 0, by simpa [repairCaptured] using! hskip, rfl, henvelope⟩ + | cons entry rest ih => + have hentry := hentries entry (by simp) + obtain ⟨firstSteps, hfirst, hfirstEnvelope⟩ := + repairBit_measured_internal hentry.1 hentry.2 + (henvelope.toMarshalEnvelope hwordLimit) hwordLimit + let first := repairBitStore n entry store + have hrestEntries : βˆ€ candidate, candidate ∈ rest β†’ + candidate.1 ≀ bound + 1 ∧ candidate.2 ≀ 1 := by + intro candidate hmem + exact hentries candidate (by simp [hmem]) + obtain ⟨final, restSteps, hrest, hrestStore, hfinalEnvelope⟩ := + ih hrestEntries (by simpa [first] using! hfirstEnvelope) + have hrun := hfirst.seq hrest + refine ⟨final, firstSteps + restSteps, ?_, ?_, hfinalEnvelope⟩ + Β· convert! hrun using 1 + simp only [List.length_cons] + ring + Β· simp [repairStore] at hrestStore ⊒ + exact hrestStore + +theorem repairCaptured_measured_internal {tm : TM n} {bound valueLimit : β„•} + {captured : List (β„• Γ— β„•)} {store : Structured.Store} + (hentries : βˆ€ entry, entry ∈ captured β†’ + entry.1 ≀ bound + 1 ∧ entry.2 ≀ 1) + (hnonempty : captured β‰  []) + (henvelope : MarshalEnvelope tm bound valueLimit store) + (hwordLimit : wordBound tm bound ≀ valueLimit) : + βˆƒ final steps, + Structured.Internal.MeasuredRuns (repairCaptured n captured) store final + steps (captured.length * (27 * (bitlen valueLimit + 1))) + (Structured.Internal.envelopeSpace + (registerBound n (bound + 1)) valueLimit) ∧ + final = repairStore n captured store ∧ StepEnvelope tm bound final := by + obtain ⟨entry, rest, rfl⟩ := List.exists_cons_of_ne_nil hnonempty + have hentry := hentries entry (by simp) + obtain ⟨firstSteps, hfirst, hfirstEnvelope⟩ := + repairBit_measured_internal hentry.1 hentry.2 henvelope hwordLimit + have hrestEntries : βˆ€ candidate, candidate ∈ rest β†’ + candidate.1 ≀ bound + 1 ∧ candidate.2 ≀ 1 := by + intro candidate hmem + exact hentries candidate (by simp [hmem]) + obtain ⟨final, restSteps, hrest, hrestStore, hfinalEnvelope⟩ := + repairCaptured_fromStep_measured rest hrestEntries hfirstEnvelope hwordLimit + have hrun := hfirst.seq hrest + refine ⟨final, firstSteps + restSteps, ?_, ?_, hfinalEnvelope⟩ + Β· convert! hrun using 1 + simp only [List.length_cons] + ring + Β· simp [repairStore] at hrestStore ⊒ + exact hrestStore + +private theorem immWrites_envelopeChain {tm : TM n} {bound : β„•} + (writes : List (β„• Γ— β„•)) {store : Structured.Store} + (hfits : βˆ€ write, write ∈ writes β†’ + write.1 < registerBound n (bound + 1) ∧ + write.2 ≀ wordBound tm bound) + (henvelope : StepEnvelope tm bound store) : + Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (writes.map fun write => Structured.Basic.imm write.1 write.2) store := by + induction writes generalizing store with + | nil => exact henvelope + | cons write rest ih => + have hwrite := hfits write (by simp) + have hnext : StepEnvelope tm bound + ((Structured.Basic.imm write.1 write.2).exec store) := by + apply henvelope.execBasic + Β· exact hwrite.1 + Β· simpa [Structured.Internal.Basic.writeValue] using! hwrite.2 + have hrestFits : βˆ€ candidate, candidate ∈ rest β†’ + candidate.1 < registerBound n (bound + 1) ∧ + candidate.2 ≀ wordBound tm bound := by + intro candidate hmem + exact hfits candidate (by simp [hmem]) + exact ⟨henvelope, ih hrestFits hnext⟩ + +private theorem initializeConfigWrite_fits (tm : TM n) (bound : β„•) + {write : β„• Γ— β„•} (hmem : write ∈ initializeConfigWrites tm) : + write.1 < registerBound n (bound + 1) ∧ + write.2 ≀ wordBound tm bound := by + simp only [initializeConfigWrites, List.mem_append, List.mem_cons, + List.not_mem_nil, or_false, List.mem_map] at hmem + rcases hmem with hstateOrHead | hstart + Β· rcases hstateOrHead with hstate | hhead + Β· subst write + constructor + Β· simp [stateReg, registerBound, cellReg, outputTape, cellBase] + Β· have hcode : stateCode tm tm.qstart < Fintype.card tm.Q := by + simp [stateCode] + exact le_trans (Nat.le_of_lt hcode) + (card_le_wordBound_internal tm bound) + Β· obtain ⟨tape, _hfin, rfl⟩ := hhead + constructor + Β· have hcontrol := headReg_lt_control_internal tape + exact lt_of_lt_of_le hcontrol + (le_trans (by simp [cellBase]; omega) + (Nat.le_of_lt (control_lt_registerBound n bound))) + Β· exact Nat.zero_le _ + Β· obtain ⟨tape, _hfin, rfl⟩ := hstart + constructor + Β· exact cellReg_lt_registerBound_internal tape (position := 0) (by omega) + Β· change symbolCode Ξ“.start ≀ wordBound tm bound + exact smallValue_le_wordBound tm bound _ (by decide) + +theorem initializeConfigOps_measured_internal {tm : TM n} {bound : β„•} + {store : Structured.Store} (henvelope : StepEnvelope tm bound store) : + let final := Structured.Basic.execList (initializeConfigOps tm) store + Structured.Internal.MeasuredRuns (.basics (initializeConfigOps tm)) store final + (initializeConfigOps tm).length + (4 * (initializeConfigOps tm).length * wordWidth tm bound) + (spaceBound tm bound) ∧ StepEnvelope tm bound final := by + have hchain := immWrites_envelopeChain (tm := tm) (bound := bound) + (initializeConfigWrites tm) (fun write hmem => + initializeConfigWrite_fits tm bound hmem) henvelope + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (initializeConfigOps tm) store (by + simpa [initializeConfigOps] using! hchain) + simpa [wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using! hmeasured + +private theorem captureValues_eq_reverse_append (store : Structured.Store) + (regs : List β„•) (captured : List (β„• Γ— β„•)) : + captureValues store regs captured = + (regs.map (fun reg => (reg, store reg))).reverse ++ captured := by + induction regs generalizing captured with + | nil => simp [captureValues] + | cons reg rest ih => + rw [captureValues, ih] + simp [List.reverse_cons, List.append_assoc] + +private theorem capturedInput_entry (n : β„•) (x : List Bool) + {entry : β„• Γ— β„•} (hmem : entry ∈ capturedInput n x) : + entry.1 ∈ captureRegs n ∧ entry.2 = initRegs x entry.1 := by + rw [capturedInput, captureValues_eq_reverse_append] at hmem + simp only [List.append_nil, List.mem_reverse, List.mem_map] at hmem + obtain ⟨reg, hreg, rfl⟩ := hmem + exact ⟨hreg, rfl⟩ + +private theorem capturedInput_entries_fit (n : β„•) (x : List Bool) + {bound : β„•} (hcontrol : valueReg n ≀ bound + 1) : + βˆ€ entry, entry ∈ capturedInput n x β†’ + entry.1 ≀ bound + 1 ∧ entry.2 ≀ 1 := by + intro entry hmem + have hentry := capturedInput_entry n x hmem + have hposition : entry.1 ≀ valueReg n := by + have hreg := hentry.1 + simp [captureRegs, zeroReg, oneReg, tapeCountReg, stateScratchReg, + addressReg, valueReg] at hreg + rcases hreg with h | h | h | h | h | h + all_goals rw [h] + all_goals simp [valueReg] + have hpositive := captureRegs_positive_internal n hentry.1 + have hbit := initRegs_bool_of_pos_internal x hpositive + constructor + Β· exact le_trans hposition hcontrol + Β· rw [hentry.2] + omega + +private theorem capturedInput_nonempty (n : β„•) (x : List Bool) : + capturedInput n x β‰  [] := by + rw [capturedInput, captureValues_eq_reverse_append] + simp [captureRegs] + +private theorem marshalBaseSpace_le_spaceBound (tm : TM n) + (inputLength : β„•) : + Structured.Internal.envelopeSpace + (registerBound n (marshalBound n inputLength + 1)) + (marshalBaseBound n inputLength) ≀ + spaceBound tm (marshalBound n inputLength) := by + have hvalue := marshalBaseBound_le_wordBound tm inputLength + have hsize := Nat.size_le_size hvalue + simp only [Structured.Internal.envelopeSpace, spaceBound, bitlen] + exact Nat.mul_le_mul_left _ (Nat.add_le_add_left hsize _) + +private theorem marshalSpace_le_spaceBound (tm : TM n) + (inputLength : β„•) : + marshalSpaceBound n inputLength ≀ + spaceBound tm (marshalBound n inputLength) := by + have hvalue := marshalValue_le_wordBound tm + (inputLength := inputLength) (processed := inputLength) le_rfl + have hsize := Nat.size_le_size (by + simpa [marshalBound] using! hvalue) + simp only [marshalSpaceBound, spaceBound, bitlen] + exact Nat.mul_le_mul_left _ (Nat.add_le_add_left hsize _) + +/-- A selected capture-tree leaf carries the public input through copy, +repair, and initialization within one concrete resource envelope. -/ +theorem marshalLeaf_measured_internal (tm : TM n) (x : List Bool) : + βˆƒ final steps, + Structured.Internal.MeasuredRuns + (marshalLeaf tm (capturedInput n x)) (initRegs x) final steps + (marshalLeafTimeBound tm x.length) + (spaceBound tm (marshalBound n x.length)) ∧ + Represents tm (tm.initCfg x) final ∧ + StepEnvelope tm (marshalBound n x.length) final := by + obtain ⟨hconstants, _hmarshal, _hstartInvariant⟩ := + marshalConstants_measured_internal tm x + have hconstants' := hconstants.weakenSpace + (marshalBaseSpace_le_spaceBound tm x.length) + obtain ⟨looped, hloop, hloopInvariant, hloopEnvelope⟩ := + marshalLoop_measured_internal (tm := tm) x + have hloop' := hloop.weakenSpace (marshalSpace_le_spaceBound tm x.length) + have hcontrol : valueReg n ≀ marshalBound n x.length + 1 := by + have hrange := (scratch_range_internal n).2.2.2.2.2.1.2 + have hbase := cellBase_le_marshalBaseBound n x.length + simp [marshalBound] at * + omega + have hentries := capturedInput_entries_fit n x hcontrol + have hnonempty := capturedInput_nonempty n x + obtain ⟨repaired, repairSteps, hrepair, hrepairStore, + hrepairEnvelope⟩ := + repairCaptured_measured_internal hentries hnonempty + (hloopEnvelope.toMarshalEnvelope le_rfl) le_rfl + have hrepair' : Structured.Internal.MeasuredRuns + (repairCaptured n (capturedInput n x)) looped repaired repairSteps + ((capturedInput n x).length * + (27 * wordWidth tm (marshalBound n x.length))) + (spaceBound tm (marshalBound n x.length)) := by + simpa [wordWidth, spaceBound, Structured.Internal.envelopeSpace] using! + hrepair + subst repaired + let final := Structured.Basic.execList (initializeConfigOps tm) + (repairStore n (capturedInput n x) looped) + obtain ⟨hinitialize, hinitializeEnvelope⟩ := + initializeConfigOps_measured_internal hrepairEnvelope + have hrepresents := initializeStore_represents_internal tm x looped + hloopInvariant + have hrun := hconstants'.seq (hloop'.seq (hrepair'.seq hinitialize)) + refine ⟨final, + (marshalConstants n).length + + (marshalLoopSteps n x.length + + (repairSteps + (initializeConfigOps tm).length)), ?_, ?_, ?_⟩ + Β· convert! hrun using 1 + simp [marshalLeafTimeBound, marshalBaseWidth, + Structured.Internal.valueWidth, capturedInput, + captureValues_eq_reverse_append] + ring + Β· simpa [final, initializeStore] using! hrepresents + Β· simpa [final] using! hinitializeEnvelope + +private theorem captureInput_measured_of_leaf {tm : TM n} (x : List Bool) + (regs : List β„•) (captured : List (β„• Γ— β„•)) + {final : Structured.Store} {leafSteps leafCost : β„•} + (hbits : βˆ€ reg, reg ∈ regs β†’ + initRegs x reg = 0 ∨ initRegs x reg = 1) + (hleaf : Structured.Internal.MeasuredRuns + (marshalLeaf tm (captureValues (initRegs x) regs captured)) + (initRegs x) final leafSteps leafCost + (spaceBound tm (marshalBound n x.length))) : + βˆƒ steps, + Structured.Internal.MeasuredRuns + (captureInput tm regs captured) (initRegs x) final steps + (3 * regs.length * wordWidth tm (marshalBound n x.length) + leafCost) + (spaceBound tm (marshalBound n x.length)) := by + induction regs generalizing captured with + | nil => + exact ⟨leafSteps, by simpa [captureInput, captureValues] using! hleaf⟩ + | cons reg rest ih => + have hrestBits : βˆ€ candidate, candidate ∈ rest β†’ + initRegs x candidate = 0 ∨ initRegs x candidate = 1 := by + intro candidate hmem + exact hbits candidate (by simp [hmem]) + simp only [captureValues] at hleaf + obtain ⟨restSteps, hrest⟩ := ih ((reg, initRegs x reg) :: captured) + hrestBits hleaf + have henvelope := initRegs_envelope_internal tm x + (marshalBound n x.length) (by simp [marshalBound]) + rcases hbits reg (by simp) with hzero | hone + Β· have hbranch := Structured.Internal.MeasuredRuns.ifZeroEnvelope + (onNonzero := captureInput tm rest ((reg, 1) :: captured)) + hzero henvelope hrest + have hweakened := hbranch.weakenCost (show + wordWidth tm (marshalBound n x.length) + + (3 * rest.length * wordWidth tm (marshalBound n x.length) + + leafCost) ≀ + 3 * (reg :: rest).length * + wordWidth tm (marshalBound n x.length) + leafCost by + simp only [List.length_cons] + have hw : 1 ≀ wordWidth tm (marshalBound n x.length) := by + simp [wordWidth] + calc + wordWidth tm (marshalBound n x.length) + + (3 * rest.length * wordWidth tm (marshalBound n x.length) + + leafCost) ≀ + 3 * wordWidth tm (marshalBound n x.length) + + (3 * rest.length * wordWidth tm (marshalBound n x.length) + + leafCost) := Nat.add_le_add_right (by omega) _ + _ = 3 * (rest.length + 1) * + wordWidth tm (marshalBound n x.length) + leafCost := by ring) + exact ⟨restSteps + 1, by + simpa [captureInput, hzero, spaceBound, + Structured.Internal.envelopeSpace] using! hweakened⟩ + Β· have hnonzero : initRegs x reg β‰  0 := by omega + have hbranch := Structured.Internal.MeasuredRuns.ifNonzeroEnvelope + (onZero := captureInput tm rest ((reg, 0) :: captured)) + hnonzero henvelope hrest + refine ⟨restSteps + 2, ?_⟩ + convert! hbranch using 1 + all_goals simp [captureInput, hone, wordWidth, + Structured.Internal.valueWidth] + all_goals ring + +/-- The full public-input marshaller has a concrete resource certificate and +hands the simulation core an exact sparse representation. -/ +theorem marshalInput_measured_internal (tm : TM n) (x : List Bool) : + βˆƒ final steps, + Structured.Internal.MeasuredRuns (marshalInput tm) (initRegs x) final + steps (marshalTimeBound tm x.length) + (spaceBound tm (marshalBound n x.length)) ∧ + Represents tm (tm.initCfg x) final ∧ + StepEnvelope tm (marshalBound n x.length) final := by + obtain ⟨final, leafSteps, hleaf, hrepresents, henvelope⟩ := + marshalLeaf_measured_internal tm x + have hselected : Structured.Internal.MeasuredRuns + (marshalLeaf tm + (captureValues (initRegs x) (captureRegs n) [])) + (initRegs x) final leafSteps (marshalLeafTimeBound tm x.length) + (spaceBound tm (marshalBound n x.length)) := by + simpa [capturedInput] using! hleaf + have hbits : βˆ€ reg, reg ∈ captureRegs n β†’ + initRegs x reg = 0 ∨ initRegs x reg = 1 := by + intro reg hmem + have hpositive := captureRegs_positive_internal n hmem + have hbit := initRegs_bool_of_pos_internal x hpositive + omega + obtain ⟨steps, hrun⟩ := captureInput_measured_of_leaf x + (captureRegs n) [] hbits hselected + refine ⟨final, steps, ?_, hrepresents, henvelope⟩ + simpa [marshalInput, marshalTimeBound, Nat.add_comm, Nat.add_left_comm, + Nat.add_assoc] using! hrun + +/-- End-to-end public-ABI execution with concrete time and space bounds. -/ +theorem decisionProgram_measured_internal {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps, + Structured.Internal.MeasuredRuns (decisionProgram tm) (initRegs x) final + sourceSteps (decisionTimeBound tm x.length steps) + (spaceBound tm (marshalBound n x.length + steps)) ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + obtain ⟨marshaled, marshalSteps, hmarshal, hrepresents, + hmarshalEnvelope⟩ := marshalInput_measured_internal tm x + have hbaseLe : marshalBound n x.length ≀ + marshalBound n x.length + steps := Nat.le_add_right _ _ + have hmarshal' := hmarshal.weakenSpace (spaceBound_mono tm hbaseLe) + have hheads : HeadsBounded (tm.initCfg x) (marshalBound n x.length) := by + intro tape + simp only [tapeAt] + split <;> simp [Tape.init] + have hworkStart : βˆ€ i, ((tm.initCfg x).work i).cells 0 = Ξ“.start := by + intro i + simp [Tape.init] + have houtputStart : (tm.initCfg x).output.cells 0 = Ξ“.start := by + simp [Tape.init] + have hlargeEnvelope := hmarshalEnvelope.monoBound hbaseLe + obtain ⟨simulated, hsimulation, hhaltedRepresents, + hsimulationEnvelope⟩ := + runUntilHalt_measured_internal hreach hhalted hrepresents hheads + hworkStart houtputStart hlargeEnvelope + have hsimulation' := hsimulation.weakenCost + (runTimeBound_le_linear_internal tm (marshalBound n x.length) steps + (tm.initCfg x)) + obtain ⟨hextract, _hextractEnvelope, hverdict⟩ := + extractVerdict_measured_internal hhaltedRepresents hsimulationEnvelope + have hrun := hmarshal'.seq (hsimulation'.seq hextract) + refine ⟨Structured.Basic.execList (extractVerdictOps n) simulated, + marshalSteps + + (runSteps tm steps (tm.initCfg x) + (extractVerdictOps n).length), + ?_, hverdict⟩ + convert! hrun using 1 + simp [decisionTimeBound] + ring + +/-- Concrete compiled-RAM transfer of the end-to-end resource certificate. -/ +theorem compiledDecision_resourceBound_internal {tm : TM n} {steps : β„•} + {x : List Bool} {halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps (tm.initCfg x) halted) + (hhalted : tm.halted halted) : + βˆƒ final sourceSteps cost space, + Structured.Exec (decisionProgram tm) (initRegs x) final + sourceSteps cost space ∧ + cost ≀ decisionTimeBound tm x.length steps ∧ + space ≀ spaceBound tm (marshalBound n x.length + steps) ∧ + run (compiledDecision tm) sourceSteps (initCfg x) = + { pc := (decisionProgram tm).codeSize, regs := final } ∧ + Halted (compiledDecision tm) + (run (compiledDecision tm) sourceSteps (initCfg x)) ∧ + logTimeUpto (compiledDecision tm) sourceSteps (initCfg x) = cost ∧ + spaceUpto (compiledDecision tm) sourceSteps (initCfg x) = space ∧ + final stateReg = symbolCode (halted.output.cells 1) - 1 := by + obtain ⟨final, sourceSteps, hrun, hverdict⟩ := + decisionProgram_measured_internal hreach hhalted + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hrun + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, sourceSteps, cost, space, hexec, hcost, hspace, ?_, ?_, ?_, + ?_, hverdict⟩ + Β· simpa [compiledDecision, initCfg] using! hcompiled.1 + Β· simpa [compiledDecision, initCfg] using! + Structured.Exec.compile_halted hexec + Β· simpa [compiledDecision, initCfg] using! hcompiled.2.1 + Β· simpa [compiledDecision, initCfg] using! hcompiled.2.2 + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment.lean new file mode 100644 index 0000000000..b454a85f5f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Containment.Internal + +/-! +# TM-to-RAM time-class containment + +The fixed sparse simulator transfers deterministic Turing deciders to +logarithmic-cost RAM deciders through the public input/output ABI. Polynomial +Turing time is therefore contained in polynomial RAM time. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- A deterministic TM time bound transfers to the fixed compiled sparse RAM +simulator through the complete public input/output ABI. -/ +theorem compiledDecision_decidesInTime + {tm : TM n} {L : Language} {T : β„• β†’ β„•} + (hdecides : tm.DecidesInTime L T) : + (compiledDecision tm).DecidesInTime L + (fun inputLength => decisionTimeBound tm inputLength (T inputLength)) := + compiledDecision_decidesInTime_internal hdecides + +/-- The explicit transferred bound packages the fixed simulator as a member of +the corresponding RAM time class. -/ +theorem mem_DTIME_of_decidesInTime + {tm : TM n} {L : Language} {T : β„• β†’ β„•} + (hdecides : tm.DecidesInTime L T) : + L ∈ RAM.DTIME (fun inputLength => + decisionTimeBound tm inputLength (T inputLength)) := + mem_DTIME_of_decidesInTime_internal hdecides + +/-- Every polynomial-time Turing language is decidable in polynomial +logarithmic-cost RAM time. -/ +theorem P_subset_RAM_P : Complexity.P βŠ† RAM.P := + P_subset_internal + +/-- Every fixed polynomial Turing-time class embeds into polynomial RAM time. -/ +theorem DTIME_pow_subset_RAM_P (degree : β„•) : + Complexity.DTIME (Β· ^ degree) βŠ† RAM.P := by + intro L hL + apply P_subset_RAM_P + exact Set.mem_iUnion.mpr ⟨degree, hL⟩ + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean new file mode 100644 index 0000000000..a8f4de8143 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics.PolyBound +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.NormalForm +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Classes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI + +/-! +# TM-to-RAM time-class containment -- proof internals + +This module lifts the checked public-ABI sparse simulation from one halting run +to deciders and then discharges the polynomial-bound arithmetic needed for the +forward machine-model robustness theorem. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +theorem compiledDecision_decidesInTime_internal + {tm : TM n} {L : Language} {T : β„• β†’ β„•} + (hdecides : tm.DecidesInTime L T) : + (compiledDecision tm).DecidesInTime L + (fun inputLength => decisionTimeBound tm inputLength (T inputLength)) := by + intro x + obtain ⟨halted, steps, hsteps, hreach, hhalted, hyes, hno⟩ := hdecides x + obtain ⟨final, fuel, cost, _space, _hexec, hcost, _hspace, hrun, + hramHalted, hlogCost, _hspaceExact, hverdict⟩ := + compiledDecision_resourceBound hreach hhalted + refine ⟨fuel, hramHalted, ?_, ?_, ?_⟩ + Β· rw [hlogCost] + exact le_trans hcost (decisionTimeBound_mono_steps tm x.length hsteps) + Β· intro hx + rw [hrun] + change final stateReg = 1 + rw [hverdict, hyes hx] + decide + Β· intro hx + rw [hrun] + change final stateReg = 0 + rw [hverdict, hno hx] + decide + +theorem mem_DTIME_of_decidesInTime_internal + {tm : TM n} {L : Language} {T : β„• β†’ β„•} + (hdecides : tm.DecidesInTime L T) : + L ∈ RAM.DTIME (fun inputLength => + decisionTimeBound tm inputLength (T inputLength)) := + ⟨compiledDecision tm, + (fun inputLength => decisionTimeBound tm inputLength (T inputLength)), + compiledDecision_decidesInTime_internal hdecides, BigO.refl _⟩ + +end Sparse + +end TMConfig + +end RAM + +/-! ## Polynomial bounds on the sparse simulation's resource functions + +Extensions of the generic `PolyBound` API of `Complexitylib.Asymptotics.PolyBound` +to the register, word, marshalling, and running-time bounds of this simulation. +They live in the root `PolyBound` namespace so that dot notation reaches them. -/ + +namespace PolyBound + +open RAM RAM.TMConfig.Sparse + +private theorem size_le_self (value : β„•) : value.size ≀ value := by + rw [Nat.size_le] + exact Nat.lt_pow_self (by decide) + +theorem width {f : β„• β†’ β„•} (hf : PolyBound f) : + PolyBound (fun inputLength => bitlen (f inputLength) + 1) := by + apply (hf.add (const 1)).mono + intro inputLength + simpa [bitlen] using Nat.add_le_add_right (size_le_self (f inputLength)) 1 + +theorem registerBound (workTapes : β„•) {f : β„• β†’ β„•} + (hf : PolyBound f) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.registerBound workTapes (f inputLength)) := by + have h := (((const (cellBase workTapes)).add + (hf.mul (const (workTapes + 2)))).add (const (workTapes + 1))).add + (const 1) + simpa [RAM.TMConfig.Sparse.registerBound, cellReg, outputTape, + Nat.add_assoc] using h + +theorem wordBound (tm : TM n) {f : β„• β†’ β„•} (hf : PolyBound f) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.wordBound tm (f inputLength)) := by + have hsucc := hf.add (const 1) + have hregister := registerBound n hsucc + have hcard := const (Fintype.card tm.Q) + simpa only [RAM.TMConfig.Sparse.wordBound] using + hregister.max (hcard.max hsucc) + +theorem wordWidth (tm : TM n) {f : β„• β†’ β„•} (hf : PolyBound f) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.wordWidth tm (f inputLength)) := by + simpa only [RAM.TMConfig.Sparse.wordWidth] using (wordBound tm hf).width + +theorem marshalBaseBound (workTapes : β„•) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalBaseBound workTapes inputLength) := by + simpa only [RAM.TMConfig.Sparse.marshalBaseBound] using + registerBound workTapes (id.add (const 1)) + +theorem marshalBound (workTapes : β„•) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalBound workTapes inputLength) := by + simpa only [RAM.TMConfig.Sparse.marshalBound] using + (marshalBaseBound workTapes).add id + +theorem marshalBaseWidth (workTapes : β„•) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalBaseWidth workTapes inputLength) := by + simpa only [RAM.TMConfig.Sparse.marshalBaseWidth] using + (marshalBaseBound workTapes).width + +theorem marshalWidth (workTapes : β„•) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalWidth workTapes inputLength) := by + simpa only [RAM.TMConfig.Sparse.marshalWidth] using + (marshalBound workTapes).width + +theorem marshalLoopTimeBound (workTapes : β„•) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalLoopTimeBound workTapes inputLength) := by + have hfactor := (id.mul (const + (3 + 4 * (marshalLoopOps workTapes).length))).add (const 1) + simpa only [RAM.TMConfig.Sparse.marshalLoopTimeBound] using + hfactor.mul (marshalWidth workTapes) + +theorem marshalLeafTimeBound (tm : TM n) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalLeafTimeBound tm inputLength) := by + have hconstants := (const (4 * (marshalConstants n).length)).mul + (marshalBaseWidth n) + have hloop := marshalLoopTimeBound n + have hword := wordWidth tm (marshalBound n) + have hrepair := (const ((captureRegs n).length * 27)).mul hword + have hinitialize := (const (4 * (initializeConfigOps tm).length)).mul hword + simpa [RAM.TMConfig.Sparse.marshalLeafTimeBound, Nat.mul_assoc] using + ((hconstants.add hloop).add hrepair).add hinitialize + +theorem marshalTimeBound (tm : TM n) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.marshalTimeBound tm inputLength) := by + have hcapture := (const (3 * (captureRegs n).length)).mul + (wordWidth tm (marshalBound n)) + simpa only [RAM.TMConfig.Sparse.marshalTimeBound] using + hcapture.add (marshalLeafTimeBound tm) + +theorem decisionTimeBound (tm : TM n) {T : β„• β†’ β„•} (hT : PolyBound T) : + PolyBound (fun inputLength => + RAM.TMConfig.Sparse.decisionTimeBound tm inputLength (T inputLength)) := by + have hbound := (marshalBound n).add hT + have hword := wordWidth tm hbound + have hrun := ((hT.add (const 1)).mul (const (runFactor tm))).mul hword + have hextract := (const (4 * (extractVerdictOps n).length)).mul hword + simpa [RAM.TMConfig.Sparse.decisionTimeBound, Nat.mul_assoc] using + ((marshalTimeBound tm).add hrun).add hextract + +end PolyBound + +namespace RAM + +namespace TMConfig + +namespace Sparse + +theorem P_subset_internal : Complexity.P βŠ† RAM.P := by + intro L hL + obtain ⟨workTapes, tm, p, hdecides⟩ := + mem_P_iff_decidesInTime_polynomial.mp hL + have hram := compiledDecision_decidesInTime_internal hdecides + obtain ⟨q, hq⟩ := PolyBound.decisionTimeBound tm (PolyBound.eval p) + apply Set.mem_iUnion.mpr + exact ⟨q.natDegree, compiledDecision tm, + (fun inputLength => decisionTimeBound tm inputLength (p.eval inputLength)), + hram, BigO.of_polynomial_bound q hq⟩ + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Defs.lean new file mode 100644 index 0000000000..5aa864f89e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Defs.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs + +/-! +# Sparse unbounded TM configurations in RAM registers + +This layout is independent of an input-length or time bound. State, heads, and +scratch occupy a fixed prefix determined only by the machine's tape count. +Tape cells are interleaved after that prefix at +`cellBase + position * (n + 2) + tape`. A fixed RAM program can therefore +compute every cell address using multiplication and addition while allocating +new tape positions on demand. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- State field followed by every named head and every named tape cell. -/ +abbrev Field (n : β„•) := + Fin 1 βŠ• (Fin (n + 2) βŠ• (Fin (n + 2) Γ— β„•)) + +/-- State register. -/ +def stateReg : β„• := 0 + +/-- Fixed head register for one named tape. -/ +def headReg (tape : Fin (n + 2)) : β„• := 1 + tape.val + +/-- Constant-zero scratch register. -/ +def zeroReg (n : β„•) : β„• := n + 3 + +/-- Constant-one scratch register. -/ +def oneReg (n : β„•) : β„• := n + 4 + +/-- Constant `n + 2`, used to compute interleaved cell addresses. -/ +def tapeCountReg (n : β„•) : β„• := n + 5 + +/-- Destructive finite-state dispatch register. -/ +def stateScratchReg (n : β„•) : β„• := n + 6 + +/-- Indirect cell-address scratch register. -/ +def addressReg (n : β„•) : β„• := n + 7 + +/-- Writable-symbol scratch register. -/ +def valueReg (n : β„•) : β„• := n + 8 + +/-- Loaded head-symbol register for one named tape. -/ +def symbolReg (n : β„•) (tape : Fin (n + 2)) : β„• := + n + 9 + tape.val + +/-- Exclusive end of the fixed control/scratch prefix and first tape-cell +register. -/ +def cellBase (n : β„•) : β„• := 2 * n + 11 + +/-- Address of one tape cell in the fixed interleaved layout. -/ +def cellReg (n : β„•) (tape : Fin (n + 2)) (position : β„•) : β„• := + cellBase n + position * (n + 2) + tape.val + +/-- Concrete address of a sparse configuration field. -/ +def fieldReg : Field n β†’ β„• + | Sum.inl _ => stateReg + | Sum.inr (Sum.inl tape) => headReg tape + | Sum.inr (Sum.inr (tape, position)) => cellReg n tape position + +/-- Semantic value of one sparse configuration field. -/ +noncomputable def fieldValue (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + Field n β†’ β„• + | Sum.inl _ => stateCode tm cfg.state + | Sum.inr (Sum.inl tape) => (tapeAt cfg tape).head + | Sum.inr (Sum.inr (tape, position)) => + symbolCode ((tapeAt cfg tape).cells position) + +/-- A store represents the complete unbounded TM configuration. Scratch +registers in the fixed gap are deliberately unconstrained. -/ +def Represents (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (store : Structured.Store) : Prop := + βˆ€ field, store (fieldReg field) = fieldValue tm cfg field + +/-- Decode the tape slot of an interleaved cell register. -/ +def decodeCellTape (n reg : β„•) : Fin (n + 2) := + ⟨(reg - cellBase n) % (n + 2), Nat.mod_lt _ (by omega)⟩ + +/-- Decode the position of an interleaved cell register. -/ +def decodeCellPosition (n reg : β„•) : β„• := + (reg - cellBase n) / (n + 2) + +/-- Canonical sparse register encoding. -/ +noncomputable def encodeRegs (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + Structured.Store := fun reg => + if hstate : reg = stateReg then stateCode tm cfg.state + else if hhead : reg < n + 3 then + (tapeAt cfg ⟨reg - 1, by omega⟩).head + else if cellBase n ≀ reg then + symbolCode ((tapeAt cfg (decodeCellTape n reg)).cells + (decodeCellPosition n reg)) + else 0 + +/-- Decode one complete sparse tape. -/ +noncomputable def decodeTape (n : β„•) (store : Structured.Store) + (tape : Fin (n + 2)) : Tape where + head := store (headReg tape) + cells := fun position => symbolDecode (store (cellReg n tape position)) + +/-- Decode a complete sparse store into a TM configuration. -/ +noncomputable def decode (tm : TM n) (store : Structured.Store) : + Complexity.Cfg n tm.Q where + state := stateDecode tm (store stateReg) + input := decodeTape n store ⟨0, by omega⟩ + work := fun i => decodeTape n store ⟨i.val + 1, by omega⟩ + output := decodeTape n store ⟨n + 1, by omega⟩ + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Internal.lean new file mode 100644 index 0000000000..5543a2d566 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Internal.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Internal + +/-! +# Sparse unbounded TM configuration encoding -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +theorem control_lt_cellBase_internal (n : β„•) : + valueReg n < cellBase n ∧ βˆ€ tape, symbolReg n tape < cellBase n := by + constructor + Β· simp [valueReg, cellBase] + omega + Β· intro tape + simp [symbolReg, cellBase] + omega + +theorem headReg_lt_control_internal (tape : Fin (n + 2)) : + headReg tape < n + 3 := by + simp [headReg] + omega + +theorem cellBase_le_cellReg_internal (tape : Fin (n + 2)) (position : β„•) : + cellBase n ≀ cellReg n tape position := by + simp [cellReg] + omega + +private theorem headPrefix_lt_cellBase (n : β„•) : n + 3 < cellBase n := by + simp [cellBase] + omega + +theorem decodeCellTape_cellReg_internal (tape : Fin (n + 2)) (position : β„•) : + decodeCellTape n (cellReg n tape position) = tape := by + have hoffset : cellReg n tape position - cellBase n = + position * (n + 2) + tape.val := by + simp [cellReg] + omega + apply Fin.ext + change (cellReg n tape position - cellBase n) % (n + 2) = tape.val + rw [hoffset] + simp [Nat.add_mod, Nat.mod_eq_of_lt tape.isLt] + +theorem decodeCellPosition_cellReg_internal (tape : Fin (n + 2)) + (position : β„•) : + decodeCellPosition n (cellReg n tape position) = position := by + have hoffset : cellReg n tape position - cellBase n = + position * (n + 2) + tape.val := by + simp [cellReg] + omega + rw [decodeCellPosition, hoffset, Nat.add_comm, + Nat.add_mul_div_right tape.val position (by omega), + Nat.div_eq_of_lt tape.isLt, Nat.zero_add] + +theorem cellReg_injective_internal : + Function.Injective (fun field : Fin (n + 2) Γ— β„• => + cellReg n field.1 field.2) := by + intro first second heq + have htape := congrArg (decodeCellTape n) heq + have hposition := congrArg (decodeCellPosition n) heq + rw [decodeCellTape_cellReg_internal, decodeCellTape_cellReg_internal] at htape + rw [decodeCellPosition_cellReg_internal, + decodeCellPosition_cellReg_internal] at hposition + exact Prod.ext htape hposition + +theorem fieldReg_injective_internal : Function.Injective (@fieldReg n) := by + intro first second heq + rcases first with state | headOrCell + Β· rcases state with ⟨state, hstate⟩ + have hzero : state = 0 := by omega + subst state + rcases second with state' | headOrCell' + Β· rcases state' with ⟨state', hstate'⟩ + have hzero' : state' = 0 := by omega + subst state' + rfl + Β· rcases headOrCell' with tape | cell + Β· simp [fieldReg, stateReg, headReg] at heq + omega + Β· rcases cell with ⟨tape, position⟩ + have hbase := cellBase_le_cellReg_internal tape position + simp [fieldReg, stateReg, cellBase] at heq hbase + omega + Β· rcases headOrCell with tape | cell + Β· rcases second with state' | headOrCell' + Β· rcases state' with ⟨state', hstate'⟩ + have hzero : state' = 0 := by omega + subst state' + simp [fieldReg, stateReg, headReg] at heq + Β· rcases headOrCell' with tape' | cell' + Β· apply congrArg Sum.inr + apply congrArg Sum.inl + apply Fin.ext + simp [fieldReg, headReg] at heq + omega + Β· rcases cell' with ⟨tape', position'⟩ + have hhead := headReg_lt_control_internal tape + have hcell := cellBase_le_cellReg_internal tape' position' + have hcontrol := headPrefix_lt_cellBase n + simp [fieldReg] at heq + omega + Β· rcases cell with ⟨tape, position⟩ + rcases second with state' | headOrCell' + Β· rcases state' with ⟨state', hstate'⟩ + have hzero : state' = 0 := by omega + subst state' + have hcell := cellBase_le_cellReg_internal tape position + simp [fieldReg, stateReg, cellBase] at heq hcell + omega + Β· rcases headOrCell' with tape' | cell' + Β· have hhead := headReg_lt_control_internal tape' + have hcell := cellBase_le_cellReg_internal tape position + simp [fieldReg, cellBase] at heq hcell + omega + Β· rcases cell' with ⟨tape', position'⟩ + have hpairs : (tape, position) = (tape', position') := + cellReg_injective_internal heq + exact congrArg (fun pair => Sum.inr (Sum.inr pair)) hpairs + +theorem fieldReg_ne_control_internal (field : Field n) {reg : β„•} + (hlow : n + 3 ≀ reg) (hhigh : reg < cellBase n) : + fieldReg field β‰  reg := by + intro heq + rcases field with state | headOrCell + Β· rcases state with ⟨state, hstate⟩ + have hzero : state = 0 := by omega + subst state + simp [fieldReg, stateReg] at heq + omega + Β· rcases headOrCell with tape | cell + Β· have hhead := headReg_lt_control_internal tape + simp [fieldReg] at heq + omega + Β· have hcell := cellBase_le_cellReg_internal cell.1 cell.2 + simp [fieldReg] at heq + omega + +theorem Represents.update_control_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} {reg value : β„•} + (hrepresents : Represents tm cfg store) + (hlow : n + 3 ≀ reg) (hhigh : reg < cellBase n) : + Represents tm cfg (Function.update store reg value) := by + intro field + rw [Function.update_of_ne (fieldReg_ne_control_internal field hlow hhigh)] + exact hrepresents field + +theorem scratch_range_internal (n : β„•) : + (n + 3 ≀ zeroReg n ∧ zeroReg n < cellBase n) ∧ + (n + 3 ≀ oneReg n ∧ oneReg n < cellBase n) ∧ + (n + 3 ≀ tapeCountReg n ∧ tapeCountReg n < cellBase n) ∧ + (n + 3 ≀ stateScratchReg n ∧ stateScratchReg n < cellBase n) ∧ + (n + 3 ≀ addressReg n ∧ addressReg n < cellBase n) ∧ + (n + 3 ≀ valueReg n ∧ valueReg n < cellBase n) ∧ + βˆ€ tape, n + 3 ≀ symbolReg n tape ∧ symbolReg n tape < cellBase n := by + constructor + Β· simp [zeroReg, cellBase] + omega + constructor + Β· simp [oneReg, cellBase] + omega + constructor + Β· simp [tapeCountReg, cellBase] + omega + constructor + Β· simp [stateScratchReg, cellBase] + omega + constructor + Β· simp [addressReg, cellBase] + omega + constructor + Β· simp [valueReg, cellBase] + omega + Β· intro tape + have htape := tape.isLt + simp [symbolReg, cellBase] + omega + +theorem encodeRegs_state_internal (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + encodeRegs tm cfg stateReg = stateCode tm cfg.state := by + simp [encodeRegs, stateReg] + +theorem encodeRegs_head_internal (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (tape : Fin (n + 2)) : + encodeRegs tm cfg (headReg tape) = (tapeAt cfg tape).head := by + have hstate : headReg tape β‰  stateReg := by + simp [headReg, stateReg] + rw [encodeRegs, dite_eq_right hstate, + dif_pos (headReg_lt_control_internal tape)] + congr 2 + apply Fin.ext + simp [headReg] + +theorem encodeRegs_cell_internal (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (tape : Fin (n + 2)) (position : β„•) : + encodeRegs tm cfg (cellReg n tape position) = + symbolCode ((tapeAt cfg tape).cells position) := by + have hbase := cellBase_le_cellReg_internal tape position + have hcontrol := headPrefix_lt_cellBase n + have hnotState : cellReg n tape position β‰  stateReg := by + simp [stateReg] + omega + have hnotHead : Β¬ cellReg n tape position < n + 3 := by omega + rw [encodeRegs, dite_eq_right hnotState, dite_eq_right hnotHead, ite_eq_left hbase, + decodeCellTape_cellReg_internal, decodeCellPosition_cellReg_internal] + +theorem encodeRegs_represents_internal (tm : TM n) + (cfg : Complexity.Cfg n tm.Q) : Represents tm cfg (encodeRegs tm cfg) := by + intro field + rcases field with state | headOrCell + Β· rcases state with ⟨state, hstate⟩ + have hzero : state = 0 := by omega + subst state + exact encodeRegs_state_internal tm cfg + Β· rcases headOrCell with tape | cell + Β· exact encodeRegs_head_internal tm cfg tape + Β· exact encodeRegs_cell_internal tm cfg cell.1 cell.2 + +theorem decode_of_represents_internal (tm : TM n) + (cfg : Complexity.Cfg n tm.Q) (store : Structured.Store) + (hrepresents : Represents tm cfg store) : decode tm store = cfg := by + apply Complexity.Cfg.ext + Β· simp only [decode] + have hstate := hrepresents (Sum.inl ⟨0, by omega⟩) + change store stateReg = stateCode tm cfg.state at hstate + rw [hstate] + exact stateDecode_code_internal tm cfg.state + Β· apply Tape.ext + Β· simpa [decode, decodeTape, tapeAt_input_internal] using! + hrepresents (Sum.inr (Sum.inl ⟨0, by omega⟩)) + Β· funext position + simp only [decode, decodeTape] + have hcell := hrepresents + (Sum.inr (Sum.inr (⟨0, by omega⟩, position))) + change store (cellReg n ⟨0, by omega⟩ position) = + symbolCode ((tapeAt cfg ⟨0, by omega⟩).cells position) at hcell + rw [hcell, symbolDecode_code_internal, tapeAt_input_internal] + Β· funext i + apply Tape.ext + Β· have hhead := hrepresents (Sum.inr (Sum.inl ⟨i.val + 1, by omega⟩)) + change store (headReg ⟨i.val + 1, by omega⟩) = + (tapeAt cfg ⟨i.val + 1, by omega⟩).head at hhead + simpa [decode, decodeTape, tapeAt_work_internal] using hhead + Β· funext position + simp only [decode, decodeTape] + have hcell := hrepresents + (Sum.inr (Sum.inr (⟨i.val + 1, by omega⟩, position))) + change store (cellReg n ⟨i.val + 1, by omega⟩ position) = + symbolCode ((tapeAt cfg ⟨i.val + 1, by omega⟩).cells position) at hcell + rw [hcell, symbolDecode_code_internal, tapeAt_work_internal] + Β· apply Tape.ext + Β· have hhead := hrepresents (Sum.inr (Sum.inl ⟨n + 1, by omega⟩)) + change store (headReg ⟨n + 1, by omega⟩) = + (tapeAt cfg ⟨n + 1, by omega⟩).head at hhead + simpa [decode, decodeTape, tapeAt_output_internal] using hhead + Β· funext position + simp only [decode, decodeTape] + have hcell := hrepresents + (Sum.inr (Sum.inr (⟨n + 1, by omega⟩, position))) + change store (cellReg n ⟨n + 1, by omega⟩ position) = + symbolCode ((tapeAt cfg ⟨n + 1, by omega⟩).cells position) at hcell + rw [hcell, symbolDecode_code_internal, tapeAt_output_internal] + +theorem decode_encode_internal (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : + decode tm (encodeRegs tm cfg) = cfg := + decode_of_represents_internal tm cfg (encodeRegs tm cfg) + (encodeRegs_represents_internal tm cfg) + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step.lean new file mode 100644 index 0000000000..3edfcd1765 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse + +/-! +# A fixed sparse-RAM block for one Turing-machine transition + +The generated program depends only on the Turing machine. Its interleaved +layout computes cell addresses at runtime, so no tape or time bound is baked +into the program. The exact address/loading layers, selected action, complete +nested dispatch, fixed iteration controller, and transfer to concrete compiled +RAM execution are checked. The separate `Sparse.ABI` surface supplies the +public input/output marshalling layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Computing a named tape's current-cell address preserves the represented +configuration and returns the exact sparse cell register. -/ +theorem addressOps_correct {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + {store : Structured.Store} (hrepresents : Represents tm cfg store) + (tape : Fin (n + 2)) (htapeCount : store (tapeCountReg n) = n + 2) : + let final := Structured.Basic.execList (addressOps n tape) store + Represents tm cfg final ∧ + final (addressReg n) = cellReg n tape (tapeAt cfg tape).head := + ⟨addressOps_represents_internal hrepresents tape, + addressOps_address_internal hrepresents tape htapeCount⟩ + +/-- The fixed loading prelude preserves the complete sparse representation, +initializes its constants, and recovers the state and every head symbol. -/ +theorem loadOps_correct {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + {store : Structured.Store} (hrepresents : Represents tm cfg store) : + let final := Structured.Basic.execList (loadOps n) store + Represents tm cfg final ∧ + final (zeroReg n) = 0 ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ + final (stateScratchReg n) = stateCode tm cfg.state ∧ + βˆ€ tape, final (symbolReg n tape) = symbolCode (readSymbols cfg tape) := + loadOps_loaded_internal hrepresents + +/-- Once the loaded finite state and symbols select an action, the fixed sparse +operations represent the exact TM successor. -/ +theorem actionOps_correct {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) : + Represents tm next + (Structured.Basic.execList + (actionOps tm cfg.state (readSymbols cfg)) store) := + actionOps_represents_internal hstep hrepresents + (fun i => (hworkStart i).1) houtputStart.1 hone htapeCount + +/-- The fixed structured program, determined solely by `tm`, performs exactly +one nonhalting TM transition with the advertised source instruction count. -/ +theorem program_correct {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (program tm) store final + (stepCount tm cfg) cost space ∧ + Represents tm next final := + program_exec_internal hstep hrepresents + (fun i => (hworkStart i).1) houtputStart.1 + +/-- The complete fixed source block decodes to the exact successor without a +tape-window premise. -/ +theorem program_decodes {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (program tm) store final + (stepCount tm cfg) cost space ∧ + decode tm final = next := by + obtain ⟨final, cost, space, hexec, hfinal⟩ := + program_correct hstep hrepresents hworkStart houtputStart + exact ⟨final, cost, space, hexec, + decode_of_represents tm next final hfinal⟩ + +/-- Exact transfer of the uniform one-step theorem to the concrete compiled +RAM block, including the compiler's logarithmic cost and peak space. -/ +theorem compiled_correct {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (program tm) store final + (stepCount tm cfg) cost space ∧ + run (compiled tm) (stepCount tm cfg) { pc := 0, regs := store } = + { pc := (program tm).codeSize, regs := final } ∧ + Halted (compiled tm) + (run (compiled tm) (stepCount tm cfg) { pc := 0, regs := store }) ∧ + logTimeUpto (compiled tm) (stepCount tm cfg) + { pc := 0, regs := store } = cost ∧ + spaceUpto (compiled tm) (stepCount tm cfg) + { pc := 0, regs := store } = space ∧ + decode tm final = next := by + obtain ⟨final, cost, space, hexec, hfinal⟩ := + program_correct hstep hrepresents hworkStart houtputStart + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, ?_, ?_, ?_, ?_, + decode_of_represents tm next final hfinal⟩ + Β· simpa [compiled] using hcompiled.1 + Β· simpa [compiled] using Structured.Exec.compile_halted hexec + Β· simpa [compiled] using hcompiled.2.1 + Β· simpa [compiled] using hcompiled.2.2 + +/-- The fixed loop controller follows any exact halting TM run and retains a +complete representation of its halted configuration. -/ +theorem runUntilHalt_correct {tm : TM n} {steps : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (runUntilHalt tm) store final + (runSteps tm steps cfg) cost space ∧ + Represents tm halted final := + runUntilHalt_exec_internal hreach hhalted hrepresents + (fun i => (hworkStart i).1) houtputStart.1 + +/-- The same fixed loop decodes to the exact halted TM configuration. -/ +theorem runUntilHalt_decodes {tm : TM n} {steps : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (runUntilHalt tm) store final + (runSteps tm steps cfg) cost space ∧ + decode tm final = halted := by + obtain ⟨final, cost, space, hexec, hfinal⟩ := + runUntilHalt_correct hreach hhalted hrepresents hworkStart houtputStart + exact ⟨final, cost, space, hexec, + decode_of_represents tm halted final hfinal⟩ + +/-- Exact compiled-RAM transfer for the complete fixed simulation loop. -/ +theorem compiledUntilHalt_correct {tm : TM n} {steps : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (runUntilHalt tm) store final + (runSteps tm steps cfg) cost space ∧ + run (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store } = + { pc := (runUntilHalt tm).codeSize, regs := final } ∧ + Halted (compiledUntilHalt tm) + (run (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store }) ∧ + logTimeUpto (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store } = cost ∧ + spaceUpto (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store } = space ∧ + decode tm final = halted := by + obtain ⟨final, cost, space, hexec, hfinal⟩ := + runUntilHalt_correct hreach hhalted hrepresents hworkStart houtputStart + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, ?_, ?_, ?_, ?_, + decode_of_represents tm halted final hfinal⟩ + Β· simpa [compiledUntilHalt] using hcompiled.1 + Β· simpa [compiledUntilHalt] using Structured.Exec.compile_halted hexec + Β· simpa [compiledUntilHalt] using hcompiled.2.1 + Β· simpa [compiledUntilHalt] using hcompiled.2.2 + +/-- Quantitative one-step theorem for the fixed sparse program. The exact +source step count, logarithmic time, and peak sparse-store space are all +checked against one explicit envelope. -/ +theorem program_resourceBound {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (program tm) store final + (stepCount tm cfg) (timeBound tm bound cfg) (spaceBound tm bound) ∧ + Represents tm next final ∧ StepEnvelope tm bound final := + program_measured_internal hstep hrepresents hheads + (fun i => (hworkStart i).1) houtputStart.1 henvelope + +/-- Quantitative iteration theorem for the fixed sparse simulator. Starting +with heads bounded by `base`, `steps` transitions fit one envelope at +`base + steps`; costs compose into `runTimeBound`. -/ +theorem runUntilHalt_resourceBound {tm : TM n} {steps base : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg base) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) + (henvelope : StepEnvelope tm (base + steps) store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (runUntilHalt tm) store final + (runSteps tm steps cfg) (runTimeBound tm base steps cfg) + (spaceBound tm (base + steps)) ∧ + Represents tm halted final ∧ + StepEnvelope tm (base + steps) final := + runUntilHalt_measured_internal hreach hhalted hrepresents hheads + (fun i => (hworkStart i).1) houtputStart.1 henvelope + +/-- The accumulated exact cost expression is linear in the number of simulated +steps and logarithmic in the common sparse word bound. -/ +theorem runTimeBound_le_linear (tm : TM n) (base steps : β„•) + (cfg : Complexity.Cfg n tm.Q) : + runTimeBound tm base steps cfg ≀ + ((steps + 1) * runFactor tm) * wordWidth tm (base + steps) := + runTimeBound_le_linear_internal tm base steps cfg + +/-- Sparse word width is logarithmic in the head allowance; all dependence on +the fixed machine is absorbed into the big-O constant. -/ +theorem wordWidth_bigO_log (tm : TM n) : + (fun bound => wordWidth tm bound) =O (fun bound => Nat.log 2 bound) := by + let C := cellBase n + 3 * n + 10 + Fintype.card tm.Q + let p : Polynomial β„• := Polynomial.C C * Polynomial.X + Polynomial.C C + have hword : βˆ€ bound, wordBound tm bound ≀ p.eval bound := by + intro bound + have hcoef : n + 2 ≀ C := by + simp [C, cellBase] + omega + have hconstant : cellBase n + (n + 2) + (n + 1) + 1 ≀ C := by + simp [C] + omega + have hregister : registerBound n (bound + 1) ≀ C * bound + C := by + rw [registerBound, cellReg] + simp only [outputTape] + have hproduct := Nat.mul_le_mul_left bound hcoef + have hproduct' : bound * (n + 2) ≀ C * bound := by + simpa [Nat.mul_comm] using hproduct + rw [show (bound + 1) * (n + 2) = bound * (n + 2) + (n + 2) by ring] + omega + have hcard : Fintype.card tm.Q ≀ C * bound + C := by + have hle : Fintype.card tm.Q ≀ C := by + simp [C] + omega + have hbound : bound + 1 ≀ C * bound + C := by + have hone : 1 ≀ C := by + simp [C, cellBase] + omega + have hmul := Nat.mul_le_mul_left bound hone + have hmul' : bound ≀ C * bound := by + simpa [Nat.mul_comm] using hmul + omega + simp only [wordBound, p, Polynomial.eval_add, Polynomial.eval_mul, + Polynomial.eval_C, Polynomial.eval_X] + rw [show C * bound + C = C * bound + C by rfl] + exact Nat.max_le.mpr ⟨hregister, Nat.max_le.mpr ⟨hcard, hbound⟩⟩ + have hsize : (fun bound => (wordBound tm bound).size) =O + (fun bound => Nat.log 2 bound) := + BigO.natSize_of_polynomial_bound p hword + have hone : (fun _ : β„• => 1) =O (fun bound => Nat.log 2 bound) := + BigO.const_le_logTwo 1 + simpa [wordWidth, bitlen] using BigO.add hsize hone + +private theorem bounded_mono {cfg : Complexity.Cfg n Q} + {bound larger : β„•} (hbounded : Bounded cfg bound) + (hle : bound ≀ larger) : Bounded cfg larger := by + intro tape position hposition + exact hbounded tape position (lt_of_le_of_lt hle hposition) + +private theorem headsBounded_mono {cfg : Complexity.Cfg n Q} + {bound larger : β„•} (hheads : HeadsBounded cfg bound) + (hle : bound ≀ larger) : HeadsBounded cfg larger := by + intro tape + exact le_trans (hheads tape) hle + +/-- Concrete compiled-RAM resource transfer from a canonical sparse encoding. +This is the finite, directly checkable core of the forward containment: a +`steps`-step halting TM run is simulated by one program depending only on +`tm`, with the stated logarithmic time and sparse-store space bounds. -/ +theorem compiledUntilHalt_resourceBound {tm : TM n} {steps base : β„•} + {cfg halted : Complexity.Cfg n tm.Q} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hbounded : Bounded cfg base) + (hheads : HeadsBounded cfg base) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + let store := encodeRegs tm cfg + βˆƒ final cost space, + Structured.Exec (runUntilHalt tm) store final + (runSteps tm steps cfg) cost space ∧ + cost ≀ runTimeBound tm base steps cfg ∧ + space ≀ spaceBound tm (base + steps) ∧ + run (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store } = + { pc := (runUntilHalt tm).codeSize, regs := final } ∧ + Halted (compiledUntilHalt tm) + (run (compiledUntilHalt tm) (runSteps tm steps cfg) + { pc := 0, regs := store }) ∧ + decode tm final = halted := by + let store := encodeRegs tm cfg + have hboundLe : base ≀ base + steps := Nat.le_add_right _ _ + have henvelope := encodeRegs_envelope_internal tm cfg (base + steps) + (bounded_mono hbounded hboundLe) (headsBounded_mono hheads hboundLe) + obtain ⟨final, hmeasured, hfinalRepresents, _hfinalEnvelope⟩ := + runUntilHalt_resourceBound hreach hhalted (encodeRegs_represents tm cfg) + hheads hworkStart houtputStart henvelope + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hmeasured + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcost, hspace, ?_, ?_, + decode_of_represents tm halted final hfinalRepresents⟩ + Β· simpa [compiledUntilHalt, store] using hcompiled.1 + Β· simpa [compiledUntilHalt, store] using + Structured.Exec.compile_halted hexec + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Defs.lean new file mode 100644 index 0000000000..ec4356ddbb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Defs.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Finset.Lattice.Fold +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs + +/-! +# A fixed sparse-RAM block for one Turing-machine transition + +Unlike the bounded dense block, this program is determined solely by `tm`. +It computes an interleaved tape-cell address as +`cellBase + head * (n + 2) + tape`, so the same finite RAM program can follow +an unbounded computation. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Input tape slot. -/ +def inputTape (n : β„•) : Fin (n + 2) := ⟨0, by omega⟩ + +/-- Work-tape slot. -/ +def workTape (i : Fin n) : Fin (n + 2) := ⟨i.val + 1, by omega⟩ + +/-- Output tape slot. -/ +def outputTape (n : β„•) : Fin (n + 2) := ⟨n + 1, by omega⟩ + +/-- Symbols currently read by all named TM heads. -/ +def readSymbols (cfg : Complexity.Cfg n Q) : Fin (n + 2) β†’ Ξ“ := + fun tape => (tapeAt cfg tape).read + +/-- Compute the indirect address of the cell under one named head. `valueReg` +temporarily holds the tape-specific base constant. -/ +def addressOps (n : β„•) (tape : Fin (n + 2)) : List Structured.Basic := + [.imm (valueReg n) (cellBase n + tape.val), + .mul (addressReg n) (headReg tape) (tapeCountReg n), + .add (addressReg n) (addressReg n) (valueReg n)] + +/-- Load the symbol under one named head. -/ +def loadTapeOps (n : β„•) (tape : Fin (n + 2)) : List Structured.Basic := + addressOps n tape ++ [.load (symbolReg n tape) (addressReg n)] + +/-- Initialize fixed constants and copy the finite-state code. -/ +def setupOps (n : β„•) : List Structured.Basic := + [.imm (zeroReg n) 0, + .imm (oneReg n) 1, + .imm (tapeCountReg n) (n + 2), + .add (stateScratchReg n) stateReg (zeroReg n)] + +/-- Initialize scratch state and load every named head symbol. -/ +def loadOps (n : β„•) : List Structured.Basic := + setupOps n ++ (List.finRange (n + 2)).flatMap (loadTapeOps n) + +/-- Update one represented head. -/ +def moveOps (n : β„•) (tape : Fin (n + 2)) : Dir3 β†’ List Structured.Basic + | .left => [.sub (headReg tape) (headReg tape) (oneReg n)] + | .right => [.add (headReg tape) (headReg tape) (oneReg n)] + | .stay => [] + +/-- Write the cell under one represented head and restore its immutable cell +zero to the left-end marker. -/ +def writeOps (n : β„•) (tape : Fin (n + 2)) (write : Ξ“w) : + List Structured.Basic := + addressOps n tape ++ + [.imm (valueReg n) (symbolCode write.toΞ“), + .store (addressReg n) (valueReg n), + .imm (cellReg n tape 0) (symbolCode Ξ“.start)] + +/-- Write and move one represented work/output tape. -/ +def writeMoveOps (n : β„•) (tape : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) : List Structured.Basic := + writeOps n tape write ++ moveOps n tape direction + +/-- Straight-line operations for one statically selected transition. -/ +noncomputable def actionOps (tm : TM n) (state : tm.Q) + (symbols : Fin (n + 2) β†’ Ξ“) : List Structured.Basic := + match tm.Ξ΄ state (symbols (inputTape n)) + (fun i => symbols (workTape i)) (symbols (outputTape n)) with + | (nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection) => + [.imm stateReg (stateCode tm nextState)] ++ + moveOps n (inputTape n) inputDirection ++ + (List.finRange n).flatMap (fun i => + writeMoveOps n (workTape i) (workWrites i) (workDirections i)) ++ + writeMoveOps n (outputTape n) outputWrite outputDirection + +/-- Structured selected-transition command. -/ +noncomputable def action (tm : TM n) (state : tm.Q) + (symbols : Fin (n + 2) β†’ Ξ“) : Structured.Cmd := + .basics (actionOps tm state symbols) + +/-- Recursively dispatch on loaded tape symbols. -/ +noncomputable def dispatchSymbols (tm : TM n) (state : tm.Q) : + List (Fin (n + 2)) β†’ (Fin (n + 2) β†’ Ξ“) β†’ Structured.Cmd + | [], symbols => action tm state symbols + | tape :: rest, symbols => + Structured.Switch.select 4 (symbolReg n tape) (oneReg n) + (fun code => dispatchSymbols tm state rest + (Function.update symbols tape (symbolDecode code.val))) + +/-- Dispatch on the state code and every loaded symbol. -/ +noncomputable def dispatchState (tm : TM n) : Structured.Cmd := + Structured.Switch.select (Fintype.card tm.Q) (stateScratchReg n) (oneReg n) + (fun stateCode => + dispatchSymbols tm ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + +/-- Fixed uniform structured-RAM block for one nonhalting TM transition. -/ +noncomputable def program (tm : TM n) : Structured.Cmd := + .seq (.basics (loadOps n)) (dispatchState tm) + +/-- Concrete compiled uniform transition block. -/ +noncomputable def compiled (tm : TM n) : Program := + (program tm).compile + +/-- Runtime loop flag: zero exactly in the designated halt state. -/ +def runningFlag (tm : TM n) (state : tm.Q) : β„• := + if state = tm.qhalt then 0 else 1 + +/-- Finite-state branch that writes the runtime loop flag. -/ +noncomputable def continueDispatch (tm : TM n) : Structured.Cmd := + Structured.Switch.select (Fintype.card tm.Q) (stateScratchReg n) (oneReg n) + (fun code => .basics + [.imm (valueReg n) (runningFlag tm ((Fintype.equivFin tm.Q).symm code))]) + +/-- Reload the represented state and set the runtime loop flag. The full load +prelude is deliberately reused so this fixed controller inherits its framing +theorem. -/ +noncomputable def continueCheck (tm : TM n) : Structured.Cmd := + .seq (.basics (loadOps n)) (continueDispatch tm) + +/-- One loop iteration: perform one TM transition, then recompute whether the +successor is halted. -/ +noncomputable def loopBody (tm : TM n) : Structured.Cmd := + .seq (program tm) (continueCheck tm) + +/-- Fixed structured program that repeats transitions until the represented TM +enters `qhalt`. -/ +noncomputable def runUntilHalt (tm : TM n) : Structured.Cmd := + .seq (continueCheck tm) + (.whileNonzero (valueReg n) (loopBody tm)) + +/-- Concrete compiled fixed program that simulates until `qhalt`. -/ +noncomputable def compiledUntilHalt (tm : TM n) : Program := + (runUntilHalt tm).compile + +/-- Exact instruction count of one continuation check. -/ +noncomputable def continueSteps (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : β„• := + (loadOps n).length + + Structured.Switch.stepCount (stateCode tm cfg.state) 1 + +/-- Largest cell-register index needed when heads stay at most `bound`. -/ +def registerBound (n bound : β„•) : β„• := + cellReg n (outputTape n) bound + 1 + +/-- Uniform value bound for a transition whose input heads are at most +`bound`; it includes a possible right move. -/ +def wordBound (tm : TM n) (bound : β„•) : β„• := + max (registerBound n (bound + 1)) + (max (Fintype.card tm.Q) (bound + 1)) + +/-- One-bit-cushioned resource width. -/ +def wordWidth (tm : TM n) (bound : β„•) : β„• := + bitlen (wordBound tm bound) + 1 + +/-- Peak sparse-store space envelope through one transition. -/ +def spaceBound (tm : TM n) (bound : β„•) : β„• := + registerBound n (bound + 1) * + (bitlen (registerBound n (bound + 1)) + bitlen (wordBound tm bound)) + +/-- Exact transition count through symbol dispatch. -/ +noncomputable def dispatchSteps (tm : TM n) (state : tm.Q) + (actual : Fin (n + 2) β†’ Ξ“) : List (Fin (n + 2)) β†’ β„• + | [] => (actionOps tm state actual).length + | tape :: rest => Structured.Switch.stepCount (symbolCode (actual tape)) + (dispatchSteps tm state actual rest) + +/-- Exact source/compiled instruction count for one sparse TM step. -/ +noncomputable def stepCount (tm : TM n) (cfg : Complexity.Cfg n tm.Q) : β„• := + (loadOps n).length + + Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm cfg.state (readSymbols cfg) (List.finRange (n + 2))) + +/-- Exact instruction count of the while-loop suffix along `steps` TM +transitions. The `none` branch is unreachable in the corresponding simulation +theorem. -/ +noncomputable def loopSteps (tm : TM n) : + β„• β†’ Complexity.Cfg n tm.Q β†’ β„• + | 0, _ => 1 + | steps + 1, cfg => + match tm.step cfg with + | none => 0 + | some next => stepCount tm cfg + continueSteps tm next + + loopSteps tm steps next + 2 + +/-- Exact instruction count of the complete fixed simulator along a known +halting run. -/ +noncomputable def runSteps (tm : TM n) (steps : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + continueSteps tm cfg + loopSteps tm steps cfg + +/-- Logarithmic-cost bound through symbol dispatch. -/ +noncomputable def dispatchCost (tm : TM n) (bound : β„•) (state : tm.Q) + (actual : Fin (n + 2) β†’ Ξ“) : List (Fin (n + 2)) β†’ β„• + | [] => 4 * (actionOps tm state actual).length * wordWidth tm bound + | tape :: rest => Structured.Switch.costBound (symbolCode (actual tape)) + (dispatchCost tm bound state actual rest) (wordWidth tm bound) + +/-- Explicit logarithmic cost bound for one sparse TM step. -/ +noncomputable def timeBound (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + 4 * (loadOps n).length * wordWidth tm bound + + Structured.Switch.costBound (stateCode tm cfg.state) + (dispatchCost tm bound cfg.state (readSymbols cfg) (List.finRange (n + 2))) + (wordWidth tm bound) + +/-- Explicit logarithmic cost bound for one continuation check under a fixed +store envelope. -/ +noncomputable def continueTimeBound (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + 4 * (loadOps n).length * wordWidth tm bound + + Structured.Switch.costBound (stateCode tm cfg.state) + (4 * wordWidth tm bound) (wordWidth tm bound) + +/-- Accumulated logarithmic cost bound for the while-loop suffix. `base` bounds +the current heads; the remaining-step allowance supplies the common envelope. -/ +noncomputable def loopTimeBound (tm : TM n) : + β„• β†’ β„• β†’ Complexity.Cfg n tm.Q β†’ β„• + | base, 0, _ => wordWidth tm base + | base, steps + 1, cfg => + match tm.step cfg with + | none => 0 + | some next => + let bound := base + steps + 1 + 3 * wordWidth tm bound + timeBound tm bound cfg + + continueTimeBound tm bound next + + loopTimeBound tm (base + 1) steps next + +/-- Accumulated logarithmic cost bound for the complete fixed simulator. -/ +noncomputable def runTimeBound (tm : TM n) (base steps : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + continueTimeBound tm (base + steps) cfg + + loopTimeBound tm base steps cfg + +/-- Width multiplier through the symbol-dispatch suffix. -/ +noncomputable def dispatchFactor (tm : TM n) (state : tm.Q) + (actual : Fin (n + 2) β†’ Ξ“) : List (Fin (n + 2)) β†’ β„• + | [] => 4 * (actionOps tm state actual).length + | tape :: rest => 7 * symbolCode (actual tape) + 1 + + dispatchFactor tm state actual rest + +/-- Configuration-independent multiplier for one sparse transition, obtained +by taking the finite maximum over states and currently scanned symbols. -/ +noncomputable def stepFactor (tm : TM n) : β„• := + 4 * (loadOps n).length + + Finset.univ.sup fun state : tm.Q => + Finset.univ.sup fun actual : Fin (n + 2) β†’ Ξ“ => + 7 * stateCode tm state + 1 + + dispatchFactor tm state actual (List.finRange (n + 2)) + +/-- Configuration-independent multiplier for one continuation check. -/ +def continueFactor (tm : TM n) : β„• := + 4 * (loadOps n).length + (7 * Fintype.card tm.Q + 5) + +/-- Per-iteration multiplier including loop control, transition, and +continuation check. -/ +noncomputable def iterationFactor (tm : TM n) : β„• := + 3 + stepFactor tm + continueFactor tm + +/-- Coarse multiplier for a complete run, including the initial continuation +check and final zero test. -/ +noncomputable def runFactor (tm : TM n) : β„• := + continueFactor tm + iterationFactor tm + 1 + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal.lean new file mode 100644 index 0000000000..a3b8072d68 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Iteration +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Resources + +/-! +# Fixed sparse TM-transition block -- proof internals + +This aggregation module collects the checked semantic and resource layers of +the uniform sparse transition block. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Action.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Action.lean new file mode 100644 index 0000000000..bc2769166c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Action.lean @@ -0,0 +1,1230 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Layout + +/-! +# Selected sparse TM transition actions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +private theorem execList_append (first second : List Structured.Basic) + (store : Structured.Store) : + Structured.Basic.execList (first ++ second) store = + Structured.Basic.execList second (Structured.Basic.execList first store) := by + induction first generalizing store with + | nil => rfl + | cons op rest ih => simp [Structured.Basic.execList, ih] + +/-- Representation restricted to one named sparse tape. -/ +private def RepresentsTape (slot : Fin (n + 2)) + (tape : Tape) (store : Structured.Store) : Prop := + store (headReg slot) = tape.head ∧ + βˆ€ position, store (cellReg n slot position) = + symbolCode (tape.cells position) + +private theorem Represents.tape {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (slot : Fin (n + 2)) : + RepresentsTape slot (tapeAt cfg slot) store := by + constructor + Β· exact hrepresents (Sum.inr (Sum.inl slot)) + Β· intro position + exact hrepresents (Sum.inr (Sum.inr (slot, position))) + +private theorem headReg_ne_cellReg (headSlot cellSlot : Fin (n + 2)) + (position : β„•) : + headReg headSlot β‰  cellReg n cellSlot position := by + intro heq + have hfield : + fieldReg (Sum.inr (Sum.inl headSlot)) = + fieldReg (Sum.inr (Sum.inr (cellSlot, position))) := heq + have := fieldReg_injective_internal hfield + cases this + +private theorem headReg_ne_headReg_of_slot_ne {first second : Fin (n + 2)} + (hne : first β‰  second) : headReg first β‰  headReg second := by + intro heq + apply hne + apply Fin.ext + simp [headReg] at heq + omega + +private theorem cellReg_ne_cellReg_of_slot_ne {first second : Fin (n + 2)} + (hne : first β‰  second) (firstPosition secondPosition : β„•) : + cellReg n first firstPosition β‰  cellReg n second secondPosition := by + intro heq + have hpairs : (first, firstPosition) = (second, secondPosition) := + cellReg_injective_internal heq + exact hne (congrArg Prod.fst hpairs) + +private theorem cellReg_ne_cellReg_of_position_ne (slot : Fin (n + 2)) + {first second : β„•} (hne : first β‰  second) : + cellReg n slot first β‰  cellReg n slot second := by + intro heq + have hpairs : (slot, first) = (slot, second) := + cellReg_injective_internal heq + exact hne (congrArg Prod.snd hpairs) + +private theorem addressOps_apply_of_ne (n : β„•) (slot : Fin (n + 2)) + (store : Structured.Store) (reg : β„•) + (hvalue : reg β‰  valueReg n) (haddress : reg β‰  addressReg n) : + Structured.Basic.execList (addressOps n slot) store reg = store reg := by + simp [addressOps, Structured.Basic.execList, Structured.Basic.exec, + Function.update_of_ne hvalue, Function.update_of_ne haddress] + +/-- On configuration registers, a sparse write is exactly an update at the +represented head followed by restoration of cell zero. -/ +private theorem writeOps_apply {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + (slot : Fin (n + 2)) (write : Ξ“w) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) (reg : β„•) + (hregValue : reg β‰  valueReg n) (hregAddress : reg β‰  addressReg n) : + Structured.Basic.execList (writeOps n slot write) store reg = + Function.update + (Function.update (Structured.Basic.execList (addressOps n slot) store) + (cellReg n slot (tapeAt cfg slot).head) (symbolCode write.toΞ“)) + (cellReg n slot 0) (symbolCode Ξ“.start) reg := by + let addressed := Structured.Basic.execList (addressOps n slot) store + have haddress : addressed (addressReg n) = + cellReg n slot (tapeAt cfg slot).head := + addressOps_address_internal hrepresents slot htapeCount + have haddressValue : addressReg n β‰  valueReg n := by + simp [addressReg, valueReg] + have hvaluedAddress : + ((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec addressed) + (addressReg n) = addressed (addressReg n) := by + simp [Structured.Basic.exec, Function.update_of_ne haddressValue] + have hvaluedValue : + ((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec addressed) + (valueReg n) = symbolCode write.toΞ“ := by + simp [Structured.Basic.exec] + simp only [writeOps, execList_append, Structured.Basic.execList] + change Function.update + (Function.update + ((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec addressed) + (((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec addressed) + (addressReg n)) + (((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec addressed) + (valueReg n))) + (cellReg n slot 0) (symbolCode Ξ“.start) reg = _ + rw [hvaluedAddress, hvaluedValue, haddress] + by_cases hzero : reg = cellReg n slot 0 + Β· subst reg + rw [Function.update_self, Function.update_self] + Β· by_cases htarget : reg = cellReg n slot (tapeAt cfg slot).head + Β· rw [Function.update_of_ne hzero, Function.update_of_ne hzero] + subst reg + rw [Function.update_self, Function.update_self] + Β· rw [Function.update_of_ne hzero, Function.update_of_ne hzero, + Function.update_of_ne htarget, Function.update_of_ne htarget] + rw [show + ((Structured.Basic.imm (valueReg n) (symbolCode write.toΞ“)).exec + addressed) reg = addressed reg by + simp [Structured.Basic.exec, Function.update_of_ne hregValue]] + +private theorem writeOps_tape {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + (slot : Fin (n + 2)) (write : Ξ“w) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) + (hstart : (tapeAt cfg slot).cells 0 = Ξ“.start) : + RepresentsTape slot ((tapeAt cfg slot).write write.toΞ“) + (Structured.Basic.execList (writeOps n slot write) store) := by + let addressed := Structured.Basic.execList (addressOps n slot) store + have haddressed := addressOps_represents_internal hrepresents slot + have htape := Represents.tape haddressed slot + constructor + Β· rw [writeOps_apply slot write store hrepresents htapeCount + (headReg slot)] + Β· rw [Function.update_of_ne + (headReg_ne_cellReg slot slot 0), + Function.update_of_ne + (headReg_ne_cellReg slot slot (tapeAt cfg slot).head)] + simpa [Tape.write_head] using htape.1 + Β· simp [headReg, valueReg] + omega + Β· simp [headReg, addressReg] + omega + Β· intro position + rw [writeOps_apply slot write store hrepresents htapeCount + (cellReg n slot position)] + Β· by_cases hheadZero : (tapeAt cfg slot).head = 0 + Β· by_cases hpositionZero : position = 0 + Β· subst position + simp [Tape.write, hheadZero, hstart] + Β· have hcellZero := + cellReg_ne_cellReg_of_position_ne (n := n) slot hpositionZero + simp [Tape.write, hheadZero, hcellZero, + htape.2 position] + Β· by_cases hpositionHead : position = (tapeAt cfg slot).head + Β· subst position + have hcellZero := cellReg_ne_cellReg_of_position_ne (n := n) slot + hheadZero + simp [Tape.write, hheadZero, hcellZero] + Β· by_cases hpositionZero : position = 0 + Β· subst position + rw [Function.update_self] + rw [Tape.write, ite_eq_right hheadZero] + change symbolCode Ξ“.start = symbolCode + (Function.update (tapeAt cfg slot).cells + (tapeAt cfg slot).head write.toΞ“ 0) + rw [Function.update_of_ne hpositionHead, hstart] + Β· have hcellZero := + cellReg_ne_cellReg_of_position_ne (n := n) slot hpositionZero + have hcellHead := cellReg_ne_cellReg_of_position_ne (n := n) slot + hpositionHead + simp [Tape.write, hheadZero, hpositionHead, + hcellZero, hcellHead, htape.2 position] + Β· simp [cellReg, valueReg, cellBase] + omega + Β· simp [cellReg, addressReg, cellBase] + omega + +private theorem moveOps_apply_of_ne (n : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (store : Structured.Store) {reg : β„•} + (hne : reg β‰  headReg slot) : + Structured.Basic.execList (moveOps n slot direction) store reg = store reg := by + cases direction <;> + simp [moveOps, Structured.Basic.execList, Structured.Basic.exec, + Function.update_of_ne hne] + +private theorem moveOps_tape (n : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (tape : Tape) (store : Structured.Store) + (hrepresents : RepresentsTape slot tape store) + (hone : store (oneReg n) = 1) : + RepresentsTape slot (tape.move direction) + (Structured.Basic.execList (moveOps n slot direction) store) := by + constructor + Β· cases direction <;> + simp [moveOps, Structured.Basic.execList, Structured.Basic.exec, Tape.move, + hrepresents.1, hone] + Β· intro position + rw [moveOps_apply_of_ne n slot direction store + (headReg_ne_cellReg slot slot position).symm] + rw [Tape.move_cells] + exact hrepresents.2 position + +private theorem controlReg_ne_cellReg (n reg : β„•) + (hhigh : reg < cellBase n) + (slot : Fin (n + 2)) (position : β„•) : + reg β‰  cellReg n slot position := by + intro heq + have hcell := cellBase_le_cellReg_internal slot position + omega + +private theorem writeOps_control {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + (slot : Fin (n + 2)) (write : Ξ“w) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) (reg : β„•) + (hhigh : reg < cellBase n) + (hvalue : reg β‰  valueReg n) (haddress : reg β‰  addressReg n) : + Structured.Basic.execList (writeOps n slot write) store reg = store reg := by + rw [writeOps_apply slot write store hrepresents htapeCount reg hvalue haddress] + rw [Function.update_of_ne + (controlReg_ne_cellReg n reg hhigh slot 0), + Function.update_of_ne + (controlReg_ne_cellReg n reg hhigh slot (tapeAt cfg slot).head)] + exact addressOps_apply_of_ne n slot store reg hvalue haddress + +private theorem moveOps_control (n : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (store : Structured.Store) (reg : β„•) + (hlow : n + 3 ≀ reg) : + Structured.Basic.execList (moveOps n slot direction) store reg = store reg := by + apply moveOps_apply_of_ne + intro heq + have hhead := headReg_lt_control_internal slot + omega + +private theorem writeMoveOps_control {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) (reg : β„•) + (hlow : n + 3 ≀ reg) (hhigh : reg < cellBase n) + (hvalue : reg β‰  valueReg n) (haddress : reg β‰  addressReg n) : + Structured.Basic.execList (writeMoveOps n slot write direction) store reg = + store reg := by + let written := Structured.Basic.execList (writeOps n slot write) store + rw [writeMoveOps, execList_append, + moveOps_control n slot direction written reg hlow] + exact writeOps_control slot write store hrepresents htapeCount reg + hhigh hvalue haddress + +private theorem writeMoveOps_tape_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) + (hone : store (oneReg n) = 1) + (hstart : (tapeAt cfg slot).cells 0 = Ξ“.start) : + RepresentsTape slot + ((tapeAt cfg slot).writeAndMove write.toΞ“ direction) + (Structured.Basic.execList (writeMoveOps n slot write direction) store) := by + let written := Structured.Basic.execList (writeOps n slot write) store + have hwritten := writeOps_tape slot write store hrepresents htapeCount hstart + have hrange := scratch_range_internal n + have honeWritten : written (oneReg n) = 1 := by + exact (writeOps_control slot write store hrepresents htapeCount + (oneReg n) hrange.2.1.2 (by simp [oneReg, valueReg]) + (by simp [oneReg, addressReg])).trans hone + rw [writeMoveOps, execList_append] + exact moveOps_tape n slot direction ((tapeAt cfg slot).write write.toΞ“) + written hwritten honeWritten + +private theorem writeMoveOps_otherTape_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {slot other : Fin (n + 2)} + (hne : slot β‰  other) (write : Ξ“w) (direction : Dir3) + (store : Structured.Store) (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) : + RepresentsTape other (tapeAt cfg other) + (Structured.Basic.execList (writeMoveOps n slot write direction) store) := by + let addressed := Structured.Basic.execList (addressOps n slot) store + let written := Structured.Basic.execList (writeOps n slot write) store + have haddressed := addressOps_represents_internal hrepresents slot + have hother := Represents.tape haddressed other + have hheadWritten : written (headReg other) = addressed (headReg other) := by + change Structured.Basic.execList (writeOps n slot write) store + (headReg other) = addressed (headReg other) + rw [writeOps_apply slot write store hrepresents htapeCount (headReg other)] + Β· rw [Function.update_of_ne (headReg_ne_cellReg other slot 0), + Function.update_of_ne + (headReg_ne_cellReg other slot (tapeAt cfg slot).head)] + Β· simp [headReg, valueReg] + omega + Β· simp [headReg, addressReg] + omega + constructor + Β· rw [writeMoveOps, execList_append, + moveOps_apply_of_ne n slot direction written + (headReg_ne_headReg_of_slot_ne (Ne.symm hne)), + hheadWritten] + exact hother.1 + Β· intro position + have hcellWritten : written (cellReg n other position) = + addressed (cellReg n other position) := by + change Structured.Basic.execList (writeOps n slot write) store + (cellReg n other position) = addressed (cellReg n other position) + rw [writeOps_apply slot write store hrepresents htapeCount + (cellReg n other position)] + Β· rw [Function.update_of_ne + (cellReg_ne_cellReg_of_slot_ne (Ne.symm hne) position 0), + Function.update_of_ne + (cellReg_ne_cellReg_of_slot_ne (Ne.symm hne) position + (tapeAt cfg slot).head)] + Β· simp [cellReg, valueReg, cellBase] + omega + Β· simp [cellReg, addressReg, cellBase] + omega + rw [writeMoveOps, execList_append, + moveOps_apply_of_ne n slot direction written + (headReg_ne_cellReg slot other position).symm, + hcellWritten] + exact hother.2 position + +private theorem RepresentsTape.stateUpdate (slot : Fin (n + 2)) + (tape : Tape) (store : Structured.Store) (state : β„•) + (hrepresents : RepresentsTape slot tape store) : + RepresentsTape slot tape + ((Structured.Basic.imm stateReg state).exec store) := by + constructor + Β· simpa [Structured.Basic.exec, stateReg, headReg, + Function.update_of_ne] using hrepresents.1 + Β· intro position + simpa [Structured.Basic.exec, stateReg, cellReg, cellBase, + Function.update_of_ne] using hrepresents.2 position + +private theorem moveOps_otherTape (n : β„•) + {slot other : Fin (n + 2)} (hne : slot β‰  other) + (direction : Dir3) (otherTape : Tape) (store : Structured.Store) + (hother : RepresentsTape other otherTape store) : + RepresentsTape other otherTape + (Structured.Basic.execList (moveOps n slot direction) store) := by + constructor + Β· rw [moveOps_apply_of_ne n slot direction store + (headReg_ne_headReg_of_slot_ne (Ne.symm hne))] + exact hother.1 + Β· intro position + rw [moveOps_apply_of_ne n slot direction store + (headReg_ne_cellReg slot other position).symm] + exact hother.2 position + +private theorem workTape_injective (n : β„•) : + Function.Injective (workTape : Fin n β†’ Fin (n + 2)) := by + intro first second heq + apply Fin.ext + simpa [workTape] using congrArg Fin.val heq + +private theorem inputTape_ne_workTape (n : β„•) (i : Fin n) : + inputTape n β‰  workTape i := by + intro heq + have := congrArg Fin.val heq + simp [inputTape, workTape] at this + +private theorem outputTape_ne_workTape (n : β„•) (i : Fin n) : + outputTape n β‰  workTape i := by + intro heq + have hi := i.isLt + have := congrArg Fin.val heq + simp [outputTape, workTape] at this + omega + +private theorem inputTape_ne_outputTape (n : β„•) : + inputTape n β‰  outputTape n := by + intro heq + have := congrArg Fin.val heq + simp [inputTape, outputTape] at this + +/-- Reassemble the complete sparse representation from the state and named +tape blocks. -/ +private theorem represents_of_named_tapes {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstate : store stateReg = stateCode tm cfg.state) + (hinput : RepresentsTape (inputTape n) cfg.input store) + (hwork : βˆ€ i, RepresentsTape (workTape i) (cfg.work i) store) + (houtput : RepresentsTape (outputTape n) cfg.output store) : + Represents tm cfg store := by + intro field + rcases field with state | headOrCell + Β· rcases state with ⟨state, hstateFin⟩ + have hzero : state = 0 := by omega + subst state + simpa [fieldReg, fieldValue] using hstate + Β· rcases headOrCell with head | cell + Β· change store (headReg head) = (tapeAt cfg head).head + by_cases hinputSlot : head = inputTape n + Β· subst head + rw [hinput.1] + simpa [inputTape] using + congrArg Tape.head (tapeAt_input_internal cfg).symm + Β· by_cases houtputSlot : head = outputTape n + Β· subst head + rw [houtput.1] + simpa [outputTape] using + congrArg Tape.head (tapeAt_output_internal cfg).symm + Β· let i : Fin n := ⟨head.val - 1, by + have hpositive : 0 < head.val := by + have hnezero : head.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + have hnotOutput : head.val β‰  n + 1 := by + intro heq + apply houtputSlot + apply Fin.ext + simpa [outputTape] using heq + omega⟩ + have hhead : head = workTape i := by + apply Fin.ext + simp [i, workTape] + have hpositive : 0 < head.val := by + have hnezero : head.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + omega + rw [hhead, (hwork i).1] + simpa [workTape] using + congrArg Tape.head (tapeAt_work_internal cfg i).symm + Β· rcases cell with ⟨tape, position⟩ + change store (cellReg n tape position) = + symbolCode ((tapeAt cfg tape).cells position) + by_cases hinputSlot : tape = inputTape n + Β· subst tape + rw [hinput.2 position] + simpa [inputTape] using + congrArg (fun t => symbolCode (t.cells position)) + (tapeAt_input_internal cfg).symm + Β· by_cases houtputSlot : tape = outputTape n + Β· subst tape + rw [houtput.2 position] + simpa [outputTape] using + congrArg (fun t => symbolCode (t.cells position)) + (tapeAt_output_internal cfg).symm + Β· let i : Fin n := ⟨tape.val - 1, by + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + have hnotOutput : tape.val β‰  n + 1 := by + intro heq + apply houtputSlot + apply Fin.ext + simpa [outputTape] using heq + omega⟩ + have htape : tape = workTape i := by + apply Fin.ext + simp [i, workTape] + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + omega + rw [htape, (hwork i).2 position] + simpa [workTape] using + congrArg (fun t => symbolCode (t.cells position)) + (tapeAt_work_internal cfg i).symm + +/-- Invariant after updating a prefix of the work tapes. -/ +private structure WorkPrefix (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (nextState : tm.Q) (inputDirection : Dir3) + (workWrites : Fin n β†’ Ξ“w) (workDirections : Fin n β†’ Dir3) + (processed : List (Fin n)) (store : Structured.Store) : Prop where + state : store stateReg = stateCode tm nextState + one : store (oneReg n) = 1 + tapeCount : store (tapeCountReg n) = n + 2 + input : RepresentsTape (inputTape n) (cfg.input.move inputDirection) store + work : βˆ€ i, RepresentsTape (workTape i) + (if i ∈ processed then + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + else cfg.work i) store + output : RepresentsTape (outputTape n) cfg.output store + +private theorem actionPrelude_workPrefix {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (nextState : tm.Q) (inputDirection : Dir3) + (workWrites : Fin n β†’ Ξ“w) (workDirections : Fin n β†’ Dir3) + (hrepresents : Represents tm cfg store) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) : + let initialized := + (Structured.Basic.imm stateReg (stateCode tm nextState)).exec store + let final := Structured.Basic.execList + (moveOps n (inputTape n) inputDirection) initialized + WorkPrefix tm cfg nextState inputDirection workWrites workDirections [] final := by + let initialized := + (Structured.Basic.imm stateReg (stateCode tm nextState)).exec store + let final := Structured.Basic.execList + (moveOps n (inputTape n) inputDirection) initialized + have honeInitialized : initialized (oneReg n) = 1 := by + simpa [initialized, Structured.Basic.exec, stateReg, oneReg, + Function.update_of_ne] using hone + have hcountInitialized : initialized (tapeCountReg n) = n + 2 := by + simpa [initialized, Structured.Basic.exec, stateReg, tapeCountReg, + Function.update_of_ne] using htapeCount + have hinputInitialized : RepresentsTape (inputTape n) cfg.input initialized := by + have htape := (Represents.tape hrepresents (inputTape n)).stateUpdate + (inputTape n) (tapeAt cfg (inputTape n)) store (stateCode tm nextState) + rw [show tapeAt cfg (inputTape n) = cfg.input by + simpa [inputTape] using tapeAt_input_internal cfg] at htape + exact htape + have hworkInitialized : βˆ€ i, + RepresentsTape (workTape i) (cfg.work i) initialized := by + intro i + have htape := (Represents.tape hrepresents (workTape i)).stateUpdate + (workTape i) (tapeAt cfg (workTape i)) store (stateCode tm nextState) + rw [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at htape + exact htape + have houtputInitialized : + RepresentsTape (outputTape n) cfg.output initialized := by + have htape := (Represents.tape hrepresents (outputTape n)).stateUpdate + (outputTape n) (tapeAt cfg (outputTape n)) store (stateCode tm nextState) + rw [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at htape + exact htape + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [moveOps_apply_of_ne n (inputTape n) inputDirection initialized] + Β· simp [initialized, Structured.Basic.exec] + Β· simp [stateReg, headReg, inputTape] + Β· exact (moveOps_control n (inputTape n) inputDirection initialized + (oneReg n) (by simp [oneReg])).trans honeInitialized + Β· exact (moveOps_control n (inputTape n) inputDirection initialized + (tapeCountReg n) (by simp [tapeCountReg])).trans hcountInitialized + Β· exact moveOps_tape n (inputTape n) inputDirection cfg.input initialized + hinputInitialized honeInitialized + Β· intro i + simpa using moveOps_otherTape n (inputTape_ne_workTape n i) + inputDirection (cfg.work i) initialized (hworkInitialized i) + Β· exact moveOps_otherTape n (inputTape_ne_outputTape n) inputDirection + cfg.output initialized houtputInitialized + +private theorem writeMoveOps_state {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) : + Structured.Basic.execList (writeMoveOps n slot write direction) store + stateReg = store stateReg := by + let written := Structured.Basic.execList (writeOps n slot write) store + rw [writeMoveOps, execList_append, + moveOps_apply_of_ne n slot direction written] + Β· change Structured.Basic.execList (writeOps n slot write) store stateReg = + store stateReg + rw [writeOps_apply slot write store hrepresents htapeCount stateReg] + Β· have hzero : stateReg β‰  cellReg n slot 0 := by + simp [stateReg, cellReg, cellBase] + omega + have htarget : stateReg β‰  + cellReg n slot (tapeAt cfg slot).head := by + simp [stateReg, cellReg, cellBase] + omega + rw [Function.update_of_ne hzero, Function.update_of_ne htarget] + exact addressOps_apply_of_ne n slot store stateReg + (by simp [stateReg, valueReg]) (by simp [stateReg, addressReg]) + Β· simp [stateReg, valueReg] + Β· simp [stateReg, addressReg] + Β· simp [stateReg, headReg] + omega + +private theorem workPrefix_step {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} {processed : List (Fin n)} + {store : Structured.Store} + (hprefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections processed store) + (i : Fin n) (hfresh : i βˆ‰ processed) + (hstart : (cfg.work i).cells 0 = Ξ“.start) : + WorkPrefix tm cfg nextState inputDirection workWrites workDirections + (i :: processed) + (Structured.Basic.execList + (writeMoveOps n (workTape i) (workWrites i) (workDirections i)) store) := by + let current : Complexity.Cfg n tm.Q := + { state := nextState + input := cfg.input.move inputDirection + work := fun j => if j ∈ processed then + (cfg.work j).writeAndMove (workWrites j).toΞ“ (workDirections j) + else cfg.work j + output := cfg.output } + have hcurrent : Represents tm current store := by + exact represents_of_named_tapes hprefix.state hprefix.input hprefix.work + hprefix.output + have hselectedTape : tapeAt current (workTape i) = cfg.work i := by + simp [current, workTape, hfresh, tapeAt_work_internal] + have hselected : RepresentsTape (workTape i) (cfg.work i) store := by + simpa [hselectedTape] using Represents.tape hcurrent (workTape i) + have hselectedFinal := writeMoveOps_tape_internal (tm := tm) + (cfg := current) (workTape i) (workWrites i) (workDirections i) store + hcurrent hprefix.tapeCount hprefix.one (by simpa [hselectedTape] using hstart) + have hrange := scratch_range_internal n + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· exact (writeMoveOps_state (workTape i) (workWrites i) + (workDirections i) store hcurrent hprefix.tapeCount).trans hprefix.state + Β· exact (writeMoveOps_control (workTape i) (workWrites i) + (workDirections i) store hcurrent hprefix.tapeCount (oneReg n) + hrange.2.1.1 hrange.2.1.2 (by simp [oneReg, valueReg]) + (by simp [oneReg, addressReg])).trans hprefix.one + Β· exact (writeMoveOps_control (workTape i) (workWrites i) + (workDirections i) store hcurrent hprefix.tapeCount (tapeCountReg n) + hrange.2.2.1.1 hrange.2.2.1.2 (by simp [tapeCountReg, valueReg]) + (by simp [tapeCountReg, addressReg])).trans hprefix.tapeCount + Β· have hother := writeMoveOps_otherTape_internal + (tm := tm) (cfg := current) (Ne.symm (inputTape_ne_workTape n i)) + (workWrites i) (workDirections i) store hcurrent hprefix.tapeCount + simpa [current, inputTape] using! hother + Β· intro j + by_cases hji : j = i + Β· subst j + simpa [hselectedTape] using hselectedFinal + Β· have hslots : workTape i β‰  workTape j := by + exact fun heq => hji ((workTape_injective n) heq).symm + have hother := writeMoveOps_otherTape_internal + (tm := tm) (cfg := current) hslots (workWrites i) + (workDirections i) store hcurrent hprefix.tapeCount + have htape : tapeAt current (workTape j) = + (if j ∈ processed then + (cfg.work j).writeAndMove (workWrites j).toΞ“ (workDirections j) + else cfg.work j) := by + simpa [current, workTape] using tapeAt_work_internal current j + rw [htape] at hother + simpa [hji] using hother + Β· have hother := writeMoveOps_otherTape_internal + (tm := tm) (cfg := current) (outputTape_ne_workTape n i).symm + (workWrites i) (workDirections i) store hcurrent hprefix.tapeCount + have htape : tapeAt current (outputTape n) = cfg.output := by + simpa [current, outputTape] using tapeAt_output_internal current + rw [htape] at hother + exact hother + +private theorem workPrefix_list {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} + (items processed : List (Fin n)) {store : Structured.Store} + (hprefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections processed store) + (hfresh : βˆ€ i, i ∈ items β†’ i βˆ‰ processed) + (hnodup : items.Nodup) + (hstarts : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) : + WorkPrefix tm cfg nextState inputDirection workWrites workDirections + (items.reverse ++ processed) + (Structured.Basic.execList + (items.flatMap (fun i => writeMoveOps n (workTape i) + (workWrites i) (workDirections i))) store) := by + induction items generalizing processed store with + | nil => simpa using! hprefix + | cons i rest ih => + have hinot : i βˆ‰ processed := hfresh i (by simp) + have hnext := workPrefix_step hprefix i hinot (hstarts i) + have hrestFresh : βˆ€ j, j ∈ rest β†’ j βˆ‰ i :: processed := by + intro j hj hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst j + exact (List.nodup_cons.mp hnodup).1 hj + Β· exact hfresh j (by simp [hj]) hprocessed + have hfinal := ih (processed := i :: processed) hnext hrestFresh + (List.nodup_cons.mp hnodup).2 + simpa [List.flatMap_cons, execList_append, List.reverse_cons, + List.append_assoc] using hfinal + +theorem actionOps_represents_internal {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) : + Represents tm next + (Structured.Basic.execList + (actionOps tm cfg.state (readSymbols cfg)) store) := by + have hnotHalted := TM.state_ne_qhalt_of_step hstep + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + rw [TM.step, ite_eq_right hnotHalted, hdelta] at hstep + dsimp only at hstep + injection hstep with hnext + subst next + have hreadInput : + readSymbols cfg (inputTape n) = cfg.input.read := by + simpa [readSymbols, inputTape] using + congrArg Tape.read (tapeAt_input_internal cfg) + have hreadWork : + (fun i => readSymbols cfg (workTape i)) = + (fun i => (cfg.work i).read) := by + funext i + simpa [readSymbols, workTape] using + congrArg Tape.read (tapeAt_work_internal cfg i) + have hreadOutput : + readSymbols cfg (outputTape n) = cfg.output.read := by + simpa [readSymbols, outputTape] using + congrArg Tape.read (tapeAt_output_internal cfg) + let initialized := + (Structured.Basic.imm stateReg (stateCode tm nextState)).exec store + let afterInput := Structured.Basic.execList + (moveOps n (inputTape n) inputDirection) initialized + have hprefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections [] afterInput := by + exact actionPrelude_workPrefix nextState inputDirection workWrites + workDirections hrepresents hone htapeCount + let afterWork := Structured.Basic.execList + ((List.finRange n).flatMap (fun i => + writeMoveOps n (workTape i) (workWrites i) (workDirections i))) + afterInput + have hworkPrefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections ((List.finRange n).reverse ++ []) afterWork := by + exact workPrefix_list (List.finRange n) [] hprefix (by simp) + (List.nodup_finRange n) hworkStart + have hworkFinal : βˆ€ i, + RepresentsTape (workTape i) + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) + afterWork := by + intro i + simpa using hworkPrefix.work i + let current : Complexity.Cfg n tm.Q := + { state := nextState + input := cfg.input.move inputDirection + work := fun i => + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + output := cfg.output } + have hcurrent : Represents tm current afterWork := by + exact represents_of_named_tapes hworkPrefix.state hworkPrefix.input + hworkFinal hworkPrefix.output + have houtputTape : tapeAt current (outputTape n) = cfg.output := by + simpa [current, outputTape] using tapeAt_output_internal current + let final := Structured.Basic.execList + (writeMoveOps n (outputTape n) outputWrite outputDirection) afterWork + have houtputFinalRaw := writeMoveOps_tape_internal (tm := tm) + (cfg := current) (outputTape n) outputWrite outputDirection afterWork + hcurrent hworkPrefix.tapeCount hworkPrefix.one + (by simpa [houtputTape] using houtputStart) + have houtputFinal : RepresentsTape (outputTape n) + (cfg.output.writeAndMove outputWrite.toΞ“ outputDirection) final := by + simpa [final, houtputTape] using houtputFinalRaw + have hinputFinalRaw := writeMoveOps_otherTape_internal + (tm := tm) (cfg := current) (inputTape_ne_outputTape n).symm + outputWrite outputDirection afterWork hcurrent hworkPrefix.tapeCount + have hinputTape : tapeAt current (inputTape n) = + cfg.input.move inputDirection := by + simpa [current, inputTape] using tapeAt_input_internal current + have hinputFinal : RepresentsTape (inputTape n) + (cfg.input.move inputDirection) final := by + rw [hinputTape] at hinputFinalRaw + exact hinputFinalRaw + have hworkFinal' : βˆ€ i, RepresentsTape (workTape i) + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) + final := by + intro i + have hother := writeMoveOps_otherTape_internal + (tm := tm) (cfg := current) (outputTape_ne_workTape n i) + outputWrite outputDirection afterWork hcurrent hworkPrefix.tapeCount + have htape : tapeAt current (workTape i) = + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) := by + simpa [current, workTape] using tapeAt_work_internal current i + rw [htape] at hother + exact hother + have hstateFinal : final stateReg = stateCode tm nextState := by + exact (writeMoveOps_state (outputTape n) outputWrite outputDirection + afterWork hcurrent hworkPrefix.tapeCount).trans hworkPrefix.state + have hfinalRepresents : + Represents tm + { state := nextState + input := cfg.input.move inputDirection + work := fun i => + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } + final := by + exact represents_of_named_tapes hstateFinal hinputFinal hworkFinal' + houtputFinal + simpa [actionOps, hreadInput, hreadWork, hreadOutput, hdelta, + initialized, afterInput, afterWork, final, execList_append, + Structured.Basic.execList, List.append_assoc] using hfinalRepresents + +private abbrev ResourceEnvelope (tm : TM n) (bound : β„•) := + Structured.Internal.StoreEnvelope (registerBound n (bound + 1)) + (wordBound tm bound) + +private abbrev ResourceEnvelopeChain (tm : TM n) (bound : β„•) := + Structured.Internal.Basic.EnvelopeChain (registerBound n (bound + 1)) + (wordBound tm bound) + +private theorem control_lt_registerBound (n bound : β„•) : + cellBase n < registerBound n (bound + 1) := by + simp [registerBound, cellReg, outputTape] + omega + +private theorem registerBound_le_wordBound (tm : TM n) (bound : β„•) : + registerBound n (bound + 1) ≀ wordBound tm bound := + le_max_left _ _ + +private theorem headReg_lt_registerBound (n bound : β„•) + (tape : Fin (n + 2)) : headReg tape < registerBound n (bound + 1) := by + have hfixed : n + 3 ≀ cellBase n := by + simp [cellBase] + omega + exact lt_of_lt_of_le (headReg_lt_control_internal tape) + (le_trans hfixed (Nat.le_of_lt (control_lt_registerBound n bound))) + +private theorem cellReg_lt_registerBound (tape : Fin (n + 2)) + {position bound : β„•} (hposition : position ≀ bound + 1) : + cellReg n tape position < registerBound n (bound + 1) := by + have hmul := Nat.mul_le_mul_right (n + 2) hposition + simp only [cellReg, registerBound, outputTape] + omega + +private theorem smallValue_le_wordBound (tm : TM n) (bound value : β„•) + (hvalue : value ≀ 4) : value ≀ wordBound tm bound := by + have hfour : 4 ≀ registerBound n (bound + 1) := by + have hcontrol := control_lt_registerBound n bound + simp [cellBase] at hcontrol + omega + exact le_trans hvalue + (le_trans hfour (registerBound_le_wordBound tm bound)) + +private theorem moveOps_envelopeChain (tm : TM n) (bound : β„•) + (tape : Fin (n + 2)) (direction : Dir3) (store : Structured.Store) + (henvelope : ResourceEnvelope tm bound store) + (hhead : store (headReg tape) ≀ bound) + (hone : store (oneReg n) = 1) : + ResourceEnvelopeChain tm bound (moveOps n tape direction) store := by + have hindex := headReg_lt_registerBound n bound tape + have hbound : bound + 1 ≀ wordBound tm bound := by + exact le_trans (le_max_right _ _) (le_max_right _ _) + cases direction with + | stay => exact henvelope + | left => + have hfinal : ResourceEnvelope tm bound + ((Structured.Basic.sub (headReg tape) (headReg tape) + (oneReg n)).exec store) := by + apply henvelope.execBasic + Β· exact hindex + Β· simp only [Structured.Internal.Basic.writeValue] + omega + exact ⟨henvelope, hfinal⟩ + | right => + have hfinal : ResourceEnvelope tm bound + ((Structured.Basic.add (headReg tape) (headReg tape) + (oneReg n)).exec store) := by + apply henvelope.execBasic + Β· exact hindex + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hone] + omega + exact ⟨henvelope, hfinal⟩ + +private theorem writeOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} (tape : Fin (n + 2)) (write : Ξ“w) + (store : Structured.Store) (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) + (henvelope : ResourceEnvelope tm bound store) + (hhead : (tapeAt cfg tape).head ≀ bound) : + ResourceEnvelopeChain tm bound (writeOps n tape write) store := by + let first := (Structured.Basic.imm (valueReg n) + (cellBase n + tape.val)).exec store + let multiplied := (Structured.Basic.mul (addressReg n) (headReg tape) + (tapeCountReg n)).exec first + let addressed := (Structured.Basic.add (addressReg n) (addressReg n) + (valueReg n)).exec multiplied + let valued := (Structured.Basic.imm (valueReg n) + (symbolCode write.toΞ“)).exec addressed + let stored := (Structured.Basic.store (addressReg n) (valueReg n)).exec valued + let final := (Structured.Basic.imm (cellReg n tape 0) + (symbolCode Ξ“.start)).exec stored + have hrange := scratch_range_internal n + have hbaseLt : cellBase n + tape.val < registerBound n (bound + 1) := by + simpa [cellReg] using + (cellReg_lt_registerBound tape (bound := bound) + (position := 0) (by omega)) + have hbaseBound : cellBase n + tape.val ≀ wordBound tm bound := + le_trans (Nat.le_of_lt hbaseLt) (registerBound_le_wordBound tm bound) + have hfirst : ResourceEnvelope tm bound first := by + apply henvelope.execBasic + Β· exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using hbaseBound + have hstoreHead : store (headReg tape) = (tapeAt cfg tape).head := + hrepresents (Sum.inr (Sum.inl tape)) + have hfirstHead : first (headReg tape) = store (headReg tape) := by + have hne : headReg tape β‰  valueReg n := by + simp [headReg, valueReg] + omega + simp [first, Structured.Basic.exec, Function.update_of_ne hne] + have hfirstCount : first (tapeCountReg n) = store (tapeCountReg n) := by + simp [first, Structured.Basic.exec, tapeCountReg, valueReg, + Function.update_of_ne] + have hproductBound : (tapeAt cfg tape).head * (n + 2) ≀ + wordBound tm bound := by + have htarget := cellReg_lt_registerBound tape + (position := (tapeAt cfg tape).head) (bound := bound) (by omega) + have hproduct : (tapeAt cfg tape).head * (n + 2) < + registerBound n (bound + 1) := by + simp [cellReg] at htarget + omega + exact le_trans (Nat.le_of_lt hproduct) + (registerBound_le_wordBound tm bound) + have hmultiplied : ResourceEnvelope tm bound multiplied := by + apply hfirst.execBasic + Β· exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hfirstHead, hfirstCount, hstoreHead, htapeCount] + exact hproductBound + have hmultipliedAddress : multiplied (addressReg n) = + (tapeAt cfg tape).head * (n + 2) := by + simp only [multiplied, Structured.Basic.exec, Function.update_self] + rw [hfirstHead, hfirstCount, hstoreHead, htapeCount] + have hmultipliedValue : multiplied (valueReg n) = + cellBase n + tape.val := by + simp [multiplied, first, Structured.Basic.exec, valueReg, addressReg, + Function.update_of_ne] + have htargetLt : cellReg n tape (tapeAt cfg tape).head < + registerBound n (bound + 1) := + cellReg_lt_registerBound tape (bound := bound) (by omega) + have htargetBound : cellReg n tape (tapeAt cfg tape).head ≀ + wordBound tm bound := + le_trans (Nat.le_of_lt htargetLt) (registerBound_le_wordBound tm bound) + have haddressed : ResourceEnvelope tm bound addressed := by + apply hmultiplied.execBasic + Β· exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hmultipliedAddress, hmultipliedValue] + simp [cellReg] at htargetBound + omega + have hwriteBound : symbolCode write.toΞ“ ≀ wordBound tm bound := by + apply smallValue_le_wordBound tm bound + cases write <;> decide + have hvalued : ResourceEnvelope tm bound valued := by + apply haddressed.execBasic + Β· exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using hwriteBound + have hvaluedAddress : valued (addressReg n) = + cellReg n tape (tapeAt cfg tape).head := by + simp only [valued, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· simp [addressed, Structured.Basic.exec, hmultipliedAddress, + hmultipliedValue, cellReg] + omega + Β· simp [addressReg, valueReg] + have hvaluedValue : valued (valueReg n) = symbolCode write.toΞ“ := by + simp [valued, Structured.Basic.exec] + have hstored : ResourceEnvelope tm bound stored := by + apply hvalued.execBasic + Β· simp only [Structured.Internal.Basic.writeIndex] + rw [hvaluedAddress] + exact htargetLt + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hvaluedValue] + exact hwriteBound + have hstartBound : symbolCode Ξ“.start ≀ wordBound tm bound := + smallValue_le_wordBound tm bound _ (by decide) + have hfinal : ResourceEnvelope tm bound final := by + apply hstored.execBasic + Β· exact cellReg_lt_registerBound tape (bound := bound) + (position := 0) (by omega) + Β· simpa [Structured.Internal.Basic.writeValue] using hstartBound + simpa [writeOps, addressOps, first, multiplied, addressed, valued, stored, + final] using! And.intro henvelope (And.intro hfirst + (And.intro hmultiplied (And.intro haddressed + (And.intro hvalued (And.intro hstored hfinal))))) + +private theorem writeMoveOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} (tape : Fin (n + 2)) (write : Ξ“w) + (direction : Dir3) (store : Structured.Store) + (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) + (hone : store (oneReg n) = 1) + (hstart : (tapeAt cfg tape).cells 0 = Ξ“.start) + (hhead : (tapeAt cfg tape).head ≀ bound) + (henvelope : Structured.Internal.StoreEnvelope + (registerBound n (bound + 1)) (wordBound tm bound) store) : + ResourceEnvelopeChain tm bound + (writeMoveOps n tape write direction) store := by + let written := Structured.Basic.execList (writeOps n tape write) store + have hwrite := writeOps_envelopeChain tape write store hrepresents + htapeCount henvelope hhead + have hwrittenTape := writeOps_tape tape write store hrepresents + htapeCount hstart + have hwrittenHead : written (headReg tape) ≀ bound := by + change Structured.Basic.execList (writeOps n tape write) store + (headReg tape) ≀ bound + rw [hwrittenTape.1, Tape.write_head] + exact hhead + have hrange := scratch_range_internal n + have hwrittenOne : written (oneReg n) = 1 := by + exact (writeOps_control tape write store hrepresents htapeCount + (oneReg n) hrange.2.1.2 (by simp [oneReg, valueReg]) + (by simp [oneReg, addressReg])).trans hone + have hmove := moveOps_envelopeChain tm bound tape direction written + hwrite.final hwrittenHead hwrittenOne + simpa [writeMoveOps] using hwrite.append hmove + +private theorem workPrefix_list_envelope {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} + (items processed : List (Fin n)) {store : Structured.Store} + (hprefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections processed store) + (henvelope : ResourceEnvelope tm bound store) + (hfresh : βˆ€ i, i ∈ items β†’ i βˆ‰ processed) + (hnodup : items.Nodup) + (hheads : βˆ€ i, (cfg.work i).head ≀ bound) + (hstarts : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) : + let ops := items.flatMap (fun i => writeMoveOps n (workTape i) + (workWrites i) (workDirections i)) + WorkPrefix tm cfg nextState inputDirection workWrites workDirections + (items.reverse ++ processed) (Structured.Basic.execList ops store) ∧ + ResourceEnvelopeChain tm bound ops store := by + induction items generalizing processed store with + | nil => exact ⟨by simpa using! hprefix, henvelope⟩ + | cons i rest ih => + have hinot : i βˆ‰ processed := hfresh i (by simp) + let current : Complexity.Cfg n tm.Q := + { state := nextState + input := cfg.input.move inputDirection + work := fun j => if j ∈ processed then + (cfg.work j).writeAndMove (workWrites j).toΞ“ (workDirections j) + else cfg.work j + output := cfg.output } + have hcurrent : Represents tm current store := by + exact represents_of_named_tapes hprefix.state hprefix.input hprefix.work + hprefix.output + have hselectedTape : tapeAt current (workTape i) = cfg.work i := by + simp [current, workTape, hinot, tapeAt_work_internal] + have hblock := writeMoveOps_envelopeChain (tm := tm) (bound := bound) + (cfg := current) (workTape i) (workWrites i) (workDirections i) store + hcurrent hprefix.tapeCount hprefix.one + (by simpa [hselectedTape] using hstarts i) + (by simpa [hselectedTape] using hheads i) henvelope + have hnext := workPrefix_step hprefix i hinot (hstarts i) + have hrestFresh : βˆ€ j, j ∈ rest β†’ j βˆ‰ i :: processed := by + intro j hj hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst j + exact (List.nodup_cons.mp hnodup).1 hj + Β· exact hfresh j (by simp [hj]) hprocessed + obtain ⟨hfinalPrefix, hrestChain⟩ := + ih (processed := i :: processed) hnext hblock.final hrestFresh + (List.nodup_cons.mp hnodup).2 + refine ⟨?_, ?_⟩ + Β· simpa [List.flatMap_cons, execList_append, List.reverse_cons, + List.append_assoc] using hfinalPrefix + Β· simpa [List.flatMap_cons] using hblock.append hrestChain + +private theorem actionOps_envelopeChain_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (henvelope : ResourceEnvelope tm bound store) : + ResourceEnvelopeChain tm bound + (actionOps tm cfg.state (readSymbols cfg)) store := by + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + have hreadInput : readSymbols cfg (inputTape n) = cfg.input.read := by + simpa [readSymbols, inputTape] using + congrArg Tape.read (tapeAt_input_internal cfg) + have hreadWork : (fun i => readSymbols cfg (workTape i)) = + (fun i => (cfg.work i).read) := by + funext i + simpa [readSymbols, workTape] using + congrArg Tape.read (tapeAt_work_internal cfg i) + have hreadOutput : readSymbols cfg (outputTape n) = cfg.output.read := by + simpa [readSymbols, outputTape] using + congrArg Tape.read (tapeAt_output_internal cfg) + let initialized := + (Structured.Basic.imm stateReg (stateCode tm nextState)).exec store + have hstateBound : stateCode tm nextState ≀ wordBound tm bound := by + have hstateLt : stateCode tm nextState < Fintype.card tm.Q := by + simp [stateCode] + exact le_trans (Nat.le_of_lt hstateLt) + (le_trans (le_max_left _ _) (le_max_right _ _)) + have hinitialized : ResourceEnvelope tm bound initialized := by + apply henvelope.execBasic + Β· simp [stateReg, registerBound, cellReg, outputTape, cellBase] + Β· simpa [Structured.Internal.Basic.writeValue] using hstateBound + have hstateChain : ResourceEnvelopeChain tm bound + [.imm stateReg (stateCode tm nextState)] store := + ⟨henvelope, hinitialized⟩ + have hinputHead : initialized (headReg (inputTape n)) ≀ bound := by + have hhead := hheads (inputTape n) + have hstored := hrepresents (Sum.inr (Sum.inl (inputTape n))) + change store (headReg (inputTape n)) = + (tapeAt cfg (inputTape n)).head at hstored + rw [show tapeAt cfg (inputTape n) = cfg.input by + simpa [inputTape] using tapeAt_input_internal cfg] at hhead hstored + rw [show initialized (headReg (inputTape n)) = + store (headReg (inputTape n)) by + simp [initialized, Structured.Basic.exec, stateReg, headReg, inputTape, + Function.update_of_ne]] + rw [hstored] + exact hhead + have honeInitialized : initialized (oneReg n) = 1 := by + simpa [initialized, Structured.Basic.exec, stateReg, oneReg, + Function.update_of_ne] using hone + let afterInput := Structured.Basic.execList + (moveOps n (inputTape n) inputDirection) initialized + have hinputChain := moveOps_envelopeChain tm bound (inputTape n) + inputDirection initialized hinitialized hinputHead honeInitialized + have hprefix : WorkPrefix tm cfg nextState inputDirection + workWrites workDirections [] afterInput := by + exact actionPrelude_workPrefix nextState inputDirection workWrites + workDirections hrepresents hone htapeCount + have hworkHeads : βˆ€ i, (cfg.work i).head ≀ bound := by + intro i + have hhead := hheads (workTape i) + rwa [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at hhead + obtain ⟨hworkPrefix, hworkChain⟩ := workPrefix_list_envelope + (bound := bound) (List.finRange n) [] hprefix hinputChain.final + (by simp) (List.nodup_finRange n) hworkHeads hworkStart + let workOps := (List.finRange n).flatMap (fun i => + writeMoveOps n (workTape i) (workWrites i) (workDirections i)) + let afterWork := Structured.Basic.execList workOps afterInput + let current : Complexity.Cfg n tm.Q := + { state := nextState + input := cfg.input.move inputDirection + work := fun i => + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + output := cfg.output } + have hworkFinal : βˆ€ i, RepresentsTape (workTape i) + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) + afterWork := by + intro i + simpa [afterWork, workOps] using hworkPrefix.work i + have hcurrent : Represents tm current afterWork := by + exact represents_of_named_tapes hworkPrefix.state hworkPrefix.input + hworkFinal hworkPrefix.output + have houtputTape : tapeAt current (outputTape n) = cfg.output := by + simpa [current, outputTape] using tapeAt_output_internal current + have houtputHead : (tapeAt current (outputTape n)).head ≀ bound := by + rw [houtputTape] + have hhead := hheads (outputTape n) + rwa [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at hhead + have houtputStartCurrent : + (tapeAt current (outputTape n)).cells 0 = Ξ“.start := by + rw [houtputTape] + exact houtputStart + have houtputChain := writeMoveOps_envelopeChain + (tm := tm) (bound := bound) (cfg := current) (outputTape n) + outputWrite outputDirection afterWork hcurrent hworkPrefix.tapeCount + hworkPrefix.one houtputStartCurrent houtputHead hworkChain.final + have hcombined := hstateChain.append (hinputChain.append + (hworkChain.append houtputChain)) + simpa [actionOps, hreadInput, hreadWork, hreadOutput, hdelta, initialized, + afterInput, workOps, afterWork, List.append_assoc] using hcombined + +theorem actionOps_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (henvelope : Structured.Internal.StoreEnvelope + (registerBound n (bound + 1)) (wordBound tm bound) store) : + let final := Structured.Basic.execList + (actionOps tm cfg.state (readSymbols cfg)) store + Structured.Internal.MeasuredRuns + (action tm cfg.state (readSymbols cfg)) store final + (actionOps tm cfg.state (readSymbols cfg)).length + (4 * (actionOps tm cfg.state (readSymbols cfg)).length * + wordWidth tm bound) (spaceBound tm bound) ∧ + Represents tm next final ∧ + Structured.Internal.StoreEnvelope + (registerBound n (bound + 1)) (wordBound tm bound) final := by + have hchain := actionOps_envelopeChain_internal hrepresents hheads + hworkStart houtputStart hone htapeCount henvelope + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (actionOps tm cfg.state (readSymbols cfg)) store hchain + refine ⟨?_, actionOps_represents_internal hstep hrepresents hworkStart + houtputStart hone htapeCount, hmeasured.2⟩ + simpa [action, wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using hmeasured.1 + + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Dispatch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Dispatch.lean new file mode 100644 index 0000000000..20e50b19a7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Dispatch.lean @@ -0,0 +1,463 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Load + +/-! +# Nested finite dispatch for the fixed sparse TM transition -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +private theorem cleared_represents {tm : TM n} {test : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) + (hlow : n + 3 ≀ test) (hhigh : test < cellBase n) : + Represents tm cfg (Structured.Switch.cleared store test) := by + exact hrepresents.update_control_internal hlow hhigh + +private theorem cleared_apply_of_ne (store : Structured.Store) {test reg : β„•} + (hne : reg β‰  test) : + Structured.Switch.cleared store test reg = store reg := by + simp [Structured.Switch.cleared, Function.update_of_ne hne] + +private theorem symbolReg_injective (n : β„•) : + Function.Injective (symbolReg n) := by + intro first second heq + apply Fin.ext + simp [symbolReg] at heq + omega + +private theorem symbolReg_ne_one (n : β„•) (tape : Fin (n + 2)) : + symbolReg n tape β‰  oneReg n := by + simp [symbolReg, oneReg] + omega + +private theorem stateScratchReg_ne_one (n : β„•) : + stateScratchReg n β‰  oneReg n := by + simp [stateScratchReg, oneReg] + +private theorem stateScratchReg_ne_symbolReg (n : β„•) + (tape : Fin (n + 2)) : + symbolReg n tape β‰  stateScratchReg n := by + simp [symbolReg, stateScratchReg] + omega + +private theorem stateCode_lt_internal (tm : TM n) (state : tm.Q) : + stateCode tm state < Fintype.card tm.Q := by + exact (Fintype.equivFin tm.Q state).isLt + +theorem dispatchSymbols_exec_internal {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (state : tm.Q) (actual symbols : Fin (n + 2) β†’ Ξ“) + (remaining : List (Fin (n + 2))) + (hstate : state = cfg.state) + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (hactual : actual = readSymbols cfg) + (hloaded : βˆ€ tape, tape ∈ remaining β†’ + store (symbolReg n tape) = symbolCode (actual tape)) + (hassigned : βˆ€ tape, tape βˆ‰ remaining β†’ symbols tape = actual tape) + (hnodup : remaining.Nodup) : + βˆƒ final cost space, + Structured.Exec (dispatchSymbols tm state remaining symbols) + store final (dispatchSteps tm state actual remaining) cost space ∧ + Represents tm next final := by + subst state + subst actual + induction remaining generalizing symbols store with + | nil => + have hsymbols : symbols = readSymbols cfg := by + funext tape + exact hassigned tape (by simp) + subst symbols + obtain ⟨cost, space, hexec⟩ := + Structured.Internal.exec_basics_exists + (actionOps tm cfg.state (readSymbols cfg)) store + refine ⟨Structured.Basic.execList + (actionOps tm cfg.state (readSymbols cfg)) store, + cost, space, ?_, ?_⟩ + Β· simpa [dispatchSymbols, action, dispatchSteps] using hexec + Β· exact actionOps_represents_internal hstep hrepresents hworkStart + houtputStart hone htapeCount + | cons tape rest ih => + have htapeCode := hloaded tape (by simp) + have htestOne : symbolReg n tape β‰  oneReg n := + symbolReg_ne_one n tape + let cleared := Structured.Switch.cleared store (symbolReg n tape) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + cleared_represents hrepresents (hrange.2.2.2.2.2.2 tape).1 + (hrange.2.2.2.2.2.2 tape).2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne store htestOne.symm).trans hone + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  symbolReg n tape := by + simp [tapeCountReg, symbolReg] + omega + exact (cleared_apply_of_ne store hne).trans htapeCount + have hclearedLoaded : βˆ€ candidate, candidate ∈ rest β†’ + cleared (symbolReg n candidate) = + symbolCode (readSymbols cfg candidate) := by + intro candidate hcandidate + have hne : candidate β‰  tape := by + intro heq + subst candidate + exact (List.nodup_cons.mp hnodup).1 hcandidate + have hregs : symbolReg n candidate β‰  symbolReg n tape := + fun heq => hne ((symbolReg_injective n) heq) + exact (cleared_apply_of_ne store hregs).trans + (hloaded candidate (by simp [hcandidate])) + have hclearedAssigned : βˆ€ candidate, candidate βˆ‰ rest β†’ + Function.update symbols tape (readSymbols cfg tape) candidate = + readSymbols cfg candidate := by + intro candidate hnot + by_cases heq : candidate = tape + Β· subst candidate + simp + Β· rw [Function.update_of_ne heq] + exact hassigned candidate (by simp [heq, hnot]) + obtain ⟨final, branchCost, branchSpace, hbranch, hfinalRepresents⟩ := + ih (symbols := Function.update symbols tape (readSymbols cfg tape)) + (store := cleared) hclearedRepresents hclearedOne hclearedCount + (List.nodup_cons.mp hnodup).2 hclearedLoaded hclearedAssigned + have hselectedBranch : + βˆƒ cost space, + Structured.Exec + ((fun code : Fin 4 => + dispatchSymbols tm cfg.state rest + (Function.update symbols tape (symbolDecode code.val))) + ⟨symbolCode (readSymbols cfg tape), + symbolCode_lt_internal (readSymbols cfg tape)⟩) + cleared final + (dispatchSteps tm cfg.state (readSymbols cfg) rest) + cost space := by + refine ⟨branchCost, branchSpace, ?_⟩ + simpa [symbolDecode_code_internal] using hbranch + obtain ⟨cost, space, hexec⟩ := Structured.Switch.select_exec + (fun code : Fin 4 => + dispatchSymbols tm cfg.state rest + (Function.update symbols tape (symbolDecode code.val))) + store final (symbolCode_lt_internal (readSymbols cfg tape)) + htapeCode hone htestOne hselectedBranch + refine ⟨final, cost, space, ?_, hfinalRepresents⟩ + simpa [dispatchSymbols, dispatchSteps] using hexec + +theorem dispatchState_exec_internal {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (hstate : store (stateScratchReg n) = stateCode tm cfg.state) + (hloaded : βˆ€ tape, store (symbolReg n tape) = + symbolCode (readSymbols cfg tape)) : + βˆƒ final cost space, + Structured.Exec (dispatchState tm) store final + (Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm cfg.state (readSymbols cfg) + (List.finRange (n + 2)))) cost space ∧ + Represents tm next final := by + let cleared := Structured.Switch.cleared store (stateScratchReg n) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + cleared_represents hrepresents hrange.2.2.2.1.1 hrange.2.2.2.1.2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne store (stateScratchReg_ne_one n).symm).trans hone + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  stateScratchReg n := by + simp [tapeCountReg, stateScratchReg] + exact (cleared_apply_of_ne store hne).trans htapeCount + have hclearedLoaded : βˆ€ tape, + cleared (symbolReg n tape) = symbolCode (readSymbols cfg tape) := by + intro tape + exact (cleared_apply_of_ne store + (stateScratchReg_ne_symbolReg n tape)).trans (hloaded tape) + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩ = + cfg.state := by + exact (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + obtain ⟨final, branchCost, branchSpace, hbranch, hfinalRepresents⟩ := + dispatchSymbols_exec_internal + ((Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + (readSymbols cfg) (fun _ => Ξ“.blank) (List.finRange (n + 2)) + hbranchState hstep hclearedRepresents hworkStart houtputStart + hclearedOne hclearedCount rfl (fun tape _ => hclearedLoaded tape) + (by simp) (List.nodup_finRange (n + 2)) + have hselectedBranch : + βˆƒ cost space, + Structured.Exec + ((fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + cleared final + (dispatchSteps tm cfg.state (readSymbols cfg) + (List.finRange (n + 2))) cost space := by + refine ⟨branchCost, branchSpace, ?_⟩ + simpa [hbranchState] using hbranch + obtain ⟨cost, space, hexec⟩ := Structured.Switch.select_exec + (fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + store final (stateCode_lt_internal tm cfg.state) hstate hone + (stateScratchReg_ne_one n) hselectedBranch + refine ⟨final, cost, space, ?_, hfinalRepresents⟩ + simpa [dispatchState] using hexec + +theorem program_exec_internal {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) : + βˆƒ final cost space, + Structured.Exec (program tm) store final + (stepCount tm cfg) cost space ∧ + Represents tm next final := by + let loaded := Structured.Basic.execList (loadOps n) store + obtain ⟨loadCost, loadSpace, hloadExec⟩ := + Structured.Internal.exec_basics_exists (loadOps n) store + have hloaded := loadOps_loaded_internal hrepresents + obtain ⟨final, dispatchCost, dispatchSpace, hdispatch, + hfinalRepresents⟩ := dispatchState_exec_internal hstep hloaded.1 + hworkStart houtputStart hloaded.2.2.1 hloaded.2.2.2.1 + hloaded.2.2.2.2.1 hloaded.2.2.2.2.2 + refine ⟨final, loadCost + dispatchCost, max loadSpace dispatchSpace, ?_, + hfinalRepresents⟩ + simpa [program, stepCount, loaded] using Structured.Exec.seq hloadExec hdispatch + +/-- Register and word bounds preserved by sparse step dispatch. -/ +abbrev ResourceEnvelope (tm : TM n) (bound : β„•) := + Structured.Internal.StoreEnvelope (registerBound n (bound + 1)) + (wordBound tm bound) + +private theorem control_lt_registerBound (n bound : β„•) : + cellBase n < registerBound n (bound + 1) := by + simp [registerBound, cellReg, outputTape] + omega + +private theorem cleared_envelope {tm : TM n} {bound test : β„•} + {store : Structured.Store} (henvelope : ResourceEnvelope tm bound store) + (htest : test < registerBound n (bound + 1)) : + ResourceEnvelope tm bound (Structured.Switch.cleared store test) := by + exact henvelope.update htest (by simp) + +theorem dispatchSymbols_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (state : tm.Q) (actual symbols : Fin (n + 2) β†’ Ξ“) + (remaining : List (Fin (n + 2))) + (hstate : state = cfg.state) + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (hactual : actual = readSymbols cfg) + (hloaded : βˆ€ tape, tape ∈ remaining β†’ + store (symbolReg n tape) = symbolCode (actual tape)) + (hassigned : βˆ€ tape, tape βˆ‰ remaining β†’ symbols tape = actual tape) + (hnodup : remaining.Nodup) + (henvelope : ResourceEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns + (dispatchSymbols tm state remaining symbols) store final + (dispatchSteps tm state actual remaining) + (dispatchCost tm bound state actual remaining) + (spaceBound tm bound) ∧ + Represents tm next final ∧ ResourceEnvelope tm bound final := by + subst state + subst actual + induction remaining generalizing symbols store with + | nil => + have hsymbols : symbols = readSymbols cfg := by + funext tape + exact hassigned tape (by simp) + subst symbols + let final := Structured.Basic.execList + (actionOps tm cfg.state (readSymbols cfg)) store + have haction := actionOps_measured_internal hstep hrepresents hheads + hworkStart houtputStart hone htapeCount henvelope + refine ⟨final, ?_, haction.2.1, haction.2.2⟩ + simpa [dispatchSymbols, dispatchSteps, dispatchCost, final] using haction.1 + | cons tape rest ih => + have htapeCode := hloaded tape (by simp) + have htestOne : symbolReg n tape β‰  oneReg n := + symbolReg_ne_one n tape + let cleared := Structured.Switch.cleared store (symbolReg n tape) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + cleared_represents hrepresents (hrange.2.2.2.2.2.2 tape).1 + (hrange.2.2.2.2.2.2 tape).2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne store htestOne.symm).trans hone + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  symbolReg n tape := by + simp [tapeCountReg, symbolReg] + omega + exact (cleared_apply_of_ne store hne).trans htapeCount + have hclearedEnvelope : ResourceEnvelope tm bound cleared := + cleared_envelope henvelope + (lt_trans (hrange.2.2.2.2.2.2 tape).2 + (control_lt_registerBound n bound)) + have hclearedLoaded : βˆ€ candidate, candidate ∈ rest β†’ + cleared (symbolReg n candidate) = + symbolCode (readSymbols cfg candidate) := by + intro candidate hcandidate + have hne : candidate β‰  tape := by + intro heq + subst candidate + exact (List.nodup_cons.mp hnodup).1 hcandidate + have hregs : symbolReg n candidate β‰  symbolReg n tape := + fun heq => hne ((symbolReg_injective n) heq) + exact (cleared_apply_of_ne store hregs).trans + (hloaded candidate (by simp [hcandidate])) + have hclearedAssigned : βˆ€ candidate, candidate βˆ‰ rest β†’ + Function.update symbols tape (readSymbols cfg tape) candidate = + readSymbols cfg candidate := by + intro candidate hnot + by_cases heq : candidate = tape + Β· subst candidate + simp + Β· rw [Function.update_of_ne heq] + exact hassigned candidate (by simp [heq, hnot]) + obtain ⟨final, hbranch, hfinalRepresents, hfinalEnvelope⟩ := + ih (symbols := Function.update symbols tape (readSymbols cfg tape)) + (store := cleared) hclearedRepresents hclearedOne hclearedCount + (List.nodup_cons.mp hnodup).2 hclearedEnvelope hclearedLoaded + hclearedAssigned + have hselectedBranch : Structured.Internal.MeasuredRuns + ((fun code : Fin 4 => + dispatchSymbols tm cfg.state rest + (Function.update symbols tape (symbolDecode code.val))) + ⟨symbolCode (readSymbols cfg tape), + symbolCode_lt_internal (readSymbols cfg tape)⟩) + cleared final + (dispatchSteps tm cfg.state (readSymbols cfg) rest) + (dispatchCost tm bound cfg.state (readSymbols cfg) rest) + (spaceBound tm bound) := by + simpa [symbolDecode_code_internal] using hbranch + have hrun := Structured.Switch.select_measured + (fun code : Fin 4 => + dispatchSymbols tm cfg.state rest + (Function.update symbols tape (symbolDecode code.val))) + store final (symbolCode_lt_internal (readSymbols cfg tape)) + htapeCode hone htestOne + (lt_trans (hrange.2.2.2.2.2.2 tape).2 + (control_lt_registerBound n bound)) + henvelope hselectedBranch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [dispatchSymbols, dispatchSteps, dispatchCost, wordWidth, + Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace] using hrun + +theorem dispatchState_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n) = 1) + (htapeCount : store (tapeCountReg n) = n + 2) + (hstate : store (stateScratchReg n) = stateCode tm cfg.state) + (hloaded : βˆ€ tape, store (symbolReg n tape) = + symbolCode (readSymbols cfg tape)) + (henvelope : ResourceEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (dispatchState tm) store final + (Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm cfg.state (readSymbols cfg) + (List.finRange (n + 2)))) + (Structured.Switch.costBound (stateCode tm cfg.state) + (dispatchCost tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) (wordWidth tm bound)) + (spaceBound tm bound) ∧ + Represents tm next final ∧ ResourceEnvelope tm bound final := by + let cleared := Structured.Switch.cleared store (stateScratchReg n) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + cleared_represents hrepresents hrange.2.2.2.1.1 hrange.2.2.2.1.2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne store (stateScratchReg_ne_one n).symm).trans hone + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  stateScratchReg n := by + simp [tapeCountReg, stateScratchReg] + exact (cleared_apply_of_ne store hne).trans htapeCount + have hclearedEnvelope : ResourceEnvelope tm bound cleared := + cleared_envelope henvelope + (lt_trans hrange.2.2.2.1.2 (control_lt_registerBound n bound)) + have hclearedLoaded : βˆ€ tape, + cleared (symbolReg n tape) = symbolCode (readSymbols cfg tape) := by + intro tape + exact (cleared_apply_of_ne store + (stateScratchReg_ne_symbolReg n tape)).trans (hloaded tape) + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩ = + cfg.state := + (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + obtain ⟨final, hbranch, hfinalRepresents, hfinalEnvelope⟩ := + dispatchSymbols_measured_internal + ((Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + (readSymbols cfg) (fun _ => Ξ“.blank) (List.finRange (n + 2)) + hbranchState hstep hclearedRepresents hheads hworkStart houtputStart + hclearedOne hclearedCount rfl (fun tape _ => hclearedLoaded tape) + (by simp) (List.nodup_finRange (n + 2)) hclearedEnvelope + have hselectedBranch : Structured.Internal.MeasuredRuns + ((fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + cleared final + (dispatchSteps tm cfg.state (readSymbols cfg) (List.finRange (n + 2))) + (dispatchCost tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) + (spaceBound tm bound) := by + simpa [hbranchState] using hbranch + have hrun := Structured.Switch.select_measured + (fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + store final (stateCode_lt_internal tm cfg.state) hstate hone + (stateScratchReg_ne_one n) + (lt_trans hrange.2.2.2.1.2 (control_lt_registerBound n bound)) + henvelope hselectedBranch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [dispatchState, wordWidth, Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace] using hrun + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Iteration.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Iteration.lean new file mode 100644 index 0000000000..6ba14990b0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Iteration.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Dispatch + +/-! +# Iterating the fixed sparse TM transition -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +private theorem stateCode_lt (tm : TM n) (state : tm.Q) : + stateCode tm state < Fintype.card tm.Q := + (Fintype.equivFin tm.Q state).isLt + +private theorem stateScratchReg_ne_one (n : β„•) : + stateScratchReg n β‰  oneReg n := by + simp [stateScratchReg, oneReg] + +private theorem cleared_apply_of_ne (store : Structured.Store) {test reg : β„•} + (hne : reg β‰  test) : + Structured.Switch.cleared store test reg = store reg := by + simp [Structured.Switch.cleared, Function.update_of_ne hne] + +theorem continueCheck_exec_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) : + βˆƒ final cost space, + Structured.Exec (continueCheck tm) store final + (continueSteps tm cfg) cost space ∧ + Represents tm cfg final ∧ + final (valueReg n) = runningFlag tm cfg.state ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 := by + let loaded := Structured.Basic.execList (loadOps n) store + obtain ⟨loadCost, loadSpace, hloadExec⟩ := + Structured.Internal.exec_basics_exists (loadOps n) store + have hloaded := loadOps_loaded_internal hrepresents + let cleared := Structured.Switch.cleared loaded (stateScratchReg n) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + hloaded.1.update_control_internal hrange.2.2.2.1.1 + hrange.2.2.2.1.2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne loaded (stateScratchReg_ne_one n).symm).trans + hloaded.2.2.1 + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  stateScratchReg n := by + simp [tapeCountReg, stateScratchReg] + exact (cleared_apply_of_ne loaded hne).trans hloaded.2.2.2.1 + let final := (Structured.Basic.imm (valueReg n) + (runningFlag tm cfg.state)).exec cleared + obtain ⟨branchCost, branchSpace, hbranchExec⟩ := + Structured.Internal.exec_basics_exists + [.imm (valueReg n) (runningFlag tm cfg.state)] cleared + have hfinalRepresents : Represents tm cfg final := by + exact hclearedRepresents.update_control_internal + hrange.2.2.2.2.2.1.1 hrange.2.2.2.2.2.1.2 + have hfinalValue : final (valueReg n) = runningFlag tm cfg.state := by + simp [final, Structured.Basic.exec] + have hfinalOne : final (oneReg n) = 1 := by + simpa [final, Structured.Basic.exec, oneReg, valueReg, + Function.update_of_ne] using hclearedOne + have hfinalCount : final (tapeCountReg n) = n + 2 := by + simpa [final, Structured.Basic.exec, tapeCountReg, valueReg, + Function.update_of_ne] using hclearedCount + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt tm cfg.state⟩ = cfg.state := + (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + have hselectedBranch : + βˆƒ cost space, + Structured.Exec + ((fun code : Fin (Fintype.card tm.Q) => .basics + [.imm (valueReg n) + (runningFlag tm ((Fintype.equivFin tm.Q).symm code))]) + ⟨stateCode tm cfg.state, stateCode_lt tm cfg.state⟩) + cleared final 1 cost space := by + refine ⟨branchCost, branchSpace, ?_⟩ + simpa [hbranchState, final] using! hbranchExec + obtain ⟨dispatchCost, dispatchSpace, hdispatch⟩ := + Structured.Switch.select_exec + (fun code : Fin (Fintype.card tm.Q) => .basics + [.imm (valueReg n) + (runningFlag tm ((Fintype.equivFin tm.Q).symm code))]) + loaded final (stateCode_lt tm cfg.state) hloaded.2.2.2.2.1 + hloaded.2.2.1 (stateScratchReg_ne_one n) hselectedBranch + refine ⟨final, loadCost + dispatchCost, max loadSpace dispatchSpace, + ?_, hfinalRepresents, hfinalValue, hfinalOne, hfinalCount⟩ + simpa [continueCheck, continueDispatch, continueSteps, loaded] using + Structured.Exec.seq hloadExec hdispatch + +theorem starts_of_step_internal {tm : TM n} + {cfg next : Complexity.Cfg n tm.Q} (hstep : tm.step cfg = some next) + (hwork : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtput : cfg.output.cells 0 = Ξ“.start) : + (βˆ€ i, (next.work i).cells 0 = Ξ“.start) ∧ + next.output.cells 0 = Ξ“.start := by + have hnotHalted := TM.state_ne_qhalt_of_step hstep + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + rw [TM.step, ite_eq_right hnotHalted, hdelta] at hstep + dsimp only at hstep + injection hstep with hnext + subst next + constructor + Β· intro i + rw [Tape.writeAndMove, Tape.move_cells] + simp only [Tape.write] + split + Β· exact hwork i + Β· change Function.update (cfg.work i).cells (cfg.work i).head + (workWrites i).toΞ“ 0 = Ξ“.start + rw [Function.update_of_ne] + Β· exact hwork i + Β· exact Ne.symm (by assumption) + Β· rw [Tape.writeAndMove, Tape.move_cells] + simp only [Tape.write] + split + Β· exact houtput + Β· change Function.update cfg.output.cells cfg.output.head + outputWrite.toΞ“ 0 = Ξ“.start + rw [Function.update_of_ne] + Β· exact houtput + Β· exact Ne.symm (by assumption) + +theorem loop_exec_internal {tm : TM n} {steps : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hflag : store (valueReg n) = runningFlag tm cfg.state) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) : + βˆƒ final cost space, + Structured.Exec (.whileNonzero (valueReg n) (loopBody tm)) + store final (loopSteps tm steps cfg) cost space ∧ + Represents tm halted final := by + induction hreach generalizing store with + | zero => + have hzero : store (valueReg n) = 0 := by + rw [hflag] + simp [runningFlag, hhalted] + refine ⟨store, bitlen (store (valueReg n)) + 1, store.space, ?_, + hrepresents⟩ + simpa [loopSteps] using + (Structured.Exec.whileZero (body := loopBody tm) hzero) + | @step current successor tail finalCfg hstep htail ih => + have hnotHalted := TM.state_ne_qhalt_of_step hstep + have hnonzero : store (valueReg n) β‰  0 := by + rw [hflag] + simp [runningFlag, hnotHalted] + obtain ⟨middle, stepCost, stepSpace, hprogram, hmiddleRepresents⟩ := + program_exec_internal hstep hrepresents hworkStart houtputStart + obtain ⟨checked, checkCost, checkSpace, hcheck, + hcheckedRepresents, hcheckedFlag, _hcheckedOne, _hcheckedCount⟩ := + continueCheck_exec_internal hmiddleRepresents + have hstarts := starts_of_step_internal hstep hworkStart houtputStart + obtain ⟨final, loopCost, loopSpace, hloop, hfinalRepresents⟩ := + ih hhalted hcheckedRepresents hcheckedFlag hstarts.1 hstarts.2 + have hbody : Structured.Exec (loopBody tm) store checked + (stepCount tm current + continueSteps tm successor) + (stepCost + checkCost) (max stepSpace checkSpace) := by + simpa [loopBody] using Structured.Exec.seq hprogram hcheck + refine ⟨final, + bitlen (store (valueReg n)) + 1 + (stepCost + checkCost) + 1 + loopCost, + max (max stepSpace checkSpace) loopSpace, ?_, hfinalRepresents⟩ + have hexec := Structured.Exec.whileNonzero hnonzero hbody hloop + simpa [loopSteps, hstep, Nat.add_assoc] using hexec + +theorem runUntilHalt_exec_internal {tm : TM n} {steps : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) : + βˆƒ final cost space, + Structured.Exec (runUntilHalt tm) store final + (runSteps tm steps cfg) cost space ∧ + Represents tm halted final := by + obtain ⟨checked, checkCost, checkSpace, hcheck, hcheckedRepresents, + hcheckedFlag, _hcheckedOne, _hcheckedCount⟩ := + continueCheck_exec_internal hrepresents + obtain ⟨final, loopCost, loopSpace, hloop, hfinalRepresents⟩ := + loop_exec_internal hreach hhalted hcheckedRepresents hcheckedFlag + hworkStart houtputStart + refine ⟨final, checkCost + loopCost, max checkSpace loopSpace, ?_, + hfinalRepresents⟩ + simpa [runUntilHalt, runSteps] using Structured.Exec.seq hcheck hloop + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Layout.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Layout.lean new file mode 100644 index 0000000000..6d4aeda8e7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Layout.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Internal + +/-! +# Sparse TM-step address and loading layout -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +private theorem execList_append (first second : List Structured.Basic) + (store : Structured.Store) : + Structured.Basic.execList (first ++ second) store = + Structured.Basic.execList second (Structured.Basic.execList first store) := by + induction first generalizing store with + | nil => rfl + | cons op rest ih => simp [Structured.Basic.execList, ih] + +theorem symbolCode_lt_internal (symbol : Ξ“) : symbolCode symbol < 4 := by + cases symbol <;> decide + +theorem addressOps_represents_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (tape : Fin (n + 2)) : + Represents tm cfg (Structured.Basic.execList (addressOps n tape) store) := by + have hrange := scratch_range_internal n + simp only [addressOps, Structured.Basic.execList] + apply Represents.update_control_internal + Β· apply Represents.update_control_internal + Β· exact hrepresents.update_control_internal hrange.2.2.2.2.2.1.1 + hrange.2.2.2.2.2.1.2 + Β· exact hrange.2.2.2.2.1.1 + Β· exact hrange.2.2.2.2.1.2 + Β· exact hrange.2.2.2.2.1.1 + Β· exact hrange.2.2.2.2.1.2 + +theorem loadTapeOps_represents_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (tape : Fin (n + 2)) : + Represents tm cfg (Structured.Basic.execList (loadTapeOps n tape) store) := by + have hrange := scratch_range_internal n + rw [loadTapeOps, execList_append] + simp only [Structured.Basic.execList, Structured.Basic.exec] + exact (addressOps_represents_internal hrepresents tape).update_control_internal + (hrange.2.2.2.2.2.2 tape).1 (hrange.2.2.2.2.2.2 tape).2 + +theorem addressOps_address_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (tape : Fin (n + 2)) + (htapeCount : store (tapeCountReg n) = n + 2) : + Structured.Basic.execList (addressOps n tape) store (addressReg n) = + cellReg n tape (tapeAt cfg tape).head := by + have hhead := hrepresents (Sum.inr (Sum.inl tape)) + change store (headReg tape) = (tapeAt cfg tape).head at hhead + have hvalueHead : valueReg n β‰  headReg tape := by + simp [valueReg, headReg] + omega + have hvalueCount : valueReg n β‰  tapeCountReg n := by + simp [valueReg, tapeCountReg] + have haddressValue : addressReg n β‰  valueReg n := by + simp [addressReg, valueReg] + let first := (Structured.Basic.imm (valueReg n) + (cellBase n + tape.val)).exec store + let multiplied := (Structured.Basic.mul (addressReg n) (headReg tape) + (tapeCountReg n)).exec first + have hfirstHead : first (headReg tape) = store (headReg tape) := by + simp [first, Structured.Basic.exec, Function.update_of_ne (Ne.symm hvalueHead)] + have hfirstCount : first (tapeCountReg n) = store (tapeCountReg n) := by + simp [first, Structured.Basic.exec, Function.update_of_ne (Ne.symm hvalueCount)] + have hfirstValue : first (valueReg n) = cellBase n + tape.val := by + simp [first, Structured.Basic.exec] + have hmultipliedAddress : multiplied (addressReg n) = + (tapeAt cfg tape).head * (n + 2) := by + simp only [multiplied, Structured.Basic.exec, Function.update_self] + rw [hfirstHead, hfirstCount, hhead, htapeCount] + have hmultipliedValue : multiplied (valueReg n) = cellBase n + tape.val := by + simp only [multiplied, Structured.Basic.exec] + rw [Function.update_of_ne (Ne.symm haddressValue), hfirstValue] + simp only [addressOps, Structured.Basic.execList] + change ((Structured.Basic.add (addressReg n) (addressReg n) + (valueReg n)).exec multiplied) (addressReg n) = _ + simp only [Structured.Basic.exec, Function.update_self] + rw [hmultipliedAddress, hmultipliedValue] + simp [cellReg] + omega + +theorem loadTapeOps_symbol_internal {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (tape : Fin (n + 2)) + (htapeCount : store (tapeCountReg n) = n + 2) : + Structured.Basic.execList (loadTapeOps n tape) store (symbolReg n tape) = + symbolCode ((tapeAt cfg tape).read) := by + let addressed := Structured.Basic.execList (addressOps n tape) store + have haddress : addressed (addressReg n) = + cellReg n tape (tapeAt cfg tape).head := + addressOps_address_internal hrepresents tape htapeCount + have haddressedRepresents := addressOps_represents_internal hrepresents tape + have hcell := haddressedRepresents + (Sum.inr (Sum.inr (tape, (tapeAt cfg tape).head))) + change addressed (cellReg n tape (tapeAt cfg tape).head) = + symbolCode ((tapeAt cfg tape).cells (tapeAt cfg tape).head) at hcell + rw [loadTapeOps, execList_append] + simp only [Structured.Basic.execList, Structured.Basic.exec, Function.update_self] + change addressed (addressed (addressReg n)) = _ + rw [haddress, hcell] + rfl + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Load.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Load.lean new file mode 100644 index 0000000000..297db80ceb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Load.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Layout + +/-! +# Loading sparse TM states and head symbols -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +private theorem execList_append (first second : List Structured.Basic) + (store : Structured.Store) : + Structured.Basic.execList (first ++ second) store = + Structured.Basic.execList second (Structured.Basic.execList first store) := by + induction first generalizing store with + | nil => rfl + | cons op rest ih => simp [Structured.Basic.execList, ih] + +private theorem loadTapeOps_apply_of_ne (n : β„•) (tape : Fin (n + 2)) + (store : Structured.Store) (reg : β„•) + (hvalue : reg β‰  valueReg n) (haddress : reg β‰  addressReg n) + (hsymbol : reg β‰  symbolReg n tape) : + Structured.Basic.execList (loadTapeOps n tape) store reg = store reg := by + simp [loadTapeOps, addressOps, Structured.Basic.execList, + Structured.Basic.exec, Function.update_of_ne hvalue, + Function.update_of_ne haddress, Function.update_of_ne hsymbol] + +private theorem symbolReg_injective (n : β„•) : + Function.Injective (symbolReg n) := by + intro first second heq + apply Fin.ext + simp [symbolReg] at heq + omega + +private structure LoadedPrefix (tm : TM n) (cfg : Complexity.Cfg n tm.Q) + (processed : List (Fin (n + 2))) (store : Structured.Store) : Prop where + represents : Represents tm cfg store + zero : store (zeroReg n) = 0 + one : store (oneReg n) = 1 + tapeCount : store (tapeCountReg n) = n + 2 + state : store (stateScratchReg n) = stateCode tm cfg.state + symbols : βˆ€ tape, tape ∈ processed β†’ + store (symbolReg n tape) = symbolCode (readSymbols cfg tape) + +private theorem setup_loadedPrefix {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + {store : Structured.Store} (hrepresents : Represents tm cfg store) : + LoadedPrefix tm cfg [] + (Structured.Basic.execList (setupOps n) store) := by + let first := (Structured.Basic.imm (zeroReg n) 0).exec store + let second := (Structured.Basic.imm (oneReg n) 1).exec first + let third := (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec second + let final := (Structured.Basic.add (stateScratchReg n) stateReg + (zeroReg n)).exec third + have hrange := scratch_range_internal n + have hfirstRep : Represents tm cfg first := by + exact hrepresents.update_control_internal hrange.1.1 hrange.1.2 + have hsecondRep : Represents tm cfg second := by + exact hfirstRep.update_control_internal hrange.2.1.1 hrange.2.1.2 + have hthirdRep : Represents tm cfg third := by + exact hsecondRep.update_control_internal hrange.2.2.1.1 hrange.2.2.1.2 + have hfinalRep : Represents tm cfg final := by + exact hthirdRep.update_control_internal + hrange.2.2.2.1.1 hrange.2.2.2.1.2 + have hzero : final (zeroReg n) = 0 := by + simp [final, third, second, first, Structured.Basic.exec, zeroReg, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hone : final (oneReg n) = 1 := by + simp [final, third, second, first, Structured.Basic.exec, zeroReg, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hcount : final (tapeCountReg n) = n + 2 := by + simp [final, third, second, first, Structured.Basic.exec, zeroReg, oneReg, + tapeCountReg, stateScratchReg, Function.update_of_ne] + have hstateStore : store stateReg = stateCode tm cfg.state := by + have hstate := hrepresents (Sum.inl ⟨0, by omega⟩) + change store stateReg = stateCode tm cfg.state at hstate + exact hstate + have hstate : final (stateScratchReg n) = stateCode tm cfg.state := by + simp only [final, Structured.Basic.exec, Function.update_self] + have hthirdState : third stateReg = store stateReg := by + simp [third, second, first, Structured.Basic.exec, stateReg, zeroReg, + oneReg, tapeCountReg, Function.update_of_ne] + have hthirdZero : third (zeroReg n) = 0 := by + simp [third, second, first, Structured.Basic.exec, zeroReg, oneReg, + tapeCountReg, Function.update_of_ne] + rw [hthirdState, hthirdZero, hstateStore, Nat.add_zero] + simpa [setupOps, first, second, third, final] using! + LoadedPrefix.mk hfinalRep hzero hone hcount hstate (by simp) + +private theorem loadTape_loadedPrefix {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {processed : List (Fin (n + 2))} + {store : Structured.Store} (hloaded : LoadedPrefix tm cfg processed store) + (tape : Fin (n + 2)) : + LoadedPrefix tm cfg (tape :: processed) + (Structured.Basic.execList (loadTapeOps n tape) store) := by + have hzeroValue : zeroReg n β‰  valueReg n := by simp [zeroReg, valueReg] + have hzeroAddress : zeroReg n β‰  addressReg n := by simp [zeroReg, addressReg] + have hzeroSymbol : zeroReg n β‰  symbolReg n tape := by + simp [zeroReg, symbolReg] + omega + have honeValue : oneReg n β‰  valueReg n := by simp [oneReg, valueReg] + have honeAddress : oneReg n β‰  addressReg n := by simp [oneReg, addressReg] + have honeSymbol : oneReg n β‰  symbolReg n tape := by + simp [oneReg, symbolReg] + omega + have hcountValue : tapeCountReg n β‰  valueReg n := by simp [tapeCountReg, valueReg] + have hcountAddress : tapeCountReg n β‰  addressReg n := by + simp [tapeCountReg, addressReg] + have hcountSymbol : tapeCountReg n β‰  symbolReg n tape := by + simp [tapeCountReg, symbolReg] + omega + have hstateValue : stateScratchReg n β‰  valueReg n := by + simp [stateScratchReg, valueReg] + have hstateAddress : stateScratchReg n β‰  addressReg n := by + simp [stateScratchReg, addressReg] + have hstateSymbol : stateScratchReg n β‰  symbolReg n tape := by + simp [stateScratchReg, symbolReg] + omega + refine ⟨loadTapeOps_represents_internal hloaded.represents tape, + loadTapeOps_apply_of_ne n tape store (zeroReg n) hzeroValue hzeroAddress + hzeroSymbol β–Έ hloaded.zero, + loadTapeOps_apply_of_ne n tape store (oneReg n) honeValue honeAddress + honeSymbol β–Έ hloaded.one, + loadTapeOps_apply_of_ne n tape store (tapeCountReg n) hcountValue + hcountAddress hcountSymbol β–Έ hloaded.tapeCount, + loadTapeOps_apply_of_ne n tape store (stateScratchReg n) hstateValue + hstateAddress hstateSymbol β–Έ hloaded.state, ?_⟩ + intro candidate hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst candidate + exact loadTapeOps_symbol_internal hloaded.represents tape hloaded.tapeCount + Β· by_cases heq : candidate = tape + Β· subst candidate + exact loadTapeOps_symbol_internal hloaded.represents tape hloaded.tapeCount + Β· rw [loadTapeOps_apply_of_ne n tape store (symbolReg n candidate)] + Β· exact hloaded.symbols candidate hprocessed + Β· simp [symbolReg, valueReg] + omega + Β· simp [symbolReg, addressReg] + omega + Β· exact fun hregs => heq (symbolReg_injective n hregs) + +private theorem loadTapes_loadedPrefix {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} (tapes processed : List (Fin (n + 2))) + {store : Structured.Store} (hloaded : LoadedPrefix tm cfg processed store) : + LoadedPrefix tm cfg (tapes.reverse ++ processed) + (Structured.Basic.execList (tapes.flatMap (loadTapeOps n)) store) := by + induction tapes generalizing processed store with + | nil => simpa using! hloaded + | cons tape rest ih => + have hnext := loadTape_loadedPrefix hloaded tape + have hfinal := ih (processed := tape :: processed) hnext + simpa [List.flatMap_cons, Structured.Basic.execList, execList_append, + List.reverse_cons, List.append_assoc] using hfinal + +theorem loadOps_loaded_internal {tm : TM n} {cfg : Complexity.Cfg n tm.Q} + {store : Structured.Store} (hrepresents : Represents tm cfg store) : + let final := Structured.Basic.execList (loadOps n) store + Represents tm cfg final ∧ + final (zeroReg n) = 0 ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ + final (stateScratchReg n) = stateCode tm cfg.state ∧ + βˆ€ tape, final (symbolReg n tape) = symbolCode (readSymbols cfg tape) := by + let setup := Structured.Basic.execList (setupOps n) store + have hsetup := setup_loadedPrefix hrepresents + have hloaded := loadTapes_loadedPrefix (List.finRange (n + 2)) [] hsetup + rw [loadOps, execList_append] + exact ⟨hloaded.represents, hloaded.zero, hloaded.one, hloaded.tapeCount, + hloaded.state, fun tape => hloaded.symbols tape (by simp)⟩ + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Resources.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Resources.lean new file mode 100644 index 0000000000..fa05d938b8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Step/Internal/Resources.lean @@ -0,0 +1,888 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.Step.Internal.Iteration +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources + +/-! +# Resource envelopes for the fixed sparse TM simulator -- proof internals + +The semantic simulation already records exact source steps, cost, and space. +This layer supplies the uniform finite-store envelope needed to turn those +measurements into explicit bounds depending only on input length and TM steps. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Sparse + + +/-- Shared envelope used by marshalling and repeated sparse simulation. -/ +abbrev StepEnvelope (tm : TM n) (bound : β„•) := + Structured.Internal.StoreEnvelope (registerBound n (bound + 1)) + (wordBound tm bound) + +theorem bound_lt_registerBound_internal (n bound : β„•) : + bound < registerBound n (bound + 1) := by + simp [registerBound, cellReg, outputTape, cellBase, Nat.mul_add] + omega + +theorem control_lt_registerBound_internal (n bound : β„•) : + cellBase n < registerBound n (bound + 1) := by + simp [registerBound, cellReg, outputTape] + omega + +theorem cellReg_lt_registerBound_internal (tape : Fin (n + 2)) + {position bound : β„•} (hposition : position ≀ bound + 1) : + cellReg n tape position < registerBound n (bound + 1) := by + have hmul := Nat.mul_le_mul_right (n + 2) hposition + simp only [cellReg, registerBound, outputTape] + omega + +theorem cellReg_decode_internal (n reg : β„•) (hreg : cellBase n ≀ reg) : + cellReg n (decodeCellTape n reg) (decodeCellPosition n reg) = reg := by + have hdivision := Nat.mod_add_div (reg - cellBase n) (n + 2) + rw [Nat.mul_comm (n + 2)] at hdivision + simp only [cellReg, decodeCellTape, decodeCellPosition] + omega + +theorem registerBound_le_wordBound_internal (tm : TM n) (bound : β„•) : + registerBound n (bound + 1) ≀ wordBound tm bound := by + exact le_max_left _ _ + +theorem card_le_wordBound_internal (tm : TM n) (bound : β„•) : + Fintype.card tm.Q ≀ wordBound tm bound := by + exact le_trans (le_max_left _ _) (le_max_right _ _) + +theorem bound_succ_le_wordBound_internal (tm : TM n) (bound : β„•) : + bound + 1 ≀ wordBound tm bound := by + exact le_trans (le_max_right _ _) (le_max_right _ _) + +private theorem tapeCount_le_wordBound (tm : TM n) (bound : β„•) : + n + 2 ≀ wordBound tm bound := by + have hcontrol := control_lt_registerBound_internal n bound + have hregister := registerBound_le_wordBound_internal tm bound + simp [cellBase] at hcontrol + omega + +private theorem initRegs_index_le_length {x : List Bool} {reg : β„•} + (hnonzero : initRegs x reg β‰  0) : reg ≀ x.length := by + by_cases hreg : reg = 0 + Β· omega + rw [initRegs, ite_eq_right hreg] at hnonzero + cases hbit : x[reg - 1]? with + | none => simp [hbit] at hnonzero + | some bit => + have hindex : reg - 1 < x.length := + (List.getElem?_eq_some_iff.mp hbit).1 + omega + +private theorem initRegs_value_le_length_succ (x : List Bool) (reg : β„•) : + initRegs x reg ≀ x.length + 1 := by + rw [initRegs] + split + Β· omega + Β· cases x[reg - 1]? with + | none => simp + | some bit => cases bit <;> simp + +/-- The public RAM input store fits every sparse execution envelope whose bound +contains the input length. -/ +theorem initRegs_envelope_internal (tm : TM n) (x : List Bool) (bound : β„•) + (hlength : x.length ≀ bound) : StepEnvelope tm bound (initRegs x) where + index_lt _reg hnonzero := + lt_of_le_of_lt + (le_trans (initRegs_index_le_length hnonzero) hlength) + (bound_lt_registerBound_internal n bound) + value_le reg := + le_trans (initRegs_value_le_length_succ x reg) + (le_trans (Nat.add_le_add_right hlength 1) + (bound_succ_le_wordBound_internal tm bound)) + +/-- The canonical sparse encoding fits the common execution envelope whenever +all heads and nonblank tape cells lie within the chosen bound. -/ +theorem encodeRegs_envelope_internal (tm : TM n) + (cfg : Complexity.Cfg n tm.Q) (bound : β„•) + (hbounded : Bounded cfg bound) (hheads : HeadsBounded cfg bound) : + StepEnvelope tm bound (encodeRegs tm cfg) where + index_lt reg hnonzero := by + by_contra houtside + have hindex : registerBound n (bound + 1) ≀ reg := by omega + rw [encodeRegs] at hnonzero + split at hnonzero + Β· subst reg + have := bound_lt_registerBound_internal n bound + simp [stateReg] at hindex + omega + next hstate => + split at hnonzero + Β· have hcontrol := control_lt_registerBound_internal n bound + simp [cellBase] at hcontrol + omega + next hhead => + split at hnonzero + Β· rename_i hcell + have hreconstruct := cellReg_decode_internal n reg hcell + have hposition : bound < decodeCellPosition n reg := by + by_contra hlow + have hpositionLe : decodeCellPosition n reg ≀ bound := + Nat.le_of_not_gt hlow + have hcellLt := cellReg_lt_registerBound_internal + (decodeCellTape n reg) (bound := bound) + (show decodeCellPosition n reg ≀ bound + 1 by omega) + rw [hreconstruct] at hcellLt + omega + rw [hbounded (decodeCellTape n reg) (decodeCellPosition n reg) + hposition] at hnonzero + simp [symbolCode] at hnonzero + Β· simp at hnonzero + value_le reg := by + rw [encodeRegs] + split + Β· have hstateCode : stateCode tm cfg.state < Fintype.card tm.Q := by + simp [stateCode] + exact le_trans (Nat.le_of_lt hstateCode) + (card_le_wordBound_internal tm bound) + next hstate => + split + Β· exact le_trans (hheads ⟨reg - 1, by omega⟩) + (le_trans (Nat.le_succ bound) + (bound_succ_le_wordBound_internal tm bound)) + next hhead => + split + Β· have hsymbol := symbolCode_lt_internal + ((tapeAt cfg (decodeCellTape n reg)).cells + (decodeCellPosition n reg)) + have hfour : 4 ≀ registerBound n (bound + 1) := by + have hcontrol := control_lt_registerBound_internal n bound + simp [cellBase] at hcontrol + omega + exact le_trans (Nat.le_of_lt hsymbol) + (le_trans hfour (registerBound_le_wordBound_internal tm bound)) + Β· exact Nat.zero_le _ + +private theorem setupOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) + (henvelope : StepEnvelope tm bound store) : + Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (setupOps n) store := by + let first := (Structured.Basic.imm (zeroReg n) 0).exec store + let second := (Structured.Basic.imm (oneReg n) 1).exec first + let third := (Structured.Basic.imm (tapeCountReg n) (n + 2)).exec second + let final := (Structured.Basic.add (stateScratchReg n) stateReg + (zeroReg n)).exec third + have hrange := scratch_range_internal n + have hfirst : StepEnvelope tm bound first := by + apply henvelope.execBasic + Β· exact lt_trans hrange.1.2 (control_lt_registerBound_internal n bound) + Β· simp [Structured.Internal.Basic.writeValue] + have hone : 1 ≀ wordBound tm bound := by + exact le_trans (show 1 ≀ n + 2 by omega) + (tapeCount_le_wordBound tm bound) + have hsecond : StepEnvelope tm bound second := by + apply hfirst.execBasic + Β· exact lt_trans hrange.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using hone + have hthird : StepEnvelope tm bound third := by + apply hsecond.execBasic + Β· exact lt_trans hrange.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using + tapeCount_le_wordBound tm bound + have hstoreState : store stateReg = stateCode tm cfg.state := by + have hstate := hrepresents (Sum.inl ⟨0, by omega⟩) + exact hstate + have hthirdState : third stateReg = store stateReg := by + simp [third, second, first, Structured.Basic.exec, stateReg, zeroReg, + oneReg, tapeCountReg, Function.update_of_ne] + have hthirdZero : third (zeroReg n) = 0 := by + simp [third, second, first, Structured.Basic.exec, zeroReg, oneReg, + tapeCountReg, Function.update_of_ne] + have hstateBound : stateCode tm cfg.state ≀ wordBound tm bound := by + have hstateLt : stateCode tm cfg.state < Fintype.card tm.Q := by + simp [stateCode] + exact le_trans (Nat.le_of_lt hstateLt) + (card_le_wordBound_internal tm bound) + have hfinal : StepEnvelope tm bound final := by + apply hthird.execBasic + Β· exact lt_trans hrange.2.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hthirdState, hthirdZero, hstoreState, Nat.add_zero] + exact hstateBound + simpa [setupOps, first, second, third, final] using! + And.intro henvelope + (And.intro hfirst (And.intro hsecond (And.intro hthird hfinal))) + +private theorem setupOps_represents {tm : TM n} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) : + Represents tm cfg (Structured.Basic.execList (setupOps n) store) := by + have hrange := scratch_range_internal n + simp only [setupOps, Structured.Basic.execList] + apply Represents.update_control_internal + Β· apply Represents.update_control_internal + Β· apply Represents.update_control_internal + Β· exact hrepresents.update_control_internal hrange.1.1 hrange.1.2 + Β· exact hrange.2.1.1 + Β· exact hrange.2.1.2 + Β· exact hrange.2.2.1.1 + Β· exact hrange.2.2.1.2 + Β· exact hrange.2.2.2.1.1 + Β· exact hrange.2.2.2.1.2 + +private theorem setupOps_tapeCount (n : β„•) (store : Structured.Store) : + Structured.Basic.execList (setupOps n) store (tapeCountReg n) = n + 2 := by + simp [setupOps, Structured.Basic.execList, Structured.Basic.exec, zeroReg, + oneReg, tapeCountReg, stateScratchReg, Function.update_of_ne] + +private theorem loadTapeOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) (tape : Fin (n + 2)) + (htapeCount : store (tapeCountReg n) = n + 2) + (hhead : (tapeAt cfg tape).head ≀ bound) + (henvelope : StepEnvelope tm bound store) : + Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (loadTapeOps n tape) store := by + let first := (Structured.Basic.imm (valueReg n) + (cellBase n + tape.val)).exec store + let multiplied := (Structured.Basic.mul (addressReg n) (headReg tape) + (tapeCountReg n)).exec first + let addressed := (Structured.Basic.add (addressReg n) (addressReg n) + (valueReg n)).exec multiplied + let final := (Structured.Basic.load (symbolReg n tape) + (addressReg n)).exec addressed + have hrange := scratch_range_internal n + have hbaseLt : cellBase n + tape.val < registerBound n (bound + 1) := by + have hcell := cellReg_lt_registerBound_internal tape + (position := 0) (bound := bound) (by omega) + simpa [cellReg] using hcell + have hbaseBound : cellBase n + tape.val ≀ wordBound tm bound := + le_trans (Nat.le_of_lt hbaseLt) + (registerBound_le_wordBound_internal tm bound) + have hfirst : StepEnvelope tm bound first := by + apply henvelope.execBasic + Β· exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using hbaseBound + have hstoreHead : store (headReg tape) = (tapeAt cfg tape).head := by + exact hrepresents (Sum.inr (Sum.inl tape)) + have hfirstHead : first (headReg tape) = store (headReg tape) := by + have hne : headReg tape β‰  valueReg n := by + simp [headReg, valueReg] + omega + simp [first, Structured.Basic.exec, Function.update_of_ne hne] + have hfirstCount : first (tapeCountReg n) = store (tapeCountReg n) := by + have hne : tapeCountReg n β‰  valueReg n := by + simp [tapeCountReg, valueReg] + simp [first, Structured.Basic.exec, Function.update_of_ne hne] + have hproductBound : (tapeAt cfg tape).head * (n + 2) ≀ + wordBound tm bound := by + have hcell := cellReg_lt_registerBound_internal tape + (position := (tapeAt cfg tape).head) (bound := bound) (by omega) + have hproduct : (tapeAt cfg tape).head * (n + 2) < + registerBound n (bound + 1) := by + simp [cellReg] at hcell + omega + exact le_trans (Nat.le_of_lt hproduct) + (registerBound_le_wordBound_internal tm bound) + have hmultiplied : StepEnvelope tm bound multiplied := by + apply hfirst.execBasic + Β· exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hfirstHead, hfirstCount, hstoreHead, htapeCount] + exact hproductBound + have hmultipliedAddress : multiplied (addressReg n) = + (tapeAt cfg tape).head * (n + 2) := by + simp only [multiplied, Structured.Basic.exec, Function.update_self] + rw [hfirstHead, hfirstCount, hstoreHead, htapeCount] + have hmultipliedValue : multiplied (valueReg n) = + cellBase n + tape.val := by + have hne : valueReg n β‰  addressReg n := by + simp [valueReg, addressReg] + simp [multiplied, first, Structured.Basic.exec, + Function.update_of_ne hne] + have hcellBound : cellReg n tape (tapeAt cfg tape).head ≀ + wordBound tm bound := by + exact le_trans (Nat.le_of_lt + (cellReg_lt_registerBound_internal tape (bound := bound) (by omega))) + (registerBound_le_wordBound_internal tm bound) + have haddressed : StepEnvelope tm bound addressed := by + apply hmultiplied.execBasic + Β· exact lt_trans hrange.2.2.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hmultipliedAddress, hmultipliedValue] + simp [cellReg] at hcellBound + omega + have hfinal : StepEnvelope tm bound final := by + apply haddressed.execBasic + Β· exact lt_trans (hrange.2.2.2.2.2.2 tape).2 + (control_lt_registerBound_internal n bound) + Β· exact haddressed.value_le (addressed (addressReg n)) + simpa [loadTapeOps, addressOps, first, multiplied, addressed, final] using! + And.intro henvelope + (And.intro hfirst (And.intro hmultiplied (And.intro haddressed hfinal))) + +private theorem loadTapes_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} (tapes : List (Fin (n + 2))) + {store : Structured.Store} (hrepresents : Represents tm cfg store) + (htapeCount : store (tapeCountReg n) = n + 2) + (hheads : HeadsBounded cfg bound) + (henvelope : StepEnvelope tm bound store) : + Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (tapes.flatMap (loadTapeOps n)) store := by + induction tapes generalizing store with + | nil => exact henvelope + | cons tape rest ih => + have hfirst := loadTapeOps_envelopeChain hrepresents tape htapeCount + (hheads tape) henvelope + have hfirstRepresents := loadTapeOps_represents_internal hrepresents tape + have hcountPreserved : + Structured.Basic.execList (loadTapeOps n tape) store + (tapeCountReg n) = n + 2 := by + have hvalue : tapeCountReg n β‰  valueReg n := by + simp [tapeCountReg, valueReg] + have haddress : tapeCountReg n β‰  addressReg n := by + simp [tapeCountReg, addressReg] + have hsymbol : tapeCountReg n β‰  symbolReg n tape := by + simp [tapeCountReg, symbolReg] + omega + simpa [loadTapeOps, addressOps, Structured.Basic.execList, + Structured.Basic.exec, Function.update_of_ne hvalue, + Function.update_of_ne haddress, Function.update_of_ne hsymbol] + using htapeCount + have hrest := ih hfirstRepresents hcountPreserved hfirst.final + simpa [List.flatMap_cons] using hfirst.append hrest + +theorem loadOps_measured_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (henvelope : StepEnvelope tm bound store) : + let final := Structured.Basic.execList (loadOps n) store + Structured.Internal.MeasuredRuns (.basics (loadOps n)) store final + (loadOps n).length + (4 * (loadOps n).length * wordWidth tm bound) + (spaceBound tm bound) ∧ StepEnvelope tm bound final := by + have hsetup := setupOps_envelopeChain hrepresents henvelope + have hsetupRepresents : Represents tm cfg + (Structured.Basic.execList (setupOps n) store) := by + exact setupOps_represents hrepresents + have hsetupCount : + Structured.Basic.execList (setupOps n) store (tapeCountReg n) = n + 2 := by + exact setupOps_tapeCount n store + have htapes := loadTapes_envelopeChain (List.finRange (n + 2)) + hsetupRepresents hsetupCount hheads hsetup.final + have hchain : Structured.Internal.Basic.EnvelopeChain + (registerBound n (bound + 1)) (wordBound tm bound) + (loadOps n) store := by + simpa [loadOps] using hsetup.append htapes + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (loadOps n) store hchain + simpa [wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using hmeasured + +private theorem cleared_apply_of_ne (store : Structured.Store) {test reg : β„•} + (hne : reg β‰  test) : + Structured.Switch.cleared store test reg = store reg := by + simp [Structured.Switch.cleared, Function.update_of_ne hne] + +private theorem stateScratchReg_ne_one (n : β„•) : + stateScratchReg n β‰  oneReg n := by + simp [stateScratchReg, oneReg] + +theorem continueCheck_measured_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (continueCheck tm) store final + (continueSteps tm cfg) (continueTimeBound tm bound cfg) + (spaceBound tm bound) ∧ + Represents tm cfg final ∧ + final (valueReg n) = runningFlag tm cfg.state ∧ + final (oneReg n) = 1 ∧ + final (tapeCountReg n) = n + 2 ∧ + StepEnvelope tm bound final := by + let loaded := Structured.Basic.execList (loadOps n) store + have hload := loadOps_measured_internal hrepresents hheads henvelope + have hloaded := loadOps_loaded_internal hrepresents + let cleared := Structured.Switch.cleared loaded (stateScratchReg n) + have hrange := scratch_range_internal n + have hclearedRepresents : Represents tm cfg cleared := + hloaded.1.update_control_internal hrange.2.2.2.1.1 + hrange.2.2.2.1.2 + have hclearedOne : cleared (oneReg n) = 1 := by + exact (cleared_apply_of_ne loaded (stateScratchReg_ne_one n).symm).trans + hloaded.2.2.1 + have hclearedCount : cleared (tapeCountReg n) = n + 2 := by + have hne : tapeCountReg n β‰  stateScratchReg n := by + simp [tapeCountReg, stateScratchReg] + exact (cleared_apply_of_ne loaded hne).trans hloaded.2.2.2.1 + have hclearedEnvelope : StepEnvelope tm bound cleared := by + exact hload.2.update + (lt_trans hrange.2.2.2.1.2 + (control_lt_registerBound_internal n bound)) (by simp) + let final := (Structured.Basic.imm (valueReg n) + (runningFlag tm cfg.state)).exec cleared + have hflagBound : runningFlag tm cfg.state ≀ wordBound tm bound := by + have hone : 1 ≀ wordBound tm bound := by + exact le_trans (show 1 ≀ n + 2 by omega) + (tapeCount_le_wordBound tm bound) + simp [runningFlag] + split <;> omega + have hfinalEnvelope : StepEnvelope tm bound final := by + apply hclearedEnvelope.execBasic + Β· exact lt_trans hrange.2.2.2.2.2.1.2 + (control_lt_registerBound_internal n bound) + Β· simpa [Structured.Internal.Basic.writeValue] using hflagBound + have hbranch := Structured.Internal.MeasuredRuns.basicEnvelope + (Structured.Basic.imm (valueReg n) (runningFlag tm cfg.state)) + cleared hclearedEnvelope hfinalEnvelope + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, by simp [stateCode]⟩ = cfg.state := + (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + have hselectedBranch : Structured.Internal.MeasuredRuns + ((fun code : Fin (Fintype.card tm.Q) => .basics + [.imm (valueReg n) + (runningFlag tm ((Fintype.equivFin tm.Q).symm code))]) + ⟨stateCode tm cfg.state, by simp [stateCode]⟩) + cleared final 1 (4 * wordWidth tm bound) (spaceBound tm bound) := by + simpa [hbranchState, final, wordWidth, Structured.Internal.valueWidth, + spaceBound, Structured.Internal.envelopeSpace] using! hbranch + have hdispatch := Structured.Switch.select_measured + (fun code : Fin (Fintype.card tm.Q) => .basics + [.imm (valueReg n) + (runningFlag tm ((Fintype.equivFin tm.Q).symm code))]) + loaded final (by simp [stateCode]) hloaded.2.2.2.2.1 + hloaded.2.2.1 (stateScratchReg_ne_one n) + (lt_trans hrange.2.2.2.1.2 + (control_lt_registerBound_internal n bound)) + hload.2 hselectedBranch + have hrun := hload.1.seq hdispatch + have hfinalRepresents : Represents tm cfg final := by + exact hclearedRepresents.update_control_internal + hrange.2.2.2.2.2.1.1 hrange.2.2.2.2.2.1.2 + have hfinalValue : final (valueReg n) = runningFlag tm cfg.state := by + simp [final, Structured.Basic.exec] + have hfinalOne : final (oneReg n) = 1 := by + simpa [final, Structured.Basic.exec, oneReg, valueReg, + Function.update_of_ne] using hclearedOne + have hfinalCount : final (tapeCountReg n) = n + 2 := by + simpa [final, Structured.Basic.exec, tapeCountReg, valueReg, + Function.update_of_ne] using hclearedCount + refine ⟨final, ?_, hfinalRepresents, hfinalValue, hfinalOne, hfinalCount, + hfinalEnvelope⟩ + simpa [continueCheck, continueDispatch, continueSteps, continueTimeBound, + loaded, wordWidth, Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace] using hrun + +theorem headsBounded_step_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} (hstep : tm.step cfg = some next) + (hheads : HeadsBounded cfg bound) : HeadsBounded next (bound + 1) := by + have hnotHalted := TM.state_ne_qhalt_of_step hstep + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + rw [TM.step, ite_eq_right hnotHalted, hdelta] at hstep + dsimp only at hstep + injection hstep with hnext + subst next + intro tape + by_cases hinput : tape = inputTape n + Β· subst tape + rw [show tapeAt + { state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } + (inputTape n) = cfg.input.move inputDirection by + simpa [inputTape] using tapeAt_input_internal + ({ state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } : + Complexity.Cfg n tm.Q)] + have h := hheads (inputTape n) + rw [show tapeAt cfg (inputTape n) = cfg.input by + simpa [inputTape] using tapeAt_input_internal cfg] at h + cases inputDirection <;> simp [Tape.move] <;> omega + Β· by_cases houtput : tape = outputTape n + Β· subst tape + rw [show tapeAt + { state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } + (outputTape n) = cfg.output.writeAndMove outputWrite.toΞ“ outputDirection by + simpa [outputTape] using tapeAt_output_internal + ({ state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } : + Complexity.Cfg n tm.Q)] + have h := hheads (outputTape n) + rw [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at h + cases outputDirection <;> + simp [Tape.writeAndMove, Tape.move, Tape.write_head] <;> omega + Β· let i : Fin n := ⟨tape.val - 1, by + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinput + apply Fin.ext + simpa [inputTape] using hzero + omega + have hnotOutput : tape.val β‰  n + 1 := by + intro heq + apply houtput + apply Fin.ext + simpa [outputTape] using heq + omega⟩ + have htape : tape = workTape i := by + apply Fin.ext + simp [i, workTape] + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinput + apply Fin.ext + simpa [inputTape] using hzero + omega + omega + rw [htape] + rw [show tapeAt + { state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } + (workTape i) = (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) by + simpa [workTape] using tapeAt_work_internal + ({ state := nextState + input := cfg.input.move inputDirection + work := fun i => (cfg.work i).writeAndMove + (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } : + Complexity.Cfg n tm.Q) i] + have h := hheads (workTape i) + rw [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at h + cases workDirections i <;> + simp [Tape.writeAndMove, Tape.move, Tape.write_head] <;> omega + +theorem program_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (program tm) store final + (stepCount tm cfg) (timeBound tm bound cfg) (spaceBound tm bound) ∧ + Represents tm next final ∧ StepEnvelope tm bound final := by + let loaded := Structured.Basic.execList (loadOps n) store + have hload := loadOps_measured_internal hrepresents hheads henvelope + have hloaded := loadOps_loaded_internal hrepresents + obtain ⟨final, hdispatch, hfinalRepresents, hfinalEnvelope⟩ := + dispatchState_measured_internal hstep hloaded.1 hheads hworkStart + houtputStart hloaded.2.2.1 hloaded.2.2.2.1 hloaded.2.2.2.2.1 + hloaded.2.2.2.2.2 hload.2 + have hrun := hload.1.seq hdispatch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [program, stepCount, timeBound, loaded] using hrun + +private theorem headsBounded_mono {cfg : Complexity.Cfg n Q} + {bound larger : β„•} (hheads : HeadsBounded cfg bound) + (hle : bound ≀ larger) : HeadsBounded cfg larger := by + intro tape + exact le_trans (hheads tape) hle + +theorem loop_measured_internal {tm : TM n} {steps base : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hflag : store (valueReg n) = runningFlag tm cfg.state) + (hheads : HeadsBounded cfg base) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (henvelope : StepEnvelope tm (base + steps) store) : + βˆƒ final, + Structured.Internal.MeasuredRuns + (.whileNonzero (valueReg n) (loopBody tm)) store final + (loopSteps tm steps cfg) (loopTimeBound tm base steps cfg) + (spaceBound tm (base + steps)) ∧ + Represents tm halted final ∧ + StepEnvelope tm (base + steps) final := by + induction hreach generalizing store base with + | zero => + have hzero : store (valueReg n) = 0 := by + rw [hflag] + simp [runningFlag, hhalted] + have hrun := Structured.Internal.MeasuredRuns.whileZeroEnvelope + (body := loopBody tm) hzero henvelope + refine ⟨store, ?_, hrepresents, henvelope⟩ + simpa [loopSteps, loopTimeBound, wordWidth, spaceBound, + Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using hrun + | @step current successor tail finalCfg hstep htail ih => + have hnotHalted := TM.state_ne_qhalt_of_step hstep + have hnonzero : store (valueReg n) β‰  0 := by + rw [hflag] + simp [runningFlag, hnotHalted] + let bound := base + tail + 1 + have hheadsBound : HeadsBounded current bound := + headsBounded_mono hheads (by simp [bound]; omega) + obtain ⟨middle, hprogram, hmiddleRepresents, hmiddleEnvelope⟩ := + program_measured_internal (bound := bound) hstep hrepresents + hheadsBound hworkStart houtputStart (by + simpa [bound, Nat.add_assoc] using henvelope) + have hsuccessorHeads : HeadsBounded successor (base + 1) := + headsBounded_step_internal hstep hheads + have hsuccessorHeadsBound : HeadsBounded successor bound := + headsBounded_mono hsuccessorHeads (by simp [bound]) + obtain ⟨checked, hcheck, hcheckedRepresents, hcheckedFlag, + _hcheckedOne, _hcheckedCount, hcheckedEnvelope⟩ := + continueCheck_measured_internal (bound := bound) hmiddleRepresents + hsuccessorHeadsBound hmiddleEnvelope + have hstarts := starts_of_step_internal hstep hworkStart houtputStart + have hboundEq : (base + 1) + tail = bound := by + simp [bound] + omega + obtain ⟨final, hloop, hfinalRepresents, hfinalEnvelope⟩ := + ih (base := base + 1) hhalted hcheckedRepresents hcheckedFlag + hsuccessorHeads hstarts.1 hstarts.2 (by + rw [hboundEq] + exact hcheckedEnvelope) + rw [hboundEq] at hloop hfinalEnvelope + have hbody := hprogram.seq hcheck + have hloop' : Structured.Internal.MeasuredRuns + (.whileNonzero (valueReg n) (loopBody tm)) checked final + (loopSteps tm tail successor) + (loopTimeBound tm (base + 1) tail successor) + (spaceBound tm bound) := by + exact hloop + have hbody' : Structured.Internal.MeasuredRuns (loopBody tm) store checked + (stepCount tm current + continueSteps tm successor) + (timeBound tm bound current + continueTimeBound tm bound successor) + (spaceBound tm bound) := by + simpa [loopBody] using hbody + have hrun := Structured.Internal.MeasuredRuns.whileNonzeroEnvelope + hnonzero (by simpa [bound, Nat.add_assoc] using! henvelope) hbody' hloop' + refine ⟨final, ?_, hfinalRepresents, ?_⟩ + Β· simpa [loopSteps, loopTimeBound, hstep, bound, wordWidth, + Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace, Nat.add_assoc] using hrun + Β· simpa [bound, Nat.add_assoc] using hfinalEnvelope + +theorem runUntilHalt_measured_internal {tm : TM n} {steps base : β„•} + {cfg halted : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hreach : tm.reachesIn steps cfg halted) + (hhalted : tm.halted halted) + (hrepresents : Represents tm cfg store) + (hheads : HeadsBounded cfg base) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (henvelope : StepEnvelope tm (base + steps) store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (runUntilHalt tm) store final + (runSteps tm steps cfg) (runTimeBound tm base steps cfg) + (spaceBound tm (base + steps)) ∧ + Represents tm halted final ∧ + StepEnvelope tm (base + steps) final := by + have hheadsBound : HeadsBounded cfg (base + steps) := + headsBounded_mono hheads (by omega) + obtain ⟨checked, hcheck, hcheckedRepresents, hcheckedFlag, + _hcheckedOne, _hcheckedCount, hcheckedEnvelope⟩ := + continueCheck_measured_internal (bound := base + steps) hrepresents + hheadsBound henvelope + obtain ⟨final, hloop, hfinalRepresents, hfinalEnvelope⟩ := + loop_measured_internal hreach hhalted hcheckedRepresents hcheckedFlag + hheads hworkStart houtputStart hcheckedEnvelope + have hrun := hcheck.seq hloop + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [runUntilHalt, runSteps, runTimeBound] using hrun + +private theorem dispatchCost_eq_factor (tm : TM n) (bound : β„•) + (state : tm.Q) (actual : Fin (n + 2) β†’ Ξ“) + (remaining : List (Fin (n + 2))) : + dispatchCost tm bound state actual remaining = + dispatchFactor tm state actual remaining * wordWidth tm bound := by + induction remaining with + | nil => simp [dispatchCost, dispatchFactor] + | cons tape rest ih => + simp [dispatchCost, dispatchFactor, Structured.Switch.costBound, ih] + ring + +theorem timeBound_le_stepFactor_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : + timeBound tm bound cfg ≀ stepFactor tm * wordWidth tm bound := by + have hfactor : 7 * stateCode tm cfg.state + 1 + + dispatchFactor tm cfg.state (readSymbols cfg) + (List.finRange (n + 2)) ≀ + Finset.univ.sup fun state : tm.Q => + Finset.univ.sup fun actual : Fin (n + 2) β†’ Ξ“ => + 7 * stateCode tm state + 1 + + dispatchFactor tm state actual (List.finRange (n + 2)) := by + apply le_trans + (Finset.le_sup + (f := fun actual : Fin (n + 2) β†’ Ξ“ => + 7 * stateCode tm cfg.state + 1 + + dispatchFactor tm cfg.state actual (List.finRange (n + 2))) + (Finset.mem_univ (readSymbols cfg))) + exact Finset.le_sup + (f := fun state : tm.Q => + Finset.univ.sup fun actual : Fin (n + 2) β†’ Ξ“ => + 7 * stateCode tm state + 1 + + dispatchFactor tm state actual (List.finRange (n + 2))) + (Finset.mem_univ cfg.state) + rw [timeBound, dispatchCost_eq_factor] + simp only [Structured.Switch.costBound] + calc + 4 * (loadOps n).length * wordWidth tm bound + + ((7 * stateCode tm cfg.state + 1) * wordWidth tm bound + + dispatchFactor tm cfg.state (readSymbols cfg) + (List.finRange (n + 2)) * wordWidth tm bound) + = (4 * (loadOps n).length + + (7 * stateCode tm cfg.state + 1 + + dispatchFactor tm cfg.state (readSymbols cfg) + (List.finRange (n + 2)))) * wordWidth tm bound := by ring + _ ≀ (4 * (loadOps n).length + + Finset.univ.sup fun state : tm.Q => + Finset.univ.sup fun actual : Fin (n + 2) β†’ Ξ“ => + 7 * stateCode tm state + 1 + + dispatchFactor tm state actual (List.finRange (n + 2))) * + wordWidth tm bound := Nat.mul_le_mul_right _ + (Nat.add_le_add_left hfactor _) + _ = stepFactor tm * wordWidth tm bound := by rfl + +theorem continueTimeBound_le_factor_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : + continueTimeBound tm bound cfg ≀ + continueFactor tm * wordWidth tm bound := by + have hstate : stateCode tm cfg.state < Fintype.card tm.Q := by + simp [stateCode] + simp only [continueTimeBound, Structured.Switch.costBound, continueFactor] + calc + 4 * (loadOps n).length * wordWidth tm bound + + ((7 * stateCode tm cfg.state + 1) * wordWidth tm bound + + 4 * wordWidth tm bound) + = (4 * (loadOps n).length + + (7 * stateCode tm cfg.state + 5)) * wordWidth tm bound := by ring + _ ≀ (4 * (loadOps n).length + + (7 * Fintype.card tm.Q + 5)) * wordWidth tm bound := by + apply Nat.mul_le_mul_right + omega + +theorem loopTimeBound_le_linear_internal (tm : TM n) (base steps : β„•) + (cfg : Complexity.Cfg n tm.Q) : + loopTimeBound tm base steps cfg ≀ + (steps * iterationFactor tm + 1) * wordWidth tm (base + steps) := by + induction steps generalizing base cfg with + | zero => simp [loopTimeBound] + | succ steps ih => + rw [loopTimeBound] + split + Β· exact Nat.zero_le _ + Β· rename_i next hstep + have hstepBound := timeBound_le_stepFactor_internal tm + (base + steps + 1) cfg + have hcheckBound := continueTimeBound_le_factor_internal tm + (base + steps + 1) next + have htail := ih (base := base + 1) (cfg := next) + have hwidth : wordWidth tm ((base + 1) + steps) = + wordWidth tm (base + (steps + 1)) := by + congr 1 + omega + rw [hwidth] at htail + have hboundWidth : wordWidth tm (base + steps + 1) = + wordWidth tm (base + (steps + 1)) := by + congr 1 + rw [hboundWidth] at hstepBound hcheckBound + calc + 3 * wordWidth tm (base + steps + 1) + + timeBound tm (base + steps + 1) cfg + + continueTimeBound tm (base + steps + 1) next + + loopTimeBound tm (base + 1) steps next + ≀ 3 * wordWidth tm (base + (steps + 1)) + + stepFactor tm * wordWidth tm (base + (steps + 1)) + + continueFactor tm * wordWidth tm (base + (steps + 1)) + + (steps * iterationFactor tm + 1) * + wordWidth tm (base + (steps + 1)) := by + rw [hboundWidth] + omega + _ = ((steps + 1) * iterationFactor tm + 1) * + wordWidth tm (base + (steps + 1)) := by + simp [iterationFactor] + ring + +theorem runTimeBound_le_linear_internal (tm : TM n) (base steps : β„•) + (cfg : Complexity.Cfg n tm.Q) : + runTimeBound tm base steps cfg ≀ + ((steps + 1) * runFactor tm) * wordWidth tm (base + steps) := by + have hcheck := continueTimeBound_le_factor_internal tm (base + steps) cfg + have hloop := loopTimeBound_le_linear_internal tm base steps cfg + rw [runTimeBound] + calc + continueTimeBound tm (base + steps) cfg + loopTimeBound tm base steps cfg + ≀ continueFactor tm * wordWidth tm (base + steps) + + (steps * iterationFactor tm + 1) * + wordWidth tm (base + steps) := Nat.add_le_add hcheck hloop + _ ≀ ((steps + 1) * runFactor tm) * wordWidth tm (base + steps) := by + have hc : continueFactor tm ≀ (steps + 1) * continueFactor tm := by + simpa only [one_mul] using + Nat.mul_le_mul_right (continueFactor tm) (show 1 ≀ steps + 1 by omega) + have hi : steps * iterationFactor tm ≀ + (steps + 1) * iterationFactor tm := + Nat.mul_le_mul_right (iterationFactor tm) (Nat.le_succ steps) + have hone : 1 ≀ steps + 1 := by omega + rw [show continueFactor tm * wordWidth tm (base + steps) + + (steps * iterationFactor tm + 1) * wordWidth tm (base + steps) = + (continueFactor tm + steps * iterationFactor tm + 1) * + wordWidth tm (base + steps) by ring] + apply Nat.mul_le_mul_right + simp only [runFactor] + calc + continueFactor tm + steps * iterationFactor tm + 1 + ≀ (steps + 1) * continueFactor tm + + (steps + 1) * iterationFactor tm + (steps + 1) := by omega + _ = (steps + 1) * + (continueFactor tm + iterationFactor tm + 1) := by ring + +end Sparse + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step.lean new file mode 100644 index 0000000000..af4961b86f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Fixed RAM transition blocks for bounded Turing-machine configurations + +The public layer exposes the exact register layout, verified loading and action +phases, and the composed nested state/symbol dispatcher. Thus the fixed +structured program has exact one-step source semantics; its common resource +envelope and compiled-RAM transfer are the next M6 layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} + +namespace Step + + +/-- Every alphabet symbol is a valid four-way dispatch code. -/ +theorem symbolCode_lt (symbol : Ξ“) : symbolCode symbol < 4 := + symbolCode_lt_internal symbol + +/-- Dispatching on an encoded alphabet symbol recovers that symbol. -/ +theorem symbolAt_code (symbol : Ξ“) : + symbolAt ⟨symbolCode symbol, symbolCode_lt symbol⟩ = symbol := + symbolAt_code_internal symbol + +/-- Every canonical state code is valid for the machine's finite state count. -/ +theorem stateCode_lt (tm : TM n) (state : tm.Q) : + stateCode tm state < Fintype.card tm.Q := + stateCode_lt_internal tm state + +/-- The arithmetic head address agrees with the configuration-field layout. -/ +theorem headReg_eq_fieldReg (tape : Fin (n + 2)) : + headReg tape = fieldReg (headField (bound := bound) tape) := + headReg_eq_fieldReg_internal tape + +/-- A tape-block base plus an in-window position agrees with the corresponding +configuration-field address. -/ +theorem cellBase_add_eq_fieldReg (tape : Fin (n + 2)) + (position : Fin (bound + 1)) : + cellBase n bound tape + position.val = fieldReg (cellField tape position) := + cellBase_add_eq_fieldReg_internal tape position + +/-- The canonical register encoding fits the one-step program's explicit store +envelope whenever all represented heads lie in the chosen window. -/ +theorem encodeRegs_storeBounded (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (hheads : HeadsBounded cfg bound) : + StoreBounded tm bound (encodeRegs tm bound cfg) := + encodeRegs_storeBounded_internal tm bound cfg hheads + +/-- The generated load block preserves the represented configuration and loads +the state and every symbol needed by the finite transition dispatcher. -/ +theorem loadOps_correct {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) : + let final := Structured.Basic.execList (loadOps n bound) store + Represents tm bound cfg final ∧ + final (zeroReg n bound) = 0 ∧ + final (oneReg n bound) = 1 ∧ + final (stateScratchReg n bound) = stateCode tm cfg.state ∧ + βˆ€ tape, final (symbolReg n bound tape) = + symbolCode (readSymbols cfg tape) := + loadOps_loaded_internal hrepresents hheads + +/-- Once the state and head symbols select a concrete transition, its generated +straight-line action maps any represented configuration to the exact TM +successor. The assumptions are precisely those needed by the bounded tape +layout: all heads are in range, writable tapes retain the left-end marker, and +the loading phase has initialized the constant-one scratch register. -/ +theorem actionOps_correct {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) : + Represents tm bound next + (Structured.Basic.execList + (actionOps tm bound cfg.state (readSymbols cfg)) store) := + actionOps_represents_internal hstep hrepresents hheads hworkStart + houtputStart hone + +/-- The complete fixed structured program performs exactly one nonhalting TM +transition. The source execution has the advertised exact instruction count and +its final store represents the successor configuration. -/ +theorem program_correct {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (program tm bound) store final + (stepCount tm bound cfg) cost space ∧ + Represents tm bound next final := + program_exec_internal hstep hrepresents hwindow + (fun i => (hworkStart i).1) houtputStart.1 + +/-- If the successor also fits the chosen cell window, decoding the complete +program's final store returns that successor exactly. -/ +theorem program_decodes {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hnextBounded : Bounded next bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + βˆƒ final cost space, + Structured.Exec (program tm bound) store final + (stepCount tm bound cfg) cost space ∧ + decode tm bound final = next := by + obtain ⟨final, cost, space, hexec, hfinal⟩ := + program_correct hstep hrepresents hwindow hworkStart houtputStart + exact ⟨final, cost, space, hexec, + decode_of_represents tm bound next final hfinal hnextBounded⟩ + +/-- The complete one-step source block satisfies its exact transition count, +explicit logarithmic-cost bound, and peak-space bound while preserving both the +successor representation and the store envelope needed for composition. -/ +theorem program_performance {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) + (hstore : StoreBounded tm bound store) : + βˆƒ final cost space, + Structured.Exec (program tm bound) store final + (stepCount tm bound cfg) cost space ∧ + cost ≀ timeBound tm bound cfg ∧ space ≀ spaceBound tm bound ∧ + Represents tm bound next final ∧ StoreBounded tm bound final := by + let henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store := + ⟨hstore.1, hstore.2⟩ + obtain ⟨final, hrun, hfinalRepresents, hfinalEnvelope⟩ := + program_measured_internal hstep hrepresents hwindow + (fun i => (hworkStart i).1) houtputStart.1 henvelope + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hrun + exact ⟨final, cost, space, hexec, hcost, hspace, hfinalRepresents, + hfinalEnvelope.index_lt, hfinalEnvelope.value_le⟩ + +/-- End-to-end transfer of the measured source theorem to the concrete compiled +RAM block. After the exact step count, the RAM is stopped at the compiler's +terminal halt instruction with the successor represented in its registers. -/ +theorem compiled_correct {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) + (hstore : StoreBounded tm bound store) : + βˆƒ final cost space, + Structured.Exec (program tm bound) store final + (stepCount tm bound cfg) cost space ∧ + run (compiled tm bound) (stepCount tm bound cfg) { pc := 0, regs := store } = + { pc := (program tm bound).codeSize, regs := final } ∧ + Halted (compiled tm bound) + (run (compiled tm bound) (stepCount tm bound cfg) { pc := 0, regs := store }) ∧ + logTimeUpto (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := store } ≀ timeBound tm bound cfg ∧ + spaceUpto (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := store } ≀ spaceBound tm bound ∧ + Represents tm bound next final ∧ StoreBounded tm bound final := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hfinal, hfinalStore⟩ := + program_performance hstep hrepresents hwindow hworkStart houtputStart hstore + have hcompiled := Structured.Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, ?_, ?_, ?_, ?_, hfinal, hfinalStore⟩ + Β· simpa [compiled] using hcompiled.1 + Β· simpa [compiled] using Structured.Exec.compile_halted hexec + Β· change logTimeUpto (program tm bound).compile (stepCount tm bound cfg) + { pc := 0, regs := store } ≀ timeBound tm bound cfg + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto (program tm bound).compile (stepCount tm bound cfg) + { pc := 0, regs := store } ≀ spaceBound tm bound + rw [hcompiled.2.2] + exact hspace + +/-- The canonical encoded configuration therefore runs through the concrete +compiled block and decodes to the exact TM successor. -/ +theorem compiled_encode_decodes {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} + (hstep : tm.step cfg = some next) + (hwindow : WithinWindow cfg bound) + (hnextBounded : Bounded next bound) + (hworkStart : βˆ€ i, (cfg.work i).StartInvariant) + (houtputStart : cfg.output.StartInvariant) : + let initial := encodeRegs tm bound cfg + βˆƒ final cost space, + Structured.Exec (program tm bound) initial final + (stepCount tm bound cfg) cost space ∧ + run (compiled tm bound) (stepCount tm bound cfg) { pc := 0, regs := initial } = + { pc := (program tm bound).codeSize, regs := final } ∧ + Halted (compiled tm bound) + (run (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := initial }) ∧ + logTimeUpto (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := initial } ≀ timeBound tm bound cfg ∧ + spaceUpto (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := initial } ≀ spaceBound tm bound ∧ + decode tm bound + (run (compiled tm bound) (stepCount tm bound cfg) + { pc := 0, regs := initial }).regs = next := by + let initial := encodeRegs tm bound cfg + obtain ⟨final, cost, space, hexec, hrun, hhalted, htime, hspace, + hfinal, _hfinalStore⟩ := compiled_correct hstep + (encodeRegs_represents tm bound cfg) hwindow hworkStart houtputStart + (encodeRegs_storeBounded tm bound cfg hwindow.2) + refine ⟨final, cost, space, hexec, hrun, hhalted, htime, hspace, ?_⟩ + rw [hrun] + exact decode_of_represents tm bound next final hfinal hnextBounded + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Defs.lean new file mode 100644 index 0000000000..4183aec0b9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Defs.lean @@ -0,0 +1,228 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs + +/-! +# A fixed structured-RAM block for one Turing-machine transition + +The finite transition function is compiled as a decision tree. The program +first loads the symbols under all named heads, dispatches on the finite-state +code and the `n + 2` four-symbol codes, then performs the selected transition +using indirect stores into the bounded tape blocks. + +The construction is fixed once `tm` and the cell-window bound are fixed. It +does not install or consult an untrusted transition-table oracle. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Step + + +/-- Input tape index. -/ +def inputTape (n : β„•) : Fin (n + 2) := ⟨0, by omega⟩ + +/-- Work-tape index in the named input/work/output order. -/ +def workTape (i : Fin n) : Fin (n + 2) := ⟨i.val + 1, by omega⟩ + +/-- Output tape index. -/ +def outputTape (n : β„•) : Fin (n + 2) := ⟨n + 1, by omega⟩ + +/-- Direct head register for one named tape. -/ +def headReg (tape : Fin (n + 2)) : β„• := 1 + tape.val + +/-- First cell register of one named tape's bounded block. -/ +def cellBase (n bound : β„•) (tape : Fin (n + 2)) : β„• := + 1 + (n + 2) + tape.val * (bound + 1) + +/-- First scratch register beyond the represented configuration. -/ +def scratchBase (n bound : β„•) : β„• := registerCount n bound + +/-- Constant-zero scratch register. -/ +def zeroReg (n bound : β„•) : β„• := scratchBase n bound + +/-- Constant-one scratch register used by decrementing switches and head moves. -/ +def oneReg (n bound : β„•) : β„• := scratchBase n bound + 1 + +/-- Destructive copy of the finite-state code used by the outer switch. -/ +def stateScratchReg (n bound : β„•) : β„• := scratchBase n bound + 2 + +/-- Scratch register holding an indirect cell address. -/ +def addressReg (n bound : β„•) : β„• := scratchBase n bound + 3 + +/-- Scratch register holding a writable symbol code. -/ +def valueReg (n bound : β„•) : β„• := scratchBase n bound + 4 + +/-- Scratch register holding the symbol loaded under one named head. -/ +def symbolReg (n bound : β„•) (tape : Fin (n + 2)) : β„• := + scratchBase n bound + 5 + tape.val + +/-- Exclusive upper bound on every configuration and scratch register. -/ +def registerLimit (n bound : β„•) : β„• := scratchBase n bound + n + 7 + +/-- A uniform value bound large enough for addresses, states, symbols, and a +single rightward head move. -/ +def wordBound (tm : TM n) (bound : β„•) : β„• := + max (registerLimit n bound) (max (Fintype.card tm.Q) (bound + 1)) + +/-- One-bit-cushioned width used in logarithmic-cost bounds. -/ +def wordWidth (tm : TM n) (bound : β„•) : β„• := + bitlen (wordBound tm bound) + 1 + +/-- Peak-space envelope for one transition block. -/ +def spaceBound (tm : TM n) (bound : β„•) : β„• := + registerLimit n bound * + (bitlen (registerLimit n bound) + bitlen (wordBound tm bound)) + +/-- A store fits the explicit register/value envelope used by one transition +block. This public predicate states the concrete boundary directly without +exposing the internal resource-certificate structure. -/ +def StoreBounded (tm : TM n) (bound : β„•) (store : Structured.Store) : Prop := + (βˆ€ reg, store reg β‰  0 β†’ reg < registerLimit n bound) ∧ + βˆ€ reg, store reg ≀ wordBound tm bound + +/-- Decode one valid four-way switch branch as a tape symbol. -/ +def symbolAt (code : Fin 4) : Ξ“ := symbolDecode code.val + +/-- Symbols currently read by all named TM heads. -/ +def readSymbols (cfg : Complexity.Cfg n Q) : Fin (n + 2) β†’ Ξ“ := + fun tape => (tapeAt cfg tape).read + +/-- Load the symbol under one represented head into its dedicated scratch +register. -/ +def loadTapeOps (n bound : β„•) (tape : Fin (n + 2)) : List Structured.Basic := + [.imm (addressReg n bound) (cellBase n bound tape), + .add (addressReg n bound) (addressReg n bound) (headReg tape), + .load (symbolReg n bound tape) (addressReg n bound)] + +/-- Initialize constants and copy the represented finite-state code. -/ +def setupOps (n bound : β„•) : List Structured.Basic := + [.imm (zeroReg n bound) 0, + .imm (oneReg n bound) 1, + .add (stateScratchReg n bound) 0 (zeroReg n bound)] + +/-- Initialize scratch state and load every represented head symbol. -/ +def loadOps (n bound : β„•) : List Structured.Basic := + setupOps n bound ++ + (List.finRange (n + 2)).flatMap (loadTapeOps n bound) + +/-- Encode a writable tape symbol with the same zero-blank convention as the +configuration representation. -/ +def writeCode (symbol : Ξ“w) : β„• := symbolCode symbol.toΞ“ + +/-- Update a represented head in the indicated direction. -/ +def moveOps (n bound : β„•) (tape : Fin (n + 2)) : Dir3 β†’ List Structured.Basic + | .left => [.sub (headReg tape) (headReg tape) (oneReg n bound)] + | .right => [.add (headReg tape) (headReg tape) (oneReg n bound)] + | .stay => [] + +/-- Write one represented work/output tape and restore the left-end marker. -/ +def writeOps (n bound : β„•) (tape : Fin (n + 2)) + (write : Ξ“w) : List Structured.Basic := + [.imm (addressReg n bound) (cellBase n bound tape), + .add (addressReg n bound) (addressReg n bound) (headReg tape), + .imm (valueReg n bound) (writeCode write), + .store (addressReg n bound) (valueReg n bound), + .imm (cellBase n bound tape) (symbolCode Ξ“.start)] + +/-- Write one represented work/output tape and move its head. + +The direct write restoring cell zero to `β–·` makes this branch-free while +matching `Tape.write`, whose write at head zero is a no-op. -/ +def writeMoveOps (n bound : β„•) (tape : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) : List Structured.Basic := + writeOps n bound tape write ++ moveOps n bound tape direction + +/-- Straight-line register operations implementing a statically selected TM +transition case. -/ +noncomputable def actionOps (tm : TM n) (bound : β„•) (state : tm.Q) + (symbols : Fin (n + 2) β†’ Ξ“) : List Structured.Basic := + match tm.Ξ΄ state (symbols (inputTape n)) + (fun i => symbols (workTape i)) (symbols (outputTape n)) with + | (nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection) => + [.imm 0 (stateCode tm nextState)] ++ + moveOps n bound (inputTape n) inputDirection ++ + (List.finRange n).flatMap (fun i => + writeMoveOps n bound (workTape i) (workWrites i) (workDirections i)) ++ + writeMoveOps n bound (outputTape n) outputWrite outputDirection + +/-- Structured command for one statically selected transition case. -/ +noncomputable def action (tm : TM n) (bound : β„•) (state : tm.Q) + (symbols : Fin (n + 2) β†’ Ξ“) : Structured.Cmd := + Structured.Cmd.basics (actionOps tm bound state symbols) + +/-- Recursively dispatch on the loaded symbols for the listed named tapes. -/ +noncomputable def dispatchSymbols (tm : TM n) (bound : β„•) (state : tm.Q) : + List (Fin (n + 2)) β†’ (Fin (n + 2) β†’ Ξ“) β†’ Structured.Cmd + | [], symbols => action tm bound state symbols + | tape :: rest, symbols => + Structured.Switch.select 4 (symbolReg n bound tape) (oneReg n bound) + (fun code => dispatchSymbols tm bound state rest + (Function.update symbols tape (symbolAt code))) + +/-- Dispatch on the finite-state code, then on every loaded tape symbol. -/ +noncomputable def dispatchState (tm : TM n) (bound : β„•) : Structured.Cmd := + Structured.Switch.select (Fintype.card tm.Q) (stateScratchReg n bound) + (oneReg n bound) (fun stateCode => + dispatchSymbols tm bound ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + +/-- Fixed structured-RAM program implementing one nonhalting TM transition. -/ +noncomputable def program (tm : TM n) (bound : β„•) : Structured.Cmd := + .seq (.basics (loadOps n bound)) (dispatchState tm bound) + +/-- Concrete compiled RAM block for one nonhalting TM transition. -/ +noncomputable def compiled (tm : TM n) (bound : β„•) : Program := + (program tm bound).compile + +/-- Exact transition count through symbol dispatch for the actually read case. -/ +noncomputable def dispatchSteps (tm : TM n) (bound : β„•) (state : tm.Q) + (actual : Fin (n + 2) β†’ Ξ“) : List (Fin (n + 2)) β†’ β„• + | [] => (actionOps tm bound state actual).length + | tape :: rest => Structured.Switch.stepCount (symbolCode (actual tape)) + (dispatchSteps tm bound state actual rest) + +/-- Exact source/compiled transition count for one represented TM step. -/ +noncomputable def stepCount (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + (loadOps n bound).length + + Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) + +/-- Logarithmic-cost bound through symbol dispatch. -/ +noncomputable def dispatchCost (tm : TM n) (bound : β„•) (state : tm.Q) + (actual : Fin (n + 2) β†’ Ξ“) : List (Fin (n + 2)) β†’ β„• + | [] => 4 * (actionOps tm bound state actual).length * wordWidth tm bound + | tape :: rest => Structured.Switch.costBound (symbolCode (actual tape)) + (dispatchCost tm bound state actual rest) (wordWidth tm bound) + +/-- Explicit logarithmic-cost bound for one represented TM step. -/ +noncomputable def timeBound (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) : β„• := + 4 * (loadOps n bound).length * wordWidth tm bound + + Structured.Switch.costBound (stateCode tm cfg.state) + (dispatchCost tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) (wordWidth tm bound) + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal.lean new file mode 100644 index 0000000000..87e6d1ebdf --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Dispatch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Resources + +/-! +# One-step TM-to-RAM simulation -- proof internals + +This aggregation module contains the checked layout, head-symbol loading, +selected transition-action, nested finite-dispatch, and source-resource layers. +The public surface transfers the resulting measured execution to compiled RAM. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Action.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Action.lean new file mode 100644 index 0000000000..7fe088c4ba --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Action.lean @@ -0,0 +1,1183 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources + +/-! +# Selected TM transition actions -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} + +namespace Step + + +private theorem execList_append (first second : List Structured.Basic) + (store : Structured.Store) : + Structured.Basic.execList (first ++ second) store = + Structured.Basic.execList second (Structured.Basic.execList first store) := by + induction first generalizing store with + | nil => rfl + | cons op rest ih => simp [Structured.Basic.execList, ih] + +/-- Representation restricted to one named tape block. -/ +private def RepresentsTape (bound : β„•) (slot : Fin (n + 2)) + (tape : Tape) (store : Structured.Store) : Prop := + store (headReg slot) = tape.head ∧ + βˆ€ position : Fin (bound + 1), + store (cellBase n bound slot + position.val) = + symbolCode (tape.cells position.val) + +private theorem Represents.tape {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) (slot : Fin (n + 2)) : + RepresentsTape bound slot (tapeAt cfg slot) store := by + constructor + Β· have hhead := hrepresents (headField (bound := bound) slot) + rwa [← headReg_eq_fieldReg_internal] at hhead + Β· intro position + have hcell := hrepresents (cellField slot position) + rwa [← cellBase_add_eq_fieldReg_internal] at hcell + +private theorem configReg_ne_address {n bound reg : β„•} + (hreg : reg < registerCount n bound) : reg β‰  addressReg n bound := + fun heq => not_lt_of_ge (addressReg_ge_internal n bound) (heq β–Έ hreg) + +private theorem configReg_ne_value {n bound reg : β„•} + (hreg : reg < registerCount n bound) : reg β‰  valueReg n bound := + fun heq => not_lt_of_ge (valueReg_ge_internal n bound) (heq β–Έ hreg) + +/-- On configuration registers, the concrete write block is exactly an update +at the represented head followed by restoration of cell zero. -/ +private theorem writeOps_apply (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (store : Structured.Store) {reg : β„•} + (hregAddress : reg β‰  addressReg n bound) + (hregValue : reg β‰  valueReg n bound) : + Structured.Basic.execList (writeOps n bound slot write) store reg = + Function.update + (Function.update store + (cellBase n bound slot + store (headReg slot)) (writeCode write)) + (cellBase n bound slot) (symbolCode Ξ“.start) reg := by + let first := + (Structured.Basic.imm (addressReg n bound) (cellBase n bound slot)).exec store + let addressed := + (Structured.Basic.add (addressReg n bound) (addressReg n bound) + (headReg slot)).exec first + let valued := (Structured.Basic.imm (valueReg n bound) (writeCode write)).exec addressed + have haddressHead : addressReg n bound β‰  headReg slot := by + intro heq + have hfield := fieldReg_lt_internal (headField (bound := bound) slot) + rw [← headReg_eq_fieldReg_internal] at hfield + have hscratch := addressReg_ge_internal n bound + omega + have haddressValue : addressReg n bound β‰  valueReg n bound := by + simp [addressReg, valueReg] + have hfirstAddress : first (addressReg n bound) = cellBase n bound slot := by + simp [first, Structured.Basic.exec] + have hfirstHead : first (headReg slot) = store (headReg slot) := by + simp [first, Structured.Basic.exec, Function.update_of_ne (Ne.symm haddressHead)] + have haddressedAddress : + addressed (addressReg n bound) = + cellBase n bound slot + store (headReg slot) := by + simp only [addressed, Structured.Basic.exec, Function.update_self] + rw [hfirstAddress, hfirstHead] + have hvaluedAddress : + valued (addressReg n bound) = + cellBase n bound slot + store (headReg slot) := by + simp only [valued, Structured.Basic.exec] + rw [Function.update_of_ne haddressValue, haddressedAddress] + have hvaluedValue : valued (valueReg n bound) = writeCode write := by + simp [valued, Structured.Basic.exec] + have hvaluedConfig : valued reg = store reg := by + simp [valued, addressed, first, Structured.Basic.exec, + Function.update_of_ne hregAddress, Function.update_of_ne hregValue] + simp only [writeOps, Structured.Basic.execList] + change Function.update + (Function.update valued (valued (addressReg n bound)) + (valued (valueReg n bound))) + (cellBase n bound slot) (symbolCode Ξ“.start) reg = _ + rw [hvaluedAddress, hvaluedValue] + by_cases hzero : reg = cellBase n bound slot + Β· subst reg + rw [Function.update_self, Function.update_self] + Β· by_cases htarget : reg = cellBase n bound slot + store (headReg slot) + Β· rw [Function.update_of_ne hzero, Function.update_of_ne hzero] + subst reg + rw [Function.update_self, Function.update_self] + Β· rw [Function.update_of_ne hzero, Function.update_of_ne hzero, + Function.update_of_ne htarget, Function.update_of_ne htarget] + exact hvaluedConfig + +private theorem headReg_ne_cellReg (headSlot cellSlot : Fin (n + 2)) + (position : Fin (bound + 1)) : + headReg headSlot β‰  cellBase n bound cellSlot + position.val := by + intro heq + rw [headReg_eq_fieldReg_internal, + cellBase_add_eq_fieldReg_internal] at heq + have hfield := fieldReg_injective_internal heq + cases hfield + +private theorem cellReg_ne_cellReg_of_slot_ne {first second : Fin (n + 2)} + (hne : first β‰  second) (firstPosition secondPosition : Fin (bound + 1)) : + cellBase n bound first + firstPosition.val β‰  + cellBase n bound second + secondPosition.val := by + intro heq + rw [cellBase_add_eq_fieldReg_internal, + cellBase_add_eq_fieldReg_internal] at heq + have hfield := fieldReg_injective_internal heq + change Sum.inr (Sum.inr (first, firstPosition)) = + Sum.inr (Sum.inr (second, secondPosition)) at hfield + have hpairs := Sum.inr.inj (Sum.inr.inj hfield) + exact hne (congrArg Prod.fst hpairs) + +private theorem writeOps_head (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (store : Structured.Store) : + Structured.Basic.execList (writeOps n bound slot write) store (headReg slot) = + store (headReg slot) := by + have hreg : headReg slot < registerCount n bound := by + rw [headReg_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + rw [writeOps_apply n bound slot write store + (configReg_ne_address hreg) (configReg_ne_value hreg)] + have hzero : headReg slot β‰  cellBase n bound slot := by + simp [headReg, cellBase] + omega + have htarget : + headReg slot β‰  cellBase n bound slot + store (headReg slot) := by + simp [headReg, cellBase] + omega + rw [Function.update_of_ne hzero, Function.update_of_ne htarget] + +private theorem writeOps_cells (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (tape : Tape) (store : Structured.Store) + (hrepresents : RepresentsTape bound slot tape store) + (hstart : tape.cells 0 = Ξ“.start) + (position : Fin (bound + 1)) : + Structured.Basic.execList (writeOps n bound slot write) store + (cellBase n bound slot + position.val) = + symbolCode ((tape.write write.toΞ“).cells position.val) := by + have hstoreHead : store (headReg slot) = tape.head := hrepresents.1 + have hstoreCell := hrepresents.2 position + have hreg : cellBase n bound slot + position.val < registerCount n bound := by + rw [cellBase_add_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + rw [writeOps_apply n bound slot write store + (configReg_ne_address hreg) (configReg_ne_value hreg)] + rw [hstoreHead] + by_cases hheadZero : tape.head = 0 + Β· rw [Tape.write, ite_eq_left hheadZero] + by_cases hpositionZero : position.val = 0 + Β· rw [hheadZero, hpositionZero, Nat.add_zero, Function.update_self, hstart] + Β· have htarget : + cellBase n bound slot + position.val β‰  cellBase n bound slot + tape.head := by + omega + have hbase : + cellBase n bound slot + position.val β‰  cellBase n bound slot := by + omega + rw [Function.update_of_ne hbase, Function.update_of_ne htarget, hstoreCell] + Β· rw [Tape.write, ite_eq_right hheadZero] + change Function.update + (Function.update store (cellBase n bound slot + tape.head) (writeCode write)) + (cellBase n bound slot) (symbolCode Ξ“.start) + (cellBase n bound slot + position.val) = + symbolCode (Function.update tape.cells tape.head write.toΞ“ position.val) + by_cases hpositionHead : position.val = tape.head + Β· have hpositionZero : position.val β‰  0 := by omega + have hbase : + cellBase n bound slot + position.val β‰  cellBase n bound slot := by + omega + rw [Function.update_of_ne hbase] + have htarget : + cellBase n bound slot + position.val = cellBase n bound slot + tape.head := by + omega + rw [htarget, Function.update_self, hpositionHead, Function.update_self] + rfl + Β· by_cases hpositionZero : position.val = 0 + Β· rw [hpositionZero, Nat.add_zero, Function.update_self, + Function.update_of_ne (Ne.symm hheadZero), hstart] + Β· have htarget : + cellBase n bound slot + position.val β‰  cellBase n bound slot + tape.head := by + omega + have hbase : + cellBase n bound slot + position.val β‰  cellBase n bound slot := by + omega + rw [Function.update_of_ne hbase, Function.update_of_ne htarget, + Function.update_of_ne hpositionHead, hstoreCell] + +private theorem writeOps_tape (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (tape : Tape) (store : Structured.Store) + (hrepresents : RepresentsTape bound slot tape store) + (hstart : tape.cells 0 = Ξ“.start) : + RepresentsTape bound slot (tape.write write.toΞ“) + (Structured.Basic.execList (writeOps n bound slot write) store) := by + constructor + Β· rw [Tape.write_head] + exact (writeOps_head n bound slot write store).trans + hrepresents.1 + Β· exact writeOps_cells n bound slot write tape store hrepresents hstart + +private theorem moveOps_apply_of_ne (n bound : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (store : Structured.Store) {reg : β„•} + (hne : reg β‰  headReg slot) : + Structured.Basic.execList (moveOps n bound slot direction) store reg = store reg := by + cases direction <;> + simp [moveOps, Structured.Basic.execList, Structured.Basic.exec, + Function.update_of_ne hne] + +private theorem moveOps_tape (n bound : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (tape : Tape) (store : Structured.Store) + (hrepresents : RepresentsTape bound slot tape store) + (hone : store (oneReg n bound) = 1) : + RepresentsTape bound slot (tape.move direction) + (Structured.Basic.execList (moveOps n bound slot direction) store) := by + constructor + Β· cases direction <;> + simp [moveOps, Structured.Basic.execList, Structured.Basic.exec, Tape.move, + hrepresents.1, hone] + Β· intro position + rw [moveOps_apply_of_ne n bound slot direction store + (headReg_ne_cellReg slot slot position).symm] + rw [Tape.move_cells] + exact hrepresents.2 position + +private theorem writeOps_one (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (store : Structured.Store) + (hhead : store (headReg slot) ≀ bound) : + Structured.Basic.execList (writeOps n bound slot write) store + (oneReg n bound) = store (oneReg n bound) := by + have honeAddress : oneReg n bound β‰  addressReg n bound := by + simp [oneReg, addressReg] + have honeValue : oneReg n bound β‰  valueReg n bound := by + simp [oneReg, valueReg] + have honeBase : oneReg n bound β‰  cellBase n bound slot := by + intro heq + have hcell := fieldReg_lt_internal + (cellField slot (⟨0, by omega⟩ : Fin (bound + 1))) + rw [← cellBase_add_eq_fieldReg_internal] at hcell + simp only [Nat.add_zero] at hcell + have hone := oneReg_ge_internal n bound + omega + let position : Fin (bound + 1) := ⟨store (headReg slot), by omega⟩ + have htargetLt : + cellBase n bound slot + store (headReg slot) < registerCount n bound := by + change cellBase n bound slot + position.val < registerCount n bound + rw [cellBase_add_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + have honeTarget : + oneReg n bound β‰  cellBase n bound slot + store (headReg slot) := by + intro heq + have hone := oneReg_ge_internal n bound + omega + rw [writeOps_apply n bound slot write store honeAddress honeValue, + Function.update_of_ne honeBase, Function.update_of_ne honeTarget] + +private theorem writeMoveOps_tape_internal (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (tape : Tape) (store : Structured.Store) + (hrepresents : RepresentsTape bound slot tape store) + (hhead : tape.head ≀ bound) (hstart : tape.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) : + RepresentsTape bound slot (tape.writeAndMove write.toΞ“ direction) + (Structured.Basic.execList (writeMoveOps n bound slot write direction) store) := by + let written := Structured.Basic.execList (writeOps n bound slot write) store + have hwritten := writeOps_tape n bound slot write tape store hrepresents hstart + have honeWritten : written (oneReg n bound) = 1 := by + exact (writeOps_one n bound slot write store (hrepresents.1 β–Έ hhead)).trans hone + rw [writeMoveOps, execList_append] + exact moveOps_tape n bound slot direction (tape.write write.toΞ“) written + hwritten honeWritten + +private theorem headReg_ne_headReg_of_slot_ne {first second : Fin (n + 2)} + (hne : first β‰  second) : headReg first β‰  headReg second := by + intro heq + apply hne + apply Fin.ext + simp [headReg] at heq + omega + +theorem writeMoveOps_one_internal (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (store : Structured.Store) + (hhead : store (headReg slot) ≀ bound) : + Structured.Basic.execList (writeMoveOps n bound slot write direction) store + (oneReg n bound) = store (oneReg n bound) := by + let written := Structured.Basic.execList (writeOps n bound slot write) store + have honeWritten : written (oneReg n bound) = store (oneReg n bound) := by + change Structured.Basic.execList (writeOps n bound slot write) store + (oneReg n bound) = store (oneReg n bound) + exact writeOps_one n bound slot write store hhead + have honeHead : oneReg n bound β‰  headReg slot := by + intro heq + have hheadReg := fieldReg_lt_internal (headField (bound := bound) slot) + rw [← headReg_eq_fieldReg_internal] at hheadReg + have hone := oneReg_ge_internal n bound + omega + rw [writeMoveOps, execList_append, + moveOps_apply_of_ne n bound slot direction written honeHead, honeWritten] + +private theorem writeMoveOps_otherTape_internal (n bound : β„•) + {slot other : Fin (n + 2)} (hne : slot β‰  other) + (write : Ξ“w) (direction : Dir3) (otherTape : Tape) + (store : Structured.Store) + (hother : RepresentsTape bound other otherTape store) + (hhead : store (headReg slot) ≀ bound) : + RepresentsTape bound other otherTape + (Structured.Basic.execList (writeMoveOps n bound slot write direction) store) := by + let written := Structured.Basic.execList (writeOps n bound slot write) store + let selectedPosition : Fin (bound + 1) := + ⟨store (headReg slot), by omega⟩ + have hotherHeadReg : headReg other < registerCount n bound := by + rw [headReg_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + have hwriteHead : written (headReg other) = store (headReg other) := by + change Structured.Basic.execList (writeOps n bound slot write) store + (headReg other) = store (headReg other) + rw [writeOps_apply n bound slot write store + (configReg_ne_address hotherHeadReg) (configReg_ne_value hotherHeadReg)] + have hbase : headReg other β‰  cellBase n bound slot := by + simpa using + (headReg_ne_cellReg other slot (⟨0, by omega⟩ : Fin (bound + 1))) + have htarget : + headReg other β‰  cellBase n bound slot + store (headReg slot) := by + simpa [selectedPosition] using + (headReg_ne_cellReg other slot selectedPosition) + rw [Function.update_of_ne hbase, Function.update_of_ne htarget] + have hmoveHead : + Structured.Basic.execList (moveOps n bound slot direction) written + (headReg other) = written (headReg other) := + moveOps_apply_of_ne n bound slot direction written + (headReg_ne_headReg_of_slot_ne (Ne.symm hne)) + constructor + Β· rw [writeMoveOps, execList_append, hmoveHead, hwriteHead] + exact hother.1 + Β· intro position + have hotherCellReg : + cellBase n bound other + position.val < registerCount n bound := by + rw [cellBase_add_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + have hwriteCell : + written (cellBase n bound other + position.val) = + store (cellBase n bound other + position.val) := by + change Structured.Basic.execList (writeOps n bound slot write) store + (cellBase n bound other + position.val) = + store (cellBase n bound other + position.val) + rw [writeOps_apply n bound slot write store + (configReg_ne_address hotherCellReg) (configReg_ne_value hotherCellReg)] + have hbase : + cellBase n bound other + position.val β‰  cellBase n bound slot := by + simpa using + (cellReg_ne_cellReg_of_slot_ne (Ne.symm hne) position + (⟨0, by omega⟩ : Fin (bound + 1))) + have htarget : + cellBase n bound other + position.val β‰  + cellBase n bound slot + store (headReg slot) := by + simpa [selectedPosition] using + (cellReg_ne_cellReg_of_slot_ne (Ne.symm hne) position selectedPosition) + rw [Function.update_of_ne hbase, Function.update_of_ne htarget] + have hmoveCell : + Structured.Basic.execList (moveOps n bound slot direction) written + (cellBase n bound other + position.val) = + written (cellBase n bound other + position.val) := + moveOps_apply_of_ne n bound slot direction written + (headReg_ne_cellReg slot other position).symm + rw [writeMoveOps, execList_append, hmoveCell, hwriteCell] + exact hother.2 position + +private theorem RepresentsTape.stateUpdate (bound : β„•) (slot : Fin (n + 2)) + (tape : Tape) (store : Structured.Store) (state : β„•) + (hrepresents : RepresentsTape bound slot tape store) : + RepresentsTape bound slot tape + ((Structured.Basic.imm 0 state).exec store) := by + constructor + Β· simpa [Structured.Basic.exec, headReg, Function.update_of_ne] using + hrepresents.1 + Β· intro position + simpa [Structured.Basic.exec, cellBase, Function.update_of_ne] using + hrepresents.2 position + +private theorem moveOps_one (n bound : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (store : Structured.Store) : + Structured.Basic.execList (moveOps n bound slot direction) store + (oneReg n bound) = store (oneReg n bound) := by + apply moveOps_apply_of_ne + intro heq + have hhead := fieldReg_lt_internal (headField (bound := bound) slot) + rw [← headReg_eq_fieldReg_internal] at hhead + have hone := oneReg_ge_internal n bound + omega + +private theorem moveOps_zero (n bound : β„•) (slot : Fin (n + 2)) + (direction : Dir3) (store : Structured.Store) : + Structured.Basic.execList (moveOps n bound slot direction) store 0 = store 0 := by + apply moveOps_apply_of_ne + simp [headReg] + omega + +private theorem moveOps_otherTape (n bound : β„•) + {slot other : Fin (n + 2)} (hne : slot β‰  other) + (direction : Dir3) (otherTape : Tape) (store : Structured.Store) + (hother : RepresentsTape bound other otherTape store) : + RepresentsTape bound other otherTape + (Structured.Basic.execList (moveOps n bound slot direction) store) := by + constructor + Β· rw [moveOps_apply_of_ne n bound slot direction store + (headReg_ne_headReg_of_slot_ne (Ne.symm hne))] + exact hother.1 + Β· intro position + rw [moveOps_apply_of_ne n bound slot direction store + (headReg_ne_cellReg slot other position).symm] + exact hother.2 position + +private theorem writeMoveOps_zero (n bound : β„•) (slot : Fin (n + 2)) + (write : Ξ“w) (direction : Dir3) (store : Structured.Store) : + Structured.Basic.execList (writeMoveOps n bound slot write direction) store 0 = + store 0 := by + let written := Structured.Basic.execList (writeOps n bound slot write) store + have hzeroAddress : 0 β‰  addressReg n bound := by + simp [addressReg, scratchBase, registerCount] + have hzeroValue : 0 β‰  valueReg n bound := by + simp [valueReg, scratchBase, registerCount] + have hzeroWritten : written 0 = store 0 := by + change Structured.Basic.execList (writeOps n bound slot write) store 0 = store 0 + rw [writeOps_apply n bound slot write store hzeroAddress hzeroValue] + have hbase : 0 β‰  cellBase n bound slot := by + simp [cellBase] + omega + have htarget : 0 β‰  cellBase n bound slot + store (headReg slot) := by + simp [cellBase] + omega + rw [Function.update_of_ne hbase, Function.update_of_ne htarget] + rw [writeMoveOps, execList_append, + moveOps_zero n bound slot direction written, hzeroWritten] + +private theorem workTape_injective (n : β„•) : + Function.Injective (workTape : Fin n β†’ Fin (n + 2)) := by + intro first second heq + apply Fin.ext + simpa [workTape] using congrArg Fin.val heq + +private theorem inputTape_ne_workTape (n : β„•) (i : Fin n) : + inputTape n β‰  workTape i := by + intro heq + have := congrArg Fin.val heq + simp [inputTape, workTape] at this + +private theorem outputTape_ne_workTape (n : β„•) (i : Fin n) : + outputTape n β‰  workTape i := by + intro heq + have hi := i.isLt + have := congrArg Fin.val heq + simp [outputTape, workTape] at this + omega + +private theorem inputTape_ne_outputTape (n : β„•) : + inputTape n β‰  outputTape n := by + intro heq + have := congrArg Fin.val heq + simp [inputTape, outputTape] at this + +/-- Reassemble the fieldwise configuration representation from the state and +the three kinds of named tape blocks. -/ +private theorem represents_of_named_tapes {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstate : store 0 = stateCode tm cfg.state) + (hinput : RepresentsTape bound (inputTape n) cfg.input store) + (hwork : βˆ€ i, RepresentsTape bound (workTape i) (cfg.work i) store) + (houtput : RepresentsTape bound (outputTape n) cfg.output store) : + Represents tm bound cfg store := by + intro field + rcases field with state | headOrCell + Β· rcases state with ⟨state, hstateFin⟩ + have hzero : state = 0 := by omega + subst state + simpa [fieldReg_state_internal, fieldValue] using! hstate + Β· rcases headOrCell with head | cell + Β· change store (headReg head) = (tapeAt cfg head).head + by_cases hinputSlot : head = inputTape n + Β· subst head + rw [hinput.1] + simpa [inputTape] using + congrArg Tape.head (tapeAt_input_internal cfg).symm + Β· by_cases houtputSlot : head = outputTape n + Β· subst head + rw [houtput.1] + simpa [outputTape] using + congrArg Tape.head (tapeAt_output_internal cfg).symm + Β· let i : Fin n := ⟨head.val - 1, by + have hpositive : 0 < head.val := by + have hnezero : head.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + have hnotOutput : head.val β‰  n + 1 := by + intro heq + apply houtputSlot + apply Fin.ext + simpa [outputTape] using heq + omega⟩ + have hhead : head = workTape i := by + apply Fin.ext + simp [i, workTape] + have hpositive : 0 < head.val := by + have hnezero : head.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + omega + rw [hhead, (hwork i).1] + simpa [workTape] using + congrArg Tape.head (tapeAt_work_internal cfg i).symm + Β· rcases cell with ⟨tape, position⟩ + simp only [fieldValue] + change store (fieldReg (cellField tape position)) = + symbolCode ((tapeAt cfg tape).cells position.val) + rw [← cellBase_add_eq_fieldReg_internal] + by_cases hinputSlot : tape = inputTape n + Β· subst tape + rw [hinput.2 position] + simpa [inputTape] using congrArg (fun t => symbolCode (t.cells position.val)) + (tapeAt_input_internal cfg).symm + Β· by_cases houtputSlot : tape = outputTape n + Β· subst tape + rw [houtput.2 position] + simpa [outputTape] using congrArg (fun t => symbolCode (t.cells position.val)) + (tapeAt_output_internal cfg).symm + Β· let i : Fin n := ⟨tape.val - 1, by + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + have hnotOutput : tape.val β‰  n + 1 := by + intro heq + apply houtputSlot + apply Fin.ext + simpa [outputTape] using heq + omega⟩ + have htape : tape = workTape i := by + apply Fin.ext + simp [i, workTape] + have hpositive : 0 < tape.val := by + have hnezero : tape.val β‰  0 := by + intro hzero + apply hinputSlot + apply Fin.ext + simpa [inputTape] using hzero + omega + omega + rw [htape, (hwork i).2 position] + simpa [workTape] using congrArg (fun t => symbolCode (t.cells position.val)) + (tapeAt_work_internal cfg i).symm + +/-- Invariant after updating a prefix of the work tapes for one selected +transition. -/ +private structure WorkPrefix (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (nextState : tm.Q) + (inputDirection : Dir3) (workWrites : Fin n β†’ Ξ“w) + (workDirections : Fin n β†’ Dir3) (processed : List (Fin n)) + (store : Structured.Store) : Prop where + state : store 0 = stateCode tm nextState + one : store (oneReg n bound) = 1 + input : RepresentsTape bound (inputTape n) + (cfg.input.move inputDirection) store + work : βˆ€ i, RepresentsTape bound (workTape i) + (if i ∈ processed then + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + else cfg.work i) store + output : RepresentsTape bound (outputTape n) cfg.output store + +private theorem actionPrelude_workPrefix {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (nextState : tm.Q) (inputDirection : Dir3) + (workWrites : Fin n β†’ Ξ“w) (workDirections : Fin n β†’ Dir3) + (hrepresents : Represents tm bound cfg store) + (hone : store (oneReg n bound) = 1) : + let initialized := (Structured.Basic.imm 0 (stateCode tm nextState)).exec store + let final := Structured.Basic.execList + (moveOps n bound (inputTape n) inputDirection) initialized + WorkPrefix tm bound cfg nextState inputDirection workWrites workDirections [] final := by + let initialized := (Structured.Basic.imm 0 (stateCode tm nextState)).exec store + let final := Structured.Basic.execList + (moveOps n bound (inputTape n) inputDirection) initialized + have honeReg : oneReg n bound β‰  0 := by + simp [oneReg, scratchBase, registerCount] + have honeInitialized : initialized (oneReg n bound) = 1 := by + simpa [initialized, Structured.Basic.exec, + Function.update_of_ne honeReg] using hone + have hinputStore : RepresentsTape bound (inputTape n) cfg.input store := by + have htape := Represents.tape hrepresents (inputTape n) + simpa [inputTape] using! htape + have hinputInitialized : + RepresentsTape bound (inputTape n) cfg.input initialized := + hinputStore.stateUpdate bound (inputTape n) cfg.input store + (stateCode tm nextState) + have hworkInitialized : βˆ€ i, + RepresentsTape bound (workTape i) (cfg.work i) initialized := by + intro i + have htape := Represents.tape hrepresents (workTape i) + have hnamed : RepresentsTape bound (workTape i) (cfg.work i) store := by + rw [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at htape + exact htape + exact hnamed.stateUpdate bound (workTape i) (cfg.work i) store + (stateCode tm nextState) + have houtputStore : RepresentsTape bound (outputTape n) cfg.output store := by + have htape := Represents.tape hrepresents (outputTape n) + rw [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at htape + exact htape + have houtputInitialized : + RepresentsTape bound (outputTape n) cfg.output initialized := + houtputStore.stateUpdate bound (outputTape n) cfg.output store + (stateCode tm nextState) + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + Β· rw [moveOps_zero n bound (inputTape n) inputDirection initialized] + simp [initialized, Structured.Basic.exec] + Β· exact (moveOps_one n bound (inputTape n) inputDirection initialized).trans + honeInitialized + Β· exact moveOps_tape n bound (inputTape n) inputDirection cfg.input initialized + hinputInitialized honeInitialized + Β· intro i + simpa using moveOps_otherTape n bound + (inputTape_ne_workTape n i) inputDirection (cfg.work i) initialized + (hworkInitialized i) + Β· exact moveOps_otherTape n bound (inputTape_ne_outputTape n) inputDirection + cfg.output initialized houtputInitialized + +private theorem workPrefix_step {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} {processed : List (Fin n)} + {store : Structured.Store} + (hprefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections processed store) + (i : Fin n) (hfresh : i βˆ‰ processed) + (hhead : (cfg.work i).head ≀ bound) + (hstart : (cfg.work i).cells 0 = Ξ“.start) : + WorkPrefix tm bound cfg nextState inputDirection workWrites workDirections + (i :: processed) + (Structured.Basic.execList + (writeMoveOps n bound (workTape i) (workWrites i) (workDirections i)) store) := by + have hselected : RepresentsTape bound (workTape i) (cfg.work i) store := by + simpa [hfresh] using hprefix.work i + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + Β· exact (writeMoveOps_zero n bound (workTape i) (workWrites i) + (workDirections i) store).trans hprefix.state + Β· exact (writeMoveOps_one_internal n bound (workTape i) (workWrites i) + (workDirections i) store (hselected.1 β–Έ hhead)).trans hprefix.one + Β· exact writeMoveOps_otherTape_internal n bound + (Ne.symm (inputTape_ne_workTape n i)) (workWrites i) (workDirections i) + (cfg.input.move inputDirection) store hprefix.input (hselected.1 β–Έ hhead) + Β· intro j + by_cases hji : j = i + Β· subst j + simpa using writeMoveOps_tape_internal n bound (workTape i) + (workWrites i) (workDirections i) (cfg.work i) store hselected hhead + hstart hprefix.one + Β· have hslots : workTape i β‰  workTape j := by + exact fun heq => hji ((workTape_injective n) heq).symm + simpa [hji] using writeMoveOps_otherTape_internal n bound hslots + (workWrites i) (workDirections i) + (if j ∈ processed then + (cfg.work j).writeAndMove (workWrites j).toΞ“ (workDirections j) + else cfg.work j) store (hprefix.work j) (hselected.1 β–Έ hhead) + Β· exact writeMoveOps_otherTape_internal n bound + (outputTape_ne_workTape n i).symm (workWrites i) (workDirections i) + cfg.output store hprefix.output (hselected.1 β–Έ hhead) + +private theorem workPrefix_list {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} + (items processed : List (Fin n)) {store : Structured.Store} + (hprefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections processed store) + (hfresh : βˆ€ i, i ∈ items β†’ i βˆ‰ processed) + (hnodup : items.Nodup) + (hheads : βˆ€ i, (cfg.work i).head ≀ bound) + (hstarts : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) : + WorkPrefix tm bound cfg nextState inputDirection workWrites workDirections + (items.reverse ++ processed) + (Structured.Basic.execList + (items.flatMap (fun i => writeMoveOps n bound (workTape i) + (workWrites i) (workDirections i))) store) := by + induction items generalizing processed store with + | nil => simpa using! hprefix + | cons i rest ih => + have hinot : i βˆ‰ processed := hfresh i (by simp) + have hnext := workPrefix_step hprefix i hinot (hheads i) (hstarts i) + have hrestFresh : βˆ€ j, j ∈ rest β†’ j βˆ‰ i :: processed := by + intro j hj hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst j + exact (List.nodup_cons.mp hnodup).1 hj + Β· exact hfresh j (by simp [hj]) hprocessed + have hfinal := ih (processed := i :: processed) hnext hrestFresh + (List.nodup_cons.mp hnodup).2 + simpa [List.flatMap_cons, execList_append, List.reverse_cons, + List.append_assoc] using hfinal + +theorem actionOps_represents_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) : + Represents tm bound next + (Structured.Basic.execList + (actionOps tm bound cfg.state (readSymbols cfg)) store) := by + have hnotHalted := TM.state_ne_qhalt_of_step hstep + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + rw [TM.step, ite_eq_right hnotHalted, hdelta] at hstep + dsimp only at hstep + injection hstep with hnext + subst next + have hreadInput : + readSymbols cfg (inputTape n) = cfg.input.read := by + simpa [readSymbols, inputTape] using + congrArg Tape.read (tapeAt_input_internal cfg) + have hreadWork : + (fun i => readSymbols cfg (workTape i)) = + (fun i => (cfg.work i).read) := by + funext i + simpa [readSymbols, workTape] using + congrArg Tape.read (tapeAt_work_internal cfg i) + have hreadOutput : + readSymbols cfg (outputTape n) = cfg.output.read := by + simpa [readSymbols, outputTape] using + congrArg Tape.read (tapeAt_output_internal cfg) + let initialized := + (Structured.Basic.imm 0 (stateCode tm nextState)).exec store + let afterInput := Structured.Basic.execList + (moveOps n bound (inputTape n) inputDirection) initialized + have hprefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections [] afterInput := by + exact actionPrelude_workPrefix nextState inputDirection workWrites + workDirections hrepresents hone + have hworkHeads : βˆ€ i, (cfg.work i).head ≀ bound := by + intro i + have hhead := hheads (workTape i) + rw [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at hhead + exact hhead + let afterWork := Structured.Basic.execList + ((List.finRange n).flatMap (fun i => + writeMoveOps n bound (workTape i) (workWrites i) (workDirections i))) + afterInput + have hworkPrefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections ((List.finRange n).reverse ++ []) afterWork := by + exact workPrefix_list (List.finRange n) [] hprefix (by simp) + (List.nodup_finRange n) hworkHeads hworkStart + have hworkFinal : βˆ€ i, + RepresentsTape bound (workTape i) + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) + afterWork := by + intro i + simpa using hworkPrefix.work i + have houtputHead : cfg.output.head ≀ bound := by + have hhead := hheads (outputTape n) + rw [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at hhead + exact hhead + let final := Structured.Basic.execList + (writeMoveOps n bound (outputTape n) outputWrite outputDirection) afterWork + have hstateFinal : final 0 = stateCode tm nextState := by + exact (writeMoveOps_zero n bound (outputTape n) outputWrite outputDirection + afterWork).trans hworkPrefix.state + have honeFinal : final (oneReg n bound) = 1 := by + exact (writeMoveOps_one_internal n bound (outputTape n) outputWrite + outputDirection afterWork (hworkPrefix.output.1 β–Έ houtputHead)).trans + hworkPrefix.one + have hinputFinal : RepresentsTape bound (inputTape n) + (cfg.input.move inputDirection) final := by + exact writeMoveOps_otherTape_internal n bound + (inputTape_ne_outputTape n).symm outputWrite outputDirection + (cfg.input.move inputDirection) afterWork hworkPrefix.input + (hworkPrefix.output.1 β–Έ houtputHead) + have hworkFinal' : βˆ€ i, RepresentsTape bound (workTape i) + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) final := by + intro i + exact writeMoveOps_otherTape_internal n bound + (outputTape_ne_workTape n i) outputWrite outputDirection + ((cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i)) + afterWork (hworkFinal i) (hworkPrefix.output.1 β–Έ houtputHead) + have houtputFinal : RepresentsTape bound (outputTape n) + (cfg.output.writeAndMove outputWrite.toΞ“ outputDirection) final := by + exact writeMoveOps_tape_internal n bound (outputTape n) outputWrite + outputDirection cfg.output afterWork hworkPrefix.output houtputHead + houtputStart hworkPrefix.one + have hfinalRepresents : + Represents tm bound + { state := nextState + input := cfg.input.move inputDirection + work := fun i => + (cfg.work i).writeAndMove (workWrites i).toΞ“ (workDirections i) + output := cfg.output.writeAndMove outputWrite.toΞ“ outputDirection } + final := by + exact represents_of_named_tapes hstateFinal hinputFinal hworkFinal' + houtputFinal + simpa [actionOps, hreadInput, hreadWork, hreadOutput, hdelta, + initialized, afterInput, afterWork, final, execList_append, + Structured.Basic.execList, List.append_assoc] using + hfinalRepresents + +private abbrev StepEnvelope (tm : TM n) (bound : β„•) := + Structured.Internal.StoreEnvelope (registerLimit n bound) (wordBound tm bound) + +private abbrev StepEnvelopeChain (tm : TM n) (bound : β„•) := + Structured.Internal.Basic.EnvelopeChain (registerLimit n bound) (wordBound tm bound) + +private theorem registerCount_lt_registerLimit' (n bound : β„•) : + registerCount n bound < registerLimit n bound := by + simp [registerLimit, scratchBase] + omega + +private theorem registerLimit_le_wordBound' (tm : TM n) (bound : β„•) : + registerLimit n bound ≀ wordBound tm bound := + le_max_left _ _ + +private theorem headReg_lt_registerLimit (n bound : β„•) + (tape : Fin (n + 2)) : headReg tape < registerLimit n bound := by + have hhead := fieldReg_lt_internal (headField (bound := bound) tape) + rw [← headReg_eq_fieldReg_internal] at hhead + exact lt_trans hhead (registerCount_lt_registerLimit' n bound) + +private theorem cellBase_lt_registerLimit (n bound : β„•) + (tape : Fin (n + 2)) : cellBase n bound tape < registerLimit n bound := by + have hcell := fieldReg_lt_internal + (cellField tape (⟨0, by omega⟩ : Fin (bound + 1))) + rw [← cellBase_add_eq_fieldReg_internal] at hcell + simpa using lt_trans hcell (registerCount_lt_registerLimit' n bound) + +private theorem smallValue_le_wordBound (tm : TM n) (bound value : β„•) + (hvalue : value ≀ 3) : value ≀ wordBound tm bound := by + have hthree : 3 ≀ registerLimit n bound := by + simp [registerLimit, scratchBase, registerCount] + exact le_trans hvalue (le_trans hthree (registerLimit_le_wordBound' tm bound)) + +private theorem moveOps_envelopeChain (tm : TM n) (bound : β„•) + (tape : Fin (n + 2)) (direction : Dir3) (store : Structured.Store) + (henvelope : StepEnvelope tm bound store) + (hhead : store (headReg tape) ≀ bound) + (hone : store (oneReg n bound) = 1) : + StepEnvelopeChain tm bound (moveOps n bound tape direction) store := by + have hindex := headReg_lt_registerLimit n bound tape + have hbound : bound + 1 ≀ wordBound tm bound := by + exact le_trans (le_max_right _ _) + (le_max_right (registerLimit n bound) _) + cases direction with + | stay => exact henvelope + | left => + have hfinal : StepEnvelope tm bound + ((Structured.Basic.sub (headReg tape) (headReg tape) + (oneReg n bound)).exec store) := by + apply henvelope.execBasic + Β· exact hindex + Β· simp only [Structured.Internal.Basic.writeValue] + omega + exact ⟨henvelope, hfinal⟩ + | right => + have hfinal : StepEnvelope tm bound + ((Structured.Basic.add (headReg tape) (headReg tape) + (oneReg n bound)).exec store) := by + apply henvelope.execBasic + Β· exact hindex + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hone] + omega + exact ⟨henvelope, hfinal⟩ + +private theorem writeOps_envelopeChain (tm : TM n) (bound : β„•) + (tape : Fin (n + 2)) (write : Ξ“w) (store : Structured.Store) + (henvelope : StepEnvelope tm bound store) + (hhead : store (headReg tape) ≀ bound) : + StepEnvelopeChain tm bound (writeOps n bound tape write) store := by + let first := + (Structured.Basic.imm (addressReg n bound) (cellBase n bound tape)).exec store + let addressed := + (Structured.Basic.add (addressReg n bound) (addressReg n bound) + (headReg tape)).exec first + let valued := (Structured.Basic.imm (valueReg n bound) (writeCode write)).exec addressed + let stored := (Structured.Basic.store (addressReg n bound) + (valueReg n bound)).exec valued + let final := + (Structured.Basic.imm (cellBase n bound tape) (symbolCode Ξ“.start)).exec stored + have hscratch := scratch_lt_registerLimit_internal n bound + have hbaseLt := cellBase_lt_registerLimit n bound tape + have hbaseBound : cellBase n bound tape ≀ wordBound tm bound := + le_trans (Nat.le_of_lt hbaseLt) (registerLimit_le_wordBound' tm bound) + have hfirst : StepEnvelope tm bound first := by + apply henvelope.execBasic + Β· exact hscratch.2.2.2.1 + Β· simpa [Structured.Internal.Basic.writeValue] using hbaseBound + have haddressHead : addressReg n bound β‰  headReg tape := by + intro heq + have haddress := addressReg_ge_internal n bound + have hheadReg := fieldReg_lt_internal (headField (bound := bound) tape) + rw [← headReg_eq_fieldReg_internal] at hheadReg + omega + have hfirstAddress : first (addressReg n bound) = cellBase n bound tape := by + simp [first, Structured.Basic.exec] + have hfirstHead : first (headReg tape) = store (headReg tape) := by + simp [first, Structured.Basic.exec, Function.update_of_ne (Ne.symm haddressHead)] + let position : Fin (bound + 1) := ⟨store (headReg tape), by omega⟩ + have htargetLt : + cellBase n bound tape + store (headReg tape) < registerCount n bound := by + change cellBase n bound tape + position.val < registerCount n bound + rw [cellBase_add_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + have htargetBound : + cellBase n bound tape + store (headReg tape) ≀ wordBound tm bound := by + exact le_trans (Nat.le_of_lt htargetLt) + (le_trans (Nat.le_of_lt (registerCount_lt_registerLimit' n bound)) + (registerLimit_le_wordBound' tm bound)) + have haddressed : StepEnvelope tm bound addressed := by + apply hfirst.execBasic + Β· exact hscratch.2.2.2.1 + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hfirstAddress, hfirstHead] + exact htargetBound + have hwriteBound : writeCode write ≀ wordBound tm bound := by + apply smallValue_le_wordBound tm bound + cases write <;> decide + have hvalued : StepEnvelope tm bound valued := by + apply haddressed.execBasic + Β· exact hscratch.2.2.2.2.1 + Β· simpa [Structured.Internal.Basic.writeValue] using hwriteBound + have hvaluedAddress : + valued (addressReg n bound) = + cellBase n bound tape + store (headReg tape) := by + simp only [valued, Structured.Basic.exec] + rw [Function.update_of_ne] + Β· simp [addressed, Structured.Basic.exec, hfirstAddress, hfirstHead] + Β· simp [addressReg, valueReg] + have hvaluedValue : valued (valueReg n bound) = writeCode write := by + simp [valued, Structured.Basic.exec] + have hstored : StepEnvelope tm bound stored := by + apply hvalued.execBasic + Β· simp only [Structured.Internal.Basic.writeIndex] + rw [hvaluedAddress] + exact lt_trans htargetLt (registerCount_lt_registerLimit' n bound) + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hvaluedValue] + exact hwriteBound + have hstartBound : symbolCode Ξ“.start ≀ wordBound tm bound := + smallValue_le_wordBound tm bound _ (by decide) + have hfinal : StepEnvelope tm bound final := by + apply hstored.execBasic + Β· exact hbaseLt + Β· simpa [Structured.Internal.Basic.writeValue] using hstartBound + simpa [writeOps, first, addressed, valued, stored, final] using! + And.intro henvelope (And.intro hfirst + (And.intro haddressed (And.intro hvalued (And.intro hstored hfinal)))) + +private theorem writeMoveOps_envelopeChain (tm : TM n) (bound : β„•) + (tape : Fin (n + 2)) (write : Ξ“w) (direction : Dir3) + (store : Structured.Store) (henvelope : StepEnvelope tm bound store) + (hhead : store (headReg tape) ≀ bound) + (hone : store (oneReg n bound) = 1) : + StepEnvelopeChain tm bound (writeMoveOps n bound tape write direction) store := by + let written := Structured.Basic.execList (writeOps n bound tape write) store + have hwrite := writeOps_envelopeChain tm bound tape write store henvelope hhead + have hwrittenEnvelope : StepEnvelope tm bound written := hwrite.final + have hwrittenHead : written (headReg tape) ≀ bound := by + change Structured.Basic.execList (writeOps n bound tape write) store + (headReg tape) ≀ bound + rw [writeOps_head n bound tape write store] + exact hhead + have hwrittenOne : written (oneReg n bound) = 1 := by + exact (writeOps_one n bound tape write store hhead).trans hone + have hmove := moveOps_envelopeChain tm bound tape direction written + hwrittenEnvelope hwrittenHead hwrittenOne + simpa [writeMoveOps] using hwrite.append hmove + +private theorem workPrefix_list_envelope {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {nextState : tm.Q} + {inputDirection : Dir3} {workWrites : Fin n β†’ Ξ“w} + {workDirections : Fin n β†’ Dir3} + (items processed : List (Fin n)) {store : Structured.Store} + (hprefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections processed store) + (henvelope : StepEnvelope tm bound store) + (hfresh : βˆ€ i, i ∈ items β†’ i βˆ‰ processed) + (hnodup : items.Nodup) + (hheads : βˆ€ i, (cfg.work i).head ≀ bound) + (hstarts : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) : + let ops := items.flatMap (fun i => writeMoveOps n bound (workTape i) + (workWrites i) (workDirections i)) + WorkPrefix tm bound cfg nextState inputDirection workWrites workDirections + (items.reverse ++ processed) (Structured.Basic.execList ops store) ∧ + StepEnvelopeChain tm bound ops store := by + induction items generalizing processed store with + | nil => exact ⟨by simpa using! hprefix, henvelope⟩ + | cons i rest ih => + have hinot : i βˆ‰ processed := hfresh i (by simp) + have hselected : RepresentsTape bound (workTape i) (cfg.work i) store := by + simpa [hinot] using hprefix.work i + have hblock := writeMoveOps_envelopeChain tm bound (workTape i) + (workWrites i) (workDirections i) store henvelope + (hselected.1 β–Έ hheads i) hprefix.one + have hnext := workPrefix_step hprefix i hinot (hheads i) (hstarts i) + have hrestFresh : βˆ€ j, j ∈ rest β†’ j βˆ‰ i :: processed := by + intro j hj hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst j + exact (List.nodup_cons.mp hnodup).1 hj + Β· exact hfresh j (by simp [hj]) hprocessed + obtain ⟨hfinalPrefix, hrestChain⟩ := + ih (processed := i :: processed) hnext hblock.final hrestFresh + (List.nodup_cons.mp hnodup).2 + refine ⟨?_, ?_⟩ + Β· simpa [List.flatMap_cons, execList_append, List.reverse_cons, + List.append_assoc] using hfinalPrefix + Β· simpa [List.flatMap_cons] using hblock.append hrestChain + +private theorem actionOps_envelopeChain_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + StepEnvelopeChain tm bound + (actionOps tm bound cfg.state (readSymbols cfg)) store := by + rcases hdelta : tm.Ξ΄ cfg.state cfg.input.read + (fun i => (cfg.work i).read) cfg.output.read with + ⟨nextState, workWrites, outputWrite, inputDirection, + workDirections, outputDirection⟩ + have hreadInput : readSymbols cfg (inputTape n) = cfg.input.read := by + simpa [readSymbols, inputTape] using + congrArg Tape.read (tapeAt_input_internal cfg) + have hreadWork : (fun i => readSymbols cfg (workTape i)) = + (fun i => (cfg.work i).read) := by + funext i + simpa [readSymbols, workTape] using + congrArg Tape.read (tapeAt_work_internal cfg i) + have hreadOutput : readSymbols cfg (outputTape n) = cfg.output.read := by + simpa [readSymbols, outputTape] using + congrArg Tape.read (tapeAt_output_internal cfg) + let initialized := + (Structured.Basic.imm 0 (stateCode tm nextState)).exec store + have hstateBound : stateCode tm nextState ≀ wordBound tm bound := by + exact le_trans (Nat.le_of_lt (stateCode_lt_internal tm nextState)) + (le_trans (le_max_left _ _) (le_max_right _ _)) + have hinitialized : StepEnvelope tm bound initialized := by + apply henvelope.execBasic + Β· simp [registerLimit, scratchBase, registerCount] + Β· simpa [Structured.Internal.Basic.writeValue] using hstateBound + have hstateChain : StepEnvelopeChain tm bound + [.imm 0 (stateCode tm nextState)] store := ⟨henvelope, hinitialized⟩ + have hinputStore : RepresentsTape bound (inputTape n) cfg.input store := by + have htape := Represents.tape hrepresents (inputTape n) + simpa [inputTape] using! htape + have hinputHead : initialized (headReg (inputTape n)) ≀ bound := by + have hhead := hheads (inputTape n) + rw [show tapeAt cfg (inputTape n) = cfg.input by + simpa [inputTape] using tapeAt_input_internal cfg] at hhead + rw [show initialized (headReg (inputTape n)) = store (headReg (inputTape n)) by + simp [initialized, Structured.Basic.exec, headReg, inputTape, + Function.update_of_ne]] + exact hinputStore.1.symm β–Έ hhead + have honeInitialized : initialized (oneReg n bound) = 1 := by + rw [show initialized (oneReg n bound) = store (oneReg n bound) by + simp [initialized, Structured.Basic.exec, oneReg, scratchBase, registerCount, + Function.update_of_ne]] + exact hone + let afterInput := Structured.Basic.execList + (moveOps n bound (inputTape n) inputDirection) initialized + have hinputChain := moveOps_envelopeChain tm bound (inputTape n) + inputDirection initialized hinitialized hinputHead honeInitialized + have hprefix : WorkPrefix tm bound cfg nextState inputDirection + workWrites workDirections [] afterInput := by + exact actionPrelude_workPrefix nextState inputDirection workWrites + workDirections hrepresents hone + have hworkHeads : βˆ€ i, (cfg.work i).head ≀ bound := by + intro i + have hhead := hheads (workTape i) + rw [show tapeAt cfg (workTape i) = cfg.work i by + simpa [workTape] using tapeAt_work_internal cfg i] at hhead + exact hhead + obtain ⟨hworkPrefix, hworkChain⟩ := workPrefix_list_envelope + (List.finRange n) [] hprefix hinputChain.final (by simp) + (List.nodup_finRange n) hworkHeads hworkStart + let workOps := (List.finRange n).flatMap (fun i => + writeMoveOps n bound (workTape i) (workWrites i) (workDirections i)) + let afterWork := Structured.Basic.execList workOps afterInput + have houtputHead : afterWork (headReg (outputTape n)) ≀ bound := by + have houtput := hworkPrefix.output.1 + have hhead := hheads (outputTape n) + rw [show tapeAt cfg (outputTape n) = cfg.output by + simpa [outputTape] using tapeAt_output_internal cfg] at hhead + change Structured.Basic.execList + ((List.finRange n).flatMap (fun i => writeMoveOps n bound (workTape i) + (workWrites i) (workDirections i))) afterInput + (headReg (outputTape n)) ≀ bound + rw [houtput] + exact hhead + have houtputChain := writeMoveOps_envelopeChain tm bound (outputTape n) + outputWrite outputDirection afterWork hworkChain.final houtputHead hworkPrefix.one + have hcombined := hstateChain.append (hinputChain.append + (hworkChain.append houtputChain)) + simpa [actionOps, hreadInput, hreadWork, hreadOutput, hdelta, initialized, + afterInput, workOps, afterWork, List.append_assoc] using hcombined + +theorem actionOps_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + let final := Structured.Basic.execList + (actionOps tm bound cfg.state (readSymbols cfg)) store + Structured.Internal.MeasuredRuns + (action tm bound cfg.state (readSymbols cfg)) store final + (actionOps tm bound cfg.state (readSymbols cfg)).length + (4 * (actionOps tm bound cfg.state (readSymbols cfg)).length * + wordWidth tm bound) (spaceBound tm bound) ∧ + Represents tm bound next final ∧ + Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) final := by + have hchain := actionOps_envelopeChain_internal hrepresents hheads + hworkStart hone henvelope + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (actionOps tm bound cfg.state (readSymbols cfg)) store hchain + refine ⟨?_, actionOps_represents_internal hstep hrepresents hheads + hworkStart houtputStart hone, hmeasured.2⟩ + simpa [action, wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using hmeasured.1 + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Dispatch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Dispatch.lean new file mode 100644 index 0000000000..d5efe9952a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Dispatch.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Load + +/-! +# Nested finite dispatch for one TM transition -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Step + + +private theorem cleared_represents {tm : TM n} {bound test : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (htest : registerCount n bound ≀ test) : + Represents tm bound cfg (Structured.Switch.cleared store test) := by + exact hrepresents.update_outside_internal htest + +private theorem cleared_apply_of_ne (store : Structured.Store) {test reg : β„•} + (hne : reg β‰  test) : + Structured.Switch.cleared store test reg = store reg := by + simp [Structured.Switch.cleared, Function.update_of_ne hne] + +private theorem symbolReg_injective (n bound : β„•) : + Function.Injective (symbolReg n bound) := by + intro first second heq + apply Fin.ext + simp [symbolReg] at heq + omega + +private theorem symbolReg_ne_one (n bound : β„•) (tape : Fin (n + 2)) : + symbolReg n bound tape β‰  oneReg n bound := by + simp [symbolReg, oneReg] + omega + +private theorem stateScratchReg_ne_one (n bound : β„•) : + stateScratchReg n bound β‰  oneReg n bound := by + simp [stateScratchReg, oneReg] + +private theorem stateScratchReg_ne_symbolReg (n bound : β„•) + (tape : Fin (n + 2)) : + symbolReg n bound tape β‰  stateScratchReg n bound := by + simp [symbolReg, stateScratchReg] + omega + +theorem dispatchSymbols_exec_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (state : tm.Q) (actual symbols : Fin (n + 2) β†’ Ξ“) + (remaining : List (Fin (n + 2))) + (hstate : state = cfg.state) + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (hactual : actual = readSymbols cfg) + (hloaded : βˆ€ tape, tape ∈ remaining β†’ + store (symbolReg n bound tape) = symbolCode (actual tape)) + (hassigned : βˆ€ tape, tape βˆ‰ remaining β†’ symbols tape = actual tape) + (hnodup : remaining.Nodup) : + βˆƒ final cost space, + Structured.Exec (dispatchSymbols tm bound state remaining symbols) + store final (dispatchSteps tm bound state actual remaining) cost space ∧ + Represents tm bound next final := by + subst state + subst actual + induction remaining generalizing symbols store with + | nil => + have hsymbols : symbols = readSymbols cfg := by + funext tape + exact hassigned tape (by simp) + subst symbols + obtain ⟨cost, space, hexec⟩ := + Structured.Internal.exec_basics_exists + (actionOps tm bound cfg.state (readSymbols cfg)) store + refine ⟨Structured.Basic.execList + (actionOps tm bound cfg.state (readSymbols cfg)) store, + cost, space, ?_, ?_⟩ + Β· simpa [dispatchSymbols, action, dispatchSteps] using hexec + Β· exact actionOps_represents_internal hstep hrepresents hheads + hworkStart houtputStart hone + | cons tape rest ih => + have htapeCode := hloaded tape (by simp) + have htestOne : symbolReg n bound tape β‰  oneReg n bound := + symbolReg_ne_one n bound tape + let cleared := Structured.Switch.cleared store (symbolReg n bound tape) + have hclearedRepresents : Represents tm bound cfg cleared := + cleared_represents hrepresents (symbolReg_ge_internal n bound tape) + have hclearedOne : cleared (oneReg n bound) = 1 := by + exact (cleared_apply_of_ne store htestOne.symm).trans hone + have hclearedLoaded : βˆ€ candidate, candidate ∈ rest β†’ + cleared (symbolReg n bound candidate) = + symbolCode (readSymbols cfg candidate) := by + intro candidate hcandidate + have hne : candidate β‰  tape := by + intro heq + subst candidate + exact (List.nodup_cons.mp hnodup).1 hcandidate + have hregs : symbolReg n bound candidate β‰  symbolReg n bound tape := + fun heq => hne ((symbolReg_injective n bound) heq) + exact (cleared_apply_of_ne store hregs).trans + (hloaded candidate (by simp [hcandidate])) + have hclearedAssigned : βˆ€ candidate, candidate βˆ‰ rest β†’ + Function.update symbols tape (readSymbols cfg tape) candidate = + readSymbols cfg candidate := by + intro candidate hnot + by_cases heq : candidate = tape + Β· subst candidate + simp + Β· rw [Function.update_of_ne heq] + exact hassigned candidate (by simp [heq, hnot]) + obtain ⟨final, branchCost, branchSpace, hbranch, hfinalRepresents⟩ := + ih (symbols := Function.update symbols tape (readSymbols cfg tape)) + (store := cleared) hclearedRepresents hclearedOne + (List.nodup_cons.mp hnodup).2 hclearedLoaded hclearedAssigned + have hselectedBranch : + βˆƒ cost space, + Structured.Exec + ((fun code : Fin 4 => + dispatchSymbols tm bound cfg.state rest + (Function.update symbols tape (symbolAt code))) + ⟨symbolCode (readSymbols cfg tape), + symbolCode_lt_internal (readSymbols cfg tape)⟩) + cleared final + (dispatchSteps tm bound cfg.state (readSymbols cfg) rest) + cost space := by + refine ⟨branchCost, branchSpace, ?_⟩ + simpa [symbolAt_code_internal] using hbranch + obtain ⟨cost, space, hexec⟩ := Structured.Switch.select_exec + (fun code : Fin 4 => + dispatchSymbols tm bound cfg.state rest + (Function.update symbols tape (symbolAt code))) + store final (symbolCode_lt_internal (readSymbols cfg tape)) + htapeCode hone htestOne hselectedBranch + refine ⟨final, cost, space, ?_, hfinalRepresents⟩ + simpa [dispatchSymbols, dispatchSteps] using hexec + +theorem dispatchState_exec_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (hstate : store (stateScratchReg n bound) = stateCode tm cfg.state) + (hloaded : βˆ€ tape, store (symbolReg n bound tape) = + symbolCode (readSymbols cfg tape)) : + βˆƒ final cost space, + Structured.Exec (dispatchState tm bound) store final + (Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2)))) cost space ∧ + Represents tm bound next final := by + let cleared := Structured.Switch.cleared store (stateScratchReg n bound) + have hclearedRepresents : Represents tm bound cfg cleared := + cleared_represents hrepresents (stateScratchReg_ge_internal n bound) + have hclearedOne : cleared (oneReg n bound) = 1 := by + exact (cleared_apply_of_ne store (stateScratchReg_ne_one n bound).symm).trans hone + have hclearedLoaded : βˆ€ tape, + cleared (symbolReg n bound tape) = symbolCode (readSymbols cfg tape) := by + intro tape + exact (cleared_apply_of_ne store + (stateScratchReg_ne_symbolReg n bound tape)).trans (hloaded tape) + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩ = + cfg.state := by + exact (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + obtain ⟨final, branchCost, branchSpace, hbranch, hfinalRepresents⟩ := + dispatchSymbols_exec_internal + ((Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + (readSymbols cfg) (fun _ => Ξ“.blank) (List.finRange (n + 2)) + hbranchState hstep hclearedRepresents hheads hworkStart houtputStart + hclearedOne rfl (fun tape _ => hclearedLoaded tape) (by simp) + (List.nodup_finRange (n + 2)) + have hselectedBranch : + βˆƒ cost space, + Structured.Exec + ((fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm bound ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + cleared final + (dispatchSteps tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) cost space := by + refine ⟨branchCost, branchSpace, ?_⟩ + simpa [hbranchState] using hbranch + obtain ⟨cost, space, hexec⟩ := Structured.Switch.select_exec + (fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm bound ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + store final (stateCode_lt_internal tm cfg.state) hstate hone + (stateScratchReg_ne_one n bound) hselectedBranch + refine ⟨final, cost, space, ?_, hfinalRepresents⟩ + simpa [dispatchState] using hexec + +theorem program_exec_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) : + βˆƒ final cost space, + Structured.Exec (program tm bound) store final + (stepCount tm bound cfg) cost space ∧ + Represents tm bound next final := by + let loaded := Structured.Basic.execList (loadOps n bound) store + obtain ⟨loadCost, loadSpace, hloadExec⟩ := + Structured.Internal.exec_basics_exists (loadOps n bound) store + have hloaded := loadOps_loaded_internal hrepresents hwindow.2 + obtain ⟨final, dispatchCost, dispatchSpace, hdispatch, + hfinalRepresents⟩ := dispatchState_exec_internal hstep hloaded.1 + hwindow.2 hworkStart houtputStart hloaded.2.2.1 hloaded.2.2.2.1 + hloaded.2.2.2.2 + refine ⟨final, loadCost + dispatchCost, max loadSpace dispatchSpace, ?_, + hfinalRepresents⟩ + simpa [program, stepCount, loaded] using Structured.Exec.seq hloadExec hdispatch + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Layout.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Layout.lean new file mode 100644 index 0000000000..cf1cccfcb4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Layout.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Defs + +/-! +# TM-to-RAM step layout -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +variable {n bound : β„•} {tape : Fin (n + 2)} + +namespace Step + + +theorem symbolCode_lt_internal (symbol : Ξ“) : symbolCode symbol < 4 := by + cases symbol <;> decide + +theorem symbolAt_code_internal (symbol : Ξ“) : + symbolAt ⟨symbolCode symbol, symbolCode_lt_internal symbol⟩ = symbol := by + exact symbolDecode_code_internal symbol + +theorem stateCode_lt_internal (tm : TM n) (state : tm.Q) : + stateCode tm state < Fintype.card tm.Q := + (Fintype.equivFin tm.Q state).isLt + +theorem headReg_eq_fieldReg_internal (tape : Fin (n + 2)) : + headReg tape = fieldReg (headField (bound := bound) tape) := by + simp [headReg] + +theorem cellBase_add_eq_fieldReg_internal (tape : Fin (n + 2)) + (position : Fin (bound + 1)) : + cellBase n bound tape + position.val = fieldReg (cellField tape position) := by + simp [cellBase] + +theorem zeroReg_ge_internal (n bound : β„•) : + registerCount n bound ≀ zeroReg n bound := by + simp [zeroReg, scratchBase] + +theorem oneReg_ge_internal (n bound : β„•) : + registerCount n bound ≀ oneReg n bound := by + simp [oneReg, scratchBase] + +theorem stateScratchReg_ge_internal (n bound : β„•) : + registerCount n bound ≀ stateScratchReg n bound := by + simp [stateScratchReg, scratchBase] + +theorem addressReg_ge_internal (n bound : β„•) : + registerCount n bound ≀ addressReg n bound := by + simp [addressReg, scratchBase] + +theorem valueReg_ge_internal (n bound : β„•) : + registerCount n bound ≀ valueReg n bound := by + simp [valueReg, scratchBase] + +theorem symbolReg_ge_internal (n bound : β„•) (tape : Fin (n + 2)) : + registerCount n bound ≀ symbolReg n bound tape := by + simp [symbolReg, scratchBase] + omega + +theorem scratch_lt_registerLimit_internal (n bound : β„•) : + zeroReg n bound < registerLimit n bound ∧ + oneReg n bound < registerLimit n bound ∧ + stateScratchReg n bound < registerLimit n bound ∧ + addressReg n bound < registerLimit n bound ∧ + valueReg n bound < registerLimit n bound ∧ + βˆ€ tape, symbolReg n bound tape < registerLimit n bound := by + constructor + Β· simp [zeroReg, scratchBase, registerLimit] + omega + constructor + Β· simp [oneReg, scratchBase, registerLimit] + omega + constructor + Β· simp [stateScratchReg, scratchBase, registerLimit] + omega + constructor + Β· simp [addressReg, scratchBase, registerLimit] + omega + constructor + Β· simp [valueReg, scratchBase, registerLimit] + omega + Β· intro tape + simp [symbolReg, scratchBase, registerLimit] + omega + +theorem encodeRegs_storeBounded_internal (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (hheads : HeadsBounded cfg bound) : + StoreBounded tm bound (encodeRegs tm bound cfg) := by + constructor + Β· intro reg hnonzero + have hreg : reg < registerCount n bound := by + by_contra hnot + have hzero := encodeRegs_outside_internal tm bound cfg (Nat.le_of_not_gt hnot) + exact hnonzero hzero + exact lt_trans hreg (by + simp [registerLimit, scratchBase] + omega) + Β· intro reg + by_cases hreg : reg < registerCount n bound + Β· rw [encodeRegs, dif_pos hreg] + let field := (fieldEquiv n bound).symm ⟨reg, hreg⟩ + change fieldValue tm bound cfg field ≀ wordBound tm bound + rcases field with state | headOrCell + Β· exact le_trans (Nat.le_of_lt (stateCode_lt_internal tm cfg.state)) + (le_trans (le_max_left _ _) (le_max_right _ _)) + Β· rcases headOrCell with tape | cell + Β· exact le_trans (hheads tape) (le_trans (Nat.le_succ bound) + (le_trans (le_max_right _ _) (le_max_right _ _))) + Β· rcases cell with ⟨tape, position⟩ + have hcode : symbolCode ((tapeAt cfg tape).cells position.val) ≀ 3 := by + cases (tapeAt cfg tape).cells position.val <;> decide + have hthree : 3 ≀ registerLimit n bound := by + simp [registerLimit, scratchBase, registerCount] + exact le_trans hcode + (le_trans hthree (le_max_left _ _)) + Β· simp [encodeRegs, hreg] + +theorem loadTapeOps_represents_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) (tape : Fin (n + 2)) : + Represents tm bound cfg + (Structured.Basic.execList (loadTapeOps n bound tape) store) := by + simp only [loadTapeOps, Structured.Basic.execList, Structured.Basic.exec] + apply Represents.update_outside_internal + Β· apply Represents.update_outside_internal + Β· exact hrepresents.update_outside_internal (addressReg_ge_internal n bound) + Β· exact addressReg_ge_internal n bound + Β· exact symbolReg_ge_internal n bound tape + +theorem loadTapeOps_symbol_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hhead : (tapeAt cfg tape).head ≀ bound) : + Structured.Basic.execList (loadTapeOps n bound tape) store + (symbolReg n bound tape) = + symbolCode ((tapeAt cfg tape).read) := by + have hheadValue := hrepresents (headField (bound := bound) tape) + rw [← headReg_eq_fieldReg_internal] at hheadValue + change store (headReg tape) = (tapeAt cfg tape).head at hheadValue + let position : Fin (bound + 1) := ⟨(tapeAt cfg tape).head, by omega⟩ + have hcellValue := hrepresents (cellField tape position) + rw [← cellBase_add_eq_fieldReg_internal] at hcellValue + change store (cellBase n bound tape + position.val) = + symbolCode ((tapeAt cfg tape).cells position.val) at hcellValue + have haddressHead : addressReg n bound β‰  headReg tape := by + intro heq + have hfield := fieldReg_lt_internal + (headField (bound := bound) tape) + rw [← headReg_eq_fieldReg_internal] at hfield + have hscratch := addressReg_ge_internal n bound + omega + have haddressCell : + addressReg n bound β‰  cellBase n bound tape + position.val := by + rw [cellBase_add_eq_fieldReg_internal] + exact ne_of_gt (lt_of_lt_of_le (fieldReg_lt_internal _) (addressReg_ge_internal n bound)) + let first := + (Structured.Basic.imm (addressReg n bound) (cellBase n bound tape)).exec store + let addressed := + (Structured.Basic.add (addressReg n bound) (addressReg n bound) + (headReg tape)).exec first + have hfirstHead : first (headReg tape) = store (headReg tape) := by + simp [first, Structured.Basic.exec, Function.update_of_ne (Ne.symm haddressHead)] + have hfirstAddress : first (addressReg n bound) = cellBase n bound tape := by + simp [first, Structured.Basic.exec] + have haddressedAddress : + addressed (addressReg n bound) = + cellBase n bound tape + (tapeAt cfg tape).head := by + simp only [addressed, Structured.Basic.exec, Function.update_self] + rw [hfirstAddress, hfirstHead, hheadValue] + have haddressedCell : + addressed (cellBase n bound tape + position.val) = + store (cellBase n bound tape + position.val) := by + simp [addressed, first, Structured.Basic.exec, + Function.update_of_ne (Ne.symm haddressCell)] + change ((Structured.Basic.load (symbolReg n bound tape) (addressReg n bound)).exec + addressed) (symbolReg n bound tape) = _ + simp only [Structured.Basic.exec, Function.update_self] + rw [haddressedAddress] + change addressed (cellBase n bound tape + position.val) = _ + rw [haddressedCell, hcellValue] + rfl + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Load.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Load.lean new file mode 100644 index 0000000000..589faf65bf --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Load.lean @@ -0,0 +1,362 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Layout +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources + +/-! +# Loading represented TM states and head symbols -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Step + + +private theorem execList_append (first second : List Structured.Basic) + (store : Structured.Store) : + Structured.Basic.execList (first ++ second) store = + Structured.Basic.execList second (Structured.Basic.execList first store) := by + induction first generalizing store with + | nil => rfl + | cons op rest ih => + simp [Structured.Basic.execList, ih] + +private theorem loadTapeOps_apply_of_ne (n bound : β„•) + (tape : Fin (n + 2)) (store : Structured.Store) (reg : β„•) + (haddress : reg β‰  addressReg n bound) + (hsymbol : reg β‰  symbolReg n bound tape) : + Structured.Basic.execList (loadTapeOps n bound tape) store reg = store reg := by + simp [loadTapeOps, Structured.Basic.execList, Structured.Basic.exec, + Function.update_of_ne haddress, Function.update_of_ne hsymbol] + +private theorem symbolReg_injective (n bound : β„•) : + Function.Injective (symbolReg n bound) := by + intro first second heq + apply Fin.ext + simp [symbolReg] at heq + omega + +/-- Semantic facts established for a processed prefix of named tapes. -/ +private structure LoadedPrefix (tm : TM n) (bound : β„•) + (cfg : Complexity.Cfg n tm.Q) (processed : List (Fin (n + 2))) + (store : Structured.Store) : Prop where + represents : Represents tm bound cfg store + zero : store (zeroReg n bound) = 0 + one : store (oneReg n bound) = 1 + state : store (stateScratchReg n bound) = stateCode tm cfg.state + symbols : βˆ€ tape, tape ∈ processed β†’ + store (symbolReg n bound tape) = symbolCode (readSymbols cfg tape) + +private theorem setup_loadedPrefix {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) : + LoadedPrefix tm bound cfg [] + (Structured.Basic.execList (setupOps n bound) store) := by + have hstate := hrepresents (stateField (n := n) (bound := bound)) + rw [fieldReg_state_internal] at hstate + change store 0 = stateCode tm cfg.state at hstate + let first := (Structured.Basic.imm (zeroReg n bound) 0).exec store + let second := (Structured.Basic.imm (oneReg n bound) 1).exec first + let final := (Structured.Basic.add (stateScratchReg n bound) 0 + (zeroReg n bound)).exec second + have hzeroOne : zeroReg n bound β‰  oneReg n bound := by + simp [zeroReg, oneReg] + have hzeroState : zeroReg n bound β‰  stateScratchReg n bound := by + simp [zeroReg, stateScratchReg] + have honeState : oneReg n bound β‰  stateScratchReg n bound := by + simp [oneReg, stateScratchReg] + have hzeroNonzero : zeroReg n bound β‰  0 := by + simp [zeroReg, scratchBase, registerCount] + have honeNonzero : oneReg n bound β‰  0 := by + simp [oneReg, scratchBase, registerCount] + have hrepFirst : Represents tm bound cfg first := by + exact hrepresents.update_outside_internal (zeroReg_ge_internal n bound) + have hrepSecond : Represents tm bound cfg second := by + exact hrepFirst.update_outside_internal (oneReg_ge_internal n bound) + have hrepFinal : Represents tm bound cfg final := by + exact hrepSecond.update_outside_internal (stateScratchReg_ge_internal n bound) + have hzeroFinal : final (zeroReg n bound) = 0 := by + simp [final, second, first, Structured.Basic.exec, + Function.update_of_ne hzeroState, + Function.update_of_ne hzeroOne] + have honeFinal : final (oneReg n bound) = 1 := by + simp [final, second, first, Structured.Basic.exec, + Function.update_of_ne honeState] + have hstateFinal : final (stateScratchReg n bound) = stateCode tm cfg.state := by + have hsecondSource : second 0 = store 0 := by + simp [second, first, Structured.Basic.exec, + Function.update_of_ne (Ne.symm hzeroNonzero), + Function.update_of_ne (Ne.symm honeNonzero)] + have hsecondZero : second (zeroReg n bound) = 0 := by + simp [second, first, Structured.Basic.exec, + Function.update_of_ne hzeroOne] + simp only [final, Structured.Basic.exec, Function.update_self] + rw [hsecondSource, hsecondZero, hstate] + rfl + simpa [setupOps, Structured.Basic.execList, first, second, final] using + LoadedPrefix.mk hrepFinal hzeroFinal honeFinal hstateFinal (by simp) + +private theorem loadTape_loadedPrefix {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {processed : List (Fin (n + 2))} + {store : Structured.Store} (hloaded : LoadedPrefix tm bound cfg processed store) + (tape : Fin (n + 2)) + (hhead : (tapeAt cfg tape).head ≀ bound) : + LoadedPrefix tm bound cfg (tape :: processed) + (Structured.Basic.execList (loadTapeOps n bound tape) store) := by + let final := Structured.Basic.execList (loadTapeOps n bound tape) store + have haddressZero : zeroReg n bound β‰  addressReg n bound := by + simp [zeroReg, addressReg] + have hsymbolZero : zeroReg n bound β‰  symbolReg n bound tape := by + simp [zeroReg, symbolReg] + omega + have haddressOne : oneReg n bound β‰  addressReg n bound := by + simp [oneReg, addressReg] + have hsymbolOne : oneReg n bound β‰  symbolReg n bound tape := by + simp [oneReg, symbolReg] + omega + have haddressState : stateScratchReg n bound β‰  addressReg n bound := by + simp [stateScratchReg, addressReg] + have hsymbolState : stateScratchReg n bound β‰  symbolReg n bound tape := by + simp [stateScratchReg, symbolReg] + omega + refine ⟨loadTapeOps_represents_internal hloaded.represents tape, + loadTapeOps_apply_of_ne n bound tape store (zeroReg n bound) + haddressZero hsymbolZero β–Έ hloaded.zero, + loadTapeOps_apply_of_ne n bound tape store (oneReg n bound) + haddressOne hsymbolOne β–Έ hloaded.one, + loadTapeOps_apply_of_ne n bound tape store (stateScratchReg n bound) + haddressState hsymbolState β–Έ hloaded.state, ?_⟩ + intro candidate hmem + rcases List.mem_cons.mp hmem with heq | hprocessed + Β· subst candidate + exact loadTapeOps_symbol_internal hloaded.represents hhead + Β· by_cases heq : candidate = tape + Β· subst candidate + exact loadTapeOps_symbol_internal hloaded.represents hhead + Β· rw [loadTapeOps_apply_of_ne n bound tape store (symbolReg n bound candidate)] + Β· exact hloaded.symbols candidate hprocessed + Β· simp [symbolReg, addressReg] + omega + Β· exact fun hregs => heq (symbolReg_injective n bound hregs) + +private theorem loadTapes_loadedPrefix {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} (tapes processed : List (Fin (n + 2))) + {store : Structured.Store} (hloaded : LoadedPrefix tm bound cfg processed store) + (hheads : HeadsBounded cfg bound) : + LoadedPrefix tm bound cfg (tapes.reverse ++ processed) + (Structured.Basic.execList (tapes.flatMap (loadTapeOps n bound)) store) := by + induction tapes generalizing processed store with + | nil => simpa using! hloaded + | cons tape rest ih => + have hnext := loadTape_loadedPrefix hloaded tape (hheads tape) + have hfinal := ih (processed := tape :: processed) hnext + simpa [List.flatMap_cons, Structured.Basic.execList, execList_append, + List.reverse_cons, List.append_assoc] using hfinal + +theorem loadOps_loaded_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) : + let final := Structured.Basic.execList (loadOps n bound) store + Represents tm bound cfg final ∧ + final (zeroReg n bound) = 0 ∧ + final (oneReg n bound) = 1 ∧ + final (stateScratchReg n bound) = stateCode tm cfg.state ∧ + βˆ€ tape, final (symbolReg n bound tape) = + symbolCode (readSymbols cfg tape) := by + let setup := Structured.Basic.execList (setupOps n bound) store + have hsetup := setup_loadedPrefix hrepresents + have hloaded := loadTapes_loadedPrefix (List.finRange (n + 2)) [] hsetup + hheads + rw [loadOps, execList_append] + exact ⟨hloaded.represents, hloaded.zero, hloaded.one, hloaded.state, + fun tape => hloaded.symbols tape (by simp)⟩ + +private theorem registerCount_lt_registerLimit (n bound : β„•) : + registerCount n bound < registerLimit n bound := by + simp [registerLimit, scratchBase] + omega + +private theorem registerLimit_le_wordBound (tm : TM n) (bound : β„•) : + registerLimit n bound ≀ wordBound tm bound := + le_max_left _ _ + +private theorem setupOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + Structured.Internal.Basic.EnvelopeChain (registerLimit n bound) + (wordBound tm bound) (setupOps n bound) store := by + let first := (Structured.Basic.imm (zeroReg n bound) 0).exec store + let second := (Structured.Basic.imm (oneReg n bound) 1).exec first + let final := (Structured.Basic.add (stateScratchReg n bound) 0 + (zeroReg n bound)).exec second + have hscratch := scratch_lt_registerLimit_internal n bound + have hfirst : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) first := by + apply henvelope.execBasic + Β· exact hscratch.1 + Β· simp [Structured.Internal.Basic.writeValue] + have honeValue : 1 ≀ wordBound tm bound := by + have hpositive : 1 ≀ registerLimit n bound := by + simp [registerLimit, scratchBase, registerCount] + exact le_trans hpositive (registerLimit_le_wordBound tm bound) + have hsecond : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) second := by + apply hfirst.execBasic + Β· exact hscratch.2.1 + Β· simpa [Structured.Internal.Basic.writeValue] using honeValue + have hstateStore : store 0 = stateCode tm cfg.state := by + have hstate := hrepresents (stateField (n := n) (bound := bound)) + simpa [fieldReg_state_internal, fieldValue] using! hstate + have hsecondSource : second 0 = store 0 := by + simp [second, first, Structured.Basic.exec, zeroReg, oneReg, scratchBase, + registerCount, Function.update_of_ne] + have hsecondZero : second (zeroReg n bound) = 0 := by + simp [second, first, Structured.Basic.exec, zeroReg, oneReg, + Function.update_of_ne] + have hstateBound : stateCode tm cfg.state ≀ wordBound tm bound := by + exact le_trans (Nat.le_of_lt (stateCode_lt_internal tm cfg.state)) + (le_trans (le_max_left _ _) (le_max_right _ _)) + have hfinal : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) final := by + apply hsecond.execBasic + Β· exact hscratch.2.2.1 + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hsecondSource, hsecondZero, hstateStore, Nat.add_zero] + exact hstateBound + simpa [setupOps, first, second, final] using! + And.intro henvelope (And.intro hfirst (And.intro hsecond hfinal)) + +private theorem loadTapeOps_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (tape : Fin (n + 2)) (hhead : (tapeAt cfg tape).head ≀ bound) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + Structured.Internal.Basic.EnvelopeChain (registerLimit n bound) + (wordBound tm bound) (loadTapeOps n bound tape) store := by + let first := + (Structured.Basic.imm (addressReg n bound) (cellBase n bound tape)).exec store + let addressed := + (Structured.Basic.add (addressReg n bound) (addressReg n bound) + (headReg tape)).exec first + let final := + (Structured.Basic.load (symbolReg n bound tape) (addressReg n bound)).exec addressed + have hscratch := scratch_lt_registerLimit_internal n bound + have hbaseLt : cellBase n bound tape < registerCount n bound := by + have hfield := fieldReg_lt_internal + (cellField tape (⟨0, by omega⟩ : Fin (bound + 1))) + rw [← cellBase_add_eq_fieldReg_internal] at hfield + simpa using hfield + have hbaseBound : cellBase n bound tape ≀ wordBound tm bound := by + exact le_trans (Nat.le_of_lt hbaseLt) + (le_trans (Nat.le_of_lt (registerCount_lt_registerLimit n bound)) + (registerLimit_le_wordBound tm bound)) + have hfirst : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) first := by + apply henvelope.execBasic + Β· exact hscratch.2.2.2.1 + Β· simpa [Structured.Internal.Basic.writeValue] using hbaseBound + have hstoreHead : store (headReg tape) = (tapeAt cfg tape).head := by + have hvalue := hrepresents (headField (bound := bound) tape) + rwa [← headReg_eq_fieldReg_internal] at hvalue + have hfirstAddress : first (addressReg n bound) = cellBase n bound tape := by + simp [first, Structured.Basic.exec] + have hfirstHead : first (headReg tape) = store (headReg tape) := by + have hne : headReg tape β‰  addressReg n bound := by + intro heq + have hheadReg := fieldReg_lt_internal (headField (bound := bound) tape) + rw [← headReg_eq_fieldReg_internal] at hheadReg + have haddress := addressReg_ge_internal n bound + omega + simp [first, Structured.Basic.exec, Function.update_of_ne hne] + let position : Fin (bound + 1) := ⟨(tapeAt cfg tape).head, by omega⟩ + have haddressedLt : + cellBase n bound tape + (tapeAt cfg tape).head < registerCount n bound := by + change cellBase n bound tape + position.val < registerCount n bound + rw [cellBase_add_eq_fieldReg_internal] + exact fieldReg_lt_internal _ + have haddressedBound : + cellBase n bound tape + (tapeAt cfg tape).head ≀ wordBound tm bound := by + exact le_trans (Nat.le_of_lt haddressedLt) + (le_trans (Nat.le_of_lt (registerCount_lt_registerLimit n bound)) + (registerLimit_le_wordBound tm bound)) + have haddressed : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) addressed := by + apply hfirst.execBasic + Β· exact hscratch.2.2.2.1 + Β· simp only [Structured.Internal.Basic.writeValue] + rw [hfirstAddress, hfirstHead, hstoreHead] + exact haddressedBound + have hfinal : Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) final := by + apply haddressed.execBasic + Β· exact hscratch.2.2.2.2.2 tape + Β· exact haddressed.value_le (addressed (addressReg n bound)) + simpa [loadTapeOps, first, addressed, final] using! + And.intro henvelope (And.intro hfirst (And.intro haddressed hfinal)) + +private theorem loadTapes_envelopeChain {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} (tapes : List (Fin (n + 2))) + {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + Structured.Internal.Basic.EnvelopeChain (registerLimit n bound) + (wordBound tm bound) (tapes.flatMap (loadTapeOps n bound)) store := by + induction tapes generalizing store with + | nil => exact henvelope + | cons tape rest ih => + have hfirst := loadTapeOps_envelopeChain hrepresents tape (hheads tape) henvelope + have hfirstEnvelope := hfirst.final + have hfirstRepresents := loadTapeOps_represents_internal hrepresents tape + have hrest := ih hfirstRepresents hfirstEnvelope + simpa [List.flatMap_cons] using hfirst.append hrest + +theorem loadOps_measured_internal {tm : TM n} {bound : β„•} + {cfg : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (henvelope : Structured.Internal.StoreEnvelope + (registerLimit n bound) (wordBound tm bound) store) : + let final := Structured.Basic.execList (loadOps n bound) store + Structured.Internal.MeasuredRuns (.basics (loadOps n bound)) store final + (loadOps n bound).length + (4 * (loadOps n bound).length * wordWidth tm bound) + (spaceBound tm bound) ∧ + Structured.Internal.StoreEnvelope (registerLimit n bound) + (wordBound tm bound) final := by + have hsetup := setupOps_envelopeChain hrepresents henvelope + have hsetupRepresents := (setup_loadedPrefix hrepresents).represents + have htapes := loadTapes_envelopeChain (List.finRange (n + 2)) + hsetupRepresents hheads hsetup.final + have hchain : Structured.Internal.Basic.EnvelopeChain (registerLimit n bound) + (wordBound tm bound) (loadOps n bound) store := by + simpa [loadOps] using hsetup.append htapes + have hmeasured := Structured.Internal.MeasuredRuns.basicsEnvelopeChain + (loadOps n bound) store hchain + simpa [wordWidth, spaceBound, Structured.Internal.valueWidth, + Structured.Internal.envelopeSpace] using hmeasured + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Resources.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Resources.lean new file mode 100644 index 0000000000..d267389bb0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Step/Internal/Resources.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Action +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Step.Internal.Load +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch + +/-! +# Resource bounds for one TM-to-RAM transition -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace TMConfig + +namespace Step + + +/-- Register and word bounds preserved by a simulated Turing-machine step. -/ +abbrev StepEnvelope (tm : TM n) (bound : β„•) := + Structured.Internal.StoreEnvelope (registerLimit n bound) (wordBound tm bound) + +private theorem cleared_envelope {tm : TM n} {bound test : β„•} + {store : Structured.Store} (henvelope : StepEnvelope tm bound store) + (htest : test < registerLimit n bound) : + StepEnvelope tm bound (Structured.Switch.cleared store test) := by + exact henvelope.update htest (by simp) + +private theorem cleared_apply_of_ne' (store : Structured.Store) {test reg : β„•} + (hne : reg β‰  test) : + Structured.Switch.cleared store test reg = store reg := by + simp [Structured.Switch.cleared, Function.update_of_ne hne] + +private theorem symbolReg_injective' (n bound : β„•) : + Function.Injective (symbolReg n bound) := by + intro first second heq + apply Fin.ext + simp [symbolReg] at heq + omega + +private theorem symbolReg_ne_one' (n bound : β„•) (tape : Fin (n + 2)) : + symbolReg n bound tape β‰  oneReg n bound := by + simp [symbolReg, oneReg] + omega + +private theorem stateScratchReg_ne_one' (n bound : β„•) : + stateScratchReg n bound β‰  oneReg n bound := by + simp [stateScratchReg, oneReg] + +private theorem stateScratchReg_ne_symbolReg' (n bound : β„•) + (tape : Fin (n + 2)) : + symbolReg n bound tape β‰  stateScratchReg n bound := by + simp [symbolReg, stateScratchReg] + omega + +theorem dispatchSymbols_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (state : tm.Q) (actual symbols : Fin (n + 2) β†’ Ξ“) + (remaining : List (Fin (n + 2))) + (hstate : state = cfg.state) + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (hactual : actual = readSymbols cfg) + (hloaded : βˆ€ tape, tape ∈ remaining β†’ + store (symbolReg n bound tape) = symbolCode (actual tape)) + (hassigned : βˆ€ tape, tape βˆ‰ remaining β†’ symbols tape = actual tape) + (hnodup : remaining.Nodup) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns + (dispatchSymbols tm bound state remaining symbols) store final + (dispatchSteps tm bound state actual remaining) + (dispatchCost tm bound state actual remaining) (spaceBound tm bound) ∧ + Represents tm bound next final ∧ StepEnvelope tm bound final := by + subst state + subst actual + induction remaining generalizing symbols store with + | nil => + have hsymbols : symbols = readSymbols cfg := by + funext tape + exact hassigned tape (by simp) + subst symbols + let final := Structured.Basic.execList + (actionOps tm bound cfg.state (readSymbols cfg)) store + have haction := actionOps_measured_internal hstep hrepresents hheads + hworkStart houtputStart hone henvelope + refine ⟨final, ?_, haction.2.1, haction.2.2⟩ + simpa [dispatchSymbols, dispatchSteps, dispatchCost, final] using haction.1 + | cons tape rest ih => + have htapeCode := hloaded tape (by simp) + have htestOne : symbolReg n bound tape β‰  oneReg n bound := + symbolReg_ne_one' n bound tape + let cleared := Structured.Switch.cleared store (symbolReg n bound tape) + have hclearedRepresents : Represents tm bound cfg cleared := by + exact hrepresents.update_outside_internal (symbolReg_ge_internal n bound tape) + have hclearedOne : cleared (oneReg n bound) = 1 := by + exact (cleared_apply_of_ne' store htestOne.symm).trans hone + have hclearedEnvelope : StepEnvelope tm bound cleared := + cleared_envelope henvelope + ((scratch_lt_registerLimit_internal n bound).2.2.2.2.2 tape) + have hclearedLoaded : βˆ€ candidate, candidate ∈ rest β†’ + cleared (symbolReg n bound candidate) = + symbolCode (readSymbols cfg candidate) := by + intro candidate hcandidate + have hne : candidate β‰  tape := by + intro heq + subst candidate + exact (List.nodup_cons.mp hnodup).1 hcandidate + have hregs : symbolReg n bound candidate β‰  symbolReg n bound tape := + fun heq => hne ((symbolReg_injective' n bound) heq) + exact (cleared_apply_of_ne' store hregs).trans + (hloaded candidate (by simp [hcandidate])) + have hclearedAssigned : βˆ€ candidate, candidate βˆ‰ rest β†’ + Function.update symbols tape (readSymbols cfg tape) candidate = + readSymbols cfg candidate := by + intro candidate hnot + by_cases heq : candidate = tape + Β· subst candidate + simp + Β· rw [Function.update_of_ne heq] + exact hassigned candidate (by simp [heq, hnot]) + obtain ⟨final, hbranch, hfinalRepresents, hfinalEnvelope⟩ := + ih (symbols := Function.update symbols tape (readSymbols cfg tape)) + (store := cleared) hclearedRepresents hclearedOne + (hnodup := (List.nodup_cons.mp hnodup).2) + (henvelope := hclearedEnvelope) hclearedLoaded hclearedAssigned + have hselectedBranch : Structured.Internal.MeasuredRuns + ((fun code : Fin 4 => + dispatchSymbols tm bound cfg.state rest + (Function.update symbols tape (symbolAt code))) + ⟨symbolCode (readSymbols cfg tape), + symbolCode_lt_internal (readSymbols cfg tape)⟩) + cleared final + (dispatchSteps tm bound cfg.state (readSymbols cfg) rest) + (dispatchCost tm bound cfg.state (readSymbols cfg) rest) + (spaceBound tm bound) := by + simpa [symbolAt_code_internal] using hbranch + have hrun := Structured.Switch.select_measured + (fun code : Fin 4 => + dispatchSymbols tm bound cfg.state rest + (Function.update symbols tape (symbolAt code))) + store final (symbolCode_lt_internal (readSymbols cfg tape)) + htapeCode hone htestOne + ((scratch_lt_registerLimit_internal n bound).2.2.2.2.2 tape) + henvelope hselectedBranch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [dispatchSymbols, dispatchSteps, dispatchCost, wordWidth, + Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace] using hrun + +theorem dispatchState_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hheads : HeadsBounded cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (hone : store (oneReg n bound) = 1) + (hstate : store (stateScratchReg n bound) = stateCode tm cfg.state) + (hloaded : βˆ€ tape, store (symbolReg n bound tape) = + symbolCode (readSymbols cfg tape)) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (dispatchState tm bound) store final + (Structured.Switch.stepCount (stateCode tm cfg.state) + (dispatchSteps tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2)))) + (Structured.Switch.costBound (stateCode tm cfg.state) + (dispatchCost tm bound cfg.state (readSymbols cfg) + (List.finRange (n + 2))) (wordWidth tm bound)) + (spaceBound tm bound) ∧ + Represents tm bound next final ∧ StepEnvelope tm bound final := by + let cleared := Structured.Switch.cleared store (stateScratchReg n bound) + have hclearedRepresents : Represents tm bound cfg cleared := by + exact hrepresents.update_outside_internal (stateScratchReg_ge_internal n bound) + have hclearedOne : cleared (oneReg n bound) = 1 := by + exact (cleared_apply_of_ne' store (stateScratchReg_ne_one' n bound).symm).trans hone + have hclearedEnvelope : StepEnvelope tm bound cleared := + cleared_envelope henvelope + (scratch_lt_registerLimit_internal n bound).2.2.1 + have hclearedLoaded : βˆ€ tape, + cleared (symbolReg n bound tape) = symbolCode (readSymbols cfg tape) := by + intro tape + exact (cleared_apply_of_ne' store + (stateScratchReg_ne_symbolReg' n bound tape)).trans (hloaded tape) + have hbranchState : + (Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩ = + cfg.state := + (Fintype.equivFin tm.Q).symm_apply_apply cfg.state + obtain ⟨final, hbranch, hfinalRepresents, hfinalEnvelope⟩ := + dispatchSymbols_measured_internal + ((Fintype.equivFin tm.Q).symm + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + (readSymbols cfg) (fun _ => Ξ“.blank) (List.finRange (n + 2)) + hbranchState hstep hclearedRepresents hheads hworkStart houtputStart + hclearedOne rfl (fun tape _ => hclearedLoaded tape) (by simp) + (List.nodup_finRange (n + 2)) hclearedEnvelope + have hselectedBranch : Structured.Internal.MeasuredRuns + ((fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm bound ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + ⟨stateCode tm cfg.state, stateCode_lt_internal tm cfg.state⟩) + cleared final + (dispatchSteps tm bound cfg.state (readSymbols cfg) (List.finRange (n + 2))) + (dispatchCost tm bound cfg.state (readSymbols cfg) (List.finRange (n + 2))) + (spaceBound tm bound) := by + simpa [hbranchState] using hbranch + have hrun := Structured.Switch.select_measured + (fun stateCode : Fin (Fintype.card tm.Q) => + dispatchSymbols tm bound ((Fintype.equivFin tm.Q).symm stateCode) + (List.finRange (n + 2)) (fun _ => Ξ“.blank)) + store final (stateCode_lt_internal tm cfg.state) hstate hone + (stateScratchReg_ne_one' n bound) + (scratch_lt_registerLimit_internal n bound).2.2.1 henvelope hselectedBranch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [dispatchState, wordWidth, Structured.Internal.valueWidth, spaceBound, + Structured.Internal.envelopeSpace] using hrun + +theorem program_measured_internal {tm : TM n} {bound : β„•} + {cfg next : Complexity.Cfg n tm.Q} {store : Structured.Store} + (hstep : tm.step cfg = some next) + (hrepresents : Represents tm bound cfg store) + (hwindow : WithinWindow cfg bound) + (hworkStart : βˆ€ i, (cfg.work i).cells 0 = Ξ“.start) + (houtputStart : cfg.output.cells 0 = Ξ“.start) + (henvelope : StepEnvelope tm bound store) : + βˆƒ final, + Structured.Internal.MeasuredRuns (program tm bound) store final + (stepCount tm bound cfg) (timeBound tm bound cfg) (spaceBound tm bound) ∧ + Represents tm bound next final ∧ StepEnvelope tm bound final := by + let loaded := Structured.Basic.execList (loadOps n bound) store + have hload := loadOps_measured_internal hrepresents hwindow.2 henvelope + have hloaded := loadOps_loaded_internal hrepresents hwindow.2 + obtain ⟨final, hdispatch, hfinalRepresents, hfinalEnvelope⟩ := + dispatchState_measured_internal hstep hloaded.1 hwindow.2 hworkStart + houtputStart hloaded.2.2.1 hloaded.2.2.2.1 hloaded.2.2.2.2 hload.2 + have hrun := hload.1.seq hdispatch + refine ⟨final, ?_, hfinalRepresents, hfinalEnvelope⟩ + simpa [program, stepCount, timeBound, loaded] using hrun + +end Step + +end TMConfig + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Soundness.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Soundness.lean new file mode 100644 index 0000000000..82718f49db --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Soundness.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import Mathlib.Data.Nat.Size + +/-! +# Why the RAM must use logarithmic cost: a formal soundness theorem + +This module turns the model's central design decision into a theorem. A RAM +stores unbounded natural numbers in each register. Under the **unit-cost** +measure (one time unit per instruction, `RAM.unitTimeUpto`) a program can +repeatedly *square* a register, reaching `2 ^ (2 ^ k)` in `k + 1` steps. That +number has `2 ^ k + 1` binary digits, so any Turing machine needs at least +`2 ^ k` steps merely to write it: unit-cost RAM time is super-polynomially +stronger than Turing time, and the two models are **not** polynomially +equivalent. + +`RAM.logGap_squaring` proves exactly this gap for the squaring program family +`RAM.sqProg`: on the same run, the unit time is `k + 1` while the logarithmic +time (`RAM.logTimeUpto`, which charges each instruction the bit-length of the +numbers it manipulates) is at least `2 ^ k`. This is why the library adopts the +logarithmic cost measure and never the unit-cost one β€” the difference is not a +convention but the boundary between a sound Turing-equivalent model and a +"reward-hacked" one that decides more than it should in polynomial time. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +/-- The `k`-fold squaring program: load `2` into register `1`, then square + register `1` a total of `k` times. After `j + 1` steps register `1` holds + `2 ^ (2 ^ j)`. -/ +def sqProg (k : β„•) : Program := + Instr.imm 1 2 :: List.replicate k (Instr.mul 1 1 1) + +/-- The start configuration for the squaring family: program counter `0`, all + registers `0`. -/ +def sqStart : Cfg := ⟨0, fun _ => 0⟩ + +/-- The configuration after `j + 1` steps of `sqProg`: program counter `j + 1`, + register `1` holding `2 ^ (2 ^ j)`, all other registers `0`. -/ +private def sqCfg (j : β„•) : Cfg := ⟨j + 1, fun i => if i = 1 then 2 ^ (2 ^ j) else 0⟩ + +private theorem sqProg_length (k : β„•) : (sqProg k).length = k + 1 := by + simp [sqProg] + +private theorem sqProg_getElem_zero (k : β„•) : + (sqProg k)[(0 : β„•)]? = some (Instr.imm 1 2) := rfl + +private theorem sqProg_getElem_succ {k j : β„•} (hj : j < k) : + (sqProg k)[j + 1]? = some (Instr.mul 1 1 1) := by + simp only [sqProg, List.getElem?_cons_succ, List.getElem?_replicate, ite_eq_left hj] + +/-- Squaring `2 ^ (2 ^ j)` yields `2 ^ (2 ^ (j + 1))`. -/ +private theorem sq_pow (j : β„•) : 2 ^ 2 ^ j * 2 ^ 2 ^ j = 2 ^ 2 ^ (j + 1) := by + rw [← pow_add] + congr 1 + rw [pow_succ] + ring + +/-- One step from the start runs the `imm` instruction, reaching `sqCfg 0`. -/ +private theorem step_sqStart (k : β„•) : step (sqProg k) sqStart = sqCfg 0 := by + have hcur : curInstr (sqProg k) sqStart = Instr.imm 1 2 := by + unfold curInstr; rw [show sqStart.pc = 0 from rfl, sqProg_getElem_zero]; rfl + unfold step + rw [hcur] + ext i + Β· rfl + Β· show Function.update sqStart.regs 1 2 i = (sqCfg 0).regs i + by_cases hi : i = 1 + Β· subst hi; rw [Function.update_self]; rfl + Β· rw [Function.update_of_ne hi] + simp only [sqStart, sqCfg, ite_eq_right hi] + +/-- One squaring step from `sqCfg j` reaches `sqCfg (j + 1)`, provided the + `(j + 1)`-th instruction is a `mul` (i.e. `j < k`). -/ +private theorem step_sqCfg {k j : β„•} (hj : j < k) : + step (sqProg k) (sqCfg j) = sqCfg (j + 1) := by + have hcur : curInstr (sqProg k) (sqCfg j) = Instr.mul 1 1 1 := by + unfold curInstr + rw [show (sqCfg j).pc = j + 1 from rfl, sqProg_getElem_succ hj]; rfl + unfold step + rw [hcur] + ext i + Β· rfl + Β· show Function.update (sqCfg j).regs 1 ((sqCfg j).regs 1 * (sqCfg j).regs 1) i + = (sqCfg (j + 1)).regs i + by_cases hi : i = 1 + Β· subst hi; rw [Function.update_self]; exact sq_pow j + Β· rw [Function.update_of_ne hi] + simp only [sqCfg, ite_eq_right hi] + +/-- The run invariant: `j + 1` steps of `sqProg k` from the start reach + `sqCfg j`, for every `j ≀ k`. -/ +private theorem sqRun {k : β„•} : βˆ€ j, j ≀ k β†’ run (sqProg k) (j + 1) sqStart = sqCfg j := by + intro j + induction j with + | zero => + intro _ + rw [run_one, step_sqStart] + | succ j ih => + intro hj + rw [run_succ_step, ih (by omega), step_sqCfg (by omega)] + +/-- The program counter after `j` steps is exactly `j`, for `j ≀ k`. -/ +private theorem sqRun_pc {k : β„•} {j : β„•} (hj : j ≀ k) : + (run (sqProg k) j sqStart).pc = j := by + cases j with + | zero => rfl + | succ j => rw [sqRun j (by omega)]; rfl + +/-- No halt occurs during the first `k + 1` steps: every visited program counter + `≀ k` points at an `imm` or `mul` instruction. -/ +private theorem sqRun_not_halted {k : β„•} {j : β„•} (hj : j ≀ k) : + Β¬ Halted (sqProg k) (run (sqProg k) j sqStart) := by + unfold Halted curInstr + rw [sqRun_pc hj] + cases j with + | zero => rw [sqProg_getElem_zero]; decide + | succ j => rw [sqProg_getElem_succ (by omega)]; decide + +/-- The **unit-vs-logarithmic gap** for the squaring family. On the run of the + `k`-fold squaring program `sqProg k` for `k + 1` steps: + + * the machine halts; + * the **unit** time is `k + 1` (linear in `k`); + * the **logarithmic** time is at least `2 ^ k` (exponential in `k`). + + Hence any complexity measure based on unit cost differs super-polynomially + from logarithmic cost, and only the logarithmic measure is polynomially + related to Turing-machine time. This is the formal justification for the + library's cost convention. -/ +theorem logGap_squaring {k : β„•} (hk : 1 ≀ k) : + βˆƒ (P : Program) (c : Cfg), + Halted P (run P (k + 1) c) ∧ + unitTimeUpto P (k + 1) c = k + 1 ∧ + 2 ^ k ≀ logTimeUpto P (k + 1) c := by + obtain ⟨m, rfl⟩ : βˆƒ m, k = m + 1 := ⟨k - 1, by omega⟩ + refine ⟨sqProg (m + 1), sqStart, ?_, ?_, ?_⟩ + Β· -- Halted after m + 2 steps: program counter reaches the end. + rw [sqRun (m + 1) (le_refl _)] + show curInstr (sqProg (m + 1)) (sqCfg (m + 1)) = Instr.halt + unfold curInstr + have hlen : (sqProg (m + 1)).length ≀ m + 2 := by rw [sqProg_length] + rw [show (sqCfg (m + 1)).pc = m + 2 from rfl, List.getElem?_eq_none hlen] + rfl + Β· -- Unit time is exactly the fuel: no halt in the first m + 2 steps. + exact unitTimeUpto_eq_of_not_halted _ _ _ (fun j hj => sqRun_not_halted (by omega)) + Β· -- Logarithmic time is at least 2 ^ (m + 1): the final squaring step alone + -- costs at least the bit-length of 2 ^ (2 ^ (m + 1)) = 2 ^ (m + 1) + 1. + have hsplit : logTimeUpto (sqProg (m + 1)) (m + 1 + 1) sqStart = + logTimeUpto (sqProg (m + 1)) (m + 1) sqStart + + logTimeUpto (sqProg (m + 1)) 1 (run (sqProg (m + 1)) (m + 1) sqStart) := + logTimeUpto_add _ (m + 1) 1 sqStart + have hcfg : run (sqProg (m + 1)) (m + 1) sqStart = sqCfg m := sqRun m (by omega) + have hnh : Β¬ Halted (sqProg (m + 1)) (sqCfg m) := by + rw [← hcfg]; exact sqRun_not_halted (by omega) + have hcur : curInstr (sqProg (m + 1)) (sqCfg m) = Instr.mul 1 1 1 := by + unfold curInstr + rw [show (sqCfg m).pc = m + 1 from rfl, sqProg_getElem_succ (by omega)]; rfl + -- Evaluate the one-step logarithmic cost of the final `mul`. + have hstep1 : logTimeUpto (sqProg (m + 1)) 1 (sqCfg m) = + stepLogCost (sqProg (m + 1)) (sqCfg m) := by + rw [show (1 : β„•) = 0 + 1 from rfl, logTimeUpto_succ, ite_eq_right hnh, logTimeUpto_zero, + Nat.add_zero] + have hval : (sqCfg m).regs 1 = 2 ^ 2 ^ m := by simp [sqCfg] + have hcost : stepLogCost (sqProg (m + 1)) (sqCfg m) = + bitlen (2 ^ 2 ^ m) + bitlen (2 ^ 2 ^ m) + bitlen (2 ^ 2 ^ (m + 1)) + 1 := by + unfold stepLogCost + rw [hcur] + simp only [Instr.logCost, hval, sq_pow] + have hbit : bitlen (2 ^ 2 ^ (m + 1)) = 2 ^ (m + 1) + 1 := by + unfold bitlen; rw [Nat.size_pow] + rw [hsplit, hcfg, hstep1, hcost, hbit] + omega + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured.lean new file mode 100644 index 0000000000..1ee185330c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch + +/-! +# Structured logarithmic-cost RAM programs + +This module exposes a minimal imperative authoring language above the concrete +logarithmic-cost RAM. Source commands have independent register-store semantics; +`Cmd.compile` lowers structured conditionals and loops to absolute RAM jumps. + +The main transfer theorem, `Exec.compile_correct`, is exact in all three +dimensions carried by `Exec`: final registers, operand-sensitive logarithmic +time, and peak register space. Thus source proofs can remain at the structured +level without weakening the concrete RAM resource statement. + +`Switch.select` supplies the verified finite numeric case split used by the +Turing-machine transition compiler. Its branch selection has exact step +accounting and preserves explicit logarithmic-cost and space envelopes. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Cmd + +/-- A closed compiled command consists of its generated code followed by one +halt instruction. -/ +theorem length_compile (cmd : Cmd) : cmd.compile.length = cmd.codeSize + 1 := by + simp [compile, length_compileAt] + +end Cmd + +namespace Exec + +/-- Exact semantic and resource preservation for closed compilation. -/ +theorem compile_correct {cmd : Cmd} {initial final : Store} {steps cost space : β„•} + (hexec : Exec cmd initial final steps cost space) : + run cmd.compile steps { pc := 0, regs := initial } = + { pc := cmd.codeSize, regs := final } ∧ + logTimeUpto cmd.compile steps { pc := 0, regs := initial } = cost ∧ + spaceUpto cmd.compile steps { pc := 0, regs := initial } = space := by + simpa [Cmd.compile] using + compileAt_correct_internal hexec ([] : Program) [Instr.halt] + +/-- A source execution reaches the halt instruction appended by `Cmd.compile`. -/ +theorem compile_halted {cmd : Cmd} {initial final : Store} {steps cost space : β„•} + (hexec : Exec cmd initial final steps cost space) : + Halted cmd.compile (run cmd.compile steps { pc := 0, regs := initial }) := by + rw [(compile_correct hexec).1] + simp [Halted, curInstr, Cmd.compile, Cmd.length_compileAt] + +end Exec + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Defs.lean new file mode 100644 index 0000000000..3e75f5705e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Defs.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Defs + +/-! +# Structured logarithmic-cost RAM programs β€” definitions + +This file defines a minimal first-order imperative language over RAM register +stores. Atomic commands are the data-manipulating RAM instructions; sequencing, +conditionals, and loops are structured syntax rather than program-counter +arithmetic. The source semantics is independent of compilation and records the +same operand-sensitive logarithmic cost and finite-support space measure as the +target RAM. + +`Cmd.compileAt` erases structured control flow into absolute `jz`/`jmp` targets. +The compiler appends no hidden data operations: source and target executions +therefore have equal register effects, logarithmic cost, and peak register space. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +/-- A source store maps register indices to natural-number contents. -/ +abbrev Store := β„• β†’ β„• + +/-- Logarithmic space occupied by a source store. This deliberately matches +`RAM.Cfg.space`, but does not mention a target program counter. -/ +noncomputable def Store.space (store : Store) : β„• := + βˆ‘αΆ  i, (if store i = 0 then 0 else bitlen i + bitlen (store i)) + +namespace Input + +/-- Natural-number representation of one input bit. -/ +@[simp] +def bitValue (bit : Bool) : β„• := if bit then 1 else 0 + +/-- Store a bit string above a reserved register prefix, with its length in a +distinguished register. -/ +def bitStore (lengthReg inputBase : β„•) (bits : List Bool) : Store := fun index => + if index = lengthReg then bits.length + else if inputBase ≀ index then + match bits[index - inputBase]? with + | some bit => bitValue bit + | none => 0 + else 0 + +end Input + +/-- Data-manipulating instructions of the structured source language. Control +flow is represented by `Cmd`, so arbitrary jumps and halt are not source atoms. -/ +inductive Basic where + | imm (dst value : β„•) + | add (dst left right : β„•) + | sub (dst left right : β„•) + | mul (dst left right : β„•) + | load (dst address : β„•) + | store (address src : β„•) + deriving Repr, DecidableEq, Inhabited + +namespace Basic + +/-- Execute one source-level basic instruction on a register store. -/ +def exec : Basic β†’ Store β†’ Store + | .imm dst value, regs => Function.update regs dst value + | .add dst left right, regs => + Function.update regs dst (regs left + regs right) + | .sub dst left right, regs => + Function.update regs dst (regs left - regs right) + | .mul dst left right, regs => + Function.update regs dst (regs left * regs right) + | .load dst address, regs => + Function.update regs dst (regs (regs address)) + | .store address src, regs => + Function.update regs (regs address) (regs src) + +/-- Erase a source basic instruction to the corresponding RAM instruction. -/ +def instr : Basic β†’ Instr + | .imm dst value => .imm dst value + | .add dst left right => .add dst left right + | .sub dst left right => .sub dst left right + | .mul dst left right => .mul dst left right + | .load dst address => .load dst address + | .store address src => .store address src + +/-- Operand-sensitive source cost of one basic instruction. -/ +def logCost : Basic β†’ Store β†’ β„• + | .imm _ value, _ => bitlen value + 1 + | .add _ left right, regs => + bitlen (regs left) + bitlen (regs right) + + bitlen (regs left + regs right) + 1 + | .sub _ left right, regs => + bitlen (regs left) + bitlen (regs right) + 1 + | .mul _ left right, regs => + bitlen (regs left) + bitlen (regs right) + + bitlen (regs left * regs right) + 1 + | .load _ address, regs => + bitlen (regs address) + bitlen (regs (regs address)) + 1 + | .store address src, regs => + bitlen (regs address) + bitlen (regs src) + 1 + +/-- Execute a straight-line list of basic instructions. -/ +def execList : List Basic β†’ Store β†’ Store + | [], regs => regs + | op :: rest, regs => execList rest (op.exec regs) + +end Basic + +/-- Minimal structured imperative syntax over RAM stores. -/ +inductive Cmd where + | skip + | basic (op : Basic) + | seq (first second : Cmd) + | ifZero (test : β„•) (onZero onNonzero : Cmd) + | whileNonzero (test : β„•) (body : Cmd) + deriving Repr, DecidableEq, Inhabited + +namespace Cmd + +/-- Number of RAM instructions emitted for a structured command. -/ +def codeSize : Cmd β†’ β„• + | .skip => 0 + | .basic _ => 1 + | .seq first second => first.codeSize + second.codeSize + | .ifZero _ onZero onNonzero => + 2 + onZero.codeSize + onNonzero.codeSize + | .whileNonzero _ body => body.codeSize + 2 + +/-- Compile a command whose first instruction will be placed at `start`. +All generated branch destinations are absolute RAM program counters. -/ +def compileAt : (start : β„•) β†’ Cmd β†’ Program + | _, .skip => [] + | _, .basic op => [op.instr] + | start, .seq first second => + first.compileAt start ++ second.compileAt (start + first.codeSize) + | start, .ifZero test onZero onNonzero => + let nonzeroStart := start + 1 + let zeroStart := nonzeroStart + onNonzero.codeSize + 1 + let done := start + (Cmd.ifZero test onZero onNonzero).codeSize + [Instr.jz test zeroStart] ++ + onNonzero.compileAt nonzeroStart ++ [Instr.jmp done] ++ + onZero.compileAt zeroStart + | start, .whileNonzero test body => + let done := start + (Cmd.whileNonzero test body).codeSize + [Instr.jz test done] ++ body.compileAt (start + 1) ++ + [Instr.jmp start] + +/-- Compile a closed source command and halt immediately after it finishes. -/ +def compile (cmd : Cmd) : Program := cmd.compileAt 0 ++ [Instr.halt] + +/-- Right-associated sequential composition of a list of commands. -/ +def seqList : List Cmd β†’ Cmd + | [] => .skip + | [cmd] => cmd + | cmd :: next :: rest => .seq cmd (seqList (next :: rest)) + +/-- Embed a straight-line list of basic instructions as one structured command. -/ +def basics (ops : List Basic) : Cmd := + seqList (ops.map Cmd.basic) + +end Cmd + +/-- Independent big-step semantics for structured commands. Besides the final +store, the relation records target instruction steps, exact logarithmic cost, +and peak source-store space. Branch and loop-control costs are explicit. -/ +inductive Exec : Cmd β†’ Store β†’ Store β†’ β„• β†’ β„• β†’ β„• β†’ Prop where + | skip (store : Store) : + Exec .skip store store 0 0 store.space + | basic (op : Basic) (store : Store) : + Exec (.basic op) store (op.exec store) 1 (op.logCost store) + (max store.space (op.exec store).space) + | seq {first second : Cmd} {store middle final : Store} + {firstSteps secondSteps firstCost secondCost firstSpace secondSpace : β„•} + (hfirst : Exec first store middle firstSteps firstCost firstSpace) + (hsecond : Exec second middle final secondSteps secondCost secondSpace) : + Exec (.seq first second) store final (firstSteps + secondSteps) + (firstCost + secondCost) (max firstSpace secondSpace) + | ifZero {test : β„•} {onZero onNonzero : Cmd} {store final : Store} + {steps cost space : β„•} (htest : store test = 0) + (hbranch : Exec onZero store final steps cost space) : + Exec (.ifZero test onZero onNonzero) store final (steps + 1) + (bitlen (store test) + 1 + cost) (max store.space space) + | ifNonzero {test : β„•} {onZero onNonzero : Cmd} {store final : Store} + {steps cost space : β„•} (htest : store test β‰  0) + (hbranch : Exec onNonzero store final steps cost space) : + Exec (.ifZero test onZero onNonzero) store final (steps + 2) + (bitlen (store test) + 1 + cost + 1) (max store.space space) + | whileZero {test : β„•} {body : Cmd} {store : Store} + (htest : store test = 0) : + Exec (.whileNonzero test body) store store 1 + (bitlen (store test) + 1) store.space + | whileNonzero {test : β„•} {body : Cmd} {store middle final : Store} + {bodySteps loopSteps bodyCost loopCost bodySpace loopSpace : β„•} + (htest : store test β‰  0) + (hbody : Exec body store middle bodySteps bodyCost bodySpace) + (hloop : Exec (.whileNonzero test body) middle final loopSteps loopCost loopSpace) : + Exec (.whileNonzero test body) store final + (bodySteps + loopSteps + 2) (bitlen (store test) + 1 + bodyCost + 1 + loopCost) + (max bodySpace loopSpace) + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval.lean new file mode 100644 index 0000000000..37a48532e9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Internal +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified structured RAM decoded-gate evaluator + +This module exposes the mutable-data kernel used by the serialized-circuit +evaluator. Given an already-decoded, topologically valid gate, it performs two +indirect memo reads, evaluates the gate with branch-free Boolean arithmetic, +and indirectly appends the result in exactly twenty RAM transitions. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateEval + +/-- Evaluate a decoded gate in any store satisfying the routine ABI. + +The memo may be located above an arbitrary base address; the result is appended +there and every prior memo cell is preserved. -/ +theorem routine_correct {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program store final stepCount cost space ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (base + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + final baseReg = base ∧ final wireCountReg = wires.length ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ index, wireBase ≀ index β†’ index β‰  base + wires.length β†’ + final index = store index := + routine_exec_internal hready value0 value1 hvalue0 hvalue1 + +/-- Source-level correctness with exact transitions and explicit resources. -/ +theorem program_performance (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final stepCount cost space ∧ + cost ≀ timeBound wires.length ∧ space ≀ spaceBound wires.length ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (wireBase + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (wireBase + index) = Input.bitValue wires[index] := + program_measured_internal gate wires value0 value1 hvalue0 hvalue1 hgate + +/-- End-to-end concrete RAM performance and decoded-gate correctness. -/ +theorem compiled_performance (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final stepCount cost space ∧ + run compiled stepCount { pc := 0, regs := inputStore gate wires } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled stepCount { pc := 0, regs := inputStore gate wires }) ∧ + logTimeUpto compiled stepCount + { pc := 0, regs := inputStore gate wires } ≀ timeBound wires.length ∧ + spaceUpto compiled stepCount + { pc := 0, regs := inputStore gate wires } ≀ spaceBound wires.length ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (wireBase + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (wireBase + index) = Input.bitValue wires[index] := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult, happended, + hpreserved⟩ := + program_performance gate wires value0 value1 hvalue0 hvalue1 hgate + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, hresult, happended, hpreserved⟩ + Β· change logTimeUpto program.compile stepCount + { pc := 0, regs := inputStore gate wires } ≀ timeBound wires.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto program.compile stepCount + { pc := 0, regs := inputStore gate wires } ≀ spaceBound wires.length + rw [hcompiled.2.2] + exact hspace + +/-- One decoded gate takes logarithmic time in the current memo length. -/ +theorem timeBound_bigO_logarithmic : timeBound =O logarithmicBound := by + have hpoint : βˆ€ n, timeBound n ≀ 80 * logarithmicBound n := by + intro n + simp [timeBound, logarithmicBound] + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 80 (BigO.refl logarithmicBound)) + +/-- The explicit memo-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear : spaceBound =O quasilinearBound := by + have hpoint : βˆ€ n, spaceBound n ≀ 2 * quasilinearBound n := by + intro n + simp only [spaceBound, quasilinearBound] + calc + (n + wireBase + 1) * (2 * bitlen (n + wireBase + 1)) = + 2 * ((n + wireBase + 1) * bitlen (n + wireBase + 1)) := by ring + _ ≀ 2 * ((n + wireBase + 1) * + (bitlen (n + wireBase + 1) + 1)) := + Nat.mul_le_mul_left 2 + (Nat.mul_le_mul_left (n + wireBase + 1) (by omega)) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 2 (BigO.refl quasilinearBound)) + +end GateEval + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Defs.lean new file mode 100644 index 0000000000..f99ff40bee --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Defs.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs + +/-! +# Structured RAM decoded-gate evaluator β€” definitions + +This kernel evaluates one already-decoded fan-in-two gate against a mutable +wire memo. It uses indirect reads for both references and an indirect write to +append the result. Boolean negation, AND, and OR are implemented arithmetically, +so the instruction count is independent of the gate and wire values. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateEval + +/-- Encoded gate-operation bit: zero for AND and one for OR. -/ +def opReg : β„• := 0 +/-- Negation bit for the first gate input. -/ +def negated0Reg : β„• := 1 +/-- Negation bit for the second gate input. -/ +def negated1Reg : β„• := 2 +/-- First gate-input index, then its physical memo address. -/ +def address0Reg : β„• := 3 +/-- Second gate-input index, then the append address. -/ +def address1Reg : β„• := 4 +/-- Number of wire values already present in the memo. -/ +def wireCountReg : β„• := 5 +/-- Loaded and optionally negated first input value. -/ +def value0Reg : β„• := 6 +/-- Loaded and optionally negated second input value. -/ +def value1Reg : β„• := 7 +/-- Final gate value. -/ +def outputReg : β„• := 8 +/-- Arithmetic scratch register. -/ +def scratchReg : β„• := 9 +/-- Physical base address of the wire memo. -/ +def baseReg : β„• := 10 +/-- First register occupied by memoized wire bits. -/ +def wireBase : β„• := 11 + +/-- Register representation of a decoded gate and its incoming wire memo. -/ +def inputStore (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + let store := Input.bitStore wireCountReg wireBase wires + let store := Function.update store opReg (Input.bitValue gate.opBit) + let store := Function.update store negated0Reg (Input.bitValue gate.negatedβ‚€) + let store := Function.update store negated1Reg (Input.bitValue gate.negated₁) + let store := Function.update store address0Reg gate.inputβ‚€ + let store := Function.update store address1Reg gate.input₁ + Function.update store baseReg wireBase + +/-- Branch-free arithmetic implementation of Boolean XOR. -/ +def xorOps (value negated : β„•) : List Basic := + [.add outputReg value negated, + .mul scratchReg value negated, + .add scratchReg scratchReg scratchReg, + .sub value outputReg scratchReg] + +/-- Convert the two absolute wire indices to physical memo addresses. -/ +def addressOps : List Basic := + [.add address0Reg address0Reg baseReg, + .add address1Reg address1Reg baseReg] + +/-- Indirectly read the gate's two inputs. -/ +def loadOps : List Basic := + [.load value0Reg address0Reg, + .load value1Reg address1Reg] + +/-- Branch-free AND/OR selection. Both candidate values are formed and the +operation bit arithmetically selects the result. -/ +def evalOps : List Basic := + [.mul scratchReg value0Reg value1Reg, + .add outputReg value0Reg value1Reg, + .sub outputReg outputReg scratchReg, + .sub address0Reg outputReg scratchReg, + .mul address0Reg opReg address0Reg, + .sub outputReg outputReg address0Reg] + +/-- Compute the next memo address and append the result indirectly. -/ +def appendOps : List Basic := + [.add address1Reg baseReg wireCountReg, + .store address1Reg outputReg] + +/-- Evaluate one gate and append its Boolean result to the wire memo. -/ +def ops : List Basic := + addressOps ++ loadOps ++ xorOps value0Reg negated0Reg ++ + xorOps value1Reg negated1Reg ++ evalOps ++ appendOps + +/-- Straight-line decoded-gate evaluator, grouped at semantic proof boundaries. -/ +def program : Cmd := Cmd.seqList + [.basics addressOps, + .basics loadOps, + .basics (xorOps value0Reg negated0Reg), + .basics (xorOps value1Reg negated1Reg), + .basics evalOps, + .basics appendOps] + +/-- Semantic calling convention for evaluating a decoded gate in an existing +store. The memo may begin at any address above the evaluator's control prefix. -/ +structure ReadyAt (base : β„•) (gate : CircuitCode.RawGate) (wires : List Bool) + (store : Store) : Prop where + /-- The memo is disjoint from the evaluator's control registers. -/ + base_ge : wireBase ≀ base + /-- The operation register contains the canonical gate-operation bit. -/ + op_eq : store opReg = Input.bitValue gate.opBit + /-- The first negation register contains its canonical bit. -/ + negated0_eq : store negated0Reg = Input.bitValue gate.negatedβ‚€ + /-- The second negation register contains its canonical bit. -/ + negated1_eq : store negated1Reg = Input.bitValue gate.negated₁ + /-- The first address register contains the first absolute wire reference. -/ + address0_eq : store address0Reg = gate.inputβ‚€ + /-- The second address register contains the second absolute wire reference. -/ + address1_eq : store address1Reg = gate.input₁ + /-- The wire-count register contains the current memo length. -/ + wireCount_eq : store wireCountReg = wires.length + /-- The base register points to the physical memo. -/ + base_eq : store baseReg = base + /-- Physical memo cells contain the semantic wire bits. -/ + wire_eq : βˆ€ index, index < wires.length β†’ + store (base + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 + +/-- Concrete compiled RAM kernel. -/ +def compiled : Program := program.compile + +/-- The branch-free kernel always takes twenty source and compiled steps. -/ +def stepCount : β„• := 20 + +/-- Uniform logarithmic-cost budget for one gate. -/ +def timeBound (wireCount : β„•) : β„• := + 80 * (bitlen (wireCount + wireBase + 1) + 1) + +/-- Peak-space budget including the appended wire. -/ +def spaceBound (wireCount : β„•) : β„• := + (wireCount + wireBase + 1) * + (2 * bitlen (wireCount + wireBase + 1)) + +/-- Shifted logarithmic comparison function for one-gate time. -/ +def logarithmicBound (wireCount : β„•) : β„• := + bitlen (wireCount + wireBase + 1) + 1 + +/-- Shifted quasilinear comparison function for the explicit memo space. -/ +def quasilinearBound (wireCount : β„•) : β„• := + (wireCount + wireBase + 1) * + (bitlen (wireCount + wireBase + 1) + 1) + +end GateEval + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Internal.lean new file mode 100644 index 0000000000..3e6fbe6924 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateEval/Internal.lean @@ -0,0 +1,1711 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import Mathlib.Algebra.Order.Sub.Basic +public import Std.Tactic.BVDecide.Normalize.Bool + +/-! +# Structured RAM decoded-gate evaluator β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateEval + +open Internal + +private abbrev StoreBound (wireCount : β„•) (store : Store) : Prop := + StoreEnvelope (wireCount + wireBase + 1) (wireCount + wireBase + 1) store + +private abbrev width (wireCount : β„•) : β„• := + valueWidth (wireCount + wireBase + 1) + +private abbrev resourceSpace (wireCount : β„•) : β„• := + envelopeSpace (wireCount + wireBase + 1) (wireCount + wireBase + 1) + +private theorem envelopeSpace_eq_spaceBound (wireCount : β„•) : + resourceSpace wireCount = spaceBound wireCount := by + simp [resourceSpace, envelopeSpace, spaceBound, two_mul] + +private theorem inputStore_bound (gate : CircuitCode.RawGate) (wires : List Bool) + (hgate : gate.WellFormedAt wires.length) : + StoreBound wires.length (inputStore gate wires) := by + have hbits : StoreBound wires.length + (Input.bitStore wireCountReg wireBase wires) := by + apply Input.bitStoreEnvelope + Β· simp [wireCountReg, wireBase] + Β· simp [wireBase] + omega + Β· omega + Β· simp [wireBase] + have hop := hbits.update (index := opReg) (value := Input.bitValue gate.opBit) + (by simp [opReg, wireBase]) (by cases gate.opBit <;> simp [wireBase]) + have hneg0 := hop.update (index := negated0Reg) + (value := Input.bitValue gate.negatedβ‚€) (by simp [negated0Reg, wireBase]) + (by cases gate.negatedβ‚€ <;> simp [wireBase]) + have hneg1 := hneg0.update (index := negated1Reg) + (value := Input.bitValue gate.negated₁) (by simp [negated1Reg, wireBase]) + (by cases gate.negated₁ <;> simp [wireBase]) + have haddress0 := hneg1.update (index := address0Reg) (value := gate.inputβ‚€) + (by simp [address0Reg, wireBase]) (by + have hinput := hgate.1 + simp [wireBase] + omega) + have haddress1 := haddress0.update (index := address1Reg) (value := gate.input₁) + (by simp [address1Reg, wireBase]) (by + have hinput := hgate.2 + simp [wireBase] + omega) + have hbase := haddress1.update (index := baseReg) (value := wireBase) + (by simp [baseReg, wireBase]) (by simp [wireBase]) + simpa [inputStore] using hbase + +private def addressed0 (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add address0Reg address0Reg baseReg).exec (inputStore gate wires) + +private def addressed (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList addressOps (inputStore gate wires) + +private def loaded0 (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.load value0Reg address0Reg).exec (addressed gate wires) + +private def loaded (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList loadOps (addressed gate wires) + +private def negated0Sum (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add outputReg value0Reg negated0Reg).exec (loaded gate wires) + +private def negated0Product (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.mul scratchReg value0Reg negated0Reg).exec (negated0Sum gate wires) + +private def negated0Twice (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add scratchReg scratchReg scratchReg).exec (negated0Product gate wires) + +private def negated0 (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList (xorOps value0Reg negated0Reg) (loaded gate wires) + +private def negated1Sum (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add outputReg value1Reg negated1Reg).exec (negated0 gate wires) + +private def negated1Product (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.mul scratchReg value1Reg negated1Reg).exec (negated1Sum gate wires) + +private def negated1Twice (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add scratchReg scratchReg scratchReg).exec (negated1Product gate wires) + +private def negated1 (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList (xorOps value1Reg negated1Reg) (negated0 gate wires) + +private def evalProduct (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.mul scratchReg value0Reg value1Reg).exec (negated1 gate wires) + +private def evalSum (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add outputReg value0Reg value1Reg).exec (evalProduct gate wires) + +private def evalOr (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.sub outputReg outputReg scratchReg).exec (evalSum gate wires) + +private def evalDelta (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.sub address0Reg outputReg scratchReg).exec (evalOr gate wires) + +private def evalSelected (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.mul address0Reg opReg address0Reg).exec (evalDelta gate wires) + +private def evaluated (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList evalOps (negated1 gate wires) + +private def appendAddressed (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.add address1Reg baseReg wireCountReg).exec (evaluated gate wires) + +private def finalStore (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + (Basic.store address1Reg outputReg).exec (appendAddressed gate wires) + +private def routineAddressed (store : Store) : Store := + Basic.execList addressOps store + +private def routineLoaded (store : Store) : Store := + Basic.execList loadOps (routineAddressed store) + +private def routineNegated0 (store : Store) : Store := + Basic.execList (xorOps value0Reg negated0Reg) (routineLoaded store) + +private def routineNegated1 (store : Store) : Store := + Basic.execList (xorOps value1Reg negated1Reg) (routineNegated0 store) + +private def routineEvaluated (store : Store) : Store := + Basic.execList evalOps (routineNegated1 store) + +private def routineFinal (store : Store) : Store := + Basic.execList appendOps (routineEvaluated store) + +private theorem inputStore_wire (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) : + inputStore gate wires (wireBase + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 := by + have h1 : 11 + index β‰  1 := by omega + have h2 : 11 + index β‰  2 := by omega + have h3 : 11 + index β‰  3 := by omega + have h4 : 11 + index β‰  4 := by omega + have h5 : 11 + index β‰  5 := by omega + have h10 : 11 + index β‰  10 := by omega + simp [inputStore, h1, h2, h3, h4, h5, h10, Input.bitStore, + wireBase, wireCountReg, opReg, negated0Reg, negated1Reg, address0Reg, + address1Reg, baseReg] + rfl + +private theorem addressed_address0 (gate : CircuitCode.RawGate) + (wires : List Bool) : + addressed gate wires address0Reg = gate.inputβ‚€ + wireBase := by + simp [addressed, addressOps, Basic.execList, Basic.exec, inputStore, + address0Reg, address1Reg, baseReg, wireBase] + +private theorem addressed_address1 (gate : CircuitCode.RawGate) + (wires : List Bool) : + addressed gate wires address1Reg = gate.input₁ + wireBase := by + simp [addressed, addressOps, Basic.execList, Basic.exec, inputStore, + address0Reg, address1Reg, baseReg, wireBase] + +private theorem addressed_apply_of_ne (gate : CircuitCode.RawGate) + (wires : List Bool) (index : β„•) (h0 : index β‰  address0Reg) + (h1 : index β‰  address1Reg) : + addressed gate wires index = inputStore gate wires index := by + simp [addressed, addressOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1] + +private theorem loaded_value0 (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + loaded gate wires value0Reg = Input.bitValue value := by + have hwire := inputStore_wire gate wires gate.inputβ‚€ + have hphysical : inputStore gate wires (gate.inputβ‚€ + wireBase) = + Input.bitValue value := by + rw [Nat.add_comm] + simpa [hvalue] using hwire + have haddress : addressed gate wires 3 = gate.inputβ‚€ + 11 := by + simpa [address0Reg, wireBase] using addressed_address0 gate wires + have hread : addressed gate wires (gate.inputβ‚€ + 11) = + Input.bitValue value := by + rw [addressed_apply_of_ne gate wires] + Β· simpa [wireBase] using hphysical + Β· simp [address0Reg] + Β· simp [address1Reg] + simp [loaded, loadOps, Basic.execList, Basic.exec, value0Reg, value1Reg, + address0Reg, address1Reg, haddress, hread] + +private theorem loaded_value1 (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.input₁]? = some value) : + loaded gate wires value1Reg = Input.bitValue value := by + have hwire := inputStore_wire gate wires gate.input₁ + have hphysical : inputStore gate wires (gate.input₁ + wireBase) = + Input.bitValue value := by + rw [Nat.add_comm] + simpa [hvalue] using hwire + have haddress : addressed gate wires 4 = gate.input₁ + 11 := by + simpa [address1Reg, wireBase] using addressed_address1 gate wires + have hread : addressed gate wires (gate.input₁ + 11) = + Input.bitValue value := by + rw [addressed_apply_of_ne gate wires] + Β· simpa [wireBase] using hphysical + Β· simp [address0Reg] + Β· simp [address1Reg] + simp [loaded, loadOps, Basic.execList, Basic.exec, value0Reg, value1Reg, + address0Reg, address1Reg, haddress, hread] + +private theorem inputStore_op (gate : CircuitCode.RawGate) (wires : List Bool) : + inputStore gate wires opReg = Input.bitValue gate.opBit := by + simp [inputStore, opReg, negated0Reg, negated1Reg, address0Reg, address1Reg, + baseReg, Input.bitValue] + +private theorem inputStore_negated0 (gate : CircuitCode.RawGate) + (wires : List Bool) : + inputStore gate wires negated0Reg = Input.bitValue gate.negatedβ‚€ := by + simp [inputStore, opReg, negated0Reg, negated1Reg, address0Reg, address1Reg, + baseReg, Input.bitValue] + +private theorem inputStore_negated1 (gate : CircuitCode.RawGate) + (wires : List Bool) : + inputStore gate wires negated1Reg = Input.bitValue gate.negated₁ := by + simp [inputStore, opReg, negated0Reg, negated1Reg, address0Reg, address1Reg, + baseReg, Input.bitValue] + +private theorem address_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics addressOps) (inputStore gate wires) + (addressed gate wires) 2 (8 * width wires.length) + (resourceSpace wires.length) ∧ + StoreBound wires.length (addressed gate wires) := by + have hinitial := inputStore_bound gate wires hgate + have hfirst : StoreBound wires.length (addressed0 gate wires) := by + apply hinitial.execBasic (.add address0Reg address0Reg baseReg) + Β· simp [address0Reg, wireBase] + Β· have hinput := hgate.1 + simp [Internal.Basic.writeValue, inputStore, address0Reg, address1Reg, + baseReg, wireBase, opReg, negated0Reg, negated1Reg] + omega + have hfinal : StoreBound wires.length (addressed gate wires) := by + have heq : addressed gate wires = + (Basic.add address1Reg address1Reg baseReg).exec (addressed0 gate wires) := by + rfl + rw [heq] + apply hfirst.execBasic (.add address1Reg address1Reg baseReg) + Β· simp [address1Reg, wireBase] + Β· have hinput := hgate.2 + simp [Internal.Basic.writeValue, addressed0, Basic.exec, inputStore, + address0Reg, address1Reg, baseReg, wireBase, opReg, negated0Reg, + negated1Reg] + omega + have hrun0 := MeasuredRuns.basicEnvelope + (.add address0Reg address0Reg baseReg) (inputStore gate wires) hinitial hfirst + have hrun1 := MeasuredRuns.basicEnvelope + (.add address1Reg address1Reg baseReg) (addressed0 gate wires) hfirst (by + simpa only [addressed, addressOps, Basic.execList] using! hfinal) + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq hrun1 + convert! hrun using 1 + ring + +private theorem load_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics loadOps) (addressed gate wires) (loaded gate wires) + 2 (8 * width wires.length) (resourceSpace wires.length) ∧ + StoreBound wires.length (loaded gate wires) := by + have hinitial := (address_measured gate wires hgate).2 + have hfirst : StoreBound wires.length (loaded0 gate wires) := by + apply hinitial.execBasic (.load value0Reg address0Reg) + Β· simp [value0Reg, wireBase] + Β· simpa [Internal.Basic.writeValue] using + hinitial.value_le (addressed gate wires address0Reg) + have hfinal : StoreBound wires.length (loaded gate wires) := by + have heq : loaded gate wires = + (Basic.load value1Reg address1Reg).exec (loaded0 gate wires) := by rfl + rw [heq] + apply hfirst.execBasic (.load value1Reg address1Reg) + Β· simp [value1Reg, wireBase] + Β· simpa [Internal.Basic.writeValue] using + hfirst.value_le (loaded0 gate wires address1Reg) + have hrun0 := MeasuredRuns.basicEnvelope (.load value0Reg address0Reg) + (addressed gate wires) hinitial hfirst + have hrun1 := MeasuredRuns.basicEnvelope (.load value1Reg address1Reg) + (loaded0 gate wires) hfirst (by + simpa only [loaded, loadOps, Basic.execList] using! hfinal) + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq hrun1 + convert! hrun using 1 + ring + +private theorem negated0_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics (xorOps value0Reg negated0Reg)) (loaded gate wires) + (negated0 gate wires) 4 (16 * width wires.length) + (resourceSpace wires.length) ∧ + StoreBound wires.length (negated0 gate wires) := by + have hinitial := (load_measured gate wires hgate).2 + have hvalueEq := loaded_value0 gate wires value hvalue + have hnegatedEq : loaded gate wires negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + rw [show loaded gate wires negated0Reg = addressed gate wires negated0Reg by + simp [loaded, loadOps, Basic.execList, Basic.exec, negated0Reg, + value0Reg, value1Reg]] + rw [addressed_apply_of_ne gate wires] + Β· exact inputStore_negated0 gate wires + Β· simp [negated0Reg, address0Reg] + Β· simp [negated0Reg, address1Reg] + have hvalueEq' : loaded gate wires 6 = Input.bitValue value := by + simpa [value0Reg] using hvalueEq + have hnegatedEq' : loaded gate wires 1 = Input.bitValue gate.negatedβ‚€ := by + simpa [negated0Reg] using hnegatedEq + have hsum : StoreBound wires.length (negated0Sum gate wires) := by + apply hinitial.execBasic (.add outputReg value0Reg negated0Reg) + Β· simp [outputReg, wireBase] + Β· change loaded gate wires 6 + loaded gate wires 1 ≀ + wires.length + wireBase + 1 + rw [hvalueEq', hnegatedEq'] + cases value <;> cases gate.negatedβ‚€ <;> simp [wireBase] + have hproduct : StoreBound wires.length (negated0Product gate wires) := by + apply hsum.execBasic (.mul scratchReg value0Reg negated0Reg) + Β· simp [scratchReg, wireBase] + Β· change negated0Sum gate wires value0Reg * + negated0Sum gate wires negated0Reg ≀ wires.length + wireBase + 1 + simp [negated0Sum, Basic.exec, value0Reg, negated0Reg, outputReg, + hvalueEq', hnegatedEq'] + cases value <;> cases gate.negatedβ‚€ <;> simp [wireBase] + have htwice : StoreBound wires.length (negated0Twice gate wires) := by + apply hproduct.execBasic (.add scratchReg scratchReg scratchReg) + Β· simp [scratchReg, wireBase] + Β· change negated0Product gate wires scratchReg + + negated0Product gate wires scratchReg ≀ wires.length + wireBase + 1 + simp [negated0Product, negated0Sum, Basic.exec, value0Reg, negated0Reg, + outputReg, scratchReg, hvalueEq', hnegatedEq'] + cases value <;> cases gate.negatedβ‚€ <;> simp [wireBase] + have hfinal : StoreBound wires.length (negated0 gate wires) := by + have heq : negated0 gate wires = + (Basic.sub value0Reg outputReg scratchReg).exec + (negated0Twice gate wires) := by rfl + rw [heq] + apply htwice.execBasic (.sub value0Reg outputReg scratchReg) + Β· simp [value0Reg, wireBase] + Β· exact Nat.le_trans (Nat.sub_le _ _) (htwice.value_le outputReg) + have hrun0 := MeasuredRuns.basicEnvelope (.add outputReg value0Reg negated0Reg) + (loaded gate wires) hinitial hsum + have hrun1 := MeasuredRuns.basicEnvelope (.mul scratchReg value0Reg negated0Reg) + (negated0Sum gate wires) hsum hproduct + have hrun2 := MeasuredRuns.basicEnvelope (.add scratchReg scratchReg scratchReg) + (negated0Product gate wires) hproduct htwice + have hrun3 := MeasuredRuns.basicEnvelope (.sub value0Reg outputReg scratchReg) + (negated0Twice gate wires) htwice (by + simpa only [negated0, xorOps, Basic.execList] using! hfinal) + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq (hrun1.seq (hrun2.seq hrun3)) + convert! hrun using 1 + ring + +private theorem loaded_apply_of_ne (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) (h0 : index β‰  value0Reg) (h1 : index β‰  value1Reg) + (ha0 : index β‰  address0Reg) (ha1 : index β‰  address1Reg) : + loaded gate wires index = inputStore gate wires index := by + rw [show loaded gate wires index = addressed gate wires index by + simp [loaded, loadOps, Basic.execList, Basic.exec, Function.update_of_ne, + h0, h1]] + exact addressed_apply_of_ne gate wires index ha0 ha1 + +private theorem negated0_value (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + negated0 gate wires value0Reg = + Input.bitValue (gate.negatedβ‚€.xor value) := by + have hloadedValue := loaded_value0 gate wires value hvalue + have hloadedNegated : loaded gate wires negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + rw [loaded_apply_of_ne gate wires] + Β· exact inputStore_negated0 gate wires + Β· simp [negated0Reg, value0Reg] + Β· simp [negated0Reg, value1Reg] + Β· simp [negated0Reg, address0Reg] + Β· simp [negated0Reg, address1Reg] + have hloadedValue' : loaded gate wires 6 = Input.bitValue value := by + simpa [value0Reg] using hloadedValue + have hloadedNegated' : loaded gate wires 1 = Input.bitValue gate.negatedβ‚€ := by + simpa [negated0Reg] using hloadedNegated + generalize hnegated : gate.negatedβ‚€ = negated + cases negated <;> cases value <;> + simp [negated0, xorOps, Basic.execList, Basic.exec, Input.bitValue, + value0Reg, outputReg, scratchReg, negated0Reg, hnegated, + hloadedValue', hloadedNegated'] + +private theorem negated0_apply_of_ne (gate : CircuitCode.RawGate) + (wires : List Bool) (index : β„•) (hvalue : index β‰  value0Reg) + (houtput : index β‰  outputReg) (hscratch : index β‰  scratchReg) : + negated0 gate wires index = loaded gate wires index := by + simp [negated0, xorOps, Basic.execList, Basic.exec, Function.update_of_ne, + hvalue, houtput, hscratch] + +private theorem negated1_value (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.input₁]? = some value) : + negated1 gate wires value1Reg = + Input.bitValue (gate.negated₁.xor value) := by + have hloadedValue := loaded_value1 gate wires value hvalue + have hnegated0Value : negated0 gate wires value1Reg = Input.bitValue value := by + rw [negated0_apply_of_ne gate wires] + Β· exact hloadedValue + Β· simp [value0Reg, value1Reg] + Β· simp [value1Reg, outputReg] + Β· simp [value1Reg, scratchReg] + have hloadedNegated : loaded gate wires negated1Reg = + Input.bitValue gate.negated₁ := by + rw [loaded_apply_of_ne gate wires] + Β· exact inputStore_negated1 gate wires + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, value1Reg] + Β· simp [negated1Reg, address0Reg] + Β· simp [negated1Reg, address1Reg] + have hnegatedBit : negated0 gate wires negated1Reg = + Input.bitValue gate.negated₁ := by + rw [negated0_apply_of_ne gate wires] + Β· exact hloadedNegated + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, outputReg] + Β· simp [negated1Reg, scratchReg] + have hnegated0Value' : negated0 gate wires 7 = Input.bitValue value := by + simpa [value1Reg] using hnegated0Value + have hnegatedBit' : negated0 gate wires 2 = Input.bitValue gate.negated₁ := by + simpa [negated1Reg] using hnegatedBit + generalize hnegated : gate.negated₁ = negated + cases negated <;> cases value <;> + simp [negated1, xorOps, Basic.execList, Basic.exec, Input.bitValue, + value1Reg, outputReg, scratchReg, negated1Reg, hnegated, + hnegated0Value', hnegatedBit'] + +private theorem negated1_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics (xorOps value1Reg negated1Reg)) (negated0 gate wires) + (negated1 gate wires) 4 (16 * width wires.length) + (resourceSpace wires.length) ∧ + StoreBound wires.length (negated1 gate wires) := by + have hinitial := (negated0_measured gate wires value0 hvalue0 hgate).2 + have hloadedValue := loaded_value1 gate wires value1 hvalue1 + have hvalueEq : negated0 gate wires value1Reg = Input.bitValue value1 := by + rw [negated0_apply_of_ne gate wires] + Β· exact hloadedValue + Β· simp [value1Reg, value0Reg] + Β· simp [value1Reg, outputReg] + Β· simp [value1Reg, scratchReg] + have hloadedNegated : loaded gate wires negated1Reg = + Input.bitValue gate.negated₁ := by + rw [loaded_apply_of_ne gate wires] + Β· exact inputStore_negated1 gate wires + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, value1Reg] + Β· simp [negated1Reg, address0Reg] + Β· simp [negated1Reg, address1Reg] + have hnegatedEq : negated0 gate wires negated1Reg = + Input.bitValue gate.negated₁ := by + rw [negated0_apply_of_ne gate wires] + Β· exact hloadedNegated + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, outputReg] + Β· simp [negated1Reg, scratchReg] + have hvalueEq' : negated0 gate wires 7 = Input.bitValue value1 := by + simpa [value1Reg] using hvalueEq + have hnegatedEq' : negated0 gate wires 2 = Input.bitValue gate.negated₁ := by + simpa [negated1Reg] using hnegatedEq + have hsum : StoreBound wires.length (negated1Sum gate wires) := by + apply hinitial.execBasic (.add outputReg value1Reg negated1Reg) + Β· simp [outputReg, wireBase] + Β· change negated0 gate wires 7 + negated0 gate wires 2 ≀ + wires.length + wireBase + 1 + rw [hvalueEq', hnegatedEq'] + cases value1 <;> cases gate.negated₁ <;> simp [wireBase] + have hproduct : StoreBound wires.length (negated1Product gate wires) := by + apply hsum.execBasic (.mul scratchReg value1Reg negated1Reg) + Β· simp [scratchReg, wireBase] + Β· change negated1Sum gate wires value1Reg * + negated1Sum gate wires negated1Reg ≀ wires.length + wireBase + 1 + simp [negated1Sum, Basic.exec, value1Reg, negated1Reg, outputReg, + hvalueEq', hnegatedEq'] + cases value1 <;> cases gate.negated₁ <;> simp [wireBase] + have htwice : StoreBound wires.length (negated1Twice gate wires) := by + apply hproduct.execBasic (.add scratchReg scratchReg scratchReg) + Β· simp [scratchReg, wireBase] + Β· change negated1Product gate wires scratchReg + + negated1Product gate wires scratchReg ≀ wires.length + wireBase + 1 + simp [negated1Product, negated1Sum, Basic.exec, value1Reg, negated1Reg, + outputReg, scratchReg, hvalueEq', hnegatedEq'] + cases value1 <;> cases gate.negated₁ <;> simp [wireBase] + have hfinal : StoreBound wires.length (negated1 gate wires) := by + have heq : negated1 gate wires = + (Basic.sub value1Reg outputReg scratchReg).exec + (negated1Twice gate wires) := by rfl + rw [heq] + apply htwice.execBasic (.sub value1Reg outputReg scratchReg) + Β· simp [value1Reg, wireBase] + Β· exact Nat.le_trans (Nat.sub_le _ _) (htwice.value_le outputReg) + have hrun0 := MeasuredRuns.basicEnvelope (.add outputReg value1Reg negated1Reg) + (negated0 gate wires) hinitial hsum + have hrun1 := MeasuredRuns.basicEnvelope (.mul scratchReg value1Reg negated1Reg) + (negated1Sum gate wires) hsum hproduct + have hrun2 := MeasuredRuns.basicEnvelope (.add scratchReg scratchReg scratchReg) + (negated1Product gate wires) hproduct htwice + have hrun3 := MeasuredRuns.basicEnvelope (.sub value1Reg outputReg scratchReg) + (negated1Twice gate wires) htwice (by + simpa only [negated1, xorOps, Basic.execList] using! hfinal) + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq (hrun1.seq (hrun2.seq hrun3)) + convert! hrun using 1 + ring + +private theorem negated1_value0 (gate : CircuitCode.RawGate) (wires : List Bool) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + negated1 gate wires value0Reg = + Input.bitValue (gate.negatedβ‚€.xor value) := by + rw [show negated1 gate wires value0Reg = negated0 gate wires value0Reg by + simp [negated1, xorOps, Basic.execList, Basic.exec, value0Reg, value1Reg, + outputReg, scratchReg]] + exact negated0_value gate wires value hvalue + +private theorem negated1_apply_of_ne (gate : CircuitCode.RawGate) + (wires : List Bool) (index : β„•) (hvalue : index β‰  value1Reg) + (houtput : index β‰  outputReg) (hscratch : index β‰  scratchReg) : + negated1 gate wires index = negated0 gate wires index := by + simp [negated1, xorOps, Basic.execList, Basic.exec, Function.update_of_ne, + hvalue, houtput, hscratch] + +private theorem negated1_op (gate : CircuitCode.RawGate) (wires : List Bool) : + negated1 gate wires opReg = Input.bitValue gate.opBit := by + rw [negated1_apply_of_ne gate wires] + Β· rw [negated0_apply_of_ne gate wires] + Β· rw [loaded_apply_of_ne gate wires] + Β· exact inputStore_op gate wires + Β· simp [opReg, value0Reg] + Β· simp [opReg, value1Reg] + Β· simp [opReg, address0Reg] + Β· simp [opReg, address1Reg] + Β· simp [opReg, value0Reg] + Β· simp [opReg, outputReg] + Β· simp [opReg, scratchReg] + Β· simp [opReg, value1Reg] + Β· simp [opReg, outputReg] + Β· simp [opReg, scratchReg] + +private theorem evaluated_output (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + evaluated gate wires outputReg = Input.bitValue (gate.eval value0 value1) := by + have hvalue0' := negated1_value0 gate wires value0 hvalue0 + have hvalue1' := negated1_value gate wires value1 hvalue1 + have hop := negated1_op gate wires + have hvalue0'' : negated1 gate wires 6 = + Input.bitValue (gate.negatedβ‚€.xor value0) := by + simpa [value0Reg] using hvalue0' + have hvalue1'' : negated1 gate wires 7 = + Input.bitValue (gate.negated₁.xor value1) := by + simpa [value1Reg] using hvalue1' + have hop' : negated1 gate wires 0 = Input.bitValue gate.opBit := by + simpa [opReg] using hop + rcases gate with ⟨op, input0, input1, negated0, negated1⟩ + cases op <;> cases negated0 <;> cases negated1 <;> + cases value0 <;> cases value1 <;> + simp [evaluated, evalOps, Basic.execList, Basic.exec, Input.bitValue, + CircuitCode.RawGate.eval, CircuitCode.RawGate.opBit, opReg, value0Reg, + value1Reg, outputReg, scratchReg, address0Reg, hvalue0'', hvalue1'', hop'] + +private theorem eval_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics evalOps) (negated1 gate wires) (evaluated gate wires) + 6 (24 * width wires.length) (resourceSpace wires.length) ∧ + StoreBound wires.length (evaluated gate wires) := by + have hinitial := + (negated1_measured gate wires value0 value1 hvalue0 hvalue1 hgate).2 + have hvalue0Eq := negated1_value0 gate wires value0 hvalue0 + have hvalue1Eq := negated1_value gate wires value1 hvalue1 + have hopEq := negated1_op gate wires + have hvalue0Eq' : negated1 gate wires 6 = + Input.bitValue (gate.negatedβ‚€.xor value0) := by + simpa [value0Reg] using hvalue0Eq + have hvalue1Eq' : negated1 gate wires 7 = + Input.bitValue (gate.negated₁.xor value1) := by + simpa [value1Reg] using hvalue1Eq + have hopEq' : negated1 gate wires 0 = Input.bitValue gate.opBit := by + simpa [opReg] using hopEq + have hproduct : StoreBound wires.length (evalProduct gate wires) := by + apply hinitial.execBasic (.mul scratchReg value0Reg value1Reg) + Β· simp [scratchReg, wireBase] + Β· change negated1 gate wires value0Reg * negated1 gate wires value1Reg ≀ + wires.length + wireBase + 1 + rw [hvalue0Eq, hvalue1Eq] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp [wireBase] + have hsum : StoreBound wires.length (evalSum gate wires) := by + apply hproduct.execBasic (.add outputReg value0Reg value1Reg) + Β· simp [outputReg, wireBase] + Β· change evalProduct gate wires value0Reg + evalProduct gate wires value1Reg ≀ + wires.length + wireBase + 1 + simp [evalProduct, Basic.exec, value0Reg, value1Reg, scratchReg, + hvalue0Eq', hvalue1Eq'] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp [wireBase] + have hsumOutput : evalSum gate wires outputReg ≀ 2 := by + simp [evalSum, evalProduct, Basic.exec, outputReg, value0Reg, value1Reg, + scratchReg, hvalue0Eq', hvalue1Eq'] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp + have hor : StoreBound wires.length (evalOr gate wires) := by + apply hsum.execBasic (.sub outputReg outputReg scratchReg) + Β· simp [outputReg, wireBase] + Β· exact le_trans (Nat.sub_le _ _) (le_trans hsumOutput (by simp [wireBase])) + have horOutput : evalOr gate wires outputReg ≀ 2 := by + exact le_trans (Nat.sub_le _ _) hsumOutput + have hdelta : StoreBound wires.length (evalDelta gate wires) := by + apply hor.execBasic (.sub address0Reg outputReg scratchReg) + Β· simp [address0Reg, wireBase] + Β· exact le_trans (Nat.sub_le _ _) (le_trans horOutput (by simp [wireBase])) + have hdeltaValue : evalDelta gate wires address0Reg ≀ 2 := by + exact le_trans (Nat.sub_le _ _) horOutput + have hselected : StoreBound wires.length (evalSelected gate wires) := by + apply hdelta.execBasic (.mul address0Reg opReg address0Reg) + Β· simp [address0Reg, wireBase] + Β· have hop : evalDelta gate wires opReg = Input.bitValue gate.opBit := by + simp [evalDelta, evalOr, evalSum, evalProduct, Basic.exec, opReg, + address0Reg, outputReg, scratchReg, value0Reg, value1Reg, hopEq'] + change evalDelta gate wires opReg * evalDelta gate wires address0Reg ≀ + wires.length + wireBase + 1 + rw [hop] + cases gate.opBit <;> simp [Input.bitValue] + exact le_trans hdeltaValue (by simp [wireBase]) + have hfinal : StoreBound wires.length (evaluated gate wires) := by + have heq : evaluated gate wires = + (Basic.sub outputReg outputReg address0Reg).exec + (evalSelected gate wires) := by rfl + rw [heq] + apply hselected.execBasic (.sub outputReg outputReg address0Reg) + Β· simp [outputReg, wireBase] + Β· exact Nat.le_trans (Nat.sub_le _ _) (hselected.value_le outputReg) + have hrun0 := MeasuredRuns.basicEnvelope (.mul scratchReg value0Reg value1Reg) + (negated1 gate wires) hinitial hproduct + have hrun1 := MeasuredRuns.basicEnvelope (.add outputReg value0Reg value1Reg) + (evalProduct gate wires) hproduct hsum + have hrun2 := MeasuredRuns.basicEnvelope (.sub outputReg outputReg scratchReg) + (evalSum gate wires) hsum hor + have hrun3 := MeasuredRuns.basicEnvelope (.sub address0Reg outputReg scratchReg) + (evalOr gate wires) hor hdelta + have hrun4 := MeasuredRuns.basicEnvelope (.mul address0Reg opReg address0Reg) + (evalDelta gate wires) hdelta hselected + have hrun5 := MeasuredRuns.basicEnvelope (.sub outputReg outputReg address0Reg) + (evalSelected gate wires) hselected (by + simpa only [evaluated, evalOps, Basic.execList] using! hfinal) + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq (hrun1.seq (hrun2.seq (hrun3.seq (hrun4.seq hrun5)))) + convert! hrun using 1 + ring + +private theorem evaluated_apply_of_ne (gate : CircuitCode.RawGate) + (wires : List Bool) (index : β„•) (haddress : index β‰  address0Reg) + (houtput : index β‰  outputReg) (hscratch : index β‰  scratchReg) : + evaluated gate wires index = negated1 gate wires index := by + simp [evaluated, evalOps, Basic.execList, Basic.exec, Function.update_of_ne, + haddress, houtput, hscratch] + +private theorem inputStore_wireCount (gate : CircuitCode.RawGate) + (wires : List Bool) : inputStore gate wires wireCountReg = wires.length := by + simp [inputStore, opReg, negated0Reg, negated1Reg, address0Reg, address1Reg, + wireCountReg, baseReg, wireBase, Input.bitStore] + +private theorem inputStore_base (gate : CircuitCode.RawGate) (wires : List Bool) : + inputStore gate wires baseReg = wireBase := by + simp [inputStore, baseReg] + +private theorem evaluated_stable (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) (ha0 : index β‰  address0Reg) (ha1 : index β‰  address1Reg) + (hv0 : index β‰  value0Reg) (hv1 : index β‰  value1Reg) + (hout : index β‰  outputReg) (hscratch : index β‰  scratchReg) : + evaluated gate wires index = inputStore gate wires index := by + rw [evaluated_apply_of_ne gate wires index ha0 hout hscratch] + rw [negated1_apply_of_ne gate wires index hv1 hout hscratch] + rw [negated0_apply_of_ne gate wires index hv0 hout hscratch] + exact loaded_apply_of_ne gate wires index hv0 hv1 ha0 ha1 + +private theorem evaluated_wireCount (gate : CircuitCode.RawGate) + (wires : List Bool) : evaluated gate wires wireCountReg = wires.length := by + rw [evaluated_stable gate wires] + Β· exact inputStore_wireCount gate wires + Β· simp [wireCountReg, address0Reg] + Β· simp [wireCountReg, address1Reg] + Β· simp [wireCountReg, value0Reg] + Β· simp [wireCountReg, value1Reg] + Β· simp [wireCountReg, outputReg] + Β· simp [wireCountReg, scratchReg] + +private theorem evaluated_base (gate : CircuitCode.RawGate) (wires : List Bool) : + evaluated gate wires baseReg = wireBase := by + rw [evaluated_stable gate wires] + Β· exact inputStore_base gate wires + Β· simp [baseReg, address0Reg] + Β· simp [baseReg, address1Reg] + Β· simp [baseReg, value0Reg] + Β· simp [baseReg, value1Reg] + Β· simp [baseReg, outputReg] + Β· simp [baseReg, scratchReg] + +private theorem finalStore_output (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + finalStore gate wires outputReg = Input.bitValue (gate.eval value0 value1) := by + have houtput := evaluated_output gate wires value0 value1 hvalue0 hvalue1 + have hcount := evaluated_wireCount gate wires + have hbase := evaluated_base gate wires + have houtput' : evaluated gate wires 8 = Input.bitValue (gate.eval value0 value1) := by + simpa [outputReg] using houtput + have hcount' : evaluated gate wires 5 = wires.length := by + simpa [wireCountReg] using hcount + have hbase' : evaluated gate wires 10 = 11 := by + simpa [baseReg, wireBase] using hbase + have happendAddress : appendAddressed gate wires 4 = 11 + wires.length := by + simp [appendAddressed, Basic.exec, address1Reg, baseReg, wireCountReg, + hcount', hbase'] + have happendOutput : appendAddressed gate wires 8 = + Input.bitValue (gate.eval value0 value1) := by + simpa [appendAddressed, Basic.exec, address1Reg, outputReg] using houtput' + rw [finalStore, Basic.exec] + change Function.update (appendAddressed gate wires) + (appendAddressed gate wires 4) (appendAddressed gate wires 8) 8 = _ + rw [happendAddress, happendOutput] + rw [Function.update_of_ne (by omega : 8 β‰  11 + wires.length)] + exact happendOutput + +private theorem finalStore_appended (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + finalStore gate wires (wireBase + wires.length) = + Input.bitValue (gate.eval value0 value1) := by + have houtput := evaluated_output gate wires value0 value1 hvalue0 hvalue1 + have hbase' : evaluated gate wires 10 = 11 := by + simpa [baseReg, wireBase] using evaluated_base gate wires + have hcount' : evaluated gate wires 5 = wires.length := by + simpa [wireCountReg] using evaluated_wireCount gate wires + have haddress : appendAddressed gate wires address1Reg = + wireBase + wires.length := by + simp [appendAddressed, Basic.exec, address1Reg, baseReg, wireCountReg] + rw [hbase', hcount'] + simp [wireBase, Nat.add_comm] + have hsource : appendAddressed gate wires outputReg = + Input.bitValue (gate.eval value0 value1) := by + simpa [appendAddressed, Basic.exec, address1Reg, outputReg] using houtput + rw [finalStore, Basic.exec] + change Function.update (appendAddressed gate wires) + (appendAddressed gate wires address1Reg) + (appendAddressed gate wires outputReg) (wireBase + wires.length) = _ + rw [haddress, hsource, Function.update_self] + +private theorem finalStore_wire (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) (hindex : index < wires.length) : + finalStore gate wires (wireBase + index) = Input.bitValue wires[index] := by + have hbase' : evaluated gate wires 10 = 11 := by + simpa [baseReg, wireBase] using evaluated_base gate wires + have hcount' : evaluated gate wires 5 = wires.length := by + simpa [wireCountReg] using evaluated_wireCount gate wires + have haddress : appendAddressed gate wires address1Reg = + wireBase + wires.length := by + simp [appendAddressed, Basic.exec, address1Reg, baseReg, wireCountReg] + rw [hbase', hcount'] + simp [wireBase, Nat.add_comm] + have hne : wireBase + index β‰  wireBase + wires.length := by omega + rw [finalStore, Basic.exec] + change Function.update (appendAddressed gate wires) + (appendAddressed gate wires address1Reg) + (appendAddressed gate wires outputReg) (wireBase + index) = _ + rw [haddress, Function.update_of_ne hne] + have happend : appendAddressed gate wires (wireBase + index) = + evaluated gate wires (wireBase + index) := by + rw [appendAddressed, Basic.exec] + simp only [wireBase, address1Reg] + rw [Function.update_of_ne (by omega : 11 + index β‰  4)] + rw [happend] + rw [evaluated_stable gate wires] + Β· have hwire := inputStore_wire gate wires index + rw [List.getElem?_eq_getElem hindex] at hwire + exact hwire + all_goals simp only [wireBase, address0Reg, address1Reg, value0Reg, value1Reg, + outputReg, scratchReg] + all_goals omega + +private theorem append_measured (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + MeasuredRuns (.basics appendOps) (evaluated gate wires) (finalStore gate wires) + 2 (8 * width wires.length) (resourceSpace wires.length) ∧ + StoreBound wires.length (finalStore gate wires) := by + have hinitial := (eval_measured gate wires value0 value1 hvalue0 hvalue1 hgate).2 + have hfirst : StoreBound wires.length (appendAddressed gate wires) := by + apply hinitial.execBasic (.add address1Reg baseReg wireCountReg) + Β· simp [address1Reg, wireBase] + Β· change evaluated gate wires baseReg + evaluated gate wires wireCountReg ≀ + wires.length + wireBase + 1 + rw [evaluated_base, evaluated_wireCount] + omega + have hbase' : evaluated gate wires 10 = 11 := by + simpa [baseReg, wireBase] using evaluated_base gate wires + have hcount' : evaluated gate wires 5 = wires.length := by + simpa [wireCountReg] using evaluated_wireCount gate wires + have hfinal : StoreBound wires.length (finalStore gate wires) := by + apply hfirst.execBasic (.store address1Reg outputReg) + Β· change appendAddressed gate wires address1Reg < + wires.length + wireBase + 1 + change evaluated gate wires 10 + evaluated gate wires 5 < + wires.length + wireBase + 1 + rw [hbase', hcount'] + simp [wireBase] + omega + Β· exact hfirst.value_le outputReg + have hrun0 := MeasuredRuns.basicEnvelope (.add address1Reg baseReg wireCountReg) + (evaluated gate wires) hinitial hfirst + have hrun1 := MeasuredRuns.basicEnvelope (.store address1Reg outputReg) + (appendAddressed gate wires) hfirst hfinal + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq hrun1 + convert! hrun using 1 + ring + +private theorem routineAddressed_address0 {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineAddressed store address0Reg = gate.inputβ‚€ + base := by + change store address0Reg + store baseReg = gate.inputβ‚€ + base + rw [hready.address0_eq, hready.base_eq] + +private theorem routineAddressed_address1 {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineAddressed store address1Reg = gate.input₁ + base := by + change store address1Reg + store baseReg = gate.input₁ + base + rw [hready.address1_eq, hready.base_eq] + +private theorem routineAddressed_apply_of_ne (store : Store) (index : β„•) + (h0 : index β‰  address0Reg) (h1 : index β‰  address1Reg) : + routineAddressed store index = store index := by + simp [routineAddressed, addressOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1] + +private theorem routineLoaded_value0 {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + routineLoaded store value0Reg = Input.bitValue value := by + have hindex := List.getElem?_eq_some_iff.mp hvalue |>.1 + have hread := hready.wire_eq gate.inputβ‚€ hindex + simp [hvalue] at hread + have haddress := routineAddressed_address0 hready + have hbase : wireBase ≀ base := hready.base_ge + have hphysical : routineAddressed store (gate.inputβ‚€ + base) = + Input.bitValue value := by + rw [routineAddressed_apply_of_ne] + Β· simpa [Nat.add_comm] using hread + Β· simp only [address0Reg, wireBase] at hbase ⊒ + omega + Β· simp only [address1Reg, wireBase] at hbase ⊒ + omega + have haddress' : routineAddressed store 3 = gate.inputβ‚€ + base := by + simpa [address0Reg] using haddress + have hphysical' : routineAddressed store (gate.inputβ‚€ + base) = + Input.bitValue value := hphysical + simp [routineLoaded, loadOps, Basic.execList, Basic.exec, value0Reg, + value1Reg, address0Reg, address1Reg, haddress', hphysical'] + +private theorem routineLoaded_value1 {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value : Bool) (hvalue : wires[gate.input₁]? = some value) : + routineLoaded store value1Reg = Input.bitValue value := by + have hindex := List.getElem?_eq_some_iff.mp hvalue |>.1 + have hread := hready.wire_eq gate.input₁ hindex + simp [hvalue] at hread + have haddress := routineAddressed_address1 hready + have hbase : wireBase ≀ base := hready.base_ge + have hphysical : routineAddressed store (gate.input₁ + base) = + Input.bitValue value := by + rw [routineAddressed_apply_of_ne] + Β· simpa [Nat.add_comm] using hread + Β· simp only [address0Reg, wireBase] at hbase ⊒ + omega + Β· simp only [address1Reg, wireBase] at hbase ⊒ + omega + have haddress' : routineAddressed store 4 = gate.input₁ + base := by + simpa [address1Reg] using haddress + have hphysical' : routineAddressed store (gate.input₁ + base) = + Input.bitValue value := hphysical + let after0 := (Basic.load value0Reg address0Reg).exec (routineAddressed store) + have hafterAddress : after0 address1Reg = gate.input₁ + base := by + simp [after0, Basic.exec, value0Reg, address1Reg, haddress'] + have hafterPhysical : after0 (gate.input₁ + base) = Input.bitValue value := by + have hne : gate.input₁ + base β‰  value0Reg := by + simp only [value0Reg, wireBase] at hbase ⊒ + omega + simp [after0, Basic.exec, Function.update_of_ne hne, hphysical'] + change (Basic.load value1Reg address1Reg).exec after0 value1Reg = + Input.bitValue value + simp [Basic.exec, hafterAddress, hafterPhysical] + +private theorem routineLoaded_apply_of_ne (store : Store) (index : β„•) + (h0 : index β‰  value0Reg) (h1 : index β‰  value1Reg) + (ha0 : index β‰  address0Reg) (ha1 : index β‰  address1Reg) : + routineLoaded store index = store index := by + rw [show routineLoaded store index = routineAddressed store index by + simp [routineLoaded, loadOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1]] + exact routineAddressed_apply_of_ne store index ha0 ha1 + +private theorem xor_measured {bound value negated : β„•} {store : Store} + (hstore : StoreEnvelope bound bound store) (hbound : 2 ≀ bound) + (hvalue : value < bound) (houtput : outputReg < bound) + (hscratch : scratchReg < bound) + (hvalueOutput : value β‰  outputReg) + (hnegatedOutput : negated β‰  outputReg) + (valueBit negatedBit : Bool) + (hvalueEq : store value = Input.bitValue valueBit) + (hnegatedEq : store negated = Input.bitValue negatedBit) : + MeasuredRuns (.basics (xorOps value negated)) store + (Basic.execList (xorOps value negated) store) 4 + (16 * valueWidth bound) (envelopeSpace bound bound) ∧ + StoreEnvelope bound bound (Basic.execList (xorOps value negated) store) := by + let sum := (Basic.add outputReg value negated).exec store + let product := (Basic.mul scratchReg value negated).exec sum + let twice := (Basic.add scratchReg scratchReg scratchReg).exec product + have hsum : StoreEnvelope bound bound sum := by + apply hstore.execBasic (.add outputReg value negated) + Β· exact houtput + Β· change store value + store negated ≀ bound + rw [hvalueEq, hnegatedEq] + cases valueBit <;> cases negatedBit <;> simp [Input.bitValue] <;> omega + have hproduct : StoreEnvelope bound bound product := by + apply hsum.execBasic (.mul scratchReg value negated) + Β· exact hscratch + Β· change sum value * sum negated ≀ bound + cases valueBit <;> cases negatedBit <;> + simp [sum, Basic.exec, Function.update_of_ne, hvalueOutput, + hnegatedOutput, hvalueEq, hnegatedEq, Input.bitValue] + all_goals omega + have htwice : StoreEnvelope bound bound twice := by + apply hproduct.execBasic (.add scratchReg scratchReg scratchReg) + Β· exact hscratch + Β· change product scratchReg + product scratchReg ≀ bound + cases valueBit <;> cases negatedBit <;> + simp [product, sum, Basic.exec, Function.update_of_ne, + hvalueOutput, hnegatedOutput, hvalueEq, hnegatedEq, + Input.bitValue] + all_goals omega + have hfinal : StoreEnvelope bound bound + (Basic.execList (xorOps value negated) store) := by + change StoreEnvelope bound bound + ((Basic.sub value outputReg scratchReg).exec twice) + apply htwice.execBasic (.sub value outputReg scratchReg) + Β· exact hvalue + Β· exact le_trans (Nat.sub_le _ _) (htwice.value_le outputReg) + have hrun0 := MeasuredRuns.basicEnvelope (.add outputReg value negated) + store hstore hsum + have hrun1 := MeasuredRuns.basicEnvelope (.mul scratchReg value negated) + sum hsum hproduct + have hrun2 := MeasuredRuns.basicEnvelope (.add scratchReg scratchReg scratchReg) + product hproduct htwice + have hrun3 := MeasuredRuns.basicEnvelope (.sub value outputReg scratchReg) + twice htwice hfinal + refine ⟨?_, hfinal⟩ + have hrun := hrun0.seq (hrun1.seq (hrun2.seq hrun3)) + convert! hrun using 1 + ring + +private theorem routineNegated0_value {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + routineNegated0 store value0Reg = + Input.bitValue (gate.negatedβ‚€.xor value) := by + have hloadedValue := routineLoaded_value0 hready value hvalue + have hloadedNegated : routineLoaded store negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + rw [routineLoaded_apply_of_ne] + Β· exact hready.negated0_eq + Β· simp [negated0Reg, value0Reg] + Β· simp [negated0Reg, value1Reg] + Β· simp [negated0Reg, address0Reg] + Β· simp [negated0Reg, address1Reg] + have hloadedValue' : routineLoaded store 6 = Input.bitValue value := by + simpa [value0Reg] using hloadedValue + have hloadedNegated' : routineLoaded store 1 = + Input.bitValue gate.negatedβ‚€ := by + simpa [negated0Reg] using hloadedNegated + generalize hnegated : gate.negatedβ‚€ = negated + cases negated <;> cases value <;> + simp [routineNegated0, xorOps, Basic.execList, Basic.exec, Input.bitValue, + value0Reg, outputReg, scratchReg, negated0Reg, hnegated, + hloadedValue', hloadedNegated'] + +private theorem routineNegated0_apply_of_ne (store : Store) (index : β„•) + (hvalue : index β‰  value0Reg) (houtput : index β‰  outputReg) + (hscratch : index β‰  scratchReg) : + routineNegated0 store index = routineLoaded store index := by + simp [routineNegated0, xorOps, Basic.execList, Basic.exec, + Function.update_of_ne, hvalue, houtput, hscratch] + +private theorem routineNegated1_value {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value : Bool) (hvalue : wires[gate.input₁]? = some value) : + routineNegated1 store value1Reg = + Input.bitValue (gate.negated₁.xor value) := by + have hloadedValue := routineLoaded_value1 hready value hvalue + have hnegated0Value : routineNegated0 store value1Reg = Input.bitValue value := by + rw [routineNegated0_apply_of_ne] + Β· exact hloadedValue + Β· simp [value0Reg, value1Reg] + Β· simp [value1Reg, outputReg] + Β· simp [value1Reg, scratchReg] + have hloadedNegated : routineLoaded store negated1Reg = + Input.bitValue gate.negated₁ := by + rw [routineLoaded_apply_of_ne] + Β· exact hready.negated1_eq + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, value1Reg] + Β· simp [negated1Reg, address0Reg] + Β· simp [negated1Reg, address1Reg] + have hnegatedBit : routineNegated0 store negated1Reg = + Input.bitValue gate.negated₁ := by + rw [routineNegated0_apply_of_ne] + Β· exact hloadedNegated + Β· simp [negated1Reg, value0Reg] + Β· simp [negated1Reg, outputReg] + Β· simp [negated1Reg, scratchReg] + have hvalue' : routineNegated0 store 7 = Input.bitValue value := by + simpa [value1Reg] using hnegated0Value + have hnegated' : routineNegated0 store 2 = Input.bitValue gate.negated₁ := by + simpa [negated1Reg] using hnegatedBit + generalize hnegatedEq : gate.negated₁ = negated + cases negated <;> cases value <;> + simp [routineNegated1, xorOps, Basic.execList, Basic.exec, Input.bitValue, + value1Reg, outputReg, scratchReg, negated1Reg, hnegatedEq, + hvalue', hnegated'] + +private theorem routineNegated1_apply_of_ne (store : Store) (index : β„•) + (hvalue : index β‰  value1Reg) (houtput : index β‰  outputReg) + (hscratch : index β‰  scratchReg) : + routineNegated1 store index = routineNegated0 store index := by + simp [routineNegated1, xorOps, Basic.execList, Basic.exec, + Function.update_of_ne, hvalue, houtput, hscratch] + +private theorem routineNegated1_value0 {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value : Bool) (hvalue : wires[gate.inputβ‚€]? = some value) : + routineNegated1 store value0Reg = + Input.bitValue (gate.negatedβ‚€.xor value) := by + rw [routineNegated1_apply_of_ne] + Β· exact routineNegated0_value hready value hvalue + Β· simp [value0Reg, value1Reg] + Β· simp [value0Reg, outputReg] + Β· simp [value0Reg, scratchReg] + +private theorem routineNegated1_op {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineNegated1 store opReg = Input.bitValue gate.opBit := by + rw [routineNegated1_apply_of_ne] + Β· rw [routineNegated0_apply_of_ne] + Β· rw [routineLoaded_apply_of_ne] + Β· exact hready.op_eq + Β· simp [opReg, value0Reg] + Β· simp [opReg, value1Reg] + Β· simp [opReg, address0Reg] + Β· simp [opReg, address1Reg] + Β· simp [opReg, value0Reg] + Β· simp [opReg, outputReg] + Β· simp [opReg, scratchReg] + Β· simp [opReg, value1Reg] + Β· simp [opReg, outputReg] + Β· simp [opReg, scratchReg] + +private theorem routineEvaluated_output {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + routineEvaluated store outputReg = + Input.bitValue (gate.eval value0 value1) := by + have hvalue0' := routineNegated1_value0 hready value0 hvalue0 + have hvalue1' := routineNegated1_value hready value1 hvalue1 + have hop := routineNegated1_op hready + have hvalue0'' : routineNegated1 store 6 = + Input.bitValue (gate.negatedβ‚€.xor value0) := by + simpa [value0Reg] using hvalue0' + have hvalue1'' : routineNegated1 store 7 = + Input.bitValue (gate.negated₁.xor value1) := by + simpa [value1Reg] using hvalue1' + have hop' : routineNegated1 store 0 = Input.bitValue gate.opBit := by + simpa [opReg] using hop + rcases gate with ⟨op, input0, input1, negated0, negated1⟩ + cases op <;> cases negated0 <;> cases negated1 <;> + cases value0 <;> cases value1 <;> + simp [routineEvaluated, evalOps, Basic.execList, Basic.exec, Input.bitValue, + CircuitCode.RawGate.eval, CircuitCode.RawGate.opBit, opReg, value0Reg, + value1Reg, outputReg, scratchReg, address0Reg, hvalue0'', hvalue1'', hop'] + +private theorem routineEvaluated_stable (store : Store) (index : β„•) + (ha0 : index β‰  address0Reg) (ha1 : index β‰  address1Reg) + (hv0 : index β‰  value0Reg) (hv1 : index β‰  value1Reg) + (hout : index β‰  outputReg) (hscratch : index β‰  scratchReg) : + routineEvaluated store index = store index := by + rw [show routineEvaluated store index = routineNegated1 store index by + simp [routineEvaluated, evalOps, Basic.execList, Basic.exec, + Function.update_of_ne, ha0, hout, hscratch]] + rw [routineNegated1_apply_of_ne store index hv1 hout hscratch] + rw [routineNegated0_apply_of_ne store index hv0 hout hscratch] + exact routineLoaded_apply_of_ne store index hv0 hv1 ha0 ha1 + +private theorem routineEvaluated_wireCount {base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (hready : ReadyAt base gate wires store) : + routineEvaluated store wireCountReg = wires.length := by + rw [routineEvaluated_stable] + Β· exact hready.wireCount_eq + all_goals simp [wireCountReg, address0Reg, address1Reg, value0Reg, value1Reg, + outputReg, scratchReg] + +private theorem routineEvaluated_base {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineEvaluated store baseReg = base := by + rw [routineEvaluated_stable] + Β· exact hready.base_eq + all_goals simp [baseReg, address0Reg, address1Reg, value0Reg, value1Reg, + outputReg, scratchReg] + +private theorem routineEvaluated_wire {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (index : β„•) (hindex : index < wires.length) : + routineEvaluated store (base + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 := by + rw [routineEvaluated_stable] + Β· exact hready.wire_eq index hindex + all_goals have hbase := hready.base_ge + all_goals simp only [wireBase, address0Reg, address1Reg, value0Reg, value1Reg, + outputReg, scratchReg] at hbase ⊒ + all_goals omega + +private theorem routineFinal_output {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + routineFinal store outputReg = Input.bitValue (gate.eval value0 value1) := by + have houtput := routineEvaluated_output hready value0 value1 hvalue0 hvalue1 + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + have hbase' : routineEvaluated store 10 = base := by + simpa [baseReg] using hbase + have hcount' : routineEvaluated store 5 = wires.length := by + simpa [wireCountReg] using hcount + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, baseReg, wireCountReg, + hbase', hcount'] + have hsource : addressed outputReg = + Input.bitValue (gate.eval value0 value1) := by + simpa [addressed, Basic.exec, address1Reg, outputReg] using houtput + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) outputReg = _ + rw [haddress, hsource, Function.update_of_ne] + Β· exact hsource + Β· have hbaseGe := hready.base_ge + simp only [outputReg, wireBase] at hbaseGe ⊒ + omega + +private theorem routineFinal_appended {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + routineFinal store (base + wires.length) = + Input.bitValue (gate.eval value0 value1) := by + have houtput := routineEvaluated_output hready value0 value1 hvalue0 hvalue1 + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + have hbase' : routineEvaluated store 10 = base := by + simpa [baseReg] using hbase + have hcount' : routineEvaluated store 5 = wires.length := by + simpa [wireCountReg] using hcount + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, baseReg, wireCountReg, + hbase', hcount'] + have hsource : addressed outputReg = + Input.bitValue (gate.eval value0 value1) := by + simpa [addressed, Basic.exec, address1Reg, outputReg] using houtput + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) (base + wires.length) = _ + rw [haddress, hsource, Function.update_self] + +private theorem routineFinal_wire {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (index : β„•) (hindex : index < wires.length) : + routineFinal store (base + index) = Input.bitValue wires[index] := by + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + have hwire := routineEvaluated_wire hready index hindex + rw [List.getElem?_eq_getElem hindex] at hwire + have hbase' : routineEvaluated store 10 = base := by + simpa [baseReg] using hbase + have hcount' : routineEvaluated store 5 = wires.length := by + simpa [wireCountReg] using hcount + have hne : base + index β‰  base + wires.length := by omega + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, baseReg, wireCountReg, + hbase', hcount'] + have hpreserved : addressed (base + index) = + routineEvaluated store (base + index) := by + have hbaseGe := hready.base_ge + have hnotAddress : base + index β‰  address1Reg := by + simp only [address1Reg, wireBase] at hbaseGe ⊒ + omega + simp [addressed, Basic.exec, Function.update_of_ne hnotAddress] + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) (base + index) = _ + rw [haddress, Function.update_of_ne hne, hpreserved, hwire] + +private theorem routineFinal_base {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineFinal store baseReg = base := by + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, hbase, hcount] + have hpreserved : addressed baseReg = routineEvaluated store baseReg := by + simp [addressed, Basic.exec, Function.update_of_ne, address1Reg, baseReg] + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) baseReg = base + rw [haddress, Function.update_of_ne, hpreserved, hbase] + have hbaseGe := hready.base_ge + simp only [baseReg, wireBase] at hbaseGe ⊒ + omega + +private theorem routineFinal_wireCount {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) : + routineFinal store wireCountReg = wires.length := by + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, hbase, hcount] + have hpreserved : addressed wireCountReg = + routineEvaluated store wireCountReg := by + simp [addressed, Basic.exec, Function.update_of_ne, address1Reg, + wireCountReg] + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) wireCountReg = wires.length + rw [haddress, Function.update_of_ne, hpreserved, hcount] + have hbaseGe := hready.base_ge + simp only [wireCountReg, wireBase] at hbaseGe ⊒ + omega + +private theorem routineFinal_frame {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (index : β„•) (hhigh : wireBase ≀ index) + (happend : index β‰  base + wires.length) : + routineFinal store index = store index := by + have hevaluated : routineEvaluated store index = store index := by + rw [routineEvaluated_stable] + all_goals simp only [wireBase, address0Reg, address1Reg, value0Reg, + value1Reg, outputReg, scratchReg] at hhigh ⊒ + all_goals omega + have hbase := routineEvaluated_base hready + have hcount := routineEvaluated_wireCount hready + let addressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have haddress : addressed address1Reg = base + wires.length := by + simp [addressed, Basic.exec, address1Reg, hbase, hcount] + have haddressed : addressed index = routineEvaluated store index := by + have hne : index β‰  address1Reg := by + simp only [wireBase, address1Reg] at hhigh ⊒ + omega + simp [addressed, Basic.exec, Function.update_of_ne hne] + rw [routineFinal, appendOps, Basic.execList] + change Function.update addressed (addressed address1Reg) + (addressed outputReg) index = store index + rw [haddress, Function.update_of_ne happend, haddressed, hevaluated] + +/-- The six evaluation operations preserve the store envelope and their measured cost. -/ +private theorem routine_evaluation_measured {bound base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (hready : ReadyAt base gate wires store) + (hnegated1 : StoreEnvelope bound bound (routineNegated1 store)) + (hsmall : 10 < bound) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + StoreEnvelope bound bound (routineEvaluated store) ∧ + MeasuredRuns (.basics evalOps) (routineNegated1 store) + (routineEvaluated store) 6 (24 * valueWidth bound) + (envelopeSpace bound bound) := by + have htwo : 2 ≀ bound := by omega + have hvalue0Eq := routineNegated1_value0 hready value0 hvalue0 + have hvalue1Eq := routineNegated1_value hready value1 hvalue1 + have hopEq := routineNegated1_op hready + let product := (Basic.mul scratchReg value0Reg value1Reg).exec + (routineNegated1 store) + let sum := (Basic.add outputReg value0Reg value1Reg).exec product + let orStore := (Basic.sub outputReg outputReg scratchReg).exec sum + let delta := (Basic.sub address0Reg outputReg scratchReg).exec orStore + let selected := (Basic.mul address0Reg opReg address0Reg).exec delta + have hproduct : StoreEnvelope bound bound product := by + apply hnegated1.execBasic (.mul scratchReg value0Reg value1Reg) + Β· simp [scratchReg] + omega + Β· change routineNegated1 store value0Reg * + routineNegated1 store value1Reg ≀ bound + rw [hvalue0Eq, hvalue1Eq] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp [Input.bitValue] <;> omega + have hproductValue0 : product value0Reg = + Input.bitValue (gate.negatedβ‚€.xor value0) := by + rw [show product value0Reg = routineNegated1 store value0Reg by + simp [product, Basic.exec, Function.update_of_ne, value0Reg, scratchReg]] + exact hvalue0Eq + have hproductValue1 : product value1Reg = + Input.bitValue (gate.negated₁.xor value1) := by + rw [show product value1Reg = routineNegated1 store value1Reg by + simp [product, Basic.exec, Function.update_of_ne, value1Reg, scratchReg]] + exact hvalue1Eq + have hsum : StoreEnvelope bound bound sum := by + apply hproduct.execBasic (.add outputReg value0Reg value1Reg) + Β· simp [outputReg] + omega + Β· change product value0Reg + product value1Reg ≀ bound + rw [hproductValue0, hproductValue1] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp [Input.bitValue] <;> omega + have hsumOutput : sum outputReg ≀ 2 := by + change product value0Reg + product value1Reg ≀ 2 + rw [hproductValue0, hproductValue1] + cases gate.negatedβ‚€ <;> cases gate.negated₁ <;> + cases value0 <;> cases value1 <;> simp [Input.bitValue] + have hor : StoreEnvelope bound bound orStore := by + apply hsum.execBasic (.sub outputReg outputReg scratchReg) + Β· simp [outputReg] + omega + Β· exact le_trans (Nat.sub_le _ _) (le_trans hsumOutput htwo) + have horOutput : orStore outputReg ≀ 2 := + le_trans (Nat.sub_le _ _) hsumOutput + have hdelta : StoreEnvelope bound bound delta := by + apply hor.execBasic (.sub address0Reg outputReg scratchReg) + Β· simp [address0Reg] + omega + Β· exact le_trans (Nat.sub_le _ _) (le_trans horOutput htwo) + have hdeltaValue : delta address0Reg ≀ 2 := + le_trans (Nat.sub_le _ _) horOutput + have hselected : StoreEnvelope bound bound selected := by + apply hdelta.execBasic (.mul address0Reg opReg address0Reg) + Β· simp [address0Reg] + omega + Β· have hop : delta opReg = Input.bitValue gate.opBit := by + rw [show delta opReg = routineNegated1 store opReg by + simp [delta, orStore, sum, product, Basic.exec, + Function.update_of_ne, opReg, address0Reg, outputReg, scratchReg, + value0Reg, value1Reg]] + exact hopEq + change delta opReg * delta address0Reg ≀ bound + rw [hop] + cases gate.opBit <;> simp [Input.bitValue] + exact le_trans hdeltaValue htwo + have hevaluated : StoreEnvelope bound bound (routineEvaluated store) := by + change StoreEnvelope bound bound + ((Basic.sub outputReg outputReg address0Reg).exec selected) + apply hselected.execBasic (.sub outputReg outputReg address0Reg) + Β· simp [outputReg] + omega + Β· exact le_trans (Nat.sub_le _ _) (hselected.value_le outputReg) + have hevalRun0 := MeasuredRuns.basicEnvelope + (.mul scratchReg value0Reg value1Reg) (routineNegated1 store) + hnegated1 hproduct + have hevalRun1 := MeasuredRuns.basicEnvelope + (.add outputReg value0Reg value1Reg) product hproduct hsum + have hevalRun2 := MeasuredRuns.basicEnvelope + (.sub outputReg outputReg scratchReg) sum hsum hor + have hevalRun3 := MeasuredRuns.basicEnvelope + (.sub address0Reg outputReg scratchReg) orStore hor hdelta + have hevalRun4 := MeasuredRuns.basicEnvelope + (.mul address0Reg opReg address0Reg) delta hdelta hselected + have hevalRun5 := MeasuredRuns.basicEnvelope + (.sub outputReg outputReg address0Reg) selected hselected hevaluated + have hevalRun : MeasuredRuns (.basics evalOps) (routineNegated1 store) + (routineEvaluated store) 6 (24 * valueWidth bound) + (envelopeSpace bound bound) := by + have hrun := hevalRun0.seq (hevalRun1.seq (hevalRun2.seq + (hevalRun3.seq (hevalRun4.seq hevalRun5)))) + convert! hrun using 1 + ring + exact ⟨hevaluated, hevalRun⟩ + +theorem routine_measured_internal {bound base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (hready : ReadyAt base gate wires store) + (hstore : StoreEnvelope bound bound store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (happend : base + wires.length < bound) : + βˆƒ final, + MeasuredRuns program store final stepCount (80 * valueWidth bound) + (envelopeSpace bound bound) ∧ + StoreEnvelope bound bound final ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (base + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + final baseReg = base ∧ final wireCountReg = wires.length ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ index, wireBase ≀ index β†’ index β‰  base + wires.length β†’ + final index = store index := by + have hinput0 : gate.inputβ‚€ < wires.length := + List.getElem?_eq_some_iff.mp hvalue0 |>.1 + have hinput1 : gate.input₁ < wires.length := + List.getElem?_eq_some_iff.mp hvalue1 |>.1 + have hsmall : 10 < bound := by + have hbase := hready.base_ge + simp only [wireBase] at hbase + omega + have htwo : 2 ≀ bound := by omega + let addressed0 := (Basic.add address0Reg address0Reg baseReg).exec store + have haddressed0 : StoreEnvelope bound bound addressed0 := by + apply hstore.execBasic (.add address0Reg address0Reg baseReg) + Β· simp [address0Reg] + omega + Β· change store address0Reg + store baseReg ≀ bound + rw [hready.address0_eq, hready.base_eq] + omega + have haddressed : StoreEnvelope bound bound (routineAddressed store) := by + change StoreEnvelope bound bound + ((Basic.add address1Reg address1Reg baseReg).exec addressed0) + apply haddressed0.execBasic (.add address1Reg address1Reg baseReg) + Β· simp [address1Reg] + omega + Β· change addressed0 address1Reg + addressed0 baseReg ≀ bound + have haddress1 : addressed0 address1Reg = gate.input₁ := by + simp [addressed0, Basic.exec, Function.update_of_ne, address0Reg, + address1Reg] + exact hready.address1_eq + have hbase : addressed0 baseReg = base := by + simp [addressed0, Basic.exec, Function.update_of_ne, address0Reg, + baseReg] + exact hready.base_eq + rw [haddress1, hbase] + omega + have haddressRun0 := MeasuredRuns.basicEnvelope + (.add address0Reg address0Reg baseReg) store hstore haddressed0 + have haddressRun1 := MeasuredRuns.basicEnvelope + (.add address1Reg address1Reg baseReg) addressed0 haddressed0 haddressed + have haddressRun : MeasuredRuns (.basics addressOps) store + (routineAddressed store) 2 (8 * valueWidth bound) + (envelopeSpace bound bound) := by + have hrun := haddressRun0.seq haddressRun1 + convert! hrun using 1 + ring + let loaded0 := (Basic.load value0Reg address0Reg).exec (routineAddressed store) + have hloaded0 : StoreEnvelope bound bound loaded0 := by + apply haddressed.execBasic (.load value0Reg address0Reg) + Β· simp [value0Reg] + omega + Β· exact haddressed.value_le (routineAddressed store address0Reg) + have hloaded : StoreEnvelope bound bound (routineLoaded store) := by + change StoreEnvelope bound bound + ((Basic.load value1Reg address1Reg).exec loaded0) + apply hloaded0.execBasic (.load value1Reg address1Reg) + Β· simp [value1Reg] + omega + Β· exact hloaded0.value_le (loaded0 address1Reg) + have hloadRun0 := MeasuredRuns.basicEnvelope (.load value0Reg address0Reg) + (routineAddressed store) haddressed hloaded0 + have hloadRun1 := MeasuredRuns.basicEnvelope (.load value1Reg address1Reg) + loaded0 hloaded0 hloaded + have hloadRun : MeasuredRuns (.basics loadOps) (routineAddressed store) + (routineLoaded store) 2 (8 * valueWidth bound) + (envelopeSpace bound bound) := by + have hrun := hloadRun0.seq hloadRun1 + convert! hrun using 1 + ring + have hloadedValue0 := routineLoaded_value0 hready value0 hvalue0 + have hloadedNegated0 : routineLoaded store negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + rw [routineLoaded_apply_of_ne] + Β· exact hready.negated0_eq + all_goals simp [negated0Reg, value0Reg, value1Reg, address0Reg, address1Reg] + have hxor0 := xor_measured hloaded htwo + (value := value0Reg) (negated := negated0Reg) + (by simp [value0Reg]; omega) (by simp [outputReg]; omega) + (by simp [scratchReg]; omega) (by simp [value0Reg, outputReg]) + (by simp [negated0Reg, outputReg]) value0 gate.negatedβ‚€ + hloadedValue0 hloadedNegated0 + have hnegated0 := hxor0.2 + have hnegated0Run : MeasuredRuns (.basics (xorOps value0Reg negated0Reg)) + (routineLoaded store) (routineNegated0 store) 4 + (16 * valueWidth bound) (envelopeSpace bound bound) := by + simpa [routineNegated0] using hxor0.1 + have hnegated0Value1 : routineNegated0 store value1Reg = + Input.bitValue value1 := by + rw [routineNegated0_apply_of_ne] + Β· exact routineLoaded_value1 hready value1 hvalue1 + all_goals simp [value0Reg, value1Reg, outputReg, scratchReg] + have hnegated0Negated1 : routineNegated0 store negated1Reg = + Input.bitValue gate.negated₁ := by + rw [routineNegated0_apply_of_ne] + Β· rw [routineLoaded_apply_of_ne] + Β· exact hready.negated1_eq + all_goals simp [negated1Reg, value0Reg, value1Reg, address0Reg, address1Reg] + all_goals simp [negated1Reg, value0Reg, outputReg, scratchReg] + have hxor1 := xor_measured hnegated0 htwo + (value := value1Reg) (negated := negated1Reg) + (by simp [value1Reg]; omega) (by simp [outputReg]; omega) + (by simp [scratchReg]; omega) (by simp [value1Reg, outputReg]) + (by simp [negated1Reg, outputReg]) value1 gate.negated₁ + hnegated0Value1 hnegated0Negated1 + have hnegated1 := hxor1.2 + have hnegated1Run : MeasuredRuns (.basics (xorOps value1Reg negated1Reg)) + (routineNegated0 store) (routineNegated1 store) 4 + (16 * valueWidth bound) (envelopeSpace bound bound) := by + simpa [routineNegated1] using! hxor1.1 + obtain ⟨hevaluated, hevalRun⟩ := routine_evaluation_measured hready + hnegated1 hsmall value0 value1 hvalue0 hvalue1 + let appendAddressed := + (Basic.add address1Reg baseReg wireCountReg).exec (routineEvaluated store) + have happendAddressed : StoreEnvelope bound bound appendAddressed := by + apply hevaluated.execBasic (.add address1Reg baseReg wireCountReg) + Β· simp [address1Reg] + omega + Β· change routineEvaluated store baseReg + + routineEvaluated store wireCountReg ≀ bound + rw [routineEvaluated_base hready, routineEvaluated_wireCount hready] + omega + have hfinal : StoreEnvelope bound bound (routineFinal store) := by + change StoreEnvelope bound bound + ((Basic.store address1Reg outputReg).exec appendAddressed) + apply happendAddressed.execBasic (.store address1Reg outputReg) + Β· change appendAddressed address1Reg < bound + change routineEvaluated store baseReg + + routineEvaluated store wireCountReg < bound + rw [routineEvaluated_base hready, routineEvaluated_wireCount hready] + exact happend + Β· exact happendAddressed.value_le outputReg + have happendRun0 := MeasuredRuns.basicEnvelope + (.add address1Reg baseReg wireCountReg) (routineEvaluated store) + hevaluated happendAddressed + have happendRun1 := MeasuredRuns.basicEnvelope + (.store address1Reg outputReg) appendAddressed happendAddressed hfinal + have happendRun : MeasuredRuns (.basics appendOps) (routineEvaluated store) + (routineFinal store) 2 (8 * valueWidth bound) + (envelopeSpace bound bound) := by + have hrun := happendRun0.seq happendRun1 + convert! hrun using 1 + ring + have hrun := haddressRun.seq (hloadRun.seq + (hnegated0Run.seq (hnegated1Run.seq (hevalRun.seq happendRun)))) + have hprogram : MeasuredRuns program store (routineFinal store) stepCount + (80 * valueWidth bound) (envelopeSpace bound bound) := by + convert! hrun using 1 + all_goals ring + exact ⟨routineFinal store, hprogram, hfinal, + routineFinal_output hready value0 value1 hvalue0 hvalue1, + routineFinal_appended hready value0 value1 hvalue0 hvalue1, + routineFinal_base hready, routineFinal_wireCount hready, + routineFinal_wire hready, routineFinal_frame hready⟩ + +theorem routine_exec_internal {base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} (hready : ReadyAt base gate wires store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program store final stepCount cost space ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (base + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + final baseReg = base ∧ final wireCountReg = wires.length ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ index, wireBase ≀ index β†’ index β‰  base + wires.length β†’ + final index = store index := by + obtain ⟨addressCost, addressSpace, haddress⟩ := + exec_basics_exists addressOps store + obtain ⟨loadCost, loadSpace, hload⟩ := + exec_basics_exists loadOps (routineAddressed store) + obtain ⟨negated0Cost, negated0Space, hnegated0⟩ := + exec_basics_exists (xorOps value0Reg negated0Reg) (routineLoaded store) + obtain ⟨negated1Cost, negated1Space, hnegated1⟩ := + exec_basics_exists (xorOps value1Reg negated1Reg) (routineNegated0 store) + obtain ⟨evalCost, evalSpace, heval⟩ := + exec_basics_exists evalOps (routineNegated1 store) + obtain ⟨appendCost, appendSpace, happend⟩ := + exec_basics_exists appendOps (routineEvaluated store) + have hrun := haddress.seq (hload.seq + (hnegated0.seq (hnegated1.seq (heval.seq happend)))) + refine ⟨routineFinal store, + addressCost + (loadCost + (negated0Cost + + (negated1Cost + (evalCost + appendCost)))), + max addressSpace (max loadSpace (max negated0Space + (max negated1Space (max evalSpace appendSpace)))), ?_, + routineFinal_output hready value0 value1 hvalue0 hvalue1, + routineFinal_appended hready value0 value1 hvalue0 hvalue1, + routineFinal_base hready, routineFinal_wireCount hready, ?_, + routineFinal_frame hready⟩ + Β· rw [program] + convert! hrun using 1 + Β· intro index hindex + exact routineFinal_wire hready index hindex + +private theorem finalStore_output_internal (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + finalStore gate wires outputReg = Input.bitValue (gate.eval value0 value1) := + finalStore_output gate wires value0 value1 hvalue0 hvalue1 + +theorem program_exec_internal (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final stepCount cost space ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) := by + obtain ⟨addressCost, addressSpace, haddress⟩ := + exec_basics_exists addressOps (inputStore gate wires) + obtain ⟨loadCost, loadSpace, hload⟩ := + exec_basics_exists loadOps (addressed gate wires) + obtain ⟨negated0Cost, negated0Space, hnegated0⟩ := + exec_basics_exists (xorOps value0Reg negated0Reg) (loaded gate wires) + obtain ⟨negated1Cost, negated1Space, hnegated1⟩ := + exec_basics_exists (xorOps value1Reg negated1Reg) (negated0 gate wires) + obtain ⟨evalCost, evalSpace, heval⟩ := + exec_basics_exists evalOps (negated1 gate wires) + obtain ⟨appendCost, appendSpace, happend⟩ := + exec_basics_exists appendOps (evaluated gate wires) + have hrun := haddress.seq (hload.seq + (hnegated0.seq (hnegated1.seq (heval.seq happend)))) + refine ⟨finalStore gate wires, + addressCost + (loadCost + (negated0Cost + + (negated1Cost + (evalCost + appendCost)))), + max addressSpace (max loadSpace (max negated0Space + (max negated1Space (max evalSpace appendSpace)))), ?_, ?_⟩ + Β· rw [program] + convert! hrun using 1 + Β· exact finalStore_output gate wires value0 value1 hvalue0 hvalue1 + +theorem program_measured_internal (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) + (hgate : gate.WellFormedAt wires.length) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final stepCount cost space ∧ + cost ≀ timeBound wires.length ∧ space ≀ spaceBound wires.length ∧ + final outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (wireBase + wires.length) = Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (wireBase + index) = Input.bitValue wires[index] := by + have haddress := (address_measured gate wires hgate).1 + have hload := (load_measured gate wires hgate).1 + have hnegated0 := (negated0_measured gate wires value0 hvalue0 hgate).1 + have hnegated1 := + (negated1_measured gate wires value0 value1 hvalue0 hvalue1 hgate).1 + have heval := (eval_measured gate wires value0 value1 hvalue0 hvalue1 hgate).1 + have happend := + (append_measured gate wires value0 value1 hvalue0 hvalue1 hgate).1 + have hrun := haddress.seq (hload.seq + (hnegated0.seq (hnegated1.seq (heval.seq happend)))) + have hprogram : MeasuredRuns program (inputStore gate wires) + (finalStore gate wires) stepCount (timeBound wires.length) + (resourceSpace wires.length) := by + convert! hrun using 1 + simp [timeBound, width, valueWidth] + ring + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hprogram + have hspace' : space ≀ spaceBound wires.length := by + rw [← envelopeSpace_eq_spaceBound] + exact hspace + exact ⟨finalStore gate wires, cost, space, hexec, hcost, hspace', + finalStore_output gate wires value0 value1 hvalue0 hvalue1, + finalStore_appended gate wires value0 value1 hvalue0 hvalue1, + finalStore_wire gate wires⟩ + +end GateEval + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep.lean new file mode 100644 index 0000000000..9cf9861546 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified structured RAM serialized-gate step + +This module is the first end-to-end composition of the structured RAM parser +and mutable-data APIs. One fixed program consumes a canonical gate encoding, +invokes the same cursor loop for both unary references, discovers the following +memo base at runtime, evaluates the decoded gate, and appends its result. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStep + +/-- Source correctness and exact transition count for one canonical gate. -/ +theorem program_correct (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := + program_exec_internal gate wires value0 value1 hvalue0 hvalue1 + +/-- Source correctness, exact transitions, and closed-form logarithmic resource +bounds for one serialized gate and its current memo. -/ +theorem program_performance (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + cost ≀ timeBound gate wires ∧ space ≀ spaceBound gate wires ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := + program_measured_internal gate wires value0 value1 hvalue0 hvalue1 + +/-- Compilation preserves the exact serialized-gate run and its memo result. -/ +theorem compiled_correct (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + run compiled (stepCount gate) { pc := 0, regs := inputStore gate wires } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount gate) { pc := 0, regs := inputStore gate wires }) ∧ + logTimeUpto compiled (stepCount gate) + { pc := 0, regs := inputStore gate wires } = cost ∧ + spaceUpto compiled (stepCount gate) + { pc := 0, regs := inputStore gate wires } = space ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := by + obtain ⟨final, cost, space, hexec, houtput, happended, hpreserved⟩ := + program_correct gate wires value0 value1 hvalue0 hvalue1 + have hcompiled := Exec.compile_correct hexec + exact ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + hcompiled.2.1, hcompiled.2.2, houtput, happended, hpreserved⟩ + +/-- Compilation transfers the serialized-gate result and both source resource +bounds exactly to the concrete logarithmic-cost RAM. -/ +theorem compiled_performance (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + cost ≀ timeBound gate wires ∧ space ≀ spaceBound gate wires ∧ + run compiled (stepCount gate) { pc := 0, regs := inputStore gate wires } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount gate) { pc := 0, regs := inputStore gate wires }) ∧ + logTimeUpto compiled (stepCount gate) + { pc := 0, regs := inputStore gate wires } = cost ∧ + spaceUpto compiled (stepCount gate) + { pc := 0, regs := inputStore gate wires } = space ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := by + obtain ⟨final, cost, space, hexec, hcost, hspace, + houtput, happended, hpreserved⟩ := + program_performance gate wires value0 value1 hvalue0 hvalue1 + have hcompiled := Exec.compile_correct hexec + exact ⟨final, cost, space, hexec, hcost, hspace, hcompiled.1, + Exec.compile_halted hexec, hcompiled.2.1, hcompiled.2.2, + houtput, happended, hpreserved⟩ + +end GateStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Defs.lean new file mode 100644 index 0000000000..0354fd8dca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Defs.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs + +/-! +# Structured RAM serialized-gate step β€” definitions + +This program composes the terminated-unary cursor routine with the decoded-gate +kernel. Its input is one canonical gate encoding followed immediately by the +current Boolean wire memo. The fixed three-bit header is consumed directly, +the two references are decoded by two calls to the same loop, and the resulting +gate is evaluated and appended without specializing the program to the input. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStep + +/-- The operation header bit is retained in the consumed input prefix. -/ +def headerOpReg : β„• := UnaryDecode.inputBase +/-- The first negation header bit is retained in the consumed input prefix. -/ +def headerNegated0Reg : β„• := UnaryDecode.inputBase + 1 +/-- The second negation header bit is retained in the consumed input prefix. -/ +def headerNegated1Reg : β„• := UnaryDecode.inputBase + 2 +/-- The first decoded reference is retained in the consumed input prefix. -/ +def savedInput0Reg : β„• := UnaryDecode.inputBase + 3 + +/-- Canonical gate code followed by its current wire memo. -/ +def inputBits (gate : CircuitCode.RawGate) (wires : List Bool) : List Bool := + gate.encode ++ wires + +/-- First physical register occupied by the wire memo. -/ +def memoBase (gate : CircuitCode.RawGate) : β„• := + UnaryDecode.inputBase + gate.encode.length + +/-- Machine input for one serialized gate and the current wire memo. -/ +def inputStore (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Input.bitStore UnaryDecode.remainingReg UnaryDecode.inputBase + (inputBits gate wires) + +/-- Consume and retain the fixed operation and negation header bits. -/ +def headerOps : List Basic := + [.load headerOpReg UnaryDecode.pointerReg, + .add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg, + .load headerNegated0Reg UnaryDecode.pointerReg, + .add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg, + .load headerNegated1Reg UnaryDecode.pointerReg, + .add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg] + +/-- Save the first reference and restart the cursor accumulator for the second. -/ +def saveRestartOps : List Basic := + [.add savedInput0Reg UnaryDecode.valueReg UnaryDecode.activeReg, + .imm UnaryDecode.verdictReg 0, + .imm UnaryDecode.valueReg 0, + .imm UnaryDecode.activeReg 1] + +/-- Marshal the parsed cursor state into the decoded-gate evaluator ABI. -/ +def marshalOps : List Basic := + [.add GateEval.wireCountReg UnaryDecode.remainingReg UnaryDecode.activeReg, + .add GateEval.address1Reg UnaryDecode.valueReg UnaryDecode.activeReg, + .add GateEval.address0Reg savedInput0Reg UnaryDecode.activeReg, + .add GateEval.baseReg UnaryDecode.pointerReg UnaryDecode.activeReg, + .add GateEval.opReg headerOpReg UnaryDecode.activeReg, + .add GateEval.negated0Reg headerNegated0Reg UnaryDecode.activeReg, + .add GateEval.negated1Reg headerNegated1Reg UnaryDecode.activeReg] + +/-- Parse and evaluate one serialized gate, appending its result to the memo. -/ +def program : Cmd := Cmd.seqList + [UnaryDecode.setup, + .basics headerOps, + UnaryDecode.mainLoop, + .basics saveRestartOps, + UnaryDecode.mainLoop, + .basics marshalOps, + GateEval.program] + +/-- Concrete compiled serialized-gate step. -/ +def compiled : Program := program.compile + +/-- Exact transition count for a canonical serialized gate. -/ +def stepCount (gate : CircuitCode.RawGate) : β„• := + 10 * (gate.inputβ‚€ + gate.input₁) + 67 + +/-- Uniform envelope including the newly appended wire. -/ +def storeBound (gate : CircuitCode.RawGate) (wires : List Bool) : β„• := + (inputBits gate wires).length + UnaryDecode.inputBase + 1 + +/-- Explicit logarithmic-cost budget for one serialized-gate step. -/ +def timeBound (gate : CircuitCode.RawGate) (wires : List Bool) : β„• := + 512 * ((inputBits gate wires).length + 1) * + (bitlen (storeBound gate wires) + 1) + +/-- Explicit peak-space budget including the appended memo cell. -/ +def spaceBound (gate : CircuitCode.RawGate) (wires : List Bool) : β„• := + storeBound gate wires * (2 * bitlen (storeBound gate wires)) + +end GateStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Internal.lean new file mode 100644 index 0000000000..780fd28f6c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStep/Internal.lean @@ -0,0 +1,1102 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal.Codec +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Internal +public import Mathlib.Tactic.IntervalCases + +/-! +# Structured RAM serialized-gate step β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStep + +open Internal + +private abbrev cursorBound (gate : CircuitCode.RawGate) (wires : List Bool) : β„• := + (inputBits gate wires).length + UnaryDecode.inputBase + +private abbrev CursorEnvelope (gate : CircuitCode.RawGate) (wires : List Bool) + (store : Store) : Prop := + StoreEnvelope (cursorBound gate wires) (cursorBound gate wires) store + +private def setupStore (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList UnaryDecode.setupOps (inputStore gate wires) + +private def headerStore (gate : CircuitCode.RawGate) (wires : List Bool) : Store := + Basic.execList headerOps (setupStore gate wires) + +private def saveRestartStore (store : Store) : Store := + Basic.execList saveRestartOps store + +private def marshalStore (store : Store) : Store := + Basic.execList marshalOps store + +private theorem input_bound (gate : CircuitCode.RawGate) (wires : List Bool) : + CursorEnvelope gate wires (inputStore gate wires) := by + apply Input.bitStoreEnvelope + Β· simp [cursorBound, inputBits, UnaryDecode.remainingReg, + UnaryDecode.inputBase] + Β· simp [cursorBound, UnaryDecode.inputBase] + omega + Β· simp [cursorBound, UnaryDecode.inputBase] + Β· simp [cursorBound, inputBits, UnaryDecode.inputBase] + +private theorem setup_measured (gate : CircuitCode.RawGate) (wires : List Bool) : + MeasuredRuns UnaryDecode.setup (inputStore gate wires) + (setupStore gate wires) 5 + (20 * valueWidth (cursorBound gate wires)) + (envelopeSpace (cursorBound gate wires) (cursorBound gate wires)) ∧ + CursorEnvelope gate wires (setupStore gate wires) := by + have hinitial := input_bound gate wires + have hpreserve : βˆ€ op, op ∈ UnaryDecode.setupOps β†’ βˆ€ store, + CursorEnvelope gate wires store β†’ CursorEnvelope gate wires (op.exec store) := by + intro op hop store hstore + simp [UnaryDecode.setupOps] at hop + rcases hop with rfl | rfl | rfl | rfl | rfl + Β· apply hstore.execBasic (.imm UnaryDecode.verdictReg 0) <;> + simp [cursorBound, inputBits, UnaryDecode.verdictReg, + UnaryDecode.inputBase] + Β· apply hstore.execBasic (.imm UnaryDecode.valueReg 0) <;> + simp [cursorBound, inputBits, UnaryDecode.valueReg, + UnaryDecode.inputBase] + Β· apply hstore.execBasic (.imm UnaryDecode.pointerReg UnaryDecode.inputBase) + Β· simp [cursorBound, inputBits, UnaryDecode.pointerReg, + UnaryDecode.inputBase] + Β· simp [Basic.writeValue, cursorBound, inputBits, UnaryDecode.inputBase] + Β· apply hstore.execBasic (.imm UnaryDecode.oneReg 1) <;> + simp [cursorBound, inputBits, UnaryDecode.oneReg, UnaryDecode.inputBase] + Β· apply hstore.execBasic (.imm UnaryDecode.activeReg 1) <;> + simp [cursorBound, inputBits, UnaryDecode.activeReg, + UnaryDecode.inputBase] + simpa [UnaryDecode.setup, setupStore] using! + MeasuredRuns.basicsEnvelope UnaryDecode.setupOps (inputStore gate wires) + hinitial hpreserve + +private theorem header_high (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) (hindex : 10 ≀ index) : + headerStore gate wires index = inputStore gate wires index := by + have h0 : index β‰  0 := by omega + have h1 : index β‰  1 := by omega + have h2 : index β‰  2 := by omega + have h3 : index β‰  3 := by omega + have h4 : index β‰  4 := by omega + have h6 : index β‰  6 := by omega + have h7 : index β‰  7 := by omega + have h8 : index β‰  8 := by omega + have h9 : index β‰  9 := by omega + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, Function.update_of_ne, h0, h1, h2, h3, h4, h6, + h7, h8, h9, headerOpReg, headerNegated0Reg, headerNegated1Reg, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, UnaryDecode.activeReg, + UnaryDecode.inputBase] + +private theorem header_bound (gate : CircuitCode.RawGate) (wires : List Bool) : + CursorEnvelope gate wires (headerStore gate wires) := by + have hinitial := input_bound gate wires + have hlarge : 10 < cursorBound gate wires := by + simp [cursorBound, inputBits, CircuitCode.RawGate.encode, + UnaryDecode.inputBase] + constructor + Β· intro index hnonzero + by_cases hindex : index < 10 + Β· omega + Β· rw [header_high gate wires index (by omega)] at hnonzero + exact hinitial.index_lt index hnonzero + Β· intro index + by_cases hindex : index < 10 + Β· interval_cases index <;> + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, inputBits, + CircuitCode.RawGate.encode, cursorBound, headerOpReg, + headerNegated0Reg, headerNegated1Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, UnaryDecode.activeReg, + UnaryDecode.inputBase] + all_goals try omega + all_goals split <;> simp + Β· rw [header_high gate wires index (by omega)] + exact hinitial.value_le index + +private theorem header_measured (gate : CircuitCode.RawGate) (wires : List Bool) : + MeasuredRuns (.basics headerOps) (setupStore gate wires) + (headerStore gate wires) 9 + (36 * valueWidth (cursorBound gate wires)) + (envelopeSpace (cursorBound gate wires) (cursorBound gate wires)) ∧ + CursorEnvelope gate wires (headerStore gate wires) := by + have hsetup := (setup_measured gate wires).2 + have hlarge : 10 < cursorBound gate wires := by + simp [cursorBound, inputBits, CircuitCode.RawGate.encode, + UnaryDecode.inputBase] + let s1 := (Basic.load headerOpReg UnaryDecode.pointerReg).exec + (setupStore gate wires) + let s2 := (Basic.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg).exec s1 + let s3 := (Basic.sub UnaryDecode.remainingReg UnaryDecode.remainingReg + UnaryDecode.oneReg).exec s2 + let s4 := (Basic.load headerNegated0Reg UnaryDecode.pointerReg).exec s3 + let s5 := (Basic.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg).exec s4 + let s6 := (Basic.sub UnaryDecode.remainingReg UnaryDecode.remainingReg + UnaryDecode.oneReg).exec s5 + let s7 := (Basic.load headerNegated1Reg UnaryDecode.pointerReg).exec s6 + let s8 := (Basic.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg).exec s7 + have hsetupPointer : setupStore gate wires UnaryDecode.pointerReg = + UnaryDecode.inputBase := by + simp [setupStore, UnaryDecode.setupOps, Basic.execList, Basic.exec, + UnaryDecode.pointerReg, UnaryDecode.oneReg, UnaryDecode.activeReg] + have hsetupOne : setupStore gate wires UnaryDecode.oneReg = 1 := by + simp [setupStore, UnaryDecode.setupOps, Basic.execList, Basic.exec, + UnaryDecode.pointerReg, UnaryDecode.oneReg, UnaryDecode.activeReg] + have h1 : CursorEnvelope gate wires s1 := by + apply hsetup.execBasic (.load headerOpReg UnaryDecode.pointerReg) + Β· simp [headerOpReg, UnaryDecode.inputBase] + omega + Β· exact hsetup.value_le (setupStore gate wires UnaryDecode.pointerReg) + have hs1Pointer : s1 UnaryDecode.pointerReg = UnaryDecode.inputBase := by + rw [show s1 UnaryDecode.pointerReg = + setupStore gate wires UnaryDecode.pointerReg by + simp [s1, Basic.exec, Function.update_of_ne, headerOpReg, + UnaryDecode.pointerReg, UnaryDecode.inputBase]] + exact hsetupPointer + have hs1One : s1 UnaryDecode.oneReg = 1 := by + rw [show s1 UnaryDecode.oneReg = setupStore gate wires UnaryDecode.oneReg by + simp [s1, Basic.exec, Function.update_of_ne, headerOpReg, + UnaryDecode.oneReg, UnaryDecode.inputBase]] + exact hsetupOne + have h2 : CursorEnvelope gate wires s2 := by + apply h1.execBasic (.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg) + Β· simp [UnaryDecode.pointerReg] + omega + Β· change s1 UnaryDecode.pointerReg + s1 UnaryDecode.oneReg ≀ + cursorBound gate wires + have hp := hs1Pointer + have ho := hs1One + simp only [UnaryDecode.pointerReg, UnaryDecode.oneReg, + UnaryDecode.inputBase] at hp ho ⊒ + omega + have h3 : CursorEnvelope gate wires s3 := by + apply h2.execBasic (.sub UnaryDecode.remainingReg UnaryDecode.remainingReg + UnaryDecode.oneReg) + Β· simp [UnaryDecode.remainingReg] + omega + Β· exact le_trans (Nat.sub_le _ _) (h2.value_le UnaryDecode.remainingReg) + have h4 : CursorEnvelope gate wires s4 := by + apply h3.execBasic (.load headerNegated0Reg UnaryDecode.pointerReg) + Β· simp [headerNegated0Reg, UnaryDecode.inputBase] + omega + Β· exact h3.value_le (s3 UnaryDecode.pointerReg) + have hs4Pointer : s4 UnaryDecode.pointerReg = UnaryDecode.inputBase + 1 := by + rw [show s4 UnaryDecode.pointerReg = + s1 UnaryDecode.pointerReg + s1 UnaryDecode.oneReg by + simp [s4, s3, s2, Basic.exec, Function.update_of_ne, + headerNegated0Reg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.inputBase]] + rw [hs1Pointer, hs1One] + have hs4One : s4 UnaryDecode.oneReg = 1 := by + rw [show s4 UnaryDecode.oneReg = s1 UnaryDecode.oneReg by + simp [s4, s3, s2, Basic.exec, Function.update_of_ne, + headerNegated0Reg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.inputBase]] + exact hs1One + have h5 : CursorEnvelope gate wires s5 := by + apply h4.execBasic (.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg) + Β· simp [UnaryDecode.pointerReg] + omega + Β· change s4 UnaryDecode.pointerReg + s4 UnaryDecode.oneReg ≀ + cursorBound gate wires + have hp := hs4Pointer + have ho := hs4One + simp only [UnaryDecode.pointerReg, UnaryDecode.oneReg, + UnaryDecode.inputBase] at hp ho ⊒ + omega + have h6 : CursorEnvelope gate wires s6 := by + apply h5.execBasic (.sub UnaryDecode.remainingReg UnaryDecode.remainingReg + UnaryDecode.oneReg) + Β· simp [UnaryDecode.remainingReg] + omega + Β· exact le_trans (Nat.sub_le _ _) (h5.value_le UnaryDecode.remainingReg) + have h7 : CursorEnvelope gate wires s7 := by + apply h6.execBasic (.load headerNegated1Reg UnaryDecode.pointerReg) + Β· simp [headerNegated1Reg, UnaryDecode.inputBase] + omega + Β· exact h6.value_le (s6 UnaryDecode.pointerReg) + have hs7Pointer : s7 UnaryDecode.pointerReg = UnaryDecode.inputBase + 2 := by + rw [show s7 UnaryDecode.pointerReg = + s4 UnaryDecode.pointerReg + s4 UnaryDecode.oneReg by + simp [s7, s6, s5, Basic.exec, Function.update_of_ne, + headerNegated1Reg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.inputBase]] + rw [hs4Pointer, hs4One] + have hs7One : s7 UnaryDecode.oneReg = 1 := by + rw [show s7 UnaryDecode.oneReg = s4 UnaryDecode.oneReg by + simp [s7, s6, s5, Basic.exec, Function.update_of_ne, + headerNegated1Reg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.inputBase]] + exact hs4One + have h8 : CursorEnvelope gate wires s8 := by + apply h7.execBasic (.add UnaryDecode.pointerReg UnaryDecode.pointerReg + UnaryDecode.oneReg) + Β· simp [UnaryDecode.pointerReg] + omega + Β· change s7 UnaryDecode.pointerReg + s7 UnaryDecode.oneReg ≀ + cursorBound gate wires + have hp := hs7Pointer + have ho := hs7One + simp only [UnaryDecode.pointerReg, UnaryDecode.oneReg, + UnaryDecode.inputBase] at hp ho ⊒ + omega + have h9 := header_bound gate wires + have r1 := MeasuredRuns.basicEnvelope + (.load headerOpReg UnaryDecode.pointerReg) (setupStore gate wires) hsetup h1 + have r2 := MeasuredRuns.basicEnvelope + (.add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg) + s1 h1 h2 + have r3 := MeasuredRuns.basicEnvelope + (.sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg) + s2 h2 h3 + have r4 := MeasuredRuns.basicEnvelope + (.load headerNegated0Reg UnaryDecode.pointerReg) s3 h3 h4 + have r5 := MeasuredRuns.basicEnvelope + (.add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg) + s4 h4 h5 + have r6 := MeasuredRuns.basicEnvelope + (.sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg) + s5 h5 h6 + have r7 := MeasuredRuns.basicEnvelope + (.load headerNegated1Reg UnaryDecode.pointerReg) s6 h6 h7 + have r8 := MeasuredRuns.basicEnvelope + (.add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg) + s7 h7 h8 + have r9 := MeasuredRuns.basicEnvelope + (.sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg) + s8 h8 h9 + refine ⟨?_, h9⟩ + have hrun := r1.seq (r2.seq (r3.seq (r4.seq (r5.seq + (r6.seq (r7.seq (r8.seq r9))))))) + convert! hrun using 1 + ring + +private theorem header_cursorReady (gate : CircuitCode.RawGate) (wires : List Bool) : + UnaryDecode.CursorReady (inputBits gate wires).length + (CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ wires) + 3 0 (headerStore gate wires) := by + constructor + Β· simp [inputBits, CircuitCode.RawGate.encode] + omega + Β· omega + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, + inputBits, CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + Β· intro delta + have h1 : 10 + delta β‰  1 := by omega + have h2 : 10 + delta β‰  2 := by omega + have h3 : 10 + delta β‰  3 := by omega + have h4 : 10 + delta β‰  4 := by omega + have h6 : 10 + delta β‰  6 := by omega + have h7 : 10 + delta β‰  7 := by omega + have h8 : 10 + delta β‰  8 := by omega + have h9 : 10 + delta β‰  9 := by omega + have hpreserved : headerStore gate wires (10 + delta) = + inputStore gate wires (10 + delta) := by + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, Function.update_of_ne, h1, h2, h3, h4, + h6, h7, h8, h9, headerOpReg, headerNegated0Reg, headerNegated1Reg, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, UnaryDecode.activeReg, + UnaryDecode.inputBase] + change headerStore gate wires (10 + delta) = _ + rw [hpreserved] + simp only [inputStore, Input.bitStore, UnaryDecode.remainingReg, + UnaryDecode.inputBase] + change (if 10 + delta = 3 then (inputBits gate wires).length else + if 7 ≀ 10 + delta then + match (inputBits gate wires)[10 + delta - 7]? with + | some bit => Input.bitValue bit + | none => 0 + else 0) = _ + rw [ite_eq_right (by omega : 10 + delta β‰  3), ite_eq_left (by omega : 7 ≀ 10 + delta)] + have hoffset : 10 + delta - 7 = 3 + delta := by omega + rw [hoffset] + change + (match (inputBits gate wires)[3 + delta]? with + | some bit => Input.bitValue bit + | none => 0) = _ + rw [show inputBits gate wires = + [gate.opBit, gate.negatedβ‚€, gate.negated₁] ++ + (CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ wires) by + simp [inputBits, CircuitCode.RawGate.encode, List.append_assoc]] + rw [List.getElem?_append_right (by simp : + [gate.opBit, gate.negatedβ‚€, gate.negated₁].length ≀ 3 + delta)] + simp + rfl + +private theorem header_op (gate : CircuitCode.RawGate) (wires : List Bool) : + headerStore gate wires headerOpReg = Input.bitValue gate.opBit := by + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, inputBits, + CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + +private theorem header_negated0 (gate : CircuitCode.RawGate) (wires : List Bool) : + headerStore gate wires headerNegated0Reg = Input.bitValue gate.negatedβ‚€ := by + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, inputBits, + CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + +private theorem header_negated1 (gate : CircuitCode.RawGate) (wires : List Bool) : + headerStore gate wires headerNegated1Reg = Input.bitValue gate.negated₁ := by + simp [headerStore, headerOps, setupStore, UnaryDecode.setupOps, + Basic.execList, Basic.exec, inputStore, Input.bitStore, inputBits, + CircuitCode.RawGate.encode, headerOpReg, headerNegated0Reg, + headerNegated1Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, UnaryDecode.inputBase] + +private theorem saveRestart_high (store : Store) (index : β„•) + (hindex : 11 ≀ index) : saveRestartStore store index = store index := by + have h0 : index β‰  UnaryDecode.verdictReg := by + simp only [UnaryDecode.verdictReg] at hindex ⊒ + omega + have h1 : index β‰  UnaryDecode.valueReg := by + simp only [UnaryDecode.valueReg] at hindex ⊒ + omega + have h6 : index β‰  UnaryDecode.activeReg := by + simp only [UnaryDecode.activeReg] at hindex ⊒ + omega + have h10 : index β‰  savedInput0Reg := by + simp only [savedInput0Reg, UnaryDecode.inputBase] at hindex ⊒ + omega + simp [saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1, h6, h10] + +private theorem saveRestart_apply_of_ne (store : Store) (index : β„•) + (hsaved : index β‰  savedInput0Reg) + (hverdict : index β‰  UnaryDecode.verdictReg) + (hvalue : index β‰  UnaryDecode.valueReg) + (hactive : index β‰  UnaryDecode.activeReg) : + saveRestartStore store index = store index := by + simp [saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + Function.update_of_ne, hsaved, hverdict, hvalue, hactive] + +private theorem saveRestart_saved (store : Store) : + saveRestartStore store savedInput0Reg = + store UnaryDecode.valueReg + store UnaryDecode.activeReg := by + simp [saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + savedInput0Reg, UnaryDecode.inputBase, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.activeReg] + +private theorem marshal_high (store : Store) (index : β„•) + (hindex : 11 ≀ index) : marshalStore store index = store index := by + have h0 : index β‰  GateEval.opReg := by + simp only [GateEval.opReg] at hindex ⊒ + omega + have h1 : index β‰  GateEval.negated0Reg := by + simp only [GateEval.negated0Reg] at hindex ⊒ + omega + have h2 : index β‰  GateEval.negated1Reg := by + simp only [GateEval.negated1Reg] at hindex ⊒ + omega + have h3 : index β‰  GateEval.address0Reg := by + simp only [GateEval.address0Reg] at hindex ⊒ + omega + have h4 : index β‰  GateEval.address1Reg := by + simp only [GateEval.address1Reg] at hindex ⊒ + omega + have h5 : index β‰  GateEval.wireCountReg := by + simp only [GateEval.wireCountReg] at hindex ⊒ + omega + have h10 : index β‰  GateEval.baseReg := by + simp only [GateEval.baseReg] at hindex ⊒ + omega + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1, h2, h3, h4, h5, h10] + +private theorem marshal_wireCount (store : Store) : + marshalStore store GateEval.wireCountReg = + store UnaryDecode.remainingReg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, UnaryDecode.remainingReg, UnaryDecode.activeReg] + +private theorem marshal_address1 (store : Store) : + marshalStore store GateEval.address1Reg = + store UnaryDecode.valueReg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, UnaryDecode.valueReg, UnaryDecode.activeReg] + +private theorem marshal_address0 (store : Store) : + marshalStore store GateEval.address0Reg = + store savedInput0Reg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, savedInput0Reg, UnaryDecode.inputBase, + UnaryDecode.activeReg] + +private theorem marshal_base (store : Store) : + marshalStore store GateEval.baseReg = + store UnaryDecode.pointerReg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, UnaryDecode.pointerReg, UnaryDecode.activeReg] + +private theorem marshal_op (store : Store) : + marshalStore store GateEval.opReg = + store headerOpReg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, headerOpReg, UnaryDecode.inputBase, + UnaryDecode.activeReg] + +private theorem marshal_negated0 (store : Store) : + marshalStore store GateEval.negated0Reg = + store headerNegated0Reg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, headerNegated0Reg, UnaryDecode.inputBase, + UnaryDecode.activeReg] + +private theorem marshal_negated1 (store : Store) : + marshalStore store GateEval.negated1Reg = + store headerNegated1Reg + store UnaryDecode.activeReg := by + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, headerNegated1Reg, UnaryDecode.inputBase, + UnaryDecode.activeReg] + +private theorem copyAdd_measured {bound dst src active : β„•} {store : Store} + (hstore : StoreEnvelope bound bound store) (hdst : dst < bound) + (hactive : store active = 0) (hne : dst β‰  active) : + MeasuredRuns (.basic (.add dst src active)) store + ((Basic.add dst src active).exec store) 1 + (4 * valueWidth bound) (envelopeSpace bound bound) ∧ + StoreEnvelope bound bound ((Basic.add dst src active).exec store) ∧ + (Basic.add dst src active).exec store active = 0 := by + have hnext : StoreEnvelope bound bound + ((Basic.add dst src active).exec store) := by + apply hstore.execBasic (.add dst src active) + Β· exact hdst + Β· change store src + store active ≀ bound + rw [hactive, Nat.add_zero] + exact hstore.value_le src + refine ⟨MeasuredRuns.basicEnvelope (.add dst src active) store hstore hnext, + hnext, ?_⟩ + simp [Basic.exec, Function.update_of_ne (Ne.symm hne), hactive] + +private theorem saveRestart_measured {bound : β„•} {store : Store} + (hstore : StoreEnvelope bound bound store) (hsmall : 10 < bound) + (hactive : store UnaryDecode.activeReg = 0) : + MeasuredRuns (.basics saveRestartOps) store (saveRestartStore store) 4 + (16 * valueWidth bound) (envelopeSpace bound bound) ∧ + StoreEnvelope bound bound (saveRestartStore store) := by + let s1 := (Basic.add savedInput0Reg UnaryDecode.valueReg + UnaryDecode.activeReg).exec store + let s2 := (Basic.imm UnaryDecode.verdictReg 0).exec s1 + let s3 := (Basic.imm UnaryDecode.valueReg 0).exec s2 + have h1 := copyAdd_measured hstore + (dst := savedInput0Reg) (src := UnaryDecode.valueReg) + (active := UnaryDecode.activeReg) + (by simp [savedInput0Reg, UnaryDecode.inputBase]; omega) hactive + (by simp [savedInput0Reg, UnaryDecode.activeReg, UnaryDecode.inputBase]) + have h2 : StoreEnvelope bound bound s2 := by + apply h1.2.1.execBasic (.imm UnaryDecode.verdictReg 0) + Β· simp [UnaryDecode.verdictReg] + omega + Β· simp [Basic.writeValue] + have h3 : StoreEnvelope bound bound s3 := by + apply h2.execBasic (.imm UnaryDecode.valueReg 0) + Β· simp [UnaryDecode.valueReg] + omega + Β· simp [Basic.writeValue] + have h4 : StoreEnvelope bound bound (saveRestartStore store) := by + change StoreEnvelope bound bound + ((Basic.imm UnaryDecode.activeReg 1).exec s3) + apply h3.execBasic (.imm UnaryDecode.activeReg 1) + Β· simp [UnaryDecode.activeReg] + omega + Β· simp [Basic.writeValue] + omega + have r2 := MeasuredRuns.basicEnvelope (.imm UnaryDecode.verdictReg 0) + s1 h1.2.1 h2 + have r3 := MeasuredRuns.basicEnvelope (.imm UnaryDecode.valueReg 0) s2 h2 h3 + have r4 := MeasuredRuns.basicEnvelope (.imm UnaryDecode.activeReg 1) s3 h3 h4 + refine ⟨?_, h4⟩ + have hrun := h1.1.seq (r2.seq (r3.seq r4)) + convert! hrun using 1 + ring + +private theorem marshal_measured {bound : β„•} {store : Store} + (hstore : StoreEnvelope bound bound store) (hsmall : 10 < bound) + (hactive : store UnaryDecode.activeReg = 0) : + MeasuredRuns (.basics marshalOps) store (marshalStore store) 7 + (28 * valueWidth bound) (envelopeSpace bound bound) ∧ + StoreEnvelope bound bound (marshalStore store) := by + let s1 := (Basic.add GateEval.wireCountReg UnaryDecode.remainingReg + UnaryDecode.activeReg).exec store + let s2 := (Basic.add GateEval.address1Reg UnaryDecode.valueReg + UnaryDecode.activeReg).exec s1 + let s3 := (Basic.add GateEval.address0Reg savedInput0Reg + UnaryDecode.activeReg).exec s2 + let s4 := (Basic.add GateEval.baseReg UnaryDecode.pointerReg + UnaryDecode.activeReg).exec s3 + let s5 := (Basic.add GateEval.opReg headerOpReg + UnaryDecode.activeReg).exec s4 + let s6 := (Basic.add GateEval.negated0Reg headerNegated0Reg + UnaryDecode.activeReg).exec s5 + have r1 := copyAdd_measured hstore + (dst := GateEval.wireCountReg) (src := UnaryDecode.remainingReg) + (active := UnaryDecode.activeReg) (by simp [GateEval.wireCountReg]; omega) + hactive (by simp [GateEval.wireCountReg, UnaryDecode.activeReg]) + have r2 := copyAdd_measured r1.2.1 + (dst := GateEval.address1Reg) (src := UnaryDecode.valueReg) + (active := UnaryDecode.activeReg) (by simp [GateEval.address1Reg]; omega) + r1.2.2 (by simp [GateEval.address1Reg, UnaryDecode.activeReg]) + have r3 := copyAdd_measured r2.2.1 + (dst := GateEval.address0Reg) (src := savedInput0Reg) + (active := UnaryDecode.activeReg) (by simp [GateEval.address0Reg]; omega) + r2.2.2 (by simp [GateEval.address0Reg, UnaryDecode.activeReg]) + have r4 := copyAdd_measured r3.2.1 + (dst := GateEval.baseReg) (src := UnaryDecode.pointerReg) + (active := UnaryDecode.activeReg) (by simp [GateEval.baseReg]; omega) + r3.2.2 (by simp [GateEval.baseReg, UnaryDecode.activeReg]) + have r5 := copyAdd_measured r4.2.1 + (dst := GateEval.opReg) (src := headerOpReg) + (active := UnaryDecode.activeReg) (by simp [GateEval.opReg]; omega) + r4.2.2 (by simp [GateEval.opReg, UnaryDecode.activeReg]) + have r6 := copyAdd_measured r5.2.1 + (dst := GateEval.negated0Reg) (src := headerNegated0Reg) + (active := UnaryDecode.activeReg) (by simp [GateEval.negated0Reg]; omega) + r5.2.2 (by simp [GateEval.negated0Reg, UnaryDecode.activeReg]) + have r7 := copyAdd_measured r6.2.1 + (dst := GateEval.negated1Reg) (src := headerNegated1Reg) + (active := UnaryDecode.activeReg) (by simp [GateEval.negated1Reg]; omega) + r6.2.2 (by simp [GateEval.negated1Reg, UnaryDecode.activeReg]) + refine ⟨?_, ?_⟩ + Β· have hrun := r1.1.seq (r2.1.seq (r3.1.seq + (r4.1.seq (r5.1.seq (r6.1.seq r7.1))))) + convert! hrun using 1 + ring + Β· simpa [marshalStore, marshalOps, s1, s2, s3, s4, s5, s6] using! r7.2.1 + +private theorem input_wire (gate : CircuitCode.RawGate) (wires : List Bool) + (index : β„•) : + inputStore gate wires (memoBase gate + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 := by + have hbase : UnaryDecode.inputBase ≀ memoBase gate + index := by + simp [memoBase] + omega + have hlength : memoBase gate + index β‰  UnaryDecode.remainingReg := by + simp only [memoBase, UnaryDecode.inputBase, UnaryDecode.remainingReg] + omega + simp only [inputStore, Input.bitStore] + rw [ite_eq_right hlength, ite_eq_left hbase] + have hoffset : memoBase gate + index - UnaryDecode.inputBase = + gate.encode.length + index := by + simp [memoBase] + omega + rw [hoffset, inputBits, List.getElem?_append_right (by omega)] + simp + rfl + +/-- Decode the first operand and restore the cursor for the second operand. -/ +private theorem firstDecode_restart_measured + (gate : CircuitCode.RawGate) (wires : List Bool) : + let firstRemaining := CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ wires + let secondRemaining := CircuitCode.NatCode.encode gate.input₁ ++ wires + βˆƒ (first : Store) (firstCost firstSpace : β„•), + Exec UnaryDecode.mainLoop (headerStore gate wires) first + (UnaryDecode.loopStepCount firstRemaining) firstCost firstSpace ∧ + firstCost ≀ UnaryDecode.timeBound (inputBits gate wires).length ∧ + firstSpace ≀ UnaryDecode.spaceBound (inputBits gate wires).length ∧ + first UnaryDecode.valueReg = gate.inputβ‚€ ∧ + first UnaryDecode.activeReg = 0 ∧ + (βˆ€ index, UnaryDecode.inputBase ≀ index β†’ + first index = headerStore gate wires index) ∧ + CursorEnvelope gate wires first ∧ + 10 < cursorBound gate wires ∧ + UnaryDecode.CursorReady (inputBits gate wires).length + secondRemaining (4 + gate.inputβ‚€) 0 (saveRestartStore first) ∧ + CursorEnvelope gate wires (saveRestartStore first) := by + dsimp only + let firstRemaining := CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ wires + let secondRemaining := CircuitCode.NatCode.encode gate.input₁ ++ wires + have hheaderReady : UnaryDecode.CursorReady (inputBits gate wires).length + firstRemaining 3 0 (headerStore gate wires) := by + simpa [firstRemaining] using header_cursorReady gate wires + have hheaderBound : StoreEnvelope + ((inputBits gate wires).length + UnaryDecode.inputBase) + ((inputBits gate wires).length + UnaryDecode.inputBase) + (headerStore gate wires) := by + simpa [cursorBound] using header_bound gate wires + obtain ⟨first, firstCost, firstSpace, hfirst, hfirstCost, hfirstSpace, + hfirstResult, hfirstActive, hfirstOne, hfirstFrame, hfirstBound⟩ := + UnaryDecode.mainLoop_measured_internal hheaderReady hheaderBound + have hdecode0 : CircuitCode.NatCode.decodePrefix? firstRemaining = + some (gate.inputβ‚€, secondRemaining) := by + simp [firstRemaining, secondRemaining, List.append_assoc] + rw [hdecode0] at hfirstResult + simp only at hfirstResult + have hfirstVerdict : first UnaryDecode.verdictReg = 1 := hfirstResult.1 + have hfirstValue : first UnaryDecode.valueReg = gate.inputβ‚€ := by + simpa using hfirstResult.2.1 + have hfirstPointer : first UnaryDecode.pointerReg = + UnaryDecode.inputBase + 3 + gate.inputβ‚€ + 1 := hfirstResult.2.2.1 + have hfirstRemaining : first UnaryDecode.remainingReg = secondRemaining.length := + hfirstResult.2.2.2 + let saved := saveRestartStore first + have hlarge : 10 < cursorBound gate wires := by + simp [cursorBound, inputBits, CircuitCode.RawGate.encode, + UnaryDecode.inputBase] + have hsaved0 : CursorEnvelope gate wires + ((Basic.add savedInput0Reg UnaryDecode.valueReg + UnaryDecode.activeReg).exec first) := by + apply hfirstBound.execBasic + Β· simpa [savedInput0Reg, UnaryDecode.inputBase] using! hlarge + Β· change first UnaryDecode.valueReg + first UnaryDecode.activeReg ≀ + cursorBound gate wires + rw [hfirstValue, hfirstActive] + simp [cursorBound, inputBits, CircuitCode.RawGate.encode, + UnaryDecode.inputBase] + omega + have hsaved1 := hsaved0.execBasic (.imm UnaryDecode.verdictReg 0) + (by simpa [Basic.writeIndex, UnaryDecode.verdictReg] using + (lt_trans (by decide : 0 < 10) hlarge)) (by simp [Basic.writeValue]) + have hsaved2 := hsaved1.execBasic (.imm UnaryDecode.valueReg 0) + (by simpa [Basic.writeIndex, UnaryDecode.valueReg] using + (lt_trans (by decide : 1 < 10) hlarge)) (by simp [Basic.writeValue]) + have hsavedBound : CursorEnvelope gate wires saved := by + have hsaved3 := hsaved2.execBasic (.imm UnaryDecode.activeReg 1) + (by simpa [Basic.writeIndex, UnaryDecode.activeReg] using + (lt_trans (by decide : 6 < 10) hlarge)) (by + have h := hlarge + simp only [Basic.writeValue] + omega) + simpa [saved, saveRestartStore, saveRestartOps, Basic.execList] using hsaved3 + have hsecondReady : UnaryDecode.CursorReady (inputBits gate wires).length + secondRemaining (4 + gate.inputβ‚€) 0 saved := by + constructor + Β· simp [secondRemaining, inputBits, CircuitCode.RawGate.encode] + omega + Β· omega + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.activeReg] + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.activeReg] + Β· change saved UnaryDecode.pointerReg = _ + rw [show saved UnaryDecode.pointerReg = first UnaryDecode.pointerReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.activeReg, + UnaryDecode.inputBase]] + rw [hfirstPointer] + omega + Β· change saved UnaryDecode.remainingReg = secondRemaining.length + rw [show saved UnaryDecode.remainingReg = first UnaryDecode.remainingReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.remainingReg, UnaryDecode.activeReg, + UnaryDecode.inputBase]] + exact hfirstRemaining + Β· change saved UnaryDecode.oneReg = 1 + rw [show saved UnaryDecode.oneReg = first UnaryDecode.oneReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.oneReg, UnaryDecode.activeReg, + UnaryDecode.inputBase]] + exact hfirstOne + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.activeReg] + Β· intro delta + have hsavedHigh : saved + (UnaryDecode.inputBase + (4 + gate.inputβ‚€) + delta) = + first (UnaryDecode.inputBase + (4 + gate.inputβ‚€) + delta) := by + apply saveRestart_high + simp [UnaryDecode.inputBase] + omega + rw [hsavedHigh, hfirstFrame _ (by + simp [UnaryDecode.inputBase] + omega)] + have hinput := hheaderReady.input_eq (gate.inputβ‚€ + 1 + delta) + have hlookup : firstRemaining[gate.inputβ‚€ + 1 + delta]? = + secondRemaining[delta]? := by + rw [show firstRemaining = CircuitCode.NatCode.encode gate.inputβ‚€ ++ + secondRemaining by simp [firstRemaining, secondRemaining, + List.append_assoc]] + rw [List.getElem?_append_right (by simp)] + simp + rw [hlookup] at hinput + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hinput + have hsecondBound : StoreEnvelope + ((inputBits gate wires).length + UnaryDecode.inputBase) + ((inputBits gate wires).length + UnaryDecode.inputBase) saved := by + simpa [cursorBound] using hsavedBound + exact ⟨first, firstCost, firstSpace, hfirst, hfirstCost, hfirstSpace, + hfirstValue, hfirstActive, hfirstFrame, hfirstBound, hlarge, + hsecondReady, hsecondBound⟩ + +/-- Marshal decoded operands and preserve the memoized wires for gate evaluation. -/ +private theorem marshal_ready_of_decoded + (gate : CircuitCode.RawGate) (wires : List Bool) (first second : Store) + (hsecondOp : second headerOpReg = Input.bitValue gate.opBit) + (hsecondNegated0 : second headerNegated0Reg = Input.bitValue gate.negatedβ‚€) + (hsecondNegated1 : second headerNegated1Reg = Input.bitValue gate.negated₁) + (hsecondInput0 : second savedInput0Reg = gate.inputβ‚€) + (hsecondValue : second UnaryDecode.valueReg = gate.input₁) + (hsecondActive : second UnaryDecode.activeReg = 0) + (hsecondRemaining : second UnaryDecode.remainingReg = wires.length) + (hsecondPointer : second UnaryDecode.pointerReg = memoBase gate) + (hfirstFrame : βˆ€ index, UnaryDecode.inputBase ≀ index β†’ + first index = headerStore gate wires index) + (hsecondFrame : βˆ€ index, UnaryDecode.inputBase ≀ index β†’ + second index = saveRestartStore first index) : + GateEval.ReadyAt (memoBase gate) gate wires (marshalStore second) := by + constructor + Β· simp [memoBase, CircuitCode.RawGate.length_encode, GateEval.wireBase, + UnaryDecode.inputBase] + omega + Β· change marshalStore second GateEval.opReg = _ + rw [marshal_op, hsecondOp, hsecondActive] + omega + Β· change marshalStore second GateEval.negated0Reg = _ + rw [marshal_negated0, hsecondNegated0, hsecondActive] + omega + Β· change marshalStore second GateEval.negated1Reg = _ + rw [marshal_negated1, hsecondNegated1, hsecondActive] + omega + Β· change marshalStore second GateEval.address0Reg = gate.inputβ‚€ + rw [marshal_address0, hsecondInput0, hsecondActive] + omega + Β· change marshalStore second GateEval.address1Reg = gate.input₁ + rw [marshal_address1, hsecondValue, hsecondActive] + omega + Β· change marshalStore second GateEval.wireCountReg = wires.length + rw [marshal_wireCount, hsecondRemaining, hsecondActive] + omega + Β· change marshalStore second GateEval.baseReg = memoBase gate + rw [marshal_base, hsecondPointer, hsecondActive] + omega + Β· intro index hindex + change marshalStore second (memoBase gate + index) = _ + rw [marshal_high second _ (by + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega)] + rw [hsecondFrame _ (by + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega)] + rw [saveRestart_high first _ (by + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega)] + rw [hfirstFrame _ (by + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega)] + rw [header_high gate wires _ (by + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega)] + exact input_wire gate wires index + +theorem program_measured_internal (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + cost ≀ timeBound gate wires ∧ space ≀ spaceBound gate wires ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := by + let firstRemaining := CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ wires + let secondRemaining := CircuitCode.NatCode.encode gate.input₁ ++ wires + obtain ⟨first, firstCost, firstSpace, hfirst, hfirstCost, hfirstSpace, + hfirstValue, hfirstActive, hfirstFrame, hfirstBound, hlarge, + hsecondReady, hsecondBound⟩ := firstDecode_restart_measured gate wires + let saved := saveRestartStore first + have hdecode0 : CircuitCode.NatCode.decodePrefix? firstRemaining = + some (gate.inputβ‚€, secondRemaining) := by + simp [firstRemaining, secondRemaining, List.append_assoc] + obtain ⟨second, secondCost, secondSpace, hsecond, hsecondCost, hsecondSpace, + hsecondResult, hsecondActive, _hsecondOne, hsecondFrame, hsecondFinalBound⟩ := + UnaryDecode.mainLoop_measured_internal hsecondReady hsecondBound + have hdecode1 : CircuitCode.NatCode.decodePrefix? secondRemaining = + some (gate.input₁, wires) := by + simp [secondRemaining] + rw [hdecode1] at hsecondResult + simp only at hsecondResult + have hsecondValue : second UnaryDecode.valueReg = gate.input₁ := by + simpa using hsecondResult.2.1 + have hsecondPointer : second UnaryDecode.pointerReg = memoBase gate := by + have hp := hsecondResult.2.2.1 + rw [hp] + simp [memoBase, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega + have hsecondRemaining : second UnaryDecode.remainingReg = wires.length := + hsecondResult.2.2.2 + have hsecondOp : second headerOpReg = Input.bitValue gate.opBit := by + rw [hsecondFrame _ (by simp [headerOpReg, UnaryDecode.inputBase])] + rw [show saveRestartStore first headerOpReg = first headerOpReg by + apply saveRestart_apply_of_ne <;> + simp [headerOpReg, savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.activeReg, UnaryDecode.inputBase]] + rw [hfirstFrame _ (by simp [headerOpReg, UnaryDecode.inputBase])] + exact header_op gate wires + have hsecondNegated0 : second headerNegated0Reg = + Input.bitValue gate.negatedβ‚€ := by + rw [hsecondFrame _ (by simp [headerNegated0Reg, UnaryDecode.inputBase])] + rw [show saveRestartStore first headerNegated0Reg = first headerNegated0Reg by + apply saveRestart_apply_of_ne <;> + simp [headerNegated0Reg, savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.activeReg, UnaryDecode.inputBase]] + rw [hfirstFrame _ (by simp [headerNegated0Reg, UnaryDecode.inputBase])] + exact header_negated0 gate wires + have hsecondNegated1 : second headerNegated1Reg = + Input.bitValue gate.negated₁ := by + rw [hsecondFrame _ (by simp [headerNegated1Reg, UnaryDecode.inputBase])] + rw [show saveRestartStore first headerNegated1Reg = first headerNegated1Reg by + apply saveRestart_apply_of_ne <;> + simp [headerNegated1Reg, savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.activeReg, UnaryDecode.inputBase]] + rw [hfirstFrame _ (by simp [headerNegated1Reg, UnaryDecode.inputBase])] + exact header_negated1 gate wires + have hsecondInput0 : second savedInput0Reg = gate.inputβ‚€ := by + rw [hsecondFrame _ (by simp [savedInput0Reg, UnaryDecode.inputBase])] + rw [show saveRestartStore first savedInput0Reg = + first UnaryDecode.valueReg + first UnaryDecode.activeReg by + exact saveRestart_saved first] + rw [hfirstValue, hfirstActive] + omega + let marshaled := marshalStore second + have hready : GateEval.ReadyAt (memoBase gate) gate wires marshaled := + marshal_ready_of_decoded gate wires first second hsecondOp hsecondNegated0 + hsecondNegated1 hsecondInput0 hsecondValue hsecondActive hsecondRemaining + hsecondPointer hfirstFrame hsecondFrame + have hcursorLe : cursorBound gate wires ≀ storeBound gate wires := by + simp [cursorBound, storeBound] + have hwidthLe : valueWidth (cursorBound gate wires) ≀ + valueWidth (storeBound gate wires) := by + have hsize := Nat.size_le_size hcursorLe + simpa [valueWidth, bitlen] using Nat.add_le_add_right hsize 1 + have hspaceLe : envelopeSpace (cursorBound gate wires) + (cursorBound gate wires) ≀ + envelopeSpace (storeBound gate wires) (storeBound gate wires) := by + unfold envelopeSpace + have hsize := Nat.size_le_size hcursorLe + apply Nat.mul_le_mul hcursorLe + simpa [bitlen] using Nat.add_le_add hsize hsize + have hsetup := (setup_measured gate wires).1 + have hheader := (header_measured gate wires).1 + have hsave := (saveRestart_measured hfirstBound hlarge hfirstActive).1 + have hmarshal := + (marshal_measured hsecondFinalBound hlarge hsecondActive).1 + have hmarshaledBound : StoreEnvelope (storeBound gate wires) + (storeBound gate wires) marshaled := by + apply (marshal_measured hsecondFinalBound hlarge hsecondActive).2.mono + Β· exact hcursorLe + Β· exact hcursorLe + have happendAddress : memoBase gate + wires.length < + storeBound gate wires := by + simp [memoBase, storeBound, inputBits, CircuitCode.RawGate.length_encode, + UnaryDecode.inputBase] + omega + obtain ⟨final, hgate, hfinalBound, houtput, happended, _hbase, _hcount, + hpreserved, _hframe⟩ := + GateEval.routine_measured_internal hready hmarshaledBound + value0 value1 hvalue0 hvalue1 happendAddress + have hsetup' := hsetup.weaken + (Nat.mul_le_mul_left 20 hwidthLe) hspaceLe + have hheader' := hheader.weaken + (Nat.mul_le_mul_left 36 hwidthLe) hspaceLe + have hfirstCost' : UnaryDecode.timeBound (inputBits gate wires).length ≀ + 96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) := by + rw [UnaryDecode.timeBound] + apply Nat.mul_le_mul_left + exact hwidthLe + have hfirst' : MeasuredRuns UnaryDecode.mainLoop (headerStore gate wires) + first (UnaryDecode.loopStepCount firstRemaining) + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires)) + (envelopeSpace (storeBound gate wires) (storeBound gate wires)) := + ⟨firstCost, firstSpace, hfirst, le_trans hfirstCost hfirstCost', + le_trans hfirstSpace (by + simpa [UnaryDecode.spaceBound, envelopeSpace, cursorBound, two_mul] + using hspaceLe)⟩ + have hsave' := hsave.weaken + (Nat.mul_le_mul_left 16 hwidthLe) hspaceLe + have hsecond' : MeasuredRuns UnaryDecode.mainLoop saved + second (UnaryDecode.loopStepCount secondRemaining) + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires)) + (envelopeSpace (storeBound gate wires) (storeBound gate wires)) := + ⟨secondCost, secondSpace, hsecond, le_trans hsecondCost hfirstCost', + le_trans hsecondSpace (by + simpa [UnaryDecode.spaceBound, envelopeSpace, cursorBound, two_mul] + using hspaceLe)⟩ + have hmarshal' := hmarshal.weaken + (Nat.mul_le_mul_left 28 hwidthLe) hspaceLe + have hrun := hsetup'.seq (hheader'.seq (hfirst'.seq + (hsave'.seq (hsecond'.seq (hmarshal'.seq hgate))))) + have hsteps : + UnaryDecode.setupOps.length + + (headerOps.length + (UnaryDecode.loopStepCount firstRemaining + + (saveRestartOps.length + + (UnaryDecode.loopStepCount secondRemaining + + (marshalOps.length + GateEval.stepCount))))) = + stepCount gate := by + simp [UnaryDecode.setupOps, headerOps, saveRestartOps, marshalOps, + UnaryDecode.loopStepCount, hdecode0, hdecode1, GateEval.stepCount, + stepCount] + omega + have hrun' : MeasuredRuns program (inputStore gate wires) final + (UnaryDecode.setupOps.length + + (headerOps.length + (UnaryDecode.loopStepCount firstRemaining + + (saveRestartOps.length + + (UnaryDecode.loopStepCount secondRemaining + + (marshalOps.length + GateEval.stepCount)))))) + (20 * valueWidth (storeBound gate wires) + + (36 * valueWidth (storeBound gate wires) + + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) + + (16 * valueWidth (storeBound gate wires) + + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) + + (28 * valueWidth (storeBound gate wires) + + 80 * valueWidth (storeBound gate wires))))))) + (envelopeSpace (storeBound gate wires) (storeBound gate wires)) := by + simpa [program, UnaryDecode.setup, setupStore, saved, marshaled, + saveRestartStore, marshalStore] using! hrun + have hcostLe : + 20 * valueWidth (storeBound gate wires) + + (36 * valueWidth (storeBound gate wires) + + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) + + (16 * valueWidth (storeBound gate wires) + + (96 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) + + (28 * valueWidth (storeBound gate wires) + + 80 * valueWidth (storeBound gate wires)))))) ≀ + timeBound gate wires := by + rw [timeBound] + change _ ≀ 512 * ((inputBits gate wires).length + 1) * + valueWidth (storeBound gate wires) + calc + _ = (192 * ((inputBits gate wires).length + 1) + 180) * + valueWidth (storeBound gate wires) := by ring + _ ≀ (512 * ((inputBits gate wires).length + 1)) * + valueWidth (storeBound gate wires) := + Nat.mul_le_mul_right _ (by omega) + _ = _ := by ring + have hprogram : MeasuredRuns program (inputStore gate wires) final + (stepCount gate) (timeBound gate wires) + (envelopeSpace (storeBound gate wires) (storeBound gate wires)) := by + rw [← hsteps] + exact hrun'.weakenCost hcostLe + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hprogram + have hspaceBound : space ≀ spaceBound gate wires := by + simpa [spaceBound, envelopeSpace, two_mul] using hspace + exact ⟨final, cost, space, hexec, hcost, hspaceBound, + houtput, happended, hpreserved⟩ + +theorem program_exec_internal (gate : CircuitCode.RawGate) (wires : List Bool) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec program (inputStore gate wires) final (stepCount gate) cost space ∧ + final GateEval.outputReg = Input.bitValue (gate.eval value0 value1) ∧ + final (memoBase gate + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + βˆ€ index (hindex : index < wires.length), + final (memoBase gate + index) = Input.bitValue wires[index] := by + obtain ⟨final, cost, space, hexec, _hcost, _hspace, + houtput, happended, hpreserved⟩ := + program_measured_internal gate wires value0 value1 hvalue0 hvalue1 + exact ⟨final, cost, space, hexec, houtput, happended, hpreserved⟩ + +end GateStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep.lean new file mode 100644 index 0000000000..d5ebfac8bc --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified structured RAM iterable serialized-gate step + +This module exposes the split-layout gate routine used by the serialized-circuit +experiment. Code and mutable memo occupy disjoint regions, so the exact same +routine can be invoked again at the returned cursor. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStreamStep + +/-- Consume and evaluate one gate while preserving the unread code tail and +advancing the independent mutable memo. -/ +theorem routine_correct {gateStart base : β„•} {gate : CircuitCode.RawGate} + {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) + (hbound : Internal.StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec routine store final (stepCount gate) cost space ∧ + final UnaryDecode.pointerReg = gateStart + gate.encode.length ∧ + final UnaryDecode.remainingReg = tail.length ∧ + final memoBaseReg = base ∧ + final wireCountMetaReg = wires.length + 1 ∧ + final (base + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ delta, + final (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0 := + routine_exec_internal hready hbound value0 value1 hvalue0 hvalue1 + +/-- Structural compilation transfers the exact iterable-gate execution, +including its logarithmic cost and peak-space measurements. -/ +theorem compiled_correct {gateStart base : β„•} {gate : CircuitCode.RawGate} + {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) + (hbound : Internal.StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec routine store final (stepCount gate) cost space ∧ + run compiled (stepCount gate) { pc := 0, regs := store } = + { pc := routine.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount gate) { pc := 0, regs := store }) ∧ + logTimeUpto compiled (stepCount gate) { pc := 0, regs := store } = cost ∧ + spaceUpto compiled (stepCount gate) { pc := 0, regs := store } = space ∧ + final UnaryDecode.pointerReg = gateStart + gate.encode.length ∧ + final UnaryDecode.remainingReg = tail.length ∧ + final memoBaseReg = base ∧ + final wireCountMetaReg = wires.length + 1 ∧ + final (base + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ delta, + final (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0 := by + obtain ⟨final, cost, space, hexec, hpointer, hremaining, hbase, + hcount, happended, hwires, htail⟩ := + routine_correct hready hbound value0 value1 hvalue0 hvalue1 + have hcompiled := Exec.compile_correct hexec + exact ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + hcompiled.2.1, hcompiled.2.2, hpointer, hremaining, hbase, hcount, + happended, hwires, htail⟩ + +end GateStreamStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Defs.lean new file mode 100644 index 0000000000..4597ae3380 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Defs.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs + +/-! +# Structured RAM iterable serialized-gate step β€” definitions + +Unlike the compact `GateStep` benchmark, this routine keeps the code cursor and +mutable wire memo physically separate. Registers `7` and `8` carry the memo base +and current wire count while the parser consumes a gate from a higher code +region. Two fixed continuation cells lie between the evaluator's control prefix +and the memo, so cursor state survives gate evaluation without aliasing either +mutable wires or unread code. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStreamStep + +/-- Physical base of the mutable wire memo. -/ +def memoBaseReg : β„• := 7 +/-- Number of semantic entries currently in the wire memo. -/ +def wireCountMetaReg : β„• := 8 +/-- Address of the current gate's first header bit. -/ +def gateStartReg : β„• := 9 +/-- First decoded reference retained across the second unary decode. -/ +def savedInput0Reg : β„• := 10 +/-- Fixed spill cell for the next code pointer. -/ +def spillPointerReg : β„• := 11 +/-- Fixed spill cell for the unread-code count. -/ +def spillRemainingReg : β„• := 12 + +/-- Initialize parser scratch and remember the current gate start. -/ +def setupOps : List Basic := + [.imm UnaryDecode.verdictReg 0, + .imm UnaryDecode.valueReg 0, + .imm UnaryDecode.oneReg 1, + .imm UnaryDecode.activeReg 1, + .imm gateStartReg 0, + .add gateStartReg UnaryDecode.pointerReg gateStartReg] + +/-- Consume the fixed three-bit gate header without copying it. The header is +loaded from its saved code address only after both references are decoded. -/ +def headerOps : List Basic := + [.add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg, + .add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg, + .add UnaryDecode.pointerReg UnaryDecode.pointerReg UnaryDecode.oneReg, + .sub UnaryDecode.remainingReg UnaryDecode.remainingReg UnaryDecode.oneReg] + +/-- Save the first reference and restart the unary accumulator. -/ +def saveRestartOps : List Basic := + [.add savedInput0Reg UnaryDecode.valueReg UnaryDecode.activeReg, + .imm UnaryDecode.verdictReg 0, + .imm UnaryDecode.valueReg 0, + .imm UnaryDecode.activeReg 1] + +/-- Spill the continuation cursor, load the saved header, and marshal the gate +and independent memo metadata into `GateEval`'s calling convention. -/ +def marshalOps : List Basic := + [.add GateEval.wireCountReg wireCountMetaReg UnaryDecode.activeReg, + .imm wireCountMetaReg spillPointerReg, + .store wireCountMetaReg UnaryDecode.pointerReg, + .imm wireCountMetaReg spillRemainingReg, + .store wireCountMetaReg UnaryDecode.remainingReg, + .add GateEval.address1Reg UnaryDecode.valueReg UnaryDecode.activeReg, + .add GateEval.address0Reg savedInput0Reg UnaryDecode.activeReg, + .add GateEval.baseReg memoBaseReg UnaryDecode.activeReg, + .imm wireCountMetaReg 1, + .load GateEval.opReg gateStartReg, + .add gateStartReg gateStartReg wireCountMetaReg, + .load GateEval.negated0Reg gateStartReg, + .add gateStartReg gateStartReg wireCountMetaReg, + .load GateEval.negated1Reg gateStartReg] + +/-- Recover the next code cursor and rebuild persistent memo metadata after the +gate kernel has appended its result. -/ +def restoreOps : List Basic := + [.imm UnaryDecode.activeReg 0, + .add memoBaseReg GateEval.baseReg UnaryDecode.activeReg, + .imm wireCountMetaReg 1, + .imm UnaryDecode.activeReg spillPointerReg, + .load UnaryDecode.pointerReg UnaryDecode.activeReg, + .imm UnaryDecode.activeReg spillRemainingReg, + .load UnaryDecode.remainingReg UnaryDecode.activeReg, + .add wireCountMetaReg GateEval.wireCountReg wireCountMetaReg] + +/-- Parse and evaluate one gate while retaining an independent code cursor and +memo base for the next call. -/ +def routine : Cmd := Cmd.seqList + [.basics setupOps, + .basics headerOps, + UnaryDecode.mainLoop, + .basics saveRestartOps, + UnaryDecode.mainLoop, + .basics marshalOps, + GateEval.program, + .basics restoreOps] + +/-- Concrete compiled iterable gate routine. -/ +def compiled : Program := routine.compile + +/-- Exact transition count on one canonical gate. -/ +def stepCount (gate : CircuitCode.RawGate) : β„• := + 10 * (gate.inputβ‚€ + gate.input₁) + 80 + +/-- Serialized bits beginning at the current gate and continuing with unread +code. -/ +def codeBits (gate : CircuitCode.RawGate) (tail : List Bool) : List Bool := + gate.encode ++ tail + +/-- Absolute address immediately after all code visible to this invocation. -/ +def codeEnd (gateStart : β„•) (gate : CircuitCode.RawGate) + (tail : List Bool) : β„• := + gateStart + (codeBits gate tail).length + +/-- Unary-decoder input length corresponding to the absolute code region. -/ +def cursorLength (gateStart : β„•) (gate : CircuitCode.RawGate) + (tail : List Bool) : β„• := + gateStart - UnaryDecode.inputBase + (codeBits gate tail).length + +/-- Calling convention at the beginning of an iterable gate invocation. -/ +structure Ready (gateStart base : β„•) (gate : CircuitCode.RawGate) + (tail : List Bool) (wires : List Bool) (store : Store) : Prop where + /-- The memo lies strictly above the fixed continuation cells. -/ + base_ge : spillRemainingReg < base + /-- The append cell lies strictly before the current gate. -/ + memo_before_code : base + wires.length < gateStart + /-- The parser cursor points at the current gate header. -/ + pointer_eq : store UnaryDecode.pointerReg = gateStart + /-- The parser sees the complete current gate followed by unread code. -/ + remaining_eq : store UnaryDecode.remainingReg = (codeBits gate tail).length + /-- Persistent physical memo base. -/ + memoBase_eq : store memoBaseReg = base + /-- Persistent semantic memo length. -/ + wireCount_eq : store wireCountMetaReg = wires.length + /-- Current gate and unread tail are encoded at the cursor. -/ + code_eq : βˆ€ delta, + store (gateStart + delta) = + match (codeBits gate tail)[delta]? with + | some bit => Input.bitValue bit + | none => 0 + /-- Existing memo contents. -/ + wire_eq : βˆ€ index, + store (base + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 + +/-- Calling convention immediately before `marshalOps`, after both references +have been decoded successfully. -/ +structure Parsed (gateStart nextPointer remaining base : β„•) + (gate : CircuitCode.RawGate) (wires : List Bool) (store : Store) : Prop where + /-- The memo lies strictly above the fixed continuation cells. -/ + base_ge : spillRemainingReg < base + /-- The append cell lies strictly before unread gate code. -/ + memo_before_code : base + wires.length < gateStart + /-- The second unary decoder recorded success. -/ + verdict_eq : store UnaryDecode.verdictReg = 1 + /-- The second decoded reference remains in the accumulator. -/ + value_eq : store UnaryDecode.valueReg = gate.input₁ + /-- The next unread code address. -/ + pointer_eq : store UnaryDecode.pointerReg = nextPointer + /-- Number of unread code bits. -/ + remaining_eq : store UnaryDecode.remainingReg = remaining + /-- The second unary loop is inactive. -/ + active_eq : store UnaryDecode.activeReg = 0 + /-- Persistent physical memo base. -/ + memoBase_eq : store memoBaseReg = base + /-- Persistent semantic memo length. -/ + wireCount_eq : store wireCountMetaReg = wires.length + /-- Saved address of the current gate header. -/ + gateStart_eq : store gateStartReg = gateStart + /-- Retained first decoded reference. -/ + input0_eq : store savedInput0Reg = gate.inputβ‚€ + /-- Operation header bit at the saved gate address. -/ + op_eq : store gateStart = Input.bitValue gate.opBit + /-- First-negation header bit. -/ + negated0_eq : store (gateStart + 1) = Input.bitValue gate.negatedβ‚€ + /-- Second-negation header bit. -/ + negated1_eq : store (gateStart + 2) = Input.bitValue gate.negated₁ + /-- Existing memo contents. -/ + wire_eq : βˆ€ index, + store (base + index) = + match wires[index]? with + | some bit => Input.bitValue bit + | none => 0 + +end GateStreamStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Internal.lean new file mode 100644 index 0000000000..2e241bb7b7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/GateStreamStep/Internal.lean @@ -0,0 +1,1091 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Internal.Codec +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateEval.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.GateStreamStep.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Internal +public import Mathlib.Tactic.IntervalCases + +/-! +# Structured RAM iterable serialized-gate step β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace GateStreamStep + +open Internal + +private def marshalStore (store : Store) : Store := + Basic.execList marshalOps store + +private def marshalPrefix (store : Store) : Store := + Basic.execList + [.add GateEval.wireCountReg wireCountMetaReg UnaryDecode.activeReg, + .imm wireCountMetaReg spillPointerReg, + .store wireCountMetaReg UnaryDecode.pointerReg, + .imm wireCountMetaReg spillRemainingReg, + .store wireCountMetaReg UnaryDecode.remainingReg, + .add GateEval.address1Reg UnaryDecode.valueReg UnaryDecode.activeReg, + .add GateEval.address0Reg savedInput0Reg UnaryDecode.activeReg, + .add GateEval.baseReg memoBaseReg UnaryDecode.activeReg, + .imm wireCountMetaReg 1] + store + +private def loadedOp (store : Store) : Store := + (Basic.load GateEval.opReg gateStartReg).exec (marshalPrefix store) + +private def advanced0 (store : Store) : Store := + (Basic.add gateStartReg gateStartReg wireCountMetaReg).exec (loadedOp store) + +private def loadedNegated0 (store : Store) : Store := + (Basic.load GateEval.negated0Reg gateStartReg).exec (advanced0 store) + +private def advanced1 (store : Store) : Store := + (Basic.add gateStartReg gateStartReg wireCountMetaReg).exec + (loadedNegated0 store) + +private def loadedNegated1 (store : Store) : Store := + (Basic.load GateEval.negated1Reg gateStartReg).exec (advanced1 store) + +private theorem marshalStore_eq (store : Store) : + marshalStore store = loadedNegated1 store := by rfl + +private theorem marshalPrefix_high (store : Store) (index : β„•) + (hindex : spillRemainingReg < index) : + marshalPrefix store index = store index := by + simp only [spillRemainingReg] at hindex + simp (disch := omega) [marshalPrefix, Basic.execList, Basic.exec, + Function.update_of_ne, GateEval.address0Reg, GateEval.address1Reg, + GateEval.wireCountReg, GateEval.baseReg, memoBaseReg, wireCountMetaReg, + savedInput0Reg, spillPointerReg, spillRemainingReg] + +private theorem marshal_high (store : Store) (index : β„•) + (hindex : spillRemainingReg < index) : + marshalStore store index = store index := by + simp only [spillRemainingReg] at hindex + have h0 : index β‰  GateEval.opReg := by + simp only [GateEval.opReg] + omega + have h1 : index β‰  GateEval.negated0Reg := by + simp only [GateEval.negated0Reg] + omega + have h2 : index β‰  GateEval.negated1Reg := by + simp only [GateEval.negated1Reg] + omega + have h3 : index β‰  GateEval.address0Reg := by + simp only [GateEval.address0Reg] + omega + have h4 : index β‰  GateEval.address1Reg := by + simp only [GateEval.address1Reg] + omega + have h5 : index β‰  GateEval.wireCountReg := by + simp only [GateEval.wireCountReg] + omega + have h8 : index β‰  wireCountMetaReg := by + simp only [wireCountMetaReg] + omega + have h9 : index β‰  gateStartReg := by + simp only [gateStartReg] + omega + have h10 : index β‰  GateEval.baseReg := by + simp only [GateEval.baseReg] + omega + have h11 : index β‰  spillPointerReg := by + simp only [spillPointerReg] + omega + have h12 : index β‰  spillRemainingReg := by + simp only [spillRemainingReg] + omega + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + Function.update_of_ne, h0, h1, h2, h3, h4, h5, h8, h9, h10, h11, + h12] + +private theorem marshal_wireCount {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.wireCountReg = wires.length := by + have hcount : store 8 = wires.length := by + simpa [wireCountMetaReg] using h.wireCount_eq + have hactive : store 6 = 0 := by + simpa [UnaryDecode.activeReg] using h.active_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.activeReg, hcount, hactive] + +private theorem marshal_address1 {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.address1Reg = gate.input₁ := by + have hvalue : store 1 = gate.input₁ := by + simpa [UnaryDecode.valueReg] using h.value_eq + have hactive : store 6 = 0 := by + simpa [UnaryDecode.activeReg] using h.active_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.valueReg, UnaryDecode.activeReg, hvalue, hactive] + +private theorem marshal_address0 {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.address0Reg = gate.inputβ‚€ := by + have hinput0 : store 10 = gate.inputβ‚€ := by + simpa [savedInput0Reg] using h.input0_eq + have hactive : store 6 = 0 := by + simpa [UnaryDecode.activeReg] using h.active_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.activeReg, hinput0, hactive] + +private theorem marshal_base {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.baseReg = base := by + have hbase : store 7 = base := by + simpa [memoBaseReg] using h.memoBase_eq + have hactive : store 6 = 0 := by + simpa [UnaryDecode.activeReg] using h.active_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.activeReg, hbase, hactive] + +private theorem marshal_spillPointer + {gateStart nextPointer remaining base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store spillPointerReg = nextPointer := by + have hpointer : store 2 = nextPointer := by + simpa [UnaryDecode.pointerReg] using h.pointer_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.pointerReg, hpointer] + +private theorem marshal_spillRemaining + {gateStart nextPointer remaining base : β„•} {gate : CircuitCode.RawGate} + {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store spillRemainingReg = remaining := by + have hremaining : store 3 = remaining := by + simpa [UnaryDecode.remainingReg] using h.remaining_eq + simp [marshalStore, marshalOps, Basic.execList, Basic.exec, + GateEval.opReg, GateEval.negated0Reg, GateEval.negated1Reg, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, memoBaseReg, wireCountMetaReg, gateStartReg, + savedInput0Reg, spillPointerReg, spillRemainingReg, + UnaryDecode.remainingReg, hremaining] + +private theorem marshal_op {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.opReg = Input.bitValue gate.opBit := by + have hlarge : spillRemainingReg < gateStart := by + have hbase := h.base_ge + have hcode := h.memo_before_code + omega + have hprefixStart : marshalPrefix store gateStartReg = gateStart := by + simpa [marshalPrefix, Basic.execList, Basic.exec, Function.update_of_ne, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, gateStartReg, wireCountMetaReg, spillPointerReg, + spillRemainingReg] using h.gateStart_eq + have hprefixHeader : marshalPrefix store gateStart = + Input.bitValue gate.opBit := by + rw [marshalPrefix_high store gateStart hlarge, h.op_eq] + have hloaded : loadedOp store GateEval.opReg = + Input.bitValue gate.opBit := by + simp [loadedOp, Basic.exec, hprefixStart, hprefixHeader] + rw [marshalStore_eq] + simpa [loadedNegated1, advanced1, loadedNegated0, advanced0, Basic.exec, + Function.update_of_ne, GateEval.opReg, GateEval.negated0Reg, + GateEval.negated1Reg, gateStartReg] using hloaded + +private theorem marshal_negated0 {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + have hlarge : spillRemainingReg < gateStart + 1 := by + have hbase := h.base_ge + have hcode := h.memo_before_code + omega + have hprefixStart : marshalPrefix store gateStartReg = gateStart := by + simpa [marshalPrefix, Basic.execList, Basic.exec, Function.update_of_ne, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, gateStartReg, wireCountMetaReg, spillPointerReg, + spillRemainingReg] using h.gateStart_eq + have hprefixOne : marshalPrefix store wireCountMetaReg = 1 := by + simp [marshalPrefix, Basic.execList, Basic.exec, wireCountMetaReg] + have hprefixStart' : marshalPrefix store 9 = gateStart := by + simpa [gateStartReg] using hprefixStart + have hprefixOne' : marshalPrefix store 8 = 1 := by + simpa [wireCountMetaReg] using hprefixOne + have hloadedStart : loadedOp store gateStartReg = gateStart := by + simpa [loadedOp, Basic.exec, Function.update_of_ne, GateEval.opReg, + gateStartReg] using hprefixStart' + have hloadedOne : loadedOp store wireCountMetaReg = 1 := by + simpa [loadedOp, Basic.exec, Function.update_of_ne, GateEval.opReg, + wireCountMetaReg] using hprefixOne' + have hadvancedStart : advanced0 store gateStartReg = gateStart + 1 := by + change loadedOp store gateStartReg + loadedOp store wireCountMetaReg = _ + rw [hloadedStart, hloadedOne] + have hprefixHeader : marshalPrefix store (gateStart + 1) = + Input.bitValue gate.negatedβ‚€ := by + rw [marshalPrefix_high store (gateStart + 1) hlarge, h.negated0_eq] + have hloadedHeader : loadedOp store (gateStart + 1) = + Input.bitValue gate.negatedβ‚€ := by + rw [show loadedOp store (gateStart + 1) = + marshalPrefix store (gateStart + 1) by + simp [loadedOp, Basic.exec, Function.update_of_ne, GateEval.opReg]] + exact hprefixHeader + have hadvancedHeader : advanced0 store (gateStart + 1) = + Input.bitValue gate.negatedβ‚€ := by + rw [advanced0, Basic.exec, Function.update_of_ne] + Β· exact hloadedHeader + Β· simp only [gateStartReg, spillRemainingReg] at hlarge ⊒ + omega + have hloaded : loadedNegated0 store GateEval.negated0Reg = + Input.bitValue gate.negatedβ‚€ := by + simp [loadedNegated0, Basic.exec, hadvancedStart, hadvancedHeader] + rw [marshalStore_eq] + simpa [loadedNegated1, advanced1, Basic.exec, Function.update_of_ne, + GateEval.negated0Reg, GateEval.negated1Reg, gateStartReg] using hloaded + +private theorem marshal_negated1 {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (h : Parsed gateStart nextPointer remaining base gate wires store) : + marshalStore store GateEval.negated1Reg = + Input.bitValue gate.negated₁ := by + have hlarge : spillRemainingReg < gateStart + 2 := by + have hbase := h.base_ge + have hcode := h.memo_before_code + omega + have hprefixStart : marshalPrefix store gateStartReg = gateStart := by + simpa [marshalPrefix, Basic.execList, Basic.exec, Function.update_of_ne, + GateEval.address0Reg, GateEval.address1Reg, GateEval.wireCountReg, + GateEval.baseReg, gateStartReg, wireCountMetaReg, spillPointerReg, + spillRemainingReg] using h.gateStart_eq + have hprefixOne : marshalPrefix store wireCountMetaReg = 1 := by + simp [marshalPrefix, Basic.execList, Basic.exec, wireCountMetaReg] + have hprefixStart' : marshalPrefix store 9 = gateStart := by + simpa [gateStartReg] using hprefixStart + have hprefixOne' : marshalPrefix store 8 = 1 := by + simpa [wireCountMetaReg] using hprefixOne + have hloadedStart : loadedOp store gateStartReg = gateStart := by + simpa [loadedOp, Basic.exec, Function.update_of_ne, GateEval.opReg, + gateStartReg] using hprefixStart' + have hloadedOne : loadedOp store wireCountMetaReg = 1 := by + simpa [loadedOp, Basic.exec, Function.update_of_ne, GateEval.opReg, + wireCountMetaReg] using hprefixOne' + have hadvanced0Start : advanced0 store gateStartReg = gateStart + 1 := by + change loadedOp store gateStartReg + loadedOp store wireCountMetaReg = _ + rw [hloadedStart, hloadedOne] + have hloaded0Start : loadedNegated0 store gateStartReg = gateStart + 1 := by + simpa [loadedNegated0, Basic.exec, Function.update_of_ne, + GateEval.negated0Reg, gateStartReg] using hadvanced0Start + have hloaded0One : loadedNegated0 store wireCountMetaReg = 1 := by + have hadvancedOne : advanced0 store wireCountMetaReg = 1 := by + simpa [advanced0, Basic.exec, Function.update_of_ne, gateStartReg, + wireCountMetaReg] using hloadedOne + simpa [loadedNegated0, Basic.exec, Function.update_of_ne, + GateEval.negated0Reg, wireCountMetaReg] using hadvancedOne + have hadvanced1Start : advanced1 store gateStartReg = gateStart + 2 := by + change loadedNegated0 store gateStartReg + + loadedNegated0 store wireCountMetaReg = _ + rw [hloaded0Start, hloaded0One] + have hprefixHeader : marshalPrefix store (gateStart + 2) = + Input.bitValue gate.negated₁ := by + rw [marshalPrefix_high store (gateStart + 2) hlarge, h.negated1_eq] + have hadvancedHeader : advanced1 store (gateStart + 2) = + Input.bitValue gate.negated₁ := by + rw [advanced1, Basic.exec, Function.update_of_ne] + Β· rw [loadedNegated0, Basic.exec, Function.update_of_ne] + Β· rw [advanced0, Basic.exec, Function.update_of_ne] + Β· rw [loadedOp, Basic.exec, Function.update_of_ne] + Β· exact hprefixHeader + Β· simp only [GateEval.opReg, spillRemainingReg] at hlarge ⊒ + omega + Β· simp only [gateStartReg, spillRemainingReg] at hlarge ⊒ + omega + Β· simp only [GateEval.negated0Reg, spillRemainingReg] at hlarge ⊒ + omega + Β· simp only [gateStartReg, spillRemainingReg] at hlarge ⊒ + omega + rw [marshalStore_eq] + simp [loadedNegated1, Basic.exec, hadvanced1Start, hadvancedHeader] + +theorem marshal_ready_internal {gateStart nextPointer remaining base : β„•} + {gate : CircuitCode.RawGate} {wires : List Bool} {store : Store} + (hparsed : Parsed gateStart nextPointer remaining base gate wires store) : + GateEval.ReadyAt base gate wires (Basic.execList marshalOps store) ∧ + Basic.execList marshalOps store spillPointerReg = nextPointer ∧ + Basic.execList marshalOps store spillRemainingReg = remaining := by + change GateEval.ReadyAt base gate wires (marshalStore store) ∧ + marshalStore store spillPointerReg = nextPointer ∧ + marshalStore store spillRemainingReg = remaining + refine ⟨?_, marshal_spillPointer hparsed, marshal_spillRemaining hparsed⟩ + constructor + Β· have hbase := hparsed.base_ge + simp only [GateEval.wireBase, spillRemainingReg] at hbase ⊒ + omega + Β· exact marshal_op hparsed + Β· exact marshal_negated0 hparsed + Β· exact marshal_negated1 hparsed + Β· exact marshal_address0 hparsed + Β· exact marshal_address1 hparsed + Β· exact marshal_wireCount hparsed + Β· exact marshal_base hparsed + Β· intro index hindex + rw [marshal_high store (base + index)] + Β· exact hparsed.wire_eq index + Β· have hbase := hparsed.base_ge + omega + +private def setupStore (store : Store) : Store := + Basic.execList setupOps store + +private def headerStore (store : Store) : Store := + Basic.execList headerOps (setupStore store) + +private def saveRestartStore (store : Store) : Store := + Basic.execList saveRestartOps store + +private def restoreStore (store : Store) : Store := + Basic.execList restoreOps store + +private def firstRemaining (gate : CircuitCode.RawGate) + (tail : List Bool) : List Bool := + CircuitCode.NatCode.encode gate.inputβ‚€ ++ + CircuitCode.NatCode.encode gate.input₁ ++ tail + +private def secondRemaining (gate : CircuitCode.RawGate) + (tail : List Bool) : List Bool := + CircuitCode.NatCode.encode gate.input₁ ++ tail + +private def firstOffset (gateStart : β„•) : β„• := + gateStart - UnaryDecode.inputBase + 3 + +private def secondOffset (gateStart : β„•) + (gate : CircuitCode.RawGate) : β„• := + gateStart - UnaryDecode.inputBase + 4 + gate.inputβ‚€ + +private theorem setup_high (store : Store) (index : β„•) (hindex : 10 < index) : + setupStore store index = store index := by + simp (disch := omega) [setupStore, setupOps, Basic.execList, Basic.exec, + Function.update_of_ne, gateStartReg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.pointerReg, UnaryDecode.oneReg, + UnaryDecode.activeReg] + +private theorem header_high (store : Store) (index : β„•) (hindex : 10 < index) : + headerStore store index = store index := by + rw [headerStore] + have hsetup := setup_high store index hindex + simpa (disch := omega) [headerOps, Basic.execList, Basic.exec, + Function.update_of_ne, UnaryDecode.pointerReg, + UnaryDecode.remainingReg] using hsetup + +private theorem first_ready {gateStart base : β„•} {gate : CircuitCode.RawGate} + {tail : List Bool} {wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) : + UnaryDecode.CursorReady (cursorLength gateStart gate tail) + (firstRemaining gate tail) (firstOffset gateStart) 0 + (headerStore store) := by + have hstart : UnaryDecode.inputBase ≀ gateStart := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [UnaryDecode.inputBase, spillRemainingReg] at hbase ⊒ + omega + constructor + Β· simp [cursorLength, firstOffset, firstRemaining, codeBits, + CircuitCode.RawGate.encode] + omega + Β· omega + Β· simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.verdictReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.valueReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg] + Β· simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.verdictReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg] + Β· have hp : store 2 = gateStart := by + simpa [UnaryDecode.pointerReg] using hready.pointer_eq + simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.pointerReg, UnaryDecode.remainingReg, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg, hp, firstOffset] + omega + Β· have hr : store 3 = + (codeBits gate tail).length := hready.remaining_eq + simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.pointerReg, UnaryDecode.remainingReg, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg, hr, firstRemaining, codeBits, + CircuitCode.RawGate.encode] + Β· simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.oneReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.activeReg, gateStartReg] + Β· simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.activeReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.oneReg, gateStartReg] + Β· intro delta + have haddress : UnaryDecode.inputBase + firstOffset gateStart + delta = + gateStart + (3 + delta) := by + simp [firstOffset] + omega + rw [haddress, header_high store] + Β· rw [hready.code_eq (3 + delta)] + rw [show 3 + delta = Nat.succ (Nat.succ (Nat.succ delta)) by omega] + simp [codeBits, firstRemaining, CircuitCode.RawGate.encode] + rfl + Β· have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + +private theorem header_bound {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) + (hbound : Internal.StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) store) : + Internal.StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) (headerStore store) := by + have hlarge : 10 < codeEnd gateStart gate tail := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + simp [codeEnd, codeBits, CircuitCode.RawGate.length_encode] + omega + have hheaderEnd : gateStart + 3 ≀ codeEnd gateStart gate tail := by + simp [codeEnd, codeBits, CircuitCode.RawGate.length_encode] + omega + have hcodeLength : (codeBits gate tail).length ≀ + codeEnd gateStart gate tail := by + simp [codeEnd] + have hserialized : 5 + gate.inputβ‚€ + gate.input₁ + tail.length ≀ + codeEnd gateStart gate tail := by + simpa [codeBits, CircuitCode.RawGate.length_encode, Nat.add_assoc, + Nat.add_comm, Nat.add_left_comm] using hcodeLength + have hp : store 2 = gateStart := by + simpa [UnaryDecode.pointerReg] using hready.pointer_eq + have hr : store 3 = (codeBits gate tail).length := by + simpa [UnaryDecode.remainingReg] using hready.remaining_eq + constructor + Β· intro index hnonzero + by_cases hindex : index ≀ 10 + Β· omega + Β· rw [header_high store index (by omega)] at hnonzero + exact hbound.index_lt index hnonzero + Β· intro index + by_cases hindex : index ≀ 10 + Β· interval_cases index <;> + simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, + UnaryDecode.oneReg, UnaryDecode.activeReg, gateStartReg, hp, hr, + codeBits] + all_goals try omega + all_goals exact hbound.value_le _ + Β· rw [header_high store index (by omega)] + exact hbound.value_le index + +private theorem saveRestart_high (store : Store) (index : β„•) + (hindex : 10 < index) : + saveRestartStore store index = store index := by + simp (disch := omega) [saveRestartStore, saveRestartOps, Basic.execList, + Basic.exec, Function.update_of_ne, savedInput0Reg, + UnaryDecode.verdictReg, UnaryDecode.valueReg, UnaryDecode.activeReg] + +private theorem saveRestart_apply_of_ne (store : Store) (index : β„•) + (hsaved : index β‰  savedInput0Reg) + (hverdict : index β‰  UnaryDecode.verdictReg) + (hvalue : index β‰  UnaryDecode.valueReg) + (hactive : index β‰  UnaryDecode.activeReg) : + saveRestartStore store index = store index := by + simp [saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + Function.update_of_ne, hsaved, hverdict, hvalue, hactive] + +private theorem saveRestart_bound {bound : β„•} {store : Store} + (hbound : Internal.StoreEnvelope bound bound store) + (hlarge : 10 < bound) (hactive : store UnaryDecode.activeReg = 0) : + Internal.StoreEnvelope bound bound (saveRestartStore store) := by + let saved0 := (Basic.add savedInput0Reg UnaryDecode.valueReg + UnaryDecode.activeReg).exec store + have h0 : Internal.StoreEnvelope bound bound saved0 := by + apply hbound.execBasic + Β· simpa [Basic.writeIndex, savedInput0Reg] using hlarge + Β· change store UnaryDecode.valueReg + store UnaryDecode.activeReg ≀ bound + rw [hactive, Nat.add_zero] + exact hbound.value_le UnaryDecode.valueReg + have h1 := h0.execBasic (.imm UnaryDecode.verdictReg 0) + (by simp [Basic.writeIndex, UnaryDecode.verdictReg]; omega) + (by simp [Basic.writeValue]) + have h2 := h1.execBasic (.imm UnaryDecode.valueReg 0) + (by simp [Basic.writeIndex, UnaryDecode.valueReg]; omega) + (by simp [Basic.writeValue]) + have h3 := h2.execBasic (.imm UnaryDecode.activeReg 1) + (by simp [Basic.writeIndex, UnaryDecode.activeReg]; omega) + (by simp [Basic.writeValue]; omega) + simpa [saveRestartStore, saveRestartOps, Basic.execList, saved0] using h3 + +private theorem header_op {gateStart base : β„•} {gate : CircuitCode.RawGate} + {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) : + headerStore store gateStart = Input.bitValue gate.opBit := by + have hlarge : 10 < gateStart := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + rw [header_high store gateStart hlarge] + have hcode := hready.code_eq 0 + simpa [codeBits, CircuitCode.RawGate.encode] using hcode + +private theorem header_negated0 {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) : + headerStore store (gateStart + 1) = + Input.bitValue gate.negatedβ‚€ := by + have hlarge : 10 < gateStart + 1 := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + rw [header_high store (gateStart + 1) hlarge, hready.code_eq 1] + simp [codeBits, CircuitCode.RawGate.encode] + +private theorem header_negated1 {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) : + headerStore store (gateStart + 2) = + Input.bitValue gate.negated₁ := by + have hlarge : 10 < gateStart + 2 := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + rw [header_high store (gateStart + 2) hlarge, hready.code_eq 2] + simp [codeBits, CircuitCode.RawGate.encode] + +/-- The two decoded operands and preserved metadata satisfy the parsed-gate interface. -/ +private theorem parsed_of_decoder_state {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store second : Store} + (hready : Ready gateStart base gate tail wires store) + (hsecondVerdict : second UnaryDecode.verdictReg = 1) + (hsecondValue : second UnaryDecode.valueReg = gate.input₁) + (hsecondPointer : second UnaryDecode.pointerReg = gateStart + gate.encode.length) + (hsecondRemaining : second UnaryDecode.remainingReg = tail.length) + (hsecondActive : second UnaryDecode.activeReg = 0) + (hmeta : βˆ€ index, UnaryDecode.inputBase ≀ index β†’ index β‰  savedInput0Reg β†’ + second index = headerStore store index) + (hpreserved : βˆ€ index, 10 < index β†’ second index = store index) + (hinput0 : second savedInput0Reg = gate.inputβ‚€) : + Parsed gateStart (gateStart + gate.encode.length) + tail.length base gate wires second := by + constructor + Β· exact hready.base_ge + Β· exact hready.memo_before_code + Β· exact hsecondVerdict + Β· exact hsecondValue + Β· exact hsecondPointer + Β· exact hsecondRemaining + Β· exact hsecondActive + Β· rw [hmeta memoBaseReg] + Β· simpa [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, memoBaseReg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg] using hready.memoBase_eq + Β· simp [memoBaseReg, UnaryDecode.inputBase] + Β· simp [memoBaseReg, savedInput0Reg] + Β· rw [hmeta wireCountMetaReg] + Β· simpa [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, wireCountMetaReg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.oneReg, + UnaryDecode.activeReg, gateStartReg] using hready.wireCount_eq + Β· simp [wireCountMetaReg, UnaryDecode.inputBase] + Β· simp [wireCountMetaReg, savedInput0Reg] + Β· rw [hmeta gateStartReg] + Β· simp [headerStore, headerOps, setupStore, setupOps, Basic.execList, + Basic.exec, gateStartReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg] + exact hready.pointer_eq + Β· simp [gateStartReg, UnaryDecode.inputBase] + Β· simp [gateStartReg, savedInput0Reg] + Β· exact hinput0 + Β· rw [hpreserved gateStart] + Β· exact hready.code_eq 0 |>.trans (by + simp [codeBits, CircuitCode.RawGate.encode]) + Β· have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + Β· rw [hpreserved (gateStart + 1)] + Β· simpa [codeBits, CircuitCode.RawGate.encode] using + hready.code_eq 1 + Β· have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + Β· rw [hpreserved (gateStart + 2)] + Β· simpa [codeBits, CircuitCode.RawGate.encode] using + hready.code_eq 2 + Β· have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + Β· intro index + rw [hpreserved (base + index)] + Β· exact hready.wire_eq index + Β· have hbase := hready.base_ge + simp only [spillRemainingReg] at hbase + omega + +/-- Decoder preservation above the register block retains the complete trailing code stream. -/ +private theorem decoder_tail_preserved {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store second : Store} + (hready : Ready gateStart base gate tail wires store) + (hpreserved : βˆ€ index, 10 < index β†’ second index = store index) : + βˆ€ delta, + second (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0 := by + intro delta + rw [hpreserved (gateStart + gate.encode.length + delta)] + Β· have hcode := hready.code_eq (gate.encode.length + delta) + rw [show gateStart + (gate.encode.length + delta) = + gateStart + gate.encode.length + delta by omega] at hcode + rw [show (codeBits gate tail)[gate.encode.length + delta]? = + tail[delta]? by + rw [codeBits, List.getElem?_append_right (by simp)] + simp] at hcode + exact hcode + Β· have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + omega + +private theorem decoders_internal {gateStart base : β„•} {gate : CircuitCode.RawGate} + {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) + (hbound : StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) store) : + βˆƒ first saved second firstCost firstSpace secondCost secondSpace, + Exec UnaryDecode.mainLoop (headerStore store) first + (UnaryDecode.loopStepCount (firstRemaining gate tail)) + firstCost firstSpace ∧ + saved = saveRestartStore first ∧ + Exec UnaryDecode.mainLoop saved second + (UnaryDecode.loopStepCount (secondRemaining gate tail)) + secondCost secondSpace ∧ + Parsed gateStart (gateStart + gate.encode.length) tail.length base + gate wires second ∧ + (βˆ€ delta, second (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0) ∧ + StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) second := by + have hstart : UnaryDecode.inputBase ≀ gateStart := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg, UnaryDecode.inputBase] at hbase ⊒ + omega + have hcursorEnd : cursorLength gateStart gate tail + + UnaryDecode.inputBase = codeEnd gateStart gate tail := by + simp [cursorLength, codeEnd] + omega + have hheaderBound : StoreEnvelope (cursorLength gateStart gate tail + + UnaryDecode.inputBase) (cursorLength gateStart gate tail + + UnaryDecode.inputBase) (headerStore store) := by + rw [hcursorEnd] + exact header_bound hready hbound + have hfirstReady := first_ready hready + obtain ⟨first, firstCost, firstSpace, hfirst, _hfirstCost, _hfirstSpace, + hfirstResult, hfirstActive, hfirstOne, hfirstFrame, hfirstBound⟩ := + UnaryDecode.mainLoop_measured_internal hfirstReady hheaderBound + have hdecode0 : CircuitCode.NatCode.decodePrefix? + (firstRemaining gate tail) = + some (gate.inputβ‚€, secondRemaining gate tail) := by + simp [firstRemaining, secondRemaining] + rw [hdecode0] at hfirstResult + simp only at hfirstResult + have hfirstValue : first UnaryDecode.valueReg = gate.inputβ‚€ := + by simpa using hfirstResult.2.1 + have hfirstPointer : first UnaryDecode.pointerReg = + gateStart + 4 + gate.inputβ‚€ := by + have hp := hfirstResult.2.2.1 + rw [hp] + simp [firstOffset] + omega + have hfirstRemaining : first UnaryDecode.remainingReg = + (secondRemaining gate tail).length := hfirstResult.2.2.2 + let saved := saveRestartStore first + have hlarge : 10 < codeEnd gateStart gate tail := by + have hbase := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbase + simp [codeEnd] + omega + have hsavedBound : StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) saved := by + apply saveRestart_bound + Β· simpa [hcursorEnd] using hfirstBound + Β· exact hlarge + Β· exact hfirstActive + have hsecondReady : UnaryDecode.CursorReady + (cursorLength gateStart gate tail) (secondRemaining gate tail) + (secondOffset gateStart gate) 0 saved := by + constructor + Β· simp [cursorLength, secondOffset, secondRemaining, codeBits, + CircuitCode.RawGate.length_encode] + omega + Β· omega + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, + Basic.exec, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.activeReg] + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, + Basic.exec, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.activeReg] + Β· change saved UnaryDecode.pointerReg = _ + rw [show saved UnaryDecode.pointerReg = + first UnaryDecode.pointerReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.pointerReg, + UnaryDecode.activeReg]] + rw [hfirstPointer] + simp [secondOffset] + omega + Β· change saved UnaryDecode.remainingReg = + (secondRemaining gate tail).length + rw [show saved UnaryDecode.remainingReg = + first UnaryDecode.remainingReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.remainingReg, + UnaryDecode.activeReg]] + exact hfirstRemaining + Β· change saved UnaryDecode.oneReg = 1 + rw [show saved UnaryDecode.oneReg = first UnaryDecode.oneReg by + apply saveRestart_apply_of_ne <;> + simp [savedInput0Reg, UnaryDecode.verdictReg, + UnaryDecode.valueReg, UnaryDecode.oneReg, + UnaryDecode.activeReg]] + exact hfirstOne + Β· simp [saved, saveRestartStore, saveRestartOps, Basic.execList, + Basic.exec, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.activeReg] + Β· intro delta + have haddress : UnaryDecode.inputBase + secondOffset gateStart gate + + delta = UnaryDecode.inputBase + firstOffset gateStart + + (gate.inputβ‚€ + 1 + delta) := by + simp [secondOffset, firstOffset] + omega + rw [haddress] + rw [show saved (UnaryDecode.inputBase + firstOffset gateStart + + (gate.inputβ‚€ + 1 + delta)) = + first (UnaryDecode.inputBase + firstOffset gateStart + + (gate.inputβ‚€ + 1 + delta)) by + apply saveRestart_high + simp [firstOffset, UnaryDecode.inputBase] + omega] + rw [hfirstFrame _ (by simp [UnaryDecode.inputBase]; omega)] + have hinput := hfirstReady.input_eq (gate.inputβ‚€ + 1 + delta) + have hlookup : (firstRemaining gate tail)[gate.inputβ‚€ + 1 + delta]? = + (secondRemaining gate tail)[delta]? := by + rw [show firstRemaining gate tail = + CircuitCode.NatCode.encode gate.inputβ‚€ ++ + secondRemaining gate tail by + simp [firstRemaining, secondRemaining, List.append_assoc]] + rw [List.getElem?_append_right (by simp)] + simp + rw [hlookup] at hinput + exact hinput + have hsavedCursorBound : StoreEnvelope + (cursorLength gateStart gate tail + UnaryDecode.inputBase) + (cursorLength gateStart gate tail + UnaryDecode.inputBase) saved := by + rw [hcursorEnd] + exact hsavedBound + obtain ⟨second, secondCost, secondSpace, hsecond, _hsecondCost, + _hsecondSpace, hsecondResult, hsecondActive, _hsecondOne, + hsecondFrame, hsecondBound⟩ := + UnaryDecode.mainLoop_measured_internal hsecondReady hsavedCursorBound + have hdecode1 : CircuitCode.NatCode.decodePrefix? + (secondRemaining gate tail) = some (gate.input₁, tail) := by + simp [secondRemaining] + rw [hdecode1] at hsecondResult + simp only at hsecondResult + have hsecondValue : second UnaryDecode.valueReg = gate.input₁ := + by simpa using hsecondResult.2.1 + have hsecondPointer : second UnaryDecode.pointerReg = + gateStart + gate.encode.length := by + have hp := hsecondResult.2.2.1 + rw [hp] + simp [secondOffset, CircuitCode.RawGate.length_encode] + omega + have hsecondRemaining : second UnaryDecode.remainingReg = tail.length := + hsecondResult.2.2.2 + have hpreserved (index : β„•) (hindex : 10 < index) : + second index = store index := by + rw [hsecondFrame index (by + simp only [UnaryDecode.inputBase] + omega)] + change saveRestartStore first index = store index + rw [saveRestart_high first index hindex] + rw [hfirstFrame index (by + simp only [UnaryDecode.inputBase] + omega)] + exact header_high store index hindex + have hmeta (index : β„•) (h7 : UnaryDecode.inputBase ≀ index) + (hsaved : index β‰  savedInput0Reg) : + second index = headerStore store index := by + rw [hsecondFrame index h7] + change saveRestartStore first index = headerStore store index + rw [saveRestart_apply_of_ne] + Β· exact hfirstFrame index h7 + Β· exact hsaved + Β· simp only [UnaryDecode.inputBase] at h7 + simp only [UnaryDecode.verdictReg] + omega + Β· simp only [UnaryDecode.inputBase] at h7 + simp only [UnaryDecode.valueReg] + omega + Β· simp only [UnaryDecode.inputBase] at h7 + simp only [UnaryDecode.activeReg] + omega + have hinput0 : second savedInput0Reg = gate.inputβ‚€ := by + rw [hsecondFrame _ (by simp [savedInput0Reg, UnaryDecode.inputBase])] + change saveRestartStore first savedInput0Reg = gate.inputβ‚€ + have hvalue : first 1 = gate.inputβ‚€ := by + simpa [UnaryDecode.valueReg] using hfirstValue + have hactive : first 6 = 0 := by + simpa [UnaryDecode.activeReg] using hfirstActive + simp [saveRestartStore, saveRestartOps, Basic.execList, Basic.exec, + savedInput0Reg, UnaryDecode.verdictReg, UnaryDecode.valueReg, + UnaryDecode.activeReg, hvalue, hactive] + have hparsed := parsed_of_decoder_state hready hsecondResult.1 hsecondValue + hsecondPointer hsecondRemaining hsecondActive hmeta hpreserved hinput0 + have hsecondCode := decoder_tail_preserved hready hpreserved + refine ⟨first, saved, second, firstCost, firstSpace, secondCost, + secondSpace, hfirst, rfl, hsecond, hparsed, hsecondCode, ?_⟩ + simpa [hcursorEnd] using hsecondBound + +private theorem restore_high (store : Store) (index : β„•) + (hindex : spillRemainingReg < index) : + restoreStore store index = store index := by + simp only [spillRemainingReg] at hindex + simp (disch := omega) [restoreStore, restoreOps, Basic.execList, Basic.exec, + Function.update_of_ne, memoBaseReg, wireCountMetaReg, spillPointerReg, + spillRemainingReg, GateEval.wireCountReg, GateEval.baseReg, + UnaryDecode.pointerReg, UnaryDecode.remainingReg, + UnaryDecode.activeReg] + +theorem routine_exec_internal {gateStart base : β„•} + {gate : CircuitCode.RawGate} {tail wires : List Bool} {store : Store} + (hready : Ready gateStart base gate tail wires store) + (hbound : StoreEnvelope (codeEnd gateStart gate tail) + (codeEnd gateStart gate tail) store) + (value0 value1 : Bool) (hvalue0 : wires[gate.inputβ‚€]? = some value0) + (hvalue1 : wires[gate.input₁]? = some value1) : + βˆƒ final cost space, + Exec routine store final (stepCount gate) cost space ∧ + final UnaryDecode.pointerReg = gateStart + gate.encode.length ∧ + final UnaryDecode.remainingReg = tail.length ∧ + final memoBaseReg = base ∧ + final wireCountMetaReg = wires.length + 1 ∧ + final (base + wires.length) = + Input.bitValue (gate.eval value0 value1) ∧ + (βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index]) ∧ + βˆ€ delta, + final (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0 := by + obtain ⟨first, saved, second, firstCost, firstSpace, secondCost, + secondSpace, hfirst, rfl, hsecond, hparsed, hsecondCode, + _hsecondBound⟩ := + decoders_internal hready hbound + let marshaled := Basic.execList marshalOps second + obtain ⟨hgateReady, hspillPointer, hspillRemaining⟩ := + marshal_ready_internal hparsed + change GateEval.ReadyAt base gate wires marshaled at hgateReady + change marshaled spillPointerReg = gateStart + gate.encode.length at hspillPointer + change marshaled spillRemainingReg = tail.length at hspillRemaining + obtain ⟨evaluated, gateCost, gateSpace, hgate, houtput, happended, + hbase, hcount, hwires, hgateFrame⟩ := + GateEval.routine_exec_internal hgateReady value0 value1 hvalue0 hvalue1 + have hevalSpillPointer : evaluated spillPointerReg = + gateStart + gate.encode.length := by + rw [hgateFrame spillPointerReg] + Β· exact hspillPointer + Β· simp [GateEval.wireBase, spillPointerReg] + Β· have hbaseGe := hready.base_ge + simp only [spillPointerReg, spillRemainingReg] at hbaseGe ⊒ + omega + have hevalSpillRemaining : evaluated spillRemainingReg = tail.length := by + rw [hgateFrame spillRemainingReg] + Β· exact hspillRemaining + Β· simp [GateEval.wireBase, spillRemainingReg] + Β· have hbaseGe := hready.base_ge + simp only [spillRemainingReg] at hbaseGe ⊒ + omega + let final := restoreStore evaluated + have hfinalPointer : final UnaryDecode.pointerReg = + gateStart + gate.encode.length := by + have hbase' : evaluated 10 = base := by + simpa [GateEval.baseReg] using hbase + have hcount' : evaluated 5 = wires.length := by + simpa [GateEval.wireCountReg] using hcount + have hspillPointer' : evaluated 11 = + gateStart + gate.encode.length := by + simpa [spillPointerReg] using hevalSpillPointer + have hspillRemaining' : evaluated 12 = tail.length := by + simpa [spillRemainingReg] using hevalSpillRemaining + simp [final, restoreStore, restoreOps, Basic.execList, Basic.exec, + memoBaseReg, wireCountMetaReg, spillPointerReg, spillRemainingReg, + GateEval.wireCountReg, GateEval.baseReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.activeReg, hbase', hcount', + hspillPointer', hspillRemaining'] + have hfinalRemaining : final UnaryDecode.remainingReg = tail.length := by + have hbase' : evaluated 10 = base := by + simpa [GateEval.baseReg] using hbase + have hcount' : evaluated 5 = wires.length := by + simpa [GateEval.wireCountReg] using hcount + have hspillPointer' : evaluated 11 = + gateStart + gate.encode.length := by + simpa [spillPointerReg] using hevalSpillPointer + have hspillRemaining' : evaluated 12 = tail.length := by + simpa [spillRemainingReg] using hevalSpillRemaining + simp [final, restoreStore, restoreOps, Basic.execList, Basic.exec, + memoBaseReg, wireCountMetaReg, spillPointerReg, spillRemainingReg, + GateEval.wireCountReg, GateEval.baseReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.activeReg, hbase', hcount', + hspillPointer', hspillRemaining'] + have hfinalBase : final memoBaseReg = base := by + have hbase' : evaluated 10 = base := by + simpa [GateEval.baseReg] using hbase + simp [final, restoreStore, restoreOps, Basic.execList, Basic.exec, + memoBaseReg, wireCountMetaReg, spillPointerReg, spillRemainingReg, + GateEval.wireCountReg, GateEval.baseReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.activeReg, hbase'] + have hfinalCount : final wireCountMetaReg = wires.length + 1 := by + have hcount' : evaluated 5 = wires.length := by + simpa [GateEval.wireCountReg] using hcount + simp [final, restoreStore, restoreOps, Basic.execList, Basic.exec, + memoBaseReg, wireCountMetaReg, spillPointerReg, spillRemainingReg, + GateEval.wireCountReg, GateEval.baseReg, UnaryDecode.pointerReg, + UnaryDecode.remainingReg, UnaryDecode.activeReg, hcount'] + have hfinalAppended : final (base + wires.length) = + Input.bitValue (gate.eval value0 value1) := by + rw [show final (base + wires.length) = + evaluated (base + wires.length) by + apply restore_high + have hbaseGe := hready.base_ge + simp only [spillRemainingReg] at hbaseGe ⊒ + omega] + exact happended + have hfinalWires : βˆ€ index (hindex : index < wires.length), + final (base + index) = Input.bitValue wires[index] := by + intro index hindex + rw [show final (base + index) = evaluated (base + index) by + apply restore_high + have hbaseGe := hready.base_ge + simp only [spillRemainingReg] at hbaseGe ⊒ + omega] + exact hwires index hindex + have hfinalCode : βˆ€ delta, + final (gateStart + gate.encode.length + delta) = + match tail[delta]? with + | some bit => Input.bitValue bit + | none => 0 := by + intro delta + have hcodeAddress : spillRemainingReg < + gateStart + gate.encode.length + delta := by + have hbaseGe := hready.base_ge + have hcode := hready.memo_before_code + simp only [spillRemainingReg] at hbaseGe ⊒ + omega + change restoreStore evaluated + (gateStart + gate.encode.length + delta) = _ + rw [restore_high evaluated _ hcodeAddress] + rw [hgateFrame _] + Β· change marshalStore second + (gateStart + gate.encode.length + delta) = _ + rw [marshal_high second _ hcodeAddress] + exact hsecondCode delta + Β· simp only [GateEval.wireBase, spillRemainingReg] at hcodeAddress ⊒ + omega + Β· have hcode := hready.memo_before_code + omega + obtain ⟨setupCost, setupSpace, hsetup⟩ := exec_basics_exists setupOps store + obtain ⟨headerCost, headerSpace, hheader⟩ := + exec_basics_exists headerOps (setupStore store) + obtain ⟨saveCost, saveSpace, hsave⟩ := exec_basics_exists saveRestartOps first + obtain ⟨marshalCost, marshalSpace, hmarshal⟩ := + exec_basics_exists marshalOps second + obtain ⟨restoreCost, restoreSpace, hrestore⟩ := + exec_basics_exists restoreOps evaluated + have hrun := hsetup.seq (hheader.seq (hfirst.seq + (hsave.seq (hsecond.seq (hmarshal.seq (hgate.seq hrestore)))))) + have hsteps : setupOps.length + + (headerOps.length + (UnaryDecode.loopStepCount (firstRemaining gate tail) + + (saveRestartOps.length + + (UnaryDecode.loopStepCount (secondRemaining gate tail) + + (marshalOps.length + (GateEval.stepCount + restoreOps.length)))))) = + stepCount gate := by + simp [setupOps, headerOps, saveRestartOps, marshalOps, restoreOps, + UnaryDecode.loopStepCount, firstRemaining, secondRemaining, + GateEval.stepCount, stepCount] + omega + have hexec : βˆƒ cost space, + Exec routine store final (stepCount gate) cost space := by + refine ⟨setupCost + (headerCost + (firstCost + + (saveCost + (secondCost + (marshalCost + (gateCost + restoreCost)))))), + max setupSpace (max headerSpace (max firstSpace + (max saveSpace (max secondSpace + (max marshalSpace (max gateSpace restoreSpace)))))), ?_⟩ + rw [← hsteps] + simpa [routine, setupStore, headerStore, saveRestartStore, marshaled, + final, restoreStore] using! hrun + obtain ⟨cost, space, hexec⟩ := hexec + exact ⟨final, cost, space, hexec, hfinalPointer, hfinalRemaining, + hfinalBase, hfinalCount, hfinalAppended, hfinalWires, hfinalCode⟩ + +end GateStreamStep + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming.lean new file mode 100644 index 0000000000..9520e16097 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Internal +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified structured RAM Hamming weight + +`Hamming.program` is a structured imperative program over the reserved-register +layout `Hamming.inputStore`. Its correctness and resource bounds are proved in +the independent source semantics. `Hamming.compiled_performance` then applies +the generic compiler theorem, carrying the result to the concrete logarithmic-cost +RAM with an exact transition count, explicit length-indexed budgets, and +quasilinear asymptotic corollaries. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Hamming + +/-- Source-level correctness with an exact transition count and explicit +logarithmic-cost time and peak-space bounds. -/ +theorem program_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + final lengthReg = weight bits := + program_measured_internal bits + +/-- End-to-end compiled performance theorem. The concrete RAM reaches its halt +instruction after exactly `stepCount bits` transitions, within the explicit +logarithmic-cost time and peak-space budgets, and returns the Hamming weight. -/ +theorem compiled_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + run compiled (stepCount bits) { pc := 0, regs := inputStore bits } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount bits) { pc := 0, regs := inputStore bits }) ∧ + logTimeUpto compiled (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length ∧ + spaceUpto compiled (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length ∧ + (run compiled (stepCount bits) { pc := 0, regs := inputStore bits }).regs + lengthReg = weight bits := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + program_performance bits + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, ?_⟩ + Β· change logTimeUpto program.compile (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto program.compile (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length + rw [hcompiled.2.2] + exact hspace + Β· change (run program.compile (stepCount bits) + { pc := 0, regs := inputStore bits }).regs lengthReg = weight bits + rw [hcompiled.1] + exact hresult + +/-- The explicit logarithmic-cost time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear : timeBound =O quasilinearBound := by + have hpoint : βˆ€ n, timeBound n ≀ 64 * quasilinearBound n := by + intro n + simp only [timeBound, quasilinearBound] + have hshift : n + 1 ≀ n + 5 := by omega + calc + 64 * (n + 1) * (bitlen (n + 5) + 1) + = 64 * ((n + 1) * (bitlen (n + 5) + 1)) := by ring + _ ≀ 64 * ((n + 5) * (bitlen (n + 5) + 1)) := + Nat.mul_le_mul_left 64 + (Nat.mul_le_mul_right (bitlen (n + 5) + 1) hshift) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 64 (BigO.refl quasilinearBound)) + +/-- The explicit peak-space budget is quasilinear under the reserved-register +input representation. -/ +theorem spaceBound_bigO_quasilinear : spaceBound =O quasilinearBound := by + have hpoint : βˆ€ n, spaceBound n ≀ 2 * quasilinearBound n := by + intro n + simp only [spaceBound, quasilinearBound] + calc + (n + 5) * (2 * bitlen (n + 5)) + = 2 * ((n + 5) * bitlen (n + 5)) := by ring + _ ≀ 2 * ((n + 5) * (bitlen (n + 5) + 1)) := + Nat.mul_le_mul_left 2 (Nat.mul_le_mul_left (n + 5) (by omega)) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 2 (BigO.refl quasilinearBound)) + +end Hamming + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Defs.lean new file mode 100644 index 0000000000..292c015bb0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Defs.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs + +/-! +# Structured RAM Hamming-weight program β€” definitions + +The benchmark uses a small reserved-register ABI: registers `Rβ‚€` through `Rβ‚„` +hold loop state and input bits start at `Rβ‚…`. This avoids the existing raw RAM +input convention's overlap between an unbounded input and fixed scratch registers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Hamming + +/-- Remaining input length and final-result register. -/ +def lengthReg : β„• := 0 +/-- Hamming-weight accumulator register. -/ +def countReg : β„• := 1 +/-- Address of the next input bit. -/ +def pointerReg : β„• := 2 +/-- Constant-one register used for increments and decrements. -/ +def oneReg : β„• := 3 +/-- Temporary register receiving the current input bit. -/ +def scratchReg : β„• := 4 +/-- First register occupied by input data under the reserved-register ABI. -/ +def inputBase : β„• := 5 + +/-- Natural-number representation of one input bit. -/ +@[simp] +def bitValue (bit : Bool) : β„• := Input.bitValue bit + +/-- Mathematical Hamming weight of a Boolean list. -/ +def weight : List Bool β†’ β„• + | [] => 0 + | bit :: rest => bitValue bit + weight rest + +/-- Reserved-register input layout for the structured benchmark. -/ +def inputStore (bits : List Bool) : Store := + Input.bitStore lengthReg inputBase bits + +/-- Basic instructions that initialize the accumulator, input pointer, and +constant-one register. -/ +def setupOps : List Basic := + [.imm countReg 0, .imm pointerReg inputBase, .imm oneReg 1] + +/-- Initialize the Hamming loop registers. -/ +def setup : Cmd := Cmd.basics setupOps + +/-- One Hamming-weight loop iteration. -/ +def body : Cmd := Cmd.seqList + [Cmd.basic (.load scratchReg pointerReg), + Cmd.ifZero scratchReg Cmd.skip (Cmd.basic (.add countReg countReg oneReg)), + Cmd.basic (.add pointerReg pointerReg oneReg), + Cmd.basic (.sub lengthReg lengthReg oneReg)] + +/-- Process input bits until the remaining-length register reaches zero. -/ +def mainLoop : Cmd := Cmd.whileNonzero lengthReg body + +/-- Copy the accumulator to the result register `Rβ‚€`. -/ +def finalize : Cmd := Cmd.seqList + [Cmd.basic (.imm oneReg 0), Cmd.basic (.add lengthReg countReg oneReg)] + +/-- Complete structured Hamming-weight program. -/ +def program : Cmd := Cmd.seq setup (.seq mainLoop finalize) + +/-- Concrete compiled RAM program for Hamming weight. -/ +def compiled : Program := program.compile + +/-- Exact number of target RAM transitions needed to reach the compiled halt +instruction. A zero bit uses six loop transitions and a one bit uses eight. -/ +def stepCount (bits : List Bool) : β„• := + 6 + 6 * bits.length + 2 * weight bits + +/-- Explicit logarithmic-cost time budget as a function of input length. The +constant is deliberately simple: the important content is the linear number +of operations, each on values of `O(bitlen n)` bits. -/ +def timeBound (inputLength : β„•) : β„• := + 64 * (inputLength + 1) * (bitlen (inputLength + 5) + 1) + +/-- Explicit peak-space budget for the reserved-register input representation. +There are at most `inputLength + 5` nonzero registers, and both an occupied +register index and its value have at most `bitlen (inputLength + 5)` bits. -/ +def spaceBound (inputLength : β„•) : β„• := + (inputLength + 5) * (2 * bitlen (inputLength + 5)) + +/-- A shifted `n Β· bitlen n` comparison function used to state the benchmark's +quasilinear time and space bounds without hiding small-input behavior. -/ +def quasilinearBound (inputLength : β„•) : β„• := + (inputLength + 5) * (bitlen (inputLength + 5) + 1) + +end Hamming + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Internal.lean new file mode 100644 index 0000000000..009699ccee --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Hamming/Internal.lean @@ -0,0 +1,475 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Hamming.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources + +/-! +# Structured RAM Hamming-weight program β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Hamming + +open Internal + +private abbrev StoreBound (inputLength : β„•) (store : Store) : Prop := + StoreEnvelope (inputLength + 5) (inputLength + 5) store + +private abbrev width (inputLength : β„•) : β„• := + valueWidth (inputLength + 5) + +private abbrev resourceSpace (inputLength : β„•) : β„• := + envelopeSpace (inputLength + 5) (inputLength + 5) + +private theorem envelopeSpace_eq_spaceBound (inputLength : β„•) : + envelopeSpace (inputLength + 5) (inputLength + 5) = spaceBound inputLength := by + simp [envelopeSpace, spaceBound, two_mul] + +private theorem inputStore_bound (bits : List Bool) : + StoreBound bits.length (inputStore bits) := by + apply Internal.Input.bitStoreEnvelope + Β· simp [lengthReg] + Β· simp [inputBase] + omega + Β· omega + Β· omega + +private structure LoopInv (inputLength : β„•) (remaining : List Bool) + (consumed acc : β„•) (store : Store) : Prop where + total_eq : consumed + remaining.length = inputLength + acc_le : acc ≀ consumed + store_bound : StoreBound inputLength store + length_eq : store lengthReg = remaining.length + count_eq : store countReg = acc + pointer_eq : store pointerReg = inputBase + consumed + one_eq : store oneReg = 1 + input_eq : βˆ€ offset, + store (inputBase + consumed + offset) = + match remaining[offset]? with + | some bit => bitValue bit + | none => 0 + +private def loaded (store : Store) : Store := + (Basic.load scratchReg pointerReg).exec store + +private def branched (bit : Bool) (store : Store) : Store := + if bit then (Basic.add countReg countReg oneReg).exec (loaded store) + else loaded store + +private def advanced (bit : Bool) (store : Store) : Store := + (Basic.add pointerReg pointerReg oneReg).exec (branched bit store) + +private def iterated (bit : Bool) (store : Store) : Store := + (Basic.sub lengthReg lengthReg oneReg).exec (advanced bit store) + +private theorem bitValue_le_one (bit : Bool) : bitValue bit ≀ 1 := by + cases bit <;> simp [bitValue] + +private theorem loaded_bound {inputLength : β„•} {store : Store} + (hstore : StoreBound inputLength store) : + StoreBound inputLength (loaded store) := by + apply hstore.execBasic (.load scratchReg pointerReg) + Β· simp [scratchReg] + Β· simpa [Internal.Basic.writeValue] using hstore.value_le (store pointerReg) + +private theorem branched_bound {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + StoreBound inputLength (branched bit store) := by + cases bit with + | false => simpa [branched] using loaded_bound hinv.store_bound + | true => + rw [branched, ite_eq_left rfl] + apply (loaded_bound hinv.store_bound).execBasic + (.add countReg countReg oneReg) + Β· simp [countReg] + Β· have hcount : loaded store countReg = acc := by + have hcountβ‚€ : store 1 = acc := by + simpa [countReg] using hinv.count_eq + simp [loaded, Basic.exec, countReg, scratchReg, hcountβ‚€] + have hone : loaded store oneReg = 1 := by + have honeβ‚€ : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + simp [loaded, Basic.exec, oneReg, scratchReg, honeβ‚€] + change loaded store countReg + loaded store oneReg ≀ inputLength + 5 + rw [hcount, hone] + have htotal := hinv.total_eq + have hacc := hinv.acc_le + omega + +private theorem advanced_bound {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + StoreBound inputLength (advanced bit store) := by + apply (branched_bound hinv).execBasic (.add pointerReg pointerReg oneReg) + Β· simp [pointerReg] + Β· have hpointer : branched bit store pointerReg = inputBase + consumed := by + have hpointerβ‚€ : store 2 = inputBase + consumed := by + simpa [pointerReg] using hinv.pointer_eq + cases bit <;> + simp [branched, loaded, Basic.exec, pointerReg, oneReg, scratchReg, + countReg, hpointerβ‚€] + have hone : branched bit store oneReg = 1 := by + have honeβ‚€ : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + cases bit <;> + simp [branched, loaded, Basic.exec, pointerReg, oneReg, scratchReg, + countReg, honeβ‚€] + change branched bit store pointerReg + branched bit store oneReg ≀ inputLength + 5 + rw [hpointer, hone] + have htotal := hinv.total_eq + simp [inputBase] at htotal ⊒ + omega + +private theorem iterated_bound {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + StoreBound inputLength (iterated bit store) := by + apply (advanced_bound hinv).execBasic (.sub lengthReg lengthReg oneReg) + Β· simp [lengthReg] + Β· have hlength : advanced bit store lengthReg = (bit :: rest).length := by + have hlengthβ‚€ : store 0 = rest.length + 1 := by + simpa [lengthReg] using hinv.length_eq + cases bit <;> + simp [advanced, branched, loaded, Basic.exec, lengthReg, pointerReg, + oneReg, scratchReg, countReg, hlengthβ‚€] + have hone : advanced bit store oneReg = 1 := by + have honeβ‚€ : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + cases bit <;> + simp [advanced, branched, loaded, Basic.exec, pointerReg, + oneReg, scratchReg, countReg, honeβ‚€] + change advanced bit store lengthReg - advanced bit store oneReg ≀ inputLength + 5 + rw [hlength, hone] + have htotal := hinv.total_eq + omega + +private theorem loaded_scratch {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + loaded store scratchReg = bitValue bit := by + simp only [loaded, Basic.exec, Function.update_self] + rw [hinv.pointer_eq] + simpa using hinv.input_eq 0 + +private theorem body_measured {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + MeasuredRuns body store (iterated bit store) (4 + 2 * bitValue bit) + (20 * width inputLength) (resourceSpace inputLength) := by + have hloadedBound := loaded_bound hinv.store_bound + have hbranchedBound := branched_bound hinv + have hadvancedBound := advanced_bound hinv + have hiteratedBound := iterated_bound hinv + have hload : MeasuredRuns (.basic (.load scratchReg pointerReg)) + store (loaded store) 1 (4 * width inputLength) (resourceSpace inputLength) := + MeasuredRuns.basicEnvelope _ _ hinv.store_bound hloadedBound + have hbranch : MeasuredRuns + (.ifZero scratchReg Cmd.skip (.basic (.add countReg countReg oneReg))) + (loaded store) (branched bit store) (1 + 2 * bitValue bit) + (8 * width inputLength) (resourceSpace inputLength) := by + cases bit with + | false => + have hzero : loaded store scratchReg = 0 := by + simpa [bitValue] using loaded_scratch hinv + have hrun := MeasuredRuns.ifZeroEnvelope + (onNonzero := .basic (.add countReg countReg oneReg)) hzero hloadedBound + (MeasuredRuns.skipEnvelope hloadedBound) + apply MeasuredRuns.weakenCost (by simpa [branched, bitValue] using hrun) + change width inputLength ≀ 8 * width inputLength + omega + | true => + have hnonzero : loaded store scratchReg β‰  0 := by + have hscratch := loaded_scratch hinv + simp [bitValue, hscratch] + let op := Basic.add countReg countReg oneReg + have hop : op.exec (loaded store) = branched true store := by + simp [op, branched] + have hadd := MeasuredRuns.basicEnvelope op (loaded store) hloadedBound + (by simpa [hop] using hbranchedBound) + have hrun := MeasuredRuns.ifNonzeroEnvelope (onZero := Cmd.skip) + hnonzero hloadedBound hadd + apply MeasuredRuns.weakenCost (by simpa [branched, bitValue, op] using hrun) + change 3 * width inputLength + 4 * width inputLength ≀ + 8 * width inputLength + omega + have hadvance : MeasuredRuns (.basic (.add pointerReg pointerReg oneReg)) + (branched bit store) (advanced bit store) 1 (4 * width inputLength) + (resourceSpace inputLength) := + MeasuredRuns.basicEnvelope _ _ hbranchedBound hadvancedBound + have hdecrement : MeasuredRuns (.basic (.sub lengthReg lengthReg oneReg)) + (advanced bit store) (iterated bit store) 1 (4 * width inputLength) + (resourceSpace inputLength) := + MeasuredRuns.basicEnvelope _ _ hadvancedBound hiteratedBound + have hrun := hload.seq (hbranch.seq (hadvance.seq hdecrement)) + rw [body, Cmd.seqList] + convert! hrun using 1 + Β· cases bit <;> simp [bitValue] + Β· ring + +private theorem iterated_high (bit : Bool) (store : Store) (index : β„•) + (hindex : inputBase ≀ index) : iterated bit store index = store index := by + have hlength : index β‰  lengthReg := by + simp [inputBase, lengthReg] at hindex ⊒ + omega + have hcount : index β‰  countReg := by + simp [inputBase, countReg] at hindex ⊒ + omega + have hpointer : index β‰  pointerReg := by + simp [inputBase, pointerReg] at hindex ⊒ + omega + have hscratch : index β‰  scratchReg := by + simp [inputBase, scratchReg] at hindex ⊒ + omega + cases bit <;> simp [iterated, advanced, branched, loaded, Basic.exec, + Function.update_of_ne, hlength, hcount, hpointer, hscratch] + +private theorem iterated_inv {bit : Bool} {rest : List Bool} + {inputLength consumed acc : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) consumed acc store) : + LoopInv inputLength rest (consumed + 1) (acc + bitValue bit) + (iterated bit store) := by + constructor + Β· have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + omega + Β· have hbit := bitValue_le_one bit + have hacc := hinv.acc_le + omega + Β· exact iterated_bound hinv + Β· cases bit <;> + simp [iterated, advanced, branched, loaded, Basic.exec, lengthReg, + countReg, pointerReg, oneReg, scratchReg] + all_goals + have hlength : store 0 = (Bool.false :: rest).length := by + simpa [lengthReg] using hinv.length_eq + have hone : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + rw [hlength, hone] + simp + Β· cases bit <;> + simp [iterated, advanced, branched, loaded, Basic.exec, lengthReg, + countReg, pointerReg, oneReg, scratchReg, bitValue] + all_goals + have hcount : store 1 = acc := by simpa [countReg] using hinv.count_eq + have hone : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + simp [hcount, hone] + Β· cases bit <;> + simp [iterated, advanced, branched, loaded, Basic.exec, lengthReg, + countReg, pointerReg, oneReg, scratchReg, inputBase] + all_goals + have hpointer : store 2 = 5 + consumed := by + simpa [pointerReg, inputBase] using hinv.pointer_eq + have hone : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + rw [hpointer, hone] + omega + Β· cases bit <;> + simp [iterated, advanced, branched, loaded, Basic.exec, lengthReg, + countReg, pointerReg, oneReg, scratchReg] <;> exact hinv.one_eq + Β· intro offset + rw [iterated_high bit store _ (by simp [inputBase]; omega)] + have hinput := hinv.input_eq (offset + 1) + convert! hinput using 1 + all_goals simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + +private def loopAdvance (state : β„• Γ— β„•) (bit : Bool) : β„• Γ— β„• := + (state.1 + 1, state.2 + bitValue bit) + +private theorem foldl_loopAdvance (bits : List Bool) (consumed acc : β„•) : + bits.foldl loopAdvance (consumed, acc) = + (consumed + bits.length, acc + weight bits) := by + induction bits generalizing consumed acc with + | nil => simp [weight] + | cons bit rest ih => + simp only [List.foldl_cons, loopAdvance] + rw [ih] + simp only [List.length_cons, weight] + cases bit <;> simp [bitValue] <;> omega + +private theorem whileFoldSteps_eq (bits : List Bool) : + MeasuredRuns.whileFoldSteps (fun bit => 4 + 2 * bitValue bit) bits = + 1 + 6 * bits.length + 2 * weight bits := by + induction bits with + | nil => simp [MeasuredRuns.whileFoldSteps, weight] + | cons bit rest ih => + rw [MeasuredRuns.whileFoldSteps, ih] + cases bit <;> simp [weight, bitValue] <;> omega + +private theorem whileFoldCost_eq (bits : List Bool) (w : β„•) : + MeasuredRuns.whileFoldCost w (fun _ : Bool => 20 * w) bits = + (23 * bits.length + 1) * w := by + induction bits with + | nil => simp [MeasuredRuns.whileFoldCost] + | cons bit rest ih => + rw [MeasuredRuns.whileFoldCost, ih] + simp only [List.length_cons] + ring + +private theorem loop_measured {remaining : List Bool} {inputLength consumed acc : β„•} + {store : Store} (hinv : LoopInv inputLength remaining consumed acc store) : + βˆƒ final, + MeasuredRuns mainLoop store final + (1 + 6 * remaining.length + 2 * weight remaining) + ((23 * remaining.length + 1) * width inputLength) + (resourceSpace inputLength) ∧ + final countReg = acc + weight remaining ∧ final lengthReg = 0 ∧ + StoreBound inputLength final := by + let bodySteps : Bool β†’ β„• := fun bit => 4 + 2 * bitValue bit + let bodyCost : Bool β†’ β„• := fun _ => 20 * width inputLength + have hrun := MeasuredRuns.whileFoldEnvelope + (Inv := fun items state store => + LoopInv inputLength items state.1 state.2 store) + (advance := loopAdvance) (bodySteps := bodySteps) (bodyCost := bodyCost) + (test := lengthReg) (body := body) + (hstore := by intro _ _ _ h; exact h.store_bound) + (hnil := by intro _ _ h; simpa using h.length_eq) + (hcons := by intro _ _ _ _ h; rw [h.length_eq]; simp) + (hbody := by + intro bit rest state current h + exact ⟨iterated bit current, body_measured h, by + simpa [loopAdvance] using iterated_inv h⟩) + (items := remaining) (state := (consumed, acc)) (initial := store) hinv + obtain ⟨final, hloop, hfinal⟩ := hrun + have hsteps : MeasuredRuns.whileFoldSteps bodySteps remaining = + 1 + 6 * remaining.length + 2 * weight remaining := by + simpa [bodySteps] using whileFoldSteps_eq remaining + have hcost : MeasuredRuns.whileFoldCost (width inputLength) bodyCost remaining = + (23 * remaining.length + 1) * width inputLength := by + simpa [bodyCost] using whileFoldCost_eq remaining (width inputLength) + have hstate := foldl_loopAdvance remaining consumed acc + rw [hstate] at hfinal + refine ⟨final, ?_, hfinal.count_eq, hfinal.length_eq, hfinal.store_bound⟩ + simpa [mainLoop, hsteps, hcost] using hloop + +private def setupStore (bits : List Bool) : Store := + Basic.execList setupOps (inputStore bits) + +private theorem setup_measured (bits : List Bool) : + MeasuredRuns setup (inputStore bits) (setupStore bits) 3 + (12 * width bits.length) (resourceSpace bits.length) ∧ + StoreBound bits.length (setupStore bits) := by + have hinitial := inputStore_bound bits + have hpreserve : βˆ€ op, op ∈ setupOps β†’ βˆ€ current, + StoreBound bits.length current β†’ + StoreBound bits.length (op.exec current) := by + intro op hop current hcurrent + simp [setupOps] at hop + rcases hop with rfl | rfl | rfl + Β· apply hcurrent.execBasic (.imm countReg 0) <;> simp [countReg] + Β· apply hcurrent.execBasic (.imm pointerReg inputBase) + Β· simp [pointerReg] + Β· simp [inputBase] + Β· apply hcurrent.execBasic (.imm oneReg 1) <;> simp [oneReg] + obtain ⟨hrun, hfinal⟩ := + MeasuredRuns.basicsEnvelope setupOps (inputStore bits) hinitial hpreserve + constructor + Β· simpa [setup, setupStore, setupOps] using hrun + Β· simpa [setupStore] using hfinal + +private theorem setup_inv (bits : List Bool) + (hbound : StoreBound bits.length (setupStore bits)) : + LoopInv bits.length bits 0 0 (setupStore bits) := by + constructor + Β· simp + Β· simp + Β· exact hbound + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, inputStore, + Input.bitStore, lengthReg, countReg, pointerReg, oneReg, inputBase] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, countReg, pointerReg, oneReg] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, pointerReg, oneReg, inputBase] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, oneReg] + Β· intro offset + have hcount : 5 + offset β‰  1 := by omega + have hpointer : 5 + offset β‰  2 := by omega + have hone : 5 + offset β‰  3 := by omega + simp [setupStore, setupOps, Basic.execList, Basic.exec, Function.update_of_ne, + hcount, hpointer, hone, inputStore, Input.bitStore, bitValue, lengthReg, + countReg, pointerReg, oneReg, inputBase] + rfl + +private def finalStore (store : Store) : Store := + (Basic.add lengthReg countReg oneReg).exec + ((Basic.imm oneReg 0).exec store) + +private theorem finalize_measured {inputLength : β„•} {store : Store} + (hstore : StoreBound inputLength store) : + MeasuredRuns finalize store (finalStore store) 2 + (8 * width inputLength) (resourceSpace inputLength) := by + let zeroed := (Basic.imm oneReg 0).exec store + have hzeroed : StoreBound inputLength zeroed := by + apply hstore.execBasic (.imm oneReg 0) + Β· simp [oneReg] + Β· simp [Internal.Basic.writeValue] + have hfinal : StoreBound inputLength (finalStore store) := by + apply hzeroed.execBasic (.add lengthReg countReg oneReg) + Β· simp [lengthReg] + Β· have hcount := hstore.value_le countReg + simpa [zeroed, Basic.exec, countReg, oneReg] using hcount + have hzero : MeasuredRuns (.basic (.imm oneReg 0)) store zeroed 1 + (4 * width inputLength) (resourceSpace inputLength) := + MeasuredRuns.basicEnvelope _ _ hstore hzeroed + have hadd : MeasuredRuns (.basic (.add lengthReg countReg oneReg)) zeroed + (finalStore store) 1 (4 * width inputLength) (resourceSpace inputLength) := + MeasuredRuns.basicEnvelope _ _ hzeroed hfinal + have hrun := hzero.seq hadd + rw [finalize, Cmd.seqList] + convert! hrun using 1 + all_goals ring + +theorem program_measured_internal (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + final lengthReg = weight bits := by + obtain ⟨hsetup, hsetupStore⟩ := setup_measured bits + have hsetupInv := setup_inv bits hsetupStore + obtain ⟨loopFinal, hloop, hcount, hlength, hloopStore⟩ := + loop_measured hsetupInv + have hfinalize := finalize_measured hloopStore + have hseq := hsetup.seq (hloop.seq hfinalize) + have hcostLe : + 12 * width bits.length + + ((23 * bits.length + 1) * width bits.length + 8 * width bits.length) + ≀ timeBound bits.length := by + rw [timeBound] + change _ ≀ 64 * (bits.length + 1) * width bits.length + calc + 12 * width bits.length + + ((23 * bits.length + 1) * width bits.length + 8 * width bits.length) + = (23 * bits.length + 21) * width bits.length := by ring + _ ≀ (64 * (bits.length + 1)) * width bits.length := + Nat.mul_le_mul_right _ (by omega) + _ = 64 * (bits.length + 1) * width bits.length := by ring + have hprogram := hseq.weakenCost hcostLe + rw [program] + have hprogram' : MeasuredRuns (setup.seq (mainLoop.seq finalize)) + (inputStore bits) (finalStore loopFinal) (stepCount bits) + (timeBound bits.length) (resourceSpace bits.length) := by + convert! hprogram using 1 + unfold stepCount + ring + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hprogram' + have hspace' : space ≀ spaceBound bits.length := by + rw [← envelopeSpace_eq_spaceBound] + exact hspace + refine ⟨finalStore loopFinal, cost, space, hexec, hcost, hspace', ?_⟩ + have hcount' : loopFinal 1 = weight bits := by + simpa [countReg] using hcount + simp [finalStore, Basic.exec, hcount', lengthReg, countReg, oneReg] + +end Hamming + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal.lean new file mode 100644 index 0000000000..5e74f07eb3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import Mathlib.Algebra.Order.Group.Nat +public import Mathlib.Algebra.Order.Sub.Basic + +/-! +# Structured logarithmic-cost RAM programs β€” proof internals + +This file proves that absolute-jump lowering preserves the independent source +semantics exactly: final registers, logarithmic cost, and peak register space. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Cmd + +theorem length_compileAt (cmd : Cmd) (start : β„•) : + (cmd.compileAt start).length = cmd.codeSize := by + induction cmd generalizing start with + | skip => rfl + | basic op => rfl + | seq first second ihFirst ihSecond => + simp only [compileAt, List.length_append, ihFirst, ihSecond, codeSize] + | ifZero test onZero onNonzero ihZero ihNonzero => + simp only [compileAt, List.length_append, List.length_cons, List.length_nil, + ihZero, ihNonzero, codeSize] + omega + | whileNonzero test body ih => + simp only [compileAt, List.length_append, List.length_cons, List.length_nil, + ih, codeSize] + omega + +end Cmd + +private theorem curInstr_append_head (pre suffix : Program) (instr : Instr) + (regs : Store) : + curInstr (pre ++ instr :: suffix) { pc := pre.length, regs := regs } = instr := by + simp [curInstr] + +private theorem not_halted_append_head (pre suffix : Program) (op : Basic) + (regs : Store) : + Β¬Halted (pre ++ op.instr :: suffix) { pc := pre.length, regs := regs } := by + simp [Halted, curInstr_append_head] + cases op <;> simp [Basic.instr] + +private theorem not_halted_jz (pre suffix : Program) (test target : β„•) + (regs : Store) : + Β¬Halted (pre ++ Instr.jz test target :: suffix) + { pc := pre.length, regs := regs } := by + simp [Halted, curInstr_append_head] + +private theorem not_halted_jmp (pre suffix : Program) (target : β„•) + (regs : Store) : + Β¬Halted (pre ++ Instr.jmp target :: suffix) + { pc := pre.length, regs := regs } := by + simp [Halted, curInstr_append_head] + +private theorem cfg_space_eq_store_space (pc : β„•) (regs : Store) : + (Cfg.mk pc regs).space = regs.space := rfl + +private theorem step_basic (pre suffix : Program) (op : Basic) (regs : Store) : + step (pre ++ op.instr :: suffix) { pc := pre.length, regs := regs } = + { pc := pre.length + 1, regs := op.exec regs } := by + unfold step + rw [curInstr_append_head] + cases op <;> simp [Basic.instr, Basic.exec, stepInstr] + +private theorem step_jz_zero (pre suffix : Program) (test target : β„•) + (regs : Store) (htest : regs test = 0) : + step (pre ++ Instr.jz test target :: suffix) + { pc := pre.length, regs := regs } = + { pc := target, regs := regs } := by + unfold step + rw [curInstr_append_head] + simp [stepInstr, htest] + +private theorem step_jz_nonzero (pre suffix : Program) (test target : β„•) + (regs : Store) (htest : regs test β‰  0) : + step (pre ++ Instr.jz test target :: suffix) + { pc := pre.length, regs := regs } = + { pc := pre.length + 1, regs := regs } := by + unfold step + rw [curInstr_append_head] + simp [stepInstr, htest] + +private theorem step_jmp (pre suffix : Program) (target : β„•) (regs : Store) : + step (pre ++ Instr.jmp target :: suffix) + { pc := pre.length, regs := regs } = + { pc := target, regs := regs } := by + unfold step + rw [curInstr_append_head] + rfl + +private theorem space_le_spaceUpto (P : Program) (fuel : β„•) (cfg : Cfg) : + cfg.space ≀ spaceUpto P fuel cfg := by + cases fuel with + | zero => rfl + | succ fuel => + simp only [spaceUpto] + split + Β· rfl + Β· exact le_max_left _ _ + +private theorem spaceUpto_halted (P : Program) {cfg : Cfg} + (hhalt : Halted P cfg) (fuel : β„•) : spaceUpto P fuel cfg = cfg.space := by + cases fuel with + | zero => rfl + | succ fuel => simp [spaceUpto, hhalt] + +private theorem spaceUpto_add (P : Program) (first second : β„•) (cfg : Cfg) : + spaceUpto P (first + second) cfg = + max (spaceUpto P first cfg) (spaceUpto P second (run P first cfg)) := by + induction first generalizing cfg with + | zero => + simp only [Nat.zero_add, spaceUpto, run_zero] + exact (max_eq_right (space_le_spaceUpto P second cfg)).symm + | succ first ih => + rw [Nat.succ_add] + simp only [spaceUpto, run_succ] + by_cases hhalt : Halted P cfg + Β· simp [hhalt, spaceUpto_halted P hhalt] + Β· simp only [ite_eq_right hhalt, ih] + omega + +private theorem run_space_le_spaceUpto (P : Program) (fuel : β„•) (cfg : Cfg) : + (run P fuel cfg).space ≀ spaceUpto P fuel cfg := by + have hsplit := spaceUpto_add P fuel 0 cfg + simp only [Nat.add_zero, spaceUpto] at hsplit + calc + (run P fuel cfg).space ≀ + max (spaceUpto P fuel cfg) (run P fuel cfg).space := le_max_right _ _ + _ = spaceUpto P fuel cfg := hsplit.symm + +/-- Compilation preserves the nonzero conditional branch, including its exit jump cost. -/ +private theorem compileAt_ifNonzero_correct + {test : β„•} {onZero onNonzero : Cmd} {store final : Store} + {branchSteps branchCost branchSpace : β„•} + (htest : store test β‰  0) + (ih : βˆ€ (pre suffix : Program), + let P := pre ++ onNonzero.compileAt pre.length ++ suffix + let start : Cfg := { pc := pre.length, regs := store } + run P branchSteps start = + { pc := pre.length + onNonzero.codeSize, regs := final } ∧ + logTimeUpto P branchSteps start = branchCost ∧ + spaceUpto P branchSteps start = branchSpace) + (pre suffix : Program) : + let cmd := Cmd.ifZero test onZero onNonzero + let P := pre ++ cmd.compileAt pre.length ++ suffix + let start : Cfg := { pc := pre.length, regs := store } + run P (branchSteps + 2) start = + { pc := pre.length + cmd.codeSize, regs := final } ∧ + logTimeUpto P (branchSteps + 2) start = + bitlen (store test) + 1 + branchCost + 1 ∧ + spaceUpto P (branchSteps + 2) start = max store.space branchSpace := by + dsimp only + simp only [Cmd.compileAt, Cmd.codeSize] + let zeroStart := pre.length + 1 + onNonzero.codeSize + 1 + let done := pre.length + (2 + onZero.codeSize + onNonzero.codeSize) + let nonzeroPre := pre ++ [Instr.jz test zeroStart] + have hNonzeroPre : nonzeroPre.length = pre.length + 1 := by + simp [nonzeroPre] + have hbranchRun := ih nonzeroPre + (Instr.jmp done :: onZero.compileAt zeroStart ++ suffix) + simp only [hNonzeroPre] at hbranchRun + dsimp only [nonzeroPre, zeroStart, done] at hbranchRun ⊒ + simp only [List.nil_append, List.cons_append, List.append_assoc] + at hbranchRun ⊒ + let jmpPre := pre ++ + [Instr.jz test (pre.length + 1 + onNonzero.codeSize + 1)] ++ + onNonzero.compileAt (pre.length + 1) + have hjmp := step_jmp jmpPre + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix) + (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) final + dsimp only [jmpPre] at hjmp + have hjmp' : + step + (pre ++ Instr.jz test (pre.length + 1 + onNonzero.codeSize + 1) :: + (onNonzero.compileAt (pre.length + 1) ++ + Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) :: + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix))) + { pc := pre.length + 1 + onNonzero.codeSize, regs := final } = + { pc := pre.length + (2 + onZero.codeSize + onNonzero.codeSize), + regs := final } := by + simpa [Cmd.length_compileAt, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hjmp + have hjmpInstr := curInstr_append_head jmpPre + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix) + (Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize))) final + dsimp only [jmpPre] at hjmpInstr + have hjmpInstr' : + curInstr + (pre ++ Instr.jz test (pre.length + 1 + onNonzero.codeSize + 1) :: + (onNonzero.compileAt (pre.length + 1) ++ + Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) :: + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix))) + { pc := pre.length + 1 + onNonzero.codeSize, regs := final } = + Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) := by + simpa [Cmd.length_compileAt, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hjmpInstr + have hjmpHalt : + Β¬Halted + (pre ++ Instr.jz test (pre.length + 1 + onNonzero.codeSize + 1) :: + (onNonzero.compileAt (pre.length + 1) ++ + Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) :: + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix))) + { pc := pre.length + 1 + onNonzero.codeSize, regs := final } := by + simp [Halted, hjmpInstr'] + rw [run_succ, logTimeUpto_succ] + simp [Halted, curInstr] + rw [step_jz_nonzero pre _ test _ store htest] + rw [run_succ_step, hbranchRun.1] + rw [hjmp'] + rw [logTimeUpto_add _ branchSteps 1] + rw [hbranchRun.2.1, hbranchRun.1] + rw [show (1 : β„•) = 0 + 1 from rfl, logTimeUpto_succ] + rw [ite_eq_right hjmpHalt] + simp [stepLogCost, hjmpInstr', Instr.logCost] + rw [spaceUpto] + simp [Halted, curInstr] + rw [step_jz_nonzero pre _ test _ store htest] + rw [spaceUpto_add _ branchSteps 1, hbranchRun.2.2, hbranchRun.1] + rw [show (1 : β„•) = 0 + 1 from rfl, spaceUpto] + rw [ite_eq_right hjmpHalt, hjmp'] + simp only [spaceUpto] + have hfinalSpace : final.space ≀ branchSpace := by + have hrunSpace := run_space_le_spaceUpto + (pre ++ Instr.jz test (pre.length + 1 + onNonzero.codeSize + 1) :: + (onNonzero.compileAt (pre.length + 1) ++ + Instr.jmp (pre.length + (2 + onZero.codeSize + onNonzero.codeSize)) :: + (onZero.compileAt (pre.length + 1 + onNonzero.codeSize + 1) ++ suffix))) + branchSteps { pc := pre.length + 1, regs := store } + rw [hbranchRun.1, hbranchRun.2.2] at hrunSpace + simpa [Store.space, Cfg.space] using hrunSpace + constructor + Β· omega + Β· change max store.space (max branchSpace (max final.space final.space)) = + max store.space branchSpace + rw [max_self, max_eq_left hfinalSpace] + +theorem compileAt_correct_internal + {cmd : Cmd} {initial final : Store} {steps cost space : β„•} + (hexec : Exec cmd initial final steps cost space) + (pre suffix : Program) : + let P := pre ++ cmd.compileAt pre.length ++ suffix + let start : Cfg := { pc := pre.length, regs := initial } + run P steps start = + { pc := pre.length + cmd.codeSize, regs := final } ∧ + logTimeUpto P steps start = cost ∧ + spaceUpto P steps start = space := by + dsimp only + induction hexec generalizing pre suffix with + | skip store => + simp [Cmd.compileAt, Cmd.codeSize, spaceUpto, Store.space, Cfg.space] + | basic op store => + simp only [Cmd.compileAt, Cmd.codeSize, List.singleton_append, + List.append_assoc] + have hhalt := not_halted_append_head pre suffix op store + rw [run_one, step_basic] + constructor + Β· rfl + constructor + Β· simp [logTimeUpto, hhalt, Basic.logCost, stepLogCost, + curInstr_append_head] + cases op <;> rfl + Β· simp [spaceUpto, hhalt, step_basic, Store.space, Cfg.space] + | seq hfirst hsecond ihFirst ihSecond => + rename_i firstCmd secondCmd store middle final firstSteps secondSteps firstCost + secondCost firstSpace secondSpace + simp only [Cmd.compileAt, Cmd.codeSize] + let secondPre := pre ++ Cmd.compileAt pre.length firstCmd + have hSecondPre : secondPre.length = pre.length + firstCmd.codeSize := by + simp [secondPre, Cmd.length_compileAt] + have hfirstRun := + ihFirst pre (Cmd.compileAt (pre.length + firstCmd.codeSize) secondCmd ++ suffix) + have hsecondRun := ihSecond secondPre suffix + simp only [secondPre, hSecondPre] at hsecondRun + simp only [List.append_assoc] at hfirstRun hsecondRun ⊒ + rw [run_add, logTimeUpto_add, spaceUpto_add] + rw [hfirstRun.1, hfirstRun.2.1, hfirstRun.2.2] + rw [hsecondRun.1, hsecondRun.2.1, hsecondRun.2.2] + simp [Nat.add_assoc] + | ifZero htest hbranch ih => + rename_i test onZero onNonzero store final branchSteps branchCost branchSpace + simp only [Cmd.compileAt, Cmd.codeSize] + let zeroStart := pre.length + 1 + onNonzero.codeSize + 1 + let done := pre.length + (2 + onZero.codeSize + onNonzero.codeSize) + let zeroPre := pre ++ [Instr.jz test zeroStart] ++ + onNonzero.compileAt (pre.length + 1) ++ [Instr.jmp done] + have hZeroPre : zeroPre.length = zeroStart := by + simp [zeroPre, zeroStart, Cmd.length_compileAt] + omega + have hbranchRun := ih zeroPre suffix + simp only [hZeroPre] at hbranchRun + dsimp only [zeroPre, zeroStart, done] at hbranchRun ⊒ + simp only [List.nil_append, List.cons_append, List.append_assoc] + at hbranchRun ⊒ + rw [run_succ, logTimeUpto_succ] + simp [Halted, curInstr] + rw [step_jz_zero pre _ test _ store htest] + rw [spaceUpto] + simp [Halted, curInstr] + rw [step_jz_zero pre _ test _ store htest] + rw [hbranchRun.1, hbranchRun.2.1, hbranchRun.2.2] + simp [stepLogCost, curInstr_append_head, Instr.logCost, Store.space, + Cfg.space, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + all_goals omega + | ifNonzero htest hbranch ih => + exact compileAt_ifNonzero_correct htest ih pre suffix + | whileZero htest => + rename_i test body store + simp only [Cmd.compileAt, Cmd.codeSize, List.cons_append, List.append_assoc] + rw [run_one] + rw [step_jz_zero pre _ test _ store htest] + constructor + Β· rfl + constructor + Β· simp [logTimeUpto, Halted, curInstr, stepLogCost, Instr.logCost, + Nat.add_comm] + Β· simp [spaceUpto, Halted, curInstr, + step_jz_zero pre _ test _ store htest, Store.space, Cfg.space] + | whileNonzero htest hbody hloop ihBody ihLoop => + rename_i test body store middle final bodySteps loopSteps bodyCost loopCost + bodySpace loopSpace + simp only [Cmd.compileAt, Cmd.codeSize] + let done := pre.length + (body.codeSize + 2) + let bodyPre := pre ++ [Instr.jz test done] + have hBodyPre : bodyPre.length = pre.length + 1 := by + simp [bodyPre] + have hbodyRun := ihBody bodyPre (Instr.jmp pre.length :: suffix) + simp only [hBodyPre] at hbodyRun + have hloopRun := ihLoop pre suffix + simp only [Cmd.compileAt, Cmd.codeSize] at hloopRun + dsimp only [bodyPre, done] at hbodyRun hloopRun ⊒ + simp only [List.nil_append, List.cons_append, List.append_assoc] + at hbodyRun hloopRun ⊒ + let jmpPre := pre ++ [Instr.jz test (pre.length + (body.codeSize + 2))] ++ + body.compileAt (pre.length + 1) + have hjmp := step_jmp jmpPre suffix pre.length middle + dsimp only [jmpPre] at hjmp + have hjmp' : + step + (pre ++ Instr.jz test (pre.length + (body.codeSize + 2)) :: + (body.compileAt (pre.length + 1) ++ Instr.jmp pre.length :: suffix)) + { pc := pre.length + 1 + body.codeSize, regs := middle } = + { pc := pre.length, regs := middle } := by + simpa [Cmd.length_compileAt, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hjmp + have hjmpInstr := curInstr_append_head jmpPre suffix + (Instr.jmp pre.length) middle + dsimp only [jmpPre] at hjmpInstr + have hjmpInstr' : + curInstr + (pre ++ Instr.jz test (pre.length + (body.codeSize + 2)) :: + (body.compileAt (pre.length + 1) ++ Instr.jmp pre.length :: suffix)) + { pc := pre.length + 1 + body.codeSize, regs := middle } = + Instr.jmp pre.length := by + simpa [Cmd.length_compileAt, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hjmpInstr + have hjmpHalt : + Β¬Halted + (pre ++ Instr.jz test (pre.length + (body.codeSize + 2)) :: + (body.compileAt (pre.length + 1) ++ Instr.jmp pre.length :: suffix)) + { pc := pre.length + 1 + body.codeSize, regs := middle } := by + simp [Halted, hjmpInstr'] + rw [run_succ, logTimeUpto_succ] + simp [Halted, curInstr] + rw [step_jz_nonzero pre _ test _ store htest] + rw [show bodySteps + loopSteps + 1 = bodySteps + (loopSteps + 1) by omega] + rw [run_add, hbodyRun.1] + rw [run_succ] + simp only [ite_eq_right hjmpHalt] + rw [hjmp', hloopRun.1] + rw [logTimeUpto_add _ bodySteps (loopSteps + 1)] + rw [hbodyRun.2.1, hbodyRun.1] + rw [logTimeUpto_succ, ite_eq_right hjmpHalt] + rw [hjmp', hloopRun.2.1] + simp [stepLogCost, hjmpInstr', Instr.logCost] + rw [spaceUpto] + simp [Halted, curInstr] + rw [step_jz_nonzero pre _ test _ store htest] + rw [show bodySteps + loopSteps + 1 = bodySteps + (loopSteps + 1) by omega] + rw [spaceUpto_add _ bodySteps (loopSteps + 1)] + rw [hbodyRun.2.2, hbodyRun.1] + rw [spaceUpto, ite_eq_right hjmpHalt, hjmp', hloopRun.2.2] + have hinitialSpace : store.space ≀ bodySpace := by + have hstart := space_le_spaceUpto + (pre ++ Instr.jz test (pre.length + (body.codeSize + 2)) :: + (body.compileAt (pre.length + 1) ++ Instr.jmp pre.length :: suffix)) + bodySteps { pc := pre.length + 1, regs := store } + rw [hbodyRun.2.2] at hstart + simpa [Store.space, Cfg.space] using hstart + have hmiddleSpace : middle.space ≀ bodySpace := by + have hend := run_space_le_spaceUpto + (pre ++ Instr.jz test (pre.length + (body.codeSize + 2)) :: + (body.compileAt (pre.length + 1) ++ Instr.jmp pre.length :: suffix)) + bodySteps { pc := pre.length + 1, regs := store } + rw [hbodyRun.1, hbodyRun.2.2] at hend + simpa [Store.space, Cfg.space] using hend + constructor + Β· omega + Β· change max store.space (max bodySpace (max middle.space loopSpace)) = + max bodySpace loopSpace + rw [max_eq_right (hinitialSpace.trans (le_max_left _ _)), ← max_assoc, + max_eq_left hmiddleSpace] + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal/Resources.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal/Resources.lean new file mode 100644 index 0000000000..6dbf2d3149 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Internal/Resources.lean @@ -0,0 +1,579 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Algebra.Order.Ring.Nat +public import Mathlib.Data.Nat.Size +public import Mathlib.Tactic.Ring.RingNF + +/-! +# Resource-proof infrastructure for structured RAM programs + +This internal module packages the generic proof obligations that arise when a +structured program is verified against the concrete logarithmic-cost RAM: +finite register envelopes, their induced `finsum` space bounds, and compositional +source executions carrying exact steps with upper bounds on time and space. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Internal + +/-- A register store fits an index/value envelope. Every nonzero register lies +below `indexBound`, and every stored value is at most `valueBound`. -/ +structure StoreEnvelope (indexBound valueBound : β„•) (store : Store) : Prop where + index_lt : βˆ€ index, store index β‰  0 β†’ index < indexBound + value_le : βˆ€ index, store index ≀ valueBound + +/-- Enlarging either side of a store envelope preserves the bound. -/ +theorem StoreEnvelope.mono {indexBound valueBound largerIndex largerValue : β„•} + {store : Store} (hstore : StoreEnvelope indexBound valueBound store) + (hindex : indexBound ≀ largerIndex) (hvalue : valueBound ≀ largerValue) : + StoreEnvelope largerIndex largerValue store where + index_lt index hnonzero := lt_of_lt_of_le (hstore.index_lt index hnonzero) hindex + value_le index := le_trans (hstore.value_le index) hvalue + +/-- A reserved-prefix bit input fits any envelope containing its length register, +input interval, list length, and Boolean values. -/ +theorem Input.bitStoreEnvelope {lengthReg inputBase indexBound valueBound : β„•} + (bits : List Bool) (hlengthReg : lengthReg < indexBound) + (hinputEnd : inputBase + bits.length ≀ indexBound) + (hlength : bits.length ≀ valueBound) (hone : 1 ≀ valueBound) : + StoreEnvelope indexBound valueBound (Input.bitStore lengthReg inputBase bits) := by + constructor + Β· intro index hnonzero + simp only [Input.bitStore] at hnonzero + split at hnonzero + Β· subst index + exact hlengthReg + Β· rename_i hlengthRegNe + split at hnonzero + Β· rename_i hbase + split at hnonzero + Β· rename_i bit hbit + have hoffset : index - inputBase < bits.length := + List.getElem?_eq_some_iff.mp hbit |>.1 + have hrecover : inputBase + (index - inputBase) = index := + Nat.add_sub_of_le hbase + omega + Β· simp at hnonzero + Β· simp at hnonzero + Β· intro index + by_cases hlengthRegEq : index = lengthReg + Β· simpa [Input.bitStore, hlengthRegEq] using hlength + Β· rw [Input.bitStore, ite_eq_right hlengthRegEq] + by_cases hbase : inputBase ≀ index + Β· rw [ite_eq_left hbase] + cases hlookup : bits[index - inputBase]? with + | none => simp + | some bit => + cases bit + Β· simp [Input.bitValue] + Β· simpa [Input.bitValue] using hone + Β· simp [hbase] + +/-- Logarithmic space occupied by the largest store admitted by an envelope. -/ +def envelopeSpace (indexBound valueBound : β„•) : β„• := + indexBound * (bitlen indexBound + bitlen valueBound) + +/-- A store envelope bounds the real finite-sum source-space measure. -/ +theorem StoreEnvelope.space_le {indexBound valueBound : β„•} {store : Store} + (hstore : StoreEnvelope indexBound valueBound store) : + store.space ≀ envelopeSpace indexBound valueBound := by + rw [Store.space, envelopeSpace, + finsum_eq_finsetSum_of_support_subset (s := Finset.range indexBound)] + Β· calc + βˆ‘ index ∈ Finset.range indexBound, + (if store index = 0 then 0 else bitlen index + bitlen (store index)) + ≀ βˆ‘ _index ∈ Finset.range indexBound, + (bitlen indexBound + bitlen valueBound) := by + apply Finset.sum_le_sum + intro index hindex + split_ifs with hzero + Β· simp + Β· have hindexLe : index ≀ indexBound := by + exact Nat.le_of_lt (Finset.mem_range.mp hindex) + have hindexSize := Nat.size_le_size hindexLe + have hvalueSize := Nat.size_le_size (hstore.value_le index) + simpa [bitlen] using Nat.add_le_add hindexSize hvalueSize + _ = indexBound * (bitlen indexBound + bitlen valueBound) := by simp + Β· intro index hsupport + by_contra hindex + have hstoreZero : store index = 0 := by + by_contra hnonzero + exact hindex (Finset.mem_range.mpr (hstore.index_lt index hnonzero)) + simp [hstoreZero] at hsupport + +/-- Updating an in-envelope register with an in-envelope value preserves the +store envelope. -/ +theorem StoreEnvelope.update {indexBound valueBound index value : β„•} + {store : Store} (hstore : StoreEnvelope indexBound valueBound store) + (hindex : index < indexBound) (hvalue : value ≀ valueBound) : + StoreEnvelope indexBound valueBound (Function.update store index value) := by + constructor + Β· intro candidate hnonzero + by_cases heq : candidate = index + Β· simpa [heq] using hindex + Β· exact hstore.index_lt candidate + (by simpa [Function.update_of_ne heq] using hnonzero) + Β· intro candidate + by_cases heq : candidate = index + Β· subst candidate + simpa using hvalue + Β· simpa [Function.update_of_ne heq] using hstore.value_le candidate + +namespace Basic + +/-- Register written by a basic instruction in a given store. The store argument +is relevant only for indirect writes. -/ +@[simp] +def writeIndex : Structured.Basic β†’ Store β†’ β„• + | .imm dst _, _ | .add dst _ _, _ | .sub dst _ _, _ | .mul dst _ _, _ | + .load dst _, _ => dst + | .store address _, store => store address + +/-- Value written by a basic instruction in a given store. -/ +@[simp] +def writeValue : Structured.Basic β†’ Store β†’ β„• + | .imm _ value, _ => value + | .add _ left right, store => store left + store right + | .sub _ left right, store => store left - store right + | .mul _ left right, store => store left * store right + | .load _ address, store => store (store address) + | .store _ src, store => store src + +/-- Basic execution is a single functional update, uniformly across direct and +indirect instructions. -/ +theorem exec_eq_update (op : Structured.Basic) (store : Store) : + op.exec store = Function.update store (writeIndex op store) (writeValue op store) := by + cases op <;> rfl + +/-- A concrete straight-line execution stays inside one store envelope at its +initial store and after every instruction. Unlike a uniform preservation +condition, this certificate can use semantic facts about the actual store at +each program point. -/ +def EnvelopeChain (indexBound valueBound : β„•) : List Structured.Basic β†’ Store β†’ Prop + | [], store => StoreEnvelope indexBound valueBound store + | op :: rest, store => + StoreEnvelope indexBound valueBound store ∧ + EnvelopeChain indexBound valueBound rest (op.exec store) + +theorem EnvelopeChain.append {indexBound valueBound : β„•} + {first second : List Structured.Basic} {store : Store} + (hfirst : EnvelopeChain indexBound valueBound first store) + (hsecond : EnvelopeChain indexBound valueBound second + (Structured.Basic.execList first store)) : + EnvelopeChain indexBound valueBound (first ++ second) store := by + induction first generalizing store with + | nil => simpa [Structured.Basic.execList] using hsecond + | cons op rest ih => + exact ⟨hfirst.1, ih hfirst.2 hsecond⟩ + +theorem EnvelopeChain.final {indexBound valueBound : β„•} + {ops : List Structured.Basic} {store : Store} + (hchain : EnvelopeChain indexBound valueBound ops store) : + StoreEnvelope indexBound valueBound (Structured.Basic.execList ops store) := by + induction ops generalizing store with + | nil => exact hchain + | cons op rest ih => exact ih hchain.2 + +end Basic + +/-- A basic instruction preserves an envelope when its destination and written +value fit that envelope. -/ +theorem StoreEnvelope.execBasic {indexBound valueBound : β„•} + {store : Store} (hstore : StoreEnvelope indexBound valueBound store) + (op : Structured.Basic) (hindex : Basic.writeIndex op store < indexBound) + (hvalue : Basic.writeValue op store ≀ valueBound) : + StoreEnvelope indexBound valueBound (op.exec store) := by + rw [Basic.exec_eq_update] + exact hstore.update hindex hvalue + +/-- A straight-line list of immediate writes preserves a register whose index +does not occur among the destinations. -/ +theorem Basic.execList_imm_apply_of_not_mem (writes : List (β„• Γ— β„•)) + (store : Store) (index : β„•) (hnot : index βˆ‰ writes.map Prod.fst) : + Basic.execList (writes.map fun write => Basic.imm write.1 write.2) store index = + store index := by + induction writes generalizing store with + | nil => rfl + | cons write rest ih => + have hne : index β‰  write.1 := by + simpa using fun heq => hnot (by simp [heq]) + have htail : index βˆ‰ rest.map Prod.fst := by + intro hmem + exact hnot (by simp [hmem]) + rw [List.map_cons, Basic.execList, ih _ htail] + simp [Basic.exec, Function.update_of_ne hne] + +/-- With distinct destinations, a listed immediate write determines the final +value at its destination. -/ +theorem Basic.execList_imm_apply_of_mem (writes : List (β„• Γ— β„•)) + (store : Store) (hnodup : (writes.map Prod.fst).Nodup) + {index value : β„•} (hmem : (index, value) ∈ writes) : + Basic.execList (writes.map fun write => Basic.imm write.1 write.2) store index = + value := by + induction writes generalizing store with + | nil => simp at hmem + | cons write rest ih => + obtain ⟨hhead, htail⟩ := List.nodup_cons.mp hnodup + rw [List.map_cons, Basic.execList] + rcases List.mem_cons.mp hmem with heq | hrest + Β· subst write + rw [Basic.execList_imm_apply_of_not_mem rest] + Β· simp [Basic.exec] + Β· simpa using hhead + Β· exact ih (store := (Basic.imm write.1 write.2).exec store) htail hrest + +/-- A one-bit cushion over the width of the envelope's largest value. -/ +def valueWidth (valueBound : β„•) : β„• := bitlen valueBound + 1 + +theorem bitlen_le_valueWidth {valueBound value : β„•} (hvalue : value ≀ valueBound) : + bitlen value ≀ valueWidth valueBound := by + have hsize := Nat.size_le_size hvalue + simpa [bitlen, valueWidth] using le_trans hsize (Nat.le_add_right _ _) + +theorem one_le_valueWidth (valueBound : β„•) : 1 ≀ valueWidth valueBound := by + simp [valueWidth] + +/-- Any basic instruction whose pre- and post-stores fit the same envelope has +logarithmic cost at most four times the envelope value width. -/ +theorem Basic.logCost_le_four_valueWidth {indexBound valueBound : β„•} + (op : Basic) (store : Store) + (hstore : StoreEnvelope indexBound valueBound store) + (hnext : StoreEnvelope indexBound valueBound (op.exec store)) : + op.logCost store ≀ 4 * valueWidth valueBound := by + have hone := one_le_valueWidth valueBound + cases op with + | imm dst value => + have hvalue : value ≀ valueBound := by + simpa [Basic.exec] using hnext.value_le dst + have hvalueWidth := bitlen_le_valueWidth hvalue + simp only [Basic.logCost] + omega + | add dst left right => + have hleftWidth := bitlen_le_valueWidth (hstore.value_le left) + have hrightWidth := bitlen_le_valueWidth (hstore.value_le right) + have hresult : store left + store right ≀ valueBound := by + simpa [Basic.exec] using hnext.value_le dst + have hresultWidth := bitlen_le_valueWidth hresult + simp only [Basic.logCost] + omega + | sub dst left right => + have hleftWidth := bitlen_le_valueWidth (hstore.value_le left) + have hrightWidth := bitlen_le_valueWidth (hstore.value_le right) + simp only [Basic.logCost] + omega + | mul dst left right => + have hleftWidth := bitlen_le_valueWidth (hstore.value_le left) + have hrightWidth := bitlen_le_valueWidth (hstore.value_le right) + have hresult : store left * store right ≀ valueBound := by + simpa [Basic.exec] using hnext.value_le dst + have hresultWidth := bitlen_le_valueWidth hresult + simp only [Basic.logCost] + omega + | load dst address => + have haddressWidth := bitlen_le_valueWidth (hstore.value_le address) + have hvalueWidth := bitlen_le_valueWidth (hstore.value_le (store address)) + simp only [Basic.logCost] + omega + | store address src => + have haddressWidth := bitlen_le_valueWidth (hstore.value_le address) + have hsourceWidth := bitlen_le_valueWidth (hstore.value_le src) + simp only [Basic.logCost] + omega + +/-- A source execution with an exact transition count and upper bounds on its +logarithmic cost and peak space. -/ +def MeasuredRuns (cmd : Cmd) (initial final : Store) + (steps costBound spaceLimit : β„•) : Prop := + βˆƒ cost space, Exec cmd initial final steps cost space ∧ + cost ≀ costBound ∧ space ≀ spaceLimit + +/-- A straight-line basic block always has an exact source execution. This +certificate deliberately leaves cost and space existential, allowing semantic +proofs to proceed before a client chooses a resource envelope. -/ +theorem exec_basics_exists (ops : List Basic) (initial : Store) : + βˆƒ cost space, + Exec (Cmd.basics ops) initial (Basic.execList ops initial) + ops.length cost space := by + induction ops generalizing initial with + | nil => + exact ⟨0, initial.space, by + simpa only [Cmd.basics, List.map_nil, Cmd.seqList, Basic.execList, + List.length_nil] using Exec.skip initial⟩ + | cons op rest ih => + cases rest with + | nil => + exact ⟨op.logCost initial, + max initial.space (op.exec initial).space, by + simpa [Cmd.basics, Cmd.seqList, Basic.execList] using Exec.basic op initial⟩ + | cons next tail => + obtain ⟨cost, space, hrest⟩ := ih (initial := op.exec initial) + refine ⟨op.logCost initial + cost, + max (max initial.space (op.exec initial).space) space, ?_⟩ + have hrun := Exec.seq (Exec.basic op initial) hrest + convert hrun using 1 <;> simp [Cmd.basics, Cmd.seqList, Basic.execList] <;> omega + +namespace MeasuredRuns + +theorem skipEnvelope {indexBound valueBound : β„•} {store : Store} + (hstore : StoreEnvelope indexBound valueBound store) : + MeasuredRuns Cmd.skip store store 0 0 (envelopeSpace indexBound valueBound) := by + exact ⟨0, store.space, Exec.skip store, le_rfl, hstore.space_le⟩ + +theorem basicEnvelope {indexBound valueBound : β„•} (op : Basic) (store : Store) + (hstore : StoreEnvelope indexBound valueBound store) + (hnext : StoreEnvelope indexBound valueBound (op.exec store)) : + MeasuredRuns (.basic op) store (op.exec store) 1 (4 * valueWidth valueBound) + (envelopeSpace indexBound valueBound) := by + exact ⟨op.logCost store, max store.space (op.exec store).space, + Exec.basic op store, Basic.logCost_le_four_valueWidth op store hstore hnext, + max_le hstore.space_le hnext.space_le⟩ + +theorem seq {first second : Cmd} {initial middle final : Store} + {firstSteps secondSteps firstCost secondCost spaceLimit : β„•} + (hfirst : MeasuredRuns first initial middle firstSteps firstCost spaceLimit) + (hsecond : MeasuredRuns second middle final secondSteps secondCost spaceLimit) : + MeasuredRuns (.seq first second) initial final (firstSteps + secondSteps) + (firstCost + secondCost) spaceLimit := by + obtain ⟨cost₁, space₁, hexec₁, hcost₁, hspaceβ‚βŸ© := hfirst + obtain ⟨costβ‚‚, spaceβ‚‚, hexecβ‚‚, hcostβ‚‚, hspaceβ‚‚βŸ© := hsecond + exact ⟨cost₁ + costβ‚‚, max space₁ spaceβ‚‚, Exec.seq hexec₁ hexecβ‚‚, + Nat.add_le_add hcost₁ hcostβ‚‚, max_le hspace₁ hspaceβ‚‚βŸ© + +/-- A straight-line list of basic instructions inherits uniform resource bounds +when every listed instruction preserves the chosen store envelope. -/ +theorem basicsEnvelope {indexBound valueBound : β„•} (ops : List Basic) + (initial : Store) (hinitial : StoreEnvelope indexBound valueBound initial) + (hpreserve : βˆ€ op, op ∈ ops β†’ βˆ€ store, + StoreEnvelope indexBound valueBound store β†’ + StoreEnvelope indexBound valueBound (op.exec store)) : + MeasuredRuns (Cmd.basics ops) initial (Basic.execList ops initial) + ops.length (4 * ops.length * valueWidth valueBound) + (envelopeSpace indexBound valueBound) ∧ + StoreEnvelope indexBound valueBound (Basic.execList ops initial) := by + induction ops generalizing initial with + | nil => + exact ⟨by simpa [Cmd.basics, Cmd.seqList, Basic.execList] using skipEnvelope hinitial, + hinitial⟩ + | cons op rest ih => + have hnext := hpreserve op (by simp) initial hinitial + have hfirst := basicEnvelope op initial hinitial hnext + cases rest with + | nil => + exact ⟨by simpa [Cmd.basics, Cmd.seqList, Basic.execList] using hfirst, hnext⟩ + | cons next tail => + obtain ⟨hrest, hfinal⟩ := ih (initial := op.exec initial) hnext (by + intro candidate hcandidate store hstore + exact hpreserve candidate (by simp [hcandidate]) store hstore) + have hrun := hfirst.seq hrest + refine ⟨?_, hfinal⟩ + Β· change MeasuredRuns (.seq (.basic op) (Cmd.basics (next :: tail))) + initial (Basic.execList (next :: tail) (op.exec initial)) + (tail.length + 2) (4 * (tail.length + 2) * valueWidth valueBound) + (envelopeSpace indexBound valueBound) + convert hrun using 1 + all_goals simp + all_goals ring + +/-- A concrete per-program-point envelope chain yields the same exact-step, +uniform-cost certificate as a globally uniform preservation proof. -/ +theorem basicsEnvelopeChain {indexBound valueBound : β„•} (ops : List Basic) + (initial : Store) (hchain : Basic.EnvelopeChain indexBound valueBound ops initial) : + MeasuredRuns (Cmd.basics ops) initial (Basic.execList ops initial) + ops.length (4 * ops.length * valueWidth valueBound) + (envelopeSpace indexBound valueBound) ∧ + StoreEnvelope indexBound valueBound (Basic.execList ops initial) := by + induction ops generalizing initial with + | nil => + exact ⟨by simpa [Cmd.basics, Cmd.seqList, Basic.execList] using skipEnvelope hchain, + hchain⟩ + | cons op rest ih => + have hinitial := hchain.1 + have htail := hchain.2 + have hnext : StoreEnvelope indexBound valueBound (op.exec initial) := by + cases rest with + | nil => exact htail + | cons next tail => exact htail.1 + have hfirst := basicEnvelope op initial hinitial hnext + cases rest with + | nil => + exact ⟨by simpa [Cmd.basics, Cmd.seqList, Basic.execList] using hfirst, hnext⟩ + | cons next tail => + obtain ⟨hrest, hfinal⟩ := + ih (initial := op.exec initial) htail + have hrun := hfirst.seq hrest + refine ⟨?_, hfinal⟩ + change MeasuredRuns (.seq (.basic op) (Cmd.basics (next :: tail))) + initial (Basic.execList (next :: tail) (op.exec initial)) + (tail.length + 2) (4 * (tail.length + 2) * valueWidth valueBound) + (envelopeSpace indexBound valueBound) + convert hrun using 1 + all_goals simp + all_goals ring + +theorem weakenCost {cmd : Cmd} {initial final : Store} + {steps costBound largerBound spaceLimit : β„•} + (hrun : MeasuredRuns cmd initial final steps costBound spaceLimit) + (hle : costBound ≀ largerBound) : + MeasuredRuns cmd initial final steps largerBound spaceLimit := by + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hrun + exact ⟨cost, space, hexec, le_trans hcost hle, hspace⟩ + +theorem weakenSpace {cmd : Cmd} {initial final : Store} + {steps costBound spaceLimit largerLimit : β„•} + (hrun : MeasuredRuns cmd initial final steps costBound spaceLimit) + (hle : spaceLimit ≀ largerLimit) : + MeasuredRuns cmd initial final steps costBound largerLimit := by + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hrun + exact ⟨cost, space, hexec, hcost, le_trans hspace hle⟩ + +theorem weaken {cmd : Cmd} {initial final : Store} + {steps costBound largerCost spaceLimit largerSpace : β„•} + (hrun : MeasuredRuns cmd initial final steps costBound spaceLimit) + (hcost : costBound ≀ largerCost) (hspace : spaceLimit ≀ largerSpace) : + MeasuredRuns cmd initial final steps largerCost largerSpace := + (hrun.weakenCost hcost).weakenSpace hspace + +theorem ifZeroEnvelope {indexBound valueBound test : β„•} {onZero onNonzero : Cmd} + {initial final : Store} {steps costBound : β„•} + (htest : initial test = 0) + (hstore : StoreEnvelope indexBound valueBound initial) + (hbranch : MeasuredRuns onZero initial final steps costBound + (envelopeSpace indexBound valueBound)) : + MeasuredRuns (.ifZero test onZero onNonzero) initial final (steps + 1) + (valueWidth valueBound + costBound) (envelopeSpace indexBound valueBound) := by + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hbranch + refine ⟨bitlen (initial test) + 1 + cost, max initial.space space, + Exec.ifZero htest hexec, ?_, max_le hstore.space_le hspace⟩ + rw [htest] + have hone := one_le_valueWidth valueBound + simp only [bitlen, Nat.size_zero, zero_add] + omega + +theorem ifNonzeroEnvelope {indexBound valueBound test : β„•} {onZero onNonzero : Cmd} + {initial final : Store} {steps costBound : β„•} + (htest : initial test β‰  0) + (hstore : StoreEnvelope indexBound valueBound initial) + (hbranch : MeasuredRuns onNonzero initial final steps costBound + (envelopeSpace indexBound valueBound)) : + MeasuredRuns (.ifZero test onZero onNonzero) initial final (steps + 2) + (3 * valueWidth valueBound + costBound) + (envelopeSpace indexBound valueBound) := by + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hbranch + refine ⟨bitlen (initial test) + 1 + cost + 1, max initial.space space, + Exec.ifNonzero htest hexec, ?_, max_le hstore.space_le hspace⟩ + have htestWidth := bitlen_le_valueWidth (hstore.value_le test) + have hone := one_le_valueWidth valueBound + omega + +theorem whileZeroEnvelope {indexBound valueBound test : β„•} {body : Cmd} + {store : Store} (htest : store test = 0) + (hstore : StoreEnvelope indexBound valueBound store) : + MeasuredRuns (.whileNonzero test body) store store 1 (valueWidth valueBound) + (envelopeSpace indexBound valueBound) := by + refine ⟨bitlen (store test) + 1, store.space, Exec.whileZero htest, ?_, + hstore.space_le⟩ + rw [htest] + simpa [bitlen] using one_le_valueWidth valueBound + +theorem whileNonzeroEnvelope {indexBound valueBound test : β„•} {body : Cmd} + {initial middle final : Store} + {bodySteps loopSteps bodyCost loopCost : β„•} + (htest : initial test β‰  0) + (hstore : StoreEnvelope indexBound valueBound initial) + (hbody : MeasuredRuns body initial middle bodySteps bodyCost + (envelopeSpace indexBound valueBound)) + (hloop : MeasuredRuns (.whileNonzero test body) middle final loopSteps loopCost + (envelopeSpace indexBound valueBound)) : + MeasuredRuns (.whileNonzero test body) initial final + (bodySteps + loopSteps + 2) + (3 * valueWidth valueBound + bodyCost + loopCost) + (envelopeSpace indexBound valueBound) := by + obtain ⟨bodyActualCost, bodySpace, hbodyExec, hbodyCost, hbodySpace⟩ := hbody + obtain ⟨loopActualCost, loopSpace, hloopExec, hloopCost, hloopSpace⟩ := hloop + refine ⟨bitlen (initial test) + 1 + bodyActualCost + 1 + loopActualCost, + max bodySpace loopSpace, Exec.whileNonzero htest hbodyExec hloopExec, ?_, + max_le hbodySpace hloopSpace⟩ + have htestWidth := bitlen_le_valueWidth (hstore.value_le test) + have hone := one_le_valueWidth valueBound + omega + +/-- Exact source transition count obtained by iterating bodies with the given +per-element step count. Each nonempty iteration also pays two loop-control +transitions, and the final zero test pays one. -/ +def whileFoldSteps {Ξ± : Type*} (bodySteps : Ξ± β†’ β„•) : List Ξ± β†’ β„• + | [] => 1 + | item :: rest => bodySteps item + whileFoldSteps bodySteps rest + 2 + +/-- Compositional cost bound for a list-indexed loop. Each nonempty iteration +pays three envelope widths for its nonzero test and back edge; the final zero +test pays one envelope width. -/ +def whileFoldCost {Ξ± : Type*} (width : β„•) (bodyCost : Ξ± β†’ β„•) : List Ξ± β†’ β„• + | [] => width + | item :: rest => 3 * width + bodyCost item + whileFoldCost width bodyCost rest + +/-- Verify a structured loop by folding an abstract state over a logical input +list. The client supplies only its invariant, one body certificate, and the +zero/nonzero interpretations of the test register; run stitching and resource +accounting are generic. -/ +theorem whileFoldEnvelope {Ξ± Οƒ : Type*} {indexBound valueBound test : β„•} + {body : Cmd} (Inv : List Ξ± β†’ Οƒ β†’ Store β†’ Prop) + (advance : Οƒ β†’ Ξ± β†’ Οƒ) (bodySteps bodyCost : Ξ± β†’ β„•) + (hstore : βˆ€ (items : List Ξ±) (state : Οƒ) (store : Store), + Inv items state store β†’ StoreEnvelope indexBound valueBound store) + (hnil : βˆ€ (state : Οƒ) (store : Store), + Inv [] state store β†’ store test = 0) + (hcons : βˆ€ (item : Ξ±) (rest : List Ξ±) (state : Οƒ) (store : Store), + Inv (item :: rest) state store β†’ store test β‰  0) + (hbody : βˆ€ (item : Ξ±) (rest : List Ξ±) (state : Οƒ) (store : Store), + Inv (item :: rest) state store β†’ + βˆƒ next, + MeasuredRuns body store next (bodySteps item) (bodyCost item) + (envelopeSpace indexBound valueBound) ∧ + Inv rest (advance state item) next) + {items : List Ξ±} {state : Οƒ} {initial : Store} + (hinv : Inv items state initial) : + βˆƒ final, + MeasuredRuns (.whileNonzero test body) initial final + (whileFoldSteps bodySteps items) + (whileFoldCost (valueWidth valueBound) bodyCost items) + (envelopeSpace indexBound valueBound) ∧ + Inv [] (items.foldl advance state) final := by + induction items generalizing state initial with + | nil => + exact ⟨initial, + MeasuredRuns.whileZeroEnvelope (hnil state initial hinv) + (hstore [] state initial hinv), hinv⟩ + | cons item rest ih => + obtain ⟨middle, hrun, hnext⟩ := hbody item rest state initial hinv + obtain ⟨final, hloop, hfinal⟩ := ih hnext + refine ⟨final, ?_, ?_⟩ + Β· simpa [whileFoldSteps, whileFoldCost] using + MeasuredRuns.whileNonzeroEnvelope + (hcons item rest state initial hinv) + (hstore (item :: rest) state initial hinv) hrun hloop + Β· simpa using hfinal + +end MeasuredRuns + +end Internal + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit.lean new file mode 100644 index 0000000000..5170004dfb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.LastBit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Languages.LastBit + +/-! +# Verified structured RAM last-bit scanner + +The typed scanner compiler supplies the implementation, exact execution proof, +and resource bounds. This module adds only agreement with the existing +`Language.lastBitZero` and `Language.lastBitOne` specifications. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace LastBit + +/-- The three-state last-bit scanner takes exactly `18 + 9n` transitions. -/ +@[simp] theorem stepCount_eq (target : Bool) (inputLength : β„•) : + stepCount target inputLength = 18 + 9 * inputLength := by + rfl + +/-- Source correctness and explicit resource bounds for the last-bit scanner. -/ +theorem program_performance (target : Bool) (bits : List Bool) : + βˆƒ final cost space, + Exec (program target) (inputStore target bits) final + (stepCount target bits.length) cost space ∧ + cost ≀ timeBound target bits.length ∧ + space ≀ spaceBound target bits.length ∧ + final verdictReg = Input.bitValue (decide (bits.getLast? = some target)) := by + simpa [spec, lastBit_fold_eq_getLast?] using! + Scanner.typed_program_performance (spec target) bits + +/-- End-to-end compiled performance and language correctness. -/ +theorem compiled_performance (target : Bool) (bits : List Bool) : + βˆƒ final cost space, + Exec (program target) (inputStore target bits) final + (stepCount target bits.length) cost space ∧ + run (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits } = + { pc := (program target).codeSize, regs := final } ∧ + Halted (compiled target) + (run (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits }) ∧ + logTimeUpto (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits } ≀ timeBound target bits.length ∧ + spaceUpto (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits } ≀ spaceBound target bits.length ∧ + ((run (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits }).regs verdictReg = 1 ↔ + bits.getLast? = some target) := by + obtain ⟨final, cost, space, hexec, hrun, hhalt, htime, hspace, hresult⟩ := + Scanner.typed_compiled_performance (spec target) bits + refine ⟨final, cost, space, hexec, hrun, hhalt, htime, hspace, ?_⟩ + rw [show (run (compiled target) (stepCount target bits.length) + { pc := 0, regs := inputStore target bits }).regs verdictReg = + Input.bitValue (decide (bits.getLast? = some target)) by + simpa [spec, lastBit_fold_eq_getLast?] using! hresult] + simp [Input.bitValue] + +/-- The explicit time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear (target : Bool) : + timeBound target =O quasilinearBound target := + Scanner.typed_timeBound_bigO_quasilinear (spec target) + +/-- The explicit peak-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear (target : Bool) : + spaceBound target =O quasilinearBound target := + Scanner.typed_spaceBound_bigO_quasilinear (spec target) + +end LastBit + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit/Defs.lean new file mode 100644 index 0000000000..5bcf5358c3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/LastBit/Defs.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs + +/-! +# Structured RAM last-bit scanner β€” definitions + +This is a second consumer of the typed finite-state scanner API. Its state is +`Option Bool`: `none` before any input and `some bit` thereafter. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace LastBit + +instance optionBoolFinEnum : FinEnum (Option Bool) := + FinEnum.ofList [none, some false, some true] (by + intro state + rcases state with _ | bit + Β· simp + Β· cases bit <;> simp) + +/-- Typed scanner for whether the final input bit equals `target`. -/ +def spec (target : Bool) : Scanner.TypedSpec (Option Bool) where + initial := none + step := fun _ bit => some bit + accept := fun state => decide (state = some target) + +/-- Final verdict register inherited from the scanner layout. -/ +abbrev verdictReg : β„• := Scanner.lengthReg + +/-- Reserved-prefix input store for the last-bit scanner. -/ +abbrev inputStore (target : Bool) : List Bool β†’ Store := (spec target).inputStore + +/-- Structured RAM last-bit program. -/ +abbrev program (target : Bool) : Cmd := (spec target).program + +/-- Concrete compiled RAM last-bit program. -/ +abbrev compiled (target : Bool) : Program := (spec target).compiled + +/-- Exact compiled transition count. -/ +abbrev stepCount (target : Bool) : β„• β†’ β„• := (spec target).stepCount + +/-- Explicit logarithmic-time budget. -/ +abbrev timeBound (target : Bool) : β„• β†’ β„• := (spec target).timeBound + +/-- Explicit peak-space budget. -/ +abbrev spaceBound (target : Bool) : β„• β†’ β„• := (spec target).spaceBound + +/-- Shifted quasilinear comparison function. -/ +abbrev quasilinearBound (target : Bool) : β„• β†’ β„• := + (spec target).quasilinearBound + +end LastBit + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate.lean new file mode 100644 index 0000000000..ecf9839cab --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate + +/-! +# Verified structured RAM pair validator + +This table-driven RAM program reimplements the same five-state automaton as +`TM.pairValidateTM`. Its proof gives an exact transition count, explicit +logarithmic-cost time and peak-space budgets, and an end-to-end compiled-RAM +correctness theorem for the canonical pair-encoding language. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace PairValidate + +/-- The five-state pair validator takes exactly `24 + 9n` transitions. -/ +@[simp] theorem stepCount_eq (inputLength : β„•) : + stepCount inputLength = 24 + 9 * inputLength := by + rfl + +/-- Source-level correctness and explicit resource bounds. -/ +theorem program_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits.length) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + final lengthReg = Input.bitValue + (TM.pairValidateAccept (bits.foldl TM.pairValidateStep .next)) := + program_measured_internal bits + +/-- End-to-end compiled performance and language correctness. -/ +theorem compiled_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits.length) cost space ∧ + run compiled (stepCount bits.length) { pc := 0, regs := inputStore bits } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount bits.length) { pc := 0, regs := inputStore bits }) ∧ + logTimeUpto compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length ∧ + spaceUpto compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length ∧ + (run compiled (stepCount bits.length) { pc := 0, regs := inputStore bits }).regs + lengthReg = Input.bitValue + (TM.pairValidateAccept (bits.foldl TM.pairValidateStep .next)) ∧ + ((run compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits }).regs lengthReg = 1 ↔ + bits ∈ validPairEncoding) := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + program_performance bits + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, ?_, ?_⟩ + Β· change logTimeUpto program.compile (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto program.compile (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length + rw [hcompiled.2.2] + exact hspace + Β· change (run program.compile (stepCount bits.length) + { pc := 0, regs := inputStore bits }).regs lengthReg = _ + rw [hcompiled.1] + exact hresult + Β· change (run program.compile (stepCount bits.length) + { pc := 0, regs := inputStore bits }).regs lengthReg = 1 ↔ _ + rw [hcompiled.1] + change final lengthReg = 1 ↔ _ + rw [hresult] + calc + Input.bitValue (TM.pairValidateAccept + (bits.foldl TM.pairValidateStep .next)) = 1 ↔ + TM.pairValidateAccept (bits.foldl TM.pairValidateStep .next) = true := by + cases TM.pairValidateAccept (bits.foldl TM.pairValidateStep .next) <;> + simp [Input.bitValue] + _ ↔ (unpair? bits).isSome = true := + TM.pairValidateAccept_fold_eq_true_iff bits + _ ↔ bits ∈ validPairEncoding := Iff.rfl + +/-- The explicit logarithmic-cost time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear : timeBound =O quasilinearBound := by + exact Scanner.timeBound_bigO_quasilinear spec + +/-- The explicit peak-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear : spaceBound =O quasilinearBound := by + exact Scanner.spaceBound_bigO_quasilinear spec + +end PairValidate + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Defs.lean new file mode 100644 index 0000000000..f1bd17841c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Defs.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Defs + +/-! +# Structured RAM pair-encoding validator β€” definitions + +The benchmark-specific implementation is just a numeric presentation of the +same five-state automaton used by `TM.pairValidateTM`. The generic scanner +compiler supplies the table-driven structured RAM program. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace PairValidate + +instance : FinEnum TM.PairValidateState := + FinEnum.ofList [.next, .afterZero, .afterOne, .suffix, .invalid] (by + intro state + cases state <;> simp) + +/-- Pair validation as a typed finite-state scanner specification. -/ +def typedSpec : Scanner.TypedSpec TM.PairValidateState where + initial := .next + step := TM.pairValidateStep + accept := TM.pairValidateAccept + +/-- Numeric lowering used by the generic structured RAM compiler. -/ +abbrev spec : Scanner.Spec := typedSpec.numeric + +/-- Final verdict register inherited from the scanner layout. -/ +abbrev lengthReg : β„• := Scanner.lengthReg +/-- First input register for the five-state instance. -/ +abbrev inputBase : β„• := Scanner.inputBase spec +/-- Reserved-prefix input store for pair validation. -/ +abbrev inputStore : List Bool β†’ Store := Scanner.inputStore spec +/-- Structured RAM pair-validator program. -/ +abbrev program : Cmd := Scanner.program spec +/-- Concrete compiled RAM pair-validator program. -/ +abbrev compiled : Program := Scanner.compiled spec +/-- Exact compiled transition count. -/ +abbrev stepCount : β„• β†’ β„• := Scanner.stepCount spec +/-- Explicit logarithmic-time budget. -/ +abbrev timeBound : β„• β†’ β„• := Scanner.timeBound spec +/-- Explicit peak-space budget. -/ +abbrev spaceBound : β„• β†’ β„• := Scanner.spaceBound spec +/-- Shifted quasilinear comparison function. -/ +abbrev quasilinearBound : β„• β†’ β„• := Scanner.quasilinearBound spec + +end PairValidate + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Internal.lean new file mode 100644 index 0000000000..b391ff7ebf --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/PairValidate/Internal.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Internal + +/-! +# Structured RAM pair validator β€” proof internals + +The benchmark supplies only its typed scanner specification. State encoding, +execution, correctness, and resource proofs are all in the generic scanner layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace PairValidate + +theorem program_measured_internal (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits.length) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + final lengthReg = Input.bitValue + (TM.pairValidateAccept (bits.foldl TM.pairValidateStep .next)) := by + exact Scanner.typed_program_measured_internal typedSpec bits + +end PairValidate + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner.lean new file mode 100644 index 0000000000..dc6d669c0f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Internal +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified finite-state structured RAM scanners + +This module exposes a reusable compiler from numeric finite automata to the +structured RAM frontend. Its correctness theorem includes an exact transition +count and explicit logarithmic-time and peak-space bounds, all transferred to +the concrete compiled RAM. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Scanner + +/-- Source-level correctness and explicit resource bounds. -/ +theorem program_performance (spec : Spec) (bits : List Bool) : + βˆƒ final cost space, + Exec (program spec) (inputStore spec bits) final + (stepCount spec bits.length) cost space ∧ + cost ≀ timeBound spec bits.length ∧ + space ≀ spaceBound spec bits.length ∧ + final lengthReg = Input.bitValue + (spec.accept (bits.foldl spec.step spec.initial)) := + program_measured_internal spec bits + +/-- End-to-end performance and correctness of the compiled concrete RAM. -/ +theorem compiled_performance (spec : Spec) (bits : List Bool) : + βˆƒ final cost space, + Exec (program spec) (inputStore spec bits) final + (stepCount spec bits.length) cost space ∧ + run (compiled spec) (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits } = + { pc := (program spec).codeSize, regs := final } ∧ + Halted (compiled spec) + (run (compiled spec) (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits }) ∧ + logTimeUpto (compiled spec) (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits } ≀ timeBound spec bits.length ∧ + spaceUpto (compiled spec) (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits } ≀ spaceBound spec bits.length ∧ + (run (compiled spec) (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits }).regs lengthReg = + Input.bitValue (spec.accept (bits.foldl spec.step spec.initial)) := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + program_performance spec bits + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, ?_⟩ + Β· change logTimeUpto (program spec).compile (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits } ≀ timeBound spec bits.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto (program spec).compile (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits } ≀ spaceBound spec bits.length + rw [hcompiled.2.2] + exact hspace + Β· change (run (program spec).compile (stepCount spec bits.length) + { pc := 0, regs := inputStore spec bits }).regs lengthReg = _ + rw [hcompiled.1] + exact hresult + +/-- Source-level correctness and resource bounds for a typed scanner. -/ +theorem typed_program_performance {State : Type} [FinEnum State] + (typed : TypedSpec State) (bits : List Bool) : + βˆƒ final cost space, + Exec typed.program (typed.inputStore bits) final + (typed.stepCount bits.length) cost space ∧ + cost ≀ typed.timeBound bits.length ∧ + space ≀ typed.spaceBound bits.length ∧ + final lengthReg = Input.bitValue + (typed.accept (bits.foldl typed.step typed.initial)) := + typed_program_measured_internal typed bits + +/-- End-to-end concrete RAM correctness for a typed scanner. -/ +theorem typed_compiled_performance {State : Type} [FinEnum State] + (typed : TypedSpec State) (bits : List Bool) : + βˆƒ final cost space, + Exec typed.program (typed.inputStore bits) final + (typed.stepCount bits.length) cost space ∧ + run typed.compiled (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits } = + { pc := typed.program.codeSize, regs := final } ∧ + Halted typed.compiled + (run typed.compiled (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits }) ∧ + logTimeUpto typed.compiled (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits } ≀ typed.timeBound bits.length ∧ + spaceUpto typed.compiled (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits } ≀ typed.spaceBound bits.length ∧ + (run typed.compiled (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits }).regs lengthReg = + Input.bitValue (typed.accept (bits.foldl typed.step typed.initial)) := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + typed_program_performance typed bits + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, ?_⟩ + Β· change logTimeUpto typed.program.compile (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits } ≀ typed.timeBound bits.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto typed.program.compile (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits } ≀ typed.spaceBound bits.length + rw [hcompiled.2.2] + exact hspace + Β· change (run typed.program.compile (typed.stepCount bits.length) + { pc := 0, regs := typed.inputStore bits }).regs lengthReg = _ + rw [hcompiled.1] + exact hresult + +/-- For each fixed scanner, its explicit time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear (spec : Spec) : + timeBound spec =O quasilinearBound spec := by + have hpoint : βˆ€ n, timeBound spec n ≀ 64 * quasilinearBound spec n := by + intro n + simp only [timeBound, quasilinearBound] + have hshift : n + spec.stateCount + 1 ≀ n + inputBase spec := by + simp [inputBase, transitionBase] + omega + calc + 64 * (n + spec.stateCount + 1) * + (bitlen (n + inputBase spec) + 1) + = 64 * ((n + spec.stateCount + 1) * + (bitlen (n + inputBase spec) + 1)) := by ring + _ ≀ 64 * ((n + inputBase spec) * + (bitlen (n + inputBase spec) + 1)) := + Nat.mul_le_mul_left 64 + (Nat.mul_le_mul_right (bitlen (n + inputBase spec) + 1) hshift) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 64 (BigO.refl (quasilinearBound spec))) + +/-- For each fixed scanner, its explicit peak-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear (spec : Spec) : + spaceBound spec =O quasilinearBound spec := by + have hpoint : βˆ€ n, spaceBound spec n ≀ 2 * quasilinearBound spec n := by + intro n + simp only [spaceBound, quasilinearBound] + calc + (n + inputBase spec) * (2 * bitlen (n + inputBase spec)) + = 2 * ((n + inputBase spec) * bitlen (n + inputBase spec)) := by ring + _ ≀ 2 * ((n + inputBase spec) * + (bitlen (n + inputBase spec) + 1)) := + Nat.mul_le_mul_left 2 + (Nat.mul_le_mul_left (n + inputBase spec) (by omega)) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 2 (BigO.refl (quasilinearBound spec))) + +/-- The typed scanner's explicit time budget is quasilinear. -/ +theorem typed_timeBound_bigO_quasilinear {State : Type} [FinEnum State] + (typed : TypedSpec State) : typed.timeBound =O typed.quasilinearBound := + timeBound_bigO_quasilinear typed.numeric + +/-- The typed scanner's explicit peak-space budget is quasilinear. -/ +theorem typed_spaceBound_bigO_quasilinear {State : Type} [FinEnum State] + (typed : TypedSpec State) : typed.spaceBound =O typed.quasilinearBound := + spaceBound_bigO_quasilinear typed.numeric + +end Scanner + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Defs.lean new file mode 100644 index 0000000000..90d416efd8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Defs.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import Mathlib.Data.FinEnum + +/-! +# Finite-state scanners for the structured RAM frontend + +`Scanner.Spec` describes a finite automaton using numeric state codes. The +compiler below realizes it as a table-driven structured RAM program. The state +bound and transition-closure fields are the complete trusted interface needed by +the generic correctness and resource proof. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Scanner + +/-- A total finite-state Boolean scanner with contiguous numeric state codes. -/ +structure Spec where + /-- Number of valid state codes. -/ + stateCount : β„• + /-- Initial state code. -/ + initial : β„• + /-- The initial code is valid. -/ + initial_lt : initial < stateCount + /-- One state transition. -/ + step : β„• β†’ Bool β†’ β„• + /-- Transitions preserve valid state codes. -/ + step_lt : βˆ€ state, state < stateCount β†’ βˆ€ bit, step state bit < stateCount + /-- Final Boolean verdict. -/ + accept : β„• β†’ Bool + +/-- A scanner specification over an explicitly enumerable Lean state type. + +`FinEnum` retains a concrete equivalence with an initial segment of natural +numbers, so lowering remains executable while consumers reason using their +domain-specific state type. -/ +structure TypedSpec (State : Type) [FinEnum State] where + /-- Initial typed state. -/ + initial : State + /-- One typed state transition. -/ + step : State β†’ Bool β†’ State + /-- Final Boolean verdict. -/ + accept : State β†’ Bool + +namespace TypedSpec + +variable {State : Type} [FinEnum State] + +/-- Numeric state code chosen by the explicit enumeration. -/ +def code (state : State) : β„• := (FinEnum.equiv state).val + +/-- Lower a typed scanner to the verified numeric scanner interface. -/ +def numeric (typed : TypedSpec State) : Spec where + stateCount := FinEnum.card State + initial := code typed.initial + initial_lt := (FinEnum.equiv typed.initial).isLt + step := fun state bit => + if hstate : state < FinEnum.card State then + code (typed.step (FinEnum.equiv.symm ⟨state, hstate⟩) bit) + else 0 + step_lt := by + intro state hstate bit + simp [hstate, code] + accept := fun state => + if hstate : state < FinEnum.card State then + typed.accept (FinEnum.equiv.symm ⟨state, hstate⟩) + else false + +end TypedSpec + +/-- Remaining input length and final verdict register. -/ +def lengthReg : β„• := 0 +/-- Current numeric automaton state. -/ +def stateReg : β„• := 1 +/-- Address of the next input bit. -/ +def pointerReg : β„• := 2 +/-- Constant-one register. -/ +def oneReg : β„• := 3 +/-- Current input bit. -/ +def bitReg : β„• := 4 +/-- Scratch address used for table lookups. -/ +def addressReg : β„• := 5 +/-- Constant-two register. -/ +def twoReg : β„• := 6 +/-- Register containing the transition-table base address. -/ +def transitionBaseReg : β„• := 7 +/-- Register containing the verdict-table base address. -/ +def acceptBaseReg : β„• := 8 +/-- First transition-table register. -/ +def transitionBase : β„• := 9 + +/-- First verdict-table register. -/ +def acceptBase (spec : Spec) : β„• := + transitionBase + 2 * spec.stateCount + +/-- First input register. -/ +def inputBase (spec : Spec) : β„• := + transitionBase + 3 * spec.stateCount + +/-- Address of one transition-table entry. -/ +def transitionAddress (state : β„•) (bit : Bool) : β„• := + transitionBase + 2 * state + Input.bitValue bit + +/-- Address of one verdict-table entry. -/ +def acceptAddress (spec : Spec) (state : β„•) : β„• := + acceptBase spec + state + +/-- Reserved-prefix input layout for a scanner. -/ +def inputStore (spec : Spec) (bits : List Bool) : Store := + Input.bitStore lengthReg (inputBase spec) bits + +/-- The six fixed setup destinations below the tables. -/ +def fixedSetupIndices : List β„• := + [stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, acceptBaseReg] + +/-- Every table destination, in increasing order. -/ +def tableIndices (spec : Spec) : List β„• := + List.range' transitionBase (3 * spec.stateCount) + +/-- Every setup destination. -/ +def setupIndices (spec : Spec) : List β„• := + fixedSetupIndices ++ tableIndices spec + +/-- Value written to one setup destination. -/ +def setupValue (spec : Spec) (index : β„•) : β„• := + if index = stateReg then spec.initial + else if index = pointerReg then inputBase spec + else if index = oneReg then 1 + else if index = twoReg then 2 + else if index = transitionBaseReg then transitionBase + else if index = acceptBaseReg then acceptBase spec + else if index < acceptBase spec then + let offset := index - transitionBase + spec.step (offset / 2) (offset % 2 = 1) + else + Input.bitValue (spec.accept (index - acceptBase spec)) + +/-- Constant and table writes performed before scanning. -/ +def setupWrites (spec : Spec) : List (β„• Γ— β„•) := + (setupIndices spec).map fun index => (index, setupValue spec index) + +/-- Straight-line setup instruction list. -/ +def setupOps (spec : Spec) : List Basic := + (setupWrites spec).map fun write => .imm write.1 write.2 + +/-- Initialize constants and transition/verdict tables. -/ +def setup (spec : Spec) : Cmd := Cmd.basics (setupOps spec) + +/-- Seven-instruction scanner body, independent of the particular automaton. -/ +def bodyOps : List Basic := + [.load bitReg pointerReg, + .mul addressReg stateReg twoReg, + .add addressReg addressReg bitReg, + .add addressReg addressReg transitionBaseReg, + .load stateReg addressReg, + .add pointerReg pointerReg oneReg, + .sub lengthReg lengthReg oneReg] + +/-- Consume one input bit and update the encoded automaton state. -/ +def body : Cmd := Cmd.basics bodyOps + +/-- Scan all input bits. -/ +def mainLoop : Cmd := Cmd.whileNonzero lengthReg body + +/-- Two-instruction final verdict lookup. -/ +def finalizeOps : List Basic := + [.add addressReg stateReg acceptBaseReg, .load lengthReg addressReg] + +/-- Write the final verdict to `Rβ‚€`. -/ +def finalize : Cmd := Cmd.basics finalizeOps + +/-- Complete structured scanner. -/ +def program (spec : Spec) : Cmd := + Cmd.seq (setup spec) (.seq mainLoop finalize) + +/-- Concrete compiled RAM scanner. -/ +def compiled (spec : Spec) : Program := (program spec).compile + +/-- Exact compiled transition count. -/ +def stepCount (spec : Spec) (inputLength : β„•) : β„• := + 9 + 3 * spec.stateCount + 9 * inputLength + +/-- Explicit logarithmic-cost time budget. -/ +def timeBound (spec : Spec) (inputLength : β„•) : β„• := + 64 * (inputLength + spec.stateCount + 1) * + (bitlen (inputLength + inputBase spec) + 1) + +/-- Explicit peak-space budget. -/ +def spaceBound (spec : Spec) (inputLength : β„•) : β„• := + (inputLength + inputBase spec) * + (2 * bitlen (inputLength + inputBase spec)) + +/-- Shifted quasilinear comparison function. -/ +def quasilinearBound (spec : Spec) (inputLength : β„•) : β„• := + (inputLength + inputBase spec) * + (bitlen (inputLength + inputBase spec) + 1) + +namespace TypedSpec + +variable {State : Type} [FinEnum State] + +/-- Input store for a typed scanner. -/ +abbrev inputStore (typed : TypedSpec State) : List Bool β†’ Store := + Scanner.inputStore typed.numeric + +/-- Structured RAM program generated from a typed scanner. -/ +abbrev program (typed : TypedSpec State) : Cmd := Scanner.program typed.numeric + +/-- Concrete RAM program generated from a typed scanner. -/ +abbrev compiled (typed : TypedSpec State) : Program := Scanner.compiled typed.numeric + +/-- Exact transition count for a typed scanner. -/ +abbrev stepCount (typed : TypedSpec State) : β„• β†’ β„• := + Scanner.stepCount typed.numeric + +/-- Explicit logarithmic-time budget for a typed scanner. -/ +abbrev timeBound (typed : TypedSpec State) : β„• β†’ β„• := + Scanner.timeBound typed.numeric + +/-- Explicit peak-space budget for a typed scanner. -/ +abbrev spaceBound (typed : TypedSpec State) : β„• β†’ β„• := + Scanner.spaceBound typed.numeric + +/-- Shifted quasilinear comparison function for a typed scanner. -/ +abbrev quasilinearBound (typed : TypedSpec State) : β„• β†’ β„• := + Scanner.quasilinearBound typed.numeric + +end TypedSpec + +end Scanner + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Internal.lean new file mode 100644 index 0000000000..16f4e52c51 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Scanner/Internal.lean @@ -0,0 +1,857 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Finite-state structured RAM scanners β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Scanner + +open Internal + +private abbrev StoreBound (spec : Spec) (inputLength : β„•) (store : Store) : Prop := + StoreEnvelope (inputLength + inputBase spec) (inputLength + inputBase spec) store + +private abbrev width (spec : Spec) (inputLength : β„•) : β„• := + valueWidth (inputLength + inputBase spec) + +private abbrev resourceSpace (spec : Spec) (inputLength : β„•) : β„• := + envelopeSpace (inputLength + inputBase spec) (inputLength + inputBase spec) + +private theorem envelopeSpace_eq_spaceBound (spec : Spec) (inputLength : β„•) : + resourceSpace spec inputLength = spaceBound spec inputLength := by + simp [resourceSpace, envelopeSpace, spaceBound, two_mul] + +private theorem inputStore_bound (spec : Spec) (bits : List Bool) : + StoreBound spec bits.length (inputStore spec bits) := by + apply Internal.Input.bitStoreEnvelope + Β· simp [lengthReg, inputBase, transitionBase] + Β· simp [inputBase, transitionBase] + omega + Β· exact Nat.le_add_right _ _ + Β· have hinitial := spec.initial_lt + have hpositive : 0 < spec.stateCount := by omega + simp [inputBase, transitionBase] + omega + +private theorem setupIndices_nodup (spec : Spec) : + (setupIndices spec).Nodup := by + rw [setupIndices, List.nodup_append'] + refine ⟨by decide, List.nodup_range', ?_⟩ + rw [List.disjoint_left] + intro index hfixed htable + have hlt : index < transitionBase := by + simp [fixedSetupIndices, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, + acceptBaseReg] at hfixed + simp [transitionBase] + omega + have hle : transitionBase ≀ index := + List.left_le_of_mem_range' htable + omega + +private theorem setupWrites_nodup (spec : Spec) : + ((setupWrites spec).map Prod.fst).Nodup := by + have hmap : (setupWrites spec).map Prod.fst = setupIndices spec := by + simp [setupWrites, List.map_map, Function.comp_def] + rw [hmap] + exact setupIndices_nodup spec + +private theorem setupOps_length (spec : Spec) : + (setupOps spec).length = 6 + 3 * spec.stateCount := by + simp [setupOps, setupWrites, setupIndices, fixedSetupIndices, tableIndices] + ring + +private theorem transitionAddress_mem (spec : Spec) (state : β„•) + (hstate : state < spec.stateCount) (bit : Bool) : + transitionAddress state bit ∈ setupIndices spec := by + rw [setupIndices, List.mem_append] + right + rw [tableIndices] + apply List.mem_range'.mpr + refine ⟨2 * state + Input.bitValue bit, ?_, ?_⟩ + Β· cases bit <;> simp [Input.bitValue] + all_goals omega + Β· simp [transitionAddress] + omega + +private theorem acceptAddress_mem (spec : Spec) (state : β„•) + (hstate : state < spec.stateCount) : + acceptAddress spec state ∈ setupIndices spec := by + rw [setupIndices, List.mem_append] + right + rw [tableIndices] + apply List.mem_range'.mpr + refine ⟨2 * spec.stateCount + state, by omega, ?_⟩ + simp [acceptAddress, acceptBase] + omega + +private theorem setupValue_transition (spec : Spec) (state : β„•) + (hstate : state < spec.stateCount) (bit : Bool) : + setupValue spec (transitionAddress state bit) = spec.step state bit := by + have hlt : transitionAddress state bit < acceptBase spec := by + cases bit <;> simp [transitionAddress, Input.bitValue, acceptBase] + all_goals omega + have hdiv : (transitionAddress state bit - transitionBase) / 2 = state := by + cases bit <;> simp [transitionAddress, Input.bitValue, transitionBase] + all_goals omega + have hbit : decide ((transitionAddress state bit - transitionBase) % 2 = 1) = bit := by + cases bit <;> simp [transitionAddress, Input.bitValue, transitionBase] + all_goals omega + unfold setupValue + split_ifs with hs hp ho ht htr ha + Β· simp [transitionAddress, Input.bitValue, stateReg, transitionBase] at hs + omega + Β· simp [transitionAddress, Input.bitValue, pointerReg, transitionBase] at hp + omega + Β· simp [transitionAddress, Input.bitValue, oneReg, transitionBase] at ho + omega + Β· simp [transitionAddress, Input.bitValue, twoReg, transitionBase] at ht + omega + Β· simp [transitionAddress, Input.bitValue, transitionBaseReg, transitionBase] at htr + omega + Β· simp [transitionAddress, Input.bitValue, acceptBaseReg, transitionBase] at ha + omega + Β· dsimp only + rw [hdiv, hbit] + +private theorem setupValue_accept (spec : Spec) (state : β„•) + (hstate : state < spec.stateCount) : + setupValue spec (acceptAddress spec state) = Input.bitValue (spec.accept state) := by + have hnotLt : Β¬acceptAddress spec state < acceptBase spec := by + simp [acceptAddress] + have hdiff : acceptAddress spec state - acceptBase spec = state := by + simp [acceptAddress] + unfold setupValue + split_ifs with hs hp ho ht htr ha + Β· simp [acceptAddress, acceptBase, stateReg, transitionBase] at hs + omega + Β· simp [acceptAddress, acceptBase, pointerReg, transitionBase] at hp + omega + Β· simp [acceptAddress, acceptBase, oneReg, transitionBase] at ho + omega + Β· simp [acceptAddress, acceptBase, twoReg, transitionBase] at ht + omega + Β· simp [acceptAddress, acceptBase, transitionBaseReg, transitionBase] at htr + omega + Β· simp [acceptAddress, acceptBase, acceptBaseReg, transitionBase] at ha + omega + Β· rw [hdiff] + +private theorem setupValue_le_inputBase (spec : Spec) (index : β„•) + (hindex : index ∈ setupIndices spec) : + setupValue spec index ≀ inputBase spec := by + rcases List.mem_append.mp hindex with hfixed | htable + Β· simp [fixedSetupIndices] at hfixed + rcases hfixed with rfl | rfl | rfl | rfl | rfl | rfl + all_goals have hinitial := spec.initial_lt + all_goals simp [setupValue, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, + acceptBaseReg, inputBase, acceptBase, transitionBase] <;> omega + Β· obtain ⟨offset, hoffset, rfl⟩ := List.mem_range'.mp htable + unfold setupValue + split_ifs with hs hp ho ht htr ha htableLt + Β· simp [stateReg, transitionBase] at hs + omega + Β· simp [pointerReg, transitionBase] at hp + omega + Β· simp [oneReg, transitionBase] at ho + omega + Β· simp [twoReg, transitionBase] at ht + omega + Β· simp [transitionBaseReg, transitionBase] at htr + omega + Β· simp [acceptBaseReg, transitionBase] at ha + omega + Β· have hstate : offset / 2 < spec.stateCount := by + simp [acceptBase, transitionBase] at htableLt + omega + have hbase : spec.stateCount ≀ inputBase spec := by + simp [inputBase, transitionBase] + omega + dsimp only + simp only [Nat.add_sub_cancel_left, one_mul] + change spec.step (offset / 2) (decide (offset % 2 = 1)) ≀ inputBase spec + exact (spec.step_lt (offset / 2) hstate _).le.trans hbase + Β· have hpositive : 1 ≀ inputBase spec := by + have hinitial := spec.initial_lt + simp [inputBase, transitionBase] + omega + simp only [Input.bitValue] + split <;> omega + +private def setupStore (spec : Spec) (bits : List Bool) : Store := + Basic.execList (setupOps spec) (inputStore spec bits) + +private theorem setupStore_apply (spec : Spec) (bits : List Bool) (index : β„•) + (hindex : index ∈ setupIndices spec) : + setupStore spec bits index = setupValue spec index := by + apply Basic.execList_imm_apply_of_mem (setupWrites spec) (inputStore spec bits) + (setupWrites_nodup spec) + simp [setupWrites, hindex] + +private theorem setupStore_unwritten (spec : Spec) (bits : List Bool) (index : β„•) + (hindex : index βˆ‰ setupIndices spec) : + setupStore spec bits index = inputStore spec bits index := by + apply Basic.execList_imm_apply_of_not_mem (setupWrites spec) + simpa [setupWrites, List.map_map, Function.comp_def] using hindex + +private theorem setupStore_high (spec : Spec) (bits : List Bool) (index : β„•) + (hindex : inputBase spec ≀ index) : + setupStore spec bits index = inputStore spec bits index := by + apply Basic.execList_imm_apply_of_not_mem (setupWrites spec) + simp only [setupWrites, List.map_map] + intro hmem + have hsetup : index ∈ setupIndices spec := by simpa using hmem + rcases List.mem_append.mp hsetup with hfixed | htable + Β· have hlt : index < inputBase spec := by + simp [fixedSetupIndices, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, + acceptBaseReg] at hfixed + simp [inputBase, transitionBase] + omega + omega + Β· rcases List.mem_range'.mp htable with ⟨offset, hoffset, heq⟩ + have hlt : index < inputBase spec := by + calc + index = transitionBase + 1 * offset := heq + _ < inputBase spec := by + simp [inputBase, transitionBase] + omega + omega + +private theorem setup_measured (spec : Spec) (bits : List Bool) : + MeasuredRuns (setup spec) (inputStore spec bits) (setupStore spec bits) + (setupOps spec).length + (4 * (setupOps spec).length * width spec bits.length) + (resourceSpace spec bits.length) ∧ + StoreBound spec bits.length (setupStore spec bits) := by + have hinitial := inputStore_bound spec bits + have hpreserve : βˆ€ op, op ∈ setupOps spec β†’ βˆ€ current, + StoreBound spec bits.length current β†’ + StoreBound spec bits.length (op.exec current) := by + intro op hop current hcurrent + rw [setupOps] at hop + obtain ⟨write, hwrite, rfl⟩ := List.mem_map.mp hop + rw [setupWrites] at hwrite + obtain ⟨index, hindex, rfl⟩ := List.mem_map.mp hwrite + apply hcurrent.execBasic (.imm index (setupValue spec index)) + Β· have hlt : index < inputBase spec := by + rcases List.mem_append.mp hindex with hfixed | htable + Β· simp [fixedSetupIndices, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, + acceptBaseReg] at hfixed + simp [inputBase, transitionBase] + omega + Β· rcases List.mem_range'.mp htable with ⟨offset, hoffset, heq⟩ + calc + index = transitionBase + 1 * offset := heq + _ < inputBase spec := by + simp [inputBase, transitionBase] + omega + exact hlt.trans_le (Nat.le_add_left _ bits.length) + Β· exact (setupValue_le_inputBase spec index hindex).trans + (Nat.le_add_left _ bits.length) + simpa [setup, setupStore] using + MeasuredRuns.basicsEnvelope (setupOps spec) (inputStore spec bits) + hinitial hpreserve + +private structure LoopInv (spec : Spec) (inputLength : β„•) + (remaining : List Bool) (state consumed : β„•) (store : Store) : Prop where + total_eq : consumed + remaining.length = inputLength + state_lt : state < spec.stateCount + store_bound : StoreBound spec inputLength store + length_eq : store lengthReg = remaining.length + state_eq : store stateReg = state + pointer_eq : store pointerReg = inputBase spec + consumed + one_eq : store oneReg = 1 + two_eq : store twoReg = 2 + transitionBase_eq : store transitionBaseReg = transitionBase + acceptBase_eq : store acceptBaseReg = acceptBase spec + transition_eq : βˆ€ automaton, automaton < spec.stateCount β†’ βˆ€ bit, + store (transitionAddress automaton bit) = spec.step automaton bit + accept_eq : βˆ€ automaton, automaton < spec.stateCount β†’ + store (acceptAddress spec automaton) = Input.bitValue (spec.accept automaton) + input_eq : βˆ€ offset, + store (inputBase spec + consumed + offset) = + match remaining[offset]? with + | some bit => Input.bitValue bit + | none => 0 + +private theorem setup_inv (spec : Spec) (bits : List Bool) + (hbound : StoreBound spec bits.length (setupStore spec bits)) : + LoopInv spec bits.length bits spec.initial 0 (setupStore spec bits) := by + constructor + Β· simp + Β· exact spec.initial_lt + Β· exact hbound + Β· rw [setupStore_unwritten] + Β· simp [inputStore, Input.bitStore, lengthReg] + Β· simp [setupIndices, fixedSetupIndices, tableIndices, lengthReg, stateReg, + pointerReg, oneReg, twoReg, transitionBaseReg, acceptBaseReg, + transitionBase] + Β· rw [setupStore_apply spec bits stateReg] + Β· simp [setupValue, stateReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· rw [setupStore_apply spec bits pointerReg] + Β· simp [setupValue, stateReg, pointerReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· rw [setupStore_apply spec bits oneReg] + Β· simp [setupValue, stateReg, pointerReg, oneReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· rw [setupStore_apply spec bits twoReg] + Β· simp [setupValue, stateReg, pointerReg, oneReg, twoReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· rw [setupStore_apply spec bits transitionBaseReg] + Β· simp [setupValue, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· rw [setupStore_apply spec bits acceptBaseReg] + Β· simp [setupValue, stateReg, pointerReg, oneReg, twoReg, transitionBaseReg, + acceptBaseReg] + Β· simp [setupIndices, fixedSetupIndices] + Β· intro state hstate bit + rw [setupStore_apply spec bits _ (transitionAddress_mem spec state hstate bit)] + exact setupValue_transition spec state hstate bit + Β· intro state hstate + rw [setupStore_apply spec bits _ (acceptAddress_mem spec state hstate)] + exact setupValue_accept spec state hstate + Β· intro offset + rw [setupStore_high spec bits _ (by omega)] + simp [inputStore, Input.bitStore, Input.bitValue, lengthReg, inputBase] + rfl + +private def loaded (store : Store) : Store := + (Basic.load bitReg pointerReg).exec store + +private def multiplied (store : Store) : Store := + (Basic.mul addressReg stateReg twoReg).exec (loaded store) + +private def indexed (store : Store) : Store := + (Basic.add addressReg addressReg bitReg).exec (multiplied store) + +private def addressed (store : Store) : Store := + (Basic.add addressReg addressReg transitionBaseReg).exec (indexed store) + +private def transitioned (store : Store) : Store := + (Basic.load stateReg addressReg).exec (addressed store) + +private def advanced (store : Store) : Store := + (Basic.add pointerReg pointerReg oneReg).exec (transitioned store) + +private def iterated (store : Store) : Store := + (Basic.sub lengthReg lengthReg oneReg).exec (advanced store) + +private theorem addressed_high (store : Store) (index : β„•) + (hindex : transitionBase ≀ index) : + addressed store index = store index := by + have hbit : index β‰  bitReg := by + simp [transitionBase, bitReg] at hindex ⊒ + omega + have haddress : index β‰  addressReg := by + simp [transitionBase, addressReg] at hindex ⊒ + omega + simp [addressed, indexed, multiplied, loaded, Basic.exec, + Function.update_of_ne, hbit, haddress] + +private theorem iterated_high (store : Store) (index : β„•) + (hindex : twoReg ≀ index) : + iterated store index = store index := by + have hlength : index β‰  lengthReg := by + simp [twoReg, lengthReg] at hindex ⊒ + omega + have hstate : index β‰  stateReg := by + simp [twoReg, stateReg] at hindex ⊒ + omega + have hpointer : index β‰  pointerReg := by + simp [twoReg, pointerReg] at hindex ⊒ + omega + have hbit : index β‰  bitReg := by + simp [twoReg, bitReg] at hindex ⊒ + omega + have haddress : index β‰  addressReg := by + simp [twoReg, addressReg] at hindex ⊒ + omega + simp [iterated, advanced, transitioned, addressed, indexed, multiplied, + loaded, Basic.exec, Function.update_of_ne, hlength, hstate, hpointer, + hbit, haddress] + +private theorem body_measured {spec : Spec} {bit : Bool} {rest : List Bool} + {inputLength consumed state : β„•} {store : Store} + (hinv : LoopInv spec inputLength (bit :: rest) state consumed store) : + MeasuredRuns body store (iterated store) 7 (28 * width spec inputLength) + (resourceSpace spec inputLength) ∧ + StoreBound spec inputLength (iterated store) := by + have hstateLt := hinv.state_lt + have hpositive := spec.initial_lt + have htotal := hinv.total_eq + have hloaded : StoreBound spec inputLength (loaded store) := by + apply hinv.store_bound.execBasic (.load bitReg pointerReg) + Β· simp [bitReg, inputBase, transitionBase] + omega + Β· simpa [Internal.Basic.writeValue] using + hinv.store_bound.value_le (store pointerReg) + have hloadedBit : loaded store bitReg = Input.bitValue bit := by + simp only [loaded, Basic.exec, Function.update_self] + rw [hinv.pointer_eq] + simpa using hinv.input_eq 0 + have hloadedState : loaded store stateReg = state := by + have hne : stateReg β‰  bitReg := by decide + simpa [loaded, Basic.exec, stateReg, bitReg, Function.update_of_ne hne] using + hinv.state_eq + have hloadedTwo : loaded store twoReg = 2 := by + have hne : twoReg β‰  bitReg := by decide + simpa [loaded, Basic.exec, twoReg, bitReg, Function.update_of_ne hne] using + hinv.two_eq + have hmultiplied : StoreBound spec inputLength (multiplied store) := by + apply hloaded.execBasic (.mul addressReg stateReg twoReg) + Β· simp [addressReg, inputBase, transitionBase] + omega + Β· change loaded store stateReg * loaded store twoReg ≀ + inputLength + inputBase spec + rw [hloadedState, hloadedTwo] + simp [inputBase, transitionBase] + omega + have hmultipliedAddress : multiplied store addressReg = 2 * state := by + simp [multiplied, Basic.exec, hloadedState, hloadedTwo] + ring + have hmultipliedBit : multiplied store bitReg = Input.bitValue bit := by + have hne : bitReg β‰  addressReg := by decide + simpa [multiplied, Basic.exec, Function.update_of_ne hne] using hloadedBit + have hindexed : StoreBound spec inputLength (indexed store) := by + apply hmultiplied.execBasic (.add addressReg addressReg bitReg) + Β· simp [addressReg, inputBase, transitionBase] + omega + Β· change multiplied store addressReg + multiplied store bitReg ≀ + inputLength + inputBase spec + rw [hmultipliedAddress, hmultipliedBit] + cases bit <;> simp [Input.bitValue, inputBase, transitionBase] <;> omega + have hindexedAddress : indexed store addressReg = + 2 * state + Input.bitValue bit := by + simp [indexed, Basic.exec, hmultipliedAddress, hmultipliedBit] + have hindexedBase : indexed store transitionBaseReg = transitionBase := by + have hne : transitionBaseReg β‰  addressReg := by decide + simpa [indexed, multiplied, loaded, Basic.exec, Function.update_of_ne hne, + transitionBaseReg, addressReg, bitReg] using hinv.transitionBase_eq + have haddressed : StoreBound spec inputLength (addressed store) := by + apply hindexed.execBasic (.add addressReg addressReg transitionBaseReg) + Β· simp [addressReg, inputBase, transitionBase] + omega + Β· change indexed store addressReg + indexed store transitionBaseReg ≀ + inputLength + inputBase spec + rw [hindexedAddress, hindexedBase] + cases bit <;> simp [Input.bitValue, inputBase, transitionBase] <;> omega + have haddressedAddress : addressed store addressReg = + transitionAddress state bit := by + simp [addressed, Basic.exec, hindexedAddress, hindexedBase, + transitionAddress] + ring + have htransitioned : StoreBound spec inputLength (transitioned store) := by + apply haddressed.execBasic (.load stateReg addressReg) + Β· simp [stateReg, inputBase, transitionBase] + omega + Β· change addressed store (addressed store addressReg) ≀ + inputLength + inputBase spec + rw [haddressedAddress, addressed_high store _ (by + simp [transitionAddress, transitionBase] + omega)] + rw [hinv.transition_eq state hinv.state_lt bit] + have hstep := spec.step_lt state hinv.state_lt bit + simp [inputBase, transitionBase] + omega + have htransitionedPointer : transitioned store pointerReg = + inputBase spec + consumed := by + have hne : pointerReg β‰  stateReg := by decide + simpa [transitioned, addressed, indexed, multiplied, loaded, Basic.exec, + pointerReg, stateReg, addressReg, bitReg, Function.update_of_ne hne] using + hinv.pointer_eq + have htransitionedOne : transitioned store oneReg = 1 := by + have hne : oneReg β‰  stateReg := by decide + simpa [transitioned, addressed, indexed, multiplied, loaded, Basic.exec, + oneReg, stateReg, addressReg, bitReg, Function.update_of_ne hne] using + hinv.one_eq + have hadvanced : StoreBound spec inputLength (advanced store) := by + apply htransitioned.execBasic (.add pointerReg pointerReg oneReg) + Β· simp [pointerReg, inputBase, transitionBase] + omega + Β· change transitioned store pointerReg + transitioned store oneReg ≀ + inputLength + inputBase spec + rw [htransitionedPointer, htransitionedOne] + have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + omega + have hadvancedLength : advanced store lengthReg = (bit :: rest).length := by + have hlength : store lengthReg = (bit :: rest).length := hinv.length_eq + simpa [advanced, transitioned, addressed, indexed, multiplied, loaded, + Basic.exec, lengthReg, pointerReg, stateReg, addressReg, bitReg] using hlength + have hadvancedOne : advanced store oneReg = 1 := by + simpa [advanced, transitioned, addressed, indexed, multiplied, loaded, + Basic.exec, oneReg, pointerReg, stateReg, addressReg, bitReg] using hinv.one_eq + have hiterated : StoreBound spec inputLength (iterated store) := by + apply hadvanced.execBasic (.sub lengthReg lengthReg oneReg) + Β· simp [lengthReg, inputBase, transitionBase] + Β· change advanced store lengthReg - advanced store oneReg ≀ + inputLength + inputBase spec + rw [hadvancedLength, hadvancedOne] + have htotal := hinv.total_eq + omega + have hload := MeasuredRuns.basicEnvelope (.load bitReg pointerReg) store + hinv.store_bound hloaded + have hmul := MeasuredRuns.basicEnvelope (.mul addressReg stateReg twoReg) + (loaded store) hloaded hmultiplied + have hindex := MeasuredRuns.basicEnvelope (.add addressReg addressReg bitReg) + (multiplied store) hmultiplied hindexed + have haddress := MeasuredRuns.basicEnvelope + (.add addressReg addressReg transitionBaseReg) (indexed store) hindexed haddressed + have htransition := MeasuredRuns.basicEnvelope (.load stateReg addressReg) + (addressed store) haddressed htransitioned + have hadvance := MeasuredRuns.basicEnvelope (.add pointerReg pointerReg oneReg) + (transitioned store) htransitioned hadvanced + have hdecrement := MeasuredRuns.basicEnvelope (.sub lengthReg lengthReg oneReg) + (advanced store) hadvanced hiterated + have hrun := hload.seq (hmul.seq + (hindex.seq (haddress.seq (htransition.seq (hadvance.seq hdecrement))))) + constructor + Β· simp only [body, Cmd.basics, bodyOps, List.map_cons, List.map_nil, Cmd.seqList] + convert! hrun using 1 + ring + Β· exact hiterated + +private theorem addressed_address_of_inv {spec : Spec} {bit : Bool} + {rest : List Bool} {inputLength consumed state : β„•} {store : Store} + (hinv : LoopInv spec inputLength (bit :: rest) state consumed store) : + addressed store addressReg = transitionAddress state bit := by + have hbit : loaded store bitReg = Input.bitValue bit := by + simp only [loaded, Basic.exec, Function.update_self] + rw [hinv.pointer_eq] + simpa using hinv.input_eq 0 + have hstate : loaded store stateReg = state := by + have hne : stateReg β‰  bitReg := by decide + simpa [loaded, Basic.exec, stateReg, bitReg, Function.update_of_ne hne] using + hinv.state_eq + have htwo : loaded store twoReg = 2 := by + have hne : twoReg β‰  bitReg := by decide + simpa [loaded, Basic.exec, twoReg, bitReg, Function.update_of_ne hne] using + hinv.two_eq + have hbase : indexed store transitionBaseReg = transitionBase := by + have hne : transitionBaseReg β‰  addressReg := by decide + simpa [indexed, multiplied, loaded, Basic.exec, Function.update_of_ne hne, + transitionBaseReg, addressReg, bitReg] using hinv.transitionBase_eq + have hmultipliedAddress : multiplied store addressReg = 2 * state := by + simp [multiplied, Basic.exec, hstate, htwo] + ring + have hmultipliedBit : multiplied store bitReg = Input.bitValue bit := by + have hne : bitReg β‰  addressReg := by decide + simpa [multiplied, Basic.exec, Function.update_of_ne hne] using hbit + have hindexedAddress : indexed store addressReg = + 2 * state + Input.bitValue bit := by + simp [indexed, Basic.exec, hmultipliedAddress, hmultipliedBit] + simp [addressed, Basic.exec, hindexedAddress, hbase, transitionAddress] + ring + +private theorem iterated_state {spec : Spec} {bit : Bool} {rest : List Bool} + {inputLength consumed state : β„•} {store : Store} + (hinv : LoopInv spec inputLength (bit :: rest) state consumed store) : + iterated store stateReg = spec.step state bit := by + have haddress := addressed_address_of_inv hinv + have htable : addressed store (transitionAddress state bit) = + spec.step state bit := by + rw [addressed_high store _ (by + cases bit <;> simp [transitionAddress, transitionBase, Input.bitValue] + all_goals omega)] + exact hinv.transition_eq state hinv.state_lt bit + simp [iterated, advanced, transitioned, Basic.exec, lengthReg, pointerReg, + stateReg, haddress, htable] + +private theorem iterated_inv {spec : Spec} {bit : Bool} {rest : List Bool} + {inputLength consumed state : β„•} {store : Store} + (hinv : LoopInv spec inputLength (bit :: rest) state consumed store) : + LoopInv spec inputLength rest (spec.step state bit) (consumed + 1) + (iterated store) := by + constructor + Β· have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + omega + Β· exact spec.step_lt state hinv.state_lt bit + Β· exact (body_measured hinv).2 + Β· have hlength : store 0 = (bit :: rest).length := by + simpa [lengthReg] using hinv.length_eq + have hone : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + simp [iterated, advanced, transitioned, addressed, indexed, multiplied, + loaded, Basic.exec, lengthReg, pointerReg, stateReg, addressReg, bitReg, + oneReg] + rw [hlength, hone] + simp + Β· exact iterated_state hinv + Β· have hpointer : store 2 = inputBase spec + consumed := by + simpa [pointerReg] using hinv.pointer_eq + have hone : store 3 = 1 := by simpa [oneReg] using hinv.one_eq + simp [iterated, advanced, transitioned, addressed, indexed, multiplied, + loaded, Basic.exec, lengthReg, pointerReg, stateReg, addressReg, bitReg, + oneReg] + rw [hpointer, hone] + omega + Β· simpa [iterated, advanced, transitioned, addressed, indexed, multiplied, + loaded, Basic.exec, lengthReg, pointerReg, stateReg, addressReg, bitReg, + oneReg] using hinv.one_eq + Β· rw [iterated_high store twoReg (by simp)] + exact hinv.two_eq + Β· rw [iterated_high store transitionBaseReg (by + simp [twoReg, transitionBaseReg])] + exact hinv.transitionBase_eq + Β· rw [iterated_high store acceptBaseReg (by simp [twoReg, acceptBaseReg])] + exact hinv.acceptBase_eq + Β· intro automaton hautomaton value + rw [iterated_high store _ (by + simp [transitionAddress, transitionBase, twoReg] + omega)] + exact hinv.transition_eq automaton hautomaton value + Β· intro automaton hautomaton + rw [iterated_high store _ (by + simp [acceptAddress, acceptBase, transitionBase, twoReg] + omega)] + exact hinv.accept_eq automaton hautomaton + Β· intro offset + rw [iterated_high store _ (by + simp [inputBase, transitionBase, twoReg] + omega)] + have hinput := hinv.input_eq (offset + 1) + convert! hinput using 1 + all_goals simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + +private def loopAdvance (spec : Spec) (state : β„• Γ— β„•) (bit : Bool) : β„• Γ— β„• := + (spec.step state.1 bit, state.2 + 1) + +private theorem foldl_loopAdvance (spec : Spec) (bits : List Bool) + (state consumed : β„•) : + bits.foldl (loopAdvance spec) (state, consumed) = + (bits.foldl spec.step state, consumed + bits.length) := by + induction bits generalizing state consumed with + | nil => simp + | cons bit rest ih => + simp only [List.foldl_cons, loopAdvance] + rw [ih] + simp + omega + +private theorem whileFoldSteps_eq (bits : List Bool) : + MeasuredRuns.whileFoldSteps (fun _ : Bool => 7) bits = + 1 + 9 * bits.length := by + induction bits with + | nil => simp [MeasuredRuns.whileFoldSteps] + | cons bit rest ih => + rw [MeasuredRuns.whileFoldSteps, ih] + simp + omega + +private theorem whileFoldCost_eq (bits : List Bool) (w : β„•) : + MeasuredRuns.whileFoldCost w (fun _ : Bool => 28 * w) bits = + (31 * bits.length + 1) * w := by + induction bits with + | nil => simp [MeasuredRuns.whileFoldCost] + | cons bit rest ih => + rw [MeasuredRuns.whileFoldCost, ih] + simp only [List.length_cons] + ring + +private theorem loop_measured {spec : Spec} {remaining : List Bool} + {inputLength consumed state : β„•} {store : Store} + (hinv : LoopInv spec inputLength remaining state consumed store) : + βˆƒ final, + MeasuredRuns mainLoop store final (1 + 9 * remaining.length) + ((31 * remaining.length + 1) * width spec inputLength) + (resourceSpace spec inputLength) ∧ + LoopInv spec inputLength [] (remaining.foldl spec.step state) + (consumed + remaining.length) final := by + let bodySteps : Bool β†’ β„• := fun _ => 7 + let bodyCost : Bool β†’ β„• := fun _ => 28 * width spec inputLength + have hrun := MeasuredRuns.whileFoldEnvelope + (Inv := fun items foldState current => + LoopInv spec inputLength items foldState.1 foldState.2 current) + (advance := loopAdvance spec) (bodySteps := bodySteps) (bodyCost := bodyCost) + (test := lengthReg) (body := body) + (hstore := by intro _ _ _ h; exact h.store_bound) + (hnil := by intro _ _ h; simpa using h.length_eq) + (hcons := by intro _ _ _ _ h; rw [h.length_eq]; simp) + (hbody := by + intro bit rest foldState current h + exact ⟨iterated current, (body_measured h).1, by + simpa [loopAdvance] using iterated_inv h⟩) + (items := remaining) (state := (state, consumed)) (initial := store) hinv + obtain ⟨final, hloop, hfinal⟩ := hrun + have hsteps : MeasuredRuns.whileFoldSteps bodySteps remaining = + 1 + 9 * remaining.length := by + simpa [bodySteps] using whileFoldSteps_eq remaining + have hcost : MeasuredRuns.whileFoldCost (width spec inputLength) + bodyCost remaining = + (31 * remaining.length + 1) * width spec inputLength := by + simpa [bodyCost] using whileFoldCost_eq remaining (width spec inputLength) + have hstate := foldl_loopAdvance spec remaining state consumed + rw [hstate] at hfinal + refine ⟨final, ?_, hfinal⟩ + simpa [mainLoop, hsteps, hcost] using hloop + +private def finalStore (store : Store) : Store := + Basic.execList finalizeOps store + +private theorem finalize_measured {spec : Spec} {inputLength state : β„•} + {store : Store} (hinv : LoopInv spec inputLength [] state inputLength store) : + MeasuredRuns finalize store (finalStore store) 2 + (8 * width spec inputLength) (resourceSpace spec inputLength) ∧ + finalStore store lengthReg = Input.bitValue (spec.accept state) := by + let indexed := (Basic.add addressReg stateReg acceptBaseReg).exec store + have hstate : store stateReg = state := hinv.state_eq + have hbase : store acceptBaseReg = acceptBase spec := hinv.acceptBase_eq + have hpositive := spec.initial_lt + have hstateLt := hinv.state_lt + have hindexed : StoreBound spec inputLength indexed := by + apply hinv.store_bound.execBasic (.add addressReg stateReg acceptBaseReg) + Β· simp [addressReg, inputBase, transitionBase] + omega + Β· change store stateReg + store acceptBaseReg ≀ + inputLength + inputBase spec + rw [hstate, hbase] + simp [acceptBase, inputBase, transitionBase] + omega + have haddress : indexed addressReg = acceptAddress spec state := by + simp [indexed, Basic.exec, hstate, hbase, acceptAddress] + ring + have htable : indexed (acceptAddress spec state) = + Input.bitValue (spec.accept state) := by + have hne : acceptAddress spec state β‰  addressReg := by + simp [acceptAddress, acceptBase, transitionBase, addressReg] + omega + rw [show indexed (acceptAddress spec state) = + store (acceptAddress spec state) by + simp [indexed, Basic.exec, Function.update_of_ne hne]] + exact hinv.accept_eq state hinv.state_lt + have hfinal : StoreBound spec inputLength (finalStore store) := by + change StoreBound spec inputLength + ((Basic.load lengthReg addressReg).exec indexed) + apply hindexed.execBasic (.load lengthReg addressReg) + Β· simp [lengthReg, inputBase, transitionBase] + Β· change indexed (indexed addressReg) ≀ inputLength + inputBase spec + rw [haddress, htable] + cases spec.accept state <;> simp [Input.bitValue, inputBase, transitionBase] + all_goals omega + have hfirst := MeasuredRuns.basicEnvelope + (.add addressReg stateReg acceptBaseReg) store hinv.store_bound hindexed + have hsecond := MeasuredRuns.basicEnvelope (.load lengthReg addressReg) + indexed hindexed hfinal + have hrun := hfirst.seq hsecond + constructor + Β· simp only [finalize, Cmd.basics, finalizeOps, List.map_cons, List.map_nil, + Cmd.seqList] + convert! hrun using 1 + ring + Β· change ((Basic.load lengthReg addressReg).exec indexed) lengthReg = _ + simp [Basic.exec, haddress, htable] + +theorem program_measured_internal (spec : Spec) (bits : List Bool) : + βˆƒ final cost space, + Exec (program spec) (inputStore spec bits) final + (stepCount spec bits.length) cost space ∧ + cost ≀ timeBound spec bits.length ∧ + space ≀ spaceBound spec bits.length ∧ + final lengthReg = Input.bitValue + (spec.accept (bits.foldl spec.step spec.initial)) := by + obtain ⟨hsetup, hsetupBound⟩ := setup_measured spec bits + have hsetupInv := setup_inv spec bits hsetupBound + obtain ⟨loopFinal, hloop, hloopInv⟩ := loop_measured hsetupInv + have hloopInv' : LoopInv spec bits.length [] + (bits.foldl spec.step spec.initial) bits.length loopFinal := by + simpa using hloopInv + obtain ⟨hfinalize, hresult⟩ := finalize_measured hloopInv' + have hseq := hsetup.seq (hloop.seq hfinalize) + have hcostLe : + 4 * (setupOps spec).length * width spec bits.length + + ((31 * bits.length + 1) * width spec bits.length + + 8 * width spec bits.length) ≀ timeBound spec bits.length := by + rw [timeBound] + change _ ≀ 64 * (bits.length + spec.stateCount + 1) * width spec bits.length + calc + 4 * (setupOps spec).length * width spec bits.length + + ((31 * bits.length + 1) * width spec bits.length + + 8 * width spec bits.length) + = (31 * bits.length + 12 * spec.stateCount + 33) * + width spec bits.length := by + rw [setupOps_length] + ring + _ ≀ (64 * (bits.length + spec.stateCount + 1)) * + width spec bits.length := + Nat.mul_le_mul_right _ (by omega) + _ = 64 * (bits.length + spec.stateCount + 1) * + width spec bits.length := by ring + have hwide := hseq.weakenCost hcostLe + have hprogram : MeasuredRuns (program spec) (inputStore spec bits) + (finalStore loopFinal) (stepCount spec bits.length) + (timeBound spec bits.length) (resourceSpace spec bits.length) := by + rw [program] + convert! hwide using 1 + rw [setupOps_length] + simp [stepCount] + ring + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hprogram + have hspace' : space ≀ spaceBound spec bits.length := by + rw [← envelopeSpace_eq_spaceBound] + exact hspace + exact ⟨finalStore loopFinal, cost, space, hexec, hcost, hspace', hresult⟩ + +private theorem TypedSpec.numeric_step_code {State : Type} [FinEnum State] + (typed : TypedSpec State) (state : State) (bit : Bool) : + typed.numeric.step (TypedSpec.code state) bit = + TypedSpec.code (typed.step state bit) := by + simp [TypedSpec.numeric, TypedSpec.code] + +private theorem TypedSpec.numeric_accept_code {State : Type} [FinEnum State] + (typed : TypedSpec State) (state : State) : + typed.numeric.accept (TypedSpec.code state) = typed.accept state := by + simp [TypedSpec.numeric, TypedSpec.code] + +private theorem TypedSpec.foldl_numeric_step {State : Type} [FinEnum State] + (typed : TypedSpec State) (bits : List Bool) (state : State) : + bits.foldl typed.numeric.step (TypedSpec.code state) = + TypedSpec.code (bits.foldl typed.step state) := by + induction bits generalizing state with + | nil => rfl + | cons bit rest ih => + simp only [List.foldl_cons] + rw [typed.numeric_step_code, ih] + +theorem typed_program_measured_internal {State : Type} [FinEnum State] + (typed : TypedSpec State) (bits : List Bool) : + βˆƒ final cost space, + Exec (program typed.numeric) (inputStore typed.numeric bits) final + (stepCount typed.numeric bits.length) cost space ∧ + cost ≀ timeBound typed.numeric bits.length ∧ + space ≀ spaceBound typed.numeric bits.length ∧ + final lengthReg = Input.bitValue + (typed.accept (bits.foldl typed.step typed.initial)) := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + program_measured_internal typed.numeric bits + refine ⟨final, cost, space, hexec, hcost, hspace, ?_⟩ + change final lengthReg = Input.bitValue + (typed.numeric.accept + (bits.foldl typed.numeric.step (TypedSpec.code typed.initial))) at hresult + rw [typed.foldl_numeric_step, typed.numeric_accept_code] at hresult + exact hresult + +end Scanner + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch.lean new file mode 100644 index 0000000000..813e03a081 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Internal + +/-! +# Verified finite numeric switches for structured RAM programs + +The theorem in this module gives exact source step accounting and explicit +logarithmic-cost and peak-space bounds for a finite numeric switch. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Switch + + +open Internal + +/-- A valid numeric code selects its corresponding branch, without requiring a +resource envelope. This semantic form supports composition before a larger +program chooses a shared cost and space bound. -/ +theorem select_exec {count test one : β„•} + (branch : Fin count β†’ Cmd) (initial final : Store) + {code branchSteps : β„•} + (hcode : code < count) (htest : initial test = code) + (hone : initial one = 1) (hne : test β‰  one) + (hbranch : βˆƒ cost space, + Exec (branch ⟨code, hcode⟩) (cleared initial test) final + branchSteps cost space) : + βˆƒ cost space, + Exec (select count test one branch) initial final + (stepCount code branchSteps) cost space := + select_exec_internal branch initial final hcode htest hone hne hbranch + +/-- A valid numeric code selects its corresponding branch. The selected branch +starts with the test register cleared, matching the decrementing implementation. +The result carries an exact transition count and envelope-based resource bounds. -/ +theorem select_measured {count test one indexBound valueBound : β„•} + (branch : Fin count β†’ Cmd) (initial final : Store) + {code branchSteps branchCost : β„•} + (hcode : code < count) (htest : initial test = code) + (hone : initial one = 1) (hne : test β‰  one) + (htestIndex : test < indexBound) + (hinitial : StoreEnvelope indexBound valueBound initial) + (hbranch : MeasuredRuns (branch ⟨code, hcode⟩) (cleared initial test) + final branchSteps branchCost (envelopeSpace indexBound valueBound)) : + MeasuredRuns (select count test one branch) initial final + (stepCount code branchSteps) + (costBound code branchCost (valueWidth valueBound)) + (envelopeSpace indexBound valueBound) := + select_measured_internal branch initial final hcode htest hone hne + htestIndex hinitial hbranch + +end Switch + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Compiled.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Compiled.lean new file mode 100644 index 0000000000..e3e97b35ca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Compiled.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Compilation theorem for finite numeric structured-RAM switches +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Switch + + +open Internal + +/-- End-to-end compilation of a measured finite switch. -/ +theorem select_compiled {count test one indexBound valueBound : β„•} + (branch : Fin count β†’ Cmd) (initial final : Store) + {code branchSteps branchCost : β„•} + (hcode : code < count) (htest : initial test = code) + (hone : initial one = 1) (hne : test β‰  one) + (htestIndex : test < indexBound) + (hinitial : StoreEnvelope indexBound valueBound initial) + (hbranch : MeasuredRuns (branch ⟨code, hcode⟩) (cleared initial test) + final branchSteps branchCost (envelopeSpace indexBound valueBound)) : + βˆƒ cost space, + Exec (select count test one branch) initial final + (stepCount code branchSteps) cost space ∧ + run (select count test one branch).compile (stepCount code branchSteps) + { pc := 0, regs := initial } = + { pc := (select count test one branch).codeSize, regs := final } ∧ + Halted (select count test one branch).compile + (run (select count test one branch).compile (stepCount code branchSteps) + { pc := 0, regs := initial }) ∧ + logTimeUpto (select count test one branch).compile + (stepCount code branchSteps) { pc := 0, regs := initial } ≀ + costBound code branchCost (valueWidth valueBound) ∧ + spaceUpto (select count test one branch).compile + (stepCount code branchSteps) { pc := 0, regs := initial } ≀ + envelopeSpace indexBound valueBound := by + obtain ⟨cost, space, hexec, hcost, hspace⟩ := + select_measured branch initial final hcode htest hone hne htestIndex + hinitial hbranch + have hcompiled := Exec.compile_correct hexec + refine ⟨cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, ?_, ?_⟩ + Β· rw [hcompiled.2.1] + exact hcost + Β· rw [hcompiled.2.2] + exact hspace + +end Switch + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Defs.lean new file mode 100644 index 0000000000..fd436e17c5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Defs.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs + +/-! +# Finite numeric switches for structured RAM programs + +`select` compiles a finite family of commands into a decrementing decision +tree. A valid numeric code in `test` selects the corresponding branch. The +register `one` must contain one and be distinct from `test`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Switch + + +/-- Store presented to the selected branch after the tested code has been +decremented to zero. -/ +def cleared (store : Store) (test : β„•) : Store := + Function.update store test 0 + +/-- A finite numeric switch. Invalid codes fall through to `skip`; correctness +theorems use the explicit hypothesis `code < count`. -/ +def select : (count : β„•) β†’ (test one : β„•) β†’ (Fin count β†’ Cmd) β†’ Cmd + | 0, _, _, _ => .skip + | count + 1, test, one, branch => + .ifZero test (branch ⟨0, by omega⟩) + (.seq (.basic (.sub test test one)) + (select count test one (fun index => branch index.succ))) + +/-- Exact compiled/source transition count for selecting `code`. -/ +def stepCount (code branchSteps : β„•) : β„• := + 3 * code + branchSteps + 1 + +/-- Envelope-based logarithmic-cost bound for selecting `code`. + +Each skipped case pays at most seven envelope widths: three for the nonzero +conditional and four for the decrement. The selected zero case pays one. -/ +def costBound (code branchCost width : β„•) : β„• := + (7 * code + 1) * width + branchCost + +end Switch + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Internal.lean new file mode 100644 index 0000000000..1247745035 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/Switch/Internal.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Switch.Defs + +/-! +# Finite numeric structured-RAM switches -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace Switch + + +open Internal + +private theorem cleared_eq_self {store : Store} {test : β„•} + (htest : store test = 0) : cleared store test = store := by + funext index + by_cases hindex : index = test + Β· subst index + simp [cleared, htest] + Β· simp [cleared, Function.update_of_ne hindex] + +private theorem cleared_sub_eq (store : Store) (test one : β„•) : + cleared ((Basic.sub test test one).exec store) test = cleared store test := by + funext index + by_cases hindex : index = test + Β· subst index + simp [cleared] + Β· simp [cleared, Basic.exec, Function.update_of_ne hindex] + +theorem select_exec_internal {count test one : β„•} + (branch : Fin count β†’ Cmd) (initial final : Store) + {code branchSteps : β„•} + (hcode : code < count) (htest : initial test = code) + (hone : initial one = 1) (hne : test β‰  one) + (hbranch : βˆƒ cost space, + Exec (branch ⟨code, hcode⟩) (cleared initial test) final + branchSteps cost space) : + βˆƒ cost space, + Exec (select count test one branch) initial final + (stepCount code branchSteps) cost space := by + induction count generalizing code initial with + | zero => omega + | succ count ih => + by_cases hzero : code = 0 + Β· have htestZero : initial test = 0 := htest.trans hzero + have hclear : cleared initial test = initial := cleared_eq_self htestZero + obtain ⟨branchCost, branchSpace, hbranchExec⟩ := hbranch + have hbranchZero : + Exec (branch ⟨0, by omega⟩) initial final branchSteps + branchCost branchSpace := by + rw [← hclear] + simpa [hzero] using hbranchExec + refine ⟨bitlen (initial test) + 1 + branchCost, + max initial.space branchSpace, ?_⟩ + simpa [select, stepCount, hzero] using + Exec.ifZero htestZero hbranchZero + Β· obtain ⟨predecessor, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hzero + have hpredecessor : predecessor < count := by omega + let next := (Basic.sub test test one).exec initial + have hnextTest : next test = predecessor := by + simp [next, Basic.exec, htest, hone] + have hnextOne : next one = 1 := by + rw [show next one = initial one by + simp [next, Basic.exec, Function.update_of_ne (Ne.symm hne)]] + exact hone + have hclear : cleared next test = cleared initial test := by + exact cleared_sub_eq initial test one + have hrecursiveBranch : + βˆƒ cost space, + Exec ((fun index : Fin count => branch index.succ) + ⟨predecessor, hpredecessor⟩) + (cleared next test) final branchSteps cost space := by + rw [hclear] + simpa using hbranch + obtain ⟨recursiveCost, recursiveSpace, hrecursive⟩ := + ih (branch := fun index => branch index.succ) (initial := next) + hpredecessor hnextTest hnextOne hrecursiveBranch + have hdecrement := Exec.basic (.sub test test one) initial + have hsequence := Exec.seq hdecrement hrecursive + have hnonzero : initial test β‰  0 := by omega + have hrun := Exec.ifNonzero + (onZero := branch ⟨0, by omega⟩) hnonzero hsequence + refine ⟨bitlen (initial test) + 1 + + ((Basic.sub test test one).logCost initial + recursiveCost) + 1, + max initial.space + (max (max initial.space + ((Basic.sub test test one).exec initial).space) recursiveSpace), ?_⟩ + convert! hrun using 1 + all_goals simp [stepCount] + all_goals omega + +theorem select_measured_internal {count test one indexBound valueBound : β„•} + (branch : Fin count β†’ Cmd) (initial final : Store) + {code branchSteps branchCost : β„•} + (hcode : code < count) (htest : initial test = code) + (hone : initial one = 1) (hne : test β‰  one) + (htestIndex : test < indexBound) + (hinitial : StoreEnvelope indexBound valueBound initial) + (hbranch : MeasuredRuns (branch ⟨code, hcode⟩) (cleared initial test) + final branchSteps branchCost (envelopeSpace indexBound valueBound)) : + MeasuredRuns (select count test one branch) initial final + (stepCount code branchSteps) + (costBound code branchCost (valueWidth valueBound)) + (envelopeSpace indexBound valueBound) := by + induction count generalizing code initial with + | zero => omega + | succ count ih => + by_cases hzero : code = 0 + Β· have htestZero : initial test = 0 := htest.trans hzero + have hclear : cleared initial test = initial := cleared_eq_self htestZero + have hcount : 0 < count + 1 := by omega + have hbranchZero : + MeasuredRuns (branch ⟨0, hcount⟩) initial final branchSteps + branchCost (envelopeSpace indexBound valueBound) := by + rw [← hclear] + simpa [hzero] using hbranch + have hrun := MeasuredRuns.ifZeroEnvelope + (onNonzero := .seq (.basic (.sub test test one)) + (select count test one (fun index => branch index.succ))) + htestZero hinitial hbranchZero + simpa [select, stepCount, costBound, hzero] using hrun + Β· obtain ⟨predecessor, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hzero + have hpredecessor : predecessor < count := by omega + let next := (Basic.sub test test one).exec initial + have hnextTest : next test = predecessor := by + simp [next, Basic.exec, htest, hone] + have hnextOne : next one = 1 := by + rw [show next one = initial one by + simp [next, Basic.exec, Function.update_of_ne (Ne.symm hne)]] + exact hone + have hnextEnvelope : StoreEnvelope indexBound valueBound next := by + apply hinitial.execBasic (.sub test test one) + Β· simpa using htestIndex + Β· simp [Internal.Basic.writeValue, htest, hone] + have hvalue := hinitial.value_le test + omega + have hclear : cleared next test = cleared initial test := by + exact cleared_sub_eq initial test one + have hrecursiveBranch : + MeasuredRuns + ((fun index : Fin count => branch index.succ) + ⟨predecessor, hpredecessor⟩) + (cleared next test) final branchSteps branchCost + (envelopeSpace indexBound valueBound) := by + rw [hclear] + simpa using hbranch + have hrecursive := ih (branch := fun index => branch index.succ) + (initial := next) hpredecessor hnextTest hnextOne + hnextEnvelope hrecursiveBranch + have hdecrement := MeasuredRuns.basicEnvelope + (.sub test test one) initial hinitial hnextEnvelope + have hnonzero : initial test β‰  0 := by omega + have hrun := MeasuredRuns.ifNonzeroEnvelope + (onZero := branch ⟨0, by omega⟩) hnonzero hinitial + (hdecrement.seq hrecursive) + convert! hrun using 1 <;> simp [stepCount, costBound] + all_goals ring + +end Switch + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax.lean new file mode 100644 index 0000000000..e77d558fdb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.ThreeSATSyntax.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner + +/-! +# Verified structured RAM exact-3-CNF syntax scanner + +The generic typed-scanner compiler supplies the entire implementation proof and +resource analysis for the existing 27-state `SAT.ThreeSAT.Syntax` automaton. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace ThreeSATSyntax + +open SAT.ThreeSAT + +/-- The 27-state syntax scanner takes exactly `90 + 9n` transitions. -/ +@[simp] theorem stepCount_eq (inputLength : β„•) : + stepCount inputLength = 90 + 9 * inputLength := by + rfl + +/-- Source correctness and explicit resource bounds for syntax recognition. -/ +theorem program_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits.length) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + final verdictReg = Input.bitValue + (Syntax.accept (bits.foldl Syntax.bitStep Syntax.bitStart)) := + Scanner.typed_program_performance spec bits + +/-- End-to-end compiled performance and syntax-language correctness. -/ +theorem compiled_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits.length) cost space ∧ + run compiled (stepCount bits.length) { pc := 0, regs := inputStore bits } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount bits.length) { pc := 0, regs := inputStore bits }) ∧ + logTimeUpto compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length ∧ + spaceUpto compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length ∧ + ((run compiled (stepCount bits.length) + { pc := 0, regs := inputStore bits }).regs verdictReg = 1 ↔ + bits ∈ Syntax.language) := by + obtain ⟨final, cost, space, hexec, hrun, hhalt, htime, hspace, hresult⟩ := + Scanner.typed_compiled_performance spec bits + refine ⟨final, cost, space, hexec, hrun, hhalt, htime, hspace, ?_⟩ + rw [hresult] + change Input.bitValue + (Syntax.accept (bits.foldl Syntax.bitStep Syntax.bitStart)) = 1 ↔ + Syntax.accept (bits.foldl Syntax.bitStep Syntax.bitStart) = true + cases Syntax.accept (bits.foldl Syntax.bitStep Syntax.bitStart) <;> + simp [Input.bitValue] + +/-- The explicit logarithmic-time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear : timeBound =O quasilinearBound := + Scanner.typed_timeBound_bigO_quasilinear spec + +/-- The explicit peak-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear : spaceBound =O quasilinearBound := + Scanner.typed_spaceBound_bigO_quasilinear spec + +end ThreeSATSyntax + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax/Defs.lean new file mode 100644 index 0000000000..dcab96ffe0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/ThreeSATSyntax/Defs.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Scanner.Defs +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT.Syntax + +/-! +# Structured RAM exact-3-CNF syntax scanner β€” definitions + +This is the larger typed-scanner benchmark: the existing 27-state bit-level +3-CNF syntax automaton is compiled without a handwritten numeric transition +table or benchmark-specific execution invariant. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace ThreeSATSyntax + +open SAT.ThreeSAT + +instance : FinEnum Syntax.TokenState := + FinEnum.ofList + (((List.finRange 4).map Syntax.TokenState.between) ++ + ((List.finRange 4).map Syntax.TokenState.inLit) ++ [.invalid]) (by + intro state + cases state <;> simp) + +instance : FinEnum Syntax.BitState := + FinEnum.ofList + (((FinEnum.toList Syntax.TokenState).map Syntax.BitState.ready) ++ + (FinEnum.toList Syntax.TokenState).flatMap fun state => + [.half state false, .half state true]) (by + intro state + cases state with + | ready state => simp + | half state bit => cases bit <;> simp) + +/-- The existing exact-3-CNF syntax automaton as a typed scanner specification. -/ +def spec : Scanner.TypedSpec Syntax.BitState where + initial := Syntax.bitStart + step := Syntax.bitStep + accept := Syntax.accept + +/-- Final verdict register inherited from the scanner layout. -/ +abbrev verdictReg : β„• := Scanner.lengthReg + +/-- Reserved-prefix input store for the syntax scanner. -/ +abbrev inputStore : List Bool β†’ Store := spec.inputStore + +/-- Structured RAM exact-3-CNF syntax program. -/ +abbrev program : Cmd := spec.program + +/-- Concrete compiled RAM exact-3-CNF syntax program. -/ +abbrev compiled : Program := spec.compiled + +/-- Exact compiled transition count. -/ +abbrev stepCount : β„• β†’ β„• := spec.stepCount + +/-- Explicit logarithmic-time budget. -/ +abbrev timeBound : β„• β†’ β„• := spec.timeBound + +/-- Explicit peak-space budget. -/ +abbrev spaceBound : β„• β†’ β„• := spec.spaceBound + +/-- Shifted quasilinear comparison function. -/ +abbrev quasilinearBound : β„• β†’ β„• := spec.quasilinearBound + +end ThreeSATSyntax + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode.lean new file mode 100644 index 0000000000..0d4c8814cb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Internal +public import LeanPool.BeyondBethe.Complexitylib.Asymptotics +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured + +/-! +# Verified structured RAM terminated-unary decoder + +This module exposes a reusable cursor decoder for the unary fields used by the +serialized-circuit format. The source proof covers both successful termination +and input exhaustion, and compilation preserves its exact transition count, +logarithmic cost, peak space, decoded value, and suffix cursor. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace UnaryDecode + +/-- Invoke the decoder loop as a resource-bounded cursor routine. + +Unlike `program_performance`, this theorem does not require the standalone +input initializer. It can therefore be sequenced after another parser step. +The loop preserves every data register at or above `inputBase`. -/ +theorem mainLoop_performance {remaining : List Bool} + {inputLength offset value : β„•} {store : Store} + (hready : CursorReady inputLength remaining offset value store) + (hbound : Internal.StoreEnvelope (inputLength + inputBase) + (inputLength + inputBase) store) : + βˆƒ final cost space, + Exec mainLoop store final (loopStepCount remaining) cost space ∧ + cost ≀ timeBound inputLength ∧ space ≀ spaceBound inputLength ∧ + (match CircuitCode.NatCode.decodePrefix? remaining with + | none => + final verdictReg = 0 ∧ final valueReg = value + remaining.length ∧ + final pointerReg = inputBase + inputLength ∧ final remainingReg = 0 + | some (decoded, rest) => + final verdictReg = 1 ∧ final valueReg = value + decoded ∧ + final pointerReg = inputBase + offset + decoded + 1 ∧ + final remainingReg = rest.length) ∧ + final activeReg = 0 ∧ + final oneReg = 1 ∧ + (βˆ€ index, inputBase ≀ index β†’ final index = store index) ∧ + Internal.StoreEnvelope (inputLength + inputBase) + (inputLength + inputBase) final := + mainLoop_measured_internal hready hbound + +/-- Source-level correctness with exact transitions and explicit resources. -/ +theorem program_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + match CircuitCode.NatCode.decodePrefix? bits with + | none => + final verdictReg = 0 ∧ final valueReg = bits.length ∧ + final pointerReg = inputBase + bits.length ∧ final remainingReg = 0 + | some (value, rest) => + final verdictReg = 1 ∧ final valueReg = value ∧ + final pointerReg = inputBase + value + 1 ∧ + final remainingReg = rest.length := + program_measured_internal bits + +/-- End-to-end concrete RAM performance and terminated-unary correctness. -/ +theorem compiled_performance (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + run compiled (stepCount bits) { pc := 0, regs := inputStore bits } = + { pc := program.codeSize, regs := final } ∧ + Halted compiled + (run compiled (stepCount bits) { pc := 0, regs := inputStore bits }) ∧ + logTimeUpto compiled (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length ∧ + spaceUpto compiled (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length ∧ + match CircuitCode.NatCode.decodePrefix? bits with + | none => + final verdictReg = 0 ∧ final valueReg = bits.length ∧ + final pointerReg = inputBase + bits.length ∧ final remainingReg = 0 + | some (value, rest) => + final verdictReg = 1 ∧ final valueReg = value ∧ + final pointerReg = inputBase + value + 1 ∧ + final remainingReg = rest.length := by + obtain ⟨final, cost, space, hexec, hcost, hspace, hresult⟩ := + program_performance bits + have hcompiled := Exec.compile_correct hexec + refine ⟨final, cost, space, hexec, hcompiled.1, Exec.compile_halted hexec, + ?_, ?_, hresult⟩ + Β· change logTimeUpto program.compile (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ timeBound bits.length + rw [hcompiled.2.1] + exact hcost + Β· change spaceUpto program.compile (stepCount bits) + { pc := 0, regs := inputStore bits } ≀ spaceBound bits.length + rw [hcompiled.2.2] + exact hspace + +/-- The explicit logarithmic-cost time budget is quasilinear. -/ +theorem timeBound_bigO_quasilinear : timeBound =O quasilinearBound := by + have hpoint : βˆ€ n, timeBound n ≀ 96 * quasilinearBound n := by + intro n + simp only [timeBound, quasilinearBound] + have hshift : n + 1 ≀ n + inputBase := by simp [inputBase] + calc + 96 * (n + 1) * (bitlen (n + inputBase) + 1) + = 96 * ((n + 1) * (bitlen (n + inputBase) + 1)) := by ring + _ ≀ 96 * ((n + inputBase) * (bitlen (n + inputBase) + 1)) := + Nat.mul_le_mul_left 96 + (Nat.mul_le_mul_right (bitlen (n + inputBase) + 1) hshift) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 96 (BigO.refl quasilinearBound)) + +/-- The explicit peak-space budget is quasilinear. -/ +theorem spaceBound_bigO_quasilinear : spaceBound =O quasilinearBound := by + have hpoint : βˆ€ n, spaceBound n ≀ 2 * quasilinearBound n := by + intro n + simp only [spaceBound, quasilinearBound] + calc + (n + inputBase) * (2 * bitlen (n + inputBase)) + = 2 * ((n + inputBase) * bitlen (n + inputBase)) := by ring + _ ≀ 2 * ((n + inputBase) * (bitlen (n + inputBase) + 1)) := + Nat.mul_le_mul_left 2 (Nat.mul_le_mul_left (n + inputBase) (by omega)) + exact (BigO.of_le hpoint).trans + (BigO.const_mul_left 2 (BigO.refl quasilinearBound)) + +end UnaryDecode + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Defs.lean new file mode 100644 index 0000000000..0af7dab336 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Defs.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Defs +public import LeanPool.BeyondBethe.Complexitylib.Circuits.Encoding.Defs + +/-! +# Structured RAM terminated-unary cursor decoder β€” definitions + +This reusable parser consumes the first terminated-unary field of an input bit +array. It is the first nested-control component of the RAM circuit evaluator: +the loop can exit either successfully at a zero terminator or unsuccessfully at +the end of the available array. +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace UnaryDecode + +/-- Success verdict: one exactly when a zero terminator was consumed. -/ +def verdictReg : β„• := 0 +/-- Decoded unary value. -/ +def valueReg : β„• := 1 +/-- Address of the next unconsumed input bit. -/ +def pointerReg : β„• := 2 +/-- Number of unconsumed input bits. -/ +def remainingReg : β„• := 3 +/-- Constant-one register. -/ +def oneReg : β„• := 4 +/-- Current input bit. -/ +def bitReg : β„• := 5 +/-- Loop activity flag. -/ +def activeReg : β„• := 6 +/-- First register occupied by input bits. -/ +def inputBase : β„• := 7 + +/-- Reserved-register input store for one unary field and its suffix. -/ +def inputStore (bits : List Bool) : Store := + Input.bitStore remainingReg inputBase bits + +/-- Initialize the parser cursor, accumulator, constant, and activity flag. -/ +def setupOps : List Basic := + [.imm verdictReg 0, .imm valueReg 0, .imm pointerReg inputBase, + .imm oneReg 1, .imm activeReg 1] + +/-- Parser initialization. -/ +def setup : Cmd := Cmd.basics setupOps + +/-- Record an unterminated field after exhausting the available input. -/ +def stopTruncated : Cmd := Cmd.basics [.imm verdictReg 0, .imm activeReg 0] + +/-- Record a successfully consumed zero terminator. -/ +def stopSuccess : Cmd := Cmd.basics [.imm verdictReg 1, .imm activeReg 0] + +/-- Consume one available bit and either stop or increment the unary value. -/ +def consume : Cmd := Cmd.seqList + [.basic (.load bitReg pointerReg), + .basic (.add pointerReg pointerReg oneReg), + .basic (.sub remainingReg remainingReg oneReg), + .ifZero bitReg stopSuccess (.basic (.add valueReg valueReg oneReg))] + +/-- One parser iteration, including the exhausted-input case. -/ +def body : Cmd := Cmd.ifZero remainingReg stopTruncated consume + +/-- Iterate until the parser records success or truncation. -/ +def mainLoop : Cmd := Cmd.whileNonzero activeReg body + +/-- Semantic calling convention for invoking `mainLoop` at an existing cursor. + +The already-consumed prefix is represented by `offset`; `value` is the current +field's unary accumulator, and `remaining` is the still-readable suffix. +Registers at or above `inputBase` are data rather than parser scratch, so the +loop's routine theorem can frame them unchanged. -/ +structure CursorReady (inputLength : β„•) (remaining : List Bool) + (offset value : β„•) (store : Store) : Prop where + /-- Consumed and remaining bits account for the original input. -/ + total_eq : offset + remaining.length = inputLength + /-- The current field accumulator cannot exceed the absolute cursor offset. -/ + value_le_offset : value ≀ offset + /-- No successful terminator has been recorded yet. -/ + verdict_eq : store verdictReg = 0 + /-- The accumulator contains the current field's consumed one-bits. -/ + value_eq : store valueReg = value + /-- The cursor points to the first remaining bit. -/ + pointer_eq : store pointerReg = inputBase + offset + /-- The remaining-length register agrees with the semantic suffix. -/ + remaining_eq : store remainingReg = remaining.length + /-- The parser's constant-one register is initialized. -/ + one_eq : store oneReg = 1 + /-- The loop is active. -/ + active_eq : store activeReg = 1 + /-- Physical input registers encode the remaining semantic suffix. -/ + input_eq : βˆ€ delta, + store (inputBase + offset + delta) = + match remaining[delta]? with + | some bit => Input.bitValue bit + | none => 0 + +/-- Exact transition count for invoking `mainLoop` at a semantic suffix. -/ +def loopStepCount (remaining : List Bool) : β„• := + match CircuitCode.NatCode.decodePrefix? remaining with + | none => 10 * remaining.length + 6 + | some (value, _) => 10 * value + 11 + +/-- Complete terminated-unary decoder. -/ +def program : Cmd := Cmd.seq setup mainLoop + +/-- Concrete compiled RAM decoder. -/ +def compiled : Program := program.compile + +/-- Exact compiled transition count through the first terminator or exhaustion. -/ +def stepCount (bits : List Bool) : β„• := + match CircuitCode.NatCode.decodePrefix? bits with + | none => 10 * bits.length + 11 + | some (value, _) => 10 * value + 16 + +/-- Explicit logarithmic-time budget. -/ +def timeBound (inputLength : β„•) : β„• := + 96 * (inputLength + 1) * (bitlen (inputLength + inputBase) + 1) + +/-- Explicit peak-space budget. -/ +def spaceBound (inputLength : β„•) : β„• := + (inputLength + inputBase) * (2 * bitlen (inputLength + inputBase)) + +/-- Shifted quasilinear comparison function. -/ +def quasilinearBound (inputLength : β„•) : β„• := + (inputLength + inputBase) * (bitlen (inputLength + inputBase) + 1) + +end UnaryDecode + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Internal.lean new file mode 100644 index 0000000000..00d1aafe76 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/RandomAccessMachine/Structured/UnaryDecode/Internal.lean @@ -0,0 +1,761 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.Internal.Resources +public import LeanPool.BeyondBethe.Complexitylib.Models.RandomAccessMachine.Structured.UnaryDecode.Defs + +/-! +# Structured RAM terminated-unary decoder β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace RAM + +namespace Structured + +namespace UnaryDecode + +open Internal + +private abbrev StoreBound (inputLength : β„•) (store : Store) : Prop := + StoreEnvelope (inputLength + inputBase) (inputLength + inputBase) store + +private abbrev width (inputLength : β„•) : β„• := + valueWidth (inputLength + inputBase) + +private abbrev resourceSpace (inputLength : β„•) : β„• := + envelopeSpace (inputLength + inputBase) (inputLength + inputBase) + +private theorem envelopeSpace_eq_spaceBound (inputLength : β„•) : + resourceSpace inputLength = spaceBound inputLength := by + simp [resourceSpace, envelopeSpace, spaceBound, two_mul] + +private theorem inputStore_bound (bits : List Bool) : + StoreBound bits.length (inputStore bits) := by + apply Internal.Input.bitStoreEnvelope + Β· simp [remainingReg, inputBase] + Β· simp [inputBase, Nat.add_comm] + Β· omega + Β· simp [inputBase] + +private def setupStore (bits : List Bool) : Store := + Basic.execList setupOps (inputStore bits) + +private theorem setup_measured (bits : List Bool) : + MeasuredRuns setup (inputStore bits) (setupStore bits) 5 + (20 * width bits.length) (resourceSpace bits.length) ∧ + StoreBound bits.length (setupStore bits) := by + have hinitial := inputStore_bound bits + have hpreserve : βˆ€ op, op ∈ setupOps β†’ βˆ€ store, + StoreBound bits.length store β†’ StoreBound bits.length (op.exec store) := by + intro op hop store hstore + simp [setupOps] at hop + rcases hop with rfl | rfl | rfl | rfl | rfl + Β· apply hstore.execBasic (.imm verdictReg 0) <;> simp [verdictReg, inputBase] + Β· apply hstore.execBasic (.imm valueReg 0) <;> simp [valueReg, inputBase] + Β· apply hstore.execBasic (.imm pointerReg inputBase) + Β· simp [pointerReg, inputBase] + Β· simp [Internal.Basic.writeValue, inputBase] + Β· apply hstore.execBasic (.imm oneReg 1) <;> simp [oneReg, inputBase] + Β· apply hstore.execBasic (.imm activeReg 1) <;> simp [activeReg, inputBase] + simpa [setup, setupStore, setupOps] using + MeasuredRuns.basicsEnvelope setupOps (inputStore bits) hinitial hpreserve + +private structure LoopInv (inputLength : β„•) (remaining : List Bool) + (offset value : β„•) (store : Store) : Prop where + total_eq : offset + remaining.length = inputLength + value_le_offset : value ≀ offset + store_bound : StoreBound inputLength store + verdict_eq : store verdictReg = 0 + value_eq : store valueReg = value + pointer_eq : store pointerReg = inputBase + offset + remaining_eq : store remainingReg = remaining.length + one_eq : store oneReg = 1 + active_eq : store activeReg = 1 + input_eq : βˆ€ delta, + store (inputBase + offset + delta) = + match remaining[delta]? with + | some bit => Input.bitValue bit + | none => 0 + +private theorem loopInv_of_cursorReady {inputLength offset value : β„•} + {remaining : List Bool} {store : Store} + (hready : CursorReady inputLength remaining offset value store) + (hbound : StoreBound inputLength store) : + LoopInv inputLength remaining offset value store where + total_eq := hready.total_eq + value_le_offset := hready.value_le_offset + store_bound := hbound + verdict_eq := hready.verdict_eq + value_eq := hready.value_eq + pointer_eq := hready.pointer_eq + remaining_eq := hready.remaining_eq + one_eq := hready.one_eq + active_eq := hready.active_eq + input_eq := hready.input_eq + +private theorem setup_inv (bits : List Bool) + (hbound : StoreBound bits.length (setupStore bits)) : + LoopInv bits.length bits 0 0 (setupStore bits) := by + constructor + Β· simp + Β· simp + Β· exact hbound + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, oneReg, activeReg] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, oneReg, activeReg] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, oneReg, activeReg, inputBase] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, remainingReg, oneReg, activeReg, + inputStore, Input.bitStore] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, oneReg, activeReg] + Β· simp [setupStore, setupOps, Basic.execList, Basic.exec, verdictReg, + valueReg, pointerReg, oneReg, activeReg] + Β· intro offset + have h1 : 7 + offset β‰  1 := by omega + have h2 : 7 + offset β‰  2 := by omega + have h3 : 7 + offset β‰  3 := by omega + have h4 : 7 + offset β‰  4 := by omega + have h6 : 7 + offset β‰  6 := by omega + simp [setupStore, setupOps, Basic.execList, Basic.exec, Function.update_of_ne, + h1, h2, h3, h4, h6, inputStore, Input.bitStore, + inputBase, verdictReg, valueReg, pointerReg, remainingReg, oneReg, + activeReg] + rfl + +private def truncatedStore (store : Store) : Store := + Basic.execList [.imm verdictReg 0, .imm activeReg 0] store + +private def loaded (store : Store) : Store := + (Basic.load bitReg pointerReg).exec store + +private def moved (store : Store) : Store := + (Basic.add pointerReg pointerReg oneReg).exec (loaded store) + +private def decremented (store : Store) : Store := + (Basic.sub remainingReg remainingReg oneReg).exec (moved store) + +private def successStore (store : Store) : Store := + Basic.execList [.imm verdictReg 1, .imm activeReg 0] (decremented store) + +private def continuedStore (store : Store) : Store := + (Basic.add valueReg valueReg oneReg).exec (decremented store) + +private theorem loaded_bound {inputLength : β„•} {store : Store} + (hstore : StoreBound inputLength store) : + StoreBound inputLength (loaded store) := by + apply hstore.execBasic (.load bitReg pointerReg) + Β· simp [bitReg, inputBase] + Β· simpa [Internal.Basic.writeValue] using hstore.value_le (store pointerReg) + +private theorem loaded_bit {bit : Bool} {rest : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) offset value store) : + loaded store bitReg = Input.bitValue bit := by + simp only [loaded, Basic.exec, Function.update_self] + rw [hinv.pointer_eq] + simpa using hinv.input_eq 0 + +private theorem moved_bound {bit : Bool} {rest : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) offset value store) : + StoreBound inputLength (moved store) := by + have hloaded := loaded_bound hinv.store_bound + apply hloaded.execBasic (.add pointerReg pointerReg oneReg) + Β· simp [pointerReg, inputBase] + Β· have hpointer : loaded store pointerReg = inputBase + offset := by + simpa [loaded, Basic.exec, bitReg, pointerReg] using hinv.pointer_eq + have hone : loaded store oneReg = 1 := by + simpa [loaded, Basic.exec, bitReg, oneReg] using hinv.one_eq + change loaded store pointerReg + loaded store oneReg ≀ inputLength + inputBase + rw [hpointer, hone] + have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + omega + +private theorem decremented_bound {bit : Bool} {rest : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength (bit :: rest) offset value store) : + StoreBound inputLength (decremented store) := by + have hmoved := moved_bound hinv + apply hmoved.execBasic (.sub remainingReg remainingReg oneReg) + Β· simp [remainingReg, inputBase] + Β· exact Nat.le_trans (Nat.sub_le _ _) (hmoved.value_le remainingReg) + +private theorem success_bound {rest : List Bool} {inputLength offset value : β„•} + {store : Store} + (hinv : LoopInv inputLength (false :: rest) offset value store) : + StoreBound inputLength (successStore store) := by + have hdecremented := decremented_bound hinv + have hverdict := hdecremented.execBasic (.imm verdictReg 1) + (by simp [verdictReg, inputBase]) (by simp [Internal.Basic.writeValue, inputBase]) + apply hverdict.execBasic (.imm activeReg 0) <;> + simp [activeReg, inputBase] + +private theorem continued_bound {rest : List Bool} {inputLength offset value : β„•} + {store : Store} + (hinv : LoopInv inputLength (true :: rest) offset value store) : + StoreBound inputLength (continuedStore store) := by + have hdecremented := decremented_bound hinv + apply hdecremented.execBasic (.add valueReg valueReg oneReg) + Β· simp [valueReg, inputBase] + Β· have hvalue : decremented store valueReg = value := by + simpa [decremented, moved, loaded, Basic.exec, remainingReg, pointerReg, + bitReg, valueReg] using hinv.value_eq + have hone : decremented store oneReg = 1 := by + simpa [decremented, moved, loaded, Basic.exec, remainingReg, pointerReg, + bitReg, valueReg, oneReg] using hinv.one_eq + change decremented store valueReg + decremented store oneReg ≀ + inputLength + inputBase + rw [hvalue, hone] + have hvalueLe := hinv.value_le_offset + have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + simp only [inputBase] + omega + +private theorem continued_high (store : Store) (index : β„•) + (hindex : inputBase ≀ index) : continuedStore store index = store index := by + have hvalue : index β‰  valueReg := by + simp only [inputBase, valueReg] at hindex ⊒ + omega + have hpointer : index β‰  pointerReg := by + simp only [inputBase, pointerReg] at hindex ⊒ + omega + have hremaining : index β‰  remainingReg := by + simp only [inputBase, remainingReg] at hindex ⊒ + omega + have hbit : index β‰  bitReg := by + simp only [inputBase, bitReg] at hindex ⊒ + omega + simp [continuedStore, decremented, moved, loaded, Basic.exec, + Function.update_of_ne, hvalue, hpointer, hremaining, hbit] + +private theorem truncated_high (store : Store) (index : β„•) + (hindex : inputBase ≀ index) : truncatedStore store index = store index := by + have hverdict : index β‰  verdictReg := by + simp only [inputBase, verdictReg] at hindex ⊒ + omega + have hactive : index β‰  activeReg := by + simp only [inputBase, activeReg] at hindex ⊒ + omega + simp [truncatedStore, Basic.execList, Basic.exec, Function.update_of_ne, + hverdict, hactive] + +private theorem success_high (store : Store) (index : β„•) + (hindex : inputBase ≀ index) : successStore store index = store index := by + have hverdict : index β‰  verdictReg := by + simp only [inputBase, verdictReg] at hindex ⊒ + omega + have hpointer : index β‰  pointerReg := by + simp only [inputBase, pointerReg] at hindex ⊒ + omega + have hremaining : index β‰  remainingReg := by + simp only [inputBase, remainingReg] at hindex ⊒ + omega + have hbit : index β‰  bitReg := by + simp only [inputBase, bitReg] at hindex ⊒ + omega + have hactive : index β‰  activeReg := by + simp only [inputBase, activeReg] at hindex ⊒ + omega + simp [successStore, decremented, moved, loaded, Basic.execList, Basic.exec, + Function.update_of_ne, hverdict, hpointer, hremaining, hbit, hactive] + +private theorem truncated_measured {inputLength : β„•} {store : Store} + (hstore : StoreBound inputLength store) : + MeasuredRuns stopTruncated store (truncatedStore store) 2 + (8 * width inputLength) (resourceSpace inputLength) ∧ + StoreBound inputLength (truncatedStore store) := by + have hpreserve : βˆ€ op, op ∈ ([Basic.imm verdictReg 0, + Basic.imm activeReg 0] : List Basic) β†’ + βˆ€ current, StoreBound inputLength current β†’ + StoreBound inputLength (op.exec current) := by + intro op hop current hcurrent + simp at hop + rcases hop with rfl | rfl + Β· apply hcurrent.execBasic (.imm verdictReg 0) <;> + simp [verdictReg, inputBase] + Β· apply hcurrent.execBasic (.imm activeReg 0) <;> + simp [activeReg, inputBase] + simpa [stopTruncated, truncatedStore] using + MeasuredRuns.basicsEnvelope [.imm verdictReg 0, .imm activeReg 0] + store hstore hpreserve + +private theorem false_body_measured {rest : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength (false :: rest) offset value store) : + MeasuredRuns body store (successStore store) 8 + (32 * width inputLength) (resourceSpace inputLength) ∧ + StoreBound inputLength (successStore store) := by + have hloaded := loaded_bound hinv.store_bound + have hmoved := moved_bound hinv + have hdecremented := decremented_bound hinv + have hsuccess := success_bound hinv + have hload := MeasuredRuns.basicEnvelope (.load bitReg pointerReg) store + hinv.store_bound hloaded + have hmove := MeasuredRuns.basicEnvelope (.add pointerReg pointerReg oneReg) + (loaded store) hloaded hmoved + have hdecrement := MeasuredRuns.basicEnvelope + (.sub remainingReg remainingReg oneReg) (moved store) hmoved hdecremented + have hstop : MeasuredRuns stopSuccess (decremented store) (successStore store) 2 + (8 * width inputLength) (resourceSpace inputLength) := by + have hpreserve : βˆ€ op, op ∈ ([Basic.imm verdictReg 1, + Basic.imm activeReg 0] : List Basic) β†’ + βˆ€ current, StoreBound inputLength current β†’ + StoreBound inputLength (op.exec current) := by + intro op hop current hcurrent + simp at hop + rcases hop with rfl | rfl + Β· apply hcurrent.execBasic (.imm verdictReg 1) <;> + simp [verdictReg, inputBase] + Β· apply hcurrent.execBasic (.imm activeReg 0) <;> + simp [activeReg, inputBase] + exact (by simpa [stopSuccess, successStore] using + (MeasuredRuns.basicsEnvelope [Basic.imm verdictReg 1, + Basic.imm activeReg 0] (decremented store) hdecremented hpreserve).1) + have hbit : decremented store bitReg = 0 := by + have hloadedBit := loaded_bit hinv + simpa [decremented, moved, Basic.exec, remainingReg, pointerReg, bitReg, + oneReg, Input.bitValue] using hloadedBit + have hbranch := MeasuredRuns.ifZeroEnvelope (onNonzero := + .basic (.add valueReg valueReg oneReg)) hbit hdecremented hstop + have hconsume := hload.seq (hmove.seq (hdecrement.seq hbranch)) + have hremaining : store remainingReg β‰  0 := by + rw [hinv.remaining_eq] + simp + have hrun := MeasuredRuns.ifNonzeroEnvelope (onZero := stopTruncated) + hremaining hinv.store_bound (by + simpa [consume, Cmd.seqList] using hconsume) + refine ⟨?_, hsuccess⟩ + apply MeasuredRuns.weakenCost (by simpa [body] using! hrun) + change 3 * width inputLength + + (4 * width inputLength + + (4 * width inputLength + + (4 * width inputLength + + (width inputLength + 8 * width inputLength)))) ≀ + 32 * width inputLength + omega + +private theorem true_body_measured {rest : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength (true :: rest) offset value store) : + MeasuredRuns body store (continuedStore store) 8 + (32 * width inputLength) (resourceSpace inputLength) ∧ + LoopInv inputLength rest (offset + 1) (value + 1) (continuedStore store) := by + have hloaded := loaded_bound hinv.store_bound + have hmoved := moved_bound hinv + have hdecremented := decremented_bound hinv + have hcontinued := continued_bound hinv + have hload := MeasuredRuns.basicEnvelope (.load bitReg pointerReg) store + hinv.store_bound hloaded + have hmove := MeasuredRuns.basicEnvelope (.add pointerReg pointerReg oneReg) + (loaded store) hloaded hmoved + have hdecrement := MeasuredRuns.basicEnvelope + (.sub remainingReg remainingReg oneReg) (moved store) hmoved hdecremented + have hadd := MeasuredRuns.basicEnvelope (.add valueReg valueReg oneReg) + (decremented store) hdecremented hcontinued + have hbit : decremented store bitReg β‰  0 := by + have hloadedBit := loaded_bit hinv + have heq : decremented store bitReg = 1 := by + simpa [decremented, moved, Basic.exec, remainingReg, pointerReg, bitReg, + oneReg, Input.bitValue] using hloadedBit + omega + have hbranch := MeasuredRuns.ifNonzeroEnvelope (onZero := stopSuccess) + hbit hdecremented hadd + have hconsume := hload.seq (hmove.seq (hdecrement.seq hbranch)) + have hremaining : store remainingReg β‰  0 := by + rw [hinv.remaining_eq] + simp + have hrun := MeasuredRuns.ifNonzeroEnvelope (onZero := stopTruncated) + hremaining hinv.store_bound (by + simpa [consume, Cmd.seqList] using hconsume) + constructor + Β· apply MeasuredRuns.weakenCost (by simpa [body] using! hrun) + change 3 * width inputLength + + (4 * width inputLength + + (4 * width inputLength + + (4 * width inputLength + + (3 * width inputLength + 4 * width inputLength)))) ≀ + 32 * width inputLength + omega + Β· constructor + Β· have htotal := hinv.total_eq + simp only [List.length_cons] at htotal + omega + Β· have hvalueLe := hinv.value_le_offset + omega + Β· exact hcontinued + Β· simpa [continuedStore, decremented, moved, loaded, Basic.exec, + verdictReg, valueReg, pointerReg, remainingReg, oneReg, bitReg, + activeReg] using hinv.verdict_eq + Β· have hvalue : store valueReg = value := hinv.value_eq + have hone : store oneReg = 1 := hinv.one_eq + simp [continuedStore, decremented, moved, loaded, Basic.exec, + valueReg, pointerReg, remainingReg, oneReg, bitReg] + have hvalue' : store 1 = value := by simpa [valueReg] using hvalue + have hone' : store 4 = 1 := by simpa [oneReg] using hone + omega + Β· have hpointer : store pointerReg = inputBase + offset := hinv.pointer_eq + have hone : store oneReg = 1 := hinv.one_eq + simp [continuedStore, decremented, moved, loaded, Basic.exec, + valueReg, pointerReg, remainingReg, oneReg, bitReg] + have hpointer' : store 2 = inputBase + offset := by + simpa [pointerReg] using hpointer + have hone' : store 4 = 1 := by simpa [oneReg] using hone + omega + Β· have hremaining : store remainingReg = rest.length + 1 := by + simpa using hinv.remaining_eq + have hone : store oneReg = 1 := hinv.one_eq + simp [continuedStore, decremented, moved, loaded, Basic.exec, + valueReg, pointerReg, remainingReg, oneReg, bitReg] + have hremaining' : store 3 = rest.length + 1 := by + simpa [remainingReg] using hremaining + have hone' : store 4 = 1 := by simpa [oneReg] using hone + omega + Β· simpa [continuedStore, decremented, moved, loaded, Basic.exec, + verdictReg, valueReg, pointerReg, remainingReg, oneReg, bitReg, + activeReg] using hinv.one_eq + Β· simpa [continuedStore, decremented, moved, loaded, Basic.exec, + verdictReg, valueReg, pointerReg, remainingReg, oneReg, bitReg, + activeReg] using hinv.active_eq + Β· intro offset + rw [continued_high store _ (by simp [inputBase]; omega)] + have hinput := hinv.input_eq (offset + 1) + convert! hinput using 1 + all_goals simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + +private theorem decodeAux?_eq_map (bits : List Bool) (acc : β„•) : + CircuitCode.NatCode.decodeAux? bits acc = + (CircuitCode.NatCode.decodePrefix? bits).map fun result => + (acc + result.1, result.2) := by + induction bits generalizing acc with + | nil => simp [CircuitCode.NatCode.decodeAux?, CircuitCode.NatCode.decodePrefix?] + | cons bit rest ih => + cases bit with + | false => + simp [CircuitCode.NatCode.decodeAux?, CircuitCode.NatCode.decodePrefix?] + | true => + rw [CircuitCode.NatCode.decodeAux?] + rw [ih (acc + 1)] + have htrue : CircuitCode.NatCode.decodePrefix? (true :: rest) = + CircuitCode.NatCode.decodeAux? rest 1 := rfl + rw [htrue] + rw [ih 1] + cases hdecode : CircuitCode.NatCode.decodePrefix? rest with + | none => simp + | some result => + rcases result with ⟨value, suffix⟩ + simp [Nat.add_assoc] + +private theorem decodePrefix?_true (rest : List Bool) : + CircuitCode.NatCode.decodePrefix? (true :: rest) = + (CircuitCode.NatCode.decodePrefix? rest).map fun result => + (result.1 + 1, result.2) := by + rw [CircuitCode.NatCode.decodePrefix?, CircuitCode.NatCode.decodeAux?] + rw [decodeAux?_eq_map] + cases hdecode : CircuitCode.NatCode.decodePrefix? rest with + | none => simp + | some result => + rcases result with ⟨value, suffix⟩ + simp [Nat.add_comm] + +private theorem loop_measured {remaining : List Bool} + {inputLength offset value : β„•} {store : Store} + (hinv : LoopInv inputLength remaining offset value store) : + βˆƒ final, + MeasuredRuns mainLoop store final + (match CircuitCode.NatCode.decodePrefix? remaining with + | none => 10 * remaining.length + 6 + | some (value, _) => 10 * value + 11) + (64 * (remaining.length + 1) * width inputLength) + (resourceSpace inputLength) ∧ + (match CircuitCode.NatCode.decodePrefix? remaining with + | none => + final verdictReg = 0 ∧ final valueReg = value + remaining.length ∧ + final pointerReg = inputBase + inputLength ∧ final remainingReg = 0 + | some (decoded, rest) => + final verdictReg = 1 ∧ final valueReg = value + decoded ∧ + final pointerReg = inputBase + offset + decoded + 1 ∧ + final remainingReg = rest.length) ∧ + final activeReg = 0 ∧ + final oneReg = 1 ∧ + (βˆ€ index, inputBase ≀ index β†’ final index = store index) ∧ + StoreBound inputLength final := by + induction remaining generalizing offset value store with + | nil => + have hremaining : store remainingReg = 0 := by + simpa using hinv.remaining_eq + obtain ⟨hbody, htruncatedBound⟩ := truncated_measured hinv.store_bound + have hbodyRun := MeasuredRuns.ifZeroEnvelope (onNonzero := consume) + hremaining hinv.store_bound hbody + have hactive : store activeReg β‰  0 := by rw [hinv.active_eq]; decide + have hfinalActive : truncatedStore store activeReg = 0 := by + simp [truncatedStore, Basic.execList, Basic.exec, activeReg, verdictReg] + have hstop := MeasuredRuns.whileZeroEnvelope (body := body) + hfinalActive htruncatedBound + have hrun := MeasuredRuns.whileNonzeroEnvelope hactive hinv.store_bound + (by simpa [body] using hbodyRun) hstop + refine ⟨truncatedStore store, ?_, ?_, ?_, ?_, ?_, htruncatedBound⟩ + Β· apply MeasuredRuns.weakenCost (by simpa [mainLoop] using! hrun) + change 3 * width inputLength + + (width inputLength + 8 * width inputLength) + + width inputLength ≀ + 64 * ([].length + 1) * width inputLength + simp only [List.length_nil, zero_add] + omega + Β· simp only [CircuitCode.NatCode.decodePrefix?, + CircuitCode.NatCode.decodeAux?] + have htotal := hinv.total_eq + have hvalue := hinv.value_eq + have hpointer := hinv.pointer_eq + have hremainingStore := hinv.remaining_eq + simp only [List.length_nil, Nat.add_zero] at htotal + have hvalue' : store 1 = value := by simpa [valueReg] using hvalue + have hpointer' : store 2 = inputBase + offset := by + simpa [pointerReg] using hpointer + have hremaining' : store 3 = 0 := by + simpa [remainingReg] using hremainingStore + simp [truncatedStore, Basic.execList, Basic.exec, verdictReg, valueReg, + pointerReg, remainingReg, activeReg, hvalue', hpointer', hremaining'] + omega + Β· simp [truncatedStore, Basic.execList, Basic.exec, activeReg, verdictReg] + Β· simpa [truncatedStore, Basic.execList, Basic.exec, oneReg, activeReg, + verdictReg] using hinv.one_eq + Β· intro index hindex + exact truncated_high store index hindex + | cons bit rest ih => + cases bit with + | false => + obtain ⟨hbody, hsuccessBound⟩ := false_body_measured hinv + have hactive : store activeReg β‰  0 := by rw [hinv.active_eq]; decide + have hfinalActive : successStore store activeReg = 0 := by + simp [successStore, Basic.execList, Basic.exec, activeReg, verdictReg, + decremented, moved, loaded, remainingReg, pointerReg, bitReg] + have hstop := MeasuredRuns.whileZeroEnvelope (body := body) + hfinalActive hsuccessBound + have hrun := MeasuredRuns.whileNonzeroEnvelope hactive hinv.store_bound + hbody hstop + refine ⟨successStore store, ?_, ?_, ?_, ?_, ?_, hsuccessBound⟩ + Β· apply MeasuredRuns.weakenCost (by simpa [mainLoop] using! hrun) + change 3 * width inputLength + 32 * width inputLength + + width inputLength ≀ + 64 * ((false :: rest).length + 1) * width inputLength + calc + _ = 36 * width inputLength := by ring + _ ≀ (64 * (rest.length + 2)) * width inputLength := + Nat.mul_le_mul_right _ (by omega) + _ = _ := by simp only [List.length_cons] + Β· simp only [CircuitCode.NatCode.decodePrefix?, + CircuitCode.NatCode.decodeAux?] + have hvalue := hinv.value_eq + have hpointer := hinv.pointer_eq + have hremaining : store remainingReg = rest.length + 1 := by + simpa using hinv.remaining_eq + have hone := hinv.one_eq + simp [successStore, Basic.execList, decremented, moved, loaded, + Basic.exec, verdictReg, valueReg, pointerReg, remainingReg, oneReg, + bitReg, activeReg] + have hvalue' : store 1 = value := by simpa [valueReg] using hvalue + have hpointer' : store 2 = inputBase + offset := by + simpa [pointerReg] using hpointer + have hremaining' : store 3 = rest.length + 1 := by + simpa [remainingReg] using hremaining + have hone' : store 4 = 1 := by simpa [oneReg] using hone + omega + Β· simp [successStore, Basic.execList, Basic.exec, activeReg, + verdictReg, decremented, moved, loaded, remainingReg, pointerReg, + bitReg] + Β· simpa [successStore, Basic.execList, Basic.exec, oneReg, activeReg, + verdictReg, decremented, moved, loaded, remainingReg, pointerReg, + bitReg] using hinv.one_eq + Β· intro index hindex + exact success_high store index hindex + | true => + obtain ⟨hbody, hnextInv⟩ := true_body_measured hinv + obtain ⟨final, hloop, hfinal, hactiveFinal, honeFinal, hframe, + hfinalBound⟩ := ih hnextInv + have hactive : store activeReg β‰  0 := by rw [hinv.active_eq]; decide + have hrun := MeasuredRuns.whileNonzeroEnvelope hactive hinv.store_bound + hbody hloop + refine ⟨final, ?_, ?_, hactiveFinal, honeFinal, ?_, hfinalBound⟩ + Β· rw [decodePrefix?_true] + cases hdecode : CircuitCode.NatCode.decodePrefix? rest with + | none => + rw [hdecode] at hrun + simp only at hrun + have hrun' : MeasuredRuns mainLoop store final + (10 * (rest.length + 1) + 6) + (3 * width inputLength + 32 * width inputLength + + 64 * (rest.length + 1) * width inputLength) + (resourceSpace inputLength) := by + rw [mainLoop] + convert! hrun using 1 + all_goals omega + apply MeasuredRuns.weakenCost hrun' + change 3 * width inputLength + 32 * width inputLength + + (64 * (rest.length + 1) * width inputLength) ≀ + 64 * ((true :: rest).length + 1) * width inputLength + calc + _ = (64 * (rest.length + 1) + 35) * width inputLength := by ring + _ ≀ (64 * (rest.length + 2)) * width inputLength := + Nat.mul_le_mul_right _ (by omega) + _ = _ := by simp only [List.length_cons] + | some result => + rcases result with ⟨value, suffix⟩ + rw [hdecode] at hrun + simp only at hrun + have hrun' : MeasuredRuns mainLoop store final + (10 * (value + 1) + 11) + (3 * width inputLength + 32 * width inputLength + + 64 * (rest.length + 1) * width inputLength) + (resourceSpace inputLength) := by + rw [mainLoop] + convert! hrun using 1 + all_goals omega + apply MeasuredRuns.weakenCost hrun' + change 3 * width inputLength + 32 * width inputLength + + (64 * (rest.length + 1) * width inputLength) ≀ + 64 * ((true :: rest).length + 1) * width inputLength + calc + _ = (64 * (rest.length + 1) + 35) * width inputLength := by ring + _ ≀ (64 * (rest.length + 2)) * width inputLength := + Nat.mul_le_mul_right _ (by omega) + _ = _ := by simp only [List.length_cons] + Β· rw [decodePrefix?_true] + cases hdecode : CircuitCode.NatCode.decodePrefix? rest with + | none => + simpa [hdecode, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] + using hfinal + | some result => + rcases result with ⟨decoded, suffix⟩ + rw [hdecode] at hfinal + simp only [Option.map_some] + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hfinal + Β· intro index hindex + rw [hframe index hindex] + exact continued_high store index hindex + +theorem mainLoop_measured_internal {remaining : List Bool} + {inputLength offset value : β„•} {store : Store} + (hready : CursorReady inputLength remaining offset value store) + (hbound : Internal.StoreEnvelope (inputLength + inputBase) + (inputLength + inputBase) store) : + βˆƒ final cost space, + Exec mainLoop store final (loopStepCount remaining) cost space ∧ + cost ≀ timeBound inputLength ∧ space ≀ spaceBound inputLength ∧ + (match CircuitCode.NatCode.decodePrefix? remaining with + | none => + final verdictReg = 0 ∧ final valueReg = value + remaining.length ∧ + final pointerReg = inputBase + inputLength ∧ final remainingReg = 0 + | some (decoded, rest) => + final verdictReg = 1 ∧ final valueReg = value + decoded ∧ + final pointerReg = inputBase + offset + decoded + 1 ∧ + final remainingReg = rest.length) ∧ + final activeReg = 0 ∧ + final oneReg = 1 ∧ + (βˆ€ index, inputBase ≀ index β†’ final index = store index) ∧ + Internal.StoreEnvelope (inputLength + inputBase) + (inputLength + inputBase) final := by + have hinv := loopInv_of_cursorReady hready hbound + obtain ⟨final, hrun, hresult, hactive, hone, hframe, hfinalBound⟩ := + loop_measured hinv + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hrun + have hremaining : remaining.length ≀ inputLength := by + have htotal := hready.total_eq + omega + have hcostBound : + 64 * (remaining.length + 1) * width inputLength ≀ + timeBound inputLength := by + rw [timeBound] + change 64 * (remaining.length + 1) * width inputLength ≀ + 96 * (inputLength + 1) * width inputLength + apply Nat.mul_le_mul_right + omega + have hspaceBound : space ≀ spaceBound inputLength := by + rw [← envelopeSpace_eq_spaceBound] + exact hspace + refine ⟨final, cost, space, ?_, le_trans hcost hcostBound, hspaceBound, + hresult, hactive, hone, hframe, hfinalBound⟩ + simpa [loopStepCount] using! hexec + +theorem program_measured_internal (bits : List Bool) : + βˆƒ final cost space, + Exec program (inputStore bits) final (stepCount bits) cost space ∧ + cost ≀ timeBound bits.length ∧ space ≀ spaceBound bits.length ∧ + match CircuitCode.NatCode.decodePrefix? bits with + | none => + final verdictReg = 0 ∧ final valueReg = bits.length ∧ + final pointerReg = inputBase + bits.length ∧ final remainingReg = 0 + | some (value, rest) => + final verdictReg = 1 ∧ final valueReg = value ∧ + final pointerReg = inputBase + value + 1 ∧ + final remainingReg = rest.length := by + obtain ⟨hsetup, hsetupBound⟩ := setup_measured bits + have hsetupInv := setup_inv bits hsetupBound + obtain ⟨final, hloop, hfinal, _hactive, _hone, _hframe, _hfinalBound⟩ := + loop_measured hsetupInv + have hseq := hsetup.seq hloop + have hcostLe : + 20 * width bits.length + + 64 * (bits.length + 1) * width bits.length ≀ + timeBound bits.length := by + rw [timeBound] + change 20 * width bits.length + + 64 * (bits.length + 1) * width bits.length ≀ + 96 * (bits.length + 1) * width bits.length + calc + _ = (64 * (bits.length + 1) + 20) * width bits.length := by ring + _ ≀ (96 * (bits.length + 1)) * width bits.length := + Nat.mul_le_mul_right _ (by omega) + _ = _ := by ring + have hprogram := hseq.weakenCost hcostLe + have hprogram' : MeasuredRuns program (inputStore bits) final + (stepCount bits) (timeBound bits.length) (resourceSpace bits.length) := by + rw [program] + cases hdecode : CircuitCode.NatCode.decodePrefix? bits with + | none => + rw [hdecode] at hprogram + simp only at hprogram + convert! hprogram using 1 + all_goals simp [stepCount, hdecode] + all_goals omega + | some result => + rcases result with ⟨value, suffix⟩ + rw [hdecode] at hprogram + simp only at hprogram + convert! hprogram using 1 + all_goals simp [stepCount, hdecode] + all_goals omega + obtain ⟨cost, space, hexec, hcost, hspace⟩ := hprogram' + have hspace' : space ≀ spaceBound bits.length := by + rw [← envelopeSpace_eq_spaceBound] + exact hspace + refine ⟨final, cost, space, hexec, hcost, hspace', ?_⟩ + cases hdecode : CircuitCode.NatCode.decodePrefix? bits with + | none => + rw [hdecode] at hfinal + simpa [hdecode] using hfinal + | some result => + rcases result with ⟨value, suffix⟩ + rw [hdecode] at hfinal + simpa [hdecode] using hfinal + +end UnaryDecode + +end Structured + +end RAM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine.lean new file mode 100644 index 0000000000..c5ef1befec --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine.lean @@ -0,0 +1,905 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Rat.Init +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# Turing machines + +This file defines the library's base model of computation: multi-tape +deterministic and nondeterministic Turing machines over a fixed four-symbol +alphabet, with named input/work/output tapes. The model's shape follows +Arora–Barak (*Computational Complexity: A Modern Approach*, Definitions +1.1–1.4 and 2.1), with the conventions below enforced structurally. + +## Main definitions + +- `Ξ“` β€” the tape alphabet `{0, 1, β–‘, β–·}` (read alphabet) +- `Ξ“w` β€” the writable alphabet `{0, 1, β–‘}` (write alphabet; `β–·` cannot be written) +- `Dir3` β€” three-way tape head direction (left, right, stay) +- `Tape` β€” a one-sided infinite tape; cell 0 is leftmost and permanently `β–·` +- `Cfg` β€” a machine configuration with named tapes (input, work, output) +- `TM` β€” a deterministic multi-tape Turing machine (AB Definition 1.1) +- `NTM` β€” a nondeterministic TM with two transition functions (AB Definition 2.1) +- `TM.stepRel`, `TM.reaches`, `TM.reachesIn` β€” deterministic step relation and reachability +- `NTM.trace` β€” execute an NTM for a fixed choice sequence (canonical NTM execution) +- `Tape.HasOutput` β€” predicate: tape contains a given binary string as output +- `TM.ComputesInTime` β€” computing a function in bounded time (AB Definition 1.4) +- `TM.Computes` β€” computing a function (existential over time bound) +- `TM.Accepts`, `TM.AcceptsInTime` β€” deterministic acceptance +- `NTM.Accepts`, `NTM.AcceptsInTime` β€” nondeterministic acceptance (existential) +- `Cfg.WithinAuxSpace`, `Cfg.WithinDecisionSpace` β€” honest tape-space bounds +- `TM.DecidesInTime`, `NTM.DecidesInTime` β€” deciding a language within a time bound +- `TM.DecidesInTimeSpace` β€” deciding with simultaneous time and space bounds +- `NTM.acceptCount`, `NTM.acceptProb` β€” counting/probabilistic acceptance +- `TM.toNTM` β€” embed a DTM into an NTM + +## Design notes + +- **One-sided tapes**: `Tape` uses `head : β„•` and `cells : β„• β†’ Ξ“`. Cell 0 is leftmost; + moving left at position 0 is a no-op (`Nat` subtraction saturates). +- **Immutable cell 0**: `Tape.write` is a no-op when the head is at position 0, ensuring + `β–·` at cell 0 is permanent. Combined with `Ξ“w` (which excludes `β–·`), this guarantees `β–·` + appears only at cell 0 on every tape. +- **Read vs write alphabet**: The transition function reads `Ξ“ = {0, 1, β–‘, β–·}` but writes + `Ξ“w = {0, 1, β–‘}`, so `Ξ΄` structurally cannot write `β–·`. +- **Finite state**: `Q` carries `[Fintype Q]`; the state space is finite. +- **Output**: Read from cell 1 of the output tape (first cell after `β–·`); machine output + is the binary string written after `β–·`. +- **Named tapes**: `Cfg` has `input`, `work`, `output` fields rather than `Fin k β†’ Tape`, + making the read-only/read-write distinction structural. +- **NTM execution**: Defined via `trace` (a fixed choice sequence), not a relational step. +-/ + + +@[expose] public section + +namespace Complexity + +/-- The tape alphabet Ξ“ = {0, 1, β–‘, β–·}. -/ +inductive Ξ“ where + | zero | one | blank | start + deriving Repr, DecidableEq + +instance : Fintype Ξ“ where + elems := {.zero, .one, .blank, .start} + complete := fun x => by cases x <;> simp + +instance : Inhabited Ξ“ := βŸ¨Ξ“.blank⟩ + +/-- The writable alphabet Ξ“w = {0, 1, β–‘}. The start symbol `β–·` cannot be written by a + transition function β€” this is enforced structurally by using `Ξ“w` in the output of `Ξ΄`. -/ +inductive Ξ“w where + | zero | one | blank + deriving Repr, DecidableEq + +instance : Fintype Ξ“w where + elems := {.zero, .one, .blank} + complete := fun x => by cases x <;> simp + +/-- Embed a writable symbol into the full alphabet. -/ +@[simp] def Ξ“w.toΞ“ : Ξ“w β†’ Ξ“ + | .zero => .zero + | .one => .one + | .blank => .blank + +instance : Coe Ξ“w Ξ“ where coe := Ξ“w.toΞ“ + +/-- A writable symbol is never the left-end marker. -/ +theorem Ξ“w.toΞ“_ne_start (s : Ξ“w) : s.toΞ“ β‰  Ξ“.start := by + cases s <;> decide + +/-- Convert a boolean to an alphabet symbol. -/ +def Ξ“.ofBool : Bool β†’ Ξ“ + | false => .zero + | true => .one + +/-- A Boolean tape symbol is never the left-end marker. -/ +theorem Ξ“.ofBool_ne_start (b : Bool) : Ξ“.ofBool b β‰  Ξ“.start := by + cases b <;> decide + +/-- A Boolean tape symbol is never blank. -/ +theorem Ξ“.ofBool_ne_blank (b : Bool) : Ξ“.ofBool b β‰  Ξ“.blank := by + cases b <;> decide + +/-- Convert a boolean to a writable symbol. -/ +def Ξ“w.ofBool : Bool β†’ Ξ“w + | false => .zero + | true => .one + +theorem Ξ“w.ofBool_toΞ“ (b : Bool) : (Ξ“w.ofBool b).toΞ“ = Ξ“.ofBool b := by + cases b <;> rfl + +/-- Three-way tape head direction: left, right, or stay. -/ +inductive Dir3 where + | left | right | stay + deriving Repr, DecidableEq + +instance : Fintype Dir3 where + elems := {.left, .right, .stay} + complete := fun x => by cases x <;> simp + +/-- A one-sided infinite tape. Cell 0 is the leftmost cell and permanently + contains `β–·`. The head cannot move left of cell 0 (moving left at position 0 + is a no-op via `Nat` subtraction). Writing at cell 0 is a no-op, + preserving `β–·`. -/ +@[ext] +structure Tape where + /-- The head position; cell 0 is the leftmost cell. -/ + head : β„• + /-- The tape contents, one symbol per cell. -/ + cells : β„• β†’ Ξ“ + +namespace Tape + +/-- Read the symbol under the head. -/ +def read (t : Tape) : Ξ“ := t.cells t.head + +/-- Write a symbol at the head position. Writing at cell 0 is a no-op, + preserving the start symbol `β–·`. -/ +def write (t : Tape) (s : Ξ“) : Tape := + if t.head = 0 then t + else { t with cells := Function.update t.cells t.head s } + +/-- Writing changes tape contents but preserves the head position. -/ +theorem write_head (t : Tape) (s : Ξ“) : (t.write s).head = t.head := by + simp only [write] + split <;> rfl + +/-- Move the head according to a three-way direction. + Moving left at position 0 stays at 0 (`Nat` subtraction saturates). -/ +def move (t : Tape) (d : Dir3) : Tape := + match d with + | .left => { t with head := t.head - 1 } + | .right => { t with head := t.head + 1 } + | .stay => t + +/-- Moving changes the head position but preserves tape contents. -/ +theorem move_cells (t : Tape) (d : Dir3) : (t.move d).cells = t.cells := by + cases d <;> rfl + +/-- Moving changes the head position by at most one. -/ +theorem head_move_le (t : Tape) (d : Dir3) : (t.move d).head ≀ t.head + 1 := by + cases d <;> (simp only [move]; omega) + +/-- The tape contains output `y : List Bool` starting at cell 1: + cells 1 through |y| match `y`, and cell |y| + 1 is blank. + Output is the binary string written on the output tape after `β–·`. -/ +def HasOutput (t : Tape) (y : List Bool) : Prop := + (βˆ€ (i : β„•) (h : i < y.length), + t.cells (i + 1) = Ξ“.ofBool (y[i]'h)) ∧ + t.cells (y.length + 1) = Ξ“.blank + +/-- `HasOutput` depends only on the tape cells, not the head position. -/ +theorem hasOutput_congr {t₁ tβ‚‚ : Tape} (h : t₁.cells = tβ‚‚.cells) (y : List Bool) : + t₁.HasOutput y ↔ tβ‚‚.HasOutput y := by + simp only [HasOutput, h] + +instance decidableHasOutput (t : Tape) (y : List Bool) : Decidable (t.HasOutput y) := + if h : (βˆ€ i : Fin y.length, t.cells (i.val + 1) = Ξ“.ofBool (y[i.val]'i.isLt)) ∧ + t.cells (y.length + 1) = Ξ“.blank + then isTrue ⟨fun i hi => h.1 ⟨i, hi⟩, h.2⟩ + else isFalse (fun ⟨h1, h2⟩ => h ⟨fun i => h1 i.val i.isLt, h2⟩) + +/-- Write a symbol and move in one step. -/ +abbrev writeAndMove (t : Tape) (s : Ξ“) (d : Dir3) : Tape := + (t.write s).move d + +/-- `t.StartInvariant` says the left-end marker `β–·` sits at cell 0 and + nowhere else β€” the standing shape of every tape reachable from an + initial configuration, since writes exclude `β–·` and cell 0 is + immutable. -/ +def StartInvariant (t : Tape) : Prop := + t.cells 0 = Ξ“.start ∧ βˆ€ j, 1 ≀ j β†’ t.cells j β‰  Ξ“.start + +/-- Under the invariant, a head at position β‰₯ 1 never reads `β–·`. -/ +theorem StartInvariant.read_ne_start {t : Tape} (h : t.StartInvariant) + (hhead : 1 ≀ t.head) : t.read β‰  Ξ“.start := by + simp only [read]; exact h.2 t.head hhead + +/-- Writing (any `Ξ“w` symbol) preserves the invariant. -/ +theorem StartInvariant.write {t : Tape} (h : t.StartInvariant) (s : Ξ“w) : + (t.write s.toΞ“).StartInvariant := by + unfold Tape.write + split + Β· exact h + Β· next hne => + refine ⟨?_, fun j hj => ?_⟩ + Β· show Function.update t.cells t.head s.toΞ“ 0 = Ξ“.start + rw [Function.update_of_ne (Ne.symm hne)]; exact h.1 + Β· show Function.update t.cells t.head s.toΞ“ j β‰  Ξ“.start + by_cases hje : j = t.head + Β· subst hje + rw [Function.update_self] + cases s <;> simp [Ξ“w.toΞ“] + Β· rw [Function.update_of_ne hje]; exact h.2 j hj + +/-- Moving preserves the invariant (cells unchanged). -/ +theorem StartInvariant.move {t : Tape} (h : t.StartInvariant) (d : Dir3) : + (t.move d).StartInvariant := by + cases d <;> exact h + +/-- Writing a `Ξ“w` symbol and moving preserves the invariant. -/ +theorem StartInvariant.writeAndMove {t : Tape} (h : t.StartInvariant) + (s : Ξ“w) (d : Dir3) : (t.writeAndMove s.toΞ“ d).StartInvariant := + (h.write s).move d + +/-- One write-and-move step advances the head by at most one. -/ +theorem head_writeAndMove_le (t : Tape) (s : Ξ“) (d : Dir3) : + (t.writeAndMove s d).head ≀ t.head + 1 := by + have h := head_move_le (t.write s) d + rwa [write_head] at h + +end Tape + +/-- Initialize a tape: `β–·` at cell 0, `contents` at cells 1, 2, ..., `β–‘` elsewhere. + Head starts at position 0 (on `β–·`). -/ +def Tape.init (contents : List Ξ“) : Tape where + head := 0 + cells := fun i => + if i = 0 then Ξ“.start + else (contents[i - 1]?).getD Ξ“.blank + +/-- An initialized tape starts with its head on the left-end marker. -/ +@[simp] theorem Tape.init_head (contents : List Ξ“) : + (Tape.init contents).head = 0 := rfl + +/-- Cell zero of an initialized tape is the left-end marker. -/ +@[simp] theorem Tape.init_cells_zero (contents : List Ξ“) : + (Tape.init contents).cells 0 = Ξ“.start := by + simp [Tape.init] + +/-- Cell `i + 1` of an initialized tape contains item `i`, or blank when `i` + lies beyond the initialized contents. -/ +theorem Tape.init_cells_succ (contents : List Ξ“) (i : β„•) : + (Tape.init contents).cells (i + 1) = (contents[i]?).getD Ξ“.blank := by + simp [Tape.init] + +/-- Cells beyond the initialized contents are blank. -/ +theorem Tape.init_cells_ge (contents : List Ξ“) (i : β„•) + (h : contents.length ≀ i) : + (Tape.init contents).cells (i + 1) = Ξ“.blank := by + rw [Tape.init_cells_succ, List.getElem?_eq_none h] + rfl + +/-- Every positive-indexed cell of the empty initialized tape is blank. -/ +@[simp] theorem Tape.init_nil_cells_succ (i : β„•) : + (Tape.init []).cells (i + 1) = Ξ“.blank := by + exact Tape.init_cells_ge [] i (by simp) + +/-- No positive-indexed cell of the empty initialized tape is a start marker. -/ +theorem Tape.init_nil_cells_ne_start (j : β„•) (hj : 1 ≀ j) : + (Tape.init []).cells j β‰  Ξ“.start := by + obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_nil_cells_succ] + decide + +/-- Within the initialized Boolean contents, cell `i + 1` stores bit `i`. -/ +theorem Tape.init_ofBool_cells_lt (contents : List Bool) (i : β„•) + (h : i < contents.length) : + (Tape.init (contents.map Ξ“.ofBool)).cells (i + 1) = Ξ“.ofBool (contents[i]'h) := by + rw [Tape.init_cells_succ] + have hmap : i < (contents.map Ξ“.ofBool).length := by simpa using h + rw [List.getElem?_eq_getElem hmap] + simp + +/-- Beyond the initialized Boolean contents, cell `i + 1` is blank. -/ +theorem Tape.init_ofBool_cells_ge (contents : List Bool) (i : β„•) + (h : contents.length ≀ i) : + (Tape.init (contents.map Ξ“.ofBool)).cells (i + 1) = Ξ“.blank := by + exact Tape.init_cells_ge (contents.map Ξ“.ofBool) i (by simpa using h) + +/-- No positive-indexed cell of a Boolean-initialized tape contains the + left-end marker. -/ +theorem Tape.init_ofBool_cells_ne_start (contents : List Bool) (j : β„•) (hj : 1 ≀ j) : + (Tape.init (contents.map Ξ“.ofBool)).cells j β‰  Ξ“.start := by + obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hi : i < contents.length + Β· rw [Tape.init_ofBool_cells_lt contents i hi] + exact Ξ“.ofBool_ne_start _ + Β· rw [Tape.init_ofBool_cells_ge contents i (Nat.le_of_not_gt hi)] + decide + +/-- Moving an empty initialized tape to cell one reads blank. -/ +@[simp] theorem Tape.init_nil_move_right_read : + ((Tape.init []).move Dir3.right).read = Ξ“.blank := by + simp [Tape.read, Tape.move] + +/-- A Boolean-initialized tape moved to its first data cell never reads the + left-end marker. -/ +theorem Tape.init_ofBool_move_right_read_ne_start (contents : List Bool) : + ((Tape.init (contents.map Ξ“.ofBool)).move Dir3.right).read β‰  Ξ“.start := by + simp only [Tape.read, Tape.move] + exact Tape.init_ofBool_cells_ne_start contents 1 (by omega) + +/-- An initialized tape whose contents avoid `β–·` satisfies the invariant. -/ +theorem Tape.StartInvariant.init (xs : List Ξ“) (hxs : βˆ€ a ∈ xs, a β‰  Ξ“.start) : + (Tape.init xs).StartInvariant := by + refine ⟨rfl, ?_⟩ + intro j hj + simp only [Tape.init, show j β‰  0 by omega, ↓reduceIte] + cases h : xs[j - 1]? with + | none => simp + | some a => + simp only [Option.getD_some] + exact hxs a (List.mem_of_getElem? h) + +/-- A Boolean-initialized tape satisfies the invariant. -/ +theorem Tape.StartInvariant.init_ofBool (xs : List Bool) : + (Tape.init (xs.map Ξ“.ofBool)).StartInvariant := by + refine Tape.StartInvariant.init _ ?_ + intro a ha + rw [List.mem_map] at ha + obtain ⟨b, _, rfl⟩ := ha + cases b <;> simp [Ξ“.ofBool] + +/-- The empty initialized tape satisfies the invariant. -/ +theorem Tape.StartInvariant.init_nil : (Tape.init []).StartInvariant := by + refine ⟨rfl, ?_⟩ + intro j hj + simp only [Tape.init, show j β‰  0 by omega, ↓reduceIte] + simp + +/-- After stepping onto cell 1 of an empty initialized tape, no positive + cell holds the left-end marker. -/ +theorem Tape.init_nil_move_right_cells_ne_start (j : β„•) (hj : j β‰₯ 1) : + ((Tape.init []).move Dir3.right).cells j β‰  Ξ“.start := by + rw [Tape.move_cells] + simp [Tape.init, show j β‰  0 by omega] + +/-- Moving the head does not introduce a left-end marker in the positive cells + of a Boolean-initialized tape. -/ +theorem Tape.init_ofBool_move_right_cells_ne_start (contents : List Bool) : + βˆ€ j, 1 ≀ j β†’ + ((Tape.init (contents.map Ξ“.ofBool)).move Dir3.right).cells j β‰  Ξ“.start := by + intro j hj + rw [Tape.move_cells] + exact Tape.init_ofBool_cells_ne_start contents j hj + +/-- A language is a set of binary strings. -/ +abbrev Language := Set (List Bool) + +/-- A configuration of a Turing machine with `n` work tapes: + a read-only input tape, `n` read-write work tapes, and a read-write output tape. -/ +structure Cfg (n : β„•) (Q : Type) where + /-- The current machine state. -/ + state : Q + /-- The read-only input tape. -/ + input : Tape + /-- The `n` read-write work tapes. -/ + work : Fin n β†’ Tape + /-- The read-write output tape. -/ + output : Tape + +namespace Cfg + +/-- Two machine configurations are equal when their named components agree. -/ +@[ext] theorem ext {c c' : Cfg n Q} + (hstate : c.state = c'.state) (hinput : c.input = c'.input) + (hwork : c.work = c'.work) (houtput : c.output = c'.output) : c = c' := by + cases c + cases c' + simp_all + +/-- Initial configuration for any TM: input on the input tape, all tapes start with `β–·`. -/ +abbrev init (qstart : Q) (x : List Bool) : Cfg n Q := + { state := qstart + input := Tape.init (x.map Ξ“.ofBool) + work := fun _ => Tape.init [] + output := Tape.init [] } + +/-- A configuration is halted when its state equals the halt state. -/ +abbrev isHalted (qhalt : Q) (c : Cfg n Q) : Prop := + c.state = qhalt + +/-- The auxiliary-space bound for a configuration on an input of length + `inputLength`. Work-tape cells through `space` are available, while the + input itself and its first trailing blank are free; travel farther into the + input tape's blank tail is charged against `space`. + + This predicate deliberately omits the output tape. It is suitable for + function computation only when the machine also satisfies the one-way + output discipline `TM.IsTransducer`. -/ +def WithinAuxSpace (c : Cfg n Q) (inputLength space : β„•) : Prop := + (βˆ€ i, (c.work i).head ≀ space) ∧ + c.input.head ≀ inputLength + space + 1 + +/-- The space bound for a language-decider configuration. In addition to + `WithinAuxSpace`, the output head is bounded by `space + 1`: cell 1 is the + free verdict cell, and any farther two-way output-tape travel is charged. -/ +def WithinDecisionSpace (c : Cfg n Q) (inputLength space : β„•) : Prop := + c.WithinAuxSpace inputLength space ∧ c.output.head ≀ space + 1 + +end Cfg + +/-- A deterministic Turing machine with `n` work tapes. + + The machine has a read-only input tape, `n` read-write work tapes, and a read-write + output tape. The transition function reads `Ξ“` from all tape heads but writes only + `Ξ“w` (excluding `β–·`) to work and output tapes. `Q` is finite. -/ +structure TM (n : β„•) where + /-- The (finite) type of machine states. -/ + Q : Type + [decEq : DecidableEq Q] + [finQ : Fintype Q] + /-- The designated start state. -/ + qstart : Q + /-- The designated halt state. -/ + qhalt : Q + /-- The transition function: from the current state and the symbols under + the input, work, and output heads, produce the next state, the symbols + to write on the work and output tapes, and a direction for every head. -/ + Ξ΄ : Q β†’ Ξ“ β†’ (Fin n β†’ Ξ“) β†’ Ξ“ β†’ + Q Γ— (Fin n β†’ Ξ“w) Γ— Ξ“w Γ— Dir3 Γ— (Fin n β†’ Dir3) Γ— Dir3 + /-- Reading the left-end marker forces that head to move right, so no head + ever falls off the left edge. -/ + Ξ΄_right_of_start : βˆ€ (q : Q) (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“), + let (_, _, _, inDir, workDirs, outDir) := Ξ΄ q iHead wHeads oHead + (iHead = Ξ“.start β†’ inDir = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ workDirs i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ outDir = Dir3.right) + +attribute [instance] TM.decEq TM.finQ + +/-- A nondeterministic Turing machine with two transition functions. + + The same structure is used for probabilistic TMs β€” only the acceptance + criterion differs (existential for NTM, counting for PTM). `Q` is finite. -/ +structure NTM (n : β„•) where + /-- The (finite) type of machine states. -/ + Q : Type + [decEq : DecidableEq Q] + [finQ : Fintype Q] + /-- The designated start state. -/ + qstart : Q + /-- The designated halt state. -/ + qhalt : Q + /-- The two transition functions, selected by the `Bool` choice bit; each + has the same shape as the deterministic `TM.Ξ΄`. -/ + Ξ΄ : Bool β†’ Q β†’ Ξ“ β†’ (Fin n β†’ Ξ“) β†’ Ξ“ β†’ + Q Γ— (Fin n β†’ Ξ“w) Γ— Ξ“w Γ— Dir3 Γ— (Fin n β†’ Dir3) Γ— Dir3 + /-- Reading the left-end marker forces that head to move right, on both + branches. -/ + Ξ΄_right_of_start : βˆ€ (b : Bool) (q : Q) (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“), + let (_, _, _, inDir, workDirs, outDir) := Ξ΄ b q iHead wHeads oHead + (iHead = Ξ“.start β†’ inDir = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ workDirs i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ outDir = Dir3.right) + +attribute [instance] NTM.decEq NTM.finQ + +namespace TM + +variable {n : β„•} + +/-- Step a deterministic TM by one step. Returns `none` if halted. -/ +def step (tm : TM n) (c : Cfg n tm.Q) : Option (Cfg n tm.Q) := + if c.state = tm.qhalt then none + else + let (q', workWrites, outWrite, inDir, workDirs, outDir) := + tm.Ξ΄ c.state c.input.read (fun i => (c.work i).read) c.output.read + some + { state := q' + input := c.input.move inDir + work := fun i => (c.work i).writeAndMove (workWrites i) (workDirs i) + output := c.output.writeAndMove outWrite outDir } + +/-- Initial configuration: input on the input tape, all tapes start with `β–·`. -/ +abbrev initCfg (tm : TM n) (x : List Bool) : Cfg n tm.Q := + Cfg.init tm.qstart x + +/-- A configuration is halted when its state is `qhalt`. -/ +abbrev halted (tm : TM n) (c : Cfg n tm.Q) : Prop := + Cfg.isHalted tm.qhalt c + +/-- If `step` returns `some`, the machine was not halted. -/ +theorem state_ne_qhalt_of_step {tm : TM n} {c c' : Cfg n tm.Q} + (h : tm.step c = some c') : c.state β‰  tm.qhalt := + fun heq => by simp [step, heq] at h + +/-- One-step relation for a deterministic TM. -/ +def stepRel (tm : TM n) (c c' : Cfg n tm.Q) : Prop := tm.step c = some c' + +/-- Reflexive-transitive closure of the step relation. -/ +def reaches (tm : TM n) : Cfg n tm.Q β†’ Cfg n tm.Q β†’ Prop := + Relation.ReflTransGen tm.stepRel + +/-- Reachability in exactly `t` steps. -/ +inductive reachesIn (tm : TM n) : β„• β†’ Cfg n tm.Q β†’ Cfg n tm.Q β†’ Prop where + | zero : reachesIn tm 0 c c + | step : tm.step c = some c'' β†’ reachesIn tm t c'' c' β†’ reachesIn tm (t + 1) c c' + +/-- DTM accepts `x`: reaches `qhalt` with output cell 1 (after `β–·`) = `1`. -/ +def Accepts (tm : TM n) (x : List Bool) : Prop := + βˆƒ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ c'.output.cells 1 = Ξ“.one + +/-- DTM accepts `x` within `T` steps. -/ +def AcceptsInTime (tm : TM n) (x : List Bool) (T : β„•) : Prop := + βˆƒ c' t, t ≀ T ∧ tm.reachesIn t (tm.initCfg x) c' ∧ tm.halted c' ∧ + c'.output.cells 1 = Ξ“.one + +/-- DTM decides `L` within time bound `T(n)`: halts on all inputs within `T(|x|)` steps, + outputting `1` for `x ∈ L` and `0` for `x βˆ‰ L`. -/ +def DecidesInTime (tm : TM n) (L : Language) (T : β„• β†’ β„•) : Prop := + βˆ€ x, βˆƒ c' t, t ≀ T x.length ∧ tm.reachesIn t (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ (x βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) + +/-- DTM computes function `f` in time `T(n)`: + for every input `x`, the machine halts within `T(|x|)` steps with `f(x)` + written on the output tape. -/ +def ComputesInTime (tm : TM n) (f : List Bool β†’ List Bool) (T : β„• β†’ β„•) : Prop := + βˆ€ x, βˆƒ c' t, t ≀ T x.length ∧ tm.reachesIn t (tm.initCfg x) c' ∧ tm.halted c' ∧ + c'.output.HasOutput (f x) + +/-- DTM computes function `f` (existential version of `ComputesInTime`). -/ +def Computes (tm : TM n) (f : List Bool β†’ List Bool) : Prop := + βˆƒ T, tm.ComputesInTime f T + +/-- DTM decides `L` using at most `S(|x|)` auxiliary space. Every reachable + configuration has work heads at position at most `S(|x|)`, input head at + position at most `|x| + S(|x|) + 1`, and output head at position at most + `S(|x|) + 1`. Thus the input region, its first trailing blank, and output + verdict cell 1 are free, but neither infinite tape can become uncharged + two-way workspace. The machine halts on all inputs with correct output. -/ +def DecidesInSpace (tm : TM n) (L : Language) (S : β„• β†’ β„•) : Prop := + (βˆ€ x c', tm.reaches (tm.initCfg x) c' β†’ + c'.WithinDecisionSpace x.length (S x.length)) ∧ + βˆ€ x, βˆƒ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ (x βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) + +/-- DTM decides `L` within time `T(|x|)` and space `S(|x|)` simultaneously: + a single machine halts in bounded time with correct output, and every + reachable configuration satisfies the honest auxiliary-space convention of + `Cfg.WithinDecisionSpace`. -/ +def DecidesInTimeSpace (tm : TM n) (L : Language) (T S : β„• β†’ β„•) : Prop := + (βˆ€ x c', tm.reaches (tm.initCfg x) c' β†’ + c'.WithinDecisionSpace x.length (S x.length)) ∧ + βˆ€ x, βˆƒ c' t, t ≀ T x.length ∧ tm.reachesIn t (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ (x βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) + +/-- The output tape head never moves left β€” the machine is a *transducer*. + This prevents earlier output from being reread as workspace while allowing + unbounded output length. `ComputesInSpace` requires this discipline; the + decision-space predicates separately bound two-way output-head travel. -/ +def IsTransducer (tm : TM n) : Prop := + βˆ€ q iHead wHeads oHead, + let (_, _, _, _, _, outDir) := tm.Ξ΄ q iHead wHeads oHead + outDir β‰  Dir3.left + +/-- DTM computes function `f` using at most `S(|x|)` auxiliary space. + Work-tape travel and input-head travel beyond the input's first trailing + blank are bounded by `Cfg.WithinAuxSpace`. The output length is not bounded: + instead, `IsTransducer` makes the output one-way so it cannot serve as + read-write workspace. -/ +def ComputesInSpace (tm : TM n) (f : List Bool β†’ List Bool) (S : β„• β†’ β„•) : Prop := + tm.IsTransducer ∧ + (βˆ€ x c', tm.reaches (tm.initCfg x) c' β†’ c'.WithinAuxSpace x.length (S x.length)) ∧ + βˆ€ x, βˆƒ c', tm.reaches (tm.initCfg x) c' ∧ tm.halted c' ∧ c'.output.HasOutput (f x) + +/-- Transitivity: if `c₁` reaches `cβ‚‚` in `t₁` steps and `cβ‚‚` reaches `c₃` + in `tβ‚‚` steps, then `c₁` reaches `c₃` in `t₁ + tβ‚‚` steps. -/ +theorem reachesIn_trans (tm : TM n) {t₁ tβ‚‚ : β„•} {c₁ cβ‚‚ c₃ : Cfg n tm.Q} + (h₁ : tm.reachesIn t₁ c₁ cβ‚‚) (hβ‚‚ : tm.reachesIn tβ‚‚ cβ‚‚ c₃) : + tm.reachesIn (t₁ + tβ‚‚) c₁ c₃ := by + induction h₁ with + | zero => simp; exact hβ‚‚ + | step hstep _ ih => + show tm.reachesIn (_ + 1 + tβ‚‚) _ _ + rw [Nat.add_right_comm] + exact reachesIn.step hstep (ih hβ‚‚) + +/-- Bounded reachability implies unbounded reachability. -/ +theorem reaches_of_reachesIn {tm : TM n} {t : β„•} {c c' : Cfg n tm.Q} + (h : tm.reachesIn t c c') : tm.reaches c c' := by + induction h with + | zero => exact Relation.ReflTransGen.refl + | step hs _ ih => exact Relation.ReflTransGen.head hs ih + +/-- `step` returns `none` exactly when the configuration is halted. The two ways + a DTM can "stop" β€” no successor configuration and being in `qhalt` β€” + coincide. -/ +theorem step_eq_none_iff_halted {tm : TM n} {c : Cfg n tm.Q} : + tm.step c = none ↔ c.state = tm.qhalt := by + by_cases h : c.state = tm.qhalt <;> simp [step, h] + +/-- Append a single step to the end of a run: reaching `c'` in `t` steps and then + stepping once to `c''` gives a run of `t + 1` steps. The `snoc` counterpart to + the `cons`-shaped `reachesIn.step`. -/ +theorem reachesIn_snoc {tm : TM n} {t : β„•} {c c' c'' : Cfg n tm.Q} + (h : tm.reachesIn t c c') (hstep : tm.step c' = some c'') : + tm.reachesIn (t + 1) c c'' := + tm.reachesIn_trans h (reachesIn.step hstep reachesIn.zero) + +/-- A zero-step run goes nowhere. Inversion form of `reachesIn.zero`, usable + when the machine is a compound expression on which `cases` cannot + abstract the configuration indices. -/ +theorem reachesIn_zero_iff {tm : TM n} {c c' : Cfg n tm.Q} : + tm.reachesIn 0 c c' ↔ c = c' := + ⟨fun h => by cases h; rfl, fun h => h β–Έ reachesIn.zero⟩ + +/-- A run of `t + 1` steps factors as one step followed by a run of `t` + steps. Inversion form of `reachesIn.step`. -/ +theorem reachesIn_succ_iff {tm : TM n} {t : β„•} {c c' : Cfg n tm.Q} : + tm.reachesIn (t + 1) c c' ↔ + βˆƒ c'', tm.step c = some c'' ∧ tm.reachesIn t c'' c' := + ⟨fun h => by cases h with | step hstep hrest => exact ⟨_, hstep, hrest⟩, + fun ⟨_, hstep, hrest⟩ => reachesIn.step hstep hrest⟩ + +/-- `AcceptsInTime` implies `Accepts` β€” forget the time bound. -/ +theorem accepts_of_acceptsInTime {tm : TM n} {x : List Bool} {T : β„•} + (h : tm.AcceptsInTime x T) : tm.Accepts x := by + obtain ⟨c', t, _, hreach, hhalt, hcell⟩ := h + exact ⟨c', reaches_of_reachesIn hreach, hhalt, hcell⟩ + +/-- DTM acceptance is monotone in the time bound. -/ +theorem AcceptsInTime.mono {tm : TM n} {x : List Bool} {T T' : β„•} (hle : T ≀ T') + (h : tm.AcceptsInTime x T) : tm.AcceptsInTime x T' := by + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := h + exact ⟨c', t, ht.trans hle, hreach, hhalt, hout⟩ + +/-- DTM decision is monotone under pointwise enlargement of the time bound. -/ +theorem DecidesInTime.mono {tm : TM n} {L : Language} {T T' : β„• β†’ β„•} + (hle : βˆ€ m, T m ≀ T' m) (h : tm.DecidesInTime L T) : tm.DecidesInTime L T' := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hyes, hno⟩ := h x + exact ⟨c', t, ht.trans (hle x.length), hreach, hhalt, hyes, hno⟩ + +/-- DTM computation is monotone under pointwise enlargement of the time bound. -/ +theorem ComputesInTime.mono {tm : TM n} {f : List Bool β†’ List Bool} + {T T' : β„• β†’ β„•} (hle : βˆ€ m, T m ≀ T' m) (h : tm.ComputesInTime f T) : + tm.ComputesInTime f T' := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := h x + exact ⟨c', t, ht.trans (hle x.length), hreach, hhalt, hout⟩ + +end TM + +namespace NTM + +variable {n : β„•} + +/-- Execute an NTM for `T` steps with a fixed choice sequence. + Stops early if the machine reaches `qhalt`. -/ +def trace (tm : NTM n) : + (T : β„•) β†’ (Fin T β†’ Bool) β†’ Cfg n tm.Q β†’ Cfg n tm.Q + | 0, _, c => c + | T + 1, choices, c => + if c.state = tm.qhalt then c + else + let b := choices ⟨0, Nat.zero_lt_succ T⟩ + let (q', workWrites, outWrite, inDir, workDirs, outDir) := + tm.Ξ΄ b c.state c.input.read (fun i => (c.work i).read) c.output.read + let c' : Cfg n tm.Q := + { state := q' + input := c.input.move inDir + work := fun i => (c.work i).writeAndMove (workWrites i) (workDirs i) + output := c.output.writeAndMove outWrite outDir } + tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) c' + +/-- Initial configuration: input on the input tape, all tapes start with `β–·`. -/ +abbrev initCfg (tm : NTM n) (x : List Bool) : Cfg n tm.Q := + Cfg.init tm.qstart x + +/-- A configuration is halted when its state is `qhalt`. -/ +abbrev halted (tm : NTM n) (c : Cfg n tm.Q) : Prop := + Cfg.isHalted tm.qhalt c + +/-- Once halted, the NTM trace stays at the same configuration regardless of + the remaining choices. -/ +theorem trace_halted (tm : NTM n) {c : Cfg n tm.Q} + (T : β„•) (choices : Fin T β†’ Bool) (h : tm.halted c) : + tm.trace T choices c = c := by + induction T with + | zero => rfl + | succ T _ => simp [NTM.trace, h] + +/-- An NTM trace preserves the unique left-end marker on the input, work, + and output tapes. -/ +theorem trace_startInvariant (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) + (hinp : c.input.StartInvariant) + (hwork : βˆ€ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + (tm.trace T choices c).input.StartInvariant ∧ + (βˆ€ i, ((tm.trace T choices c).work i).StartInvariant) ∧ + (tm.trace T choices c).output.StartInvariant := by + induction T generalizing c with + | zero => exact ⟨hinp, hwork, hout⟩ + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simpa [trace, hhalt] using And.intro hinp (And.intro hwork hout) + Β· simp only [trace, hhalt, ite_false] + apply ih + Β· exact hinp.move _ + Β· intro i + exact (hwork i).writeAndMove _ _ + Β· exact hout.writeAndMove _ _ + +/-- Every tape in a trace from `initCfg` has a unique left-end marker. -/ +theorem trace_initCfg_startInvariant (tm : NTM n) (x : List Bool) (T : β„•) + (choices : Fin T β†’ Bool) : + (tm.trace T choices (tm.initCfg x)).input.StartInvariant ∧ + (βˆ€ i, ((tm.trace T choices (tm.initCfg x)).work i).StartInvariant) ∧ + (tm.trace T choices (tm.initCfg x)).output.StartInvariant := + tm.trace_startInvariant T choices (tm.initCfg x) + (Tape.StartInvariant.init_ofBool x) (fun _ => Tape.StartInvariant.init_nil) + Tape.StartInvariant.init_nil + +/-- NTM accepts `x`: there exists a time bound and choice sequence leading to + `qhalt` with output cell 1 = `1`. -/ +def Accepts (tm : NTM n) (x : List Bool) : Prop := + βˆƒ (T : β„•) (choices : Fin T β†’ Bool), + let c' := tm.trace T choices (tm.initCfg x) + tm.halted c' ∧ c'.output.cells 1 = Ξ“.one + +/-- NTM accepts `x` within `T` steps: there exists a choice sequence of length `T` + leading to `qhalt` with output cell 1 = `1`. -/ +def AcceptsInTime (tm : NTM n) (x : List Bool) (T : β„•) : Prop := + βˆƒ choices : Fin T β†’ Bool, + let c' := tm.trace T choices (tm.initCfg x) + tm.halted c' ∧ c'.output.cells 1 = Ξ“.one + +/-- `AcceptsInTime` implies `Accepts` β€” package the time bound existentially. -/ +theorem accepts_of_acceptsInTime {tm : NTM n} {x : List Bool} {T : β„•} + (h : tm.AcceptsInTime x T) : tm.Accepts x := + ⟨T, h⟩ + +/-- `Accepts` is exactly `βˆƒ T, AcceptsInTime x T`. -/ +theorem accepts_iff_exists_acceptsInTime {tm : NTM n} {x : List Bool} : + tm.Accepts x ↔ βˆƒ T, tm.AcceptsInTime x T := Iff.rfl + +/-- Running the NTM trace for more steps preserves the final configuration: + if the machine halts within `T` steps and the extended choice sequence + agrees with the original on the first `T` positions, the extra steps are + no-ops. -/ +theorem trace_mono (tm : NTM n) {T T' : β„•} (hle : T ≀ T') + {choices : Fin T β†’ Bool} {choices' : Fin T' β†’ Bool} {c : Cfg n tm.Q} + (hagree : βˆ€ i : Fin T, choices' ⟨i.val, by omega⟩ = choices i) + (h : tm.halted (tm.trace T choices c)) : + tm.trace T' choices' c = tm.trace T choices c := by + induction T generalizing T' choices' c with + | zero => + have hhalt : tm.halted c := by simpa [NTM.trace] using h + simpa [NTM.trace] using tm.trace_halted T' choices' hhalt + | succ T ih => + rcases T' with _ | T' + Β· omega + by_cases hc : c.state = tm.qhalt + Β· have hcT : tm.trace (T + 1) choices c = c := by simp [NTM.trace, hc] + have hcT' : tm.trace (T' + 1) choices' c = c := by simp [NTM.trace, hc] + rw [hcT, hcT'] + Β· have hch0 := hagree ⟨0, Nat.zero_lt_succ _⟩ + have hle' : T ≀ T' := Nat.le_of_succ_le_succ hle + simp only [NTM.trace, hc, hch0, ite_false] at h ⊒ + exact ih hle' (fun i => hagree ⟨i.val + 1, by omega⟩) h + +/-- NTM acceptance is monotone in the time bound: `AcceptsInTime x T` implies + `AcceptsInTime x T'` for any `T' β‰₯ T`. Extra steps are no-ops once halted. -/ +theorem AcceptsInTime.mono {tm : NTM n} {x : List Bool} {T T' : β„•} (hle : T ≀ T') + (h : tm.AcceptsInTime x T) : tm.AcceptsInTime x T' := by + obtain ⟨choices, hhalt, hout⟩ := h + let choices' : Fin T' β†’ Bool := fun i => + if hi : i.val < T then choices ⟨i.val, hi⟩ else false + have heq := tm.trace_mono hle (choices := choices) (choices' := choices') + (c := tm.initCfg x) (fun i => by simp [choices', i.isLt]) hhalt + exact ⟨choices', heq β–Έ hhalt, heq β–Έ hout⟩ + +/-- All computation paths of the NTM halt within `T(|x|)` steps, for every + input `x` and every choice sequence. This is the core time-boundedness + condition shared by `DecidesInTime`, `BPTIME`, and `NTM.IsPPT`. -/ +def AllPathsHaltIn (tm : NTM n) (T : β„• β†’ β„•) : Prop := + βˆ€ x (choices : Fin (T x.length) β†’ Bool), + tm.halted (tm.trace (T x.length) choices (tm.initCfg x)) + +/-- NTM decides `L` within time bound `T(n)`: + all computation paths halt within `T(|x|)` steps, and accepting paths exist + iff `x ∈ L` (AB Definition 2.1). -/ +def DecidesInTime (tm : NTM n) (L : Language) (T : β„• β†’ β„•) : Prop := + tm.AllPathsHaltIn T ∧ + (βˆ€ x, x ∈ L ↔ tm.AcceptsInTime x (T x.length)) + +/-- All-paths halting is monotone in the time bound: once halted, the extra + steps are no-ops. -/ +theorem AllPathsHaltIn.mono {tm : NTM n} {T T' : β„• β†’ β„•} (hle : βˆ€ m, T m ≀ T' m) + (h : tm.AllPathsHaltIn T) : tm.AllPathsHaltIn T' := by + intro x choices' + have heq := tm.trace_mono (hle x.length) + (choices := fun i => choices' ⟨i.val, lt_of_lt_of_le i.isLt (hle x.length)⟩) + (choices' := choices') (c := tm.initCfg x) (fun i => rfl) + (h x fun i => choices' ⟨i.val, lt_of_lt_of_le i.isLt (hle x.length)⟩) + rw [heq] + exact h x _ + +/-- With all paths halting within `T`, timed acceptance transfers DOWN from any + pointwise-larger bound: by `T(|x|)` every path is already frozen. -/ +theorem acceptsInTime_of_le_of_allPathsHaltIn {tm : NTM n} {T T' : β„• β†’ β„•} + {x : List Bool} (hle : βˆ€ m, T m ≀ T' m) (hN : tm.AllPathsHaltIn T) + (h : tm.AcceptsInTime x (T' x.length)) : tm.AcceptsInTime x (T x.length) := by + obtain ⟨choices', hhalt', hout'⟩ := h + have heq := tm.trace_mono (hle x.length) + (choices := fun i => choices' ⟨i.val, lt_of_lt_of_le i.isLt (hle x.length)⟩) + (choices' := choices') (c := tm.initCfg x) (fun i => rfl) + (hN x fun i => choices' ⟨i.val, lt_of_lt_of_le i.isLt (hle x.length)⟩) + exact ⟨_, hN x _, by rw [heq] at hout'; exact hout'⟩ + +/-- Deciding within `T` transfers to any pointwise-larger bound `T'`: halting + is monotone, and acceptance transfers both ways (up by monotonicity, down + by the all-paths-halt freeze). -/ +theorem DecidesInTime.mono {tm : NTM n} {L : Language} {T T' : β„• β†’ β„•} + (hle : βˆ€ m, T m ≀ T' m) (h : tm.DecidesInTime L T) : tm.DecidesInTime L T' := + ⟨h.1.mono hle, fun x => (h.2 x).trans + ⟨fun ha => AcceptsInTime.mono (hle x.length) ha, + fun ha => acceptsInTime_of_le_of_allPathsHaltIn hle h.1 ha⟩⟩ + +/-- Count of accepting choice sequences of length `T`. + + Meaningful when the machine halts on all paths within `T` steps β€” use in conjunction + with `NTM.DecidesInTime` or an explicit all-paths-halt hypothesis. -/ +noncomputable def acceptCount (tm : NTM n) (x : List Bool) (T : β„•) : β„• := + (Finset.univ.filter fun (choices : Fin T β†’ Bool) => + let c' := tm.trace T choices (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.cells 1 = Ξ“.one).card + +/-- Acceptance probability = |accepting paths| / 2^T. + + Meaningful when the machine halts on all paths within `T` steps. -/ +noncomputable def acceptProb (tm : NTM n) (x : List Bool) (T : β„•) : β„š := + (tm.acceptCount x T : β„š) / (2 ^ T : β„š) + +/-- Count of choice sequences of length `T` on which the machine halts with + output `y` (using `Tape.HasOutput`). + + Meaningful when the machine halts on all paths within `T` steps. -/ +noncomputable def outputCount (tm : NTM n) (x : List Bool) (T : β„•) + (y : List Bool) : β„• := + (Finset.univ.filter fun (choices : Fin T β†’ Bool) => + let c' := tm.trace T choices (tm.initCfg x) + c'.state = tm.qhalt ∧ c'.output.HasOutput y).card + +/-- Probability that the machine outputs `y` on input `x` = + |output-matching paths| / 2^T. + + Meaningful when the machine halts on all paths within `T` steps. + This generalizes `acceptProb` from accept/reject to arbitrary output + strings, as needed for cryptographic definitions. -/ +noncomputable def outputProb (tm : NTM n) (x : List Bool) (T : β„•) + (y : List Bool) : β„š := + (tm.outputCount x T y : β„š) / (2 ^ T : β„š) + +/-- NTM decides `L` using at most `S(|x|)` auxiliary space. Every intermediate + configuration on every path obeys `Cfg.WithinDecisionSpace`: work heads are + bounded by `S`, the finite input plus first blank is free but farther input + travel is charged, and only output verdict cell 1 is free. There exists a + time bound within which all paths halt and decide correctly. -/ +def DecidesInSpace (tm : NTM n) (L : Language) (S : β„• β†’ β„•) : Prop := + βˆƒ T, tm.DecidesInTime L T ∧ + βˆ€ x (choices : Fin (T x.length) β†’ Bool) (t' : β„•) (ht : t' ≀ T x.length), + (tm.trace t' (fun j => choices ⟨j.val, by omega⟩) (tm.initCfg x)).WithinDecisionSpace + x.length (S x.length) + +/-- The output tape head never moves left β€” the machine is a *transducer*. + This prevents earlier output from being reread as workspace while allowing + unbounded output length. Decision-space predicates separately bound two-way + output-head travel. -/ +def IsTransducer (tm : NTM n) : Prop := + βˆ€ b q iHead wHeads oHead, + let (_, _, _, _, _, outDir) := tm.Ξ΄ b q iHead wHeads oHead + outDir β‰  Dir3.left + +end NTM + +/-- Embed a DTM into an NTM by using the same transition for both choices. -/ +def TM.toNTM (tm : TM n) : NTM n where + Q := tm.Q + qstart := tm.qstart + qhalt := tm.qhalt + Ξ΄ := fun _ => tm.Ξ΄ + Ξ΄_right_of_start := fun _ => tm.Ξ΄_right_of_start + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators.lean new file mode 100644 index 0000000000..17a088ed12 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Defs + +/-! +# TM Combinators + +This file provides TM constructions for composing machines, used to prove +closure properties of complexity classes. + +## Main definitions + +- `TM.unionTM` β€” Given `tm₁ : TM n₁` deciding `L₁` and `tmβ‚‚ : TM nβ‚‚` deciding `Lβ‚‚`, + construct a `TM (n₁ + 1 + nβ‚‚)` that decides `L₁ βˆͺ Lβ‚‚`. +- `TM.complementTM` β€” Given a TM deciding `L`, construct a TM (with the same + number of work tapes) deciding `Lᢜ` by flipping the output bit. +- `TM.seqTM` β€” Sequential composition: run `tm₁` to completion, then `tmβ‚‚` + on the same tapes. +- `TM.ifTM` β€” Conditional branching: run a test machine, then branch to a + "then" or "else" machine based on its output. +- `TM.loopTM` β€” Loop combinator: repeatedly run a body machine then a test + machine, halting when the test outputs `Ξ“.one`. +- `TM.scannerTM` β€” Generic finite-state scanner: fold a finite-state + transition function over the input bits and emit a final symbol. +- `TM.retargetInput` β€” Given `M : TM k`, construct a `TM (k + 1)` that runs + `M` but reads its "input" from work tape `k` instead of the input tape. + +## Design + +The union machine has three phases: + +1. **Phase 1**: Simulate `tm₁`, redirecting its output to work tape `n₁` + (a "fake output" tape). The real output tape stays pristine. +2. **Transition**: Rewind the fake output to cell 1 and check the result. + If `Ξ“.one` (tm₁ accepted), write `Ξ“.one` to the real output and halt. + Otherwise rewind the input tape and reset Phase-2 tapes to cell 0. +3. **Phase 2**: Simulate `tmβ‚‚` using work tapes `n₁+1..n₁+nβ‚‚` + and the real output tape. + +### Work tape layout (0-indexed) + +- `0 .. n₁-1` β€” Phase 1's work tapes (mirrors `tm₁.work`) +- `n₁` β€” Phase 1's redirected output (mirrors `tm₁.output`) +- `n₁+1 .. n₁+nβ‚‚` β€” Phase 2's work tapes (mirrors `tmβ‚‚.work`) + +### State space + +`Q₁ βŠ• UnionPhase βŠ• Qβ‚‚` where `UnionPhase` encodes the four transition states +between Phase 1 and Phase 2. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Apply.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Apply.lean new file mode 100644 index 0000000000..cf31018bf8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Apply.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Frame +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.RetargetOutput + +/-! +# Running a machine from a work tape onto a work tape + +A loop body cannot compute into the real output tape β€” it is one-way, so it +cannot serve as scratch across iterations. `TM.retargetInputStarted` reads a +machine's input off a work tape and `TM.retargetOutput` writes its output onto a +fresh one; composing them gives `TM.applyTM`, a work-to-work evaluator, and +composing their Hoare rules gives its contract. + +## Main results + +- `TM.applyTM` β€” the work-to-work evaluator for a source machine +- `TM.applyTM_hoareTime` / `TM.applyTM_hoareTime_frame` β€” its time contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : β„•} + +/-- **Work-tape-to-work-tape evaluation.** `applyTM M : TM (k + 2)` reads the +source machine's input off work tape `k`, runs `M` on it, and leaves the result +on work tape `k + 1`; the real input and output tapes are untouched. + +Work tapes `0, …, k-1` are `M`'s own scratch, so a caller that runs `applyTM M` +more than once has to restore them between calls β€” that is what the +precondition below demands. -/ +def applyTM (M : TM k) : TM (k + 2) := (retargetInputStarted M).retargetOutput + +/-- The tapes `applyTM M` expects at entry: `M`'s scratch blank, the virtual +input holding `y`, the result tape blank. -/ +def applyPre (M : TM k) (y : List Bool) (realInput : Tape) : + Fin (k + 2) β†’ Tape := + Fin.snoc (retargetInputStartedCfg M y realInput).work parkedBlank + +/-- **The contract of the work-to-work evaluator.** Given `M`'s own time bound, +`applyTM M` halts within that bound with `f y` on its result tape β€” provided +`M`'s scratch tapes were blank, work tape `k` held `y`, and the result tape was +blank. -/ +theorem applyTM_hoareTime (M : TM k) {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) : + (applyTM M).HoareTime + (fun inp work out => + ((fun i : Fin (k + 1) => work (Fin.castSucc i)) + = (retargetInputStartedCfg M y inp).work) ∧ + work (Fin.last (k + 1)) = parkedBlank ∧ + out = parkedBlank) + (fun _inp work out => + (work (Fin.last (k + 1))).HasOutput (f y) ∧ out = parkedBlank) + (T y.length) := by + have h := retargetOutput_hoareTime (retargetInputStarted M) + (retargetInputStarted_hoareTime M hcomp y) + intro inp work out hpre + obtain ⟨h1, h2, h3⟩ := hpre + exact h inp work out ⟨⟨h1, h2⟩, h3⟩ + +/-- The entry tapes do satisfy the entry condition. -/ +theorem applyPre_spec (M : TM k) (y : List Bool) (realInput : Tape) : + ((fun i : Fin (k + 1) => applyPre M y realInput (Fin.castSucc i)) + = (retargetInputStartedCfg M y realInput).work) ∧ + applyPre M y realInput (Fin.last (k + 1)) = parkedBlank := by + refine ⟨funext fun i => ?_, ?_⟩ + Β· rw [applyPre, Fin.snoc_castSucc] + Β· rw [applyPre, Fin.snoc_last] + +/-- The work-to-work evaluator reads its input from a work tape, so it idles +the real input head. -/ +theorem applyTM_idlesInput (M : TM k) : IdlesInput (applyTM M) := fun _ _ _ _ => rfl + +/-- Every entry tape of the work-to-work evaluator is parked at cell `1`. -/ +theorem applyPre_head (M : TM k) (y : List Bool) (realInput : Tape) (i : Fin (k + 2)) : + (applyPre M y realInput i).head = 1 := by + refine Fin.lastCases ?_ ?_ i + Β· rw [applyPre, Fin.snoc_last]; rfl + Β· intro i' + rw [applyPre, Fin.snoc_castSucc] + show ((retargetInputStartedCfg M y realInput).work i').head = 1 + rw [retargetInputStartedCfg] + dsimp only + split <;> rfl + +/-- Every entry tape of the work-to-work evaluator satisfies the left-marker +invariant. -/ +theorem applyPre_startInvariant (M : TM k) (y : List Bool) (realInput : Tape) + (i : Fin (k + 2)) : Tape.StartInvariant (applyPre M y realInput i) := by + refine Fin.lastCases ?_ ?_ i + Β· rw [applyPre, Fin.snoc_last] + show Tape.StartInvariant ((Tape.init ([] : List Ξ“)).move Dir3.right) + exact startInvariant_initNil.move Dir3.right + Β· intro i' + rw [applyPre, Fin.snoc_castSucc] + show Tape.StartInvariant ((retargetInputStartedCfg M y realInput).work i') + rw [retargetInputStartedCfg] + dsimp only + split + Β· exact startInvariant_initNil.move Dir3.right + Β· exact (startInvariant_initOfBool y).move Dir3.right + +/-- Every entry tape of the work-to-work evaluator is blank beyond the virtual +input's length. -/ +theorem applyPre_cells_blank (M : TM k) (y : List Bool) (realInput : Tape) + (i : Fin (k + 2)) (j : β„•) (hj : y.length < j) : + (applyPre M y realInput i).cells j = Ξ“.blank := by + have hj0 : j = (j - 1) + 1 := by omega + refine Fin.lastCases ?_ ?_ i + Β· rw [applyPre, Fin.snoc_last] + show ((Tape.init ([] : List Ξ“)).move Dir3.right).cells j = Ξ“.blank + rw [Tape.move_cells, hj0, Tape.init_cells_ge [] (j - 1) (by simp)] + Β· intro i' + rw [applyPre, Fin.snoc_castSucc] + show ((retargetInputStartedCfg M y realInput).work i').cells j = Ξ“.blank + rw [retargetInputStartedCfg] + dsimp only + split + Β· show ((Tape.init ([] : List Ξ“)).move Dir3.right).cells j = Ξ“.blank + rw [Tape.move_cells, hj0, Tape.init_cells_ge [] (j - 1) (by simp)] + Β· show ((Tape.init (y.map Ξ“.ofBool)).move Dir3.right).cells j = Ξ“.blank + rw [Tape.move_cells, hj0, + Tape.init_cells_ge (y.map Ξ“.ofBool) (j - 1) (by simp only [List.length_map]; omega)] + +/-- **The work-to-work evaluator, with its disturbance framed.** Beyond +computing `f y` onto the result tape, this records the two facts a caller needs +in order to reset the machine for a second call: every tape's head is still +within `H`, and every cell beyond `H` is still blank. Both follow from the run +being `T |y|`-bounded and every entry tape being parked and blank past `|y|`. -/ +theorem applyTM_hoareTime_frame (M : TM k) {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (inpβ‚€ : Tape) (hinp : Parked inpβ‚€) + (hinpSI : Tape.StartInvariant inpβ‚€) + (H : β„•) (hHy : y.length ≀ H) (hHT : 1 + T y.length ≀ H) : + (applyTM M).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = applyPre M y inpβ‚€ ∧ out = parkedBlank) + (fun inp work out => inp = inpβ‚€ ∧ out = parkedBlank ∧ + (work (Fin.last (k + 1))).HasOutput (f y) ∧ + βˆ€ i, Tape.StartInvariant (work i) ∧ (work i).head ≀ H ∧ + βˆ€ j, H < j β†’ (work i).cells j = Ξ“.blank) + (T y.length) := by + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hOut, hOutEq⟩ := + applyTM_hoareTime M hcomp y inpβ‚€ (applyPre M y inpβ‚€) parkedBlank + ⟨(applyPre_spec M y inpβ‚€).1, (applyPre_spec M y inpβ‚€).2, rfl⟩ + have hinpEq : c'.input = inpβ‚€ := + reachesIn_input_eq_of_idlesInput (applyTM_idlesInput M) hreach hinp + have hSI := reachesIn_startInvariant hreach hinpSI + (fun i => applyPre_startInvariant M y inpβ‚€ i) + (show Tape.StartInvariant parkedBlank from startInvariant_initNil.move Dir3.right) + refine ⟨c', t, ht, hreach, hhalt, hinpEq, hOutEq, hOut, + fun i => ⟨hSI.2.1 i, ?_, fun j hj => ?_⟩⟩ + Β· have hh := (head_le_start_add_of_reachesIn (applyTM M) hreach).2.2 i + rw [show ((⟨(applyTM M).qstart, inpβ‚€, applyPre M y inpβ‚€, parkedBlank⟩ : + Cfg (k + 2) (applyTM M).Q).work i).head = 1 from applyPre_head M y inpβ‚€ i] at hh + omega + Β· rw [reachesIn_work_cells_far hreach i j + (by rw [applyPre_head M y inpβ‚€ i]; omega)] + exact applyPre_cells_blank M y inpβ‚€ i j (by omega) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Defs.lean new file mode 100644 index 0000000000..b0510bc68f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Defs.lean @@ -0,0 +1,908 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Helpers + +/-! +# Turing-machine combinator definitions + +State spaces, tape layouts, transition functions, and start-marker invariants for +union, complement, branching, sequencing, looping, scanning, and input retargeting. +The public `Combinators` module documents and re-exports these constructions. +-/ + +@[expose] public section + +namespace Complexity + +variable {n₁ nβ‚‚ : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- State type +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states between Phase 1 and Phase 2 of the union machine. -/ +inductive UnionPhase where + | rewindOut -- rewind fake output (work tape n₁) to cell 0 + | checkResult -- at fake output cell 1: read and decide accept/continue + | rewindIn -- rewind input tape to cell 0 + | setup2 -- move Phase-2 tapes from cell 1 to cell 0 + deriving DecidableEq + +instance : Fintype UnionPhase where + elems := {.rewindOut, .checkResult, .rewindIn, .setup2} + complete := fun x => by cases x <;> simp + +/-- The state type for the union TM. -/ +abbrev UnionQ (Q₁ Qβ‚‚ : Type) := Q₁ βŠ• UnionPhase βŠ• Qβ‚‚ + +-- ════════════════════════════════════════════════════════════════════════ +-- Index helpers for the n₁ + 1 + nβ‚‚ work tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- Index of the fake output tape (work tape `n₁`). -/ +def fakeOutIdx : Fin (n₁ + 1 + nβ‚‚) := ⟨n₁, by omega⟩ + +/-- Read tm₁'s work tapes from the composite work tapes. -/ +def phase1WorkReads (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (i : Fin n₁) : Ξ“ := + wHeads ⟨i.val, by omega⟩ + +/-- Read tmβ‚‚'s work tapes from the composite work tapes. -/ +def phase2WorkReads (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (j : Fin nβ‚‚) : Ξ“ := + wHeads ⟨n₁ + 1 + j.val, by omega⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- The union TM +-- ════════════════════════════════════════════════════════════════════════ + +/-- Construct a TM deciding `L₁ βˆͺ Lβ‚‚` from TMs deciding `L₁` and `Lβ‚‚`. + + The composite machine has `n₁ + 1 + nβ‚‚` work tapes: + - `0 .. n₁-1` for `tm₁`'s work tapes + - `n₁` for `tm₁`'s redirected output + - `n₁+1 .. n₁+nβ‚‚` for `tmβ‚‚`'s work tapes -/ +def unionTM (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) : TM (n₁ + 1 + nβ‚‚) := + haveI : Fintype tm₁.Q := tm₁.finQ + haveI : DecidableEq tm₁.Q := tm₁.decEq + haveI : Fintype tmβ‚‚.Q := tmβ‚‚.finQ + haveI : DecidableEq tmβ‚‚.Q := tmβ‚‚.decEq + { Q := UnionQ tm₁.Q tmβ‚‚.Q, + qstart := Sum.inl tm₁.qstart, + qhalt := Sum.inr (Sum.inr tmβ‚‚.qhalt), + Ξ΄ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Phase 1: simulate tm₁ with output redirected to work tape n₁ + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tm₁.qhalt then + -- Transition to rewind; preserve fake output value to avoid corrupting cell 1 + ( Sum.inr (Sum.inl .rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := + tm₁.Ξ΄ q iHead (phase1WorkReads wHeads) (wHeads fakeOutIdx) + ( Sum.inl q', + fun i => + if h : i.val < n₁ then wW ⟨i.val, h⟩ + else if i.val = n₁ then oW + else .blank, + .blank, iD, + fun i => + if h : i.val < n₁ then wD ⟨i.val, h⟩ + else if i.val = n₁ then oD + else idleDir (wHeads i), + idleDir oHead ) + -- ══════════════════════════════════════════════════════════════════ + -- Transition states between phases + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inl m) => + match m with + | .rewindOut => + if wHeads fakeOutIdx = Ξ“.start then + -- At cell 0 β†’ move right to cell 1 + ( Sum.inr (Sum.inl .checkResult), + fun _ => .blank, .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.right else idleDir (wHeads i), + idleDir oHead ) + else + -- Not at cell 0 β†’ keep moving left; preserve fake output to avoid corrupting cell 1 + ( Sum.inr (Sum.inl .rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.left else idleDir (wHeads i), + idleDir oHead ) + | .checkResult => + if wHeads fakeOutIdx = Ξ“.one then + -- tm₁ accepted β†’ write Ξ“.one to real output (at cell 1), halt + ( Sum.inr (Sum.inr tmβ‚‚.qhalt), + fun _ => .blank, .one, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- tm₁ rejected β†’ proceed to rewind input + allIdle (Sum.inr (Sum.inl .rewindIn)) iHead wHeads oHead + | .rewindIn => + if iHead = Ξ“.start then + -- At cell 0 β†’ forced right by Ξ΄_right_of_start, then setup2 + ( Sum.inr (Sum.inl .setup2), + fun _ => .blank, .blank, Dir3.right, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Not at cell 0 β†’ keep moving left + ( Sum.inr (Sum.inl .rewindIn), + fun _ => .blank, .blank, Dir3.left, + fun i => idleDir (wHeads i), + idleDir oHead ) + | .setup2 => + -- Move input, Phase-2 work tapes, and real output from cell 1 to cell 0 + ( Sum.inr (Sum.inr tmβ‚‚.qstart), + fun _ => .blank, .blank, moveLeftDir iHead, + fun i => if i.val ≀ n₁ then idleDir (wHeads i) else moveLeftDir (wHeads i), + moveLeftDir oHead ) + -- ══════════════════════════════════════════════════════════════════ + -- Phase 2: simulate tmβ‚‚ with the real output tape + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr q) => + if q = tmβ‚‚.qhalt then + -- Unreachable (step returns none), but Ξ΄ is total + allIdle (Sum.inr (Sum.inr tmβ‚‚.qhalt)) iHead wHeads oHead + else + let (q', wW, oW, iD, wD, oD) := + tmβ‚‚.Ξ΄ q iHead (phase2WorkReads wHeads) oHead + ( Sum.inr (Sum.inr q'), + fun i => + if h : i.val ≀ n₁ then .blank + else wW ⟨i.val - (n₁ + 1), by omega⟩, + oW, iD, + fun i => + if h : i.val ≀ n₁ then idleDir (wHeads i) + else wD ⟨i.val - (n₁ + 1), by omega⟩, + oD ), + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· next hne => + have hΞ΄ := tm₁.Ξ΄_right_of_start q iHead (phase1WorkReads wHeads) (wHeads fakeOutIdx) + simp only [phase1WorkReads, fakeOutIdx] at hΞ΄ + refine ⟨hΞ΄.1, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only [] + split + Β· next hi => + exact hΞ΄.2.1 ⟨i.val, hi⟩ (by + rwa [show wHeads βŸ¨β†‘i, by omega⟩ = wHeads i from by congr 1]) + Β· split + Β· next hi hn => + exact hΞ΄.2.2 (by + rwa [show wHeads ⟨n₁, by omega⟩ = wHeads i from by congr 1; ext; simp [hn]]) + Β· exact idleDir_right_of_start hwi + | Sum.inr (Sum.inl m) => + match m with + | .rewindOut => + dsimp only [fakeOutIdx] + by_cases hphase : wHeads fakeOutIdx = Ξ“.start + all_goals simp only [fakeOutIdx] at hphase + all_goals simp only [hphase, ite_true, ite_false] + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; split + Β· rfl + Β· exact idleDir_right_of_start hwi + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; split + Β· next heq => + exfalso; apply hphase + rwa [show wHeads ⟨n₁, by omega⟩ = wHeads i from by congr 1; ext; simp [heq]] + Β· exact idleDir_right_of_start hwi + | .checkResult => + dsimp only [fakeOutIdx] + by_cases hphase : wHeads fakeOutIdx = Ξ“.one + all_goals simp only [fakeOutIdx] at hphase + all_goals simp only [hphase, ite_true, ite_false] + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + Β· exact rightOfStart_allIdle iHead wHeads oHead + | .rewindIn => + dsimp only [] + split + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + Β· refine ⟨?_, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + intro hiHead; next hn => exact absurd hiHead hn + | .setup2 => + refine ⟨moveLeftDir_right_of_start, ?_, moveLeftDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· exact idleDir_right_of_start hwi + Β· exact moveLeftDir_right_of_start hwi + | Sum.inr (Sum.inr q) => + dsimp only [] + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· next hne => + have hΞ΄ := tmβ‚‚.Ξ΄_right_of_start q iHead (phase2WorkReads wHeads) oHead + simp only [phase2WorkReads] at hΞ΄ + refine ⟨hΞ΄.1, ?_, hΞ΄.2.2⟩ + intro i hwi; simp only []; split + Β· exact idleDir_right_of_start hwi + Β· next hi => + exact hΞ΄.2.1 ⟨i.val - (n₁ + 1), by omega⟩ (by + rwa [show wHeads ⟨n₁ + 1 + (↑i - (n₁ + 1)), by omega⟩ = wHeads i from by + congr 1; ext; simp; omega]) } + +-- ════════════════════════════════════════════════════════════════════════ +-- Complement TM +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states for the complement machine's output-flipping phase. -/ +inductive ComplementPhase where + | rewind -- rewind output head left to cell 0, then right to cell 1 + | flip -- at cell 1: flip the output bit and halt + | done -- halt state + deriving DecidableEq + +instance : Fintype ComplementPhase where + elems := {.rewind, .flip, .done} + complete := fun x => by cases x <;> simp + +/-- The state type for the complement TM. -/ +abbrev ComplementQ (Q : Type) := Q βŠ• ComplementPhase + +/-- Flip a readable symbol: `1 ↔ 0`, blanks stay blank. -/ +def flipBit (g : Ξ“) : Ξ“w := + match g with + | .one => .zero + | .zero => .one + | .blank => .blank + | .start => .blank + +/-- Construct a TM deciding `Lᢜ` from a TM deciding `L`. + + The complement machine has the same number of work tapes as the original. + It runs in three stages: + + 1. **Simulate**: Run the original TM. When it halts, transition to `rewind`. + 2. **Rewind**: Move the output head left to `β–·` (cell 0), then right to cell 1. + 3. **Flip**: Read output cell 1, write the flipped bit, and halt. -/ +def complementTM (tm : TM n) : TM n := + haveI : Fintype tm.Q := tm.finQ + haveI : DecidableEq tm.Q := tm.decEq + { Q := ComplementQ tm.Q, + qstart := Sum.inl tm.qstart, + qhalt := Sum.inr .done, + Ξ΄ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Simulation phase: run original TM + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tm.qhalt then + -- Original TM halted β†’ begin rewinding output + -- Write back the current output symbol to preserve cell contents + ( Sum.inr .rewind, + fun _ => .blank, + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Not halted β†’ run original Ξ΄, wrapping state in Sum.inl + let (q', wW, oW, iD, wD, oD) := tm.Ξ΄ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Rewind phase: move output head left to β–·, then right to cell 1 + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr .rewind => + if oHead = Ξ“.start then + -- At cell 0 (β–·) β†’ move right to cell 1, enter flip state + ( Sum.inr .flip, + fun _ => .blank, + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.right ) + else + -- Not at cell 0 β†’ keep moving left, preserve output cell contents + ( Sum.inr .rewind, + fun _ => .blank, + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.left ) + -- ══════════════════════════════════════════════════════════════════ + -- Flip phase: at cell 1, flip the output bit and halt + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr .flip => + ( Sum.inr .done, + fun _ => .blank, + flipBit oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + -- ══════════════════════════════════════════════════════════════════ + -- Done (= qhalt): unreachable by step, but Ξ΄ is total + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr .done => + allIdle (Sum.inr .done) iHead wHeads oHead, + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tm.Ξ΄_right_of_start q iHead wHeads oHead + | Sum.inr .rewind => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + Β· refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | Sum.inr .flip => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | Sum.inr .done => + exact rightOfStart_allIdle iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Conditional Branching +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states for the conditional branching machine. -/ +inductive IfPhase where + | rewindOut -- rewind output head left to β–· (cell 0) + | check -- at cell 0, move right to cell 1, read result, branch + | done -- halt state (reached when either branch halts) + deriving DecidableEq + +instance : Fintype IfPhase where + elems := {.rewindOut, .check, .done} + complete := fun x => by cases x <;> simp + +/-- The state type for the conditional branching TM. -/ +abbrev IfQ (QT QThen QElse : Type) := QT βŠ• IfPhase βŠ• QThen βŠ• QElse + +/-- Conditional branching: run `tmTest` to completion, read its output at + cell 1, then run `tmThen` (if output = `Ξ“.one`) or `tmElse` (otherwise). + + All three machines share the same `n` work tapes, input tape, and output + tape. Work tape contents are preserved across all transitions via + `readBackWrite`, maintaining shared state for the branch machines. + + ## Phases + + 1. **Test**: Simulate `tmTest`. When it halts, enter rewind. + 2. **Rewind output**: Move output head left to `β–·` (cell 0). + 3. **Check**: Move output head right to cell 1, read the test result. + If `Ξ“.one`, enter `tmThen.qstart`. Otherwise, enter `tmElse.qstart`. + 4. **Branch**: Simulate `tmThen` or `tmElse`. When the branch machine + halts, transition to the `done` halt state. + + ## Time + + `t_test + (output_head_pos + 2) + 1 + t_branch + 1` where + `output_head_pos ≀ t_test`. Total: at most `2Β·t_test + t_branch + 4`. -/ +def ifTM (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) : TM n := + haveI : Fintype tmTest.Q := tmTest.finQ + haveI : DecidableEq tmTest.Q := tmTest.decEq + haveI : Fintype tmThen.Q := tmThen.finQ + haveI : DecidableEq tmThen.Q := tmThen.decEq + haveI : Fintype tmElse.Q := tmElse.finQ + haveI : DecidableEq tmElse.Q := tmElse.decEq + { Q := IfQ tmTest.Q tmThen.Q tmElse.Q, + qstart := Sum.inl tmTest.qstart, + qhalt := Sum.inr (Sum.inl .done), + Ξ΄ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Test phase: simulate tmTest + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tmTest.qhalt then + -- tmTest halted β†’ begin rewinding output, preserve all tapes + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmTest.Ξ΄ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Transition: rewind output and check result + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + if oHead = Ξ“.start then + -- At β–· (cell 0) β†’ move right to cell 1, enter check + ( Sum.inr (Sum.inl .check), + fun i => readBackWrite (wHeads i), + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.right ) + else + -- Not at cell 0 β†’ keep moving left, preserve output + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.left ) + | .check => + -- At cell 1: read output and branch + if oHead = Ξ“.one then + ( Sum.inr (Sum.inr (Sum.inl tmThen.qstart)), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + ( Sum.inr (Sum.inr (Sum.inr tmElse.qstart)), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + | .done => + allIdle (Sum.inr (Sum.inl .done)) iHead wHeads oHead + -- ══════════════════════════════════════════════════════════════════ + -- Then branch: simulate tmThen + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr (Sum.inl q)) => + if q = tmThen.qhalt then + -- tmThen halted β†’ transition to done, preserve tapes + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmThen.Ξ΄ q iHead wHeads oHead + ( Sum.inr (Sum.inr (Sum.inl q')), wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Else branch: simulate tmElse + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr (Sum.inr q)) => + if q = tmElse.qhalt then + -- tmElse halted β†’ transition to done, preserve tapes + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmElse.Ξ΄ q iHead wHeads oHead + ( Sum.inr (Sum.inr (Sum.inr q')), wW, oW, iD, wD, oD ), + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tmTest.Ξ΄_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + Β· refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .check => + dsimp only [] + split <;> exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact rightOfStart_allIdle iHead wHeads oHead + | Sum.inr (Sum.inr (Sum.inl q)) => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tmThen.Ξ΄_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inr (Sum.inr q)) => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tmElse.Ξ΄_right_of_start q iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Sequential Composition +-- ════════════════════════════════════════════════════════════════════════ + +/-- The state type for the sequential composition TM. -/ +abbrev SeqQ (Q₁ Qβ‚‚ : Type) := Q₁ βŠ• Qβ‚‚ + +/-- Sequential composition: run tm₁ to completion, then tmβ‚‚ on the same tapes. + + Both machines share the same `n` work tapes, input tape, and output tape. + When tm₁ halts, there is one transition step that: + - Changes state from `Q₁` to `Qβ‚‚` (entering `tmβ‚‚.qstart`) + - Preserves all tape cell contents (via `readBackWrite`) + - Moves any tape head at position 0 to position 1 (forced by `Ξ΄_right_of_start`) + - Leaves all other tape head positions unchanged + + After the transition, tmβ‚‚ runs from the resulting tape state. + Total time: `t₁ + 1 + tβ‚‚` where `t₁` and `tβ‚‚` are the run times of + `tm₁` and `tmβ‚‚` respectively. -/ +def seqTM (tm₁ tmβ‚‚ : TM n) : TM n := + haveI : Fintype tm₁.Q := tm₁.finQ + haveI : DecidableEq tm₁.Q := tm₁.decEq + haveI : Fintype tmβ‚‚.Q := tmβ‚‚.finQ + haveI : DecidableEq tmβ‚‚.Q := tmβ‚‚.decEq + { Q := SeqQ tm₁.Q tmβ‚‚.Q, + qstart := Sum.inl tm₁.qstart, + qhalt := Sum.inr tmβ‚‚.qhalt, + Ξ΄ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Phase 1: simulate tm₁ + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tm₁.qhalt then + -- tm₁ halted β†’ transition to tmβ‚‚.qstart, preserve tape contents + ( Sum.inr tmβ‚‚.qstart, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Not halted β†’ run tm₁.Ξ΄, wrapping state in Sum.inl + let (q', wW, oW, iD, wD, oD) := tm₁.Ξ΄ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Phase 2: simulate tmβ‚‚ + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr q => + if q = tmβ‚‚.qhalt then + -- Unreachable by step, but Ξ΄ is total + allIdle (Sum.inr tmβ‚‚.qhalt) iHead wHeads oHead + else + -- Not halted β†’ run tmβ‚‚.Ξ΄, wrapping state in Sum.inr + let (q', wW, oW, iD, wD, oD) := tmβ‚‚.Ξ΄ q iHead wHeads oHead + ( Sum.inr q', wW, oW, iD, wD, oD ), + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tm₁.Ξ΄_right_of_start q iHead wHeads oHead + | Sum.inr q => + dsimp only [] + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· exact tmβ‚‚.Ξ΄_right_of_start q iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Loop Combinator +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states for the loop machine's output-checking phase. -/ +inductive LoopPhase where + | rewindOut -- rewind output head left to β–· (cell 0) + | check -- at cell 1: read output, decide continue/halt + | done -- halt state + deriving DecidableEq + +instance : Fintype LoopPhase where + elems := {.rewindOut, .check, .done} + complete := fun x => by cases x <;> simp + +/-- The state type for the loop TM. -/ +abbrev LoopQ (QBody QTest : Type) := QBody βŠ• LoopPhase βŠ• QTest + +/-- Loop combinator: repeatedly run `tmBody` then `tmTest`, halting when + the test's output at cell 1 is `Ξ“.one`. + + Both machines share the same `n` work tapes, input tape, and output tape. + Work tape contents are preserved across transitions (via `readBackWrite`), + allowing the body to accumulate state across iterations. + + ## Phases + + 1. **Body**: Simulate `tmBody`. When it halts, transition to test. + 2. **Test**: Simulate `tmTest`. When it halts, enter rewind. + 3. **Rewind output**: Move output head left to `β–·` (cell 0). + 4. **Check**: Move right to cell 1, read the test result. + If `Ξ“.one`, enter `done` (halt). Otherwise, transition back to body. + + ## Use case + + The UTM's main loop: `loopTM simStepTM checkHaltTM` runs one simulation + step, then checks if the simulated machine has halted. -/ +def loopTM (tmBody : TM n) (tmTest : TM n) : TM n := + haveI : Fintype tmBody.Q := tmBody.finQ + haveI : DecidableEq tmBody.Q := tmBody.decEq + haveI : Fintype tmTest.Q := tmTest.finQ + haveI : DecidableEq tmTest.Q := tmTest.decEq + { Q := LoopQ tmBody.Q tmTest.Q, + qstart := Sum.inl tmBody.qstart, + qhalt := Sum.inr (Sum.inl .done), + Ξ΄ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Body phase: simulate tmBody + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tmBody.qhalt then + -- Body halted β†’ transition to test, preserve tape contents + ( Sum.inr (Sum.inr tmTest.qstart), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmBody.Ξ΄ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Transition phases: rewind and check output + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + if oHead = Ξ“.start then + -- At β–· (cell 0) β†’ move right to cell 1, enter check + ( Sum.inr (Sum.inl .check), + fun i => readBackWrite (wHeads i), + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.right ) + else + -- Not at cell 0 β†’ keep moving left, preserve output + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.left ) + | .check => + if oHead = Ξ“.one then + -- Test output = 1: halt the loop + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Test output β‰  1: loop back to body + ( Sum.inl tmBody.qstart, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + | .done => + allIdle (Sum.inr (Sum.inl .done)) iHead wHeads oHead + -- ══════════════════════════════════════════════════════════════════ + -- Test phase: simulate tmTest + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr q) => + if q = tmTest.qhalt then + -- Test halted β†’ begin rewinding output, preserve tapes + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmTest.Ξ΄ q iHead wHeads oHead + ( Sum.inr (Sum.inr q'), wW, oW, iD, wD, oD ), + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tmBody.Ξ΄_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + Β· refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .check => + dsimp only [] + split <;> exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact rightOfStart_allIdle iHead wHeads oHead + | Sum.inr (Sum.inr q) => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact tmTest.Ξ΄_right_of_start q iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Finite-state scanner +-- ════════════════════════════════════════════════════════════════════════ + +/-- Control states of a generic finite-state scanner parameterized by a + user-supplied scan-state type `S`. The machine has a one-time `start` + step that advances off cell 0, then a stream of `scan s` states holding + the current scan state, and finally a `done` halt state. -/ +inductive ScannerPhase (S : Type) where + | start + | scan (s : S) + | done + +instance {S : Type} [DecidableEq S] : DecidableEq (ScannerPhase S) + | .start, .start => isTrue rfl + | .start, .scan _ => isFalse (fun h => by cases h) + | .start, .done => isFalse (fun h => by cases h) + | .scan _, .start => isFalse (fun h => by cases h) + | .scan _, .done => isFalse (fun h => by cases h) + | .done, .start => isFalse (fun h => by cases h) + | .done, .scan _ => isFalse (fun h => by cases h) + | .done, .done => isTrue rfl + | .scan s₁, .scan sβ‚‚ => + if h : s₁ = sβ‚‚ then isTrue (by rw [h]) + else isFalse (fun heq => h (by cases heq; rfl)) + +instance {S : Type} [DecidableEq S] [Fintype S] : Fintype (ScannerPhase S) where + elems := insert ScannerPhase.start + (insert (ScannerPhase.done : ScannerPhase S) + (Finset.univ.image ScannerPhase.scan)) + complete := fun x => by + cases x with + | start => exact Finset.mem_insert_self _ _ + | done => exact Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + | scan s => + apply Finset.mem_insert_of_mem + apply Finset.mem_insert_of_mem + exact Finset.mem_image.mpr ⟨s, Finset.mem_univ s, rfl⟩ + +/-- **Generic finite-state scanner.** + + A 0-work-tape TM parameterized by a scan-state type `S`, an initial + state `sβ‚€`, a transition function `scanStep : S β†’ Bool β†’ S` (called on + each input bit), and a finalizer `finalOutput : S β†’ Ξ“w` (the symbol to + emit when end-of-input is reached). + + Semantics: runs left-to-right through the input, folding `scanStep` over + the bits starting from `sβ‚€`; when a blank is reached, writes + `finalOutput (finalState)` to output cell 1 and halts. + + This captures the common "read once, fold into a fixed-size state" + pattern used by `evenLength`, `allZeros`/`allOnes`, `containsZero`/`containsOne`, + `lengthDivBy k`, `lastBit`, and similar regular-language scanners. + + Halts in `|x| + 2` steps on every input (1 start + `|x|` scans + 1 halt). -/ +def scannerTM {S : Type} [DecidableEq S] [Fintype S] + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) : TM 0 where + Q := ScannerPhase S + qstart := .start + qhalt := .done + Ξ΄ := fun state iHead _wHeads oHead => + match state with + | .start => + -- Advance input and output from cell 0 (β–·) to cell 1. Writes at cell 0 + -- are no-ops. Enter the initial scan state. + (.scan sβ‚€, fun i => i.elim0, .blank, + .right, fun i => i.elim0, .right) + | .scan s => + if iHead = Ξ“.blank then + -- End of input. Emit `finalOutput s` and halt. + (.done, fun i => i.elim0, finalOutput s, + idleDir iHead, fun i => i.elim0, idleDir oHead) + else + -- Read a bit: `Ξ“.one ↦ true`, anything else (including the + -- structurally-unreachable `Ξ“.start`) ↦ `false`. + let b : Bool := decide (iHead = Ξ“.one) + (.scan (scanStep s b), fun i => i.elim0, readBackWrite oHead, + .right, fun i => i.elim0, idleDir oHead) + | .done => + allIdle .done iHead _wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .start => + refine ⟨fun _ => rfl, fun i => i.elim0, fun _ => rfl⟩ + | .scan _ => + dsimp only []; split + Β· exact ⟨idleDir_right_of_start, fun i => i.elim0, idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun i => i.elim0, idleDir_right_of_start⟩ + | .done => + exact rightOfStart_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- retargetInput: read virtual input from work tape k instead of input tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- Given a DTM `M : TM k`, construct a DTM `retargetInput M : TM (k + 1)` + that behaves like `M` but reads its "input" from work tape `k` (the last + work tape) instead of the real input tape. + + Tape layout: + - Real input tape: ignored (moved idly each step, never read). + - Work tapes `0..k-1`: mirror `M`'s work tapes. + - Work tape `k`: plays the role of `M`'s input tape (read-only, no + writes except a no-op `readBackWrite` that preserves cells). + + When work tape `k` is initialized with `Tape.init (z.map Ξ“.ofBool)`, the + machine simulates `M` on input `z`. + + Used in `witnessLang` NTM constructions where the verifier DTM's + "input" (e.g. `pair(x, y)`) is built on a work tape rather than + supplied on the real input tape. -/ +def retargetInput {k : β„•} (M : TM k) : TM (k + 1) where + Q := M.Q + qstart := M.qstart + qhalt := M.qhalt + Ξ΄ := fun q _iHead wHeads oHead => + let virtualInput : Ξ“ := wHeads ⟨k, by omega⟩ + let innerWork : Fin k β†’ Ξ“ := fun i => wHeads ⟨i.val, by omega⟩ + let (q', workWrites, outWrite, inDir, workDirs, outDir) := + M.Ξ΄ q virtualInput innerWork oHead + ( q', + fun i => + if h : i.val < k then workWrites ⟨i.val, h⟩ + else readBackWrite virtualInput, + outWrite, + idleDir _iHead, + fun i => + if h : i.val < k then workDirs ⟨i.val, h⟩ + else inDir, + outDir ) + Ξ΄_right_of_start := by + intro q iHead wHeads oHead + have hΞ΄ := M.Ξ΄_right_of_start q (wHeads ⟨k, by omega⟩) + (fun i => wHeads ⟨i.val, by omega⟩) oHead + obtain ⟨hinp, hwork, hout⟩ := hΞ΄ + refine ⟨idleDir_right_of_start, ?_, hout⟩ + intro i hwi + dsimp only [] + split + Β· next hi => + -- i.val < k: use M's work condition + exact hwork ⟨i.val, hi⟩ (by + change wHeads ⟨i.val, _⟩ = _ + rwa [show wHeads ⟨i.val, by omega⟩ = wHeads i from by congr 1]) + Β· next hi => + -- i.val = k: use M's input condition + have hik : i.val = k := by + have := i.isLt + omega + have : wHeads ⟨k, by omega⟩ = Ξ“.start := by + rw [show (⟨k, by omega⟩ : Fin (k + 1)) = i from by ext; simp [hik]] + exact hwi + exact hinp this + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork.lean new file mode 100644 index 0000000000..ddc7c52845 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Internal + +/-! +# Binary work-tape loop combinator + +`TM.forBinaryWorkTM driverIdx body` invokes `body` once per Boolean cell on a +designated work tape and stops at the first blank. The body sees the current +bit; the loopback seam advances the driver. This supplies width-driven control +for bitwise algorithms without iterating over the represented numeric value. + +## Main results + +- `TM.ForBinaryWorkLoopSpec.reachesIn` composes an indexed exact-execution + certificate for the complete loop. +- `TM.ForBinaryWorkLoopSpaceSpec.prefix_withinAuxSpace` bounds every prefix of + the certified loop run. +- `TM.IsTransducer.forBinaryWorkTM` preserves one-way output safety. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Exact remaining execution of a certified binary work-tape loop. -/ +theorem ForBinaryWorkLoopSpec.reachesIn + {driverIdx : Fin n} {body : TM n} {bodyTime : β„• β†’ β„•} + {total count value : β„•} + (spec : ForBinaryWorkLoopSpec driverIdx body bodyTime total) + (htotal : value + count = total) : + (forBinaryWorkTM driverIdx body).reachesIn + (forBinaryWorkLoopTime bodyTime value count) + (spec.scanCfg value) spec.doneCfg := + spec.reachesIn_internal count value htotal + +/-- Every prefix up to the exact remaining runtime of a certified binary-work +loop respects its all-reachable auxiliary-space budget. -/ +theorem ForBinaryWorkLoopSpaceSpec.prefix_withinAuxSpace + {driverIdx : Fin n} {body : TM n} {bodyTime : β„• β†’ β„•} + {total inputLength spaceBound count value t : β„•} + {spec : ForBinaryWorkLoopSpec driverIdx body bodyTime total} + (spaceSpec : ForBinaryWorkLoopSpaceSpec spec inputLength spaceBound) + {c : Cfg n (forBinaryWorkTM driverIdx body).Q} + (htotal : value + count = total) + (hreach : (forBinaryWorkTM driverIdx body).reachesIn t + (spec.scanCfg value) c) + (htime : t ≀ forBinaryWorkLoopTime bodyTime value count) : + c.WithinAuxSpace inputLength spaceBound := + spaceSpec.prefix_withinAuxSpace_internal count value t c htotal hreach + htime + +/-- Iterating a one-way-output body over a binary work tape remains a +transducer. -/ +theorem IsTransducer.forBinaryWorkTM + {driverIdx : Fin n} {body : TM n} (hbody : body.IsTransducer) : + (forBinaryWorkTM driverIdx body).IsTransducer := + hbody.forBinaryWorkTM_internal + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Defs.lean new file mode 100644 index 0000000000..9e69933075 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Defs.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Binary work-tape loop combinator -- definitions + +`TM.forBinaryWorkTM driverIdx body` invokes `body` once for each `0` or `1` +under a designated work-tape cursor and stops on the first blank. The body sees +the current bit; the loopback seam advances the driver by one cell. This is the +width-driven control needed by bitwise algorithms such as schoolbook +multiplication, without a numeric-value counter. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Scanner and terminal states outside the nested body machine. -/ +inductive ForBinaryWorkPhase where + | scan + | done + deriving DecidableEq + +/-- `ForBinaryWorkPhase` has exactly two states. -/ +instance instFintypeForBinaryWorkPhase : Fintype ForBinaryWorkPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- Iterate `body` over the Boolean cells of work tape `driverIdx`. + +The scanner skips an initial left marker, halts on blank, and enters `body` +without moving on either Boolean symbol. When the body halts, one preserving +seam step advances only the driver and resumes scanning. Exact once-per-bit +semantics therefore requires the body to preserve the driver tape and head. -/ +def forBinaryWorkTM {n : β„•} (driverIdx : Fin n) (body : TM n) : TM n where + Q := ForBinaryWorkPhase βŠ• body.Q + qstart := .inl .scan + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .scan => + if wHeads driverIdx = Ξ“.start then + (.inl .scan, fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = driverIdx then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else if wHeads driverIdx = Ξ“.blank then + allReadBack (.inl .done) iHead wHeads oHead + else + allReadBack (.inr body.qstart) iHead wHeads oHead + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr state => + if state = body.qhalt then + (.inl .scan, fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = driverIdx then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + ((Sum.inr (body.Ξ΄ state iHead wHeads oHead).1 : + ForBinaryWorkPhase βŠ• body.Q), + (body.Ξ΄ state iHead wHeads oHead).2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.2.2) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .scan => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hi + Β· split <;> exact rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr state => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hi + Β· exact body.Ξ΄_right_of_start state iHead wHeads oHead + +/-- Exact remaining time for a bit-driven work loop. Each live iteration takes +one scanner step, the body run, and one advancing loopback step; the terminal +blank exit takes one step. -/ +def forBinaryWorkLoopTime (bodyTime : β„• β†’ β„•) (value : β„•) : β„• β†’ β„• + | 0 => 1 + | count + 1 => + 1 + bodyTime value + 1 + + forBinaryWorkLoopTime bodyTime (value + 1) count + +/-- Wrapper-free exact-control certificate for a binary work-tape loop. -/ +structure ForBinaryWorkLoopSpec {n : β„•} (driverIdx : Fin n) (body : TM n) + (bodyTime : β„• β†’ β„•) (total : β„•) where + /-- Canonical scanner configuration at iteration `value`. -/ + scanCfg : β„• β†’ Cfg n (forBinaryWorkTM driverIdx body).Q + /-- Canonical combined-machine configuration at body entry. -/ + bodyStartCfg : β„• β†’ Cfg n (forBinaryWorkTM driverIdx body).Q + /-- Canonical combined-machine configuration after the exact body run. -/ + bodyDoneCfg : β„• β†’ Cfg n (forBinaryWorkTM driverIdx body).Q + /-- Canonical final driver configuration. -/ + doneCfg : Cfg n (forBinaryWorkTM driverIdx body).Q + /-- One scanner step on a Boolean cell enters the body. -/ + scanStep : βˆ€ value, value < total β†’ + (forBinaryWorkTM driverIdx body).step (scanCfg value) = + some (bodyStartCfg value) + /-- The body has the advertised exact runtime. -/ + bodyRun : βˆ€ value, value < total β†’ + (forBinaryWorkTM driverIdx body).reachesIn (bodyTime value) + (bodyStartCfg value) (bodyDoneCfg value) + /-- The preserving loopback advances the driver to the next cell. -/ + loopbackStep : βˆ€ value, value < total β†’ + (forBinaryWorkTM driverIdx body).step (bodyDoneCfg value) = + some (scanCfg (value + 1)) + /-- The scanner exits on the first blank. -/ + stopStep : + (forBinaryWorkTM driverIdx body).step (scanCfg total) = some doneCfg + +/-- Space obligations turning an exact binary-work loop certificate into an +all-prefix auxiliary-space certificate. -/ +structure ForBinaryWorkLoopSpaceSpec {n : β„•} {driverIdx : Fin n} + {body : TM n} {bodyTime : β„• β†’ β„•} {total : β„•} + (spec : ForBinaryWorkLoopSpec driverIdx body bodyTime total) + (inputLength spaceBound : β„•) where + /-- Every canonical scanner configuration is within the space budget. -/ + scanWithin : βˆ€ value, value ≀ total β†’ + (spec.scanCfg value).WithinAuxSpace inputLength spaceBound + /-- The canonical terminal configuration is within the space budget. -/ + doneWithin : spec.doneCfg.WithinAuxSpace inputLength spaceBound + /-- Every prefix of each exact body run remains within the budget. -/ + bodyPrefixWithin : βˆ€ value t c, value < total β†’ t ≀ bodyTime value β†’ + (forBinaryWorkTM driverIdx body).reachesIn t + (spec.bodyStartCfg value) c β†’ + c.WithinAuxSpace inputLength spaceBound + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Internal.lean new file mode 100644 index 0000000000..3d54c62adb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForBinaryWork/Internal.lean @@ -0,0 +1,311 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability + +/-! +# Binary work-tape loop combinator -- proof internals + +This module proves exact body embedding, bit/blank scanner transitions, the +advancing loopback seam, certified finite iteration, and transducer closure. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed a body configuration in the body phase of `forBinaryWorkTM`. -/ +def forBinaryWorkBodyWrap (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n body.Q) : Cfg n (forBinaryWorkTM driverIdx body).Q := + { state := .inr cfg.state + input := cfg.input + work := cfg.work + output := cfg.output } + +/-- Every nonhalting body step is simulated exactly. -/ +theorem forBinaryWorkTM_body_step_internal (driverIdx : Fin n) (body : TM n) + {cfg next : Cfg n body.Q} (hstep : body.step cfg = some next) : + (forBinaryWorkTM driverIdx body).step + (forBinaryWorkBodyWrap driverIdx body cfg) = + some (forBinaryWorkBodyWrap driverIdx body next) := by + have hne : cfg.state β‰  body.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [forBinaryWorkBodyWrap, forBinaryWorkTM])] + simp only [forBinaryWorkBodyWrap, forBinaryWorkTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize body.Ξ΄ cfg.state cfg.input.read (fun i => (cfg.work i).read) + cfg.output.read = action + obtain ⟨state, workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := + action + intro hstep + cases Option.some.inj hstep + rfl + +/-- Exact body runs lift through the combined machine's body phase. -/ +theorem forBinaryWorkTM_body_reachesIn_internal + (driverIdx : Fin n) (body : TM n) + {time : β„•} {cfg next : Cfg n body.Q} + (hreach : body.reachesIn time cfg next) : + (forBinaryWorkTM driverIdx body).reachesIn time + (forBinaryWorkBodyWrap driverIdx body cfg) + (forBinaryWorkBodyWrap driverIdx body next) := + reachesIn_map (forBinaryWorkBodyWrap driverIdx body) + (fun _ _ => forBinaryWorkTM_body_step_internal driverIdx body) hreach + +/-- On either Boolean symbol, the scanner enters the body without moving or +changing any tape. -/ +theorem forBinaryWorkTM_step_scan_bit_internal + (driverIdx : Fin n) (body : TM n) (bit : Bool) + (cfg : Cfg n (forBinaryWorkTM driverIdx body).Q) + (hstate : cfg.state = .inl .scan) + (hbit : (cfg.work driverIdx).read = Ξ“.ofBool bit) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forBinaryWorkTM driverIdx body).step cfg = some + { state := .inr body.qstart + input := cfg.input + work := cfg.work + output := cfg.output } := by + have hstart : (cfg.work driverIdx).read β‰  Ξ“.start := by + rw [hbit] + exact Ξ“.ofBool_ne_start bit + have hblank : (cfg.work driverIdx).read β‰  Ξ“.blank := by + rw [hbit] + cases bit <;> decide + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forBinaryWorkTM])] + simp only [forBinaryWorkTM, hstate, hstart, hblank, allReadBack, + ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +/-- On the first blank, the scanner halts without consuming it. -/ +theorem forBinaryWorkTM_step_scan_blank_internal + (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n (forBinaryWorkTM driverIdx body).Q) + (hstate : cfg.state = .inl .scan) + (hblank : (cfg.work driverIdx).read = Ξ“.blank) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forBinaryWorkTM driverIdx body).step cfg = some + { state := .inl .done + input := cfg.input + work := cfg.work + output := cfg.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forBinaryWorkTM])] + simp only [forBinaryWorkTM, hstate, hblank, allReadBack, + ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +/-- A halted body takes one preserving seam step that advances only the +selected driver head. -/ +theorem forBinaryWorkTM_step_body_halt_internal + (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n body.Q) (hhalt : body.halted cfg) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forBinaryWorkTM driverIdx body).step + (forBinaryWorkBodyWrap driverIdx body cfg) = some + { state := .inl .scan + input := cfg.input + work := fun i => + if i = driverIdx then (cfg.work i).move Dir3.right + else cfg.work i + output := cfg.output } := by + rw [TM.step, ite_eq_right (by simp [forBinaryWorkBodyWrap, forBinaryWorkTM])] + simp only [forBinaryWorkBodyWrap, forBinaryWorkTM, hhalt, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + rw [writeAndMove_readBack _ (hwork i)] + split + Β· rfl + Β· rw [idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- A certified bit-driven loop has its advertised exact remaining run. -/ +theorem ForBinaryWorkLoopSpec.reachesIn_internal + {driverIdx : Fin n} {body : TM n} {bodyTime : β„• β†’ β„•} {total : β„•} + (spec : ForBinaryWorkLoopSpec driverIdx body bodyTime total) : + βˆ€ count value, value + count = total β†’ + (forBinaryWorkTM driverIdx body).reachesIn + (forBinaryWorkLoopTime bodyTime value count) + (spec.scanCfg value) spec.doneCfg := by + intro count + induction count with + | zero => + intro value htotal + have hvalue : value = total := by omega + subst value + exact .step spec.stopStep .zero + | succ count ih => + intro value htotal + have hvalue : value < total := by omega + have hscan : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have hbody := spec.bodyRun value hvalue + have hloopback : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.bodyDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have htail := ih (value + 1) (by omega) + have hreach := reachesIn_trans (forBinaryWorkTM driverIdx body) hscan + (reachesIn_trans (forBinaryWorkTM driverIdx body) hbody + (reachesIn_trans (forBinaryWorkTM driverIdx body) hloopback htail)) + convert hreach using 1 + simp only [forBinaryWorkLoopTime] + omega + +/-- Every prefix no longer than a certified loop's exact remaining runtime +respects its auxiliary-space budget. -/ +theorem ForBinaryWorkLoopSpaceSpec.prefix_withinAuxSpace_internal + {driverIdx : Fin n} {body : TM n} {bodyTime : β„• β†’ β„•} + {total inputLength spaceBound : β„•} + {spec : ForBinaryWorkLoopSpec driverIdx body bodyTime total} + (spaceSpec : + ForBinaryWorkLoopSpaceSpec spec inputLength spaceBound) : + βˆ€ count value t (c : Cfg n (forBinaryWorkTM driverIdx body).Q), + value + count = total β†’ + (forBinaryWorkTM driverIdx body).reachesIn t + (spec.scanCfg value) c β†’ + t ≀ forBinaryWorkLoopTime bodyTime value count β†’ + c.WithinAuxSpace inputLength spaceBound := by + intro count + induction count with + | zero => + intro value t c htotal hreach ht + have hvalue : value = total := by omega + subst value + simp only [forBinaryWorkLoopTime] at ht + have ht' : t = 0 ∨ t = 1 := by omega + rcases ht' with rfl | rfl + Β· cases hreach + exact spaceSpec.scanWithin total le_rfl + Β· have hdone : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.scanCfg total) spec.doneCfg := + .step spec.stopStep .zero + have hc := + (forBinaryWorkTM driverIdx body).reachesIn_right_unique hreach hdone + rw [hc] + exact spaceSpec.doneWithin + | succ count ih => + intro value t c htotal hreach ht + have hvalue : value < total := by omega + by_cases htzero : t = 0 + Β· subst t + cases hreach + exact spaceSpec.scanWithin value (Nat.le_of_lt hvalue) + Β· let u := t - 1 + have htu : 1 + u = t := by + dsimp only [u] + omega + by_cases hubody : u ≀ bodyTime value + Β· obtain ⟨d, hprefix, _hsuffix⟩ := reachesIn_prefix_internal + (spec.bodyRun value hvalue) hubody + have hcanonical : (forBinaryWorkTM driverIdx body).reachesIn t + (spec.scanCfg value) d := by + have hscan : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have htotalRun := + reachesIn_trans (forBinaryWorkTM driverIdx body) hscan hprefix + simpa [htu] using htotalRun + have hc := + (forBinaryWorkTM driverIdx body).reachesIn_right_unique + hreach hcanonical + rw [hc] + exact spaceSpec.bodyPrefixWithin value u d hvalue hubody hprefix + Β· let prefixTime := 1 + bodyTime value + 1 + have hprefixTime : prefixTime ≀ t := by + dsimp only [prefixTime, u] at ⊒ hubody + omega + let tailTime := t - prefixTime + have htailEq : prefixTime + tailTime = t := by + dsimp only [tailTime] + exact Nat.add_sub_of_le hprefixTime + have htailBound : + tailTime ≀ + forBinaryWorkLoopTime bodyTime (value + 1) count := by + rw [forBinaryWorkLoopTime] at ht + dsimp only [prefixTime, tailTime] at ⊒ + omega + have htailFull := + spec.reachesIn_internal count (value + 1) (by omega) + obtain ⟨d, htail, _hsuffix⟩ := reachesIn_prefix_internal + htailFull htailBound + have hscan : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have hloopback : (forBinaryWorkTM driverIdx body).reachesIn 1 + (spec.bodyDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have hcanonical := + reachesIn_trans (forBinaryWorkTM driverIdx body) hscan + (reachesIn_trans (forBinaryWorkTM driverIdx body) + (spec.bodyRun value hvalue) + (reachesIn_trans (forBinaryWorkTM driverIdx body) + hloopback htail)) + have hcanonical' : (forBinaryWorkTM driverIdx body).reachesIn t + (spec.scanCfg value) d := by + convert hcanonical using 1 + all_goals + dsimp only [prefixTime] at htailEq ⊒ + omega + have hc := + (forBinaryWorkTM driverIdx body).reachesIn_right_unique + hreach hcanonical' + rw [hc] + exact ih (value + 1) tailTime d (by omega) htail htailBound + +/-- Bit-driven work iteration preserves one-way output when the body does. -/ +theorem IsTransducer.forBinaryWorkTM_internal + {driverIdx : Fin n} {body : TM n} (hbody : body.IsTransducer) : + (forBinaryWorkTM driverIdx body).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase with + | scan => + by_cases hstart : wHeads driverIdx = Ξ“.start + Β· cases iHead <;> cases oHead <;> + simp [forBinaryWorkTM, hstart, allReadBack, idleDir] + Β· by_cases hblank : wHeads driverIdx = Ξ“.blank + Β· cases iHead <;> cases oHead <;> + simp [forBinaryWorkTM, hblank, allReadBack, idleDir] + Β· cases iHead <;> cases oHead <;> + simp [forBinaryWorkTM, hstart, hblank, allReadBack, idleDir] + | done => + cases iHead <;> cases oHead <;> + simp [forBinaryWorkTM, allIdle, idleDir] + | inr state => + by_cases hstate : state = body.qhalt + Β· cases iHead <;> cases oHead <;> + simp [forBinaryWorkTM, hstate, allReadBack, idleDir] + Β· simpa [forBinaryWorkTM, hstate] using hbody state iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput.lean new file mode 100644 index 0000000000..0ecf0293ed --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Defs.lean new file mode 100644 index 0000000000..24a8e277b3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Defs.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Read-only-input loop combinator β€” definitions + +`TM.forInputTM body` scans the Boolean input from left to right and invokes +`body` after each bit. When `body` preserves the input tape, this is exactly one +invocation per original input bit. The input itself is the loop fuel, so the +combinator does not materialize a linear-size unary counter on an auxiliary tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Driver states for the read-only-input loop. -/ +inductive ForInputPhase where + | scan + | done + deriving DecidableEq + +/-- `ForInputPhase` has exactly two states. -/ +instance instFintypeForInputPhase : Fintype ForInputPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- Advance over a Boolean input symbol and run `body`. + +The driver skips an initial left-end marker, advances the read-only input by +one cell before each body invocation, and halts whenever scanning encounters a +blank. Work and output tapes take the structurally safe read-back/idle action in +driver states. Nonhalting body transitions are embedded exactly, so the usual +once-per-original-symbol behavior requires the body to preserve the input tape. -/ +def forInputTM {n : β„•} (body : TM n) : TM n where + Q := ForInputPhase βŠ• body.Q + qstart := .inl .scan + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .scan => + if iHead = Ξ“.start then + (.inl .scan, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + else if iHead = Ξ“.blank then + allReadBack (.inl .done) iHead wHeads oHead + else + (.inr body.qstart, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr q => + if q = body.qhalt then + allReadBack (.inl .scan) iHead wHeads oHead + else + ((Sum.inr (body.Ξ΄ q iHead wHeads oHead).1 : ForInputPhase βŠ• body.Q), + (body.Ξ΄ q iHead wHeads oHead).2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.2.2) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .scan => + dsimp only + split + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr q => + dsimp only + split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact body.Ξ΄_right_of_start q iHead wHeads oHead + +/-- Exact remaining time for an input-driven loop whose body takes +`bodyTime value` steps on iteration `value`. The terminal input-blank exit +takes one step. Each nonterminal iteration takes one scanner step, the body +run, and one loopback step. -/ +def forInputLoopTime (bodyTime : β„• β†’ β„•) (value : β„•) : β„• β†’ β„• + | 0 => 1 + | count + 1 => + 1 + bodyTime value + 1 + forInputLoopTime bodyTime (value + 1) count + +/-- Wrapper-free certificate for the exact control flow of an input-driven +loop. All configurations use the public state type of `forInputTM body`, so +clients need not mention the internal body-state embedding. + +`total` is the first scanner index whose input symbol is blank. -/ +structure ForInputLoopSpec {n : β„•} (body : TM n) (bodyTime : β„• β†’ β„•) + (total : β„•) where + /-- Canonical scanner configuration at iteration `value`. -/ + scanCfg : β„• β†’ Cfg n (forInputTM body).Q + /-- Canonical combined-machine configuration at the start of the body. -/ + bodyStartCfg : β„• β†’ Cfg n (forInputTM body).Q + /-- Canonical combined-machine configuration after the exact body run. -/ + bodyDoneCfg : β„• β†’ Cfg n (forInputTM body).Q + /-- Canonical final driver configuration. -/ + doneCfg : Cfg n (forInputTM body).Q + /-- A nonterminal scanner step enters the body. -/ + scanStep : βˆ€ value, value < total β†’ + (forInputTM body).step (scanCfg value) = some (bodyStartCfg value) + /-- The body has the advertised exact runtime. -/ + bodyRun : βˆ€ value, value < total β†’ + (forInputTM body).reachesIn (bodyTime value) + (bodyStartCfg value) (bodyDoneCfg value) + /-- The preserving seam step advances to the next scanner configuration. -/ + loopbackStep : βˆ€ value, value < total β†’ + (forInputTM body).step (bodyDoneCfg value) = some (scanCfg (value + 1)) + /-- The scanner exits on the first blank. -/ + blankStep : + (forInputTM body).step (scanCfg total) = some doneCfg + +/-- Space obligations needed to turn a `ForInputLoopSpec` into an +all-prefix auxiliary-space certificate. The body obligation concerns only +prefixes of its advertised exact run; later combined-machine execution may +already have crossed the loopback seam. -/ +structure ForInputLoopSpaceSpec {n : β„•} {body : TM n} {bodyTime : β„• β†’ β„•} + {total : β„•} (spec : ForInputLoopSpec body bodyTime total) + (inputLength spaceBound : β„•) where + /-- Every canonical scanner configuration is within the space budget. -/ + scanWithin : βˆ€ value, value ≀ total β†’ + (spec.scanCfg value).WithinAuxSpace inputLength spaceBound + /-- The canonical final configuration is within the space budget. -/ + doneWithin : spec.doneCfg.WithinAuxSpace inputLength spaceBound + /-- Every prefix of each exact body run is within the space budget. -/ + bodyPrefixWithin : βˆ€ value t c, value < total β†’ t ≀ bodyTime value β†’ + (forInputTM body).reachesIn t (spec.bodyStartCfg value) c β†’ + c.WithinAuxSpace inputLength spaceBound + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Internal.lean new file mode 100644 index 0000000000..f5d8dcee8c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForInput/Internal.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability + +/-! +# Read-only-input loop combinator β€” proof internals + +This module supplies the exact body-simulation embedding and the structural +one-way-output proof for `TM.forInputTM`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed a body configuration into the body phase of `forInputTM`. -/ +def forInputBodyWrap (body : TM n) (c : Cfg n body.Q) : + Cfg n (forInputTM body).Q := + { state := .inr c.state + input := c.input + work := c.work + output := c.output } + +/-- Every nonhalting body step is simulated exactly by one `forInputTM` step. -/ +theorem forInputTM_body_step_internal (body : TM n) + {c c' : Cfg n body.Q} (hstep : body.step c = some c') : + (forInputTM body).step (forInputBodyWrap body c) = + some (forInputBodyWrap body c') := by + have hne : c.state β‰  body.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [forInputBodyWrap, forInputTM])] + simp only [forInputBodyWrap, forInputTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize body.Ξ΄ c.state c.input.read (fun i => (c.work i).read) c.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + intro hstep + cases Option.some.inj hstep + rfl + +/-- Exact body runs lift through the body phase of `forInputTM`. -/ +theorem forInputTM_body_reachesIn_internal (body : TM n) + {t : β„•} {c c' : Cfg n body.Q} (hreach : body.reachesIn t c c') : + (forInputTM body).reachesIn t + (forInputBodyWrap body c) (forInputBodyWrap body c') := + reachesIn_map (forInputBodyWrap body) + (fun _ _ => forInputTM_body_step_internal body) hreach + +/-- On a Boolean input symbol, the driver advances the read-only input and +enters the body while preserving every off-start work and output tape. -/ +theorem forInputTM_step_scan_bit_internal (body : TM n) + (c : Cfg n (forInputTM body).Q) + (hstate : c.state = .inl .scan) + (hstart : c.input.read β‰  Ξ“.start) (hblank : c.input.read β‰  Ξ“.blank) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (forInputTM body).step c = some + { state := .inr body.qstart + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forInputTM])] + simp only [forInputTM, hstate, hstart, hblank, allReadBack, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + rw [writeAndMove_readBack _ (hwork i), idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- At the first input blank, the driver halts while preserving all off-start +tapes exactly. -/ +theorem forInputTM_step_scan_blank_internal (body : TM n) + (c : Cfg n (forInputTM body).Q) + (hstate : c.state = .inl .scan) (hblank : c.input.read = Ξ“.blank) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (forInputTM body).step c = some + { state := .inl .done + input := c.input + work := c.work + output := c.output } := by + have hstart : c.input.read β‰  Ξ“.start := by rw [hblank]; decide + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forInputTM])] + simp only [forInputTM, hstate, hblank, allReadBack, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· simp [idleDir, Tape.move] + Β· funext i + rw [writeAndMove_readBack _ (hwork i), idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- A halted body takes one preserving seam step back to the input scanner. -/ +theorem forInputTM_step_body_halt_internal (body : TM n) + (c : Cfg n body.Q) (hhalt : body.halted c) + (hinput : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (forInputTM body).step (forInputBodyWrap body c) = some + { state := .inl .scan + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, ite_eq_right (by simp [forInputBodyWrap, forInputTM])] + simp only [forInputBodyWrap, forInputTM, hhalt, allReadBack, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + rw [writeAndMove_readBack _ (hwork i), idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- A certified input-driven loop has the advertised exact remaining run. -/ +theorem ForInputLoopSpec.reachesIn_internal {body : TM n} + {bodyTime : β„• β†’ β„•} {total : β„•} + (spec : ForInputLoopSpec body bodyTime total) : + βˆ€ count value, value + count = total β†’ + (forInputTM body).reachesIn (forInputLoopTime bodyTime value count) + (spec.scanCfg value) spec.doneCfg := by + intro count + induction count with + | zero => + intro value htotal + have hvalue : value = total := by omega + subst value + exact .step spec.blankStep .zero + | succ count ih => + intro value htotal + have hvalue : value < total := by omega + have hscan : (forInputTM body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have hbody := spec.bodyRun value hvalue + have hloopback : (forInputTM body).reachesIn 1 + (spec.bodyDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have htail := ih (value + 1) (by omega) + have hreach := reachesIn_trans (forInputTM body) hscan + (reachesIn_trans (forInputTM body) hbody + (reachesIn_trans (forInputTM body) hloopback htail)) + convert hreach using 1 + simp only [forInputLoopTime] + omega + +/-- Every configuration reached no later than a certified loop's exact +remaining runtime satisfies its auxiliary-space budget. -/ +theorem ForInputLoopSpaceSpec.prefix_withinAuxSpace_internal + {body : TM n} {bodyTime : β„• β†’ β„•} {total inputLength spaceBound : β„•} + {spec : ForInputLoopSpec body bodyTime total} + (spaceSpec : ForInputLoopSpaceSpec spec inputLength spaceBound) : + βˆ€ count value t (c : Cfg n (forInputTM body).Q), + value + count = total β†’ + (forInputTM body).reachesIn t (spec.scanCfg value) c β†’ + t ≀ forInputLoopTime bodyTime value count β†’ + c.WithinAuxSpace inputLength spaceBound := by + intro count + induction count with + | zero => + intro value t c htotal hreach ht + have hvalue : value = total := by omega + subst value + simp only [forInputLoopTime] at ht + have ht' : t = 0 ∨ t = 1 := by omega + rcases ht' with rfl | rfl + Β· cases hreach + exact spaceSpec.scanWithin total le_rfl + Β· have hdone : (forInputTM body).reachesIn 1 + (spec.scanCfg total) spec.doneCfg := + .step spec.blankStep .zero + have hc := (forInputTM body).reachesIn_right_unique hreach hdone + rw [hc] + exact spaceSpec.doneWithin + | succ count ih => + intro value t c htotal hreach ht + have hvalue : value < total := by omega + by_cases htzero : t = 0 + Β· subst t + cases hreach + exact spaceSpec.scanWithin value (Nat.le_of_lt hvalue) + Β· let u := t - 1 + have htu : 1 + u = t := by + dsimp only [u] + omega + by_cases hubody : u ≀ bodyTime value + Β· obtain ⟨d, hprefix, _hsuffix⟩ := reachesIn_prefix_internal + (spec.bodyRun value hvalue) hubody + have hcanonical : (forInputTM body).reachesIn t + (spec.scanCfg value) d := by + have hscan : (forInputTM body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have htotalRun := reachesIn_trans (forInputTM body) hscan hprefix + simpa [htu] using htotalRun + have hc := (forInputTM body).reachesIn_right_unique hreach hcanonical + rw [hc] + exact spaceSpec.bodyPrefixWithin value u d hvalue hubody hprefix + Β· let prefixTime := 1 + bodyTime value + 1 + have hprefixTime : prefixTime ≀ t := by + dsimp only [prefixTime, u] at ⊒ hubody + omega + let tailTime := t - prefixTime + have htailEq : prefixTime + tailTime = t := by + dsimp only [tailTime] + exact Nat.add_sub_of_le hprefixTime + have htailBound : + tailTime ≀ forInputLoopTime bodyTime (value + 1) count := by + rw [forInputLoopTime] at ht + dsimp only [prefixTime, tailTime] at ⊒ + omega + have htailFull := spec.reachesIn_internal count (value + 1) (by omega) + obtain ⟨d, htail, _hsuffix⟩ := reachesIn_prefix_internal + htailFull htailBound + have hscan : (forInputTM body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have hloopback : (forInputTM body).reachesIn 1 + (spec.bodyDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have hcanonical := reachesIn_trans (forInputTM body) hscan + (reachesIn_trans (forInputTM body) (spec.bodyRun value hvalue) + (reachesIn_trans (forInputTM body) hloopback htail)) + have hcanonical' : (forInputTM body).reachesIn t + (spec.scanCfg value) d := by + convert hcanonical using 1 + all_goals + dsimp only [prefixTime] at htailEq ⊒ + omega + have hc := (forInputTM body).reachesIn_right_unique hreach hcanonical' + rw [hc] + exact ih (value + 1) tailTime d (by omega) htail htailBound + +/-- A read-only-input loop preserves the body's one-way-output discipline. -/ +theorem IsTransducer.forInputTM_internal {body : TM n} + (hbody : body.IsTransducer) : (forInputTM body).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase <;> cases iHead <;> cases oHead <;> + simp [forInputTM, allIdle, allReadBack, idleDir] + | inr q => + by_cases hq : q = body.qhalt + Β· cases oHead <;> simp [forInputTM, hq, allReadBack, idleDir] + Β· simpa [forInputTM, hq] using hbody q iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes.lean new file mode 100644 index 0000000000..e448998507 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Defs.lean new file mode 100644 index 0000000000..39ab3b2128 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Defs.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# One-prefix work-tape loop combinator β€” definitions + +`TM.forWorkOnesTM driverIdx body` scans a work tape from left to right and +invokes `body` once for each consecutive `1` symbol. The driver advances before +each invocation and halts with its head on the first non-`1` symbol. This is the +machine-level control needed to consume the unary-width prefix of a +self-delimiting binary word without materializing the prefix elsewhere. + +Exact iteration semantics require `body` to preserve the already-advanced +driver tape and head. The combinator itself is a concrete `TM`; loop +certificates and proofs live in the adjacent internal and surface modules. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Driver states for a consecutive-one work-tape loop. -/ +inductive ForWorkOnesPhase where + | scan + | done + deriving DecidableEq + +/-- `ForWorkOnesPhase` has exactly two states. -/ +instance instFintypeForWorkOnesPhase : Fintype ForWorkOnesPhase where + elems := {.scan, .done} + complete := fun phase => by cases phase <;> simp + +/-- Advance over one `1` on work tape `driverIdx` and invoke `body`; halt on +the first non-`1` symbol. An initial left marker is skipped safely. -/ +def forWorkOnesTM {n : β„•} (driverIdx : Fin n) (body : TM n) : TM n where + Q := ForWorkOnesPhase βŠ• body.Q + qstart := .inl .scan + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .scan => + if wHeads driverIdx = Ξ“.start then + (.inl .scan, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = driverIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else if wHeads driverIdx = Ξ“.one then + (.inr body.qstart, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = driverIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + allReadBack (.inl .done) iHead wHeads oHead + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr state => + if state = body.qhalt then + allReadBack (.inl .scan) iHead wHeads oHead + else + ((Sum.inr (body.Ξ΄ state iHead wHeads oHead).1 : + ForWorkOnesPhase βŠ• body.Q), + (body.Ξ΄ state iHead wHeads oHead).2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.2.1, + (body.Ξ΄ state iHead wHeads oHead).2.2.2.2.2) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .scan => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hwi + Β· split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hwi + Β· exact rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr state => + dsimp only + split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact body.Ξ΄_right_of_start state iHead wHeads oHead + +/-- Exact remaining time for a one-prefix loop whose body takes +`bodyTime value` steps on iteration `value`. The terminal non-one exit takes +one step. -/ +def forWorkOnesLoopTime (bodyTime : β„• β†’ β„•) (value : β„•) : β„• β†’ β„• + | 0 => 1 + | count + 1 => + 1 + bodyTime value + 1 + forWorkOnesLoopTime bodyTime (value + 1) count + +/-- Wrapper-free exact-control certificate for a consecutive-one work loop. -/ +structure ForWorkOnesLoopSpec {n : β„•} (driverIdx : Fin n) (body : TM n) + (bodyTime : β„• β†’ β„•) (total : β„•) where + /-- Canonical scanner configuration at iteration `value`. -/ + scanCfg : β„• β†’ Cfg n (forWorkOnesTM driverIdx body).Q + /-- Canonical combined-machine configuration at body entry. -/ + bodyStartCfg : β„• β†’ Cfg n (forWorkOnesTM driverIdx body).Q + /-- Canonical combined-machine configuration after the exact body run. -/ + bodyDoneCfg : β„• β†’ Cfg n (forWorkOnesTM driverIdx body).Q + /-- Canonical final driver configuration. -/ + doneCfg : Cfg n (forWorkOnesTM driverIdx body).Q + /-- One scanner step consumes a `1` and enters the body. -/ + scanStep : βˆ€ value, value < total β†’ + (forWorkOnesTM driverIdx body).step (scanCfg value) = + some (bodyStartCfg value) + /-- The body has the advertised exact runtime. -/ + bodyRun : βˆ€ value, value < total β†’ + (forWorkOnesTM driverIdx body).reachesIn (bodyTime value) + (bodyStartCfg value) (bodyDoneCfg value) + /-- The preserving seam returns to the scanner. -/ + loopbackStep : βˆ€ value, value < total β†’ + (forWorkOnesTM driverIdx body).step (bodyDoneCfg value) = + some (scanCfg (value + 1)) + /-- The scanner exits on the first non-`1` symbol. -/ + stopStep : + (forWorkOnesTM driverIdx body).step (scanCfg total) = some doneCfg + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Internal.lean new file mode 100644 index 0000000000..3a3df259ec --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/ForWorkOnes/Internal.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForWorkOnes.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# One-prefix work-tape loop combinator β€” proof internals + +This module proves exact body embedding, driver transitions, certified loop +execution, and one-way-output preservation for `TM.forWorkOnesTM`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed a body configuration in the body phase of `forWorkOnesTM`. -/ +def forWorkOnesBodyWrap (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n body.Q) : Cfg n (forWorkOnesTM driverIdx body).Q := + { state := .inr cfg.state + input := cfg.input + work := cfg.work + output := cfg.output } + +/-- Every nonhalting body step is simulated exactly. -/ +theorem forWorkOnesTM_body_step_internal (driverIdx : Fin n) (body : TM n) + {cfg next : Cfg n body.Q} (hstep : body.step cfg = some next) : + (forWorkOnesTM driverIdx body).step + (forWorkOnesBodyWrap driverIdx body cfg) = + some (forWorkOnesBodyWrap driverIdx body next) := by + have hne : cfg.state β‰  body.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [forWorkOnesBodyWrap, forWorkOnesTM])] + simp only [forWorkOnesBodyWrap, forWorkOnesTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize body.Ξ΄ cfg.state cfg.input.read (fun i => (cfg.work i).read) + cfg.output.read = action + obtain ⟨state, workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + intro hstep + cases Option.some.inj hstep + rfl + +/-- Exact body runs lift through the combined machine's body phase. -/ +theorem forWorkOnesTM_body_reachesIn_internal (driverIdx : Fin n) (body : TM n) + {time : β„•} {cfg next : Cfg n body.Q} + (hreach : body.reachesIn time cfg next) : + (forWorkOnesTM driverIdx body).reachesIn time + (forWorkOnesBodyWrap driverIdx body cfg) + (forWorkOnesBodyWrap driverIdx body next) := + reachesIn_map (forWorkOnesBodyWrap driverIdx body) + (fun _ _ => forWorkOnesTM_body_step_internal driverIdx body) hreach + +/-- On a `1`, the driver advances its selected work head and enters the body. -/ +theorem forWorkOnesTM_step_scan_one_internal (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n (forWorkOnesTM driverIdx body).Q) + (hstate : cfg.state = .inl .scan) + (hone : (cfg.work driverIdx).read = Ξ“.one) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forWorkOnesTM driverIdx body).step cfg = some + { state := .inr body.qstart + input := cfg.input + work := fun i => + if i = driverIdx then (cfg.work i).move Dir3.right else cfg.work i + output := cfg.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forWorkOnesTM])] + simp only [forWorkOnesTM, hstate, hone, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· rw [idleDir, ite_eq_right hinput] + rfl + Β· funext i + rw [writeAndMove_readBack _ (hwork i)] + split + Β· rfl + Β· rw [idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- On the zero separator, the driver halts without consuming it. -/ +theorem forWorkOnesTM_step_scan_zero_internal (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n (forWorkOnesTM driverIdx body).Q) + (hstate : cfg.state = .inl .scan) + (hzero : (cfg.work driverIdx).read = Ξ“.zero) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forWorkOnesTM driverIdx body).step cfg = some + { state := .inl .done + input := cfg.input + work := cfg.work + output := cfg.output } := by + have hstart : (cfg.work driverIdx).read β‰  Ξ“.start := by rw [hzero]; decide + have hone : (cfg.work driverIdx).read β‰  Ξ“.one := by rw [hzero]; decide + rw [TM.step, ite_eq_right (by rw [hstate]; simp [forWorkOnesTM])] + simp only [forWorkOnesTM, hstate, hstart, hone, allReadBack, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· rw [idleDir, ite_eq_right hinput] + rfl + Β· funext i + rw [writeAndMove_readBack _ (hwork i), idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- A halted body takes one preserving seam step back to the scanner. -/ +theorem forWorkOnesTM_step_body_halt_internal (driverIdx : Fin n) (body : TM n) + (cfg : Cfg n body.Q) (hhalt : body.halted cfg) + (hinput : cfg.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (cfg.work i).read β‰  Ξ“.start) + (houtput : cfg.output.read β‰  Ξ“.start) : + (forWorkOnesTM driverIdx body).step + (forWorkOnesBodyWrap driverIdx body cfg) = some + { state := .inl .scan + input := cfg.input + work := cfg.work + output := cfg.output } := by + rw [TM.step, ite_eq_right (by simp [forWorkOnesBodyWrap, forWorkOnesTM])] + simp only [forWorkOnesBodyWrap, forWorkOnesTM, hhalt, allReadBack, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + rw [writeAndMove_readBack _ (hwork i), idleDir, ite_eq_right (hwork i)] + rfl + Β· rw [writeAndMove_readBack _ houtput, idleDir, ite_eq_right houtput] + rfl + +/-- A certified consecutive-one loop has its advertised exact remaining run. -/ +theorem ForWorkOnesLoopSpec.reachesIn_internal + {driverIdx : Fin n} {body : TM n} {bodyTime : β„• β†’ β„•} {total : β„•} + (spec : ForWorkOnesLoopSpec driverIdx body bodyTime total) : + βˆ€ count value, value + count = total β†’ + (forWorkOnesTM driverIdx body).reachesIn + (forWorkOnesLoopTime bodyTime value count) + (spec.scanCfg value) spec.doneCfg := by + intro count + induction count with + | zero => + intro value htotal + have hvalue : value = total := by omega + subst value + exact .step spec.stopStep .zero + | succ count ih => + intro value htotal + have hvalue : value < total := by omega + have hscan : (forWorkOnesTM driverIdx body).reachesIn 1 + (spec.scanCfg value) (spec.bodyStartCfg value) := + .step (spec.scanStep value hvalue) .zero + have hbody := spec.bodyRun value hvalue + have hloopback : (forWorkOnesTM driverIdx body).reachesIn 1 + (spec.bodyDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have htail := ih (value + 1) (by omega) + have hreach := reachesIn_trans (forWorkOnesTM driverIdx body) hscan + (reachesIn_trans (forWorkOnesTM driverIdx body) hbody + (reachesIn_trans (forWorkOnesTM driverIdx body) hloopback htail)) + convert hreach using 1 + simp only [forWorkOnesLoopTime] + omega + +/-- Consecutive-one iteration preserves one-way output when the body does. -/ +theorem IsTransducer.forWorkOnesTM_internal {driverIdx : Fin n} {body : TM n} + (hbody : body.IsTransducer) : + (forWorkOnesTM driverIdx body).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase with + | scan => + by_cases hstart : wHeads driverIdx = Ξ“.start + Β· cases iHead <;> cases oHead <;> + simp [forWorkOnesTM, hstart, allReadBack, idleDir] + Β· by_cases hone : wHeads driverIdx = Ξ“.one + Β· cases iHead <;> cases oHead <;> + simp [forWorkOnesTM, hone, allReadBack, idleDir] + Β· cases iHead <;> cases oHead <;> + simp [forWorkOnesTM, hstart, hone, allReadBack, idleDir] + | done => + cases iHead <;> cases oHead <;> + simp [forWorkOnesTM, allIdle, idleDir] + | inr state => + by_cases hstate : state = body.qhalt + Β· cases oHead <;> simp [forWorkOnesTM, hstate, allReadBack, idleDir] + Β· simpa [forWorkOnesTM, hstate] using hbody state iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Helpers.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Helpers.lean new file mode 100644 index 0000000000..8d02c55ba4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Helpers.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import Mathlib.Data.Fintype.Sum + +/-! +# Tape actions shared by Turing-machine combinators + +Idle and leftward directions respect the start marker. Read-back writes preserve +off-start tape contents, providing the transition invariants used by combinators. +-/ + +@[expose] public section + +namespace Complexity + +variable {n₁ nβ‚‚ : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Direction for an idle tape: move right if reading `β–·`, else stay. + Satisfies `Ξ΄_right_of_start` for tapes not involved in the current phase. -/ +def idleDir (head : Ξ“) : Dir3 := + if head = Ξ“.start then .right else .stay + +/-- Direction for a tape we want to move left: move left unless reading `β–·`, + in which case move right to satisfy `Ξ΄_right_of_start`. During actual + execution the tape won't be at cell 0, so this always moves left. -/ +def moveLeftDir (head : Ξ“) : Dir3 := + if head = Ξ“.start then .right else .left + +/-- `idleDir` moves right when reading the start symbol `β–·`. -/ +theorem idleDir_start : idleDir Ξ“.start = Dir3.right := rfl +private theorem moveLeftDir_start : moveLeftDir Ξ“.start = Dir3.right := rfl + +/-- If the head reads `β–·`, then `idleDir` moves right β€” the shape of the + `Ξ΄_right_of_start` obligation for idle tapes. -/ +theorem idleDir_right_of_start {head : Ξ“} (h : head = Ξ“.start) : idleDir head = Dir3.right := by + subst h; rfl + +/-- If the head reads `β–·`, then `moveLeftDir` moves right β€” the shape of the + `Ξ΄_right_of_start` obligation for tapes being rewound. -/ +theorem moveLeftDir_right_of_start {head : Ξ“} + (h : head = Ξ“.start) : moveLeftDir head = Dir3.right := + by subst h; rfl + +/-- Write back the same symbol read from a tape, preserving cell contents. + Maps `β–·` to `β–‘` since `Tape.write` at position 0 is a no-op anyway. -/ +def readBackWrite (g : Ξ“) : Ξ“w := + match g with + | .zero => .zero + | .one => .one + | .blank => .blank + | .start => .blank + +/-- `readBackWrite` recovers the original symbol away from the left-end marker. -/ +theorem toΞ“_readBackWrite_of_ne_start {g : Ξ“} (h : g β‰  Ξ“.start) : + (readBackWrite g).toΞ“ = g := by + cases g <;> simp_all [readBackWrite, Ξ“w.toΞ“] + +/-- Writing back the symbol under an off-start head is a no-op. -/ +theorem write_readBack (t : Tape) (hread : t.read β‰  Ξ“.start) : + t.write (readBackWrite t.read) = t := by + rw [Tape.write] + split + Β· rfl + Β· refine Tape.ext rfl ?_ + change Function.update t.cells t.head (readBackWrite t.read).toΞ“ = t.cells + rw [toΞ“_readBackWrite_of_ne_start hread, Tape.read, Function.update_eq_self] + +/-- Writing back the symbol under an off-start head and moving is just the move. -/ +theorem writeAndMove_readBack (t : Tape) (hread : t.read β‰  Ξ“.start) (d : Dir3) : + t.writeAndMove (readBackWrite t.read) d = t.move d := by + change (t.write _).move d = t.move d + rw [write_readBack t hread] + +/-- The "do nothing" transition output: all writes are `β–‘`, all directions + are `idleDir`. Used for states that only change the control state. -/ +def allIdle {Οƒ : Type} {k : β„•} + (newState : Οƒ) (iHead : Ξ“) (wHeads : Fin k β†’ Ξ“) (oHead : Ξ“) : + Οƒ Γ— (Fin k β†’ Ξ“w) Γ— Ξ“w Γ— Dir3 Γ— (Fin k β†’ Dir3) Γ— Dir3 := + (newState, fun _ => .blank, .blank, idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + +/-- The content-preserving driver action: write every currently read work and +output symbol back, and use `idleDir` on every tape. Every off-start tape is +preserved exactly; a head on `β–·` takes the structurally mandatory move right. -/ +def allReadBack {Οƒ : Type} {k : β„•} + (newState : Οƒ) (iHead : Ξ“) (wHeads : Fin k β†’ Ξ“) (oHead : Ξ“) : + Οƒ Γ— (Fin k β†’ Ξ“w) Γ— Ξ“w Γ— Dir3 Γ— (Fin k β†’ Dir3) Γ— Dir3 := + (newState, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + +/-- Proof that all-idle directions satisfy `Ξ΄_right_of_start`. -/ +theorem rightOfStart_allIdle (iHead : Ξ“) (wHeads : Fin k β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ idleDir iHead = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ idleDir (wHeads i) = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + +/-- `allReadBack` satisfies the one-sided-tape direction invariant. -/ +theorem rightOfStart_allReadBack (iHead : Ξ“) (wHeads : Fin k β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ idleDir iHead = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ idleDir (wHeads i) = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal.lean new file mode 100644 index 0000000000..6cfbf42765 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Complement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Seq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.If +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Loop +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Union + +/-! +# Combinator proof internals (aggregation) + +This file aggregates the proof-internal modules for the Turing machine +combinators (`Complement`, `Seq`, `If`, `Loop`, `Retarget`, `Scanner`, +`Generic`, `Union`). It contains no definitions of its own; it exists so +that the surface module `Combinators.lean` can pull in all combinator +proof internals with a single import. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Complement.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Complement.lean new file mode 100644 index 0000000000..504fd0bd60 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Complement.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# Complement TM: proof internals + +This file provides the simulation lemmas for `TM.complementTM`, showing that +the complement machine correctly flips the output of the original TM. +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Configuration embedding +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a configuration of `tm` into `tm.complementTM` by tagging the state + with `Sum.inl` and keeping all tapes unchanged. -/ +def complementCfg (tm : TM n) (c : Cfg n tm.Q) : Cfg n (tm.complementTM.Q) := + { state := Sum.inl c.state, input := c.input, work := c.work, output := c.output } + +/-- Embedding the initial configuration of `tm` on input `x` yields the initial + configuration of `tm.complementTM` on `x`. -/ +theorem compCfg_initCfg (tm : TM n) (x : List Bool) : + complementCfg tm (tm.initCfg x) = tm.complementTM.initCfg x := rfl + +/-- The embedding sends configurations in `tm`'s start state to configurations in + `tm.complementTM`'s start state, preserving all tapes. -/ +theorem compCfg_qstart (tm : TM n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + complementCfg tm ⟨tm.qstart, inp, work, out⟩ = + ⟨tm.complementTM.qstart, inp, work, out⟩ := rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: Simulation (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem complementTM_step_sim (tm : TM n) {c c' : Cfg n tm.Q} + (hstep : tm.step c = some c') : + tm.complementTM.step (complementCfg tm c) = some (complementCfg tm c') := by + have hne := state_ne_qhalt_of_step hstep + simp only [TM.step, complementTM, complementCfg] at hstep ⊒ + have hne2 : (Sum.inl c.state : ComplementQ tm.Q) β‰  Sum.inr .done := nofun + simp only [hne, hne2, ↓reduceIte, Option.some.injEq] at hstep ⊒ + rw [← hstep] + +/-- `tm.complementTM` simulates `tm` step-for-step on embedded configurations: a + `t`-step run of `tm` lifts to a `t`-step run of the complement machine. -/ +theorem complementTM_simulation (tm : TM n) {c c' : Cfg n tm.Q} {t : β„•} + (hreach : tm.reachesIn t c c') : + tm.complementTM.reachesIn t (complementCfg tm c) (complementCfg tm c') := + reachesIn_map (tm' := tm.complementTM) (complementCfg tm) + (fun _ _ => complementTM_step_sim tm) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One rewind step: at head > 0, move left, preserve cells. -/ +private theorem complement_rewind_step_left (tm : TM n) (c : Cfg n tm.complementTM.Q) + (hstate : c.state = Sum.inr ComplementPhase.rewind) + (hread_ne : c.output.read β‰  Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', tm.complementTM.step c = some c' ∧ + c'.state = Sum.inr ComplementPhase.rewind ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hstate, complementTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp only [Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· omega + Β· simp + Β· simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + +/-- Base rewind step: at head = 0 (reading β–·), move right to cell 1, enter flip. -/ +private theorem complement_rewind_step_base (tm : TM n) (c : Cfg n tm.complementTM.Q) + (hstate : c.state = Sum.inr ComplementPhase.rewind) + (hread : c.output.read = Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', tm.complementTM.step c = some c' ∧ + c'.state = Sum.inr ComplementPhase.flip ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hhead : c.output.head = 0 := by + by_contra hne + have hge : c.output.head β‰₯ 1 := by omega + exact hnostart c.output.head hge (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, complementTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + +/-- From rewind state with output head at position `h`, reach flip state + at cell 1 with output cells preserved, in `h + 1` steps. -/ +private theorem rewind_loop (tm : TM n) : + βˆ€ (h : β„•) (c : Cfg n tm.complementTM.Q), + c.state = Sum.inr ComplementPhase.rewind β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = h β†’ + βˆƒ c_flip, + tm.complementTM.reachesIn (h + 1) c c_flip ∧ + c_flip.state = Sum.inr ComplementPhase.flip ∧ + c_flip.output.head = 1 ∧ + c_flip.output.cells = c.output.cells := + exists_reachesIn_of_rewindStep_output tm.complementTM + (fun c hst hread hc0 hns => complement_rewind_step_left tm c hst hread hc0 hns) + (fun c hst hread hc0 hns => complement_rewind_step_base tm c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Combined: halt β†’ rewind β†’ flip β†’ done +-- ════════════════════════════════════════════════════════════════════════ + +/-- From halted complementCfg, reach done state with flipped output. + Takes ≀ `output.head + 4` steps. -/ +theorem complementTM_rewind_and_flip (tm : TM n) + (c_halt : Cfg n tm.Q) + (hhalt : tm.halted c_halt) + (hcell0 : c_halt.output.cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ c_halt.output.cells j β‰  Ξ“.start) : + βˆƒ c_done t_rw, + tm.complementTM.reachesIn t_rw (complementCfg tm c_halt) c_done ∧ + tm.complementTM.halted c_done ∧ + c_done.output.cells 1 = (flipBit (c_halt.output.cells 1)).toΞ“ ∧ + t_rw ≀ c_halt.output.head + 4 := by + -- Step 1: halt β†’ rewind (1 step) + have hne : (complementCfg tm c_halt).state β‰  Sum.inr ComplementPhase.done := nofun + have hstep1 : βˆƒ c_rw, tm.complementTM.step (complementCfg tm c_halt) = some c_rw ∧ + c_rw.state = Sum.inr ComplementPhase.rewind ∧ + c_rw.output.cells = c_halt.output.cells ∧ + c_rw.output.head ≀ c_halt.output.head + 1 := by + simp only [TM.step, ↓reduceIte, + show (complementCfg tm c_halt).state = Sum.inl c_halt.state from rfl, + complementTM, hhalt] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· dsimp only [complementCfg] + simp only [Tape.writeAndMove, Tape.move_cells] + by_cases hread : c_halt.output.read = Ξ“.start + Β· have hh0 : c_halt.output.head = 0 := by + have h := hread; simp only [Tape.read] at h + by_contra hne; exact hnostart _ (by omega) h + simp [Tape.write, hh0] + Β· rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + Β· dsimp only [complementCfg] + exact Tape.head_writeAndMove_le _ _ _ + obtain ⟨c_rw, hstep1', hst_rw, hcells_rw, hhead_rw⟩ := hstep1 + -- Step 2: rewind loop (c_rw.output.head + 1 steps) + have hcell0_rw : c_rw.output.cells 0 = Ξ“.start := by rw [hcells_rw]; exact hcell0 + have hnostart_rw : βˆ€ j, j β‰₯ 1 β†’ c_rw.output.cells j β‰  Ξ“.start := by + intro j hj; rw [hcells_rw]; exact hnostart j hj + obtain ⟨c_flip, hreach_rw, hst_flip, hhead_flip, hcells_flip⟩ := + rewind_loop tm c_rw.output.head c_rw hst_rw hcell0_rw hnostart_rw rfl + -- Step 3: flip (1 step) + have hne_flip : c_flip.state β‰  Sum.inr ComplementPhase.done := by rw [hst_flip]; nofun + have hnostart_flip : c_flip.output.read β‰  Ξ“.start := by + simp [Tape.read, hhead_flip, hcells_flip, hcells_rw] + exact hnostart 1 (by omega) + have hne1 : c_halt.output.cells 1 β‰  Ξ“.start := hnostart 1 (by omega) + have hstep3 : βˆƒ c_done, tm.complementTM.step c_flip = some c_done ∧ + c_done.state = Sum.inr ComplementPhase.done ∧ + c_done.output.cells 1 = (flipBit (c_halt.output.cells 1)).toΞ“ := by + simp only [TM.step, hst_flip, complementTM] + refine ⟨_, rfl, rfl, ?_⟩ + simp only [Tape.writeAndMove, Tape.move, Tape.write, Tape.read, hhead_flip, + hcells_flip, hcells_rw] + have hdir2 : idleDir (c_halt.output.cells 1) = Dir3.stay := by + simp [idleDir, hne1] + simp [hdir2, Function.update_self] + obtain ⟨c_done, hstep3', hst_done, hflip⟩ := hstep3 + refine ⟨c_done, ((c_rw.output.head + 1) + 1) + 1, + reachesIn_trans tm.complementTM (.step hstep1' hreach_rw) (.step hstep3' .zero), + hst_done, hflip, by omega⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Main theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- If `tm` decides `L` in time `f`, then `complementTM tm` decides `Lᢜ` + in time `2 * f + 4`. -/ +theorem complementTM_decidesInTime (tm : TM n) {L : Language} {f : β„• β†’ β„•} + (hdec : tm.DecidesInTime L f) : + tm.complementTM.DecidesInTime Lᢜ (fun n => 2 * f n + 4) := by + intro x + obtain ⟨c', t, hle, hreach, hhalt, hyes, hno⟩ := hdec x + have hsim := complementTM_simulation tm hreach + rw [compCfg_initCfg] at hsim + have ⟨_, hout_head, _⟩ := head_le_of_reachesIn tm hreach + have hcell0 := output_cells_zero_eq_start_of_reachesIn hreach (by simp [Tape.init]) + have hnostart := output_cells_ne_start_of_reachesIn hreach (by + intro i hi; simp [Tape.init]; omega) + obtain ⟨c_done, t_rw, hreach_rw, hhalt_done, hflip, hle_rw⟩ := + complementTM_rewind_and_flip tm c' hhalt hcell0 hnostart + have htotal := reachesIn_trans tm.complementTM hsim hreach_rw + refine ⟨c_done, t + t_rw, ?_, htotal, hhalt_done, ?_, ?_⟩ + Β· show t + t_rw ≀ 2 * f x.length + 4 + have : t_rw ≀ t + 4 := le_trans hle_rw (by omega) + omega + Β· intro hxc; rw [hflip, hno hxc]; simp [flipBit] + Β· intro hxc + simp only [Set.mem_compl_iff, not_not] at hxc + rw [hflip, hyes hxc]; simp [flipBit] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean new file mode 100644 index 0000000000..4277d45b8c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean @@ -0,0 +1,366 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Generic proof tools for TM combinators + +This file provides reusable proof infrastructure for TM combinator proofs, +eliminating duplication across `SeqInternal`, `IfInternal`, `LoopInternal`, +and `ComplementInternal`. + +## Main results + +- `reachesIn_map` β€” generic simulation lifting: if a state embedding + commutes with `step`, then `reachesIn` lifts through the embedding +- `exists_reachesIn_of_rewindStep_tape` β€” generic rewind loop for an + arbitrary tape accessor: stepping from a "rewind state" moves the head + left (preserving cells) until cell 0, then enters a "target state" at + head 1 +- `exists_reachesIn_of_rewindStep_output` β€” the same rewind loop + specialized to the output tape +- `exists_reachesIn_of_rewindStep_frame` β€” the output-tape rewind loop, + additionally proving the input and work tapes are unchanged +- `transitionTape` / `transitionInput` β€” the standard tape operations + applied at combinator phase boundaries, with cell-preservation and + head-bound lemmas (`transitionTape_cells`, `transitionInput_cells`, + `one_le_head_transitionTape`, `transitionInput_head_ge`, + `head_transitionTape_le`) +- `transitionTape_eq_self` / `transitionInput_eq_self` β€” frame rules: + both operations are no-ops on tapes reading a non-β–· symbol + +## Shared tape stability lemmas + +These lemmas were previously duplicated across multiple Internal files. +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Shared tape lemmas (deduplicated from Internal files) +-- ════════════════════════════════════════════════════════════════════════ + +/-- A tape with head β‰₯ 1 and cells β‰₯ 1 β‰  start is stable under + `writeAndMove(readBackWrite(read).toΞ“, idleDir(read))`. -/ +theorem tape_writeAndMove_stable (t : Tape) + (hhead : t.head β‰₯ 1) (hns : βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read).toΞ“ (idleDir t.read) = t := by + have hne : t.read β‰  Ξ“.start := by simp only [Tape.read]; exact hns t.head hhead + rw [toΞ“_readBackWrite_of_ne_start hne] + change (t.write t.read).move (idleDir t.read) = t + simp only [idleDir, hne, ↓reduceIte] + change (t.write (t.cells t.head)).move .stay = t + simp only [Tape.write, show Β¬(t.head = 0) by omega, ↓reduceIte, + Function.update_eq_self, Tape.move] + +/-- A tape with head β‰₯ 1 and cells β‰₯ 1 β‰  start is stable under `move(idleDir(read))`. -/ +theorem tape_move_idleDir_stable (t : Tape) + (hhead : t.head β‰₯ 1) (hns : βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start) : + t.move (idleDir t.read) = t := by + have hne : t.read β‰  Ξ“.start := by simp only [Tape.read]; exact hns t.head hhead + simp only [idleDir, hne, ↓reduceIte, Tape.move] + +/-- Helper: readBackWrite preserves tape cells when head = 0 or read β‰  start. -/ +theorem tape_readBackWrite_preserves (t : Tape) (d : Dir3) + (h : t.head = 0 ∨ t.read β‰  Ξ“.start) : + (t.writeAndMove (readBackWrite t.read).toΞ“ d).cells = t.cells := by + simp only [Tape.writeAndMove, Tape.move_cells] + rcases h with hh0 | hne + Β· simp only [Tape.write, hh0, ↓reduceIte] + Β· rw [toΞ“_readBackWrite_of_ne_start hne] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + +-- ════════════════════════════════════════════════════════════════════════ +-- Generic simulation lifting +-- ════════════════════════════════════════════════════════════════════════ + +/-- If `wrap` commutes with `step` (i.e., one step of `tm` corresponds to + one step of `tm'` through the embedding), then `reachesIn` lifts. -/ +theorem reachesIn_map {tm tm' : TM n} + (wrap : Cfg n tm.Q β†’ Cfg n tm'.Q) + (h_step : βˆ€ c c' : Cfg n tm.Q, tm.step c = some c' β†’ + tm'.step (wrap c) = some (wrap c')) + {t : β„•} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn t c c') : + tm'.reachesIn t (wrap c) (wrap c') := by + induction hreach with + | zero => exact .zero + | step hstep _ ih => exact .step (h_step _ _ hstep) ih + +-- ════════════════════════════════════════════════════════════════════════ +-- Generic tape rewind loop (parameterized by tape accessor) +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Generic rewind loop (abstract tape accessor)**. + + For any TM with a designated "rewind state" where stepping: + - At head > 0: stays in rewind, moves head left by 1, preserves cells + - At head = 0: enters target state, moves head to 1, preserves cells + + Then from rewind state with tape head at `p`, the machine reaches the + target state with tape head at 1 in exactly `p + 1` steps. + + The `tape` parameter selects which tape to track (output, work, etc.). + This captures the common rewind pattern used in `complementTM`, `ifTM`, + `loopTM`, `writeTM`, and `rewindWorkTM`. -/ +theorem exists_reachesIn_of_rewindStep_tape (tm : TM n) (tape : Cfg n tm.Q β†’ Tape) + {rewindState targetState : tm.Q} + (h_step_left : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + (tape c).read β‰  Ξ“.start β†’ + (tape c).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (tape c).cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = rewindState ∧ + (tape c').head = (tape c).head - 1 ∧ + (tape c').cells = (tape c).cells) + (h_step_base : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + (tape c).read = Ξ“.start β†’ + (tape c).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (tape c).cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = targetState ∧ + (tape c').head = 1 ∧ + (tape c').cells = (tape c).cells) : + βˆ€ (p : β„•) (c : Cfg n tm.Q), + c.state = rewindState β†’ + (tape c).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (tape c).cells j β‰  Ξ“.start) β†’ + (tape c).head = p β†’ + βˆƒ c_target, + tm.reachesIn (p + 1) c c_target ∧ + c_target.state = targetState ∧ + (tape c_target).head = 1 ∧ + (tape c_target).cells = (tape c).cells := by + intro p + induction p with + | zero => + intro c hstate hcell0 _ hhead + have hread : (tape c).read = Ξ“.start := by simp [Tape.read, hhead, hcell0] + obtain ⟨c', hstep, hst, hh, hc⟩ := h_step_base c hstate hread hcell0 (by assumption) + exact ⟨c', .step hstep .zero, hst, hh, hc⟩ + | succ p ih => + intro c hstate hcell0 hnostart hhead + have hread_ne : (tape c).read β‰  Ξ“.start := by + simpa only [Tape.read, hhead] using hnostart (p + 1) (by omega) + obtain ⟨c', hstep, hst, hh, hcells⟩ := h_step_left c hstate hread_ne hcell0 hnostart + have hh' : (tape c').head = p := by rw [hh, hhead]; omega + obtain ⟨c_target, hreach, hst_t, hh_t, hcells_t⟩ := ih c' hst + (by rw [hcells]; exact hcell0) + (by intro j hj; rw [hcells]; exact hnostart j hj) hh' + exact ⟨c_target, .step hstep hreach, hst_t, hh_t, by rw [hcells_t, hcells]⟩ + +/-- Specialization of `exists_reachesIn_of_rewindStep_tape` for the output tape. -/ +theorem exists_reachesIn_of_rewindStep_output (tm : TM n) + {rewindState targetState : tm.Q} + (h_step_left : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + c.output.read β‰  Ξ“.start β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = rewindState ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells) + (h_step_base : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + c.output.read = Ξ“.start β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = targetState ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells) : + βˆ€ (p : β„•) (c : Cfg n tm.Q), + c.state = rewindState β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = p β†’ + βˆƒ c_target, + tm.reachesIn (p + 1) c c_target ∧ + c_target.state = targetState ∧ + c_target.output.head = 1 ∧ + c_target.output.cells = c.output.cells := + exists_reachesIn_of_rewindStep_tape tm (fun c => c.output) h_step_left h_step_base + +/-- **Generic rewind loop (full tape tracking)**. + + Same as `exists_reachesIn_of_rewindStep_output`, but the step hypotheses also guarantee + that input and work tapes are preserved (given stability conditions: + head β‰₯ 1 and cells β‰₯ 1 β‰  start). The conclusion additionally proves + `c_target.input = c.input` and `c_target.work = c.work`. -/ +theorem exists_reachesIn_of_rewindStep_frame (tm : TM n) + {rewindState targetState : tm.Q} + (h_step_left : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + c.output.read β‰  Ξ“.start β†’ + c.output.cells 0 = Ξ“.start β†’ (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.input.head β‰₯ 1 β†’ (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + (βˆ€ i, (c.work i).head β‰₯ 1) β†’ (βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = rewindState ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work) + (h_step_base : βˆ€ c : Cfg n tm.Q, + c.state = rewindState β†’ + c.output.read = Ξ“.start β†’ + c.output.cells 0 = Ξ“.start β†’ (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.input.head β‰₯ 1 β†’ (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + (βˆ€ i, (c.work i).head β‰₯ 1) β†’ (βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) β†’ + βˆƒ c', tm.step c = some c' ∧ + c'.state = targetState ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work) : + βˆ€ (p : β„•) (c : Cfg n tm.Q), + c.state = rewindState β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = p β†’ + c.input.head β‰₯ 1 β†’ (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + (βˆ€ i, (c.work i).head β‰₯ 1) β†’ (βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) β†’ + βˆƒ c_target, + tm.reachesIn (p + 1) c c_target ∧ + c_target.state = targetState ∧ + c_target.output.head = 1 ∧ + c_target.output.cells = c.output.cells ∧ + c_target.input = c.input ∧ + c_target.work = c.work := by + intro p + induction p with + | zero => + intro c hstate hcell0 _ hhead h_ih h_ins h_wh h_wns + have hread : c.output.read = Ξ“.start := by simp [Tape.read, hhead, hcell0] + obtain ⟨c', hstep, hst, hh, hcells, hinp, hwork⟩ := + h_step_base c hstate hread hcell0 (by assumption) h_ih h_ins h_wh h_wns + exact ⟨c', .step hstep .zero, hst, hh, hcells, hinp, hwork⟩ + | succ p ih => + intro c hstate hcell0 hnostart hhead h_ih h_ins h_wh h_wns + have hread_ne : c.output.read β‰  Ξ“.start := by + simpa only [Tape.read, hhead] using hnostart (p + 1) (by omega) + obtain ⟨c', hstep, hst, hh, hcells, hinp, hwork⟩ := + h_step_left c hstate hread_ne hcell0 hnostart h_ih h_ins h_wh h_wns + have hh' : c'.output.head = p := by rw [hh, hhead]; omega + obtain ⟨c_target, hreach, hst_t, hh_t, hcells_t, hinp_t, hwork_t⟩ := ih c' hst + (by rw [hcells]; exact hcell0) + (by intro j hj; rw [hcells]; exact hnostart j hj) hh' + (by rw [hinp]; exact h_ih) (by rw [hinp]; exact h_ins) + (by intro i; rw [hwork]; exact h_wh i) + (by intro i j hj; rw [hwork]; exact h_wns i j hj) + exact ⟨c_target, .step hstep hreach, hst_t, hh_t, + by rw [hcells_t, hcells], + by rw [hinp_t, hinp], + by rw [hwork_t, hwork]⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Standard phase-transition tape operations +-- ════════════════════════════════════════════════════════════════════════ + +/-- The standard tape transformation applied at combinator phase boundaries + (work tapes and output tape). Writes back the current symbol (preserving + cells) and stays in place; if at cell 0, `Ξ΄_right_of_start` forces a + right move to cell 1. + + Used by all combinators (`seqTM`, `ifTM`, `loopTM`, `complementTM`) + at transitions between phases. -/ +def transitionTape (t : Tape) : Tape := + t.writeAndMove (readBackWrite t.read).toΞ“ (idleDir t.read) + +/-- The standard input-tape transformation at combinator phase boundaries. + The input tape is read-only (no write), so only the head moves: stay + in place unless at cell 0, where `Ξ΄_right_of_start` forces right. -/ +def transitionInput (t : Tape) : Tape := + t.move (idleDir t.read) + +/-- `transitionTape` preserves cells when cells β‰₯ 1 β‰  start. -/ +theorem transitionTape_cells (t : Tape) + (hns : βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start) : + (transitionTape t).cells = t.cells := by + simp only [transitionTape, Tape.writeAndMove, Tape.move_cells] + by_cases hh : t.head = 0 + Β· simp only [Tape.write, hh, ↓reduceIte] + Β· have hge : t.head β‰₯ 1 := by omega + rw [toΞ“_readBackWrite_of_ne_start (by simp only [Tape.read]; exact hns t.head hge)] + simp only [Tape.write, hh, ↓reduceIte, Tape.read, Function.update_eq_self] + +/-- `transitionInput` preserves cells (always, since input has no write). -/ +theorem transitionInput_cells (t : Tape) : + (transitionInput t).cells = t.cells := by + simp [transitionInput, Tape.move]; split <;> rfl + +/-- After `transitionTape`, head β‰₯ 1 when cell 0 = start. -/ +theorem one_le_head_transitionTape (t : Tape) (h0 : t.cells 0 = Ξ“.start) : + (transitionTape t).head β‰₯ 1 := by + unfold transitionTape Tape.writeAndMove + by_cases hh : t.head = 0 + Β· simp only [Tape.write, hh, ↓reduceIte, Tape.read, h0, idleDir, Tape.move]; omega + Β· cases hdir : idleDir t.read with + | stay => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | right => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | left => exfalso; revert hdir; simp only [idleDir]; split <;> simp + +/-- After `transitionInput`, head β‰₯ 1 when cell 0 = start. -/ +theorem transitionInput_head_ge (t : Tape) (h0 : t.cells 0 = Ξ“.start) : + (transitionInput t).head β‰₯ 1 := by + unfold transitionInput + by_cases hh : t.head = 0 + Β· simp only [Tape.read, hh, h0, idleDir, ↓reduceIte, Tape.move]; omega + Β· cases hdir : idleDir t.read with + | stay => simp only [Tape.move]; omega + | right => simp only [Tape.move]; omega + | left => exfalso; revert hdir; simp only [idleDir]; split <;> simp + +/-- Bound on `transitionTape` output head: ≀ original head + 1. -/ +theorem head_transitionTape_le {t : Tape} {p_bound : β„•} + (hcell0 : t.cells 0 = Ξ“.start) (hhead : t.head ≀ p_bound) : + (transitionTape t).head ≀ p_bound + 1 := by + unfold transitionTape Tape.writeAndMove + by_cases hh : t.head = 0 + Β· simp only [Tape.write, hh, ↓reduceIte, Tape.read, hcell0, idleDir, Tape.move]; omega + Β· cases hdir : idleDir t.read with + | stay => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | right => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | left => exfalso; revert hdir; simp only [idleDir]; split <;> simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Frame rules: transitionTape/transitionInput are identity on stable tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Frame rule**: `transitionTape` is the identity when the tape reads a + non-β–· symbol. This is the key lemma for threading invariants through + `seqTM` / `loopTM` / `ifTM` composition: tapes that are "stable" + (head not at cell 0) pass through phase transitions unchanged. -/ +theorem transitionTape_eq_self {t : Tape} (hread : t.read β‰  Ξ“.start) : + transitionTape t = t := by + unfold transitionTape Tape.writeAndMove + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [idleDir, hread, ↓reduceIte, Tape.move, Tape.write] + split + Β· rfl + Β· simp only [Tape.read, Function.update_eq_self] + +/-- **Frame rule**: `transitionInput` is the identity when the tape reads a + non-β–· symbol. -/ +theorem transitionInput_eq_self {t : Tape} (hread : t.read β‰  Ξ“.start) : + transitionInput t = t := by + simp only [transitionInput, idleDir, hread, ↓reduceIte, Tape.move] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/If.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/If.lean new file mode 100644 index 0000000000..0caadcddb0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/If.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# ifTM simulation β€” proof internals + +This file contains the simulation lemmas for `ifTM tmTest tmThen tmElse`. + +## Key definitions + +- `ifTestWrap` β€” embed a `tmTest` config into the `ifTM` config space +- `ifThenWrap` β€” embed a `tmThen` config into the `ifTM` config space +- `ifElseWrap` β€” embed a `tmElse` config into the `ifTM` config space +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a `tmTest` config into the `ifTM` config space (test phase). -/ +def ifTestWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmTest.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inl c.state + input := c.input + work := c.work + output := c.output + +/-- Embed a `tmThen` config into the `ifTM` config space (then branch). -/ +def ifThenWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmThen.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inr (Sum.inr (Sum.inl c.state)) + input := c.input + work := c.work + output := c.output + +/-- Embed a `tmElse` config into the `ifTM` config space (else branch). -/ +def ifElseWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmElse.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inr (Sum.inr (Sum.inr c.state)) + input := c.input + work := c.work + output := c.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Sum discrimination helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem ifQ_test_ne_halt {QT QThen QElse : Type} {q : QT} : + (Sum.inl q : IfQ QT QThen QElse) β‰  Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_then_ne_halt {QT QThen QElse : Type} {q : QThen} : + (Sum.inr (Sum.inr (Sum.inl q)) : IfQ QT QThen QElse) β‰  + Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_else_ne_halt {QT QThen QElse : Type} {q : QElse} : + (Sum.inr (Sum.inr (Sum.inr q)) : IfQ QT QThen QElse) β‰  + Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_phase_ne_halt {QT QThen QElse : Type} + {p : IfPhase} (hp : p β‰  .done) : + (Sum.inr (Sum.inl p) : IfQ QT QThen QElse) β‰  + Sum.inr (Sum.inl IfPhase.done) := + fun h => hp (Sum.inl.inj (Sum.inr.inj h)) + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase: ifTM simulates tmTest (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmTest` corresponds to one step of `ifTM` during the test phase. -/ +theorem ifTM_test_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmTest.Q} + (hstep : tmTest.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifTestWrap tmTest tmThen tmElse c) = + some (ifTestWrap tmTest tmThen tmElse c') := by + classical + have hne : c.state β‰  tmTest.qhalt := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [ifTestWrap, ifTM, ite_eq_right ifQ_test_ne_halt, ite_eq_right hne] + +/-- Multi-step test phase simulation. -/ +theorem ifTM_reachesIn_ifTestWrap (tmTest tmThen tmElse : TM n) {t : β„•} + {c_start c_end : Cfg n tmTest.Q} + (hreach : tmTest.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifTestWrap tmTest tmThen tmElse c_start) + (ifTestWrap tmTest tmThen tmElse c_end) := + reachesIn_map (tm' := ifTM tmTest tmThen tmElse) (ifTestWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_test_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Then branch: ifTM simulates tmThen (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmThen` corresponds to one step of `ifTM` during the then branch. -/ +theorem ifTM_then_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmThen.Q} + (hstep : tmThen.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifThenWrap tmTest tmThen tmElse c) = + some (ifThenWrap tmTest tmThen tmElse c') := by + classical + have hne : c.state β‰  tmThen.qhalt := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [ifThenWrap, ifTM, ite_eq_right ifQ_then_ne_halt, ite_eq_right hne] + +/-- Multi-step then-branch simulation. -/ +theorem ifTM_reachesIn_ifThenWrap (tmTest tmThen tmElse : TM n) {t : β„•} + {c_start c_end : Cfg n tmThen.Q} + (hreach : tmThen.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifThenWrap tmTest tmThen tmElse c_start) + (ifThenWrap tmTest tmThen tmElse c_end) := + reachesIn_map (tm' := ifTM tmTest tmThen tmElse) (ifThenWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_then_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Else branch: ifTM simulates tmElse (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmElse` corresponds to one step of `ifTM` during the else branch. -/ +theorem ifTM_else_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmElse.Q} + (hstep : tmElse.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifElseWrap tmTest tmThen tmElse c) = + some (ifElseWrap tmTest tmThen tmElse c') := by + classical + have hne : c.state β‰  tmElse.qhalt := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [ifElseWrap, ifTM, ite_eq_right ifQ_else_ne_halt, ite_eq_right hne] + +/-- Multi-step else-branch simulation. -/ +theorem ifTM_reachesIn_ifElseWrap (tmTest tmThen tmElse : TM n) {t : β„•} + {c_start c_end : Cfg n tmElse.Q} + (hreach : tmElse.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifElseWrap tmTest tmThen tmElse c_start) + (ifElseWrap tmTest tmThen tmElse c_end) := + reachesIn_map (tm' := ifTM tmTest tmThen tmElse) (ifElseWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_else_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Halt transitions: branch halt β†’ done +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tmThen` halts, one step transitions to `done`. -/ +theorem ifTM_then_halt_step (tmTest tmThen tmElse : TM n) {c : Cfg n tmThen.Q} + (hhalt : c.state = tmThen.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifThenWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.done), + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape c.output } := by + classical + unfold step + simp only [ifThenWrap, ifTM, ite_eq_right ifQ_then_ne_halt, hhalt, ↓reduceIte] + congr 1 + +/-- When `tmElse` halts, one step transitions to `done`. -/ +theorem ifTM_else_halt_step (tmTest tmThen tmElse : TM n) {c : Cfg n tmElse.Q} + (hhalt : c.state = tmElse.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifElseWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.done), + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape c.output } := by + classical + unfold step + simp only [ifElseWrap, ifTM, ite_eq_right ifQ_else_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase β†’ rewind transition +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tmTest` halts, one step enters the rewindOut phase. -/ +theorem ifTM_test_to_rewind (tmTest tmThen tmElse : TM n) {c : Cfg n tmTest.Q} + (hhalt : c.state = tmTest.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifTestWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.rewindOut), + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape c.output } := by + classical + unfold step + simp only [ifTestWrap, ifTM, ite_eq_right ifQ_test_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting +-- ════════════════════════════════════════════════════════════════════════ + +theorem ifTM_qhalt_eq_done (tmTest tmThen tmElse : TM n) : + (ifTM tmTest tmThen tmElse).qhalt = Sum.inr (Sum.inl IfPhase.done) := rfl + +/-- The `done` state is halted in `ifTM`. -/ +theorem ifTM_halted_of_state_eq_done (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (h : c.state = Sum.inr (Sum.inl IfPhase.done)) : + (ifTM tmTest tmThen tmElse).halted c := h + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (full tape tracking, via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem if_rewind_step_left_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread_ne : c.output.read β‰  Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) + (h_ih : c.input.head β‰₯ 1) (h_ins : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) + (h_wh : βˆ€ i, (c.work i).head β‰₯ 1) (h_wns : βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) : + βˆƒ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state β‰  (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· simp only [Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· omega + Β· simp + Β· simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + Β· exact tape_move_idleDir_stable _ h_ih h_ins + Β· funext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +private theorem if_rewind_step_base_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread : c.output.read = Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) + (h_ih : c.input.head β‰₯ 1) (h_ins : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) + (h_wh : βˆ€ i, (c.work i).head β‰₯ 1) (h_wns : βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) : + βˆƒ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state β‰  (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hhead : c.output.head = 0 := by + by_contra hne + exact hnostart c.output.head (by omega) (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + Β· exact tape_move_idleDir_stable _ h_ih h_ins + Β· funext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +/-- Extended rewind loop: also tracks that input and work tapes are preserved + when they satisfy the stability condition (head β‰₯ 1, cells β‰₯ 1 β‰  start). -/ +theorem ifTM_rewindOut_reachesIn_check (tmTest tmThen tmElse : TM n) : + βˆ€ (p : β„•) (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)), + c.state = Sum.inr (Sum.inl IfPhase.rewindOut) β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = p β†’ + c.input.head β‰₯ 1 β†’ (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + (βˆ€ i, (c.work i).head β‰₯ 1) β†’ + (βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) β†’ + βˆƒ c_check, + (ifTM tmTest tmThen tmElse).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells ∧ + c_check.input = c.input ∧ + c_check.work = c.work := + exists_reachesIn_of_rewindStep_frame (ifTM tmTest tmThen tmElse) + (fun c hst hread hc0 hns h_ih h_ins h_wh h_wns => + if_rewind_step_left_full tmTest tmThen tmElse c hst hread hc0 hns h_ih h_ins h_wh h_wns) + (fun c hst hread hc0 hns h_ih h_ins h_wh h_wns => + if_rewind_step_base_full tmTest tmThen tmElse c hst hread hc0 hns h_ih h_ins h_wh h_wns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Check step (full tape tracking) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Check step to then-branch, tracking all tapes. -/ +theorem ifTM_check_step_then_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Ξ“.one) + (h_ih : c.input.head β‰₯ 1) (h_ins : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) + (h_wh : βˆ€ i, (c.work i).head β‰₯ 1) + (h_wns : βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) : + βˆƒ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inl tmThen.qstart)) ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state β‰  (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread : c.output.read = Ξ“.one := by simp [Tape.read, hhead, hcell1] + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· show (c.output.writeAndMove (readBackWrite Ξ“.one).toΞ“ (idleDir Ξ“.one)).cells = c.output.cells + simp only [readBackWrite, Ξ“w.toΞ“, idleDir, Tape.writeAndMove, Tape.move_cells] + simp only [Tape.write]; split + Β· omega + Β· dsimp only []; rw [hhead, ← hcell1]; exact Function.update_eq_self _ _ + Β· simp only [readBackWrite, Ξ“w.toΞ“, idleDir, Tape.writeAndMove, Tape.move, Tape.write] + split <;> simp_all + Β· exact tape_move_idleDir_stable _ h_ih h_ins + Β· funext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +/-- Check step to else-branch, tracking all tapes. -/ +theorem ifTM_check_step_else_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 β‰  Ξ“.one) + (hnostart_out : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) + (h_ih : c.input.head β‰₯ 1) (h_ins : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) + (h_wh : βˆ€ i, (c.work i).head β‰₯ 1) + (h_wns : βˆ€ i j, j β‰₯ 1 β†’ (c.work i).cells j β‰  Ξ“.start) : + βˆƒ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inr tmElse.qstart)) ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state β‰  (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread_ne_one : c.output.read β‰  Ξ“.one := by simp [Tape.read, hhead]; exact hcell1 + have hread_ne_start : c.output.read β‰  Ξ“.start := by + simp only [Tape.read, hhead]; exact hnostart_out 1 (by omega) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne_one] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· apply tape_readBackWrite_preserves; right; exact hread_ne_start + Β· have hstable := tape_writeAndMove_stable c.output (by omega) hnostart_out + show (c.output.writeAndMove (readBackWrite c.output.read).toΞ“ + (idleDir c.output.read)).head = 1 + rw [hstable, hhead] + Β· exact tape_move_idleDir_stable _ h_ih h_ins + Β· funext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Loop.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Loop.lean new file mode 100644 index 0000000000..a119167400 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Loop.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# loopTM simulation β€” proof internals + +This file contains the simulation lemmas for `loopTM tmBody tmTest`. + +## Key definitions + +- `loopBodyWrap` β€” embed a `tmBody` config into the `loopTM` config space +- `loopTestWrap` β€” embed a `tmTest` config into the `loopTM` config space +- Tape transformations use the shared `transitionTape` / `transitionInput` +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a `tmBody` config into the `loopTM` config space (body phase). -/ +def loopBodyWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmBody.Q) : + Cfg n (LoopQ tmBody.Q tmTest.Q) where + state := Sum.inl c.state + input := c.input + work := c.work + output := c.output + +/-- Embed a `tmTest` config into the `loopTM` config space (test phase). -/ +def loopTestWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmTest.Q) : + Cfg n (LoopQ tmBody.Q tmTest.Q) where + state := Sum.inr (Sum.inr c.state) + input := c.input + work := c.work + output := c.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Sum discrimination helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loopQ_body_ne_halt {QBody QTest : Type} {q : QBody} : + (Sum.inl q : LoopQ QBody QTest) β‰  Sum.inr (Sum.inl LoopPhase.done) := nofun + +private theorem loopQ_test_ne_halt {QBody QTest : Type} {q : QTest} : + (Sum.inr (Sum.inr q) : LoopQ QBody QTest) β‰  + Sum.inr (Sum.inl LoopPhase.done) := nofun + +-- ════════════════════════════════════════════════════════════════════════ +-- Body phase: loopTM simulates tmBody (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- A non-halting `tmBody` step is simulated by one `loopTM` step on +body-wrapped configurations. -/ +theorem loopTM_body_step (tmBody tmTest : TM n) {c c' : Cfg n tmBody.Q} + (hstep : tmBody.step c = some c') : + (loopTM tmBody tmTest).step (loopBodyWrap tmBody tmTest c) = + some (loopBodyWrap tmBody tmTest c') := by + classical + have hne : c.state β‰  tmBody.qhalt := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [loopBodyWrap, loopTM, ite_eq_right loopQ_body_ne_halt, ite_eq_right hne] + +/-- A `t`-step run of `tmBody` lifts to a `t`-step run of `loopTM` between the +body-wrapped configurations. -/ +theorem loopTM_body_simulation (tmBody tmTest : TM n) {t : β„•} + {c_start c_end : Cfg n tmBody.Q} + (hreach : tmBody.reachesIn t c_start c_end) : + (loopTM tmBody tmTest).reachesIn t + (loopBodyWrap tmBody tmTest c_start) (loopBodyWrap tmBody tmTest c_end) := + reachesIn_map (tm' := loopTM tmBody tmTest) (loopBodyWrap tmBody tmTest) + (fun _ _ => loopTM_body_step tmBody tmTest) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Body β†’ test transition +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tmBody` has halted, one `loopTM` step moves from the body-wrapped +configuration to `tmTest`'s start state, applying the shared tape transition to +every tape. -/ +theorem loopTM_body_to_test (tmBody tmTest : TM n) {c : Cfg n tmBody.Q} + (hhalt : c.state = tmBody.qhalt) : + (loopTM tmBody tmTest).step (loopBodyWrap tmBody tmTest c) = + some (loopTestWrap tmBody tmTest + { state := tmTest.qstart, + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape c.output }) := by + classical + unfold step + simp only [loopBodyWrap, loopTM, ite_eq_right loopQ_body_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase: loopTM simulates tmTest (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- A non-halting `tmTest` step is simulated by one `loopTM` step on +test-wrapped configurations. -/ +theorem loopTM_test_step (tmBody tmTest : TM n) {c c' : Cfg n tmTest.Q} + (hstep : tmTest.step c = some c') : + (loopTM tmBody tmTest).step (loopTestWrap tmBody tmTest c) = + some (loopTestWrap tmBody tmTest c') := by + classical + have hne : c.state β‰  tmTest.qhalt := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [loopTestWrap, loopTM, ite_eq_right loopQ_test_ne_halt, ite_eq_right hne] + +/-- A `t`-step run of `tmTest` lifts to a `t`-step run of `loopTM` between the +test-wrapped configurations. -/ +theorem loopTM_test_simulation (tmBody tmTest : TM n) {t : β„•} + {c_start c_end : Cfg n tmTest.Q} + (hreach : tmTest.reachesIn t c_start c_end) : + (loopTM tmBody tmTest).reachesIn t + (loopTestWrap tmBody tmTest c_start) (loopTestWrap tmBody tmTest c_end) := + reachesIn_map (tm' := loopTM tmBody tmTest) (loopTestWrap tmBody tmTest) + (fun _ _ => loopTM_test_step tmBody tmTest) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Test β†’ rewind transition +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tmTest` has halted, one `loopTM` step moves from the test-wrapped +configuration to the `rewindOut` phase, applying the shared tape transition to +every tape. -/ +theorem loopTM_test_to_rewind (tmBody tmTest : TM n) {c : Cfg n tmTest.Q} + (hhalt : c.state = tmTest.qhalt) : + (loopTM tmBody tmTest).step (loopTestWrap tmBody tmTest c) = + some { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape c.output } := by + classical + unfold step + simp only [loopTestWrap, loopTM, ite_eq_right loopQ_test_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loop_rewind_step_left (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread_ne : c.output.read β‰  Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state β‰  (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp only [Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· omega + Β· simp + Β· simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + +private theorem loop_rewind_step_base (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread : c.output.read = Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state β‰  (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hhead : c.output.head = 0 := by + by_contra hne + have hge : c.output.head β‰₯ 1 := by omega + exact hnostart c.output.head hge (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + +/-- From the `rewindOut` phase with the output head at position `p`, `loopTM` +reaches the `check` phase in `p + 1` steps with the output head at cell 1 and +the output cells unchanged. -/ +theorem loopTM_rewind_loop (tmBody tmTest : TM n) : + βˆ€ (p : β„•) (c : Cfg n (LoopQ tmBody.Q tmTest.Q)), + c.state = Sum.inr (Sum.inl LoopPhase.rewindOut) β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = p β†’ + βˆƒ c_check, + (loopTM tmBody tmTest).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells := + exists_reachesIn_of_rewindStep_output (loopTM tmBody tmTest) + (fun c hst hread hc0 hns => loop_rewind_step_left tmBody tmTest c hst hread hc0 hns) + (fun c hst hread hc0 hns => loop_rewind_step_base tmBody tmTest c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Check step: halt (output = 1) or continue (output β‰  1) +-- ════════════════════════════════════════════════════════════════════════ + +/-- In the `check` phase, if output cell 1 holds `1` then one `loopTM` step +enters the `done` phase, leaving the output cells unchanged. -/ +theorem loopTM_check_halt (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Ξ“.one) : + βˆƒ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.done) ∧ + c'.output.cells = c.output.cells := by + have hne : c.state β‰  (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hread : c.output.read = Ξ“.one := by simp [Tape.read, hhead, hcell1] + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_⟩ + show (c.output.writeAndMove (readBackWrite Ξ“.one).toΞ“ (idleDir Ξ“.one)).cells = c.output.cells + simp only [readBackWrite, Ξ“w.toΞ“, idleDir, Tape.writeAndMove, Tape.move_cells] + simp only [Tape.write]; split + Β· omega + Β· dsimp only []; rw [hhead, ← hcell1]; exact Function.update_eq_self _ _ + +/-- In the `check` phase, if output cell 1 does not hold `1` then one `loopTM` +step restarts `tmBody` (state `Sum.inl tmBody.qstart`), leaving the output +cells unchanged. -/ +theorem loopTM_check_continue (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 β‰  Ξ“.one) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inl tmBody.qstart ∧ + c'.output.cells = c.output.cells := by + have hne : c.state β‰  (loopTM tmBody tmTest).qhalt := by + rw [hstate]; nofun + have hread_ne : c.output.read β‰  Ξ“.one := by + simp [Tape.read, hhead]; exact hcell1 + have hread_ne_start : c.output.read β‰  Ξ“.start := by + simp only [Tape.read, hhead]; exact hnostart 1 (by omega) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_⟩ + simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread_ne_start] + simp only [Tape.write, Tape.read]; split + Β· omega + Β· rw [hhead]; exact Function.update_eq_self _ _ + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting +-- ════════════════════════════════════════════════════════════════════════ + +/-- A `loopTM` configuration in the `done` phase is halted. -/ +theorem loopTM_halted_done (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (h : c.state = Sum.inr (Sum.inl LoopPhase.done)) : + (loopTM tmBody tmTest).halted c := h + +-- ════════════════════════════════════════════════════════════════════════ +-- One full iteration ending in halt +-- ════════════════════════════════════════════════════════════════════════ + +/-- One full `loopTM` iteration ending in halt: if `tmBody` halts in `t_body` +steps, `tmTest` then halts in `t_test` steps, and the resulting output tape +(head at `p`, cell 1 = `1`, `β–·` only at cell 0) passes the check, then `loopTM` +halts from the body-wrapped start in `t_body + 1 + t_test + 1 + (p + 1) + 1` +steps with output cell 1 equal to `1`. -/ +theorem loopTM_iteration_halt (tmBody tmTest : TM n) + {t_body : β„•} {c_body_start c_body_end : Cfg n tmBody.Q} + (hreach_body : tmBody.reachesIn t_body c_body_start c_body_end) + (hhalt_body : c_body_end.state = tmBody.qhalt) + {t_test : β„•} {c_test_end : Cfg n tmTest.Q} + (hreach_test : tmTest.reachesIn t_test + { state := tmTest.qstart, + input := transitionInput c_body_end.input, + work := fun i => transitionTape (c_body_end.work i), + output := transitionTape c_body_end.output } + c_test_end) + (hhalt_test : c_test_end.state = tmTest.qhalt) + {p : β„•} + (hcell0 : (transitionTape c_test_end.output).cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ + (transitionTape c_test_end.output).cells j β‰  Ξ“.start) + (hhead : (transitionTape c_test_end.output).head = p) + (hcell1 : (transitionTape c_test_end.output).cells 1 = Ξ“.one) : + βˆƒ c_final, + (loopTM tmBody tmTest).reachesIn (t_body + 1 + t_test + 1 + (p + 1) + 1) + (loopBodyWrap tmBody tmTest c_body_start) c_final ∧ + (loopTM tmBody tmTest).halted c_final ∧ + c_final.output.cells 1 = Ξ“.one := by + -- Phase 1: body simulation + have hp1 := loopTM_body_simulation tmBody tmTest hreach_body + -- Body β†’ test transition (1 step) + have h_tr1 : (loopTM tmBody tmTest).reachesIn 1 + (loopBodyWrap tmBody tmTest c_body_end) (loopTestWrap tmBody tmTest _) := + .step (loopTM_body_to_test tmBody tmTest hhalt_body) .zero + -- Phase 2: test simulation + have hp2 := loopTM_test_simulation tmBody tmTest hreach_test + -- Test β†’ rewind transition (1 step) + have h_tr2 : (loopTM tmBody tmTest).reachesIn 1 + (loopTestWrap tmBody tmTest c_test_end) + { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := transitionInput c_test_end.input, + work := fun i => transitionTape (c_test_end.work i), + output := transitionTape c_test_end.output } := + .step (loopTM_test_to_rewind tmBody tmTest hhalt_test) .zero + -- Rewind (p + 1 steps) + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check⟩ := + loopTM_rewind_loop tmBody tmTest p + { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := transitionInput c_test_end.input, + work := fun i => transitionTape (c_test_end.work i), + output := transitionTape c_test_end.output } + rfl hcell0 hnostart hhead + -- Check: output at cell 1 is Ξ“.one + obtain ⟨c_done, hstep_done, hst_done, hcells_done⟩ := + loopTM_check_halt tmBody tmTest c_check hst_check hh_check + (by rw [hcells_check]; exact hcell1) + -- Combine all phases + have h_check : (loopTM tmBody tmTest).reachesIn 1 c_check c_done := + .step hstep_done .zero + have h_all := reachesIn_trans _ (reachesIn_trans _ (reachesIn_trans _ + (reachesIn_trans _ (reachesIn_trans _ hp1 h_tr1) hp2) h_tr2) hreach_rw) h_check + refine ⟨c_done, ?_, hst_done, ?_⟩ + Β· exact h_all + Β· rw [hcells_done, hcells_check]; exact hcell1 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Retarget.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Retarget.lean new file mode 100644 index 0000000000..502df20992 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Retarget.lean @@ -0,0 +1,714 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal + +/-! +# retargetInput simulation β€” proof internals + +This file contains the simulation lemmas for `retargetInput M`, showing +that `retargetInput M` on a configuration where work tape `k` holds the +"virtual input" `z` faithfully simulates `M` on input `z`. + +## Key definitions and lemmas + +- `retargetWrap` β€” embed a config of `M : TM k` into a config of + `retargetInput M : TM (k+1)`, given a choice of real-input tape. +- `retargetInput_step_commute` β€” one step of `M` corresponds to one step + of `retargetInput M` under the wrap (assuming a structural invariant on + `c.input`: cells β‰₯ 1 are never `Ξ“.start`). +- `retargetInput_reachesIn_of_reachesIn` β€” multi-step simulation lifting. +- `retargetInput_reachesIn_halted_of_decidesInTime` β€” user-facing: if `M` decides `L` in + time `T`, then `retargetInput M` started with `z` on work tape `k` + reaches a halting configuration within `T(|z|)` steps with the correct + output. + +## The `startedCfg` family + +For phase-composed machines, the interesting entry point is not `initCfg` +but the configuration reached after `M`'s forced first move off the `β–·` +cells. `startedCfg M z hne` names that configuration (well-defined once +`qstart β‰  qhalt`, which `qstart_ne_qhalt_of_decidesInTime` guarantees for +any deciding machine), and the `startedCfg_*` lemmas pin down each field: +state, work, and output are input-independent, while every tape sits one +cell right of `β–·`. `retargetInput_decidesVirtual_started` restates the +user-facing simulation from this post-start configuration. + +## Hoare liftings + +- `retargetInput_hoareTime` β€” a `HoareTime` triple for `M` lifts to a + triple for `retargetInput M` in which the precondition reads `M`'s input + off work tape `k` and the postcondition existentially recovers `M`'s + final tapes. +- `retargetInput_copyInputToWorkTM_started_hoareTime`, + `retargetInput_inputLengthPlusOneCounterTM_started_hoareTime`, + `retargetInput_inputLengthPlusOneCounterTM_started_tracksInput_hoareTime` + β€” virtual-input instantiations of the corresponding subroutine triples. + +## The structural invariant + +Because `retargetInput M` writes back the read symbol on work tape `k` +(to preserve cells), the simulation only goes through cleanly when the +current write is a no-op. This requires: + + head = 0 OR read β‰  Ξ“.start + +The second disjunct is equivalent to "cells at positions β‰₯ 1 never +contain `Ξ“.start`". This is a *structural* invariant of any DTM run +(since `Ξ΄` writes only `Ξ“w`, which excludes `Ξ“.start`, and writes at +cell 0 are no-ops) β€” captured by `Tape.StartInvariant` below and preserved +across `TM.step` by `Tape.StartInvariant.step`. +-/ + + +@[expose] public section + +namespace Complexity + +variable {k : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a `Cfg k M.Q` into `Cfg (k+1) (retargetInput M).Q` by: + - putting `realInput` on the real input tape (ignored by the machine), + - putting `c.work i` on work tape `i` for `i < k`, + - putting `c.input` on work tape `k` (the virtual input). + State and output are shared. -/ +def retargetWrap (M : TM k) (realInput : Tape) (c : Cfg k M.Q) : + Cfg (k + 1) (retargetInput M).Q where + state := c.state + input := realInput + work := fun i => + if h : i.val < k then c.work ⟨i.val, h⟩ + else c.input + output := c.output + +/-- The state of a wrapped configuration is the state of the wrapped `M`-configuration. -/ +@[simp] theorem retargetWrap_state (M : TM k) (realInput : Tape) (c : Cfg k M.Q) : + (retargetWrap M realInput c).state = c.state := rfl + +/-- The output tape of a wrapped configuration is the output tape of the + wrapped `M`-configuration. -/ +@[simp] theorem retargetWrap_output (M : TM k) (realInput : Tape) (c : Cfg k M.Q) : + (retargetWrap M realInput c).output = c.output := rfl + +/-- The (ignored) real input tape of a wrapped configuration is exactly the + supplied `realInput`. -/ +@[simp] theorem retargetWrap_input (M : TM k) (realInput : Tape) (c : Cfg k M.Q) : + (retargetWrap M realInput c).input = realInput := rfl + +/-- For an index `i < k`, work tape `i` of a wrapped configuration is work + tape `i` of the wrapped `M`-configuration. -/ +theorem retargetWrap_work_lt (M : TM k) (realInput : Tape) (c : Cfg k M.Q) + (i : Fin (k + 1)) (h : i.val < k) : + (retargetWrap M realInput c).work i = c.work ⟨i.val, h⟩ := by + simp [retargetWrap, h] + +/-- The last work tape (index `k`) of a wrapped configuration holds the + wrapped `M`-configuration's input tape β€” the virtual input. -/ +theorem retargetWrap_work_last (M : TM k) (realInput : Tape) (c : Cfg k M.Q) : + (retargetWrap M realInput c).work ⟨k, by omega⟩ = c.input := by + simp [retargetWrap] + +-- ════════════════════════════════════════════════════════════════════════ +-- Core step commute +-- ════════════════════════════════════════════════════════════════════════ + +/-- Auxiliary: `writeAndMove` with `readBackWrite` of the current read + symbol equals `move` when the tape has either head = 0 or read β‰  start. -/ +private theorem tape_writeBack_eq_move (t : Tape) (d : Dir3) + (h : t.head = 0 ∨ t.read β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read).toΞ“ d = t.move d := by + show (t.write (readBackWrite t.read).toΞ“).move d = t.move d + have hwrite : t.write (readBackWrite t.read).toΞ“ = t := by + simp only [Tape.write] + rcases h with hh | hne + Β· simp [hh] + Β· split + Β· rfl + Β· rw [toΞ“_readBackWrite_of_ne_start hne] + simp [Tape.read, Function.update_eq_self] + rw [hwrite] + +/-- One step of `M` corresponds to one step of `retargetInput M` through + `retargetWrap`. The real-input tape drifts by `move (idleDir Β· )`. + Requires the structural invariant on `c.input` (cells β‰₯ 1 β‰  start). -/ +theorem retargetInput_step_commute (M : TM k) {c c' : Cfg k M.Q} + (hstep : M.step c = some c') (realInput : Tape) + (hinp : Tape.StartInvariant c.input) : + (retargetInput M).step (retargetWrap M realInput c) = + some (retargetWrap M (realInput.move (idleDir realInput.read)) c') := by + have hne : c.state β‰  M.qhalt := state_ne_qhalt_of_step hstep + -- Extract c' from M.step c. + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + -- Key fact 1: wHeads ⟨k, _⟩ = c.input.read. + have hwHead_last : ((retargetWrap M realInput c).work ⟨k, by omega⟩).read + = c.input.read := by + show (if h : k < k then c.work ⟨k, h⟩ else c.input).read = c.input.read + simp + -- Key fact 2: fun i : Fin k => wHeads ⟨i.val, _⟩ equals fun i => (c.work i).read. + have hinner : (fun i : Fin k => + ((retargetWrap M realInput c).work ⟨i.val, by omega⟩).read) + = (fun i => (c.work i).read) := by + funext i + show (if h : i.val < k then c.work ⟨i.val, h⟩ else c.input).read = (c.work i).read + rw [dif_pos i.isLt] + -- Unfold step on the LHS. `split` reduces the halting ite (the stored + -- decidability instance blocks `simp`/`ite_eq_right` post-v4.30). + simp only [step, show (retargetWrap M realInput c).state = c.state from rfl, + show (retargetInput M).qhalt = M.qhalt from rfl, + retargetWrap_input, retargetWrap_output] + split + Β· exact absurd β€Ή_β€Ί hne + simp only [Option.some.injEq] + -- Unfold retargetInput's Ξ΄. + dsimp only [retargetInput] + rw [hwHead_last, hinner] + -- Now show the Cfg equality field-by-field. + refine Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩ + funext i + by_cases hik : i.val < k + Β· -- i.val < k: matches M's work tape i. + -- LHS: ((retargetWrap...).work i).writeAndMove (M.workWrites ⟨i.val, _⟩).toΞ“ + -- (M.workDirs ⟨i.val, _⟩) + -- RHS: (retargetWrap... c').work i where c'.work ⟨i.val, _⟩ is the updated tape. + rw [retargetWrap_work_lt _ _ _ _ hik] + show (_ : Tape).writeAndMove _ _ = (if h : i.val < k then _ else _) + rw [dif_pos hik, dif_pos hik, dif_pos hik] + Β· -- i.val = k: virtual input case. + have hik_eq : i.val = k := by have := i.isLt; omega + have hwork_k : (retargetWrap M realInput c).work i = c.input := by + show (if h : i.val < k then c.work ⟨i.val, h⟩ else c.input) = c.input + rw [dite_eq_right hik] + have hcond : c.input.head = 0 ∨ c.input.read β‰  Ξ“.start := by + by_cases hh : c.input.head = 0 + Β· left; exact hh + Β· right + show c.input.cells c.input.head β‰  Ξ“.start + exact hinp.2 c.input.head (by omega) + -- Rewrite LHS via hwork_k, then use tape_writeBack_eq_move. + rw [hwork_k] + show _ = (if h : i.val < k then _ else _) + rw [dite_eq_right hik, dite_eq_right hik, dite_eq_right hik] + exact tape_writeBack_eq_move c.input _ hcond + +-- ════════════════════════════════════════════════════════════════════════ +-- Multi-step simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Multi-step version: if `M` reaches `c'` in `t` steps, then + `retargetInput M` reaches *some* config (differing from `retargetWrap` + only in the real-input tape drift) in the same `t` steps. -/ +theorem retargetInput_reachesIn_of_reachesIn (M : TM k) + {c c' : Cfg k M.Q} {t : β„•} (hreach : M.reachesIn t c c') + (hinp : Tape.StartInvariant c.input) (hwork : βˆ€ i, Tape.StartInvariant (c.work i)) + (hout : Tape.StartInvariant c.output) (realInput : Tape) : + βˆƒ finalReal : Tape, + (retargetInput M).reachesIn t + (retargetWrap M realInput c) + (retargetWrap M finalReal c') := by + induction hreach generalizing realInput with + | zero => exact ⟨realInput, .zero⟩ + | @step cβ‚€ c_mid _ _ hstep hrest ih => + obtain ⟨hinp', hwork', hout'⟩ := + Tape.StartInvariant.step M hstep hinp hwork hout + have hcommute := retargetInput_step_commute M hstep realInput hinp + obtain ⟨finalReal', hreach'⟩ := ih hinp' hwork' hout' + (realInput.move (idleDir realInput.read)) + exact ⟨finalReal', .step hcommute hreach'⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- User-facing: retargetInput M decides on a virtual input +-- ════════════════════════════════════════════════════════════════════════ + +/-- Initial configuration for `retargetInput M` with virtual input `z` on + work tape `k` and an arbitrary `realInput` on the (ignored) real + input tape. Work tapes `0..k-1` are empty; output is empty. -/ +def retargetInitCfg (M : TM k) (z : List Bool) (realInput : Tape) : + Cfg (k + 1) (retargetInput M).Q where + state := M.qstart + input := realInput + work := fun i => + if i.val < k then Tape.init [] + else Tape.init (z.map Ξ“.ofBool) + output := Tape.init [] + +/-- `retargetInitCfg M z realInput` is exactly the `retargetWrap` of `M`'s + ordinary initial configuration on input `z`. -/ +theorem retargetInitCfg_eq_retargetWrap (M : TM k) (z : List Bool) (realInput : Tape) : + retargetInitCfg M z realInput = retargetWrap M realInput (M.initCfg z) := by + simp only [retargetInitCfg, retargetWrap] + refine Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩ + funext i + by_cases hik : i.val < k + Β· simp only [hik, ↓reduceIte, ↓reduceDIte] + Β· simp only [hik, ↓reduceIte, ↓reduceDIte] + +/-- **User-facing simulation**: if `M` decides `L` in time `T`, then + `retargetInput M` started with `z` on work tape `k` reaches a halted + configuration within `T(|z|)` steps whose output cell 1 indicates + membership of `z` in `L`. -/ +theorem retargetInput_reachesIn_halted_of_decidesInTime (M : TM k) {L : Language} {T : β„• β†’ β„•} + (hM : M.DecidesInTime L T) (z : List Bool) (realInput : Tape) : + βˆƒ c' t, t ≀ T z.length ∧ + (retargetInput M).reachesIn t (retargetInitCfg M z realInput) c' ∧ + (retargetInput M).halted c' ∧ + (z ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ + (z βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) := by + obtain ⟨c_M, t, ht, hreach, hhalt, hyes, hno⟩ := hM z + have hinp : Tape.StartInvariant (M.initCfg z).input := by + exact Tape.StartInvariant.init_ofBool z + have hwork : βˆ€ i, Tape.StartInvariant ((M.initCfg z).work i) := fun i => by + exact Tape.StartInvariant.init_nil + have hout : Tape.StartInvariant (M.initCfg z).output := by + exact Tape.StartInvariant.init_nil + obtain ⟨finalReal, hreachSim⟩ := + retargetInput_reachesIn_of_reachesIn M hreach hinp hwork hout realInput + refine ⟨retargetWrap M finalReal c_M, t, ht, ?_, ?_, ?_, ?_⟩ + Β· rw [retargetInitCfg_eq_retargetWrap]; exact hreachSim + Β· show (retargetWrap M finalReal c_M).state = (retargetInput M).qhalt + show c_M.state = M.qhalt + exact hhalt + Β· intro hz + show (retargetWrap M finalReal c_M).output.cells 1 = Ξ“.one + exact hyes hz + Β· intro hz + show (retargetWrap M finalReal c_M).output.cells 1 = Ξ“.zero + exact hno hz + +/-- A verifier that decides a language cannot have `qstart = qhalt`, because + the initial output cell is blank, not an accepting or rejecting bit. -/ +theorem qstart_ne_qhalt_of_decidesInTime (M : TM k) {L : Language} {T : β„• β†’ β„•} + (hM : M.DecidesInTime L T) : M.qstart β‰  M.qhalt := by + intro hstart + obtain ⟨c', t, _ht, hreach, _hhalt, hyes, hno⟩ := hM [] + have hinit_halt : M.halted (M.initCfg []) := by + simpa [TM.halted, Cfg.isHalted, Cfg.init] using hstart + have ht0 : t = 0 := by + have hle := M.reachesIn_le_halt hreach + (TM.reachesIn.zero : M.reachesIn 0 (M.initCfg []) (M.initCfg [])) + hinit_halt + omega + subst ht0 + cases hreach + by_cases hmem : ([] : List Bool) ∈ L + Β· have hcell := hyes hmem + simp [Tape.init] at hcell + Β· have hcell := hno hmem + simp [Tape.init] at hcell + +/-- The verifier configuration after its forced first move off the start cells. + For a deciding machine this is well-defined by `qstart_ne_qhalt_of_decidesInTime`. -/ +noncomputable def startedCfg (M : TM k) (z : List Bool) (hne : M.qstart β‰  M.qhalt) : + Cfg k M.Q := + (M.step (M.initCfg z)).get (by + simp [TM.step, hne]) + +/-- `startedCfg` is the result of one deterministic verifier step from + `M.initCfg z`. -/ +theorem step_initCfg_startedCfg (M : TM k) (z : List Bool) + (hne : M.qstart β‰  M.qhalt) : + M.step (M.initCfg z) = some (startedCfg M z hne) := by + simp [startedCfg, TM.step, hne] + +/-- The verifier state immediately after the forced first move off `β–·` is + independent of the concrete input string: the first step reads only the + start symbols on every tape. -/ +theorem startedCfg_state_eq (M : TM k) (z₁ zβ‚‚ : List Bool) + (hne : M.qstart β‰  M.qhalt) : + (startedCfg M z₁ hne).state = (startedCfg M zβ‚‚ hne).state := by + simp [startedCfg, TM.step, hne, Tape.read, Tape.init] + +/-- The verifier work tapes immediately after the forced first move off `β–·` + are independent of the concrete input string. -/ +theorem startedCfg_work_eq (M : TM k) (z₁ zβ‚‚ : List Bool) + (hne : M.qstart β‰  M.qhalt) : + (startedCfg M z₁ hne).work = (startedCfg M zβ‚‚ hne).work := by + funext i + simp [startedCfg, TM.step, hne, Tape.read, Tape.init] + +/-- The verifier output tape immediately after the forced first move off `β–·` + is independent of the concrete input string. -/ +theorem startedCfg_output_eq (M : TM k) (z₁ zβ‚‚ : List Bool) + (hne : M.qstart β‰  M.qhalt) : + (startedCfg M z₁ hne).output = (startedCfg M zβ‚‚ hne).output := by + simp [startedCfg, TM.step, hne, Tape.read, Tape.init] + +/-- The verifier input tape immediately after the forced first move off `β–·` + is the ordinary initialized input moved right to cell 1. -/ +theorem startedCfg_input_eq (M : TM k) (z : List Bool) + (hne : M.qstart β‰  M.qhalt) : + (startedCfg M z hne).input = (Tape.init (z.map Ξ“.ofBool)).move Dir3.right := by + have hinDir : + (M.Ξ΄ M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.1 = + Dir3.right := + (M.Ξ΄_right_of_start M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).1 rfl + change (M.6 M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.1 = + Dir3.right at hinDir + simp [startedCfg, TM.step, hne, Tape.read, Tape.init] + rw [hinDir] + +/-- Each verifier work tape immediately after the forced first move off `β–·` + is a blank initialized tape moved right to cell 1. -/ +theorem startedCfg_work_eq_init_move_right (M : TM k) (z : List Bool) + (hne : M.qstart β‰  M.qhalt) (i : Fin k) : + (startedCfg M z hne).work i = (Tape.init []).move Dir3.right := by + have hworkDir : + (M.Ξ΄ M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.2.1 i = + Dir3.right := + (M.Ξ΄_right_of_start M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.1 i rfl + change (M.6 M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.2.1 i = + Dir3.right at hworkDir + simp [startedCfg, TM.step, hne, Tape.read, Tape.init, Tape.writeAndMove, Tape.write] + rw [hworkDir] + +/-- The verifier output tape immediately after the forced first move off `β–·` + is a blank initialized tape moved right to cell 1. -/ +theorem startedCfg_output_eq_init_move_right (M : TM k) (z : List Bool) + (hne : M.qstart β‰  M.qhalt) : + (startedCfg M z hne).output = (Tape.init []).move Dir3.right := by + have houtDir : + (M.Ξ΄ M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.2.2 = + Dir3.right := + (M.Ξ΄_right_of_start M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2 rfl + change (M.6 M.qstart Ξ“.start (fun _ : Fin k => Ξ“.start) Ξ“.start).2.2.2.2.2 = + Dir3.right at houtDir + simp [startedCfg, TM.step, hne, Tape.read, Tape.init, Tape.writeAndMove, Tape.write] + rw [houtDir] + +/-- User-facing simulation from the post-start verifier configuration. + + If `M` decides `L`, then `retargetInput M` can start from `retargetWrap` + of the verifier state immediately after `M`'s first step on `z`, and it + reaches the same accepting/rejecting output. This is the form needed by + phase-composed machines whose earlier phases have already moved every + tape off `β–·`. -/ +theorem retargetInput_decidesVirtual_started (M : TM k) {L : Language} {T : β„• β†’ β„•} + (hM : M.DecidesInTime L T) (z : List Bool) (realInput : Tape) : + βˆƒ c' t, t + 1 ≀ T z.length ∧ + (retargetInput M).reachesIn t + (retargetWrap M realInput (startedCfg M z (qstart_ne_qhalt_of_decidesInTime M hM))) c' ∧ + (retargetInput M).halted c' ∧ + (z ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ + (z βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) := by + let hne := qstart_ne_qhalt_of_decidesInTime M hM + obtain ⟨c_M, t, ht, hreach, hhalt, hyes, hno⟩ := hM z + have ht_ne : t β‰  0 := by + intro ht0 + subst ht0 + cases hreach + exact hne hhalt + obtain ⟨t', ht'⟩ := Nat.exists_eq_succ_of_ne_zero ht_ne + subst ht' + obtain ⟨c_mid, hstep, hrest⟩ : βˆƒ c_mid, + M.step (M.initCfg z) = some c_mid ∧ M.reachesIn t' c_mid c_M := by + cases hreach with + | step hstep hrest => exact ⟨_, hstep, hrest⟩ + have hstarted : c_mid = startedCfg M z hne := by + have hs : some c_mid = some (startedCfg M z hne) := by + rw [← hstep, step_initCfg_startedCfg M z hne] + exact Option.some.inj hs + subst hstarted + have hinp : Tape.StartInvariant (startedCfg M z hne).input := by + have hinit : Tape.StartInvariant (M.initCfg z).input := Tape.StartInvariant.init_ofBool z + have hwork : βˆ€ i, Tape.StartInvariant ((M.initCfg z).work i) := + fun _ => Tape.StartInvariant.init_nil + have hout : Tape.StartInvariant (M.initCfg z).output := Tape.StartInvariant.init_nil + obtain ⟨hinp', _, _⟩ := + Tape.StartInvariant.step M (step_initCfg_startedCfg M z hne) hinit hwork hout + exact hinp' + have hwork : βˆ€ i, Tape.StartInvariant ((startedCfg M z hne).work i) := by + have hinit : Tape.StartInvariant (M.initCfg z).input := Tape.StartInvariant.init_ofBool z + have hwork : βˆ€ i, Tape.StartInvariant ((M.initCfg z).work i) := + fun _ => Tape.StartInvariant.init_nil + have hout : Tape.StartInvariant (M.initCfg z).output := Tape.StartInvariant.init_nil + obtain ⟨_, hwork', _⟩ := + Tape.StartInvariant.step M (step_initCfg_startedCfg M z hne) hinit hwork hout + exact hwork' + have hout : Tape.StartInvariant (startedCfg M z hne).output := by + have hinit : Tape.StartInvariant (M.initCfg z).input := Tape.StartInvariant.init_ofBool z + have hwork : βˆ€ i, Tape.StartInvariant ((M.initCfg z).work i) := + fun _ => Tape.StartInvariant.init_nil + have hout : Tape.StartInvariant (M.initCfg z).output := Tape.StartInvariant.init_nil + obtain ⟨_, _, hout'⟩ := + Tape.StartInvariant.step M (step_initCfg_startedCfg M z hne) hinit hwork hout + exact hout' + obtain ⟨finalReal, hreachSim⟩ := + retargetInput_reachesIn_of_reachesIn M hrest hinp hwork hout realInput + refine ⟨retargetWrap M finalReal c_M, t', by omega, hreachSim, ?_, ?_, ?_⟩ + Β· show (retargetWrap M finalReal c_M).state = (retargetInput M).qhalt + show c_M.state = M.qhalt + exact hhalt + Β· intro hz + show (retargetWrap M finalReal c_M).output.cells 1 = Ξ“.one + exact hyes hz + Β· intro hz + show (retargetWrap M finalReal c_M).output.cells 1 = Ξ“.zero + exact hno hz + +/-- Hoare lifting for `retargetInput`: if a deterministic TM satisfies a + Hoare triple on its ordinary input tape, then `retargetInput` satisfies + the corresponding triple when that input is supplied on the last work + tape. The real input tape is ignored. -/ +theorem retargetInput_hoareTime (M : TM k) + {pre post : TapePred k} {b : β„•} + (hM : M.HoareTime pre post b) + (hpre_inp : βˆ€ inp work out, pre inp work out β†’ Tape.StartInvariant inp) + (hpre_work : βˆ€ inp work out, pre inp work out β†’ βˆ€ i, Tape.StartInvariant (work i)) + (hpre_out : βˆ€ inp work out, pre inp work out β†’ Tape.StartInvariant out) : + (retargetInput M).HoareTime + (fun _inp work out => + pre (work ⟨k, by omega⟩) (fun i => work ⟨i.val, by omega⟩) out) + (fun _inp work out => + βˆƒ vin : Tape, βˆƒ innerWork : Fin k β†’ Tape, + post vin innerWork out ∧ + (βˆ€ i : Fin k, work ⟨i.val, by omega⟩ = innerWork i) ∧ + work ⟨k, by omega⟩ = vin) + b := by + intro realInput work out hpre + let vin : Tape := work ⟨k, by omega⟩ + let innerWork : Fin k β†’ Tape := fun i => work ⟨i.val, by omega⟩ + have hpreM : pre vin innerWork out := hpre + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := hM vin innerWork out hpreM + have hinp : Tape.StartInvariant vin := hpre_inp vin innerWork out hpreM + have hwork : βˆ€ i, Tape.StartInvariant (innerWork i) := hpre_work vin innerWork out hpreM + have hout : Tape.StartInvariant out := hpre_out vin innerWork out hpreM + obtain ⟨finalReal, hreachSim⟩ := + retargetInput_reachesIn_of_reachesIn M hreach hinp hwork hout realInput + let c0 : Cfg k M.Q := + { state := M.qstart, input := vin, work := innerWork, output := out } + have hworkField : (retargetWrap M realInput c0).work = work := by + funext j + by_cases hj : j.val < k + Β· simp [retargetWrap, c0, vin, innerWork, hj] + Β· have hjval : j.val = k := by + omega + have hjk : j = ⟨k, by omega⟩ := by + apply Fin.ext + simp [hjval] + simp [retargetWrap, c0, vin, innerWork, hjk] + have hstart : + retargetWrap M realInput c0 = + ({ state := (retargetInput M).qstart, input := realInput, work := work, output := out } : + Cfg (k + 1) (retargetInput M).Q) := by + refine Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩ + simpa [retargetInput] using! hworkField + refine ⟨retargetWrap M finalReal c', t, ht, ?_, ?_, ?_⟩ + Β· rw [← hstart] + exact hreachSim + Β· show (retargetWrap M finalReal c').state = (retargetInput M).qhalt + simpa [retargetInput, retargetWrap] using hhalt + Β· refine ⟨c'.input, c'.work, hpost, ?_, ?_⟩ + Β· intro i + simp [retargetWrap_work_lt] + Β· simp [retargetWrap_work_last] + +/-- Virtual-input version of `copyInputToWorkTM_started_hoareTime`: if the +virtual input is a Boolean string at head `1` and work tape `idx` is a blank +started tape, then `retargetInput (copyInputToWorkTM idx)` copies that virtual +input onto work tape `idx` within `|x| + 1` steps. -/ +theorem retargetInput_copyInputToWorkTM_started_hoareTime (idx : Fin k) (x : List Bool) : + (retargetInput (copyInputToWorkTM idx)).HoareTime + (fun _inp work out => + work ⟨k, by omega⟩ = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work ⟨idx.val, by omega⟩ = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant out ∧ + (βˆ€ i : Fin k, i β‰  idx β†’ Tape.StartInvariant (work ⟨i.val, by omega⟩))) + (fun _inp work _out => + (work ⟨k, by omega⟩).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work ⟨k, by omega⟩).head = x.length + 1 ∧ + (work ⟨idx.val, by omega⟩).HasBinaryPrefix x) + (x.length + 1) := by + have hmove_right_invariant : βˆ€ {t : Tape}, + Tape.StartInvariant t β†’ Tape.StartInvariant (t.move Dir3.right) := by + intro t ht + refine ⟨?_, ?_⟩ + Β· simpa [Tape.move_cells] using ht.1 + Β· intro j hj + simpa [Tape.move_cells] using ht.2 j hj + have hcopy : + (copyInputToWorkTM idx).HoareTime + (fun inp work out => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work idx = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant out ∧ + (βˆ€ i : Fin k, i β‰  idx β†’ Tape.StartInvariant (work i))) + (fun inp work _out => + inp.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + inp.head = x.length + 1 ∧ + (work idx).HasBinaryPrefix x) + (x.length + 1) := + (copyInputToWorkTM_started_hoareTime idx x).weaken_pre (by + intro inp work out hpre + refine ⟨hpre.1, ?_⟩ + rw [hpre.2.1] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + have hret := retargetInput_hoareTime (M := copyInputToWorkTM idx) hcopy + (hpre_inp := by + intro _inp work out hpre + rcases hpre with ⟨hvin, _hidx, _hout, _hrest⟩ + rw [hvin] + exact hmove_right_invariant (Tape.StartInvariant.init_ofBool x)) + (hpre_work := by + intro _inp work out hpre i + rcases hpre with ⟨_hvin, hidx, _hout, hrest⟩ + by_cases hi : i = idx + Β· subst hi + rw [hidx] + exact hmove_right_invariant Tape.StartInvariant.init_nil + Β· exact hrest i hi) + (hpre_out := by + intro _inp work out hpre + exact hpre.2.2.1) + refine hret.strengthen_post ?_ + intro _inp work out hpost + rcases hpost with ⟨vin, innerWork, hinner, hmap, hvin⟩ + exact ⟨by simpa [hvin] using hinner.1, + by simpa [hvin] using hinner.2.1, + by simpa [hmap idx] using hinner.2.2⟩ + +/-- Virtual-input version of `inputLengthPlusOneCounterTM_started_hoareTime`: +if the virtual input is a started Boolean string and work tape `counterIdx` +is a started blank tape, then `retargetInput (inputLengthPlusOneCounterTM +counterIdx)` materializes a unary counter of length `|x| + 1` on that tape. -/ +theorem retargetInput_inputLengthPlusOneCounterTM_started_hoareTime + (counterIdx : Fin k) (x : List Bool) : + (retargetInput (inputLengthPlusOneCounterTM counterIdx)).HoareTime + (fun _inp work out => + work ⟨k, by omega⟩ = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work ⟨counterIdx.val, by omega⟩ = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant out ∧ + (βˆ€ i : Fin k, i β‰  counterIdx β†’ Tape.StartInvariant (work ⟨i.val, by omega⟩))) + (fun _inp work _out => + (work ⟨counterIdx.val, by omega⟩).HasUnaryCounter (x.length + 1) ∧ + (work ⟨counterIdx.val, by omega⟩).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work ⟨counterIdx.val, by omega⟩).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := by + have hmove_right_invariant : βˆ€ {t : Tape}, + Tape.StartInvariant t β†’ Tape.StartInvariant (t.move Dir3.right) := by + intro t ht + refine ⟨?_, ?_⟩ + Β· simpa [Tape.move_cells] using ht.1 + Β· intro j hj + simpa [Tape.move_cells] using ht.2 j hj + have hcounter : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work _out => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work counterIdx = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant _out ∧ + (βˆ€ i : Fin k, i β‰  counterIdx β†’ Tape.StartInvariant (work i))) + (fun _inp work _out => + (work counterIdx).HasUnaryCounter (x.length + 1) ∧ + (work counterIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work counterIdx).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := + (inputLengthPlusOneCounterTM_started_hoareTime counterIdx x).weaken_pre (by + intro inp work out hpre + exact ⟨hpre.1, hpre.2.1⟩) + have hret := retargetInput_hoareTime (M := inputLengthPlusOneCounterTM counterIdx) hcounter + (hpre_inp := by + intro _inp work out hpre + rcases hpre with ⟨hvin, _hidx, _hout, _hrest⟩ + rw [hvin] + exact hmove_right_invariant (Tape.StartInvariant.init_ofBool x)) + (hpre_work := by + intro _inp work out hpre i + rcases hpre with ⟨_hvin, hidx, _hout, hrest⟩ + by_cases hi : i = counterIdx + Β· subst hi + rw [hidx] + exact hmove_right_invariant Tape.StartInvariant.init_nil + Β· exact hrest i hi) + (hpre_out := by + intro _inp work out hpre + exact hpre.2.2.1) + refine hret.strengthen_post ?_ + intro _inp work out hpost + rcases hpost with ⟨vin, innerWork, hinner, hmap, hvin⟩ + exact ⟨by simpa [hmap counterIdx] using hinner.1, + by simpa [hmap counterIdx] using hinner.2.1, + by simpa [hmap counterIdx] using hinner.2.2⟩ + +/-- Virtual-input version of +`inputLengthPlusOneCounterTM_started_tracksInput_hoareTime`: besides building +the unary counter on work tape `counterIdx`, the postcondition also records +the final cells and head of the virtual-input tape itself. -/ +theorem retargetInput_inputLengthPlusOneCounterTM_started_tracksInput_hoareTime + (counterIdx : Fin k) (x : List Bool) : + (retargetInput (inputLengthPlusOneCounterTM counterIdx)).HoareTime + (fun _inp work out => + work ⟨k, by omega⟩ = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work ⟨counterIdx.val, by omega⟩ = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant out ∧ + (βˆ€ i : Fin k, i β‰  counterIdx β†’ Tape.StartInvariant (work ⟨i.val, by omega⟩))) + (fun _inp work _out => + (work ⟨k, by omega⟩).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work ⟨k, by omega⟩).head = x.length + 1 ∧ + (work ⟨counterIdx.val, by omega⟩).HasUnaryCounter (x.length + 1) ∧ + (work ⟨counterIdx.val, by omega⟩).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work ⟨counterIdx.val, by omega⟩).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := by + have hmove_right_invariant : βˆ€ {t : Tape}, + Tape.StartInvariant t β†’ Tape.StartInvariant (t.move Dir3.right) := by + intro t ht + refine ⟨?_, ?_⟩ + Β· simpa [Tape.move_cells] using ht.1 + Β· intro j hj + simpa [Tape.move_cells] using ht.2 j hj + have hcounter : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work _out => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work counterIdx = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant _out ∧ + (βˆ€ i : Fin k, i β‰  counterIdx β†’ Tape.StartInvariant (work i))) + (fun inp work _out => + inp.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + inp.head = x.length + 1 ∧ + (work counterIdx).HasUnaryCounter (x.length + 1) ∧ + (work counterIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work counterIdx).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := + (inputLengthPlusOneCounterTM_started_tracksInput_hoareTime counterIdx x).weaken_pre (by + intro inp work out hpre + exact ⟨hpre.1, hpre.2.1⟩) + have hret := retargetInput_hoareTime (M := inputLengthPlusOneCounterTM counterIdx) hcounter + (hpre_inp := by + intro _inp work out hpre + rcases hpre with ⟨hvin, _hidx, _hout, _hrest⟩ + rw [hvin] + exact hmove_right_invariant (Tape.StartInvariant.init_ofBool x)) + (hpre_work := by + intro _inp work out hpre i + rcases hpre with ⟨_hvin, hidx, _hout, hrest⟩ + by_cases hi : i = counterIdx + Β· subst hi + rw [hidx] + exact hmove_right_invariant Tape.StartInvariant.init_nil + Β· exact hrest i hi) + (hpre_out := by + intro _inp work out hpre + exact hpre.2.2.1) + refine hret.strengthen_post ?_ + intro _inp work out hpost + rcases hpost with ⟨vin, innerWork, hinner, hmap, hvin⟩ + exact ⟨by rw [hvin]; exact hinner.1, + by rw [hvin]; exact hinner.2.1, + by simpa [hmap counterIdx] using hinner.2.2.1, + by simpa [hmap counterIdx] using hinner.2.2.2.1, + by simpa [hmap counterIdx] using hinner.2.2.2.2⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Scanner.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Scanner.lean new file mode 100644 index 0000000000..f25551caf8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Scanner.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Correctness of the generic finite-state scanner + +Proofs that `TM.scannerTM` correctly implements a left-to-right fold with +`|x| + 2`-step running time. + +## Main results + +- `TM.scannerTM_reachesIn` β€” the scanner halts in `|x| + 2` steps on every + input `x`, writing `finalOutput (x.foldl scanStep sβ‚€)` to output cell 1. +- `TM.scannerTM_decidesInTime` β€” bridge to `DecidesInTime` for any language + characterized by `x ∈ L ↔ finalOutput (x.foldl scanStep sβ‚€) = Ξ“w.one`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {S : Type} [DecidableEq S] [Fintype S] + +-- ════════════════════════════════════════════════════════════════════════ +-- Step lemmas +-- ════════════════════════════════════════════════════════════════════════ + +/-- Step 1: from `.start` with both input and output heads at cell 0 on `β–·`, + the machine enters `.scan sβ‚€` with both heads advanced to cell 1. + Tape cell contents are preserved (writes at cell 0 are no-ops). -/ +private theorem scannerTM_step_start + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) + (c : Cfg 0 (scannerTM sβ‚€ scanStep finalOutput).Q) + (hst : c.state = ScannerPhase.start) + (hih : c.input.head = 0) (hoh : c.output.head = 0) : + βˆƒ c', (scannerTM sβ‚€ scanStep finalOutput).step c = some c' ∧ + c'.state = ScannerPhase.scan sβ‚€ ∧ + c'.input.head = 1 ∧ c'.input.cells = c.input.cells ∧ + c'.output.head = 1 ∧ c'.output.cells = c.output.cells := by + simp only [TM.step, hst, scannerTM, reduceCtorEq, ↓reduceIte] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· simp [Tape.move, hih] + Β· rfl + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hoh] + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hoh] + +/-- Scan step: from `.scan s` reading a non-blank input symbol, advance + input one cell, transition scan state via `scanStep s (decide iHead = Ξ“.one)`. + Output and work tapes are preserved. -/ +private theorem scannerTM_step_scan + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) + (c : Cfg 0 (scannerTM sβ‚€ scanStep finalOutput).Q) (s : S) + (hst : c.state = ScannerPhase.scan s) + (hi_nb : c.input.read β‰  Ξ“.blank) + (ho_head : c.output.head = 1) + (ho_cell1_nb : c.output.cells 1 β‰  Ξ“.start) : + βˆƒ c', (scannerTM sβ‚€ scanStep finalOutput).step c = some c' ∧ + c'.state = ScannerPhase.scan (scanStep s (decide (c.input.read = Ξ“.one))) ∧ + c'.input.head = c.input.head + 1 ∧ c'.input.cells = c.input.cells ∧ + c'.output.head = 1 ∧ c'.output.cells = c.output.cells := by + simp only [TM.step, hst, scannerTM, reduceCtorEq, ↓reduceIte, ite_eq_right hi_nb] + have hne : c.output.read β‰  Ξ“.start := by + simp only [Tape.read, ho_head]; exact ho_cell1_nb + have ho_move : idleDir c.output.read = Dir3.stay := by + simp [idleDir, hne] + refine ⟨_, rfl, rfl, ?_, rfl, ?_, ?_⟩ + Β· simp [Tape.move] + Β· simp [Tape.writeAndMove, ho_move, Tape.move, Tape.write_head, ho_head] + Β· exact tape_readBackWrite_preserves c.output _ (Or.inr hne) + +/-- Halt step: from `.scan s` reading blank (end of input), emit + `finalOutput s` at output cell 1 and enter `.done`. -/ +private theorem scannerTM_step_halt + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) + (c : Cfg 0 (scannerTM sβ‚€ scanStep finalOutput).Q) (s : S) + (hst : c.state = ScannerPhase.scan s) + (hi_blank : c.input.read = Ξ“.blank) + (ho_head : c.output.head = 1) + (ho_cell1_nb : c.output.cells 1 β‰  Ξ“.start) : + βˆƒ c', (scannerTM sβ‚€ scanStep finalOutput).step c = some c' ∧ + (scannerTM sβ‚€ scanStep finalOutput).halted c' ∧ + c'.output.cells 1 = (finalOutput s).toΞ“ := by + simp only [TM.step, hst, scannerTM, reduceCtorEq, ↓reduceIte, ite_eq_left hi_blank] + refine ⟨_, rfl, rfl, ?_⟩ + have hne : c.output.read β‰  Ξ“.start := by + simp only [Tape.read, ho_head]; exact ho_cell1_nb + have ho_move : idleDir c.output.read = Dir3.stay := by + simp [idleDir, hne] + have h1 : (1 : β„•) β‰  0 := by omega + simp [Tape.writeAndMove, ho_move, Tape.move, Tape.write, ho_head, h1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Scan loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Scan invariant**: from a scan-state configuration `.scan s` with + input head at cell `k + 1` and `m` input bits remaining (`|x| = k + m`), + the scanner halts in `m + 1` steps with output cell 1 set to the fold + of `scanStep` over the remaining bits `x.drop k`, starting from `s`. -/ +private theorem scannerTM_scan + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) + (x : List Bool) (m k : β„•) (hlen : x.length = k + m) (s : S) + (c : Cfg 0 (scannerTM sβ‚€ scanStep finalOutput).Q) + (hst : c.state = ScannerPhase.scan s) + (hic : c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells) + (hih : c.input.head = k + 1) + (hoh : c.output.head = 1) + (hoc : c.output.cells 1 β‰  Ξ“.start) : + βˆƒ c', (scannerTM sβ‚€ scanStep finalOutput).reachesIn (m + 1) c c' ∧ + (scannerTM sβ‚€ scanStep finalOutput).halted c' ∧ + c'.output.cells 1 = (finalOutput ((x.drop k).foldl scanStep s)).toΞ“ := by + induction m generalizing k s c with + | zero => + -- k = x.length: reading blank, apply halt step. + have hk : k = x.length := by omega + have hi_blank : c.input.read = Ξ“.blank := by + simp only [Tape.read, hih, hic] + show (Tape.init (x.map Ξ“.ofBool)).cells (k + 1) = Ξ“.blank + simp [Tape.init, hk] + obtain ⟨c', hstep, hhalt, hout⟩ := + scannerTM_step_halt sβ‚€ scanStep finalOutput c s hst hi_blank hoh hoc + refine ⟨c', .step hstep .zero, hhalt, ?_⟩ + have : x.drop k = [] := by simp [hk] + rw [hout, this, List.foldl_nil] + | succ m ih => + -- k < x.length: read bit, scan step, IH. + have hk_lt : k < x.length := by omega + have hmap_len : (x.map Ξ“.ofBool).length = x.length := by simp + have hkmap : k < (x.map Ξ“.ofBool).length := by rw [hmap_len]; exact hk_lt + -- The symbol under the input head is `Ξ“.ofBool x[k]`. + have hi_read : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp only [Tape.read, hih, hic] + show (Tape.init (x.map Ξ“.ofBool)).cells (k + 1) = _ + simp only [Tape.init, show k + 1 β‰  0 from by omega, ↓reduceIte, + Nat.add_sub_cancel, List.getElem?_eq_getElem hkmap, Option.getD_some, + List.getElem_map] + have hi_nb : c.input.read β‰  Ξ“.blank := by + rw [hi_read]; cases x[k]'hk_lt <;> simp [Ξ“.ofBool] + -- Apply scan step. + obtain ⟨c₁, hstep, hst₁, hih₁, hic₁, hoh₁, hocβ‚βŸ© := + scannerTM_step_scan sβ‚€ scanStep finalOutput c s hst hi_nb hoh hoc + -- Bit decoding: `decide (Ξ“.ofBool b = Ξ“.one) = b`. + have hbit : decide (c.input.read = Ξ“.one) = x[k]'hk_lt := by + rw [hi_read]; cases x[k]'hk_lt <;> simp [Ξ“.ofBool] + rw [hbit] at hst₁ + -- Apply IH at k + 1 with state `scanStep s x[k]`. + have hlen' : x.length = (k + 1) + m := by omega + have hic₁' : c₁.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + rw [hic₁]; exact hic + have hih₁' : c₁.input.head = (k + 1) + 1 := by + rw [hih₁, hih] + have hoc₁' : c₁.output.cells 1 β‰  Ξ“.start := by + rw [hoc₁]; exact hoc + obtain ⟨c', hreach, hhalt, hout⟩ := + ih (k + 1) hlen' (scanStep s (x[k]'hk_lt)) c₁ hst₁ hic₁' hih₁' hoh₁ hoc₁' + refine ⟨c', .step hstep hreach, hhalt, ?_⟩ + -- `(x.drop k).foldl scanStep s = (x.drop (k+1)).foldl scanStep (scanStep s x[k])`. + have hdrop : x.drop k = (x[k]'hk_lt) :: x.drop (k + 1) := + List.drop_eq_getElem_cons hk_lt + rw [hout, hdrop, List.foldl_cons] + +-- ════════════════════════════════════════════════════════════════════════ +-- Main correctness theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- **`scannerTM` halts in `|x| + 2` steps and emits the fold result.** + + Output cell 1 is set to `finalOutput (x.foldl scanStep sβ‚€)`, and the + machine reaches a halted configuration in exactly `|x| + 2` steps on + every input. -/ +theorem scannerTM_reachesIn + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (finalOutput : S β†’ Ξ“w) (x : List Bool) : + βˆƒ c', (scannerTM sβ‚€ scanStep finalOutput).reachesIn (x.length + 2) + ((scannerTM sβ‚€ scanStep finalOutput).initCfg x) c' ∧ + (scannerTM sβ‚€ scanStep finalOutput).halted c' ∧ + c'.output.cells 1 = (finalOutput (x.foldl scanStep sβ‚€)).toΞ“ := by + -- Step 1: start β†’ scan sβ‚€. + obtain ⟨c₁, hstep1, hst1, hih1, hic1, hoh1, hoc1⟩ := + scannerTM_step_start sβ‚€ scanStep finalOutput + ((scannerTM sβ‚€ scanStep finalOutput).initCfg x) rfl rfl rfl + -- Apply scan lemma from k = 0 with m = |x|. + have hic1' : c₁.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := hic1 + have hih1' : c₁.input.head = 0 + 1 := by simpa using hih1 + have hoc1' : c₁.output.cells 1 β‰  Ξ“.start := by + rw [hoc1]; simp [Tape.init] + obtain ⟨c', hreach, hhalt, hout⟩ := + scannerTM_scan sβ‚€ scanStep finalOutput x x.length 0 (by omega) sβ‚€ c₁ + hst1 hic1' hih1' hoh1 hoc1' + refine ⟨c', ?_, hhalt, ?_⟩ + Β· exact .step hstep1 hreach + Β· simpa using hout + +-- ════════════════════════════════════════════════════════════════════════ +-- DecidesInTime bridge +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Bridge to `DecidesInTime`**. Whenever a language `L` is characterized + by a decision predicate `accept : S β†’ Bool` applied to the fold, the + scanner with finalOutput `fun s => if accept s then .one else .zero` + decides `L` in time `n + 2`. -/ +theorem scannerTM_decidesInTime + (sβ‚€ : S) (scanStep : S β†’ Bool β†’ S) (accept : S β†’ Bool) + {L : Language} + (hL : βˆ€ x, x ∈ L ↔ accept (x.foldl scanStep sβ‚€) = true) : + TM.DecidesInTime + (scannerTM sβ‚€ scanStep (fun s => if accept s then .one else .zero)) + L (fun n => n + 2) := by + intro x + obtain ⟨c', hreach, hhalt, hout⟩ := + scannerTM_reachesIn sβ‚€ scanStep (fun s => if accept s then .one else .zero) x + refine ⟨c', x.length + 2, le_refl _, hreach, hhalt, ?_, ?_⟩ + Β· intro hxL + rw [hout, ite_eq_left ((hL x).mp hxL)]; rfl + Β· intro hxnL + rw [hout] + have hacc : accept (x.foldl scanStep sβ‚€) = false := by + rcases h : accept (x.foldl scanStep sβ‚€) with _ | _ + Β· rfl + Β· exact absurd ((hL x).mpr h) hxnL + rw [ite_eq_right (by simp [hacc])]; rfl + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Seq.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Seq.lean new file mode 100644 index 0000000000..596c192052 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Seq.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# seqTM simulation β€” proof internals + +This file contains the simulation lemmas for `seqTM tm₁ tmβ‚‚`. + +## Key definitions + +- `phase1Wrap` β€” embed a `tm₁` config into the `seqTM` config space +- `phase2Wrap` β€” embed a `tmβ‚‚` config into the `seqTM` config space +- Tape transformations use the shared `transitionTape` / `transitionInput` +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a `tm₁` configuration into the `seqTM` config space (Phase 1). + State is wrapped in `Sum.inl`; tapes are shared. -/ +def phase1Wrap (tm₁ : TM n) (tmβ‚‚ : TM n) (c₁ : Cfg n tm₁.Q) : + Cfg n (SeqQ tm₁.Q tmβ‚‚.Q) where + state := Sum.inl c₁.state + input := c₁.input + work := c₁.work + output := c₁.output + +/-- Embed a `tmβ‚‚` configuration into the `seqTM` config space (Phase 2). + State is wrapped in `Sum.inr`; tapes are shared. -/ +def phase2Wrap (tm₁ : TM n) (tmβ‚‚ : TM n) (cβ‚‚ : Cfg n tmβ‚‚.Q) : + Cfg n (SeqQ tm₁.Q tmβ‚‚.Q) where + state := Sum.inr cβ‚‚.state + input := cβ‚‚.input + work := cβ‚‚.work + output := cβ‚‚.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: seqTM simulates tm₁ (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tm₁` corresponds to one step of `seqTM` during Phase 1. -/ +theorem seqTM_phase1_step (tm₁ tmβ‚‚ : TM n) {c₁ c₁' : Cfg n tm₁.Q} + (hstep : tm₁.step c₁ = some c₁') : + (seqTM tm₁ tmβ‚‚).step (phase1Wrap tm₁ tmβ‚‚ c₁) = some (phase1Wrap tm₁ tmβ‚‚ c₁') := by + classical + have hne := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [phase1Wrap, seqTM, ite_eq_right Sum.inl_ne_inr, ite_eq_right hne] + +/-- Multi-step Phase 1 simulation. -/ +theorem seqTM_reachesIn_phase1Wrap (tm₁ tmβ‚‚ : TM n) {t : β„•} + {c₁_start c₁_end : Cfg n tm₁.Q} + (hreach : tm₁.reachesIn t c₁_start c₁_end) : + (seqTM tm₁ tmβ‚‚).reachesIn t + (phase1Wrap tm₁ tmβ‚‚ c₁_start) (phase1Wrap tm₁ tmβ‚‚ c₁_end) := + reachesIn_map (tm' := seqTM tm₁ tmβ‚‚) (phase1Wrap tm₁ tmβ‚‚) + (fun _ _ => seqTM_phase1_step tm₁ tmβ‚‚) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition step +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tm₁` halts, one step of `seqTM` transitions to Phase 2. -/ +theorem seqTM_transition_step (tm₁ tmβ‚‚ : TM n) {c₁ : Cfg n tm₁.Q} + (hhalt : c₁.state = tm₁.qhalt) : + (seqTM tm₁ tmβ‚‚).step (phase1Wrap tm₁ tmβ‚‚ c₁) = + some (phase2Wrap tm₁ tmβ‚‚ + { state := tmβ‚‚.qstart, + input := transitionInput c₁.input, + work := fun i => transitionTape (c₁.work i), + output := transitionTape c₁.output }) := by + classical + unfold step + simp only [phase1Wrap, seqTM, ite_eq_right Sum.inl_ne_inr, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: seqTM simulates tmβ‚‚ (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmβ‚‚` corresponds to one step of `seqTM` during Phase 2. -/ +theorem seqTM_phase2_step (tm₁ tmβ‚‚ : TM n) {cβ‚‚ cβ‚‚' : Cfg n tmβ‚‚.Q} + (hstep : tmβ‚‚.step cβ‚‚ = some cβ‚‚') : + (seqTM tm₁ tmβ‚‚).step (phase2Wrap tm₁ tmβ‚‚ cβ‚‚) = some (phase2Wrap tm₁ tmβ‚‚ cβ‚‚') := by + classical + have hne := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + unfold step + simp only [phase2Wrap, seqTM, ite_eq_right (Sum.inr_injective.ne hne), ite_eq_right hne] + +/-- Multi-step Phase 2 simulation. -/ +theorem seqTM_reachesIn_phase2Wrap (tm₁ tmβ‚‚ : TM n) {t : β„•} + {cβ‚‚_start cβ‚‚_end : Cfg n tmβ‚‚.Q} + (hreach : tmβ‚‚.reachesIn t cβ‚‚_start cβ‚‚_end) : + (seqTM tm₁ tmβ‚‚).reachesIn t + (phase2Wrap tm₁ tmβ‚‚ cβ‚‚_start) (phase2Wrap tm₁ tmβ‚‚ cβ‚‚_end) := + reachesIn_map (tm' := seqTM tm₁ tmβ‚‚) (phase2Wrap tm₁ tmβ‚‚) + (fun _ _ => seqTM_phase2_step tm₁ tmβ‚‚) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Full simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Full `seqTM` simulation combining all three phases. -/ +theorem seqTM_reachesIn_of_reachesIn (tm₁ tmβ‚‚ : TM n) + {t₁ : β„•} {c₁_start c₁_end : Cfg n tm₁.Q} + (hreach₁ : tm₁.reachesIn t₁ c₁_start c₁_end) + (hhalt₁ : c₁_end.state = tm₁.qhalt) + {tβ‚‚ : β„•} {cβ‚‚_end : Cfg n tmβ‚‚.Q} + (hreachβ‚‚ : tmβ‚‚.reachesIn tβ‚‚ + { state := tmβ‚‚.qstart, + input := transitionInput c₁_end.input, + work := fun i => transitionTape (c₁_end.work i), + output := transitionTape c₁_end.output } + cβ‚‚_end) : + (seqTM tm₁ tmβ‚‚).reachesIn (t₁ + 1 + tβ‚‚) + (phase1Wrap tm₁ tmβ‚‚ c₁_start) + (phase2Wrap tm₁ tmβ‚‚ cβ‚‚_end) := by + have hp1 := seqTM_reachesIn_phase1Wrap tm₁ tmβ‚‚ hreach₁ + have htrans := seqTM_transition_step tm₁ tmβ‚‚ hhalt₁ + have hp2 := seqTM_reachesIn_phase2Wrap tm₁ tmβ‚‚ hreachβ‚‚ + have h_tr : (seqTM tm₁ tmβ‚‚).reachesIn 1 + (phase1Wrap tm₁ tmβ‚‚ c₁_end) (phase2Wrap tm₁ tmβ‚‚ _) := + .step htrans .zero + exact reachesIn_trans _ (reachesIn_trans _ hp1 h_tr) hp2 + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting and output in Phase 2 +-- ════════════════════════════════════════════════════════════════════════ + +/-- A Phase-2 wrapped configuration is halted in `seqTM` iff the underlying `tmβ‚‚` + configuration is halted. -/ +theorem phase2Wrap_halted_iff (tm₁ tmβ‚‚ : TM n) (cβ‚‚ : Cfg n tmβ‚‚.Q) : + (seqTM tm₁ tmβ‚‚).halted (phase2Wrap tm₁ tmβ‚‚ cβ‚‚) ↔ tmβ‚‚.halted cβ‚‚ := by + simp [phase2Wrap, seqTM, halted, Cfg.isHalted] + +/-- Wrapping a `tmβ‚‚` configuration into the `seqTM` config space leaves the output + tape unchanged. -/ +theorem phase2Wrap_output (tm₁ tmβ‚‚ : TM n) (cβ‚‚ : Cfg n tmβ‚‚.Q) : + (phase2Wrap tm₁ tmβ‚‚ cβ‚‚).output = cβ‚‚.output := rfl + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean new file mode 100644 index 0000000000..b6f2db27f4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean @@ -0,0 +1,1277 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# unionTM simulation β€” proof internals + +This file contains the simulation lemmas needed to prove that `unionTM tm₁ tmβ‚‚` +correctly decides `L₁ βˆͺ Lβ‚‚` when `tm₁` decides `L₁` and `tmβ‚‚` decides `Lβ‚‚`. + +## Strategy + +The proof proceeds in three phases: + +1. **Phase 1 simulation**: Show that the union machine faithfully simulates + `tm₁` for `t₁` steps, with tm₁'s output redirected to the fake output + tape (work tape `n₁`). + +2. **Transition phase**: After Phase 1, the machine rewinds the fake output + to check tm₁'s result. If tm₁ accepted (cell 1 = `Ξ“.one`), write `Ξ“.one` + to the real output and halt. Otherwise, rewind the input and start Phase 2. + +3. **Phase 2 simulation**: Simulate `tmβ‚‚` using the real output tape. + +## Key definitions + +- `unionIdleTape` β€” the steady-state of an idle tape (head at 1, cells from `Tape.init []`) +- `unionPhase1Cfg` β€” embedding of a tm₁ config into the union machine's config space +-/ + + +@[expose] public section + +namespace Complexity + +variable {n₁ nβ‚‚ : β„•} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Idle tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- The steady-state tape for an idle tape during Phase 1. + After the first step (where `Ξ΄_right_of_start` forces a right move from + cell 0), idle tapes remain at head position 1 with blank cells. -/ +def unionIdleTape : Tape := + { head := 1, cells := (Tape.init ([] : List Ξ“)).cells } + +private theorem idleTape_read : unionIdleTape.read = Ξ“.blank := by + simp [unionIdleTape, Tape.read, Tape.init] + +/-- Writing blank to an idle tape at position 1 is a no-op. -/ +private theorem idleTape_write_blank : unionIdleTape.write Ξ“.blank = unionIdleTape := by + simp [unionIdleTape, Tape.write, Tape.init, Function.update_eq_self_iff] + +/-- An idle tape stays idle when written with blank and moved by idleDir. -/ +private theorem idleTape_step_idle : + (unionIdleTape.write Ξ“w.blank.toΞ“).move (idleDir unionIdleTape.read) = unionIdleTape := by + show (unionIdleTape.write Ξ“.blank).move (idleDir unionIdleTape.read) = unionIdleTape + rw [idleTape_read, idleDir, ite_eq_right (by decide)] + simp [idleTape_write_blank, Tape.move] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1 config embedding +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a tm₁ configuration into the union machine's config space. + Active tapes (input, work 0..n₁-1, fake output at n₁) come from `c`. + Idle tapes (work n₁+1..n₁+nβ‚‚ and real output) use `unionIdleTape`. -/ +def unionPhase1Cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (c : Cfg n₁ tm₁.Q) : + Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) where + state := Sum.inl c.state + input := c.input + work := fun i => + if h : i.val < n₁ then c.work ⟨i.val, h⟩ + else if i.val = n₁ then c.output + else unionIdleTape + output := unionIdleTape + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: one-step correspondence +-- ════════════════════════════════════════════════════════════════════════ + +/-- Key computation: unionTM.Ξ΄ for a Phase 1 non-halted state delegates to tm₁.Ξ΄. -/ +private theorem unionTM_delta_inl (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) {q : tm₁.Q} + (hne : q β‰  tm₁.qhalt) (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inl q) iHead wHeads oHead = + let r := tm₁.Ξ΄ q iHead (phase1WorkReads wHeads) (wHeads fakeOutIdx) + (Sum.inl r.1, + fun i => if h : i.val < n₁ then r.2.1 ⟨i.val, h⟩ else if i.val = n₁ then r.2.2.1 else .blank, + .blank, r.2.2.2.1, + fun i => if h : i.val < n₁ then r.2.2.2.2.1 ⟨i.val, h⟩ + else if i.val = n₁ then r.2.2.2.2.2 else idleDir (wHeads i), + idleDir oHead) := by + simp only [unionTM, ite_eq_right hne] + +private theorem unionTM_qhalt (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) : + (unionTM tm₁ tmβ‚‚).qhalt = Sum.inr (Sum.inr tmβ‚‚.qhalt) := rfl + +/-- Key computation: unionTM.Ξ΄ for a Phase 2 non-halted state delegates to tmβ‚‚.Ξ΄. -/ +private theorem unionTM_delta_inr_inr (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) {q : tmβ‚‚.Q} + (hne : q β‰  tmβ‚‚.qhalt) (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inr q)) iHead wHeads oHead = + let r := tmβ‚‚.Ξ΄ q iHead (phase2WorkReads wHeads) oHead + (Sum.inr (Sum.inr r.1), + fun i => if h : i.val ≀ n₁ then (Ξ“w.blank : Ξ“w) else r.2.1 ⟨i.val - (n₁ + 1), by omega⟩, + r.2.2.1, r.2.2.2.1, + fun i => if h : i.val ≀ n₁ then idleDir (wHeads i) + else r.2.2.2.2.1 ⟨i.val - (n₁ + 1), by omega⟩, + r.2.2.2.2.2) := by + simp only [unionTM, ite_eq_right hne] + +private theorem phase1Cfg_state (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (c : Cfg n₁ tm₁.Q) : + (unionPhase1Cfg tm₁ tmβ‚‚ c).state = Sum.inl c.state := rfl + +private theorem phase1_step_corr (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c c' : Cfg n₁ tm₁.Q} (hstep : tm₁.step c = some c') : + (unionTM tm₁ tmβ‚‚).step (unionPhase1Cfg tm₁ tmβ‚‚ c) = some (unionPhase1Cfg tm₁ tmβ‚‚ c') := by + have hne := state_ne_qhalt_of_step hstep + -- Extract c' from tm₁.step + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + -- Unfold step for unionTM on unionPhase1Cfg + simp only [step, phase1Cfg_state, unionTM_qhalt] + simp only [reduceCtorEq, ↓reduceIte] + apply congrArg some + -- Rewrite the Ξ΄ call using our helper + simp only [unionTM_delta_inl tm₁ tmβ‚‚ hne] + -- Now unfold unionPhase1Cfg on both sides and simplify + dsimp only [unionPhase1Cfg] + -- Establish that the Ξ΄ calls produce the same result + have hfake_read : (if h : (n₁ : β„•) < n₁ then c.work ⟨n₁, h⟩ + else if (n₁ : β„•) = n₁ then c.output else unionIdleTape).read = c.output.read := by + rw [dite_eq_right (Nat.lt_irrefl n₁), ite_eq_left rfl] + have hwork_reads : (phase1WorkReads fun i : Fin (n₁ + 1 + nβ‚‚) => + (if h : i.val < n₁ then c.work ⟨i.val, h⟩ + else if i.val = n₁ then c.output else unionIdleTape).read) = + fun j => (c.work j).read := by + ext ⟨j, hj⟩; simp only [phase1WorkReads]; rw [dif_pos (show j < n₁ from hj)] + -- Simplify fakeOutIdx to ⟨n₁, _⟩ and reduce the dite conditions + simp only [fakeOutIdx] at hfake_read ⊒ + -- Rewrite the work reads and fake output read + simp_rw [hwork_reads, hfake_read] + -- State and input match by rfl; work and output need case analysis + have hcfg : βˆ€ (a b : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + a.state = b.state β†’ a.input = b.input β†’ a.work = b.work β†’ a.output = b.output β†’ a = b := by + intros a b hs hi hw ho; cases a; cases b; simp_all + apply hcfg + Β· rfl -- state + Β· rfl -- input + Β· -- work tapes: case split on i + funext i; dsimp only []; split + Β· rfl -- i < n₁: active work tape + Β· split + Β· rfl -- i = n₁: fake output + Β· -- i > n₁: idle tape stays idle + exact idleTape_step_idle + Β· -- output: idle tape stays idle + exact idleTape_step_idle + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1 simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Multi-step Phase 1: if tm₁ takes t steps from c to c', the union machine + takes t steps from unionPhase1Cfg c to unionPhase1Cfg c'. -/ +private theorem phase1_steps (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {t : β„•} {c c' : Cfg n₁ tm₁.Q} + (hreach : tm₁.reachesIn t c c') : + (unionTM tm₁ tmβ‚‚).reachesIn t (unionPhase1Cfg tm₁ tmβ‚‚ c) (unionPhase1Cfg tm₁ tmβ‚‚ c') := by + induction hreach with + | zero => exact .zero + | step hstep _ ih => exact .step (phase1_step_corr tm₁ tmβ‚‚ hstep) ih + +/-- The first step of unionTM on initCfg produces unionPhase1Cfg of tm₁'s first step result. + At step 0, all tapes are at cell 0 with β–·, so Ξ΄_right_of_start forces right moves. + After this step, idle tapes become unionIdleTape (head=1, blank cells). -/ +private theorem phase1_init_step (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (x : List Bool) + {c_mid : Cfg n₁ tm₁.Q} (hstep : tm₁.step (tm₁.initCfg x) = some c_mid) : + (unionTM tm₁ tmβ‚‚).step ((unionTM tm₁ tmβ‚‚).initCfg x) = some (unionPhase1Cfg tm₁ tmβ‚‚ c_mid) := by + have hne := state_ne_qhalt_of_step hstep + simp only [step] at hstep ⊒ + rw [ite_eq_right hne] at hstep + simp only [Option.some.injEq] at hstep + subst hstep + -- Unfold unionTM qstart/qhalt + rw [show (unionTM tm₁ tmβ‚‚).qstart = Sum.inl tm₁.qstart from rfl, + show (unionTM tm₁ tmβ‚‚).qhalt = Sum.inr (Sum.inr tmβ‚‚.qhalt) from rfl] + simp only [reduceCtorEq, ↓reduceIte] + apply congrArg some + -- Rewrite the unionTM Ξ΄ call + simp only [unionTM_delta_inl tm₁ tmβ‚‚ hne] + -- The phase1WorkReads of constant function is a constant function + have hwork_reads : + phase1WorkReads (fun (_ : Fin (n₁ + 1 + nβ‚‚)) => (Tape.init ([] : List Ξ“)).read) = + fun _ => (Tape.init ([] : List Ξ“)).read := by ext; rfl + simp_rw [hwork_reads] + -- Now the Ξ΄ calls match; show Cfg equality field by field + have hcfg : βˆ€ (a b : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + a.state = b.state β†’ a.input = b.input β†’ a.work = b.work β†’ a.output = b.output β†’ a = b := by + intros a b hs hi hw ho; cases a; cases b; simp_all + apply hcfg + Β· rfl -- state + Β· rfl -- input + Β· -- work tapes + funext i; dsimp only [unionPhase1Cfg]; split + Β· -- i < n₁: all tapes start at Tape.init [], write at head 0 is no-op + simp [Tape.init, Tape.read] + Β· split + Β· -- i = n₁ + simp [Tape.init, Tape.read] + Β· -- i > n₁: becomes unionIdleTape + simp [Tape.init, Tape.write, Tape.read, unionIdleTape, idleDir, Tape.move] + Β· -- output: becomes unionIdleTape (unionPhase1Cfg always has unionIdleTape as output) + simp only [unionPhase1Cfg] + simp [Tape.init, Tape.write, Tape.read, idleDir, Tape.move, unionIdleTape] + +/-- **Phase 1 simulation**: if `tm₁` reaches `c₁` from `initCfg x` in `t₁ β‰₯ 1` + steps, the union machine reaches the embedded config `unionPhase1Cfg c₁` + from its own `initCfg x` in the same number of steps. -/ +theorem unionTM_phase1_simulation (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (x : List Bool) + {t₁ : β„•} {c₁ : Cfg n₁ tm₁.Q} + (hreach : tm₁.reachesIn t₁ (tm₁.initCfg x) c₁) + (ht₁ : t₁ β‰₯ 1) : + (unionTM tm₁ tmβ‚‚).reachesIn t₁ ((unionTM tm₁ tmβ‚‚).initCfg x) + (unionPhase1Cfg tm₁ tmβ‚‚ c₁) := by + -- Split the first step off + cases hreach with + | zero => omega -- contradicts t₁ β‰₯ 1 + | step hstep hrest => + exact .step (phase1_init_step tm₁ tmβ‚‚ x hstep) (phase1_steps tm₁ tmβ‚‚ hrest) + +/-- If a tape has head β‰₯ 1 and cells[β‰₯1] β‰  start, idleDir gives stay (head unchanged). -/ +private theorem idleDir_stay_of_ge_one (t : Tape) + (hhead : t.head β‰₯ 1) (hno : βˆ€ i, i β‰₯ 1 β†’ t.cells i β‰  Ξ“.start) : + idleDir t.read = Dir3.stay := by + rw [idleDir, ite_eq_right]; rw [Tape.read]; exact hno _ hhead + +/-- Input head stays constant when moved by idleDir if head β‰₯ 1 and cells[β‰₯1] β‰  start. -/ +private theorem idle_move_preserves_head (t : Tape) + (hhead : t.head β‰₯ 1) (hno : βˆ€ i, i β‰₯ 1 β†’ t.cells i β‰  Ξ“.start) : + (t.move (idleDir t.read)).head = t.head := by + rw [idleDir_stay_of_ge_one t hhead hno]; rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Union TM delta helpers for UnionPhase states +-- ════════════════════════════════════════════════════════════════════════ + +/-- Delta computation for rewindOut when fake output is not at start. -/ +private theorem unionTM_delta_rewindOut_nostart (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : wHeads fakeOutIdx β‰  Ξ“.start) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.rewindOut)) iHead wHeads oHead = + ( Sum.inr (Sum.inl UnionPhase.rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.left else idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [ite_eq_right hread] + +/-- Delta computation for rewindOut when fake output is at start. -/ +private theorem unionTM_delta_rewindOut_start (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : wHeads fakeOutIdx = Ξ“.start) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.rewindOut)) iHead wHeads oHead = + ( Sum.inr (Sum.inl UnionPhase.checkResult), + fun _ => .blank, .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.right else idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [ite_eq_left hread] + +/-- Delta computation for checkResult when fake output reads Ξ“.one. -/ +private theorem unionTM_delta_checkResult_one (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : wHeads fakeOutIdx = Ξ“.one) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.checkResult)) iHead wHeads oHead = + ( Sum.inr (Sum.inr tmβ‚‚.qhalt), + fun _ => .blank, .one, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [ite_eq_left hread] + +/-- Delta computation for checkResult when fake output does not read Ξ“.one. -/ +private theorem unionTM_delta_checkResult_notone (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : wHeads fakeOutIdx β‰  Ξ“.one) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.checkResult)) iHead wHeads oHead = + allIdle (Sum.inr (Sum.inl UnionPhase.rewindIn)) iHead wHeads oHead := by + unfold unionTM; simp only [ite_eq_right hread] + +/-- Delta computation for rewindIn when input is not at start. -/ +private theorem unionTM_delta_rewindIn_nostart (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : iHead β‰  Ξ“.start) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.rewindIn)) iHead wHeads oHead = + ( Sum.inr (Sum.inl UnionPhase.rewindIn), + fun _ => .blank, .blank, Dir3.left, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, ite_eq_right hread] + +/-- Delta computation for rewindIn when input is at start. -/ +private theorem unionTM_delta_rewindIn_start (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) + (hread : iHead = Ξ“.start) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.rewindIn)) iHead wHeads oHead = + ( Sum.inr (Sum.inl UnionPhase.setup2), + fun _ => .blank, .blank, Dir3.right, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, ite_eq_left hread] + +/-- Delta computation for setup2. -/ +private theorem unionTM_delta_setup2 (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inr (Sum.inl UnionPhase.setup2)) iHead wHeads oHead = + ( Sum.inr (Sum.inr tmβ‚‚.qstart), + fun _ => .blank, .blank, moveLeftDir iHead, + fun i => if i.val ≀ n₁ then idleDir (wHeads i) else moveLeftDir (wHeads i), + moveLeftDir oHead ) := by + unfold unionTM; rfl + +/-- Delta computation for Phase 1 halted state (transition to rewindOut). -/ +private theorem unionTM_delta_inl_qhalt (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (iHead : Ξ“) (wHeads : Fin (n₁ + 1 + nβ‚‚) β†’ Ξ“) (oHead : Ξ“) : + (unionTM tm₁ tmβ‚‚).Ξ΄ (Sum.inl tm₁.qhalt) iHead wHeads oHead = + ( Sum.inr (Sum.inl UnionPhase.rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, ite_true] + +-- ════════════════════════════════════════════════════════════════════════ +-- One-step lemmas for union TM +-- ════════════════════════════════════════════════════════════════════════ + +/-- The union machine is not halted in any UnionPhase state. -/ +private theorem unionTM_mid_not_halted (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (m : UnionPhase) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl m)) : + c.state β‰  (unionTM tm₁ tmβ‚‚).qhalt := by + rw [hstate]; exact fun h => nomatch h + +/-- The union machine is not halted when in a Phase 1 state. -/ +private theorem unionTM_inl_not_halted (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (q : tm₁.Q) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inl q) : + c.state β‰  (unionTM tm₁ tmβ‚‚).qhalt := by + rw [hstate]; exact fun h => nomatch h + +/-- Step the union machine from a rewindOut state with non-start fake output read. -/ +private theorem step_rewindOut_nostart_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.rewindOut)) + (hread : (c.work fakeOutIdx).read β‰  Ξ“.start) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Ξ“w).toΞ“).move + (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_right hread]; rfl + +/-- Step the union machine from a rewindOut state when fake output reads start. -/ +private theorem step_rewindOut_start_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.rewindOut)) + (hread : (c.work fakeOutIdx).read = Ξ“.start) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.checkResult), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move + (if i.val = n₁ then Dir3.right else idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_left hread]; rfl + +/-- Step the union machine from checkResult with Ξ“.one β†’ halted. -/ +private theorem step_checkResult_one_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.checkResult)) + (hread : (c.work fakeOutIdx).read = Ξ“.one) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inr tmβ‚‚.qhalt), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work i).read), + output := (c.output.write Ξ“w.one.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_left hread]; rfl + +/-- Step the union machine from checkResult when not Ξ“.one β†’ rewindIn (allIdle). -/ +private theorem step_checkResult_notone_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.checkResult)) + (hread : (c.work fakeOutIdx).read β‰  Ξ“.one) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.rewindIn), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_right hread, allIdle]; rfl + +/-- Step the union machine from rewindIn with non-start input. -/ +private theorem step_rewindIn_nostart_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.rewindIn)) + (hread : c.input.read β‰  Ξ“.start) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.rewindIn), + input := c.input.move Dir3.left, + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_right hread]; rfl + +/-- Step the union machine from rewindIn when input reads start. -/ +private theorem step_rewindIn_start_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.rewindIn)) + (hread : c.input.read = Ξ“.start) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.setup2), + input := c.input.move Dir3.right, + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_eq_left hread]; rfl + +/-- Step the union machine from setup2. -/ +private theorem step_setup2_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inr (Sum.inl UnionPhase.setup2)) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inr tmβ‚‚.qstart), + input := c.input.move (moveLeftDir c.input.read), + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move + (if i.val ≀ n₁ then idleDir (c.work i).read else moveLeftDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (moveLeftDir c.output.read) } := by + simp only [step]; rw [hstate]; rfl + +/-- Step the union machine from unionPhase1Cfg when tm₁ halted. -/ +private theorem step_inl_qhalt_cfg (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hstate : c.state = Sum.inl tm₁.qhalt) : + (unionTM tm₁ tmβ‚‚).step c = some + { state := Sum.inr (Sum.inl UnionPhase.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Ξ“w).toΞ“).move + (idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } := by + simp only [step]; rw [hstate]; simp only [unionTM, ite_true]; rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind fake output loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- readBackWrite preserves cells at non-zero head positions. -/ +private theorem write_readBack_cells_eq (t : Tape) (hne : t.read β‰  Ξ“.start) : + (t.write (readBackWrite t.read).toΞ“).cells = t.cells := by + rw [toΞ“_readBackWrite_of_ne_start hne] + simp only [Tape.write] + split + Β· rfl + Β· ext i; simp only [Function.update]; split + Β· next heq => subst heq; rfl + Β· rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition phase: accept path (x ∈ L₁) +-- ════════════════════════════════════════════════════════════════════════ + +/-- unionPhase1Cfg output is unionIdleTape. -/ +private theorem phase1Cfg_output (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (c : Cfg n₁ tm₁.Q) : + (unionPhase1Cfg tm₁ tmβ‚‚ c).output = unionIdleTape := rfl + +/-- unionPhase1Cfg fake output tape is c.output. -/ +private theorem phase1Cfg_fakeOut (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (c : Cfg n₁ tm₁.Q) : + (unionPhase1Cfg tm₁ tmβ‚‚ c).work fakeOutIdx = c.output := by + simp [unionPhase1Cfg, fakeOutIdx] + +/-- One step from unionPhase1Cfg when tm₁ is halted transitions to rewindOut. -/ +private theorem step_phase1_halted (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (c₁ : Cfg n₁ tm₁.Q) (hhalt : tm₁.halted c₁) + (hnostart_out : βˆ€ i, i β‰₯ 1 β†’ c₁.output.cells i β‰  Ξ“.start) : + βˆƒ c', (unionTM tm₁ tmβ‚‚).step (unionPhase1Cfg tm₁ tmβ‚‚ c₁) = some c' ∧ + c'.state = Sum.inr (Sum.inl UnionPhase.rewindOut) ∧ + (c'.work fakeOutIdx).cells = c₁.output.cells ∧ + c'.output = (unionIdleTape.write Ξ“w.blank.toΞ“).move (idleDir unionIdleTape.read) := by + have hstate : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep := step_inl_qhalt_cfg tm₁ tmβ‚‚ hstate + -- The result config + set c' : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.rewindOut), + input := (unionPhase1Cfg tm₁ tmβ‚‚ c₁).input.move + (idleDir (unionPhase1Cfg tm₁ tmβ‚‚ c₁).input.read), + work := fun i => (((unionPhase1Cfg tm₁ tmβ‚‚ c₁).work i).write + ((if i.val = n₁ then readBackWrite ((unionPhase1Cfg tm₁ tmβ‚‚ c₁).work fakeOutIdx).read + else .blank) : Ξ“w).toΞ“).move + (idleDir ((unionPhase1Cfg tm₁ tmβ‚‚ c₁).work i).read), + output := ((unionPhase1Cfg tm₁ tmβ‚‚ c₁).output.write Ξ“w.blank.toΞ“).move + (idleDir (unionPhase1Cfg tm₁ tmβ‚‚ c₁).output.read) } with hc'_def + refine ⟨c', hstep, rfl, ?_, ?_⟩ + Β· -- fake output cells preserved + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + rw [phase1Cfg_fakeOut] + rw [Tape.move_cells] + simp only [Tape.write] + split + Β· rfl -- head = 0: write is no-op + Β· next hne => + -- head β‰  0: readBackWrite writes back the same value + have hread_ne : c₁.output.read β‰  Ξ“.start := by + rw [Tape.read]; exact hnostart_out _ (by omega) + rw [toΞ“_readBackWrite_of_ne_start hread_ne, Tape.read] + exact Function.update_eq_self _ _ + Β· -- output is unionIdleTape write blank / move idle + simp only [hc'_def, phase1Cfg_output] + +/-- Rewind the fake output tape, tracking all loop invariants: + state, fakeOut head/cells, output = unionIdleTape, and conditionally + input head preservation and work tape idleness for tapes > n₁. -/ +private theorem rewind_fakeOut_loop (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) : + βˆ€ (h : β„•) (c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + c.state = Sum.inr (Sum.inl UnionPhase.rewindOut) β†’ + c.output = unionIdleTape β†’ + (c.work fakeOutIdx).head = h β†’ + (c.work fakeOutIdx).cells 0 = Ξ“.start β†’ + (βˆ€ i, i β‰₯ 1 β†’ (c.work fakeOutIdx).cells i β‰  Ξ“.start) β†’ + βˆƒ c', (unionTM tm₁ tmβ‚‚).reachesIn h c c' ∧ + c'.state = Sum.inr (Sum.inl UnionPhase.rewindOut) ∧ + (c'.work fakeOutIdx).head = 0 ∧ + (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells ∧ + c'.output = unionIdleTape ∧ + (c.input.head β‰₯ 1 β†’ (βˆ€ i, i β‰₯ 1 β†’ c.input.cells i β‰  Ξ“.start) β†’ + c'.input.head = c.input.head) ∧ + (βˆ€ i : Fin (n₁ + 1 + nβ‚‚), i.val > n₁ β†’ c.work i = unionIdleTape β†’ + c'.work i = unionIdleTape) := by + intro h + induction h with + | zero => + intro c hst hout hhead _ _ + exact ⟨c, .zero, hst, hhead, rfl, hout, fun _ _ => rfl, fun _ _ h => h⟩ + | succ n ih => + intro c hst hout hhead hcell0 hnostart + have hread_ne : (c.work fakeOutIdx).read β‰  Ξ“.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindOut_nostart_cfg tm₁ tmβ‚‚ hst hread_ne + set c' : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Ξ“w).toΞ“).move + (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } + with hc'_def + have hout' : c'.output = unionIdleTape := by + simp only [hc'_def]; rw [hout, idleTape_step_idle] + have hhead' : (c'.work fakeOutIdx).head = n := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + rw [toΞ“_readBackWrite_of_ne_start hread_ne]; simp only [Tape.write] + split + Β· omega + Β· simp [Tape.move, hhead] + have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] + obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout'', hinp'', hwork''⟩ := + ih c' rfl hout' hhead' + (by rw [hcells']; exact hcell0) + (by intro i hi; rw [hcells']; exact hnostart i hi) + refine ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout'', + fun hih hino => ?_, fun i hi hidle => ?_⟩ + Β· -- Input head: chain c β†’ c' β†’ c'' + have hih' : c'.input.head = c.input.head := idle_move_preserves_head _ hih hino + have hino' : βˆ€ i, i β‰₯ 1 β†’ c'.input.cells i β‰  Ξ“.start := by + intro i hi; show (c.input.move _).cells i β‰  _; rw [Tape.move_cells]; exact hino i hi + rw [hinp'' (by omega) hino', hih'] + Β· -- Work tapes: chain c β†’ c' β†’ c'' + have hidle' : c'.work i = unionIdleTape := by + simp only [hc'_def, show (i : β„•) β‰  n₁ from by omega, ↓reduceIte] + rw [hidle]; exact idleTape_step_idle + exact hwork'' i hi hidle' + +/-- After Phase 1, if tm₁ accepted (output cell 1 = `Ξ“.one`), the union + machine rewinds the fake output, checks the result, writes `Ξ“.one` to + the real output, and halts. -/ +theorem unionTM_transition_accept (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c₁ : Cfg n₁ tm₁.Q} + (hhalt : tm₁.halted c₁) + (haccept : c₁.output.cells 1 = Ξ“.one) + (hcell0 : c₁.output.cells 0 = Ξ“.start) + (hnostart : βˆ€ i, i β‰₯ 1 β†’ c₁.output.cells i β‰  Ξ“.start) : + βˆƒ (t_tr : β„•) (c_final : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + (unionTM tm₁ tmβ‚‚).reachesIn t_tr (unionPhase1Cfg tm₁ tmβ‚‚ c₁) c_final ∧ + (unionTM tm₁ tmβ‚‚).halted c_final ∧ + c_final.output.cells 1 = Ξ“.one ∧ + t_tr ≀ c₁.output.head + 4 := by + -- Step 1: unionPhase1Cfg β†’ rewindOut (1 step) + obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := + step_phase1_halted tm₁ tmβ‚‚ c₁ hhalt hnostart + -- Head bound for the fake output after step 1 + have hfo_head_bound : (c_rw.work fakeOutIdx).head ≀ c₁.output.head + 1 := by + have hstate : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hexp := (step_inl_qhalt_cfg tm₁ tmβ‚‚ hstate).symm.trans hstep1 + rw [Option.some.injEq] at hexp + rw [← hexp] + simp only [phase1Cfg_fakeOut] + have hmv : βˆ€ (t : Tape) (d : Dir3), (t.move d).head ≀ t.head + 1 := by + intro t d; cases d <;> simp [Tape.move]; omega + have hwh : βˆ€ (t : Tape) (s : Ξ“), (t.write s).head = t.head := by + intro t s; simp [Tape.write]; split <;> rfl + calc ((c₁.output.write _).move _).head ≀ (c₁.output.write _).head + 1 := hmv _ _ + _ = c₁.output.head + 1 := by rw [hwh] + -- Fake output cells preserved + have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Ξ“.start := by + rw [hcells_rw]; exact hcell0 + have hnostart_rw : βˆ€ i, i β‰₯ 1 β†’ (c_rw.work fakeOutIdx).cells i β‰  Ξ“.start := by + intro i hi; rw [hcells_rw]; exact hnostart i hi + -- c_rw.output = unionIdleTape + have hout_rw_eq : c_rw.output = unionIdleTape := by + rw [hout_rw]; exact idleTape_step_idle + -- Step 2: Rewind loop (h_rw steps), also preserving output = unionIdleTape + set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def + obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0, -, -⟩ := + rewind_fakeOut_loop tm₁ tmβ‚‚ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw + -- Step 3: rewindOut at head 0 β†’ checkResult (1 step) + have hread_start : (c_at0.work fakeOutIdx).read = Ξ“.start := by + rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0 + have hstep3 := step_rewindOut_start_cfg tm₁ tmβ‚‚ hst_at0 hread_start + set c_cr : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.checkResult), + input := c_at0.input.move (idleDir c_at0.input.read), + work := fun i => ((c_at0.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move + (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), + output := (c_at0.output.write Ξ“w.blank.toΞ“).move (idleDir c_at0.output.read) } + with hc_cr_def + -- c_cr fake output head = 1 (moved right from head 0) + have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] + -- c_cr fake output cells preserved (write blank at head 0 is no-op) + have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells]; simp only [Tape.write, ite_eq_left hhead_at0] + -- c_cr fake output reads cell 1 = Ξ“.one + have hcr_read : (c_cr.work fakeOutIdx).read = Ξ“.one := by + rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw]; exact haccept + -- c_cr output = unionIdleTape + have hout_cr : c_cr.output = unionIdleTape := by + show (c_at0.output.write Ξ“w.blank.toΞ“).move (idleDir c_at0.output.read) = unionIdleTape + rw [hout_at0]; exact idleTape_step_idle + -- Step 4: checkResult with Ξ“.one β†’ halt (1 step) + have hst_cr : c_cr.state = Sum.inr (Sum.inl UnionPhase.checkResult) := rfl + have hstep4 := step_checkResult_one_cfg tm₁ tmβ‚‚ hst_cr hcr_read + set c_final : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inr tmβ‚‚.qhalt), + input := c_cr.input.move (idleDir c_cr.input.read), + work := fun i => ((c_cr.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c_cr.work i).read), + output := (c_cr.output.write Ξ“w.one.toΞ“).move (idleDir c_cr.output.read) } + with hc_final_def + -- c_final is halted + have hhalt_final : (unionTM tm₁ tmβ‚‚).halted c_final := rfl + -- c_final output cell 1 = Ξ“.one + have hcells_final : c_final.output.cells 1 = Ξ“.one := by + show ((c_cr.output.write Ξ“w.one.toΞ“).move (idleDir c_cr.output.read)).cells 1 = Ξ“.one + rw [Tape.move_cells, hout_cr] + simp [Tape.write, unionIdleTape, Ξ“w.toΞ“, Function.update, Tape.init] + -- Compose all steps: 1 + h_rw + 1 + 1 steps total + have htotal : (unionTM tm₁ tmβ‚‚).reachesIn (1 + (h_rw + (1 + 1))) + (unionPhase1Cfg tm₁ tmβ‚‚ c₁) c_final := + reachesIn_trans _ (.step hstep1 .zero) + (reachesIn_trans _ hreach_rw + (.step hstep3 (.step hstep4 .zero))) + have heq : 1 + (h_rw + (1 + 1)) = 1 + h_rw + 1 + 1 := by omega + exact ⟨1 + h_rw + 1 + 1, c_final, heq β–Έ htotal, hhalt_final, hcells_final, by omega⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition phase: reject path (x βˆ‰ L₁) β†’ Phase 2 ready +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind the input tape from head position `h` to head position 0, + preserving output = unionIdleTape. -/ +private theorem rewind_input_loop (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) : + βˆ€ (h : β„•) (c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + c.state = Sum.inr (Sum.inl UnionPhase.rewindIn) β†’ + c.input.head = h β†’ + (βˆ€ i, i β‰₯ 1 β†’ c.input.cells i β‰  Ξ“.start) β†’ + c.input.cells 0 = Ξ“.start β†’ + c.output = unionIdleTape β†’ + βˆƒ c', (unionTM tm₁ tmβ‚‚).reachesIn h c c' ∧ + c'.state = Sum.inr (Sum.inl UnionPhase.rewindIn) ∧ + c'.input.head = 0 ∧ + c'.input.cells = c.input.cells ∧ + c'.output = unionIdleTape := by + intro h + induction h with + | zero => + intro c hst hhead _ _ hout + exact ⟨c, .zero, hst, hhead, rfl, hout⟩ + | succ n ih => + intro c hst hhead hnostart hcell0 hout + have hread_ne : c.input.read β‰  Ξ“.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindIn_nostart_cfg tm₁ tmβ‚‚ hst hread_ne + set c' : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.rewindIn), + input := c.input.move Dir3.left, + work := fun i => ((c.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work i).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } + with hc'_def + have hst' : c'.state = Sum.inr (Sum.inl UnionPhase.rewindIn) := rfl + have hhead' : c'.input.head = n := by + show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead] + have hcells' : c'.input.cells = c.input.cells := Tape.move_cells _ _ + have hcell0' : c'.input.cells 0 = Ξ“.start := by rw [hcells']; exact hcell0 + have hnostart' : βˆ€ i, i β‰₯ 1 β†’ c'.input.cells i β‰  Ξ“.start := by + intro i hi; rw [hcells']; exact hnostart i hi + have hout' : c'.output = unionIdleTape := by + show (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) = unionIdleTape + rw [hout]; exact idleTape_step_idle + obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout''⟩ := + ih c' hst' hhead' hnostart' hcell0' hout' + exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout''⟩ + +/-- Writing blank to unionIdleTape and moving left yields Tape.init []. -/ +private theorem idleTape_moveLeft : + (unionIdleTape.write Ξ“w.blank.toΞ“).move (moveLeftDir unionIdleTape.read) = Tape.init [] := by + simp [unionIdleTape, moveLeftDir, Tape.write, Tape.move, Tape.read, Tape.init] + +/-- unionIdleTape stays unionIdleTape when written with blank and moved by idleDir (on any tape). -/ +private theorem tape_idle_step (t : Tape) (ht : t = unionIdleTape) : + (t.write Ξ“w.blank.toΞ“).move (idleDir t.read) = unionIdleTape := by + rw [ht]; exact idleTape_step_idle + +/-- Input cells are preserved through any reachesIn (input tape is read-only). -/ +private theorem union_input_cells_of_step (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c c' : Cfg (n₁ + 1 + nβ‚‚) (unionTM tm₁ tmβ‚‚).Q} + (hs : (unionTM tm₁ tmβ‚‚).step c = some c') : c'.input.cells = c.input.cells := by + have hne := state_ne_qhalt_of_step hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact Tape.move_cells _ _ + +private theorem union_input_cells_of_reachesIn (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {t : β„•} {cβ‚€ c : Cfg (n₁ + 1 + nβ‚‚) (unionTM tm₁ tmβ‚‚).Q} + (h : (unionTM tm₁ tmβ‚‚).reachesIn t cβ‚€ c) : c.input.cells = cβ‚€.input.cells := by + induction h with + | zero => rfl + | step hs _ ih => rw [ih, union_input_cells_of_step tm₁ tmβ‚‚ hs] + +/-- Work tapes at index `> n₁` get write blank + move idle in any step + from `inl q`, `rewindOut`, `checkResult`, or `rewindIn` states. -/ +private theorem phase2_work_step_idle (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {c c' : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hs : (unionTM tm₁ tmβ‚‚).step c = some c') + (hstate : (βˆƒ q, c.state = Sum.inl q) ∨ + c.state = Sum.inr (Sum.inl UnionPhase.rewindOut) ∨ + c.state = Sum.inr (Sum.inl UnionPhase.checkResult) ∨ + c.state = Sum.inr (Sum.inl UnionPhase.rewindIn)) + {i : Fin (n₁ + 1 + nβ‚‚)} (hi : i.val > n₁) : + c'.work i = ((c.work i).write Ξ“w.blank.toΞ“).move (idleDir (c.work i).read) := by + have hne : c.state β‰  (unionTM tm₁ tmβ‚‚).qhalt := by + rcases hstate with ⟨q, hq⟩ | hq | hq | hq <;> rw [hq] <;> exact fun h => nomatch h + simp only [step] at hs + split at hs + Β· exact absurd β€Ή_β€Ί hne + injection hs with hs; subst hs + have hine : (i : β„•) β‰  n₁ := by omega + rcases hstate with ⟨q, hq⟩ | hq | hq | hq + Β· dsimp only []; rw [hq]; dsimp only [unionTM]; split + Β· -- qhalt: write (if i = n₁ then ... else blank), dir idleDir + congr 1; simp only [hine, ↓reduceIte] + Β· -- q β‰  qhalt: write/dir have dif/if structure + congr 1 + Β· congr 1 + show (if h : (i : β„•) < n₁ then _ else if (i : β„•) = n₁ then _ else Ξ“w.blank) = Ξ“w.blank + rw [dite_eq_right (show Β¬((i : β„•) < n₁) from by omega), ite_eq_right hine] + Β· show (if h : (i : β„•) < n₁ then _ + else if (i : β„•) = n₁ then _ else idleDir (c.work i).read) = _ + rw [dite_eq_right (show Β¬((i : β„•) < n₁) from by omega), ite_eq_right hine] + Β· rw [hq]; dsimp only [unionTM]; split + Β· congr 1; simp only [hine, ↓reduceIte] + Β· congr 1 + Β· congr 1; simp only [hine, ↓reduceIte] + Β· simp only [hine, ↓reduceIte] + Β· rw [hq]; dsimp only [unionTM]; split <;> rfl + Β· rw [hq]; dsimp only [unionTM]; split <;> rfl + +/-- Rewind input loop also preserves phase 2 work tapes. -/ +private theorem rewind_input_work_idle (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {i : Fin (n₁ + 1 + nβ‚‚)} (_hi : i.val > n₁) : + βˆ€ (h : β„•) (c : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + c.state = Sum.inr (Sum.inl UnionPhase.rewindIn) β†’ + c.input.head = h β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + c.input.cells 0 = Ξ“.start β†’ + c.work i = unionIdleTape β†’ + βˆƒ c', (unionTM tm₁ tmβ‚‚).reachesIn h c c' ∧ + c'.work i = unionIdleTape := by + intro h + induction h with + | zero => + intro c _ _ _ _ hidle; exact ⟨c, .zero, hidle⟩ + | succ n ih => + intro c hst hhead hnostart hcell0 hidle + have hread_ne : c.input.read β‰  Ξ“.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindIn_nostart_cfg tm₁ tmβ‚‚ hst hread_ne + set c' : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.rewindIn), + input := c.input.move Dir3.left, + work := fun j => ((c.work j).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c.work j).read), + output := (c.output.write Ξ“w.blank.toΞ“).move (idleDir c.output.read) } + with hc'_def + have hidle' : c'.work i = unionIdleTape := by + show ((c.work i).write _).move _ = _; rw [hidle]; exact idleTape_step_idle + obtain ⟨c'', hreach, hidle''⟩ := ih c' rfl + (by show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead]) + (by intro j hj; show (c.input.move Dir3.left).cells j β‰  _ + rw [Tape.move_cells]; exact hnostart j hj) + (by show (c.input.move Dir3.left).cells 0 = _; rw [Tape.move_cells]; exact hcell0) + hidle' + exact ⟨c'', .step hstep hreach, hidle''⟩ + +/-- The rejection check leaves the input rewind distance at most one past its original head. -/ +private theorem unionReject_rewindInput_head_bound + (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (x : List Bool) + (c₁ : Cfg n₁ tm₁.Q) + (c_rw c_at0 : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)) (h_rw : β„•) + (hhalt : tm₁.halted c₁) + (hinput_cells : c₁.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells) + (hstep1 : (unionTM tm₁ tmβ‚‚).step (unionPhase1Cfg tm₁ tmβ‚‚ c₁) = some c_rw) + (hreach_rw : (unionTM tm₁ tmβ‚‚).reachesIn h_rw c_rw c_at0) + (hinp_at0 : c_rw.input.head β‰₯ 1 β†’ + (βˆ€ i, i β‰₯ 1 β†’ c_rw.input.cells i β‰  Ξ“.start) β†’ + c_at0.input.head = c_rw.input.head) : + let checkInput := c_at0.input.move (idleDir c_at0.input.read) + let rewindInput := checkInput.move (idleDir checkInput.read) + rewindInput.head ≀ c₁.input.head + 1 := by + dsimp only + let checkInput := c_at0.input.move (idleDir c_at0.input.read) + let rewindInput := checkInput.move (idleDir checkInput.read) + -- c_rw.input.cells = c₁.input.cells (input cells preserved through step) + have hcrw_cells : c_rw.input.cells = c₁.input.cells := by + have := union_input_cells_of_step tm₁ tmβ‚‚ hstep1 + rw [this]; rfl + -- c_rw.input cells[β‰₯1] β‰  Ξ“.start + have hcrw_ino : βˆ€ i, i β‰₯ 1 β†’ c_rw.input.cells i β‰  Ξ“.start := by + intro i hi; rw [hcrw_cells, hinput_cells] + simp only [Tape.init, show i β‰  0 from by omega, ↓reduceIte] + intro heq + cases hget : (x.map Ξ“.ofBool)[i - 1]? with + | none => simp [hget, Option.getD] at heq + | some v => + simp [hget, Option.getD] at heq; subst heq + have hmem := List.mem_of_getElem? hget + simp [List.mem_map] at hmem; rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Ξ“.ofBool] at hb + -- c_rw.input.head ≀ c₁.input.head + 1 + -- From step_inl_qhalt_cfg, the input direction is idleDir(input.read) + -- Use step_inl_qhalt_cfg to get the exact form of c_rw.input + have hstateq : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep_eq := step_inl_qhalt_cfg tm₁ tmβ‚‚ hstateq + -- c_rw.input = c₁.input.move (idleDir c₁.input.read) since unionPhase1Cfg.input = c₁.input + have hcrw_input_eq : c_rw.input = c₁.input.move (idleDir c₁.input.read) := by + exact congrArg (fun c => c.input) (Option.some.inj (hstep1.symm.trans hstep_eq)) + -- c_rw.input.head ≀ c₁.input.head + 1 + have hcrw_head : c_rw.input.head ≀ c₁.input.head + 1 := by + rw [hcrw_input_eq]; cases (idleDir c₁.input.read) <;> simp [Tape.move]; omega + -- c_rw.input.head β‰₯ 1 + have hcrw_hge : c_rw.input.head β‰₯ 1 := by + rw [hcrw_input_eq] + by_cases hh : c₁.input.head = 0 + Β· have hread0 : c₁.input.read = Ξ“.start := by + rw [Tape.read, hh, hinput_cells]; simp [Tape.init] + rw [hread0, idleDir, ite_eq_left rfl]; simp [Tape.move, hh] + Β· have hge : c₁.input.head β‰₯ 1 := by omega + have hc1_ino : βˆ€ i, i β‰₯ 1 β†’ c₁.input.cells i β‰  Ξ“.start := by + intro i hi; rw [← hcrw_cells]; exact hcrw_ino i hi + rw [idleDir_stay_of_ge_one _ hge hc1_ino]; simp [Tape.move]; omega + -- Through rewind_fakeOut loop: input head preserved + have hat0_head : c_at0.input.head = c_rw.input.head := + hinp_at0 hcrw_hge hcrw_ino + -- c_at0.input.cells[β‰₯1] β‰  start (preserved through reachesIn) + have hat0_ino : βˆ€ i, i β‰₯ 1 β†’ c_at0.input.cells i β‰  Ξ“.start := by + intro i hi; rw [union_input_cells_of_reachesIn tm₁ tmβ‚‚ hreach_rw]; exact hcrw_ino i hi + -- checkInput.head = c_at0.input.head (idleDir step from head β‰₯ 1) + have hcr_head : checkInput.head = c_at0.input.head := by + show (c_at0.input.move (idleDir c_at0.input.read)).head = _ + exact idle_move_preserves_head _ (by omega) hat0_ino + -- rewindInput.head = checkInput.head (idleDir step from head β‰₯ 1) + have hcr_ino : βˆ€ i, i β‰₯ 1 β†’ checkInput.cells i β‰  Ξ“.start := by + intro i hi; show (c_at0.input.move _).cells i β‰  _; rw [Tape.move_cells]; exact hat0_ino i hi + have hri_head : rewindInput.head = checkInput.head := by + show (checkInput.move (idleDir checkInput.read)).head = _ + exact idle_move_preserves_head _ (by omega) hcr_ino + exact (hri_head.trans (hcr_head.trans hat0_head)).trans_le hcrw_head + +/-- After Phase 1, if tm₁ rejected, the union machine transitions to a + config ready for Phase 2: state is `Sum.inr (Sum.inr tmβ‚‚.qstart)`, + input/output/active work tapes match `tmβ‚‚.initCfg x`. -/ +theorem unionTM_transition_reject (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (x : List Bool) + {c₁ : Cfg n₁ tm₁.Q} + (hhalt : tm₁.halted c₁) + (hreject : c₁.output.cells 1 = Ξ“.zero) + (hcell0_out : c₁.output.cells 0 = Ξ“.start) + (hnostart_out : βˆ€ i, i β‰₯ 1 β†’ c₁.output.cells i β‰  Ξ“.start) + (hinput_cells : c₁.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells) : + βˆƒ (t_tr : β„•) (c_mid : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)), + (unionTM tm₁ tmβ‚‚).reachesIn t_tr (unionPhase1Cfg tm₁ tmβ‚‚ c₁) c_mid ∧ + c_mid.state = Sum.inr (Sum.inr tmβ‚‚.qstart) ∧ + c_mid.input = Tape.init (x.map Ξ“.ofBool) ∧ + (βˆ€ j : Fin nβ‚‚, c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = Tape.init []) ∧ + c_mid.output = Tape.init [] ∧ + t_tr ≀ c₁.output.head + c₁.input.head + 7 := by + -- Step 1: unionPhase1Cfg halted β†’ rewindOut (1 step) + obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := + step_phase1_halted tm₁ tmβ‚‚ c₁ hhalt hnostart_out + -- Head bounds + have hfo_head_bound : (c_rw.work fakeOutIdx).head ≀ c₁.output.head + 1 := by + have hstate : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hexp := (step_inl_qhalt_cfg tm₁ tmβ‚‚ hstate).symm.trans hstep1 + rw [Option.some.injEq] at hexp + rw [← hexp] + simp only [phase1Cfg_fakeOut] + have hmv : βˆ€ (t : Tape) (d : Dir3), (t.move d).head ≀ t.head + 1 := by + intro t d; cases d <;> simp [Tape.move]; omega + have hwh : βˆ€ (t : Tape) (s : Ξ“), (t.write s).head = t.head := by + intro t s; simp [Tape.write]; split <;> rfl + calc ((c₁.output.write _).move _).head ≀ (c₁.output.write _).head + 1 := hmv _ _ + _ = c₁.output.head + 1 := by rw [hwh] + -- c_rw properties + have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Ξ“.start := by rw [hcells_rw]; exact hcell0_out + have hnostart_rw : βˆ€ i, i β‰₯ 1 β†’ (c_rw.work fakeOutIdx).cells i β‰  Ξ“.start := by + intro i hi; rw [hcells_rw]; exact hnostart_out i hi + have hout_rw_eq : c_rw.output = unionIdleTape := by rw [hout_rw]; exact idleTape_step_idle + -- Step 2: Rewind fake output (h_rw steps) + set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def + obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0, hinp_at0, hwork_at0⟩ := + rewind_fakeOut_loop tm₁ tmβ‚‚ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw + -- Step 3: rewindOut at head 0 β†’ checkResult (1 step) + have hread_start : (c_at0.work fakeOutIdx).read = Ξ“.start := by + rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0_out + have hstep3 := step_rewindOut_start_cfg tm₁ tmβ‚‚ hst_at0 hread_start + set c_cr : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.checkResult), + input := c_at0.input.move (idleDir c_at0.input.read), + work := fun i => ((c_at0.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move + (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), + output := (c_at0.output.write Ξ“w.blank.toΞ“).move (idleDir c_at0.output.read) } + with hc_cr_def + have hout_cr : c_cr.output = unionIdleTape := by + show (c_at0.output.write Ξ“w.blank.toΞ“).move (idleDir c_at0.output.read) = unionIdleTape + rw [hout_at0]; exact idleTape_step_idle + -- c_cr fake output reads Ξ“.zero (not Ξ“.one) + have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] + have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + nβ‚‚)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells]; simp only [Tape.write, ite_eq_left hhead_at0] + have hcr_read_ne_one : (c_cr.work fakeOutIdx).read β‰  Ξ“.one := by + rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw, hreject]; decide + -- Step 4: checkResult β‰  Ξ“.one β†’ rewindIn (1 step) + have hstep4 := step_checkResult_notone_cfg tm₁ tmβ‚‚ rfl hcr_read_ne_one + set c_ri : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.rewindIn), + input := c_cr.input.move (idleDir c_cr.input.read), + work := fun i => ((c_cr.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c_cr.work i).read), + output := (c_cr.output.write Ξ“w.blank.toΞ“).move (idleDir c_cr.output.read) } + with hc_ri_def + have hout_ri : c_ri.output = unionIdleTape := by + show (c_cr.output.write Ξ“w.blank.toΞ“).move (idleDir c_cr.output.read) = unionIdleTape + rw [hout_cr]; exact idleTape_step_idle + -- Input cells chain: input is read-only, so cells are preserved through all steps. + -- unionPhase1Cfg β†’ c_rw β†’ (rewind) β†’ c_at0 β†’ c_cr β†’ c_ri all preserve input.cells + have hin_cells_chain : c_ri.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + -- c_ri.input.cells = c_cr.input.cells (move) + show (c_cr.input.move _).cells = _; rw [Tape.move_cells] + -- c_cr.input.cells = c_at0.input.cells (move) + show (c_at0.input.move _).cells = _; rw [Tape.move_cells] + -- c_at0.input.cells = c_rw.input.cells (reachesIn) + rw [union_input_cells_of_reachesIn tm₁ tmβ‚‚ hreach_rw] + -- c_rw.input.cells = unionPhase1Cfg.input.cells (step) + have hstate : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hexp := (step_inl_qhalt_cfg tm₁ tmβ‚‚ hstate).symm.trans hstep1 + rw [Option.some.injEq] at hexp + rw [← hexp, Tape.move_cells]; exact hinput_cells + -- Input cells β‰₯ 1 β‰  Ξ“.start + have hin_nostart_ri : βˆ€ i, i β‰₯ 1 β†’ c_ri.input.cells i β‰  Ξ“.start := by + intro i hi; rw [hin_cells_chain] + simp only [Tape.init, show i β‰  0 from by omega, ↓reduceIte] + intro heq + have : (x.map Ξ“.ofBool)[i - 1]?.getD Ξ“.blank = Ξ“.start := heq + cases hget : (x.map Ξ“.ofBool)[i - 1]? with + | none => simp [hget, Option.getD] at this + | some v => + simp [hget, Option.getD] at this; subst this + have hmem := List.mem_of_getElem? hget + simp [List.mem_map] at hmem + rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Ξ“.ofBool] at hb + -- Input cell 0 = Ξ“.start + have hin_cell0_ri : c_ri.input.cells 0 = Ξ“.start := by + rw [hin_cells_chain]; simp [Tape.init] + -- Input head bound for c_ri + -- c_ri.input goes through: unionPhase1Cfg.input β†’ move β†’ (h_rw moves) β†’ move β†’ move β†’ move + -- Each move adds at most 1, so total head ≀ initial + (1 + h_rw + 1 + 1 + 1) + -- But we need a tighter bound. Let's compute it through the reachesIn chain. + -- Actually, we just need c_ri.input.head for the rewind loop bound. + -- Let's compose: steps 1..4 give reachesIn (1 + h_rw + 1 + 1) from unionPhase1Cfg to c_ri + have hreach_to_ri : (unionTM tm₁ tmβ‚‚).reachesIn (1 + (h_rw + (1 + 1))) + (unionPhase1Cfg tm₁ tmβ‚‚ c₁) c_ri := + reachesIn_trans _ (.step hstep1 .zero) + (reachesIn_trans _ hreach_rw (.step hstep3 (.step hstep4 .zero))) + -- Input head bound: through all steps, head changes by at most 1 per step + -- total steps so far = 1 + h_rw + 2, so head ≀ initial + (1 + h_rw + 2) + -- unionPhase1Cfg.input.head = c₁.input.head + -- But we need a precise bound. Let's just track c_ri.input.head. + -- Actually for rewind_input_loop we need h_ri = c_ri.input.head and the + -- total t_tr ≀ c₁.output.head + c₁.input.head + 7 + -- We don't need a tight head bound; we just use the loop count. + -- Step 5: Rewind input (h_ri steps) + set h_ri := c_ri.input.head with hh_ri_def + obtain ⟨c_ri0, hreach_ri, hst_ri0, hhead_ri0, hcells_ri0, hout_ri0⟩ := + rewind_input_loop tm₁ tmβ‚‚ h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri hout_ri + -- Step 6: rewindIn at head 0 β†’ setup2 (1 step) + have hread_start_ri : c_ri0.input.read = Ξ“.start := by + rw [Tape.read, hhead_ri0, hcells_ri0, hin_cells_chain]; simp [Tape.init] + have hstep6 := step_rewindIn_start_cfg tm₁ tmβ‚‚ hst_ri0 hread_start_ri + set c_s2 : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inl UnionPhase.setup2), + input := c_ri0.input.move Dir3.right, + work := fun i => + ((c_ri0.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move (idleDir (c_ri0.work i).read), + output := (c_ri0.output.write Ξ“w.blank.toΞ“).move (idleDir c_ri0.output.read) } + with hc_s2_def + -- Step 7: setup2 β†’ Phase 2 start (1 step) + have hstep7 := step_setup2_cfg tm₁ tmβ‚‚ + (show c_s2.state = Sum.inr (Sum.inl UnionPhase.setup2) from rfl) + set c_mid : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q) := + { state := Sum.inr (Sum.inr tmβ‚‚.qstart), + input := c_s2.input.move (moveLeftDir c_s2.input.read), + work := fun i => ((c_s2.work i).write (Ξ“w.blank : Ξ“w).toΞ“).move + (if i.val ≀ n₁ then idleDir (c_s2.work i).read else moveLeftDir (c_s2.work i).read), + output := (c_s2.output.write Ξ“w.blank.toΞ“).move (moveLeftDir c_s2.output.read) } + with hc_mid_def + -- Now prove all properties of c_mid. + -- c_mid.state + have hst_mid : c_mid.state = Sum.inr (Sum.inr tmβ‚‚.qstart) := rfl + -- c_mid.input = Tape.init (x.map Ξ“.ofBool) + -- c_mid.input = c_s2.input.move (moveLeftDir c_s2.input.read) + -- c_s2.input = c_ri0.input.move Dir3.right + -- c_ri0.input.head = 0, so moving right gives head = 1 + -- c_s2.input.head = 1, c_s2.input.cells = c_ri0.input.cells (move preserves) + -- c_s2.input.read = cells[1] which is from Tape.init, not start + -- moveLeftDir(non-start) = left, so head goes from 1 to 0 + -- c_mid.input = { head := 0, cells := Tape.init cells } = Tape.init (x.map Ξ“.ofBool) + have hcells_ri0_eq : c_ri0.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + rw [hcells_ri0, hin_cells_chain] + have hin_mid : c_mid.input = Tape.init (x.map Ξ“.ofBool) := by + -- c_mid.input.cells = Tape.init cells + have h2 : c_mid.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + show (c_s2.input.move _).cells = _ + rw [Tape.move_cells]; show (c_ri0.input.move Dir3.right).cells = _ + rw [Tape.move_cells]; exact hcells_ri0_eq + -- c_s2.input = c_ri0.input.move Dir3.right, head = 1 + have hs2_head : c_s2.input.head = 1 := by + show (c_ri0.input.move Dir3.right).head = 1 + simp [Tape.move, hhead_ri0] + have hs2_cells : c_s2.input.cells = c_ri0.input.cells := Tape.move_cells _ _ + -- c_s2.input.read β‰  Ξ“.start (cells[1] is from Tape.init, not start) + have hs2_read_ne : c_s2.input.read β‰  Ξ“.start := by + rw [Tape.read, hs2_head, hs2_cells, hcells_ri0] + exact hin_nostart_ri 1 (by omega) + -- c_mid.input.head = 0 (moveLeftDir of non-start = left, from head 1 β†’ 0) + have h1 : c_mid.input.head = 0 := by + show (c_s2.input.move (moveLeftDir c_s2.input.read)).head = 0 + rw [moveLeftDir, ite_eq_right hs2_read_ne]; simp [Tape.move, hs2_head] + -- Combine + have hcfg : βˆ€ (a b : Tape), a.head = b.head β†’ a.cells = b.cells β†’ a = b := by + intros a b hh hc; cases a; cases b; simp only [Tape.mk.injEq] at *; exact ⟨hh, hc⟩ + exact hcfg _ _ (by rw [h1]; rfl) h2 + -- c_mid.output = Tape.init [] + -- c_mid.output = (c_s2.output.write blank).move (moveLeftDir c_s2.output.read) + -- c_s2.output = (c_ri0.output.write blank).move (idleDir c_ri0.output.read) + -- c_ri0.output = unionIdleTape + -- c_s2.output = unionIdleTape (write blank + move idle on unionIdleTape) + -- c_mid.output = (unionIdleTape.write blank).move (moveLeftDir unionIdleTape.read) = Tape.init [] + have hout_s2 : c_s2.output = unionIdleTape := by + show (c_ri0.output.write Ξ“w.blank.toΞ“).move (idleDir c_ri0.output.read) = unionIdleTape + rw [hout_ri0]; exact idleTape_step_idle + have hout_mid : c_mid.output = Tape.init [] := by + show (c_s2.output.write Ξ“w.blank.toΞ“).move (moveLeftDir c_s2.output.read) = Tape.init [] + rw [hout_s2]; exact idleTape_moveLeft + -- Phase 2 work tapes = Tape.init [] + -- Strategy: show work tapes at > n₁ indices stay unionIdleTape through each phase, + -- then setup2 sends unionIdleTape to Tape.init []. + -- Step 1: c_rw.work at > n₁ = unionIdleTape (from phase1_halted step) + have hwork_rw_idle : βˆ€ (j : Fin nβ‚‚), + c_rw.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j + have hstateq : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep' := phase2_work_step_idle tm₁ tmβ‚‚ hstep1 + (Or.inl ⟨tm₁.qhalt, hstateq⟩) (i := ⟨n₁ + 1 + j.val, by omega⟩) + (by omega : n₁ + 1 + j.val > n₁) + rw [hstep'] + have hp1 : (unionPhase1Cfg tm₁ tmβ‚‚ c₁).work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + simp [unionPhase1Cfg, show Β¬(n₁ + 1 + j.val < n₁) from by omega, + show Β¬(n₁ + 1 + j.val = n₁) from by omega] + rw [hp1]; exact idleTape_step_idle + -- Step 2: Through rewind_fakeOut (hreach_rw), work tapes > n₁ stay unionIdleTape + have hwork_at0_idle : βˆ€ (j : Fin nβ‚‚), + c_at0.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j; exact hwork_at0 ⟨n₁ + 1 + j.val, by omega⟩ + (show n₁ + 1 + j.val > n₁ by omega) (hwork_rw_idle j) + -- Step 3 (rewindOutβ†’checkResult): c_cr.work at > n₁ = unionIdleTape + have hwork_cr_idle : βˆ€ (j : Fin nβ‚‚), + c_cr.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j + show ((c_at0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move + (if (n₁ + 1 + j.val) = n₁ then _ else _) = _ + rw [ite_eq_right (show n₁ + 1 + j.val β‰  n₁ from by omega), hwork_at0_idle j] + exact idleTape_step_idle + -- Step 4 (checkResultβ†’rewindIn): c_ri.work at > n₁ = unionIdleTape + have hwork_ri_idle : βˆ€ (j : Fin nβ‚‚), + c_ri.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j + show ((c_cr.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ + rw [hwork_cr_idle j]; exact idleTape_step_idle + -- Step 5: Through rewind_input (hreach_ri), work tapes > n₁ stay unionIdleTape + have hwork_ri0_idle : βˆ€ (j : Fin nβ‚‚), + c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j + obtain ⟨c_ri0', hreach', hidle'⟩ := rewind_input_work_idle tm₁ tmβ‚‚ + (show n₁ + 1 + j.val > n₁ from by omega) + h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri (hwork_ri_idle j) + have hdet := TM.reachesIn_right_unique hreach_ri hreach' + rw [hdet]; exact hidle' + -- Step 6 (rewindInβ†’setup2): c_s2.work at > n₁ = unionIdleTape + have hwork_s2_idle : βˆ€ (j : Fin nβ‚‚), + c_s2.work ⟨n₁ + 1 + j.val, by omega⟩ = unionIdleTape := by + intro j + show ((c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ + rw [hwork_ri0_idle j]; exact idleTape_step_idle + -- Step 7 (setup2β†’phase2_start): c_mid.work at > n₁ = Tape.init [] + have hwork_mid : βˆ€ (j : Fin nβ‚‚), + c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = Tape.init [] := by + intro j + show ((c_s2.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move + (if (n₁ + 1 + j.val) ≀ n₁ then _ else _) = _ + rw [ite_eq_right (show Β¬(n₁ + 1 + j.val ≀ n₁) from by omega), hwork_s2_idle j] + exact idleTape_moveLeft + -- Compose all reachesIn steps + have hreach_total : (unionTM tm₁ tmβ‚‚).reachesIn + (1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1))) + (unionPhase1Cfg tm₁ tmβ‚‚ c₁) c_mid := + reachesIn_trans _ hreach_to_ri + (reachesIn_trans _ hreach_ri (.step hstep6 (.step hstep7 .zero))) + -- Time bound + -- h_rw ≀ c₁.output.head + 1 (hfo_head_bound) + -- h_ri = c_ri.input.head ≀ c₁.input.head + 1 (input moves by idleDir, which is stay for head β‰₯ 1) + -- Need: 1 + (h_rw + 2) + (h_ri + 2) = h_rw + h_ri + 5 ≀ c₁.output.head + c₁.input.head + 7 + -- Suffices: h_rw + h_ri ≀ c₁.output.head + c₁.input.head + 2, which holds. + -- Prove h_ri ≀ c₁.input.head + 1: + have hri_bound : h_ri ≀ c₁.input.head + 1 := + unionReject_rewindInput_head_bound tm₁ tmβ‚‚ x c₁ c_rw c_at0 h_rw + hhalt hinput_cells hstep1 hreach_rw hinp_at0 + have htime : 1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)) ≀ c₁.output.head + c₁.input.head + 7 := by + omega + refine ⟨1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)), c_mid, ?_, hst_mid, hin_mid, hwork_mid, + hout_mid, htime⟩ + exact hreach_total + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: one-step correspondence +-- ════════════════════════════════════════════════════════════════════════ + +/-- Phase 2 compatibility: a union machine config agrees with a tmβ‚‚ config + on the active components (state, input, Phase 2 work tapes, output). -/ +structure UnionPhase2Compat (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + (c_u : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)) + (cβ‚‚ : Cfg nβ‚‚ tmβ‚‚.Q) : Prop where + state_eq : c_u.state = Sum.inr (Sum.inr cβ‚‚.state) + input_eq : c_u.input = cβ‚‚.input + work_eq : βˆ€ j : Fin nβ‚‚, c_u.work ⟨n₁ + 1 + j.val, by omega⟩ = cβ‚‚.work j + output_eq : c_u.output = cβ‚‚.output + +/-- One step of the union machine on a Phase 2 compatible config preserves + compatibility. -/ +private theorem phase2_step_corr (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {cβ‚‚ cβ‚‚' : Cfg nβ‚‚ tmβ‚‚.Q} (hstep : tmβ‚‚.step cβ‚‚ = some cβ‚‚') + {c_u : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hcompat : UnionPhase2Compat tm₁ tmβ‚‚ c_u cβ‚‚) : + βˆƒ c_u', (unionTM tm₁ tmβ‚‚).step c_u = some c_u' ∧ + UnionPhase2Compat tm₁ tmβ‚‚ c_u' cβ‚‚' := by + have hne := state_ne_qhalt_of_step hstep + -- Extract cβ‚‚' from tmβ‚‚.step + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep; subst hstep + -- c_u is not halted in the union machine + have hne_u : c_u.state β‰  (unionTM tm₁ tmβ‚‚).qhalt := by + rw [hcompat.state_eq, unionTM_qhalt]; exact fun h => hne (Sum.inr.inj (Sum.inr.inj h)) + -- Unfold the union step; `split` reduces the halting ite (the stored + -- decidability instance blocks `simp`/`rw [ite_eq_right]` here), then pin the + -- explicit step-result config as the existential witness via `rfl`. + simp only [step] + split + Β· exact absurd β€Ή_β€Ί hne_u + refine ⟨_, rfl, ?_⟩ + -- Rewrite reads using UnionPhase2Compat + have hwork_reads : phase2WorkReads (fun i => (c_u.work i).read) = + fun j => (cβ‚‚.work j).read := by + ext ⟨j, hj⟩; simp only [phase2WorkReads]; exact congrArg Tape.read (hcompat.work_eq ⟨j, hj⟩) + -- Construct UnionPhase2Compat (state_eq, input_eq, output_eq all close; + -- work_eq needs dif reduction) + refine ⟨?_, ?_, fun ⟨j, hj⟩ => ?_, ?_⟩ <;> dsimp only [] <;> rw [hcompat.state_eq] <;> + simp only [unionTM_delta_inr_inr tm₁ tmβ‚‚ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] + have hgt : Β¬((n₁ + 1 + j) ≀ n₁) := by omega + rw [dite_eq_right hgt] + have hfin : βˆ€ (p : n₁ + 1 + j - (n₁ + 1) < nβ‚‚), + (⟨n₁ + 1 + j - (n₁ + 1), p⟩ : Fin nβ‚‚) = ⟨j, hj⟩ := by + intro p; apply Fin.ext; show n₁ + 1 + j - (n₁ + 1) = j; omega + simp only [hfin, hcompat.work_eq ⟨j, hj⟩, dite_eq_right hgt] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2 simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Multi-step Phase 2 simulation via step correspondence. -/ +private theorem phase2_steps (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) + {t : β„•} {cβ‚‚_start cβ‚‚_end : Cfg nβ‚‚ tmβ‚‚.Q} + (hreach : tmβ‚‚.reachesIn t cβ‚‚_start cβ‚‚_end) + {c_start : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hcompat : UnionPhase2Compat tm₁ tmβ‚‚ c_start cβ‚‚_start) : + βˆƒ c_end, (unionTM tm₁ tmβ‚‚).reachesIn t c_start c_end ∧ + UnionPhase2Compat tm₁ tmβ‚‚ c_end cβ‚‚_end := by + induction hreach generalizing c_start with + | zero => exact ⟨c_start, .zero, hcompat⟩ + | step hstep _ ih => + obtain ⟨c_mid, hstep_u, hcompat_mid⟩ := phase2_step_corr tm₁ tmβ‚‚ hstep hcompat + obtain ⟨c_end, hreach_u, hcompat_end⟩ := ih hcompat_mid + exact ⟨c_end, .step hstep_u hreach_u, hcompat_end⟩ + +/-- **Phase 2 simulation**: if `tmβ‚‚` reaches `cβ‚‚` from `initCfg x` in + `tβ‚‚` steps, and the starting union config is compatible with `initCfg x`, + then the union machine reaches a config compatible with `cβ‚‚` in `tβ‚‚` steps. -/ +theorem unionTM_phase2_simulation (tm₁ : TM n₁) (tmβ‚‚ : TM nβ‚‚) (x : List Bool) + {tβ‚‚ : β„•} {cβ‚‚ : Cfg nβ‚‚ tmβ‚‚.Q} + (hreach : tmβ‚‚.reachesIn tβ‚‚ (tmβ‚‚.initCfg x) cβ‚‚) + {c_start : Cfg (n₁ + 1 + nβ‚‚) (UnionQ tm₁.Q tmβ‚‚.Q)} + (hss : c_start.state = Sum.inr (Sum.inr tmβ‚‚.qstart)) + (hsi : c_start.input = Tape.init (x.map Ξ“.ofBool)) + (hsw : βˆ€ j : Fin nβ‚‚, c_start.work ⟨n₁ + 1 + j.val, by omega⟩ = Tape.init []) + (hso : c_start.output = Tape.init []) : + βˆƒ c_end, (unionTM tm₁ tmβ‚‚).reachesIn tβ‚‚ c_start c_end ∧ + c_end.state = Sum.inr (Sum.inr cβ‚‚.state) ∧ + c_end.output = cβ‚‚.output := by + have hcompat : UnionPhase2Compat tm₁ tmβ‚‚ c_start (tmβ‚‚.initCfg x) := + ⟨by rw [hss], hsi, hsw, hso⟩ + obtain ⟨c_end, hreach_u, hcompat_end⟩ := phase2_steps tm₁ tmβ‚‚ hreach hcompat + exact ⟨c_end, hreach_u, hcompat_end.state_eq, hcompat_end.output_eq⟩ + +-- ════════════════════════════════════════════════════════════════════════ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute.lean new file mode 100644 index 0000000000..8ffee5c8e3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Internal + +/-! +# Retargeted-input computation seams + +`TM.retargetInputStarted` runs a source machine on a virtual input held by its +last work tape when every participating head is already parked at cell `1`. +It absorbs the source machine's compulsory first transition from `β–·`, making +the wrapper suitable as a later phase of `TM.seqTM`. + +The degenerate `qstart = qhalt` case is included: such a source computes only +the empty string, and the wrapper halts immediately without requiring a +positive advertised time bound. + +## Main results + +- `TM.retargetInputStarted_computesVirtual_exact` β€” exact saved-start time +- `TM.retargetInputStarted_computesVirtual` β€” same-time virtual computation +- `TM.retargetInputStarted_decidesVirtual` β€” same-time virtual decision +- `TM.retargetInputStarted_hoareTime` β€” Hoare form for phase composition +- `TM.placeWorkTM_retargetInputStarted_computesVirtual` β€” placed stable-frame seam +- `TM.placeWorkTM_retargetInputStarted_decidesVirtual` β€” placed decision seam +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : β„•} + +/-- The started wrapper and ordinary retargeted-input machine have identical +step functions. -/ +theorem retargetInputStarted_step_eq (M : TM k) (c : Cfg (k + 1) M.Q) : + (retargetInputStarted M).step c = (retargetInput M).step c := + retargetInputStarted_step_eq_internal M c + +/-- A run of `retargetInput M` is also a run of its started wrapper. -/ +theorem retargetInputStarted_reachesIn_of_retargetInput (M : TM k) + {t : β„•} {c c' : Cfg (k + 1) M.Q} + (hreach : (retargetInput M).reachesIn t c c') : + (retargetInputStarted M).reachesIn t c c' := + retargetInputStarted_reachesIn_of_retargetInput_internal M hreach + +/-- For a non-halted source start state, the wrapper entry configuration is +exactly the retargeted embedding of the source's post-sentinel configuration. -/ +theorem retargetInputStartedCfg_eq_retargetWrap (M : TM k) + (y : List Bool) (realInput : Tape) (hne : M.qstart β‰  M.qhalt) : + retargetInputStartedCfg M y realInput = + retargetWrap M realInput (startedCfg M y hne) := + retargetInputStartedCfg_eq_retargetWrap_internal M y realInput hne + +/-- Exact virtual-input computation seam. A nondegenerate source run saves its +first transition; an initially halted source uses zero transitions. -/ +theorem retargetInputStarted_computesVirtual_exact (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t + (if M.qstart = M.qhalt then 0 else 1) ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + c'.output.HasOutput (f y) := + retargetInputStarted_computesVirtual_exact_internal M hcomp y realInput + +/-- The started virtual-input wrapper computes within the source's advertised +time bound. -/ +theorem retargetInputStarted_computesVirtual (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + c'.output.HasOutput (f y) := + retargetInputStarted_computesVirtual_internal M hcomp y realInput + +/-- The started virtual-input wrapper retains a source decider's two verdict +implications within the source's advertised time bound. -/ +theorem retargetInputStarted_decidesVirtual (M : TM k) + {L : Language} {T : β„• β†’ β„•} + (hdec : M.DecidesInTime L T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + (y ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) := + retargetInputStarted_decidesVirtual_internal M hdec y realInput + +/-- Hoare form of the same-time virtual-input seam. The real input is ignored; +the work and output tapes have the canonical already-started shapes. -/ +theorem retargetInputStarted_hoareTime (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) : + (retargetInputStarted M).HoareTime + (fun inp work out => + work = (retargetInputStartedCfg M y inp).work ∧ + out = (Tape.init []).move Dir3.right) + (fun _inp _work out => out.HasOutput (f y)) + (T y.length) := + retargetInputStarted_hoareTime_internal M hcomp y + +/-- Placed virtual-input computation with an exact preserved prefix/suffix +frame. The middle block contains the source scratch tapes and virtual input. +Every extra tape satisfying the standard start invariant at a positive head +position is unchanged in the final `placeWorkCfg` endpoint. -/ +theorem placeWorkTM_retargetInputStarted_computesVirtual (M : TM k) + (pre post : β„•) (extras : Fin (pre + (k + 1) + post) β†’ Tape) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + 1 ≀ (extras i).head) : + βˆƒ (c' : Cfg (k + 1) M.Q) + (C' : Cfg (pre + (k + 1) + post) + (placeWorkTM pre post (retargetInputStarted M)).Q) (t : β„•), + t ≀ T y.length ∧ + (placeWorkTM pre post (retargetInputStarted M)).reachesIn t + (placeWorkCfg (retargetInputStarted M) pre post extras + (retargetInputStartedCfg M y realInput)) C' ∧ + C' = placeWorkCfg (retargetInputStarted M) pre post extras c' ∧ + (placeWorkTM pre post (retargetInputStarted M)).halted C' ∧ + C'.output.HasOutput (f y) := + placeWorkTM_retargetInputStarted_computesVirtual_internal M pre post extras + hcomp y realInput hinv hhead + +/-- Placed virtual-input decision with an exact preserved prefix/suffix frame. -/ +theorem placeWorkTM_retargetInputStarted_decidesVirtual (M : TM k) + (pre post : β„•) (extras : Fin (pre + (k + 1) + post) β†’ Tape) + {L : Language} {T : β„• β†’ β„•} + (hdec : M.DecidesInTime L T) (y : List Bool) (realInput : Tape) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + 1 ≀ (extras i).head) : + βˆƒ (c' : Cfg (k + 1) M.Q) + (C' : Cfg (pre + (k + 1) + post) + (placeWorkTM pre post (retargetInputStarted M)).Q) (t : β„•), + t ≀ T y.length ∧ + (placeWorkTM pre post (retargetInputStarted M)).reachesIn t + (placeWorkCfg (retargetInputStarted M) pre post extras + (retargetInputStartedCfg M y realInput)) C' ∧ + C' = placeWorkCfg (retargetInputStarted M) pre post extras c' ∧ + (placeWorkTM pre post (retargetInputStarted M)).halted C' ∧ + (y ∈ L β†’ C'.output.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ C'.output.cells 1 = Ξ“.zero) := + placeWorkTM_retargetInputStarted_decidesVirtual_internal M pre post extras + hdec y realInput hinv hhead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Defs.lean new file mode 100644 index 0000000000..899917810c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Defs.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Retargeted-input computation seams + +An ordinary machine begins with every head on `β–·`; its first transition moves +all heads right and may also change the control state. A phase-composed machine +usually enters its next phase with tapes already parked at cell `1`. This file +defines an executable wrapper that resumes a machine after that compulsory +sentinel transition while reading its input from the last work tape. + +## Main definitions + +- `TM.retargetInputStartState` β€” control state after the sentinel transition +- `TM.retargetInputStarted` β€” virtual-input machine entered with heads at cell `1` +- `TM.retargetInputStartedCfg` β€” canonical entry configuration for a virtual input +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : β„•} + +/-- The source control state produced by its first transition from the all-`β–·` +initial head positions. -/ +def retargetInputStartState (M : TM k) : M.Q := + (M.Ξ΄ M.qstart Ξ“.start (fun _ => Ξ“.start) Ξ“.start).1 + +/-- Read the source input from work tape `k`, starting from the already-parked +post-sentinel configuration. If the source starts halted, the wrapper also +starts halted; otherwise its start state is `retargetInputStartState M`. + +The transition function and halt state are exactly those of `retargetInput M`. -/ +def retargetInputStarted (M : TM k) : TM (k + 1) where + Q := M.Q + qstart := if M.qstart = M.qhalt then M.qhalt else retargetInputStartState M + qhalt := M.qhalt + Ξ΄ := (retargetInput M).Ξ΄ + Ξ΄_right_of_start := (retargetInput M).Ξ΄_right_of_start + +/-- Canonical phase-entry configuration for `retargetInputStarted M`: virtual +input `y` is on the last work tape at head `1`; source work tapes and the real +output are parked and blank. The ignored real input tape is arbitrary. -/ +def retargetInputStartedCfg (M : TM k) (y : List Bool) (realInput : Tape) : + Cfg (k + 1) (retargetInputStarted M).Q where + state := (retargetInputStarted M).qstart + input := realInput + work := fun i => + if i.val < k then (Tape.init []).move Dir3.right + else (Tape.init (y.map Ξ“.ofBool)).move Dir3.right + output := (Tape.init []).move Dir3.right + +@[simp] theorem retargetInputStartedCfg_state (M : TM k) (y : List Bool) + (realInput : Tape) : + (retargetInputStartedCfg M y realInput).state = (retargetInputStarted M).qstart := rfl + +@[simp] theorem retargetInputStartedCfg_input (M : TM k) (y : List Bool) + (realInput : Tape) : + (retargetInputStartedCfg M y realInput).input = realInput := rfl + +@[simp] theorem retargetInputStartedCfg_output (M : TM k) (y : List Bool) + (realInput : Tape) : + (retargetInputStartedCfg M y realInput).output = + (Tape.init []).move Dir3.right := rfl + +theorem retargetInputStartedCfg_work_lt (M : TM k) (y : List Bool) + (realInput : Tape) (i : Fin (k + 1)) (h : i.val < k) : + (retargetInputStartedCfg M y realInput).work i = + (Tape.init []).move Dir3.right := by + simp [retargetInputStartedCfg, h] + +@[simp] theorem retargetInputStartedCfg_work_last (M : TM k) (y : List Bool) + (realInput : Tape) : + (retargetInputStartedCfg M y realInput).work ⟨k, by omega⟩ = + (Tape.init (y.map Ξ“.ofBool)).move Dir3.right := by + simp [retargetInputStartedCfg] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Internal.lean new file mode 100644 index 0000000000..19d1caeb07 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/RetargetCompute/Internal.lean @@ -0,0 +1,285 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Retarget +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Internal + +/-! +# Retargeted-input computation seam internals + +This file proves that `TM.retargetInputStarted` resumes an ordinary source run +after its compulsory sentinel transition. The already-halted case is handled +separately: such a machine can compute only the empty output, and the wrapper +therefore halts immediately on its parked blank output tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : β„•} + +/-- The started wrapper has exactly the same transition behavior as the +ordinary retargeted-input machine. -/ +theorem retargetInputStarted_step_eq_internal (M : TM k) + (c : Cfg (k + 1) M.Q) : + (retargetInputStarted M).step c = (retargetInput M).step c := by + rfl + +/-- Any bounded run of the ordinary retargeted-input machine is also a run of +the started wrapper. -/ +theorem retargetInputStarted_reachesIn_of_retargetInput_internal (M : TM k) + {t : β„•} {c c' : Cfg (k + 1) M.Q} + (hreach : (retargetInput M).reachesIn t c c') : + (retargetInputStarted M).reachesIn t c c' := by + apply reachesIn_map (tm := retargetInput M) (tm' := retargetInputStarted M) + (fun c => c) _ hreach + intro cβ‚€ c₁ hstep + change (retargetInputStarted M).step cβ‚€ = some c₁ + exact (retargetInputStarted_step_eq_internal M cβ‚€).trans hstep + +/-- In the nondegenerate case, the wrapper start state is exactly the source +state after its first transition from the all-sentinel configuration. -/ +theorem retargetInputStarted_qstart_eq_startedCfg_state_internal (M : TM k) + (y : List Bool) (hne : M.qstart β‰  M.qhalt) : + (retargetInputStarted M).qstart = (startedCfg M y hne).state := by + simp [retargetInputStarted, retargetInputStartState, startedCfg, TM.step, hne, + Tape.read, Tape.init] + +/-- In the nondegenerate case, the canonical wrapper entry is the ordinary +`retargetWrap` of the source's exact post-sentinel configuration. -/ +theorem retargetInputStartedCfg_eq_retargetWrap_internal (M : TM k) + (y : List Bool) (realInput : Tape) (hne : M.qstart β‰  M.qhalt) : + retargetInputStartedCfg M y realInput = + retargetWrap M realInput (startedCfg M y hne) := by + refine Cfg.ext ?_ rfl ?_ ?_ + Β· exact retargetInputStarted_qstart_eq_startedCfg_state_internal M y hne + Β· funext i + by_cases hi : i.val < k + Β· rw [retargetInputStartedCfg_work_lt M y realInput i hi, + retargetWrap_work_lt M realInput _ i hi] + exact (startedCfg_work_eq_init_move_right M y hne ⟨i.val, hi⟩).symm + Β· have hval : i.val = k := by omega + have hilast : i = ⟨k, by omega⟩ := by + apply Fin.ext + exact hval + rw [hilast] + rw [retargetInputStartedCfg_work_last, retargetWrap_work_last, + startedCfg_input_eq] + Β· rw [retargetInputStartedCfg_output, retargetWrap_output, + startedCfg_output_eq_init_move_right] + +/-- An initially halted machine that computes a function can only compute the +empty string. -/ +private theorem computes_eq_nil_of_qstart_eq_qhalt (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (heq : M.qstart = M.qhalt) (y : List Bool) : + f y = [] := by + obtain ⟨c', t, _ht, hreach, _hhalt, hout⟩ := hcomp y + have hinit : M.halted (M.initCfg y) := by + simpa [TM.halted, Cfg.isHalted] using heq + have ht0 : t = 0 := by + have hle := M.reachesIn_le_halt hreach + (TM.reachesIn.zero : M.reachesIn 0 (M.initCfg y) (M.initCfg y)) hinit + omega + subst t + cases hreach + cases hy : f y with + | nil => rfl + | cons bit bits => + have hcell := hout.1 0 (by simp [hy]) + simp [hy, Tape.init] at hcell + exact (False.elim ((Ξ“.ofBool_ne_blank bit) hcell.symm)) + +/-- Exact virtual-input computation seam. The result time omits the source's +first transition when that transition exists; an initially halted source uses +zero steps. -/ +theorem retargetInputStarted_computesVirtual_exact_internal (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t + (if M.qstart = M.qhalt then 0 else 1) ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + c'.output.HasOutput (f y) := by + by_cases heq : M.qstart = M.qhalt + Β· have hfy := computes_eq_nil_of_qstart_eq_qhalt M hcomp heq y + refine ⟨retargetInputStartedCfg M y realInput, 0, ?_, .zero, ?_, ?_⟩ + Β· simp [heq] + Β· show (retargetInputStarted M).qstart = (retargetInputStarted M).qhalt + simp [retargetInputStarted, heq] + Β· rw [hfy] + simp [Tape.HasOutput, Tape.init, Tape.move] + Β· obtain ⟨cM, t, ht, hreach, hhalt, hout⟩ := hcomp y + have ht_ne : t β‰  0 := by + intro ht0 + subst t + cases hreach + exact heq hhalt + obtain ⟨t', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ht_ne + cases hreach with + | step hstep hrest => + next cMid => + have hmid : cMid = startedCfg M y heq := by + have hs : some cMid = some (startedCfg M y heq) := by + rw [← hstep, step_initCfg_startedCfg M y heq] + exact Option.some.inj hs + subst cMid + have hinitIn : Tape.StartInvariant (M.initCfg y).input := + Tape.StartInvariant.init_ofBool y + have hinitWork : βˆ€ i, Tape.StartInvariant ((M.initCfg y).work i) := + fun _ => Tape.StartInvariant.init_nil + have hinitOut : Tape.StartInvariant (M.initCfg y).output := + Tape.StartInvariant.init_nil + obtain ⟨hinv, hworkInv, houtInv⟩ := Tape.StartInvariant.step M + (step_initCfg_startedCfg M y heq) hinitIn hinitWork hinitOut + obtain ⟨finalReal, hsim⟩ := retargetInput_reachesIn_of_reachesIn M hrest + hinv hworkInv houtInv realInput + let c' := retargetWrap M finalReal cM + have hsim' : (retargetInputStarted M).reachesIn t' + (retargetInputStartedCfg M y realInput) c' := by + rw [retargetInputStartedCfg_eq_retargetWrap_internal M y realInput heq] + exact retargetInputStarted_reachesIn_of_retargetInput_internal M hsim + refine ⟨c', t', ?_, hsim', ?_, ?_⟩ + Β· simp [heq] + omega + Β· show cM.state = M.qhalt + exact hhalt + Β· show cM.output.HasOutput (f y) + exact hout + +/-- Same-time form of the virtual-input computation seam. -/ +theorem retargetInputStarted_computesVirtual_internal (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + c'.output.HasOutput (f y) := by + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + retargetInputStarted_computesVirtual_exact_internal M hcomp y realInput + exact ⟨c', t, by omega, hreach, hhalt, hout⟩ + +/-- A decider run can be resumed on a virtual input with the same advertised +time bound while retaining both verdict implications. -/ +theorem retargetInputStarted_decidesVirtual_internal (M : TM k) + {L : Language} {T : β„• β†’ β„•} + (hdec : M.DecidesInTime L T) (y : List Bool) (realInput : Tape) : + βˆƒ (c' : Cfg (k + 1) M.Q) (t : β„•), + t ≀ T y.length ∧ + (retargetInputStarted M).reachesIn t + (retargetInputStartedCfg M y realInput) c' ∧ + (retargetInputStarted M).halted c' ∧ + (y ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) := by + obtain ⟨c', t, ht, hreach, hhalt, hyes, hno⟩ := + retargetInput_decidesVirtual_started M hdec y realInput + refine ⟨c', t, by omega, ?_, hhalt, hyes, hno⟩ + rw [retargetInputStartedCfg_eq_retargetWrap_internal M y realInput + (qstart_ne_qhalt_of_decidesInTime M hdec)] + exact retargetInputStarted_reachesIn_of_retargetInput_internal M hreach + +/-- Hoare form of the same-time virtual-input seam. -/ +theorem retargetInputStarted_hoareTime_internal (M : TM k) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) : + (retargetInputStarted M).HoareTime + (fun inp work out => + work = (retargetInputStartedCfg M y inp).work ∧ + out = (Tape.init []).move Dir3.right) + (fun _inp _work out => out.HasOutput (f y)) + (T y.length) := by + intro inp work out hpre + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + retargetInputStarted_computesVirtual_internal M hcomp y inp + have hstart : + ({ state := (retargetInputStarted M).qstart, input := inp, + work := work, output := out } : Cfg (k + 1) M.Q) = + retargetInputStartedCfg M y inp := by + exact Cfg.ext rfl rfl hpre.1 hpre.2 + refine ⟨c', t, ht, ?_, hhalt, hout⟩ + exact hstart.symm β–Έ hreach + +/-- Combined placement seam with an exact preserved physical frame. The source +work tapes and virtual input occupy the placed middle block; all prefix and +suffix tapes are returned unchanged. -/ +theorem placeWorkTM_retargetInputStarted_computesVirtual_internal (M : TM k) + (pre post : β„•) (extras : Fin (pre + (k + 1) + post) β†’ Tape) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : M.ComputesInTime f T) (y : List Bool) (realInput : Tape) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + 1 ≀ (extras i).head) : + βˆƒ (c' : Cfg (k + 1) M.Q) + (C' : Cfg (pre + (k + 1) + post) + (placeWorkTM pre post (retargetInputStarted M)).Q) (t : β„•), + t ≀ T y.length ∧ + (placeWorkTM pre post (retargetInputStarted M)).reachesIn t + (placeWorkCfg (retargetInputStarted M) pre post extras + (retargetInputStartedCfg M y realInput)) C' ∧ + C' = placeWorkCfg (retargetInputStarted M) pre post extras c' ∧ + (placeWorkTM pre post (retargetInputStarted M)).halted C' ∧ + C'.output.HasOutput (f y) := by + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + retargetInputStarted_computesVirtual_internal M hcomp y realInput + let C' := placeWorkCfg (retargetInputStarted M) pre post extras c' + refine ⟨c', C', t, ht, ?_, rfl, ?_, ?_⟩ + Β· apply placeWorkTM_reachesIn_placeWorkCfg_stable_internal _ pre post extras hreach + intro i hi + show (extras i).cells (extras i).head β‰  Ξ“.start + exact (hinv i hi).2 (extras i).head (hhead i hi) + Β· show c'.state = (retargetInputStarted M).qhalt + exact hhalt + Β· show c'.output.HasOutput (f y) + exact hout + +/-- Placed virtual-input decision with an exact preserved physical frame. -/ +theorem placeWorkTM_retargetInputStarted_decidesVirtual_internal (M : TM k) + (pre post : β„•) (extras : Fin (pre + (k + 1) + post) β†’ Tape) + {L : Language} {T : β„• β†’ β„•} + (hdec : M.DecidesInTime L T) (y : List Bool) (realInput : Tape) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre (k + 1) i β†’ + 1 ≀ (extras i).head) : + βˆƒ (c' : Cfg (k + 1) M.Q) + (C' : Cfg (pre + (k + 1) + post) + (placeWorkTM pre post (retargetInputStarted M)).Q) (t : β„•), + t ≀ T y.length ∧ + (placeWorkTM pre post (retargetInputStarted M)).reachesIn t + (placeWorkCfg (retargetInputStarted M) pre post extras + (retargetInputStartedCfg M y realInput)) C' ∧ + C' = placeWorkCfg (retargetInputStarted M) pre post extras c' ∧ + (placeWorkTM pre post (retargetInputStarted M)).halted C' ∧ + (y ∈ L β†’ C'.output.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ C'.output.cells 1 = Ξ“.zero) := by + obtain ⟨c', t, ht, hreach, hhalt, hyes, hno⟩ := + retargetInputStarted_decidesVirtual_internal M hdec y realInput + let C' := placeWorkCfg (retargetInputStarted M) pre post extras c' + refine ⟨c', C', t, ht, ?_, rfl, ?_, ?_, ?_⟩ + Β· apply placeWorkTM_reachesIn_placeWorkCfg_stable_internal _ pre post extras hreach + intro i hi + show (extras i).cells (extras i).head β‰  Ξ“.start + exact (hinv i hi).2 (extras i).head (hhead i hi) + Β· show c'.state = (retargetInputStarted M).qhalt + exact hhalt + Β· show y ∈ L β†’ c'.output.cells 1 = Ξ“.one + exact hyes + Β· show y βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero + exact hno + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch.lean new file mode 100644 index 0000000000..356b21cdcd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Internal + +/-! +# Direct work-symbol branch combinator + +`TM.branchWorkBlankTM idx onBlank onNonblank` reads one work-tape symbol and +runs `onBlank` exactly on blank, or `onNonblank` on any other symbol. The +dispatcher performs one framed, tape-preserving step. It never writes a test +result to the output tape, and branch simulation adds no trailing seam step. + +The preservation results require every head to be off the left marker. This +is the necessary boundary condition imposed by the one-sided tape model: +heads reading `β–·` must move right. + +## Main results + +- `TM.branchWorkBlankTM_reachesIn_blank_frame` and its nonblank counterpart + give exact selected-branch execution and literal tape frames. +- `TM.branchWorkBlankTM_hoareTime` composes two branch contracts with one + dispatch step. +- `TM.branchWorkBlankTM_hoareTimeSpace` preserves the maximum branch budget. +- `Tape.HasBinaryNat.read_eq_blank_iff` specializes blank dispatch to + canonical binary zero. +- `TM.IsTransducer.branchWorkBlankTM` preserves one-way output behavior. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Tape + +/-- A canonical little-endian natural reads blank exactly when its value is +zero. Consequently the direct blank/nonblank work branch is a canonical +zero/nonzero branch on `HasBinaryNat` tapes. -/ +theorem HasBinaryNat.read_eq_blank_iff {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : + t.read = Ξ“.blank ↔ value = 0 := + h.read_eq_blank_iff_internal + +end Tape + +namespace TM + +variable {n : β„•} + +/-- Blank dispatch takes one step, selects the blank branch, and preserves +all tapes exactly. -/ +theorem branchWorkBlankTM_dispatch_blank + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hblank : (work idx).read = Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkBlankTM idx onBlank onNonblank).step + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } = + some + { state := workBranchBlankState onBlank onNonblank onBlank.qstart + input := inp + work := work + output := out } := by + simpa [workBranchBlankWrap] using + branchWorkBlankTM_dispatch_blank_internal idx onBlank onNonblank + inp work out hblank hinp hwork hout + +/-- Nonblank dispatch takes one step, selects the nonblank branch, and +preserves all tapes exactly. -/ +theorem branchWorkBlankTM_dispatch_nonblank + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hnonblank : (work idx).read β‰  Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkBlankTM idx onBlank onNonblank).step + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } = + some + { state := workBranchNonblankState onBlank onNonblank + onNonblank.qstart + input := inp + work := work + output := out } := by + simpa [workBranchNonblankWrap] using + branchWorkBlankTM_dispatch_nonblank_internal idx onBlank onNonblank + inp work out hnonblank hinp hwork hout + +/-- Exact framed execution through the blank branch. The combined controller +uses one dispatch transition followed by the branch's exact `t` transitions. -/ +theorem branchWorkBlankTM_reachesIn_blank_frame + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onBlank.Q} + (hblank : (work idx).read = Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onBlank.reachesIn t + { state := onBlank.qstart, input := inp, work := work, output := out } c') + (hhalt : onBlank.halted c') : + βˆƒ C, + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkBlankTM idx onBlank onNonblank).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := + branchWorkBlankTM_reachesIn_blank_frame_internal idx onBlank onNonblank + inp work out hblank hinp hwork hout hreach hhalt + +/-- Exact framed execution through the nonblank branch. -/ +theorem branchWorkBlankTM_reachesIn_nonblank_frame + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onNonblank.Q} + (hnonblank : (work idx).read β‰  Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onNonblank.reachesIn t + { state := onNonblank.qstart, input := inp, work := work, output := out } c') + (hhalt : onNonblank.halted c') : + βˆƒ C, + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkBlankTM idx onBlank onNonblank).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := + branchWorkBlankTM_reachesIn_nonblank_frame_internal idx onBlank onNonblank + inp work out hnonblank hinp hwork hout hreach hhalt + +/-- Compose two time-bounded branch contracts. The precondition supplies the +off-marker frame and translates the initial read into the selected branch's +precondition. The postcondition records which branch contract completed. -/ +theorem branchWorkBlankTM_hoareTime + (idx : Fin n) (onBlank onNonblank : TM n) + {pre blankPre nonblankPre blankPost nonblankPost : TapePred n} + {blankTime nonblankTime : β„•} + (hframe : βˆ€ inp work out, pre inp work out β†’ + inp.read β‰  Ξ“.start ∧ (βˆ€ i, (work i).read β‰  Ξ“.start) ∧ + out.read β‰  Ξ“.start) + (hblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read = Ξ“.blank β†’ blankPre inp work out) + (hnonblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read β‰  Ξ“.blank β†’ nonblankPre inp work out) + (hblank : onBlank.HoareTime blankPre blankPost blankTime) + (hnonblank : onNonblank.HoareTime nonblankPre nonblankPost nonblankTime) : + (branchWorkBlankTM idx onBlank onNonblank).HoareTime pre + (fun inp work out => + blankPost inp work out ∨ nonblankPost inp work out) + (branchWorkBlankTime blankTime nonblankTime) := + branchWorkBlankTM_hoareTime_internal idx onBlank onNonblank hframe + hblankPre hnonblankPre hblank hnonblank + +/-- Compose two time-and-space branch contracts. Dispatch preserves the +starting tapes, so the all-reachable space bound is exactly the maximum of the +two branch budgets rather than an additional seam allowance. -/ +theorem branchWorkBlankTM_hoareTimeSpace + (idx : Fin n) (onBlank onNonblank : TM n) + {pre blankPre nonblankPre blankPost nonblankPost : TapePred n} + {blankTime nonblankTime inputLength blankSpace nonblankSpace : β„•} + (hframe : βˆ€ inp work out, pre inp work out β†’ + inp.read β‰  Ξ“.start ∧ (βˆ€ i, (work i).read β‰  Ξ“.start) ∧ + out.read β‰  Ξ“.start) + (hblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read = Ξ“.blank β†’ blankPre inp work out) + (hnonblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read β‰  Ξ“.blank β†’ nonblankPre inp work out) + (hblank : onBlank.HoareTimeSpace blankPre blankPost blankTime + inputLength blankSpace) + (hnonblank : onNonblank.HoareTimeSpace nonblankPre nonblankPost + nonblankTime inputLength nonblankSpace) : + (branchWorkBlankTM idx onBlank onNonblank).HoareTimeSpace pre + (fun inp work out => + blankPost inp work out ∨ nonblankPost inp work out) + (branchWorkBlankTime blankTime nonblankTime) inputLength + (max blankSpace nonblankSpace) := + branchWorkBlankTM_hoareTimeSpace_internal idx onBlank onNonblank hframe + hblankPre hnonblankPre hblank hnonblank + +/-- Direct work branching preserves one-way output when both selected +branches do. The dispatch step itself never moves the output head left. -/ +theorem IsTransducer.branchWorkBlankTM + {idx : Fin n} {onBlank onNonblank : TM n} + (hblank : onBlank.IsTransducer) + (hnonblank : onNonblank.IsTransducer) : + (branchWorkBlankTM idx onBlank onNonblank).IsTransducer := + hblank.branchWorkBlankTM_internal hnonblank + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Defs.lean new file mode 100644 index 0000000000..518c1fd494 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Defs.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Direct work-symbol branch combinator -- definitions + +`TM.branchWorkBlankTM idx onBlank onNonblank` inspects work tape `idx` once. +A blank selects `onBlank`; every other symbol selects `onNonblank`. The +dispatcher uses the ordinary read-back action on every tape and never uses the +output tape as control storage. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Finite driver states for direct work-symbol branching. -/ +inductive WorkBranchPhase where + | dispatch + | done + deriving DecidableEq + +/-- `WorkBranchPhase` has exactly two states. -/ +instance instFintypeWorkBranchPhase : Fintype WorkBranchPhase where + elems := {.dispatch, .done} + complete := fun phase => by cases phase <;> simp + +/-- State space of a direct work-symbol branch. -/ +abbrev WorkBranchQ (QBlank QNonblank : Type) := + WorkBranchPhase βŠ• (QBlank βŠ• QNonblank) + +/-- Embed a blank-branch state, collapsing its halt state to the shared halt. -/ +def workBranchBlankState {n : β„•} (onBlank onNonblank : TM n) + (q : onBlank.Q) : WorkBranchQ onBlank.Q onNonblank.Q := + if q = onBlank.qhalt then .inl .done else .inr (.inl q) + +/-- Embed a nonblank-branch state, collapsing its halt state to the shared halt. -/ +def workBranchNonblankState {n : β„•} (onBlank onNonblank : TM n) + (q : onNonblank.Q) : WorkBranchQ onBlank.Q onNonblank.Q := + if q = onNonblank.qhalt then .inl .done else .inr (.inr q) + +/-- Uniform time bound for a one-step dispatch followed by either branch. -/ +def branchWorkBlankTime (blankTime nonblankTime : β„•) : β„• := + 1 + max blankTime nonblankTime + +/-- Inspect one work symbol and run the selected branch on the same tapes. + +The dispatcher selects `onBlank` exactly when `wHeads idx = Ξ“.blank` and +otherwise selects `onNonblank`. Branch halt states are collapsed into the +shared halt state on the same simulated transition, so there is no trailing +seam step and no extra tape action after a branch halts. -/ +def branchWorkBlankTM {n : β„•} (idx : Fin n) + (onBlank onNonblank : TM n) : TM n where + Q := WorkBranchQ onBlank.Q onNonblank.Q + qstart := .inl .dispatch + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .dispatch => + if wHeads idx = Ξ“.blank then + allReadBack + (workBranchBlankState onBlank onNonblank onBlank.qstart) + iHead wHeads oHead + else + allReadBack + (workBranchNonblankState onBlank onNonblank onNonblank.qstart) + iHead wHeads oHead + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr (.inl q) => + if q = onBlank.qhalt then + allIdle (.inl .done) iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + onBlank.Ξ΄ q iHead wHeads oHead + (workBranchBlankState onBlank onNonblank q', workWrites, + outputWrite, inputDir, workDirs, outputDir) + | .inr (.inr q) => + if q = onNonblank.qhalt then + allIdle (.inl .done) iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + onNonblank.Ξ΄ q iHead wHeads oHead + (workBranchNonblankState onBlank onNonblank q', workWrites, + outputWrite, inputDir, workDirs, outputDir) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .dispatch => + dsimp only + split <;> exact rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr (.inl q) => + dsimp only + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· exact onBlank.Ξ΄_right_of_start q iHead wHeads oHead + | .inr (.inr q) => + dsimp only + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· exact onNonblank.Ξ΄_right_of_start q iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Internal.lean new file mode 100644 index 0000000000..5f397e2a99 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkBranch/Internal.lean @@ -0,0 +1,469 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import Mathlib.Algebra.Order.Group.Nat + +/-! +# Direct work-symbol branch combinator -- proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed a blank-branch configuration into the combined controller. -/ +def workBranchBlankWrap (idx : Fin n) (onBlank onNonblank : TM n) + (c : Cfg n onBlank.Q) : Cfg n (branchWorkBlankTM idx onBlank onNonblank).Q where + state := workBranchBlankState onBlank onNonblank c.state + input := c.input + work := c.work + output := c.output + +/-- Embed a nonblank-branch configuration into the combined controller. -/ +def workBranchNonblankWrap (idx : Fin n) (onBlank onNonblank : TM n) + (c : Cfg n onNonblank.Q) : + Cfg n (branchWorkBlankTM idx onBlank onNonblank).Q where + state := workBranchNonblankState onBlank onNonblank c.state + input := c.input + work := c.work + output := c.output + +theorem workBranchBlankWrap_halted_iff_internal + (idx : Fin n) (onBlank onNonblank : TM n) (c : Cfg n onBlank.Q) : + (branchWorkBlankTM idx onBlank onNonblank).halted + (workBranchBlankWrap idx onBlank onNonblank c) ↔ + onBlank.halted c := by + change (workBranchBlankWrap idx onBlank onNonblank c).state = + (branchWorkBlankTM idx onBlank onNonblank).qhalt ↔ + c.state = onBlank.qhalt + by_cases hhalt : c.state = onBlank.qhalt + Β· simp [workBranchBlankWrap, workBranchBlankState, branchWorkBlankTM, + hhalt] + Β· simp [workBranchBlankWrap, workBranchBlankState, branchWorkBlankTM, + hhalt] + +theorem workBranchNonblankWrap_halted_iff_internal + (idx : Fin n) (onBlank onNonblank : TM n) (c : Cfg n onNonblank.Q) : + (branchWorkBlankTM idx onBlank onNonblank).halted + (workBranchNonblankWrap idx onBlank onNonblank c) ↔ + onNonblank.halted c := by + change (workBranchNonblankWrap idx onBlank onNonblank c).state = + (branchWorkBlankTM idx onBlank onNonblank).qhalt ↔ + c.state = onNonblank.qhalt + by_cases hhalt : c.state = onNonblank.qhalt + Β· simp [workBranchNonblankWrap, workBranchNonblankState, + branchWorkBlankTM, hhalt] + Β· simp [workBranchNonblankWrap, workBranchNonblankState, + branchWorkBlankTM, hhalt] + +theorem branchWorkBlankTM_blank_step_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {c c' : Cfg n onBlank.Q} (hstep : onBlank.step c = some c') : + (branchWorkBlankTM idx onBlank onNonblank).step + (workBranchBlankWrap idx onBlank onNonblank c) = + some (workBranchBlankWrap idx onBlank onNonblank c') := by + have hne : c.state β‰  onBlank.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [workBranchBlankWrap, workBranchBlankState, branchWorkBlankTM, + hne])] + simp only [workBranchBlankWrap, workBranchBlankState, hne, ↓reduceIte, + branchWorkBlankTM] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : onBlank.Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +theorem branchWorkBlankTM_nonblank_step_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {c c' : Cfg n onNonblank.Q} (hstep : onNonblank.step c = some c') : + (branchWorkBlankTM idx onBlank onNonblank).step + (workBranchNonblankWrap idx onBlank onNonblank c) = + some (workBranchNonblankWrap idx onBlank onNonblank c') := by + have hne : c.state β‰  onNonblank.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [workBranchNonblankWrap, workBranchNonblankState, + branchWorkBlankTM, hne])] + simp only [workBranchNonblankWrap, workBranchNonblankState, hne, + ↓reduceIte, branchWorkBlankTM] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : onNonblank.Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +theorem branchWorkBlankTM_blank_reachesIn_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {t : β„•} {c c' : Cfg n onBlank.Q} + (hreach : onBlank.reachesIn t c c') : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn t + (workBranchBlankWrap idx onBlank onNonblank c) + (workBranchBlankWrap idx onBlank onNonblank c') := + reachesIn_map (workBranchBlankWrap idx onBlank onNonblank) + (fun _ _ => branchWorkBlankTM_blank_step_internal idx onBlank onNonblank) + hreach + +theorem branchWorkBlankTM_nonblank_reachesIn_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {t : β„•} {c c' : Cfg n onNonblank.Q} + (hreach : onNonblank.reachesIn t c c') : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn t + (workBranchNonblankWrap idx onBlank onNonblank c) + (workBranchNonblankWrap idx onBlank onNonblank c') := + reachesIn_map (workBranchNonblankWrap idx onBlank onNonblank) + (fun _ _ => branchWorkBlankTM_nonblank_step_internal idx onBlank onNonblank) + hreach + +theorem branchWorkBlankTM_dispatch_blank_internal + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hblank : (work idx).read = Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkBlankTM idx onBlank onNonblank).step + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } = + some (workBranchBlankWrap idx onBlank onNonblank + { state := onBlank.qstart + input := inp + work := work + output := out }) := by + rw [TM.step, ite_eq_right (by simp [branchWorkBlankTM])] + simp only [branchWorkBlankTM, hblank, allReadBack, ↓reduceIte, + workBranchBlankWrap] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· exact transitionInput_eq_self hinp + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self hout + +theorem branchWorkBlankTM_dispatch_nonblank_internal + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hnonblank : (work idx).read β‰  Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkBlankTM idx onBlank onNonblank).step + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } = + some (workBranchNonblankWrap idx onBlank onNonblank + { state := onNonblank.qstart + input := inp + work := work + output := out }) := by + rw [TM.step, ite_eq_right (by simp [branchWorkBlankTM])] + simp only [branchWorkBlankTM, hnonblank, allReadBack, ↓reduceIte, + workBranchNonblankWrap] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· exact transitionInput_eq_self hinp + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self hout + +theorem branchWorkBlankTM_reachesIn_blank_frame_internal + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onBlank.Q} + (hblank : (work idx).read = Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onBlank.reachesIn t + { state := onBlank.qstart, input := inp, work := work, output := out } c') + (hhalt : onBlank.halted c') : + βˆƒ C, + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkBlankTM idx onBlank onNonblank).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := by + let C := workBranchBlankWrap idx onBlank onNonblank c' + refine ⟨C, .step + (branchWorkBlankTM_dispatch_blank_internal idx onBlank onNonblank + inp work out hblank hinp hwork hout) + (branchWorkBlankTM_blank_reachesIn_internal idx onBlank onNonblank + hreach), ?_, rfl, rfl, rfl⟩ + exact (workBranchBlankWrap_halted_iff_internal idx onBlank onNonblank c').2 + hhalt + +theorem branchWorkBlankTM_reachesIn_nonblank_frame_internal + (idx : Fin n) (onBlank onNonblank : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onNonblank.Q} + (hnonblank : (work idx).read β‰  Ξ“.blank) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onNonblank.reachesIn t + { state := onNonblank.qstart, input := inp, work := work, output := out } c') + (hhalt : onNonblank.halted c') : + βˆƒ C, + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkBlankTM idx onBlank onNonblank).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := by + let C := workBranchNonblankWrap idx onBlank onNonblank c' + refine ⟨C, .step + (branchWorkBlankTM_dispatch_nonblank_internal idx onBlank onNonblank + inp work out hnonblank hinp hwork hout) + (branchWorkBlankTM_nonblank_reachesIn_internal idx onBlank onNonblank + hreach), ?_, rfl, rfl, rfl⟩ + exact (workBranchNonblankWrap_halted_iff_internal idx onBlank onNonblank c').2 + hhalt + +theorem branchWorkBlankTM_hoareTime_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {pre blankPre nonblankPre blankPost nonblankPost : TapePred n} + {blankTime nonblankTime : β„•} + (hframe : βˆ€ inp work out, pre inp work out β†’ + inp.read β‰  Ξ“.start ∧ (βˆ€ i, (work i).read β‰  Ξ“.start) ∧ + out.read β‰  Ξ“.start) + (hblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read = Ξ“.blank β†’ blankPre inp work out) + (hnonblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read β‰  Ξ“.blank β†’ nonblankPre inp work out) + (hblank : onBlank.HoareTime blankPre blankPost blankTime) + (hnonblank : onNonblank.HoareTime nonblankPre nonblankPost nonblankTime) : + (branchWorkBlankTM idx onBlank onNonblank).HoareTime pre + (fun inp work out => + blankPost inp work out ∨ nonblankPost inp work out) + (branchWorkBlankTime blankTime nonblankTime) := by + intro inp work out hpre + obtain ⟨hinp, hwork, hout⟩ := hframe inp work out hpre + by_cases hread : (work idx).read = Ξ“.blank + Β· obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + hblank inp work out (hblankPre inp work out hpre hread) + obtain ⟨C, hrun, hhaltC, hinput, hworkC, houtput⟩ := + branchWorkBlankTM_reachesIn_blank_frame_internal idx onBlank + onNonblank inp work out hread hinp hwork hout hreach hhalt + refine ⟨C, t + 1, ?_, hrun, hhaltC, ?_⟩ + Β· unfold branchWorkBlankTime + omega + Β· left + simpa [hinput, hworkC, houtput] using hpost + Β· obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + hnonblank inp work out (hnonblankPre inp work out hpre hread) + obtain ⟨C, hrun, hhaltC, hinput, hworkC, houtput⟩ := + branchWorkBlankTM_reachesIn_nonblank_frame_internal idx onBlank + onNonblank inp work out hread hinp hwork hout hreach hhalt + refine ⟨C, t + 1, ?_, hrun, hhaltC, ?_⟩ + Β· unfold branchWorkBlankTime + omega + Β· right + simpa [hinput, hworkC, houtput] using hpost + +theorem branchWorkBlankTM_hoareTimeSpace_internal + (idx : Fin n) (onBlank onNonblank : TM n) + {pre blankPre nonblankPre blankPost nonblankPost : TapePred n} + {blankTime nonblankTime inputLength blankSpace nonblankSpace : β„•} + (hframe : βˆ€ inp work out, pre inp work out β†’ + inp.read β‰  Ξ“.start ∧ (βˆ€ i, (work i).read β‰  Ξ“.start) ∧ + out.read β‰  Ξ“.start) + (hblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read = Ξ“.blank β†’ blankPre inp work out) + (hnonblankPre : βˆ€ inp work out, pre inp work out β†’ + (work idx).read β‰  Ξ“.blank β†’ nonblankPre inp work out) + (hblank : onBlank.HoareTimeSpace blankPre blankPost blankTime + inputLength blankSpace) + (hnonblank : onNonblank.HoareTimeSpace nonblankPre nonblankPost + nonblankTime inputLength nonblankSpace) : + (branchWorkBlankTM idx onBlank onNonblank).HoareTimeSpace pre + (fun inp work out => + blankPost inp work out ∨ nonblankPost inp work out) + (branchWorkBlankTime blankTime nonblankTime) inputLength + (max blankSpace nonblankSpace) := by + constructor + Β· exact branchWorkBlankTM_hoareTime_internal idx onBlank onNonblank + hframe hblankPre hnonblankPre hblank.1 hnonblank.1 + Β· intro inp work out hpre C hreach + obtain ⟨hinp, hwork, hout⟩ := hframe inp work out hpre + obtain ⟨u, hreachU⟩ := + (branchWorkBlankTM idx onBlank onNonblank).reaches_to_reachesIn hreach + by_cases hread : (work idx).read = Ξ“.blank + Β· have hbranchPre := hblankPre inp work out hpre hread + obtain ⟨cHalt, t, _ht, hbranch, hhalt, _hpost⟩ := + hblank.1 inp work out hbranchPre + have hfull : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } + (workBranchBlankWrap idx onBlank onNonblank cHalt) := + .step + (branchWorkBlankTM_dispatch_blank_internal idx onBlank onNonblank + inp work out hread hinp hwork hout) + (branchWorkBlankTM_blank_reachesIn_internal idx onBlank onNonblank + hbranch) + have hfullHalt : + (branchWorkBlankTM idx onBlank onNonblank).halted + (workBranchBlankWrap idx onBlank onNonblank cHalt) := + (workBranchBlankWrap_halted_iff_internal idx onBlank onNonblank + cHalt).2 hhalt + have hu : u ≀ t + 1 := + (branchWorkBlankTM idx onBlank onNonblank).reachesIn_le_halt + hreachU hfull hfullHalt + cases u with + | zero => + cases hreachU + have hspace := hblank.2 inp work out hbranchPre _ .refl + exact hspace.mono le_rfl (le_max_left _ _) + | succ v => + have hv : v ≀ t := by omega + obtain ⟨d, hprefix, _hsuffix⟩ := + reachesIn_prefix_internal hbranch hv + have hcanonical : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (v + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } + (workBranchBlankWrap idx onBlank onNonblank d) := + .step + (branchWorkBlankTM_dispatch_blank_internal idx onBlank + onNonblank inp work out hread hinp hwork hout) + (branchWorkBlankTM_blank_reachesIn_internal idx onBlank + onNonblank hprefix) + have hC : C = workBranchBlankWrap idx onBlank onNonblank d := + (branchWorkBlankTM idx onBlank onNonblank).reachesIn_right_unique + hreachU hcanonical + rw [hC] + have hspace := hblank.2 inp work out hbranchPre d + (reaches_of_reachesIn hprefix) + exact (hspace.mono le_rfl (le_max_left _ _)) + Β· have hbranchPre := hnonblankPre inp work out hpre hread + obtain ⟨cHalt, t, _ht, hbranch, hhalt, _hpost⟩ := + hnonblank.1 inp work out hbranchPre + have hfull : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (t + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } + (workBranchNonblankWrap idx onBlank onNonblank cHalt) := + .step + (branchWorkBlankTM_dispatch_nonblank_internal idx onBlank + onNonblank inp work out hread hinp hwork hout) + (branchWorkBlankTM_nonblank_reachesIn_internal idx onBlank + onNonblank hbranch) + have hfullHalt : + (branchWorkBlankTM idx onBlank onNonblank).halted + (workBranchNonblankWrap idx onBlank onNonblank cHalt) := + (workBranchNonblankWrap_halted_iff_internal idx onBlank onNonblank + cHalt).2 hhalt + have hu : u ≀ t + 1 := + (branchWorkBlankTM idx onBlank onNonblank).reachesIn_le_halt + hreachU hfull hfullHalt + cases u with + | zero => + cases hreachU + have hspace := hnonblank.2 inp work out hbranchPre _ .refl + exact hspace.mono le_rfl (le_max_right _ _) + | succ v => + have hv : v ≀ t := by omega + obtain ⟨d, hprefix, _hsuffix⟩ := + reachesIn_prefix_internal hbranch hv + have hcanonical : + (branchWorkBlankTM idx onBlank onNonblank).reachesIn (v + 1) + { state := (branchWorkBlankTM idx onBlank onNonblank).qstart + input := inp + work := work + output := out } + (workBranchNonblankWrap idx onBlank onNonblank d) := + .step + (branchWorkBlankTM_dispatch_nonblank_internal idx onBlank + onNonblank inp work out hread hinp hwork hout) + (branchWorkBlankTM_nonblank_reachesIn_internal idx onBlank + onNonblank hprefix) + have hC : C = workBranchNonblankWrap idx onBlank onNonblank d := + (branchWorkBlankTM idx onBlank onNonblank).reachesIn_right_unique + hreachU hcanonical + rw [hC] + have hspace := hnonblank.2 inp work out hbranchPre d + (reaches_of_reachesIn hprefix) + exact (hspace.mono le_rfl (le_max_right _ _)) + +theorem IsTransducer.branchWorkBlankTM_internal + {idx : Fin n} {onBlank onNonblank : TM n} + (hblank : onBlank.IsTransducer) + (hnonblank : onNonblank.IsTransducer) : + (branchWorkBlankTM idx onBlank onNonblank).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase with + | dispatch => + simp only [branchWorkBlankTM] + split <;> cases oHead <;> simp [allReadBack, idleDir] + | done => cases oHead <;> simp [branchWorkBlankTM, allIdle, idleDir] + | inr branchState => + cases branchState with + | inl q => + simp only [branchWorkBlankTM] + split + Β· cases oHead <;> simp [allIdle, idleDir] + Β· exact hblank q iHead wHeads oHead + | inr q => + simp only [branchWorkBlankTM] + split + Β· cases oHead <;> simp [allIdle, idleDir] + Β· exact hnonblank q iHead wHeads oHead + +end TM + +namespace Tape + +/-- A canonical little-endian natural reads blank exactly at zero. -/ +theorem HasBinaryNat.read_eq_blank_iff_internal {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : + t.read = Ξ“.blank ↔ value = 0 := by + constructor + Β· intro hread + by_contra hvalue + have hbits : value.bits β‰  [] := by + intro hnil + apply hvalue + rw [← Nat.fromBitsLE_bits value, hnil] + rfl + obtain ⟨bit, bits, hcons⟩ := List.exists_cons_of_ne_nil hbits + have hcell : t.cells 1 = Ξ“.ofBool bit := by + have hfirst := h.2.2.1 0 (by simp [hcons]) + simpa [hcons] using hfirst + rw [Tape.read, h.2.1, hcell] at hread + cases bit <;> simp [Ξ“.ofBool] at hread + Β· intro hvalue + subst value + rw [Tape.read, h.2.1] + exact h.2.2.2 0 (by simp) + +end Tape + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch.lean new file mode 100644 index 0000000000..c196b7e2dd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space + +/-! +# Direct work-symbol branch combinator + +This module exposes exact framed execution for a one-step branch on an +arbitrary work-tape symbol. It is the direct controller primitive used to +branch on the readable sparse-entry equality flag. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Exact framed execution through the symbol-equal branch. -/ +theorem branchWorkSymbolTM_reachesIn_equal_frame + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onEqual.Q} + (hequal : (work idx).read = symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onEqual.reachesIn t + { state := onEqual.qstart, input := inp, work := work, output := out } c') + (hhalt : onEqual.halted c') : + βˆƒ C, + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn (t + 1) + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := + branchWorkSymbolTM_reachesIn_equal_frame_internal idx symbol onEqual + onDifferent inp work out hequal hinp hwork hout hreach hhalt + +/-- Exact framed execution through the symbol-different branch. -/ +theorem branchWorkSymbolTM_reachesIn_different_frame + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onDifferent.Q} + (hdifferent : (work idx).read β‰  symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onDifferent.reachesIn t + { state := onDifferent.qstart, input := inp, work := work, output := out } + c') + (hhalt : onDifferent.halted c') : + βˆƒ C, + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn (t + 1) + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := + branchWorkSymbolTM_reachesIn_different_frame_internal idx symbol onEqual + onDifferent inp work out hdifferent hinp hwork hout hreach hhalt + +/-- A direct work-symbol branch is a transducer when both selected branches +are transducers. -/ +theorem IsTransducer.branchWorkSymbolTM + {idx : Fin n} {symbol : Ξ“} {onEqual onDifferent : TM n} + (hequal : onEqual.IsTransducer) (hdifferent : onDifferent.IsTransducer) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).IsTransducer := + hequal.branchWorkSymbolTM_internal hdifferent + +/-- Coarse all-prefix auxiliary-space envelope for a direct work-symbol +branch. -/ +theorem branchWorkSymbolTM_prefix_withinAuxSpace + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (branchTime inputLength initialSpace time : β„•) + (start current : Cfg n + (branchWorkSymbolTM idx symbol onEqual onDifferent).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn + time start current) + (htime : time ≀ branchTime + 1) : + current.WithinAuxSpace inputLength (initialSpace + branchTime + 1) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Defs.lean new file mode 100644 index 0000000000..3152906731 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Defs.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkBranch.Defs + +/-! +# Direct work-symbol branch combinator β€” definitions + +`TM.branchWorkSymbolTM idx symbol onEqual onDifferent` inspects one work tape +and runs `onEqual` exactly when the current symbol equals `symbol`. This is the +generic controller branch used by the sparse RAM lookup scan. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Inspect one work symbol and run the selected branch on the same tapes. -/ +def branchWorkSymbolTM {n : β„•} (idx : Fin n) (symbol : Ξ“) + (onEqual onDifferent : TM n) : TM n where + Q := WorkBranchQ onEqual.Q onDifferent.Q + qstart := .inl .dispatch + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl .dispatch => + if wHeads idx = symbol then + allReadBack + (workBranchBlankState onEqual onDifferent onEqual.qstart) + iHead wHeads oHead + else + allReadBack + (workBranchNonblankState onEqual onDifferent onDifferent.qstart) + iHead wHeads oHead + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr (.inl q) => + if q = onEqual.qhalt then + allReadBack (.inl .done) iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + onEqual.Ξ΄ q iHead wHeads oHead + (workBranchBlankState onEqual onDifferent q', workWrites, + outputWrite, inputDir, workDirs, outputDir) + | .inr (.inr q) => + if q = onDifferent.qhalt then + allReadBack (.inl .done) iHead wHeads oHead + else + let (q', workWrites, outputWrite, inputDir, workDirs, outputDir) := + onDifferent.Ξ΄ q iHead wHeads oHead + (workBranchNonblankState onEqual onDifferent q', workWrites, + outputWrite, inputDir, workDirs, outputDir) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl .dispatch => + dsimp only + split <;> exact rightOfStart_allReadBack iHead wHeads oHead + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr (.inl q) => + dsimp only + split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact onEqual.Ξ΄_right_of_start q iHead wHeads oHead + | .inr (.inr q) => + dsimp only + split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact onDifferent.Ξ΄_right_of_start q iHead wHeads oHead + +/-- One dispatch step followed by either branch's advertised time. -/ +def branchWorkSymbolTime (equalTime differentTime : β„•) : β„• := + 1 + max equalTime differentTime + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Internal.lean new file mode 100644 index 0000000000..de113dafd7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Combinators/WorkSymbolBranch/Internal.lean @@ -0,0 +1,260 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs + +/-! +# Direct work-symbol branch combinator β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed an equal-branch configuration in the direct-symbol controller. -/ +def workSymbolEqualWrap (idx : Fin n) (symbol : Ξ“) + (onEqual onDifferent : TM n) (c : Cfg n onEqual.Q) : + Cfg n (branchWorkSymbolTM idx symbol onEqual onDifferent).Q where + state := workBranchBlankState onEqual onDifferent c.state + input := c.input + work := c.work + output := c.output + +/-- Embed a different-branch configuration in the direct-symbol controller. -/ +def workSymbolDifferentWrap (idx : Fin n) (symbol : Ξ“) + (onEqual onDifferent : TM n) (c : Cfg n onDifferent.Q) : + Cfg n (branchWorkSymbolTM idx symbol onEqual onDifferent).Q where + state := workBranchNonblankState onEqual onDifferent c.state + input := c.input + work := c.work + output := c.output + +private theorem workSymbolEqualWrap_halted_iff + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (c : Cfg n onEqual.Q) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted + (workSymbolEqualWrap idx symbol onEqual onDifferent c) ↔ + onEqual.halted c := by + change (workSymbolEqualWrap idx symbol onEqual onDifferent c).state = + (branchWorkSymbolTM idx symbol onEqual onDifferent).qhalt ↔ + c.state = onEqual.qhalt + by_cases hhalt : c.state = onEqual.qhalt <;> + simp [workSymbolEqualWrap, workBranchBlankState, branchWorkSymbolTM, + hhalt] + +private theorem workSymbolDifferentWrap_halted_iff + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (c : Cfg n onDifferent.Q) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted + (workSymbolDifferentWrap idx symbol onEqual onDifferent c) ↔ + onDifferent.halted c := by + change (workSymbolDifferentWrap idx symbol onEqual onDifferent c).state = + (branchWorkSymbolTM idx symbol onEqual onDifferent).qhalt ↔ + c.state = onDifferent.qhalt + by_cases hhalt : c.state = onDifferent.qhalt <;> + simp [workSymbolDifferentWrap, workBranchNonblankState, + branchWorkSymbolTM, hhalt] + +private theorem branchWorkSymbolTM_equal_step + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + {c c' : Cfg n onEqual.Q} (hstep : onEqual.step c = some c') : + (branchWorkSymbolTM idx symbol onEqual onDifferent).step + (workSymbolEqualWrap idx symbol onEqual onDifferent c) = + some (workSymbolEqualWrap idx symbol onEqual onDifferent c') := by + have hne : c.state β‰  onEqual.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [workSymbolEqualWrap, workBranchBlankState, branchWorkSymbolTM, + hne])] + simp only [workSymbolEqualWrap, workBranchBlankState, hne, ↓reduceIte, + branchWorkSymbolTM] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : onEqual.Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem branchWorkSymbolTM_different_step + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + {c c' : Cfg n onDifferent.Q} (hstep : onDifferent.step c = some c') : + (branchWorkSymbolTM idx symbol onEqual onDifferent).step + (workSymbolDifferentWrap idx symbol onEqual onDifferent c) = + some (workSymbolDifferentWrap idx symbol onEqual onDifferent c') := by + have hne : c.state β‰  onDifferent.qhalt := state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by + simp [workSymbolDifferentWrap, workBranchNonblankState, + branchWorkSymbolTM, hne])] + simp only [workSymbolDifferentWrap, workBranchNonblankState, hne, + ↓reduceIte, branchWorkSymbolTM] + rw [TM.step, ite_eq_right hne] at hstep + revert hstep + generalize haction : onDifferent.Ξ΄ c.state c.input.read + (fun i => (c.work i).read) c.output.read = action + obtain ⟨q', workWrites, outputWrite, inputDir, workDirs, outputDir⟩ := action + simp only [haction] + intro hstep + cases Option.some.inj hstep + rfl + +private theorem branchWorkSymbolTM_equal_reachesIn + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + {t : β„•} {c c' : Cfg n onEqual.Q} (hreach : onEqual.reachesIn t c c') : + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn t + (workSymbolEqualWrap idx symbol onEqual onDifferent c) + (workSymbolEqualWrap idx symbol onEqual onDifferent c') := + reachesIn_map (workSymbolEqualWrap idx symbol onEqual onDifferent) + (fun _ _ => branchWorkSymbolTM_equal_step idx symbol onEqual onDifferent) + hreach + +private theorem branchWorkSymbolTM_different_reachesIn + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + {t : β„•} {c c' : Cfg n onDifferent.Q} + (hreach : onDifferent.reachesIn t c c') : + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn t + (workSymbolDifferentWrap idx symbol onEqual onDifferent c) + (workSymbolDifferentWrap idx symbol onEqual onDifferent c') := + reachesIn_map (workSymbolDifferentWrap idx symbol onEqual onDifferent) + (fun _ _ => branchWorkSymbolTM_different_step idx symbol onEqual onDifferent) + hreach + +private theorem branchWorkSymbolTM_dispatch_equal + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hequal : (work idx).read = symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).step + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } = + some (workSymbolEqualWrap idx symbol onEqual onDifferent + { state := onEqual.qstart, input := inp, work := work, output := out }) := by + rw [TM.step, ite_eq_right (by simp [branchWorkSymbolTM])] + simp only [branchWorkSymbolTM, hequal, allReadBack, ↓reduceIte, + workSymbolEqualWrap] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· exact transitionInput_eq_self hinp + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self hout + +private theorem branchWorkSymbolTM_dispatch_different + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hdifferent : (work idx).read β‰  symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).step + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } = + some (workSymbolDifferentWrap idx symbol onEqual onDifferent + { state := onDifferent.qstart, input := inp, work := work, + output := out }) := by + rw [TM.step, ite_eq_right (by simp [branchWorkSymbolTM])] + simp only [branchWorkSymbolTM, hdifferent, allReadBack, ↓reduceIte, + workSymbolDifferentWrap] + refine congrArg some (Cfg.ext rfl ?_ ?_ ?_) + Β· exact transitionInput_eq_self hinp + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self hout + +theorem branchWorkSymbolTM_reachesIn_equal_frame_internal + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onEqual.Q} + (hequal : (work idx).read = symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onEqual.reachesIn t + { state := onEqual.qstart, input := inp, work := work, output := out } c') + (hhalt : onEqual.halted c') : + βˆƒ C, + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn (t + 1) + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := by + let C := workSymbolEqualWrap idx symbol onEqual onDifferent c' + refine ⟨C, .step + (branchWorkSymbolTM_dispatch_equal idx symbol onEqual onDifferent + inp work out hequal hinp hwork hout) + (branchWorkSymbolTM_equal_reachesIn idx symbol onEqual onDifferent hreach), + ?_, rfl, rfl, rfl⟩ + exact (workSymbolEqualWrap_halted_iff idx symbol onEqual onDifferent c').2 + hhalt + +theorem branchWorkSymbolTM_reachesIn_different_frame_internal + (idx : Fin n) (symbol : Ξ“) (onEqual onDifferent : TM n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {t : β„•} {c' : Cfg n onDifferent.Q} + (hdifferent : (work idx).read β‰  symbol) + (hinp : inp.read β‰  Ξ“.start) (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) + (hreach : onDifferent.reachesIn t + { state := onDifferent.qstart, input := inp, work := work, output := out } + c') + (hhalt : onDifferent.halted c') : + βˆƒ C, + (branchWorkSymbolTM idx symbol onEqual onDifferent).reachesIn (t + 1) + { state := (branchWorkSymbolTM idx symbol onEqual onDifferent).qstart + input := inp + work := work + output := out } C ∧ + (branchWorkSymbolTM idx symbol onEqual onDifferent).halted C ∧ + C.input = c'.input ∧ C.work = c'.work ∧ C.output = c'.output := by + let C := workSymbolDifferentWrap idx symbol onEqual onDifferent c' + refine ⟨C, .step + (branchWorkSymbolTM_dispatch_different idx symbol onEqual onDifferent + inp work out hdifferent hinp hwork hout) + (branchWorkSymbolTM_different_reachesIn idx symbol onEqual onDifferent + hreach), ?_, rfl, rfl, rfl⟩ + exact (workSymbolDifferentWrap_halted_iff idx symbol onEqual onDifferent + c').2 hhalt + +theorem IsTransducer.branchWorkSymbolTM_internal + {idx : Fin n} {symbol : Ξ“} {onEqual onDifferent : TM n} + (hequal : onEqual.IsTransducer) (hdifferent : onDifferent.IsTransducer) : + (branchWorkSymbolTM idx symbol onEqual onDifferent).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase with + | dispatch => + simp only [branchWorkSymbolTM] + split <;> cases oHead <;> simp [allReadBack, idleDir] + | done => cases oHead <;> simp [branchWorkSymbolTM, allIdle, idleDir] + | inr branchState => + cases branchState with + | inl q => + simp only [branchWorkSymbolTM] + split + Β· cases oHead <;> simp [allReadBack, idleDir] + Β· exact hequal q iHead wHeads oHead + | inr q => + simp only [branchWorkSymbolTM] + split + Β· cases oHead <;> simp [allReadBack, idleDir] + Β· exact hdifferent q iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition.lean new file mode 100644 index 0000000000..583b72e417 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal + +/-! +# Sequential composition after function computation + +`TM.compositionTM tmF tmG` is an executable deterministic machine that runs +`tmF`, copies its delimited output onto a fresh virtual-input tape, and then +runs `tmG` on that output. Work tapes of the two machines occupy disjoint +blocks, and the intermediate raw output may contain arbitrary junk after its +first delimiter. + +## Main result + +- `TM.compositionTM_computesInTime` β€” correctness with a monotone coarse time bound +- `TM.compositionTM_decidesInTime` β€” function computation followed by a decider +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf ng : β„•} + +/-- Sequential deterministic function composition. The first computation, +two copy/rewind passes, four phase transitions, and the second computation fit +within `4 * TF(n) + 11 + TG(TF(n))` whenever `TG` is monotone. -/ +theorem compositionTM_computesInTime + {tmF : TM nf} {tmG : TM ng} + {f g : List Bool β†’ List Bool} {TF TG : β„• β†’ β„•} + (hF : tmF.ComputesInTime f TF) + (hG : tmG.ComputesInTime g TG) + (hmono : Monotone TG) : + (compositionTM tmF tmG).ComputesInTime (g ∘ f) + (fun n => 4 * TF n + 11 + TG (TF n)) := + compositionTM_computesInTime_internal hF hG hmono + +/-- Sequential deterministic preprocessing followed by a language decider. +The composite decides the preimage language with the same coarse monotone time +bound as function composition. -/ +theorem compositionTM_decidesInTime + {tmF : TM nf} {tmG : TM ng} + {f : List Bool β†’ List Bool} {L : Language} {TF TG : β„• β†’ β„•} + (hF : tmF.ComputesInTime f TF) + (hG : tmG.DecidesInTime L TG) + (hmono : Monotone TG) : + (compositionTM tmF tmG).DecidesInTime (f ⁻¹' L) + (fun n => 4 * TF n + 11 + TG (TF n)) := + compositionTM_decidesInTime_preimage_internal hF hG hmono + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Defs.lean new file mode 100644 index 0000000000..178eaefc3b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Defs.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines + +/-! +# Sequential composition after function computation + +This file fixes the tape layout and executable phase pipeline used to feed one +deterministic function computation into a second machine. Proofs of correctness +and time bounds live in the internal and public theorem layers. + +For a function-computing `tmF : TM nf` and a second machine `tmG : TM ng`, the +composite has +`nf + 1 + (ng + 1)` work tapes: + +- `0 .. nf - 1`: work tapes of `tmF` +- `nf`: raw redirected output of `tmF` +- `nf + 1 .. nf + ng`: work tapes of `tmG` +- `nf + ng + 1`: canonical virtual input of `tmG` + +The raw output is rewound and copied to the fresh virtual-input tape before +`tmG` resumes after its compulsory first transition off the left-end markers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf ng : β„•} + +/-- Work-tape count of the sequential composition machine. -/ +abbrev compositionTapeCount (nf ng : β„•) := 0 + (nf + 1) + (ng + 1) + +/-- Physical work tape holding the raw redirected output of the first machine. -/ +def compositionRawOutputIdx (nf ng : β„•) : Fin (compositionTapeCount nf ng) := + ⟨nf, by simp [compositionTapeCount]; omega⟩ + +@[simp] theorem compositionRawOutputIdx_val (nf ng : β„•) : + (compositionRawOutputIdx nf ng).val = nf := rfl + +/-- Physical work tape holding the canonical virtual input of the second machine. -/ +def compositionVirtualInputIdx (nf ng : β„•) : Fin (compositionTapeCount nf ng) := + ⟨nf + 1 + ng, by simp [compositionTapeCount]⟩ + +@[simp] theorem compositionVirtualInputIdx_val (nf ng : β„•) : + (compositionVirtualInputIdx nf ng).val = nf + 1 + ng := rfl + +/-- The two pipeline tapes occupy distinct physical coordinates. -/ +theorem compositionRawOutputIdx_ne_virtualInputIdx (nf ng : β„•) : + compositionRawOutputIdx nf ng β‰  compositionVirtualInputIdx nf ng := by + intro h + have := congrArg Fin.val h + simp only [compositionRawOutputIdx_val, compositionVirtualInputIdx_val] at this + omega + +/-- The raw-output coordinate is the placed last work tape of +`tmF.retargetOutput`. -/ +theorem compositionRawOutputIdx_eq_firstPlacedLast (nf ng : β„•) : + compositionRawOutputIdx nf ng = + placeWorkIdx 0 (ng + 1) (Fin.last nf) := by + apply Fin.ext + simp [compositionRawOutputIdx, placeWorkIdx] + +/-- The virtual-input coordinate is the placed last work tape of +`retargetInputStarted tmG`. -/ +theorem compositionVirtualInputIdx_eq_secondPlacedLast (nf ng : β„•) : + compositionVirtualInputIdx nf ng = + placeWorkIdx (0 + (nf + 1)) 0 (Fin.last ng) := by + apply Fin.ext + simp [compositionVirtualInputIdx, placeWorkIdx] + +/-- Physical coordinate of work tape `i` of the first computation. -/ +def compositionPrefixIdx (nf ng : β„•) (i : Fin nf) : + Fin (compositionTapeCount nf ng) := + ⟨i.val, by simp [compositionTapeCount]; omega⟩ + +@[simp] theorem compositionPrefixIdx_val (nf ng : β„•) (i : Fin nf) : + (compositionPrefixIdx nf ng i).val = i.val := rfl + +/-- Physical coordinate of source work tape `j` of the second computation. -/ +def compositionSecondWorkIdx (nf ng : β„•) (j : Fin ng) : + Fin (compositionTapeCount nf ng) := + placeWorkIdx (0 + (nf + 1)) 0 (Fin.castSucc j) + +@[simp] theorem compositionSecondWorkIdx_val (nf ng : β„•) (j : Fin ng) : + (compositionSecondWorkIdx nf ng j).val = nf + 1 + j.val := by + simp [compositionSecondWorkIdx, placeWorkIdx] + +/-- The first phase redirects `tmF`'s output into the raw-output tape and parks +the work-tape suffix reserved for the second computation. -/ +def compositionFirstTM (tmF : TM nf) (ng : β„•) : TM (compositionTapeCount nf ng) := + placeWorkTM 0 (ng + 1) tmF.retargetOutput + +/-- The last phase places the already-started virtual-input wrapper for `tmG` +after the first computation's work and raw-output tapes. -/ +def compositionSecondTM (nf : β„•) (tmG : TM ng) : TM (compositionTapeCount nf ng) := + placeWorkTM (0 + (nf + 1)) 0 (retargetInputStarted tmG) + +/-- Pipeline after the first computation: rewind its raw output, copy it onto +a clean virtual-input tape, rewind that tape, and run the second computation. -/ +def compositionTailTM (nf ng : β„•) (tmG : TM ng) : TM (compositionTapeCount nf ng) := + seqTM (rewindWorkTM (compositionRawOutputIdx nf ng)) + (seqTM + (copyWorkToWorkTM (compositionRawOutputIdx nf ng) + (compositionVirtualInputIdx nf ng)) + (seqTM (rewindWorkTM (compositionVirtualInputIdx nf ng)) + (compositionSecondTM nf tmG))) + +/-- Executable sequential composition of a function computation with a second +deterministic machine. -/ +def compositionTM (tmF : TM nf) (tmG : TM ng) : TM (compositionTapeCount nf ng) := + seqTM (compositionFirstTM tmF ng) (compositionTailTM nf ng tmG) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal.lean new file mode 100644 index 0000000000..2ce3f3d7ea --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.FirstPhase +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.Tail +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.OutputBounds + +/-! +# Sequential composition correctness β€” proof internals + +This module connects the first function computation's placed raw-output +boundary to the normalization tail. It derives coarse monotone time bounds for +both function composition and preprocessing followed by a language decider. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf ng : β„•} + +/-- Internal correctness theorem for the executable sequential function +composition machine. -/ +theorem compositionTM_computesInTime_internal + {tmF : TM nf} {tmG : TM ng} + {f g : List Bool β†’ List Bool} {TF TG : β„• β†’ β„•} + (hF : tmF.ComputesInTime f TF) + (hG : tmG.ComputesInTime g TG) + (hmono : Monotone TG) : + (compositionTM tmF tmG).ComputesInTime (g ∘ f) + (fun n => 4 * TF n + 11 + TG (TF n)) := by + intro x + obtain ⟨C, t, ht, hreachF, hhaltF, hrawOutput, hrawHead, + hvirtual, hscratch, hinputInv, hinputHead, hworkBoundary, + houtputParked⟩ := + compositionFirstTM_boundary_internal tmF ng hF x + let boundaryInput := transitionInput C.input + let boundaryWork : Fin (compositionTapeCount nf ng) β†’ Tape := + fun i => transitionTape (C.work i) + let boundaryOutput := transitionTape C.output + have htail := compositionTailTM_hoareTime_internal (nf := nf) + tmG hG (f x) (TF x.length + 1) + obtain ⟨D, u, hu, hreachTail, hhaltTail, houtTail⟩ := + htail boundaryInput boundaryWork boundaryOutput (by + refine ⟨hrawOutput, (hworkBoundary _).1, ?_, hvirtual, hscratch, + houtputParked, hinputInv, hinputHead, ?_⟩ + Β· dsimp only [boundaryWork] + omega + Β· intro i + exact hworkBoundary (compositionPrefixIdx nf ng i)) + let first := compositionFirstTM tmF ng + let tail := compositionTailTM nf ng tmG + let final := phase2Wrap first tail D + refine ⟨final, t + 1 + u, ?_, ?_, ?_, ?_⟩ + Β· have hlength : (f x).length ≀ TF x.length := hF.output_length_le x + have hgBound : TG (f x).length ≀ TG (TF x.length) := hmono hlength + have hu' : u ≀ TF x.length + 1 + 2 * (f x).length + 9 + TG (f x).length := by + omega + change t + 1 + u ≀ 4 * TF x.length + 11 + TG (TF x.length) + omega + Β· have hreach := seqTM_reachesIn_of_reachesIn first tail + hreachF hhaltF hreachTail + simpa [compositionTM, first, tail, final, boundaryInput, boundaryWork, + boundaryOutput] using! hreach + Β· show (compositionTM tmF tmG).halted final + simpa [compositionTM, first, tail, final] using! + (phase2Wrap_halted_iff first tail D).2 hhaltTail + Β· simpa [final, phase2Wrap, Function.comp_apply] using! houtTail + +/-- Internal correctness theorem for deterministic preprocessing followed by a +language decider. -/ +theorem compositionTM_decidesInTime_preimage_internal + {tmF : TM nf} {tmG : TM ng} + {f : List Bool β†’ List Bool} {L : Language} {TF TG : β„• β†’ β„•} + (hF : tmF.ComputesInTime f TF) + (hG : tmG.DecidesInTime L TG) + (hmono : Monotone TG) : + (compositionTM tmF tmG).DecidesInTime (f ⁻¹' L) + (fun n => 4 * TF n + 11 + TG (TF n)) := by + intro x + obtain ⟨C, t, ht, hreachF, hhaltF, hrawOutput, hrawHead, + hvirtual, hscratch, hinputInv, hinputHead, hworkBoundary, + houtputParked⟩ := + compositionFirstTM_boundary_internal tmF ng hF x + let boundaryInput := transitionInput C.input + let boundaryWork : Fin (compositionTapeCount nf ng) β†’ Tape := + fun i => transitionTape (C.work i) + let boundaryOutput := transitionTape C.output + have htail := compositionTailTM_decides_hoareTime_internal (nf := nf) + tmG hG (f x) (TF x.length + 1) + obtain ⟨D, u, hu, hreachTail, hhaltTail, hyesTail, hnoTail⟩ := + htail boundaryInput boundaryWork boundaryOutput (by + refine ⟨hrawOutput, (hworkBoundary _).1, ?_, hvirtual, hscratch, + houtputParked, hinputInv, hinputHead, ?_⟩ + Β· dsimp only [boundaryWork] + omega + Β· intro i + exact hworkBoundary (compositionPrefixIdx nf ng i)) + let first := compositionFirstTM tmF ng + let tail := compositionTailTM nf ng tmG + let final := phase2Wrap first tail D + refine ⟨final, t + 1 + u, ?_, ?_, ?_, ?_, ?_⟩ + Β· have hlength : (f x).length ≀ TF x.length := hF.output_length_le x + have hgBound : TG (f x).length ≀ TG (TF x.length) := hmono hlength + have hu' : u ≀ TF x.length + 1 + 2 * (f x).length + 9 + TG (f x).length := by + omega + change t + 1 + u ≀ 4 * TF x.length + 11 + TG (TF x.length) + omega + Β· have hreach := seqTM_reachesIn_of_reachesIn first tail + hreachF hhaltF hreachTail + simpa [compositionTM, first, tail, final, boundaryInput, boundaryWork, + boundaryOutput] using! hreach + Β· show (compositionTM tmF tmG).halted final + simpa [compositionTM, first, tail, final] using! + (phase2Wrap_halted_iff first tail D).2 hhaltTail + Β· intro hx + simpa [final, phase2Wrap] using! hyesTail hx + Β· intro hx + simpa [final, phase2Wrap] using! hnoTail hx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/FirstPhase.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/FirstPhase.lean new file mode 100644 index 0000000000..619c410541 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/FirstPhase.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# Function composition: first-phase boundary + +This module runs the first function machine with its output redirected to the +raw-output work tape, places that run in the composite layout, and exposes the +exact tape facts required by the normalization tail. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf ng : β„•} + +/-- Start-tape well-formedness is preserved over a deterministic run. -/ +private theorem reachesIn_startInvariant {n : β„•} {tm : TM n} + {t : β„•} {c c' : Cfg n tm.Q} (hreach : tm.reachesIn t c c') + (hin : c.input.StartInvariant) + (hwork : βˆ€ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.StartInvariant ∧ (βˆ€ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + induction hreach with + | zero => exact ⟨hin, hwork, hout⟩ + | step hstep _ ih => + obtain ⟨hin1, hwork1, hout1⟩ := Tape.StartInvariant.step tm hstep hin hwork hout + exact ih hin1 hwork1 hout1 + +/-- A phase-boundary work-tape action preserves the start invariant and moves +the head off the left-end marker. -/ +private theorem transitionTape_boundary {t : Tape} (h : t.StartInvariant) : + (transitionTape t).StartInvariant ∧ 1 ≀ (transitionTape t).head := by + refine ⟨⟨?_, ?_⟩, one_le_head_transitionTape t h.1⟩ + Β· rw [transitionTape_cells t h.2] + exact h.1 + Β· intro j hj + rw [transitionTape_cells t h.2] + exact h.2 j hj + +/-- The input counterpart of `transitionTape_boundary`. -/ +private theorem transitionInput_boundary {t : Tape} (h : t.StartInvariant) : + (transitionInput t).StartInvariant ∧ 1 ≀ (transitionInput t).head := by + refine ⟨⟨?_, ?_⟩, transitionInput_head_ge t h.1⟩ + Β· rw [transitionInput_cells] + exact h.1 + Β· intro j hj + rw [transitionInput_cells] + exact h.2 j hj + +/-- A blank output tape whose head is still at zero or one becomes the +canonical parked blank tape at a phase boundary. -/ +private theorem transitionTape_blank_eq_parked {t : Tape} + (hcells : t.cells = (Tape.init []).cells) (hhead : t.head ≀ 1) : + transitionTape t = (Tape.init []).move Dir3.right := by + rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hhead with hzero | hone + Β· have ht : t = Tape.init [] := Tape.ext hzero hcells + subst ht + rfl + Β· have ht : t = (Tape.init []).move Dir3.right := by + apply Tape.ext + Β· exact hone + Β· simpa only [Tape.move_cells] using hcells + subst ht + exact transitionTape_eq_self (by decide) + +/-- The first computation reaches a halted composite-layout boundary within +its original time bound. The raw output remains readable, the destination for +the canonical virtual input is still fresh, and every seam tape is parked in +a start-invariant state. -/ +theorem compositionFirstTM_boundary_internal (tmF : TM nf) (ng : β„•) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : tmF.ComputesInTime f T) (x : List Bool) : + βˆƒ (C : Cfg (compositionTapeCount nf ng) (compositionFirstTM tmF ng).Q) + (t : β„•), + t ≀ T x.length ∧ + (compositionFirstTM tmF ng).reachesIn t + ((compositionFirstTM tmF ng).initCfg x) C ∧ + (compositionFirstTM tmF ng).halted C ∧ + (transitionTape (C.work (compositionRawOutputIdx nf ng))).HasOutput (f x) ∧ + (transitionTape (C.work (compositionRawOutputIdx nf ng))).head ≀ t + 1 ∧ + transitionTape (C.work (compositionVirtualInputIdx nf ng)) = + (Tape.init []).move Dir3.right ∧ + (βˆ€ j : Fin ng, + transitionTape (C.work (compositionSecondWorkIdx nf ng j)) = + (Tape.init []).move Dir3.right) ∧ + (transitionInput C.input).StartInvariant ∧ + 1 ≀ (transitionInput C.input).head ∧ + (βˆ€ i, (transitionTape (C.work i)).StartInvariant ∧ + 1 ≀ (transitionTape (C.work i)).head) ∧ + transitionTape C.output = (Tape.init []).move Dir3.right := by + obtain ⟨cR, t, ht, hreachR, hhaltR, hrawR, houtCells, houtHead⟩ := + retargetOutput_computesInTime_boundary tmF hcomp x + obtain ⟨C, hreachC, hstateC, _hinputC, houtputC, hshapeC⟩ := + placeWorkTM_reachesIn_init_internal tmF.retargetOutput 0 (ng + 1) x hreachR + have hreachFirst : (compositionFirstTM tmF ng).reachesIn t + ((compositionFirstTM tmF ng).initCfg x) C := by + simpa [compositionFirstTM] using hreachC + have hhaltFirst : (compositionFirstTM tmF ng).halted C := by + show C.state = (compositionFirstTM tmF ng).qhalt + rw [hstateC] + exact hhaltR + have hrawC : (C.work (compositionRawOutputIdx nf ng)).HasOutput (f x) := by + rcases hshapeC with ht0 | hC + Β· subst t + cases hreachR + cases hreachC + simpa [compositionFirstTM, compositionRawOutputIdx, Cfg.init] using hrawR + Β· rw [hC, compositionRawOutputIdx_eq_firstPlacedLast] + have hmiddle := placeWorkCfg_work_middle tmF.retargetOutput 0 (ng + 1) + (fun _ => (Tape.init []).move Dir3.right) cR (Fin.last nf) + have houtput := hmiddle β–Έ hrawR + simpa only [placeWorkParkedCfg] using! houtput + have hvirtual : transitionTape (C.work (compositionVirtualInputIdx nf ng)) = + (Tape.init []).move Dir3.right := by + rcases hshapeC with ht0 | hC + Β· subst t + cases hreachC + rfl + Β· rw [hC] + have hnot : Β¬placeWorkInMiddle 0 (nf + 1) + (compositionVirtualInputIdx nf ng) := by + simp [placeWorkInMiddle, compositionVirtualInputIdx] + change transitionTape + ((placeWorkCfg tmF.retargetOutput 0 (ng + 1) + (fun _ => (Tape.init []).move Dir3.right) cR).work + (compositionVirtualInputIdx nf ng)) = _ + have hextra := placeWorkCfg_work_extra tmF.retargetOutput 0 (ng + 1) + (fun _ => (Tape.init []).move Dir3.right) cR _ hnot + exact (congrArg transitionTape hextra).trans + (transitionTape_eq_self (t := (Tape.init []).move Dir3.right) (by decide)) + have hscratch : βˆ€ j : Fin ng, + transitionTape (C.work (compositionSecondWorkIdx nf ng j)) = + (Tape.init []).move Dir3.right := by + intro j + let idx := compositionSecondWorkIdx nf ng j + change transitionTape (C.work idx) = _ + rcases hshapeC with ht0 | hC + Β· subst t + cases hreachC + rfl + Β· rw [hC] + have hnot : Β¬placeWorkInMiddle 0 (nf + 1) idx := by + simp [placeWorkInMiddle, idx] + change transitionTape + ((placeWorkCfg tmF.retargetOutput 0 (ng + 1) + (fun _ => (Tape.init []).move Dir3.right) cR).work idx) = _ + have hextra := placeWorkCfg_work_extra tmF.retargetOutput 0 (ng + 1) + (fun _ => (Tape.init []).move Dir3.right) cR _ hnot + exact (congrArg transitionTape hextra).trans + (transitionTape_eq_self (t := (Tape.init []).move Dir3.right) (by decide)) + have hinvariants := reachesIn_startInvariant hreachFirst + (Tape.StartInvariant.init_ofBool x) + (fun _ => Tape.StartInvariant.init_nil) + Tape.StartInvariant.init_nil + have hinBoundary := transitionInput_boundary hinvariants.1 + have hworkBoundary : βˆ€ i, (transitionTape (C.work i)).StartInvariant ∧ + 1 ≀ (transitionTape (C.work i)).head := + fun i => transitionTape_boundary (hinvariants.2.1 i) + have hrawOutput : + (transitionTape (C.work (compositionRawOutputIdx nf ng))).HasOutput (f x) := by + exact (Tape.hasOutput_congr + (transitionTape_cells _ (hinvariants.2.1 _).2) (f x)).mpr hrawC + have hheads := head_le_of_reachesIn (compositionFirstTM tmF ng) hreachFirst + have hrawHead : + (transitionTape (C.work (compositionRawOutputIdx nf ng))).head ≀ t + 1 := + head_transitionTape_le (hinvariants.2.1 _).1 (hheads.2.2 _) + have houtputParked : transitionTape C.output = + (Tape.init []).move Dir3.right := by + rw [houtputC] + exact transitionTape_blank_eq_parked houtCells houtHead + exact ⟨C, t, ht, hreachFirst, hhaltFirst, hrawOutput, hrawHead, hvirtual, + hscratch, hinBoundary.1, hinBoundary.2, hworkBoundary, houtputParked⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/Tail.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/Tail.lean new file mode 100644 index 0000000000..136bdc7b77 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/Internal/Tail.lean @@ -0,0 +1,712 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.RetargetCompute + +/-! +# Sequential-composition tail pipeline + +This module verifies the pipeline after the first function computation has +placed its raw output on the dedicated work tape. The pipeline rewinds that +tape, copies its delimited `HasOutput` value onto a fresh canonical tape, +rewinds the fresh tape, and runs the placed started-input wrapper for the +second machine. Its final output contract may describe either a computed string +or a decision verdict. + +The phase-expanded bound is +`(B + 2) + 1 + (|y| + 1) + 1 + (|y| + 1 + 2) + 1 + G(|y|)`, +which simplifies to `B + 2 * |y| + 9 + G(|y|)`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- A start-invariant tape at a positive head does not read `β–·`. -/ +private theorem read_ne_start_of_startInvariant {t : Tape} + (hinv : Tape.StartInvariant t) (hhead : 1 ≀ t.head) : + t.read β‰  Ξ“.start := by + show t.cells t.head β‰  Ξ“.start + exact hinv.2 t.head hhead + +/-- A start-invariant tape at a positive head is unchanged by a `seqTM` +boundary. -/ +private theorem transitionTape_eq_of_startInvariant {t : Tape} + (hinv : Tape.StartInvariant t) (hhead : 1 ≀ t.head) : + transitionTape t = t := + transitionTape_eq_self (read_ne_start_of_startInvariant hinv hhead) + +/-- Boundary contract consumed only by the proof-internal composition tail. -/ +def CompositionTailPre (nf ng : β„•) (y : List Bool) (B : β„•) + (inp : Tape) (work : Fin (compositionTapeCount nf ng) β†’ Tape) + (out : Tape) : Prop := + (work (compositionRawOutputIdx nf ng)).HasOutput y ∧ + Tape.StartInvariant (work (compositionRawOutputIdx nf ng)) ∧ + (work (compositionRawOutputIdx nf ng)).head ≀ B ∧ + work (compositionVirtualInputIdx nf ng) = (Tape.init []).move Dir3.right ∧ + (βˆ€ j : Fin ng, work (compositionSecondWorkIdx nf ng j) = + (Tape.init []).move Dir3.right) ∧ + out = (Tape.init []).move Dir3.right ∧ + Tape.StartInvariant inp ∧ 1 ≀ inp.head ∧ + (βˆ€ i : Fin nf, Tape.StartInvariant (work (compositionPrefixIdx nf ng i)) ∧ + 1 ≀ (work (compositionPrefixIdx nf ng i)).head) + +/-- Rewind raw output while preserving the input, output, and stable work-tape frame. -/ +private theorem compositionTail_rewindRawFrame + {nf ng : β„•} (y : List Bool) (B : β„•) + (inp : Tape) (work : Fin (compositionTapeCount nf ng) β†’ Tape) (out : Tape) + (hpre : CompositionTailPre nf ng y B inp work out) : + let raw := compositionRawOutputIdx nf ng + let source : Tape := { head := 1, cells := (work raw).cells } + βˆƒ (c₁ : Cfg (compositionTapeCount nf ng) (rewindWorkTM raw).Q) (t₁ : β„•), + (t₁ ≀ B + 2) ∧ + ((rewindWorkTM raw).reachesIn t₁ + { state := (rewindWorkTM raw).qstart, + input := inp, work := work, output := out } c₁) ∧ + ((rewindWorkTM raw).halted c₁) ∧ + (c₁.input = inp) ∧ + (c₁.output = out) ∧ + (βˆ€ i, i β‰  raw β†’ c₁.work i = work i) ∧ + (Tape.StartInvariant out) ∧ + (1 ≀ out.head) ∧ + (βˆ€ i, i β‰  raw β†’ + Tape.StartInvariant (work i) ∧ 1 ≀ (work i).head) ∧ + (c₁.work raw = source) ∧ + (Tape.StartInvariant source) ∧ + (source.HasOutput y) ∧ + (βˆ€ i, Tape.StartInvariant (c₁.work i) ∧ + 1 ≀ (c₁.work i).head) ∧ + (transitionInput c₁.input = c₁.input) ∧ + (transitionTape c₁.output = c₁.output) ∧ + (βˆ€ i, transitionTape (c₁.work i) = c₁.work i) := by + dsimp only + rcases hpre with + ⟨hrawOutput, hrawInv, hrawBound, hvinBlank, hgBlank, houtBlank, + hinv, hinputHead, hprefix⟩ + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + change (work raw).HasOutput y at hrawOutput + change Tape.StartInvariant (work raw) at hrawInv + change (work raw).head ≀ B at hrawBound + change work vin = (Tape.init []).move Dir3.right at hvinBlank + have hrawVin : raw β‰  vin := compositionRawOutputIdx_ne_virtualInputIdx nf ng + have houtInv : Tape.StartInvariant out := by + rw [houtBlank] + exact Tape.StartInvariant.init_nil.move Dir3.right + have houtHead : 1 ≀ out.head := by rw [houtBlank]; simp [Tape.move] + have hvinInv : Tape.StartInvariant (work vin) := by + rw [hvinBlank] + exact Tape.StartInvariant.init_nil.move Dir3.right + have hvinHead : 1 ≀ (work vin).head := by + rw [hvinBlank] + simp [Tape.move] + have hotherStable : βˆ€ i, i β‰  raw β†’ + Tape.StartInvariant (work i) ∧ 1 ≀ (work i).head := by + intro i hiRaw + by_cases hiPrefix : i.val < nf + Β· let j : Fin nf := ⟨i.val, hiPrefix⟩ + have hidx : compositionPrefixIdx nf ng j = i := by + apply Fin.ext + rfl + rw [← hidx] + exact hprefix j + by_cases hiVin : i = vin + Β· subst i + exact ⟨hvinInv, hvinHead⟩ + Β· have hiLower : nf + 1 ≀ i.val := by + have hneVal : i.val β‰  nf := by + intro heq + apply hiRaw + apply Fin.ext + simpa [raw] using! heq + omega + have hiUpper : i.val < nf + 1 + ng := by + have hlt := i.isLt + have hneVinVal : i.val β‰  nf + 1 + ng := by + intro heq + apply hiVin + apply Fin.ext + simpa [vin] using! heq + simp only [compositionTapeCount] at hlt + omega + let j : Fin ng := ⟨i.val - (nf + 1), by omega⟩ + have hidx : compositionSecondWorkIdx nf ng j = i := by + apply Fin.ext + simp [compositionSecondWorkIdx, placeWorkIdx, j] + omega + rw [← hidx, hgBlank j] + exact ⟨Tape.StartInvariant.init_nil.move Dir3.right, by simp [Tape.move]⟩ + let FrameRaw : TapePred (compositionTapeCount nf ng) := + fun inp' work' out' => + (work' raw).cells = (work raw).cells ∧ + inp' = inp ∧ out' = out ∧ βˆ€ i, i β‰  raw β†’ work' i = work i + have hrewRaw := rewindWorkTM_hoareTime_frame raw B + (P := FrameRaw) (by + intro inpβ‚€ workβ‚€ outβ‚€ inp' work' out' hframe hcells _hhead hother hinp' + houtCells houtHead' + rcases hframe with ⟨hrawCellsβ‚€, hinpβ‚€, houtβ‚€, hworkβ‚€βŸ© + have hout' : out' = outβ‚€ := Tape.ext houtHead' houtCells + exact ⟨hcells.trans hrawCellsβ‚€, hinp'.trans hinpβ‚€, + hout'.trans houtβ‚€, fun i hi => (hother i hi).trans (hworkβ‚€ i hi)⟩) + have hrewPre : + (work raw).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work raw).cells j β‰  Ξ“.start) ∧ + (work raw).head ≀ B ∧ inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  raw β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + FrameRaw inp work out := by + refine ⟨hrawInv.1, hrawInv.2, hrawBound, + read_ne_start_of_startInvariant hinv hinputHead, + read_ne_start_of_startInvariant houtInv houtHead, houtHead, ?_, ?_⟩ + Β· intro i hi + exact ⟨read_ne_start_of_startInvariant (hotherStable i hi).1 + (hotherStable i hi).2, (hotherStable i hi).2⟩ + Β· exact ⟨rfl, rfl, rfl, fun _ _ => rfl⟩ + obtain ⟨c₁, t₁, ht₁, hreach₁, hhalt₁, hc₁Head, hc₁Frame⟩ := + hrewRaw inp work out hrewPre + rcases hc₁Frame with ⟨hc₁RawCells, hc₁Input, hc₁Output, hc₁Other⟩ + let source : Tape := { head := 1, cells := (work raw).cells } + have hc₁Raw : c₁.work raw = source := Tape.ext hc₁Head hc₁RawCells + have hsourceInv : Tape.StartInvariant source := by + exact ⟨by simpa [source] using! hrawInv.1, + by intro j hj; simpa [source] using! hrawInv.2 j hj⟩ + have hsourceOutput : source.HasOutput y := by + exact (Tape.hasOutput_congr (by rfl) y).mpr hrawOutput + have hc₁WorkStable : βˆ€ i, Tape.StartInvariant (c₁.work i) ∧ + 1 ≀ (c₁.work i).head := by + intro i + by_cases hi : i = raw + Β· subst i + rw [hc₁Raw] + exact ⟨hsourceInv, by simp [source]⟩ + Β· rw [hc₁Other i hi] + exact hotherStable i hi + have hc₁InputTr : transitionInput c₁.input = c₁.input := by + rw [hc₁Input] + exact transitionInput_eq_self (read_ne_start_of_startInvariant hinv hinputHead) + have hc₁OutputTr : transitionTape c₁.output = c₁.output := by + rw [hc₁Output] + exact transitionTape_eq_of_startInvariant houtInv houtHead + have hc₁WorkTr : βˆ€ i, transitionTape (c₁.work i) = c₁.work i := by + intro i + exact transitionTape_eq_of_startInvariant (hc₁WorkStable i).1 + (hc₁WorkStable i).2 + exact ⟨c₁, t₁, + ht₁, hreach₁, hhalt₁, hc₁Input, hc₁Output, hc₁Other, + houtInv, houtHead, hotherStable, hc₁Raw, hsourceInv, + hsourceOutput, hc₁WorkStable, hc₁InputTr, hc₁OutputTr, hc₁WorkTr⟩ + +/-- Copy raw output to the virtual input and preserve the stable frame for rewinding. -/ +private theorem compositionTail_copyFrame + {nf ng : β„•} {Q : Type} (y : List Bool) + (inp : Tape) (work : Fin (compositionTapeCount nf ng) β†’ Tape) (out : Tape) + (c₁ : Cfg (compositionTapeCount nf ng) Q) + (hinv : Tape.StartInvariant inp) (hinputHead : 1 ≀ inp.head) + (hvinBlank : work (compositionVirtualInputIdx nf ng) = + (Tape.init []).move Dir3.right) : + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + let source : Tape := { head := 1, cells := (work raw).cells } + (c₁.input = inp) β†’ + (c₁.output = out) β†’ + (βˆ€ i, i β‰  raw β†’ c₁.work i = work i) β†’ + (Tape.StartInvariant out) β†’ + (1 ≀ out.head) β†’ + (βˆ€ i, i β‰  raw β†’ + Tape.StartInvariant (work i) ∧ 1 ≀ (work i).head) β†’ + (c₁.work raw = source) β†’ + (Tape.StartInvariant source) β†’ + (source.HasOutput y) β†’ + (transitionInput c₁.input = c₁.input) β†’ + (transitionTape c₁.output = c₁.output) β†’ + (βˆ€ i, transitionTape (c₁.work i) = c₁.work i) β†’ + βˆƒ (cβ‚‚ : Cfg (compositionTapeCount nf ng) (copyWorkToWorkTM raw vin).Q) (tβ‚‚ : β„•), + (tβ‚‚ ≀ y.length + 1) ∧ + ((copyWorkToWorkTM raw vin).reachesIn tβ‚‚ + { state := (copyWorkToWorkTM raw vin).qstart, + input := transitionInput c₁.input, + work := fun i => transitionTape (c₁.work i), + output := transitionTape c₁.output } cβ‚‚) ∧ + ((copyWorkToWorkTM raw vin).halted cβ‚‚) ∧ + (cβ‚‚.input = inp) ∧ + (cβ‚‚.output = out) ∧ + (βˆ€ i, i β‰  raw β†’ i β‰  vin β†’ cβ‚‚.work i = work i) ∧ + ((cβ‚‚.work vin).cells = + (Tape.init (y.map Ξ“.ofBool)).cells) ∧ + (Tape.StartInvariant (cβ‚‚.work vin)) ∧ + (βˆ€ i, Tape.StartInvariant (cβ‚‚.work i) ∧ + 1 ≀ (cβ‚‚.work i).head) ∧ + (transitionInput cβ‚‚.input = cβ‚‚.input) ∧ + (transitionTape cβ‚‚.output = cβ‚‚.output) ∧ + (βˆ€ i, transitionTape (cβ‚‚.work i) = cβ‚‚.work i) ∧ + ((cβ‚‚.work vin).head = y.length + 1) := by + dsimp only + intro hc₁Input hc₁Output hc₁Other houtInv houtHead hotherStable + hc₁Raw hsourceInv hsourceOutput hc₁InputTr hc₁OutputTr hc₁WorkTr + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + let source : Tape := { head := 1, cells := (work raw).cells } + have hrawVin : raw β‰  vin := compositionRawOutputIdx_ne_virtualInputIdx nf ng + let FrameCopy : TapePred (compositionTapeCount nf ng) := + fun inp' work' out' => + inp' = inp ∧ out' = out ∧ + βˆ€ i, i β‰  raw β†’ i β‰  vin β†’ work' i = work i + have hcopy := copyWorkToWorkTM_hoareTime_frame_of_hasOutput raw vin hrawVin y source + (P := FrameCopy) (by + intro inpβ‚€ workβ‚€ outβ‚€ inp' work' out' hframe _hsrcCells _hsrcHead + _hsrcOutput _hdstPrefix _hdst0 hinp' hout' hother + rcases hframe with ⟨hinpβ‚€, houtβ‚€, hworkβ‚€βŸ© + exact ⟨hinp'.trans hinpβ‚€, hout'.trans houtβ‚€, + fun i hiRaw hiVin => (hother i hiRaw hiVin).trans (hworkβ‚€ i hiRaw hiVin)⟩) + have hcopyPre : + (fun i => transitionTape (c₁.work i)) raw = source ∧ + source.head = 1 ∧ source.HasOutput y ∧ + (fun i => transitionTape (c₁.work i)) vin = + (Tape.init []).move Dir3.right ∧ + (transitionInput c₁.input).read β‰  Ξ“.start ∧ + (transitionTape c₁.output).read β‰  Ξ“.start ∧ + 1 ≀ (transitionTape c₁.output).head ∧ + (βˆ€ i, i β‰  raw β†’ i β‰  vin β†’ + ((fun i => transitionTape (c₁.work i)) i).read β‰  Ξ“.start ∧ + 1 ≀ ((fun i => transitionTape (c₁.work i)) i).head) ∧ + FrameCopy (transitionInput c₁.input) + (fun i => transitionTape (c₁.work i)) (transitionTape c₁.output) := by + refine ⟨?_, rfl, hsourceOutput, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· change transitionTape (c₁.work raw) = source + rw [hc₁WorkTr raw, hc₁Raw] + Β· change transitionTape (c₁.work vin) = (Tape.init []).move Dir3.right + rw [hc₁WorkTr vin, hc₁Other vin hrawVin.symm, hvinBlank] + Β· rw [hc₁InputTr, hc₁Input] + exact read_ne_start_of_startInvariant hinv hinputHead + Β· rw [hc₁OutputTr, hc₁Output] + exact read_ne_start_of_startInvariant houtInv houtHead + Β· rw [hc₁OutputTr, hc₁Output] + exact houtHead + Β· intro i hiRaw hiVin + change (transitionTape (c₁.work i)).read β‰  Ξ“.start ∧ + 1 ≀ (transitionTape (c₁.work i)).head + rw [hc₁WorkTr i, hc₁Other i hiRaw] + exact ⟨read_ne_start_of_startInvariant (hotherStable i hiRaw).1 + (hotherStable i hiRaw).2, (hotherStable i hiRaw).2⟩ + Β· refine ⟨?_, ?_, ?_⟩ + Β· rw [hc₁InputTr, hc₁Input] + Β· rw [hc₁OutputTr, hc₁Output] + Β· intro i hiRaw hiVin + change transitionTape (c₁.work i) = work i + rw [hc₁WorkTr i, hc₁Other i hiRaw] + obtain ⟨cβ‚‚, tβ‚‚, htβ‚‚, hreachβ‚‚, hhaltβ‚‚, hcβ‚‚RawCells, + hcβ‚‚RawHead, hcβ‚‚RawOutput, hcβ‚‚VinPrefix, hcβ‚‚Vin0, hcβ‚‚Frame⟩ := + hcopy (transitionInput c₁.input) (fun i => transitionTape (c₁.work i)) + (transitionTape c₁.output) hcopyPre + rcases hcβ‚‚Frame with ⟨hcβ‚‚Input, hcβ‚‚Output, hcβ‚‚Other⟩ + have hcβ‚‚VinCells : (cβ‚‚.work vin).cells = + (Tape.init (y.map Ξ“.ofBool)).cells := + hcβ‚‚VinPrefix.cells_eq_init hcβ‚‚Vin0 + have hcβ‚‚RawInv : Tape.StartInvariant (cβ‚‚.work raw) := by + refine ⟨?_, ?_⟩ + Β· rw [hcβ‚‚RawCells] + exact hsourceInv.1 + Β· intro j hj + rw [hcβ‚‚RawCells] + exact hsourceInv.2 j hj + have hcβ‚‚VinInv : Tape.StartInvariant (cβ‚‚.work vin) := by + refine ⟨?_, ?_⟩ + Β· rw [hcβ‚‚VinCells] + rfl + Β· intro j hj + rw [hcβ‚‚VinCells] + exact Tape.init_ofBool_cells_ne_start y j hj + have hcβ‚‚WorkStable : βˆ€ i, Tape.StartInvariant (cβ‚‚.work i) ∧ + 1 ≀ (cβ‚‚.work i).head := by + intro i + by_cases hiRaw : i = raw + Β· subst i + exact ⟨hcβ‚‚RawInv, by omega⟩ + by_cases hiVin : i = vin + Β· subst i + refine ⟨hcβ‚‚VinInv, ?_⟩ + rw [hcβ‚‚VinPrefix.1] + omega + Β· rw [hcβ‚‚Other i hiRaw hiVin] + exact hotherStable i hiRaw + have hcβ‚‚InputTr : transitionInput cβ‚‚.input = cβ‚‚.input := by + rw [hcβ‚‚Input] + exact transitionInput_eq_self (read_ne_start_of_startInvariant hinv hinputHead) + have hcβ‚‚OutputTr : transitionTape cβ‚‚.output = cβ‚‚.output := by + rw [hcβ‚‚Output] + exact transitionTape_eq_of_startInvariant houtInv houtHead + have hcβ‚‚WorkTr : βˆ€ i, transitionTape (cβ‚‚.work i) = cβ‚‚.work i := by + intro i + exact transitionTape_eq_of_startInvariant (hcβ‚‚WorkStable i).1 + (hcβ‚‚WorkStable i).2 + exact ⟨cβ‚‚, tβ‚‚, htβ‚‚, hreachβ‚‚, hhaltβ‚‚, hcβ‚‚Input, hcβ‚‚Output, hcβ‚‚Other, + hcβ‚‚VinCells, hcβ‚‚VinInv, hcβ‚‚WorkStable, hcβ‚‚InputTr, hcβ‚‚OutputTr, hcβ‚‚WorkTr, + hcβ‚‚VinPrefix.1⟩ + +/-- The placed virtual-input configuration equals the restored composition entry frame. -/ +private theorem compositionTail_placedEntry + {nf ng : β„•} (tmG : TM ng) (y : List Bool) + (work workβ‚‚ work₃ : Fin (compositionTapeCount nf ng) β†’ Tape) + (out out₃ input₃ : Tape) + (hgBlank : βˆ€ j : Fin ng, work (compositionSecondWorkIdx nf ng j) = + (Tape.init []).move Dir3.right) + (hcβ‚‚Other : βˆ€ i, i β‰  compositionRawOutputIdx nf ng β†’ + i β‰  compositionVirtualInputIdx nf ng β†’ workβ‚‚ i = work i) + (hc₃Other : βˆ€ i, i β‰  compositionVirtualInputIdx nf ng β†’ work₃ i = workβ‚‚ i) + (hc₃WorkTr : βˆ€ i, transitionTape (work₃ i) = work₃ i) + (hc₃Vin : work₃ (compositionVirtualInputIdx nf ng) = + (Tape.init (y.map Ξ“.ofBool)).move Dir3.right) + (houtBlank : out = (Tape.init []).move Dir3.right) + (hc₃Output : out₃ = out) (hc₃OutputTr : transitionTape out₃ = out₃) : + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + let secondPre := 0 + (nf + 1) + let extras : Fin (secondPre + (ng + 1) + 0) β†’ Tape := + fun i => transitionTape (work₃ i) + let realInput := transitionInput input₃ + let gEntry : Cfg (compositionTapeCount nf ng) (compositionSecondTM nf tmG).Q := + { state := (compositionSecondTM nf tmG).qstart + input := transitionInput input₃ + work := fun i => transitionTape (work₃ i) + output := transitionTape out₃ } + placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput) = gEntry := by + dsimp only + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + let secondPre := 0 + (nf + 1) + let extras : Fin (secondPre + (ng + 1) + 0) β†’ Tape := + fun i => transitionTape (work₃ i) + let realInput := transitionInput input₃ + let gEntry : Cfg (compositionTapeCount nf ng) (compositionSecondTM nf tmG).Q := + { state := (compositionSecondTM nf tmG).qstart + input := transitionInput input₃ + work := fun i => transitionTape (work₃ i) + output := transitionTape out₃ } + refine Cfg.ext rfl rfl ?_ ?_ + Β· funext i + by_cases hmid : placeWorkInMiddle secondPre (ng + 1) i + Β· let j := placeWorkCoord secondPre (ng + 1) i hmid + have hphys : placeWorkIdx secondPre 0 j = i := + placeWorkIdx_placeWorkCoord i hmid + by_cases hj : j.val < ng + Β· let jG : Fin ng := ⟨j.val, hj⟩ + have hjcast : Fin.castSucc jG = j := by + apply Fin.ext + rfl + have hiVal : i.val = secondPre + j.val := by + have hv := congrArg Fin.val hphys + simp only [placeWorkIdx_val] at hv + omega + have hiRaw : i β‰  raw := by + change i β‰  compositionRawOutputIdx nf ng + intro heq + have hv := congrArg Fin.val heq + simp only [compositionRawOutputIdx_val] at hv + dsimp only [secondPre] at hiVal + omega + have hiVin : i β‰  vin := by + change i β‰  compositionVirtualInputIdx nf ng + intro heq + have hv := congrArg Fin.val heq + simp only [compositionVirtualInputIdx_val] at hv + dsimp only [secondPre] at hiVal + omega + have hblank : work₃ i = (Tape.init []).move Dir3.right := by + calc + work₃ i = workβ‚‚ i := hc₃Other i hiVin + _ = work i := hcβ‚‚Other i hiRaw hiVin + _ = (Tape.init []).move Dir3.right := by + rw [← hphys, ← hjcast] + exact hgBlank jG + change + (placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput)).work i = + transitionTape (work₃ i) + calc + _ = (retargetInputStartedCfg tmG y realInput).work j := by + rw [← hphys, placeWorkCfg_work_middle] + _ = (Tape.init []).move Dir3.right := by + exact retargetInputStartedCfg_work_lt tmG y realInput j hj + _ = transitionTape (work₃ i) := by + rw [hc₃WorkTr i, hblank] + Β· have hjval : j.val = ng := by + have := j.isLt + omega + have hjlast : j = Fin.last ng := by + apply Fin.ext + simpa using! hjval + have hiVin : i = vin := by + rw [← hphys, hjlast] + exact (compositionVirtualInputIdx_eq_secondPlacedLast nf ng).symm + change + (placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput)).work i = + transitionTape (work₃ i) + calc + _ = (retargetInputStartedCfg tmG y realInput).work j := by + rw [← hphys, placeWorkCfg_work_middle] + _ = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right := by + rw [hjlast] + simp [Fin.last] + _ = transitionTape (work₃ i) := by + rw [hiVin, hc₃WorkTr vin, hc₃Vin] + Β· change + (placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput)).work i = + transitionTape (work₃ i) + rw [placeWorkCfg_work_extra _ _ _ _ _ i hmid] + Β· change (retargetInputStartedCfg tmG y realInput).output = + transitionTape out₃ + rw [retargetInputStartedCfg_output, hc₃OutputTr, hc₃Output, houtBlank] + +/-- Generic post-first-computation tail driven by a virtual-input run contract. + +The prefix tapes are arbitrary stable frame tapes. The raw tape may initially +have any head up to `B`, and cells after its first output delimiter may contain +arbitrary junk. The virtual-input tape, second-machine scratch block, and real +output begin in their canonical parked blank shapes. -/ +private theorem compositionTailTM_hoareTime_of_virtualRun_internal + {nf ng : β„•} (tmG : TM ng) {G : β„• β†’ β„•} + (y : List Bool) (B : β„•) (P : Tape β†’ Prop) + (hG : βˆ€ realInput : Tape, + βˆƒ (c' : Cfg (ng + 1) tmG.Q) (t : β„•), + t ≀ G y.length ∧ + (retargetInputStarted tmG).reachesIn t + (retargetInputStartedCfg tmG y realInput) c' ∧ + (retargetInputStarted tmG).halted c' ∧ P c'.output) : + (compositionTailTM nf ng tmG).HoareTime + (CompositionTailPre nf ng y B) + (fun _inp _work out => P out) + ((B + 2) + 1 + ((y.length + 1) + 1 + + ((y.length + 1 + 2) + 1 + G y.length))) := by + intro inp work out hpre + let raw := compositionRawOutputIdx nf ng + let vin := compositionVirtualInputIdx nf ng + let source : Tape := { head := 1, cells := (work raw).cells } + obtain ⟨c₁, t₁, + ht₁, hreach₁, hhalt₁, hc₁Input, hc₁Output, hc₁Other, + houtInv, houtHead, hotherStable, hc₁Raw, hsourceInv, + hsourceOutput, hc₁WorkStable, hc₁InputTr, hc₁OutputTr, hc₁WorkTr⟩ := + compositionTail_rewindRawFrame y B inp work out hpre + rcases hpre with + ⟨hrawOutput, hrawInv, hrawBound, hvinBlank, hgBlank, houtBlank, + hinv, hinputHead, hprefix⟩ + have hrawVin : raw β‰  vin := compositionRawOutputIdx_ne_virtualInputIdx nf ng + obtain ⟨cβ‚‚, tβ‚‚, htβ‚‚, hreachβ‚‚, hhaltβ‚‚, hcβ‚‚Input, hcβ‚‚Output, hcβ‚‚Other, + hcβ‚‚VinCells, hcβ‚‚VinInv, hcβ‚‚WorkStable, hcβ‚‚InputTr, hcβ‚‚OutputTr, hcβ‚‚WorkTr, + hcβ‚‚VinHead⟩ := + compositionTail_copyFrame y inp work out c₁ hinv hinputHead hvinBlank + hc₁Input hc₁Output hc₁Other houtInv houtHead hotherStable + hc₁Raw hsourceInv hsourceOutput hc₁InputTr hc₁OutputTr hc₁WorkTr + let FrameVin : TapePred (compositionTapeCount nf ng) := + fun inp' work' out' => + (work' vin).cells = (Tape.init (y.map Ξ“.ofBool)).cells ∧ + inp' = inp ∧ out' = out ∧ βˆ€ i, i β‰  vin β†’ work' i = cβ‚‚.work i + have hrewVin := rewindWorkTM_hoareTime_frame vin (y.length + 1) + (P := FrameVin) (by + intro inpβ‚€ workβ‚€ outβ‚€ inp' work' out' hframe hcells _hhead hother hinp' + houtCells houtHead' + rcases hframe with ⟨hvinCellsβ‚€, hinpβ‚€, houtβ‚€, hworkβ‚€βŸ© + have hout' : out' = outβ‚€ := Tape.ext houtHead' houtCells + exact ⟨hcells.trans hvinCellsβ‚€, hinp'.trans hinpβ‚€, + hout'.trans houtβ‚€, fun i hi => (hother i hi).trans (hworkβ‚€ i hi)⟩) + have hrewVinPre : + ((fun i => transitionTape (cβ‚‚.work i)) vin).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ ((fun i => transitionTape (cβ‚‚.work i)) vin).cells j β‰  + Ξ“.start) ∧ + ((fun i => transitionTape (cβ‚‚.work i)) vin).head ≀ y.length + 1 ∧ + (transitionInput cβ‚‚.input).read β‰  Ξ“.start ∧ + (transitionTape cβ‚‚.output).read β‰  Ξ“.start ∧ + (transitionTape cβ‚‚.output).head β‰₯ 1 ∧ + (βˆ€ i, i β‰  vin β†’ + ((fun i => transitionTape (cβ‚‚.work i)) i).read β‰  Ξ“.start ∧ + ((fun i => transitionTape (cβ‚‚.work i)) i).head β‰₯ 1) ∧ + FrameVin (transitionInput cβ‚‚.input) + (fun i => transitionTape (cβ‚‚.work i)) (transitionTape cβ‚‚.output) := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· change (transitionTape (cβ‚‚.work vin)).cells 0 = Ξ“.start + rw [hcβ‚‚WorkTr vin] + exact hcβ‚‚VinInv.1 + Β· intro j hj + change (transitionTape (cβ‚‚.work vin)).cells j β‰  Ξ“.start + rw [hcβ‚‚WorkTr vin] + exact hcβ‚‚VinInv.2 j hj + Β· change (transitionTape (cβ‚‚.work vin)).head ≀ y.length + 1 + rw [hcβ‚‚WorkTr vin, hcβ‚‚VinHead] + Β· rw [hcβ‚‚InputTr, hcβ‚‚Input] + exact read_ne_start_of_startInvariant hinv hinputHead + Β· rw [hcβ‚‚OutputTr, hcβ‚‚Output] + exact read_ne_start_of_startInvariant houtInv houtHead + Β· rw [hcβ‚‚OutputTr, hcβ‚‚Output] + exact houtHead + Β· intro i hi + change (transitionTape (cβ‚‚.work i)).read β‰  Ξ“.start ∧ + (transitionTape (cβ‚‚.work i)).head β‰₯ 1 + rw [hcβ‚‚WorkTr i] + exact ⟨read_ne_start_of_startInvariant (hcβ‚‚WorkStable i).1 + (hcβ‚‚WorkStable i).2, (hcβ‚‚WorkStable i).2⟩ + Β· refine ⟨?_, ?_, ?_, ?_⟩ + Β· change (transitionTape (cβ‚‚.work vin)).cells = + (Tape.init (y.map Ξ“.ofBool)).cells + rw [hcβ‚‚WorkTr vin] + exact hcβ‚‚VinCells + Β· rw [hcβ‚‚InputTr, hcβ‚‚Input] + Β· rw [hcβ‚‚OutputTr, hcβ‚‚Output] + Β· intro i hi + change transitionTape (cβ‚‚.work i) = cβ‚‚.work i + rw [hcβ‚‚WorkTr i] + obtain ⟨c₃, t₃, ht₃, hreach₃, hhalt₃, hc₃VinHead, hc₃Frame⟩ := + hrewVin (transitionInput cβ‚‚.input) (fun i => transitionTape (cβ‚‚.work i)) + (transitionTape cβ‚‚.output) hrewVinPre + rcases hc₃Frame with ⟨hc₃VinCells, hc₃Input, hc₃Output, hc₃Other⟩ + have hc₃Vin : c₃.work vin = + (Tape.init (y.map Ξ“.ofBool)).move Dir3.right := by + exact Tape.ext hc₃VinHead hc₃VinCells + have hc₃WorkStable : βˆ€ i, Tape.StartInvariant (c₃.work i) ∧ + 1 ≀ (c₃.work i).head := by + intro i + by_cases hi : i = vin + Β· subst i + rw [hc₃Vin] + exact ⟨Tape.StartInvariant.init_ofBool y |>.move Dir3.right, by simp [Tape.move]⟩ + Β· rw [hc₃Other i hi] + exact hcβ‚‚WorkStable i + have hc₃InputTr : transitionInput c₃.input = c₃.input := by + rw [hc₃Input] + exact transitionInput_eq_self (read_ne_start_of_startInvariant hinv hinputHead) + have hc₃OutputTr : transitionTape c₃.output = c₃.output := by + rw [hc₃Output] + exact transitionTape_eq_of_startInvariant houtInv houtHead + have hc₃WorkTr : βˆ€ i, transitionTape (c₃.work i) = c₃.work i := by + intro i + exact transitionTape_eq_of_startInvariant (hc₃WorkStable i).1 + (hc₃WorkStable i).2 + let secondPre := 0 + (nf + 1) + let extras : Fin (secondPre + (ng + 1) + 0) β†’ Tape := + fun i => transitionTape (c₃.work i) + let realInput := transitionInput c₃.input + have hextrasInv : βˆ€ i, Β¬placeWorkInMiddle secondPre (ng + 1) i β†’ + Tape.StartInvariant (extras i) := by + intro i _hi + rw [show extras i = c₃.work i from hc₃WorkTr i] + exact (hc₃WorkStable i).1 + have hextrasHead : βˆ€ i, Β¬placeWorkInMiddle secondPre (ng + 1) i β†’ + 1 ≀ (extras i).head := by + intro i _hi + rw [show extras i = c₃.work i from hc₃WorkTr i] + exact (hc₃WorkStable i).2 + obtain ⟨cβ‚„, tβ‚„, htβ‚„, hreachSourceβ‚„, hhaltSourceβ‚„, houtβ‚„βŸ© := hG realInput + let Cβ‚„ := placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras cβ‚„ + have hreachβ‚„ : + (placeWorkTM secondPre 0 (retargetInputStarted tmG)).reachesIn tβ‚„ + (placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput)) Cβ‚„ := by + apply placeWorkTM_reachesIn_placeWorkCfg_stable_internal + (retargetInputStarted tmG) secondPre 0 extras hreachSourceβ‚„ + intro i hi + show (extras i).cells (extras i).head β‰  Ξ“.start + exact (hextrasInv i hi).2 (extras i).head (hextrasHead i hi) + have hhaltβ‚„ : + (placeWorkTM secondPre 0 (retargetInputStarted tmG)).halted Cβ‚„ := by + show cβ‚„.state = (retargetInputStarted tmG).qhalt + exact hhaltSourceβ‚„ + let gEntry : Cfg (compositionTapeCount nf ng) (compositionSecondTM nf tmG).Q := + { state := (compositionSecondTM nf tmG).qstart + input := transitionInput c₃.input + work := fun i => transitionTape (c₃.work i) + output := transitionTape c₃.output } + have hEntry : + placeWorkCfg (retargetInputStarted tmG) secondPre 0 extras + (retargetInputStartedCfg tmG y realInput) = gEntry := by + exact compositionTail_placedEntry (nf := nf) tmG y work cβ‚‚.work c₃.work + out c₃.output c₃.input hgBlank hcβ‚‚Other hc₃Other hc₃WorkTr hc₃Vin + houtBlank hc₃Output hc₃OutputTr + have hreachβ‚„' : (compositionSecondTM nf tmG).reachesIn tβ‚„ gEntry Cβ‚„ := by + change (placeWorkTM secondPre 0 (retargetInputStarted tmG)).reachesIn tβ‚„ gEntry Cβ‚„ + rw [← hEntry] + exact hreachβ‚„ + let tm₃ := rewindWorkTM vin + let tmβ‚‚ := copyWorkToWorkTM raw vin + let tm₁ := rewindWorkTM raw + let c₃₄ := phase2Wrap tm₃ (compositionSecondTM nf tmG) Cβ‚„ + have hreach₃₄ : (seqTM tm₃ (compositionSecondTM nf tmG)).reachesIn + (t₃ + 1 + tβ‚„) + (phase1Wrap tm₃ (compositionSecondTM nf tmG) + { state := tm₃.qstart, input := transitionInput cβ‚‚.input, + work := fun i => transitionTape (cβ‚‚.work i), + output := transitionTape cβ‚‚.output }) c₃₄ := by + exact seqTM_reachesIn_of_reachesIn tm₃ (compositionSecondTM nf tmG) + hreach₃ hhalt₃ hreachβ‚„' + let tm₃₄ := seqTM tm₃ (compositionSecondTM nf tmG) + let c₂₃₄ := phase2Wrap tmβ‚‚ tm₃₄ c₃₄ + have hreach₂₃₄ : (seqTM tmβ‚‚ tm₃₄).reachesIn + (tβ‚‚ + 1 + (t₃ + 1 + tβ‚„)) + (phase1Wrap tmβ‚‚ tm₃₄ + { state := tmβ‚‚.qstart, input := transitionInput c₁.input, + work := fun i => transitionTape (c₁.work i), + output := transitionTape c₁.output }) c₂₃₄ := by + exact seqTM_reachesIn_of_reachesIn tmβ‚‚ tm₃₄ hreachβ‚‚ hhaltβ‚‚ hreach₃₄ + let tm₂₃₄ := seqTM tmβ‚‚ tm₃₄ + let cFinal := phase2Wrap tm₁ tm₂₃₄ c₂₃₄ + have hreachFinal : (compositionTailTM nf ng tmG).reachesIn + (t₁ + 1 + (tβ‚‚ + 1 + (t₃ + 1 + tβ‚„))) + { state := (compositionTailTM nf ng tmG).qstart, + input := inp, work := work, output := out } cFinal := by + change (seqTM tm₁ tm₂₃₄).reachesIn _ _ _ + exact seqTM_reachesIn_of_reachesIn tm₁ tm₂₃₄ + hreach₁ hhalt₁ hreach₂₃₄ + refine ⟨cFinal, t₁ + 1 + (tβ‚‚ + 1 + (t₃ + 1 + tβ‚„)), ?_, + hreachFinal, ?_, ?_⟩ + Β· omega + Β· change (seqTM tm₁ tm₂₃₄).halted cFinal + exact (phase2Wrap_halted_iff tm₁ tm₂₃₄ c₂₃₄).mpr + ((phase2Wrap_halted_iff tmβ‚‚ tm₃₄ c₃₄).mpr + ((phase2Wrap_halted_iff tm₃ (compositionSecondTM nf tmG) Cβ‚„).mpr hhaltβ‚„)) + Β· show P Cβ‚„.output + exact houtβ‚„ + +/-- The post-first-computation tail correctly runs the second function. -/ +theorem compositionTailTM_hoareTime_internal {nf ng : β„•} (tmG : TM ng) + {g : List Bool β†’ List Bool} {G : β„• β†’ β„•} + (hG : tmG.ComputesInTime g G) (y : List Bool) (B : β„•) : + (compositionTailTM nf ng tmG).HoareTime + (CompositionTailPre nf ng y B) + (fun _inp _work out => out.HasOutput (g y)) + ((B + 2) + 1 + ((y.length + 1) + 1 + + ((y.length + 1 + 2) + 1 + G y.length))) := by + apply compositionTailTM_hoareTime_of_virtualRun_internal tmG y B + (fun out => out.HasOutput (g y)) + intro realInput + exact retargetInputStarted_computesVirtual tmG hG y realInput + +/-- The same tail pipeline retains a second machine's decision verdict. -/ +theorem compositionTailTM_decides_hoareTime_internal {nf ng : β„•} (tmG : TM ng) + {L : Language} {G : β„• β†’ β„•} + (hG : tmG.DecidesInTime L G) (y : List Bool) (B : β„•) : + (compositionTailTM nf ng tmG).HoareTime + (CompositionTailPre nf ng y B) + (fun _inp _work out => + (y ∈ L β†’ out.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ out.cells 1 = Ξ“.zero)) + ((B + 2) + 1 + ((y.length + 1) + 1 + + ((y.length + 1 + 2) + 1 + G y.length))) := by + apply compositionTailTM_hoareTime_of_virtualRun_internal tmG y B + (fun out => + (y ∈ L β†’ out.cells 1 = Ξ“.one) ∧ + (y βˆ‰ L β†’ out.cells 1 = Ξ“.zero)) + intro realInput + exact retargetInputStarted_decidesVirtual tmG hG y realInput + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput.lean new file mode 100644 index 0000000000..486b7f1e69 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Internal + +/-! +# Pair a computed value with the original input + +This module exposes a generic deterministic fanout combinator. If `tmF` +computes `f`, then `pairWithInputTM tmF` computes `x ↦ pair (f x) x` while +retaining a concrete polynomial-preserving time bound. + +## Main result + +- `TM.pairWithInputTM_computesInTime` β€” computation paired with original input +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf : β„•} + +/-- Pairing a computed string with the unchanged original input costs at most +five source-time budgets, one linear input scan, and constant seam overhead. -/ +theorem pairWithInputTM_computesInTime + {tmF : TM nf} {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : tmF.ComputesInTime f T) : + (pairWithInputTM tmF).ComputesInTime + (fun x => pair (f x) x) (pairWithInputTime T) := + pairWithInputTM_computesInTime_internal hcomp + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Defs.lean new file mode 100644 index 0000000000..dd241b258a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Defs.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Defs + +/-! +# Pair a computed value with the original input + +This file defines a generic deterministic pipeline for the fanout operation +`x ↦ pair (f x) x`. It redirects the computed value to a work tape, rewinds +that tape and the immutable original input, then emits both components +directly to the real output. Only the first raw-output delimiter is semantic; +later cells may contain arbitrary non-`β–·` junk. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf : β„•} + +/-- Work-tape count of `pairWithInputTM`. One extra tape beyond the redirected +output is kept as a stable phase-composition frame. -/ +abbrev pairWithInputTapeCount (nf : β„•) := compositionTapeCount nf 0 + +/-- Physical work tape holding the raw output of the function computation. -/ +def pairWithInputRawOutputIdx (nf : β„•) : Fin (pairWithInputTapeCount nf) := + compositionRawOutputIdx nf 0 + +/-- First phase of `pairWithInputTM`: compute with the output redirected to +the raw-output work tape. -/ +def pairWithInputFirstTM (tmF : TM nf) : TM (pairWithInputTapeCount nf) := + compositionFirstTM tmF 0 + +/-- Normalize the two read heads, then emit the computed value paired with +the unchanged original input. -/ +def pairWithInputTailTM (nf : β„•) : TM (pairWithInputTapeCount nf) := + seqTM (rewindWorkTM (pairWithInputRawOutputIdx nf)) + (seqTM rewindInputTM (pairInputWorkTM (pairWithInputRawOutputIdx nf))) + +/-- Executable deterministic fanout combinator computing +`x ↦ pair (f x) x` whenever `tmF` computes `f`. -/ +def pairWithInputTM (tmF : TM nf) : TM (pairWithInputTapeCount nf) := + seqTM (pairWithInputFirstTM tmF) (pairWithInputTailTM nf) + +/-- Coarse time budget for `pairWithInputTM`. It covers the source run, both +rewinds, pair emission, and the three phase transitions. -/ +def pairWithInputTime (sourceTime : β„• β†’ β„•) (inputLength : β„•) : β„• := + 5 * sourceTime inputLength + inputLength + 12 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Internal.lean new file mode 100644 index 0000000000..2323ed9074 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Composition/PairWithInput/Internal.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.Internal.FirstPhase +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Composition.PairWithInput.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.OutputBounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit + +/-! +# Pair a computed value with the original input β€” proof internals + +This module verifies the generic fanout pipeline defined in +`Composition.PairWithInput.Defs`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {nf : β„•} + +/-- Boundary contract after the source computation has redirected its output. +Both source heads remain within `B`, every tape is safely parked away from the +left marker, and the real output is fresh for pair emission. -/ +def PairWithInputTailPre (nf : β„•) (first second : List Bool) (B : β„•) + (inp : Tape) (work : Fin (pairWithInputTapeCount nf) β†’ Tape) + (out : Tape) : Prop := + let raw := pairWithInputRawOutputIdx nf + (work raw).HasOutput first ∧ + (work raw).StartInvariant ∧ + (work raw).head ≀ B ∧ + inp.cells = (Tape.init (second.map Ξ“.ofBool)).cells ∧ + inp.StartInvariant ∧ + 1 ≀ inp.head ∧ + inp.head ≀ B ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right + +/-- Boundary after rewinding the raw computed output. -/ +private def PairWithInputAfterRaw (nf : β„•) (first second : List Bool) (B : β„•) + (inp : Tape) (work : Fin (pairWithInputTapeCount nf) β†’ Tape) + (out : Tape) : Prop := + let raw := pairWithInputRawOutputIdx nf + (work raw).head = 1 ∧ + (work raw).HasOutput first ∧ + inp.cells = (Tape.init (second.map Ξ“.ofBool)).cells ∧ + inp.StartInvariant ∧ + 1 ≀ inp.head ∧ + inp.head ≀ B ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right + +/-- Boundary after also rewinding the immutable original input. -/ +private def PairWithInputEmitterPre (nf : β„•) (first second : List Bool) + (inp : Tape) (work : Fin (pairWithInputTapeCount nf) β†’ Tape) + (out : Tape) : Prop := + let raw := pairWithInputRawOutputIdx nf + inp = (Tape.init (second.map Ξ“.ofBool)).move Dir3.right ∧ + (work raw).head = 1 ∧ + (work raw).HasOutput first ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right + +/-- The normalization-and-emission tail turns a raw delimited source output +and the original input into their canonical pair. -/ +theorem pairWithInputTailTM_hoareTime_internal (nf : β„•) + (first second : List Bool) (B : β„•) : + (pairWithInputTailTM nf).HoareTime + (PairWithInputTailPre nf first second B) + (fun _inp _work out => out.HasOutput (pair first second)) + (2 * B + pairInputWorkTime first second + 6) := by + let raw := pairWithInputRawOutputIdx nf + let RawFrame : TapePred (pairWithInputTapeCount nf) := + fun inp work out => + (work raw).HasOutput first ∧ + inp.cells = (Tape.init (second.map Ξ“.ofBool)).cells ∧ + inp.StartInvariant ∧ + 1 ≀ inp.head ∧ + inp.head ≀ B ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right + have hrewRaw := rewindWorkTM_hoareTime_frame raw B + (P := RawFrame) (by + intro inp work out inp' work' out' hframe hrawCells hrawHead + hother hinp houtCells houtHead + rcases hframe with + ⟨hrawOutput, hinputCells, hinputInv, hinputHead, hinputBound, + hworkInv, hout⟩ + have hout' : out' = out := Tape.ext houtHead houtCells + have hrawOutput' : (work' raw).HasOutput first := + (Tape.hasOutput_congr hrawCells first).mpr hrawOutput + have hrawInv' : (work' raw).StartInvariant := by + refine ⟨?_, ?_⟩ + Β· rw [hrawCells] + exact (hworkInv raw).1.1 + Β· intro j hj + rw [hrawCells] + exact (hworkInv raw).1.2 j hj + refine ⟨hrawOutput', hinp β–Έ hinputCells, hinp β–Έ hinputInv, + hinp β–Έ hinputHead, hinp β–Έ hinputBound, ?_, hout' β–Έ hout⟩ + intro i + by_cases hi : i = raw + Β· subst i + exact ⟨hrawInv', by omega⟩ + Β· rw [hother i hi] + exact hworkInv i) + have hrewRaw' : + (rewindWorkTM raw).HoareTime + (PairWithInputTailPre nf first second B) + (PairWithInputAfterRaw nf first second B) + (B + 2) := by + apply hrewRaw.consequence (b' := B + 2) + Β· intro inp work out hpre + rcases hpre with + ⟨hrawOutput, hrawInv, hrawBound, hinputCells, hinputInv, + hinputHead, hinputBound, hworkInv, hout⟩ + refine ⟨hrawInv.1, hrawInv.2, hrawBound, + hinputInv.read_ne_start hinputHead, ?_, ?_, ?_, ?_⟩ + Β· rw [hout] + decide + Β· rw [hout] + simp [Tape.move] + Β· intro i hi + exact ⟨(hworkInv i).1.read_ne_start (hworkInv i).2, (hworkInv i).2⟩ + Β· exact ⟨hrawOutput, hinputCells, hinputInv, hinputHead, + hinputBound, hworkInv, hout⟩ + Β· intro inp work out hpost + rcases hpost with ⟨hrawHead, hrawOutput, hinputCells, + hinputInv, hinputHead, hinputBound, hworkInv, hout⟩ + exact ⟨hrawHead, hrawOutput, hinputCells, hinputInv, + hinputHead, hinputBound, hworkInv, hout⟩ + Β· exact le_rfl + let InputFrame : TapePred (pairWithInputTapeCount nf) := + fun inp work out => + inp.cells = (Tape.init (second.map Ξ“.ofBool)).cells ∧ + (work raw).head = 1 ∧ + (work raw).HasOutput first ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right + have hrewInput := rewindInputTM_hoareTime_frame B + (P := InputFrame) (by + intro inp work out inp' work' out' hframe hinputCells _hinputHead + hwork hout + rcases hframe with + ⟨hcanonical, hrawHead, hrawOutput, hworkInv, houtEq⟩ + subst work' + subst out' + exact ⟨hinputCells.trans hcanonical, hrawHead, hrawOutput, + hworkInv, houtEq⟩) + have hrewInput' : + rewindInputTM.HoareTime + (PairWithInputAfterRaw nf first second B) + (PairWithInputEmitterPre nf first second) + (B + 2) := by + apply hrewInput.consequence (b' := B + 2) + Β· intro inp work out hpre + rcases hpre with + ⟨hrawHead, hrawOutput, hinputCells, hinputInv, + hinputHead, hinputBound, hworkInv, hout⟩ + refine ⟨hinputInv.1, hinputInv.2, hinputBound, ?_, ?_, ?_, ?_⟩ + Β· rw [hout] + decide + Β· rw [hout] + simp [Tape.move] + Β· intro i + exact ⟨(hworkInv i).1.read_ne_start (hworkInv i).2, (hworkInv i).2⟩ + Β· exact ⟨hinputCells, hrawHead, hrawOutput, hworkInv, hout⟩ + Β· intro inp work out hpost + rcases hpost with + ⟨hinputHead, hinputCells, hrawHead, hrawOutput, hworkInv, hout⟩ + have hinput : inp = + (Tape.init (second.map Ξ“.ofBool)).move Dir3.right := by + apply Tape.ext + Β· simpa [Tape.move] using hinputHead + Β· simpa only [Tape.move_cells] using hinputCells + exact ⟨hinput, hrawHead, hrawOutput, hworkInv, hout⟩ + Β· exact le_rfl + have hemitter := pairInputWorkTM_hoareTime raw first second + have hinner := seqTM_hoareTime rewindInputTM (pairInputWorkTM raw) + hrewInput' (by + intro inp work out hpre + rcases hpre with ⟨hinput, hrawHead, hrawOutput, hworkInv, hout⟩ + have hinputStable : transitionInput inp = inp := by + apply transitionInput_eq_self + rw [hinput] + exact Tape.init_ofBool_move_right_read_ne_start second + have hworkStable : (fun i => transitionTape (work i)) = work := by + funext i + apply transitionTape_eq_self + exact (hworkInv i).1.read_ne_start (hworkInv i).2 + have hworkStableAt (i) : transitionTape (work i) = work i := + congrFun hworkStable i + have houtStable : transitionTape out = out := by + apply transitionTape_eq_self + rw [hout] + decide + simpa only [hinputStable, hworkStableAt, houtStable] using! + (show PairWithInputEmitterPre nf first second inp work out from + ⟨hinput, hrawHead, hrawOutput, hworkInv, hout⟩)) + hemitter + have htail := seqTM_hoareTime (rewindWorkTM raw) + (seqTM rewindInputTM (pairInputWorkTM raw)) hrewRaw' (by + intro inp work out hpre + rcases hpre with + ⟨hrawHead, hrawOutput, hinputCells, hinputInv, + hinputHead, hinputBound, hworkInv, hout⟩ + have hinputStable : transitionInput inp = inp := + transitionInput_eq_self (hinputInv.read_ne_start hinputHead) + have hworkStable : (fun i => transitionTape (work i)) = work := by + funext i + apply transitionTape_eq_self + exact (hworkInv i).1.read_ne_start (hworkInv i).2 + have hworkStableAt (i) : transitionTape (work i) = work i := + congrFun hworkStable i + have houtStable : transitionTape out = out := by + apply transitionTape_eq_self + rw [hout] + decide + simpa only [hinputStable, hworkStableAt, houtStable] using + (show PairWithInputAfterRaw nf first second B inp work out from + ⟨hrawHead, hrawOutput, hinputCells, hinputInv, hinputHead, + hinputBound, hworkInv, hout⟩)) + hinner + simpa only [pairWithInputTailTM] using + htail.mono_bound (by omega) + +/-- Internal correctness of the executable fanout combinator. -/ +theorem pairWithInputTM_computesInTime_internal + {tmF : TM nf} {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : tmF.ComputesInTime f T) : + (pairWithInputTM tmF).ComputesInTime + (fun x => pair (f x) x) (pairWithInputTime T) := by + intro x + obtain ⟨C, t, ht, hreachF, hhaltF, hrawOutput, hrawHead, + _hvirtual, _hscratch, hinputInv, hinputHead, hworkBoundary, + houtputParked⟩ := + compositionFirstTM_boundary_internal tmF 0 hcomp x + let boundaryInput := transitionInput C.input + let boundaryWork : Fin (pairWithInputTapeCount nf) β†’ Tape := + fun i => transitionTape (C.work i) + let boundaryOutput := transitionTape C.output + have hinputCells : boundaryInput.cells = + (Tape.init (x.map Ξ“.ofBool)).cells := by + dsimp only [boundaryInput] + rw [transitionInput_cells, + input_cells_eq_of_reachesIn hreachF] + have hinputBound : boundaryInput.head ≀ T x.length + 1 := by + have hhead := (head_le_of_reachesIn + (compositionFirstTM tmF 0) hreachF).1 + have hmove := Tape.head_move_le C.input (idleDir C.input.read) + change (C.input.move (idleDir C.input.read)).head ≀ T x.length + 1 + omega + have htail := pairWithInputTailTM_hoareTime_internal nf + (f x) x (T x.length + 1) + obtain ⟨D, u, hu, hreachTail, hhaltTail, houtTail⟩ := + htail boundaryInput boundaryWork boundaryOutput (by + refine ⟨hrawOutput, (hworkBoundary _).1, ?_, hinputCells, + hinputInv, hinputHead, hinputBound, hworkBoundary, houtputParked⟩ + dsimp only [boundaryWork] + change (transitionTape + (C.work (compositionRawOutputIdx nf 0))).head ≀ T x.length + 1 + omega) + let first := pairWithInputFirstTM tmF + let tail := pairWithInputTailTM nf + let final := phase2Wrap first tail D + refine ⟨final, t + 1 + u, ?_, ?_, ?_, ?_⟩ + Β· have hlength : (f x).length ≀ T x.length := hcomp.output_length_le x + have hu' : u ≀ 2 * (T x.length + 1) + + pairInputWorkTime (f x) x + 6 := hu + change t + 1 + u ≀ 5 * T x.length + x.length + 12 + simp only [pairInputWorkTime] at hu' + omega + Β· have hreach := seqTM_reachesIn_of_reachesIn first tail + hreachF hhaltF hreachTail + simpa [pairWithInputTM, pairWithInputFirstTM, first, tail, final, + boundaryInput, boundaryWork, boundaryOutput] using! hreach + Β· show (pairWithInputTM tmF).halted final + simpa [pairWithInputTM, first, tail, final] using + (phase2Wrap_halted_iff first tail D).2 hhaltTail + Β· simpa [final, phase2Wrap] using houtTail + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Frame.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Frame.lean new file mode 100644 index 0000000000..0b88e8b401 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Frame.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers + +/-! +# Frame rules for composite machines + +Two things a machine built out of sub-machines needs to know: that a +sub-machine's Hoare triple still holds once its tapes are embedded in a larger +tape space (`TM.placeWorkTM_hoareTime_frame`), and that a run of bounded length +cannot have touched cells far from where its heads started +(`TM.reachesIn_work_cells_far`). The second is what lets a *bounded* wipe reset +an opaque machine's scratch completely. + +## Main results + +- `TM.placeWorkTM_hoareTime_frame` β€” a Hoare triple survives tape embedding +- `TM.reachesIn_work_cells_far` β€” a `t`-step run leaves cells beyond `head + t` alone +- `TM.reachesIn_startInvariant` β€” runs preserve `Tape.StartInvariant` +- `TM.seqTM_det` β€” sequential composition is deterministic on its components +- `TM.IdlesInput` β€” machines that never move their input head +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The parked blank tape every scratch tape starts and ends at. -/ +def parkedBlank : Tape := (Tape.init []).move Dir3.right + +/-! ## Embedding a Hoare triple in a larger tape space + +A composite machine runs sub-machines that each own a fixed number of work +tapes, while carrying persistent state (running values, fuel registers) on tapes +those sub-machines never touch. `TM.placeWorkTM` already gives the exact +frame-preserving simulation +(`placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant`); the lemma below turns +that into a Hoare-triple-level tool, so each embedding is a single lemma +application instead of a fresh `reachesIn` argument. -/ + +/-- **Placing a Hoare triple.** If `tm : TM n` satisfies a Hoare triple, then +`placeWorkTM pre post tm` satisfies the triple obtained by reindexing `tm`'s +work-tape predicate through the middle block, with an arbitrary `Parked`-style +frame (`extras`) held exactly fixed outside it. -/ +theorem placeWorkTM_hoareTime_frame {n pre post : β„•} (tm : TM n) + {preSmall postSmall : TapePred n} {b : β„•} + (h : tm.HoareTime preSmall postSmall b) + (extras : Fin (pre + n + post) β†’ Tape) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ 1 ≀ (extras i).head) : + (placeWorkTM pre post tm).HoareTime + (fun inp work out => preSmall inp (fun i => work (placeWorkIdx pre post i)) out ∧ + βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ work i = extras i) + (fun inp work out => postSmall inp (fun i => work (placeWorkIdx pre post i)) out ∧ + βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ work i = extras i) + b := by + rintro inp work out ⟨hpre, hextra⟩ + set wSmall : Fin n β†’ Tape := fun i => work (placeWorkIdx pre post i) with hwSmall + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp wSmall out hpre + have hweq : work = (placeWorkCfg tm pre post extras + { state := tm.qstart, input := inp, work := wSmall, output := out }).work := by + funext i + by_cases hmid : placeWorkInMiddle pre n i + Β· rw [show i = placeWorkIdx pre post (placeWorkCoord pre n i hmid) from + (placeWorkIdx_placeWorkCoord i hmid).symm, placeWorkCfg_work_middle] + Β· rw [placeWorkCfg_work_extra tm pre post extras _ i hmid] + exact hextra i hmid + refine ⟨placeWorkCfg tm pre post extras c', t, ht, ?_, + (placeWorkCfg_halted_iff tm pre post extras c').mpr hhalt, ?_, ?_⟩ + Β· rw [hweq] + exact placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant tm pre post extras hreach + hinv hhead + Β· show postSmall c'.input (fun i => (placeWorkCfg tm pre post extras c').work + (placeWorkIdx pre post i)) c'.output + simp only [placeWorkCfg_work_middle] + exact hpost + Β· intro i hi + exact placeWorkCfg_work_extra tm pre post extras c' i hi + +/-! ## What a bounded run can have disturbed + +Resetting an opaque machine's scratch tapes between calls needs +to know *how far out* the machine could possibly have written. Since each head +moves by at most one cell per step and a machine only ever writes under its +heads, a `t`-step run leaves every cell beyond `head + t` exactly as it found +it. That is what makes the bounded wipe of `TM.resetTapesTM` complete rather +than merely partial. -/ + +/-- One step leaves every work-tape cell other than that tape's own head +unchanged: a machine writes only under its heads. -/ +theorem work_cells_ne_of_step {n : β„•} {tm : TM n} {c c' : Cfg n tm.Q} + (hstep : tm.step c = some c') (i : Fin n) {j : β„•} (hj : j β‰  (c.work i).head) : + (c'.work i).cells j = (c.work i).cells j := by + simp only [TM.step] at hstep + split at hstep + Β· simp at hstep + Β· simp only [Option.some.injEq] at hstep + rw [← hstep] + simp only [Tape.move_cells, Tape.write] + split + Β· rfl + Β· change Function.update (c.work i).cells (c.work i).head _ j = (c.work i).cells j + rw [Function.update_of_ne hj] + +/-- **Cells beyond a work head's maximum reach are never touched.** -/ +theorem reachesIn_work_cells_far {n : β„•} {tm : TM n} : + βˆ€ {t : β„•} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' β†’ + βˆ€ (i : Fin n) (j : β„•), (c.work i).head + t < j β†’ + (c'.work i).cells j = (c.work i).cells j := by + intro t + induction t with + | zero => + intro c c' hreach i j _ + cases hreach + rfl + | succ t ih => + intro c c' hreach i j hj + cases hreach with + | step hstep hrest => + next c'' => + have hhead : (c''.work i).head ≀ (c.work i).head + 1 := + (head_le_start_add_of_reachesIn tm (TM.reachesIn.step hstep TM.reachesIn.zero)).2.2 i + have hcell : (c''.work i).cells j = (c.work i).cells j := + work_cells_ne_of_step hstep i (by omega) + rw [ih hrest i j (by omega), hcell] + +/-- The standing left-marker invariant survives an entire run, on every tape. -/ +theorem reachesIn_startInvariant {n : β„•} {tm : TM n} : + βˆ€ {t : β„•} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' β†’ + c.input.StartInvariant β†’ (βˆ€ i, (c.work i).StartInvariant) β†’ c.output.StartInvariant β†’ + c'.input.StartInvariant ∧ (βˆ€ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + intro t c c' hreach + induction hreach with + | zero => exact fun hi hw ho => ⟨hi, hw, ho⟩ + | step hstep _ ih => + intro hi hw ho + obtain ⟨hi', hw', ho'⟩ := Tape.StartInvariant.step _ hstep hi hw ho + exact ih hi' hw' ho' + +/-- A fully parked tape frame passes through a combinator seam unchanged β€” +the boundary obligation of `TM.seqTM_hoareTime` in the common case where every +tape is parked on both sides of the seam. -/ +theorem parked_transition {n : β„•} {inpβ‚€ outβ‚€ : Tape} {W : Fin n β†’ Tape} + (hinp : Parked inpβ‚€) (hW : βˆ€ i, Parked (W i)) (hout : Parked outβ‚€) : + transitionInput inpβ‚€ = inpβ‚€ ∧ + (fun i => transitionTape (W i)) = W ∧ transitionTape outβ‚€ = outβ‚€ := + ⟨transitionInput_eq_self hinp.read_ne_start, + funext fun i => transitionTape_eq_self (hW i).read_ne_start, + transitionTape_eq_self hout.read_ne_start⟩ + +/-- **Chaining two fully-determined phases.** When each phase pins down the +entire tape family and every intermediate tape is parked, sequential +composition needs no boundary reasoning at all. -/ +theorem seqTM_det {n : β„•} (m₁ mβ‚‚ : TM n) {inpβ‚€ outβ‚€ : Tape} {Wβ‚€ W₁ Wβ‚‚ : Fin n β†’ Tape} + {b₁ bβ‚‚ : β„•} (hinp : Parked inpβ‚€) (hout : Parked outβ‚€) (hW₁ : βˆ€ i, Parked (W₁ i)) + (h₁ : m₁.HoareTime (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = outβ‚€) b₁) + (hβ‚‚ : mβ‚‚.HoareTime (fun inp work out => inp = inpβ‚€ ∧ work = W₁ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚‚ ∧ out = outβ‚€) bβ‚‚) : + (seqTM m₁ mβ‚‚).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = Wβ‚‚ ∧ out = outβ‚€) + (b₁ + 1 + bβ‚‚) := by + refine seqTM_hoareTime m₁ mβ‚‚ h₁ ?_ hβ‚‚ + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact parked_transition hinp hW₁ hout + +/-- A machine that never moves its real input head off a parked position: its +transition function always returns `idleDir` for the input tape. Machines that +read their input from a work tape instead (`TM.retargetInput` and everything +built on it) satisfy this. -/ +def IdlesInput {n : β„•} (tm : TM n) : Prop := + βˆ€ q iHead wHeads oHead, (tm.Ξ΄ q iHead wHeads oHead).2.2.2.1 = idleDir iHead + +/-- An input-idling machine preserves a parked real input tape exactly, for +any number of steps. -/ +theorem reachesIn_input_eq_of_idlesInput {n : β„•} {tm : TM n} (hidle : IdlesInput tm) : + βˆ€ {t : β„•} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' β†’ Parked c.input β†’ + c'.input = c.input := by + intro t + induction t with + | zero => + intro c c' hreach _ + cases hreach + rfl + | succ t ih => + intro c c' hreach hp + cases hreach with + | step hstep hrest => + next c'' => + have hc'' : c''.input = c.input := by + simp only [TM.step] at hstep + split at hstep + Β· simp at hstep + Β· simp only [Option.some.injEq] at hstep + rw [← hstep] + show c.input.move _ = c.input + rw [hidle, hp.move_idle] + rw [ih hrest (by rw [hc'']; exact hp), hc''] + +/-- The blank tape satisfies the left-marker invariant. -/ +theorem startInvariant_initNil : Tape.StartInvariant (Tape.init ([] : List Ξ“)) := by + refine ⟨Tape.init_cells_zero [], fun j hj => ?_⟩ + rw [show j = (j - 1) + 1 from by omega, Tape.init_cells_ge [] (j - 1) (by simp)] + decide + +/-- A tape initialized with a Boolean string satisfies the left-marker +invariant: `Ξ“.ofBool` never produces `β–·`. -/ +theorem startInvariant_initOfBool (y : List Bool) : + Tape.StartInvariant (Tape.init (y.map Ξ“.ofBool)) := by + refine ⟨Tape.init_cells_zero _, fun j hj => ?_⟩ + have hj1 : j = (j - 1) + 1 := by omega + by_cases hlt : j - 1 < y.length + Β· rw [hj1, Tape.init_ofBool_cells_lt y (j - 1) hlt] + cases y[j - 1]'hlt <;> decide + Β· rw [hj1, Tape.init_ofBool_cells_ge y (j - 1) (by omega)] + decide + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare.lean new file mode 100644 index 0000000000..e7988f6e4f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare.lean @@ -0,0 +1,382 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Seq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.If +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Complement + +/-! +# Hoare-style composition rules for TM combinators + +This file provides Hoare-triple composition rules for all four TM combinators. +Each rule specifies how pre/postconditions and time bounds compose. + +## Main results + +- `seqTM_hoareTime` β€” sequential composition: time `b₁ + 1 + bβ‚‚` +- `phaseTransition_eq_self_of_reads_ne_start` β€” identify a stable phase boundary +- `complementTM_hoareTime` β€” complement flips output cell 1: time `b + p_bound + 4` +- `ifTM_hoareTime` β€” if-then-else branching: time `b_test + p_bound + max b_then b_else + 5` +- `loopTM_hoareTime` β€” loop invariant with variant: time `(k + 1) * b_iter` + +## Tape transition effects + +All combinators apply `transitionTape` / `transitionInput` at phase boundaries. +A current read other than `β–·` is exactly what their fixed-point rules require; +parked tapes, or `AllTapesWF` together with positive-head facts, provide common +stronger certificates. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- **Sequential composition of Hoare triples**. -/ +theorem seqTM_hoareTime (tm₁ tmβ‚‚ : TM n) + {pre mid mid' post : TapePred n} {b₁ bβ‚‚ : β„•} + (h₁ : tm₁.HoareTime pre mid b₁) + (h_trans : βˆ€ inp work out, mid inp work out β†’ + mid' (transitionInput inp) + (fun i => transitionTape (work i)) + (transitionTape out)) + (hβ‚‚ : tmβ‚‚.HoareTime mid' post bβ‚‚) : + (seqTM tm₁ tmβ‚‚).HoareTime pre post (b₁ + 1 + bβ‚‚) := by + intro inp work out hpre + obtain ⟨c₁, t₁, ht₁, hreach₁, hhalt₁, hmid⟩ := h₁ inp work out hpre + have hmid' := h_trans c₁.input c₁.work c₁.output hmid + obtain ⟨cβ‚‚, tβ‚‚, htβ‚‚, hreachβ‚‚, hhaltβ‚‚, hpost⟩ := hβ‚‚ _ _ _ hmid' + refine ⟨phase2Wrap tm₁ tmβ‚‚ cβ‚‚, t₁ + 1 + tβ‚‚, ?_, ?_, ?_, ?_⟩ + Β· omega + Β· convert! seqTM_reachesIn_of_reachesIn tm₁ tmβ‚‚ hreach₁ hhalt₁ hreachβ‚‚ using 1 + Β· rw [phase2Wrap_halted_iff]; exact hhaltβ‚‚ + Β· exact hpost + +/-- The input, work family, and output transition maps are jointly the +identity when every tape is reading something other than the left-end marker. +This shared read-local boundary certificate matches the transition shape +accepted by both time-only and time-space sequential composition; it +deliberately does not require parked heads or global tape well-formedness. -/ +theorem phaseTransition_eq_self_of_reads_ne_start + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : inp.read β‰  Ξ“.start) + (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + transitionInput inp = inp ∧ + (fun i => transitionTape (work i)) = work ∧ + transitionTape out = out := by + exact ⟨transitionInput_eq_self hinput, + funext fun i => transitionTape_eq_self (hwork i), + transitionTape_eq_self houtput⟩ + +/-- Well-formedness condition on all tapes: cells 0 = start and cells β‰₯ 1 β‰  start. -/ +def AllTapesWF (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : Prop := + inp.cells 0 = Ξ“.start ∧ (βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start) ∧ + (βˆ€ i, (work i).cells 0 = Ξ“.start) ∧ (βˆ€ i j, j β‰₯ 1 β†’ (work i).cells j β‰  Ξ“.start) ∧ + out.cells 0 = Ξ“.start ∧ (βˆ€ j, j β‰₯ 1 β†’ out.cells j β‰  Ξ“.start) + +-- ════════════════════════════════════════════════════════════════════════ +-- AllTapesWF propagation through phase transitions +-- ════════════════════════════════════════════════════════════════════════ + +/-- AllTapesWF is preserved through the standard combinator phase transition + (`transitionTape` / `transitionInput`). -/ +theorem AllTapesWF.transition {inp : Tape} {work : Fin n β†’ Tape} {out : Tape} + (h : AllTapesWF inp work out) : + (transitionInput inp).head β‰₯ 1 ∧ + (βˆ€ j, j β‰₯ 1 β†’ (transitionInput inp).cells j β‰  Ξ“.start) ∧ + (βˆ€ i, (transitionTape (work i)).head β‰₯ 1) ∧ + (βˆ€ i j, j β‰₯ 1 β†’ (transitionTape (work i)).cells j β‰  Ξ“.start) ∧ + (transitionTape out).cells = out.cells ∧ + (transitionTape out).head β‰₯ 1 := by + obtain ⟨hic0, hins, hwc0, hwns, hoc0, hons⟩ := h + exact ⟨transitionInput_head_ge inp hic0, + by rw [transitionInput_cells]; exact hins, + fun i => one_le_head_transitionTape _ (hwc0 i), + fun i j hj => by rw [transitionTape_cells _ (hwns i)]; exact hwns i j hj, + transitionTape_cells out hons, + one_le_head_transitionTape out hoc0⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Complement rule +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Complement Hoare triple**. If `tm` satisfies a Hoare triple whose + postcondition provides output WF (for rewind), a head bound, and a + property of output cell 1, then `complementTM tm` satisfies a triple + where output cell 1 is flipped. Time: `b + p_bound + 4`. -/ +theorem complementTM_hoareTime (tm : TM n) + {pre : TapePred n} {b p_bound : β„•} + {cell1_pred : Ξ“ β†’ Prop} + (h_tm : tm.HoareTime pre + (fun _ _ out => + out.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ out.cells j β‰  Ξ“.start) ∧ + out.head ≀ p_bound ∧ + cell1_pred (out.cells 1)) + b) : + tm.complementTM.HoareTime pre + (fun _ _ out => βˆƒ g, cell1_pred g ∧ out.cells 1 = (flipBit g).toΞ“) + (b + p_bound + 4) := by + intro inp work out hpre + obtain ⟨c', t, ht, hreach, hhalt, hcell0, hnostart, hhead, hcell1⟩ := + h_tm inp work out hpre + have hsim := complementTM_simulation tm hreach + rw [compCfg_qstart] at hsim + obtain ⟨c_done, t_rw, hreach_rw, hhalt_done, hflip, hle_rw⟩ := + complementTM_rewind_and_flip tm c' hhalt hcell0 hnostart + exact ⟨c_done, t + t_rw, + by have : t_rw ≀ p_bound + 4 := le_trans hle_rw (by omega); omega, + reachesIn_trans _ hsim hreach_rw, hhalt_done, + c'.output.cells 1, hcell1, hflip⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- If-then-else rule +-- ════════════════════════════════════════════════════════════════════════ + +/-- **If-then-else Hoare triple**. Composes test, then-branch, and else-branch + Hoare triples. The test postcondition must include `AllTapesWF` (for rewind) + and a head bound. Branch routing maps the test postcondition to the branch + precondition on transitioned tapes (output gets head = 1, cells preserved). + + Time: `b_test + p_bound + max b_then b_else + 5` + (test + transition + rewind + check + branch + halt). -/ +theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) + {pre mid_test mid_then mid_else post_then post_else post : TapePred n} + {b_test b_then b_else p_bound : β„•} + (h_test : tmTest.HoareTime pre mid_test b_test) + (h_wf : βˆ€ inp work out, mid_test inp work out β†’ AllTapesWF inp work out) + (h_head : βˆ€ inp work out, mid_test inp work out β†’ out.head ≀ p_bound) + (h_to_then : βˆ€ inp work out, mid_test inp work out β†’ out.cells 1 = Ξ“.one β†’ + mid_then (transitionInput inp) (fun i => transitionTape (work i)) + ⟨1, out.cells⟩) + (h_to_else : βˆ€ inp work out, mid_test inp work out β†’ out.cells 1 β‰  Ξ“.one β†’ + mid_else (transitionInput inp) (fun i => transitionTape (work i)) + ⟨1, out.cells⟩) + (h_then : tmThen.HoareTime mid_then post_then b_then) + (h_else : tmElse.HoareTime mid_else post_else b_else) + (h_post_then : βˆ€ inp work out, post_then inp work out β†’ + post (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) + (h_post_else : βˆ€ inp work out, post_else inp work out β†’ + post (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) : + (ifTM tmTest tmThen tmElse).HoareTime pre post + (b_test + p_bound + max b_then b_else + 5) := by + intro inp work out hpre + obtain ⟨c_test, t₁, ht₁, hreach₁, hhalt₁, hmid⟩ := h_test inp work out hpre + have hwf := h_wf _ _ _ hmid + have hhead_bound := h_head _ _ _ hmid + obtain ⟨hic0, hins, hwc0, hwns, hoc0, hons⟩ := hwf + -- Phase 1: test simulation + have hsim := ifTM_reachesIn_ifTestWrap tmTest tmThen tmElse hreach₁ + -- Phase 2: test β†’ rewind transition (1 step) + have h_tr := ifTM_test_to_rewind tmTest tmThen tmElse hhalt₁ + -- Phase 3: rewind loop (tracks all tapes, using AllTapesWF propagation) + obtain ⟨h_inp_ge, h_inp_ns, h_work_ge, h_work_ns, h_out_cells, _⟩ := + AllTapesWF.transition (h_wf _ _ _ hmid) + have h_out_head_bound := head_transitionTape_le hoc0 hhead_bound + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check, hinp_check, hwork_check⟩ := + ifTM_rewindOut_reachesIn_check tmTest tmThen tmElse (transitionTape c_test.output).head + { state := Sum.inr (Sum.inl IfPhase.rewindOut), + input := transitionInput c_test.input, + work := fun i => transitionTape (c_test.work i), + output := transitionTape c_test.output } + rfl (by rw [h_out_cells]; exact hoc0) + (by intro j hj; rw [h_out_cells]; exact hons j hj) rfl + h_inp_ge h_inp_ns h_work_ge h_work_ns + -- Phase 4: check + branch (cases on output cell 1) + -- Derive invariants on the check config from rewind results + have hcells_at_check : c_check.output.cells 1 = c_test.output.cells 1 := by + rw [hcells_check, h_out_cells] + have hns_at_check : βˆ€ j, j β‰₯ 1 β†’ c_check.output.cells j β‰  Ξ“.start := by + intro j hj; rw [hcells_check, h_out_cells]; exact hons j hj + have hinp_stable : c_check.input.head β‰₯ 1 := by rw [hinp_check]; exact h_inp_ge + have hins_stable : βˆ€ j, j β‰₯ 1 β†’ c_check.input.cells j β‰  Ξ“.start := by + intro j hj; rw [hinp_check]; exact h_inp_ns j hj + have hwh_stable : βˆ€ i, (c_check.work i).head β‰₯ 1 := by + intro i; rw [hwork_check]; exact h_work_ge i + have hwns_stable : βˆ€ i j, j β‰₯ 1 β†’ (c_check.work i).cells j β‰  Ξ“.start := by + intro i j hj; rw [hwork_check]; exact h_work_ns i j hj + -- Time for transition + rewind + have hreach_tr_rw : (ifTM tmTest tmThen tmElse).reachesIn + (1 + ((transitionTape c_test.output).head + 1)) + (ifTestWrap tmTest tmThen tmElse c_test) c_check := + reachesIn_trans _ (.step h_tr .zero) hreach_rw + -- Branch on output cell 1 + by_cases hcell1 : c_test.output.cells 1 = Ξ“.one + Β· -- Then branch + obtain ⟨c_branch, hstep_check, hst_branch, hcells_branch, hhead_branch, + hinp_branch, hwork_branch⟩ := + ifTM_check_step_then_full tmTest tmThen tmElse c_check hst_check hh_check + (by rw [hcells_at_check]; exact hcell1) hinp_stable hins_stable hwh_stable hwns_stable + have hmid_then := h_to_then c_test.input c_test.work c_test.output hmid hcell1 + obtain ⟨c_then, t₃, ht₃, hreach₃, hhalt₃, hpost_then⟩ := + h_then _ _ _ hmid_then + have hsim₃ := ifTM_reachesIn_ifThenWrap tmTest tmThen tmElse hreach₃ + have h_halt_step := ifTM_then_halt_step tmTest tmThen tmElse hhalt₃ + have hpost := h_post_then c_then.input c_then.work c_then.output hpost_then + -- Compose: test sim + transition + rewind + check + branch sim + halt + let c_done : Cfg n (ifTM tmTest tmThen tmElse).Q := + ⟨(ifTM tmTest tmThen tmElse).qhalt, + transitionInput c_then.input, + fun i => transitionTape (c_then.work i), + transitionTape c_then.output⟩ + refine ⟨c_done, t₁ + (1 + ((transitionTape c_test.output).head + 1)) + 1 + t₃ + 1, + ?_, ?_, ?_, ?_⟩ + Β· have : (transitionTape c_test.output).head + 1 ≀ p_bound + 2 := by omega + calc t₁ + _ + 1 + t₃ + 1 + ≀ b_test + (1 + (p_bound + 2)) + 1 + b_then + 1 := by omega + _ ≀ b_test + p_bound + max b_then b_else + 5 := by omega + Β· have hstep_branch : (ifTM tmTest tmThen tmElse).step c_check = + some (ifThenWrap tmTest tmThen tmElse + ⟨tmThen.qstart, transitionInput c_test.input, + fun i => transitionTape (c_test.work i), ⟨1, c_test.output.cells⟩⟩) := by + rw [hstep_check]; congr 1; simp only [ifThenWrap] + have hcfg_eta : c_branch = + ⟨c_branch.state, c_branch.input, c_branch.work, c_branch.output⟩ := rfl + have htape_eta : c_branch.output = + ⟨c_branch.output.head, c_branch.output.cells⟩ := rfl + rw [hcfg_eta, hst_branch, hinp_branch, hinp_check, hwork_branch, hwork_check, + htape_eta, hhead_branch] + congr 1; simp only [hcells_branch, hcells_check, h_out_cells] + have r1 := reachesIn_trans _ hsim hreach_tr_rw + have r2 := reachesIn_trans _ r1 (.step hstep_branch .zero) + have r3 := reachesIn_trans _ r2 hsim₃ + exact reachesIn_trans _ r3 (.step h_halt_step .zero) + Β· exact ifTM_halted_of_state_eq_done tmTest tmThen tmElse _ rfl + Β· exact hpost + Β· -- Else branch (symmetric) + obtain ⟨c_branch, hstep_check, hst_branch, hcells_branch, hhead_branch, + hinp_branch, hwork_branch⟩ := + ifTM_check_step_else_full tmTest tmThen tmElse c_check hst_check hh_check + (by rw [hcells_at_check]; exact hcell1) hns_at_check + hinp_stable hins_stable hwh_stable hwns_stable + have hmid_else := h_to_else c_test.input c_test.work c_test.output hmid hcell1 + obtain ⟨c_else, t₃, ht₃, hreach₃, hhalt₃, hpost_else⟩ := + h_else _ _ _ hmid_else + have hsim₃ := ifTM_reachesIn_ifElseWrap tmTest tmThen tmElse hreach₃ + have h_halt_step := ifTM_else_halt_step tmTest tmThen tmElse hhalt₃ + have hpost := h_post_else c_else.input c_else.work c_else.output hpost_else + let c_done_else : Cfg n (ifTM tmTest tmThen tmElse).Q := + ⟨(ifTM tmTest tmThen tmElse).qhalt, + transitionInput c_else.input, + fun i => transitionTape (c_else.work i), + transitionTape c_else.output⟩ + refine ⟨c_done_else, t₁ + (1 + ((transitionTape c_test.output).head + 1)) + 1 + t₃ + 1, + ?_, ?_, ?_, ?_⟩ + Β· have : (transitionTape c_test.output).head + 1 ≀ p_bound + 2 := by omega + calc t₁ + _ + 1 + t₃ + 1 + ≀ b_test + (1 + (p_bound + 2)) + 1 + b_else + 1 := by omega + _ ≀ b_test + p_bound + max b_then b_else + 5 := by omega + Β· have hstep_branch : (ifTM tmTest tmThen tmElse).step c_check = + some (ifElseWrap tmTest tmThen tmElse + ⟨tmElse.qstart, transitionInput c_test.input, + fun i => transitionTape (c_test.work i), ⟨1, c_test.output.cells⟩⟩) := by + rw [hstep_check]; congr 1; simp only [ifElseWrap] + have hcfg_eta : c_branch = + ⟨c_branch.state, c_branch.input, c_branch.work, c_branch.output⟩ := rfl + have htape_eta : c_branch.output = + ⟨c_branch.output.head, c_branch.output.cells⟩ := rfl + rw [hcfg_eta, hst_branch, hinp_branch, hinp_check, hwork_branch, hwork_check, + htape_eta, hhead_branch] + congr 1; simp only [hcells_branch, hcells_check, h_out_cells] + have r1 := reachesIn_trans _ hsim hreach_tr_rw + have r2 := reachesIn_trans _ r1 (.step hstep_branch .zero) + have r3 := reachesIn_trans _ r2 hsim₃ + exact reachesIn_trans _ r3 (.step h_halt_step .zero) + Β· exact ifTM_halted_of_state_eq_done tmTest tmThen tmElse _ rfl + Β· exact hpost + +-- ════════════════════════════════════════════════════════════════════════ +-- Loop invariant rule +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loopTM_hoareTime_aux (tmBody tmTest : TM n) + {inv post : TapePred n} {b_iter : β„•} + {variant : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ β„•} + (h_iter : βˆ€ inp work out, inv inp work out β†’ + (βˆƒ c' t, t ≀ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output) + ∨ + (βˆƒ inp' work' out' t, t ≀ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + inv inp' work' out' ∧ + variant inp' work' out' < variant inp work out)) + (fuel : β„•) : + βˆ€ inp work out, inv inp work out β†’ variant inp work out ≀ fuel β†’ + βˆƒ c' t, t ≀ (fuel + 1) * b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output := by + induction fuel with + | zero => + intro inp work out hinv hfuel + cases h_iter inp work out hinv with + | inl h => + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h + exact ⟨c', t, le_trans ht (by omega), hreach, hhalt, hpost⟩ + | inr h => + obtain ⟨_, _, _, _, _, _, _, hvar_dec⟩ := h + omega + | succ fuel ih => + intro inp work out hinv hfuel + cases h_iter inp work out hinv with + | inl h => + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h + refine ⟨c', t, le_trans ht ?_, hreach, hhalt, hpost⟩ + calc b_iter = 1 * b_iter := (Nat.one_mul _).symm + _ ≀ (fuel + 1 + 1) * b_iter := Nat.mul_le_mul_right _ (by omega) + | inr h => + obtain ⟨inp', work', out', t₁, ht₁, hreach₁, hinv', hvar_dec⟩ := h + have hfuel' : variant inp' work' out' ≀ fuel := by omega + obtain ⟨c', tβ‚‚, htβ‚‚, hreachβ‚‚, hhalt, hpost⟩ := ih inp' work' out' hinv' hfuel' + refine ⟨c', t₁ + tβ‚‚, ?_, reachesIn_trans _ hreach₁ hreachβ‚‚, hhalt, hpost⟩ + calc t₁ + tβ‚‚ + ≀ b_iter + (fuel + 1) * b_iter := Nat.add_le_add ht₁ htβ‚‚ + _ = (fuel + 1) * b_iter + b_iter := Nat.add_comm _ _ + _ = (fuel + 1 + 1) * b_iter := (Nat.succ_mul _ _).symm + +/-- **Loop invariant rule**. Each iteration (≀ `b_iter` steps) either halts with + `post` or returns to the loop start with `inv` preserved and `variant` decreased. + The `variant` is bounded by `k` under `inv`, giving total time `(k + 1) * b_iter`. -/ +theorem loopTM_hoareTime (tmBody tmTest : TM n) + {inv post : TapePred n} {b_iter k : β„•} + {variant : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ β„•} + (h_variant_bound : βˆ€ inp work out, inv inp work out β†’ variant inp work out ≀ k) + (h_iter : βˆ€ inp work out, inv inp work out β†’ + (βˆƒ c' t, t ≀ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output) + ∨ + (βˆƒ inp' work' out' t, t ≀ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + inv inp' work' out' ∧ + variant inp' work' out' < variant inp work out)) : + (loopTM tmBody tmTest).HoareTime inv post ((k + 1) * b_iter) := by + intro inp work out hinv + exact loopTM_hoareTime_aux tmBody tmTest h_iter k inp work out hinv + (h_variant_bound inp work out hinv) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Defs.lean new file mode 100644 index 0000000000..6627ef2be2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Defs.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# Hoare-style specifications for Turing machines + +This file defines Hoare triples for reasoning about TM behavior in terms of +tape preconditions and postconditions. This provides a compositional framework +for building and verifying complex machines from simpler components. + +## Main definitions + +- `TapePred` β€” a predicate on the tape configuration (input, work, output) +- `TM.HoareTime` β€” time-bounded Hoare triple: `{pre} tm {post} [≀ bound]` +- `TM.Hoare` β€” unbounded Hoare triple: `{pre} tm {post}` + +## Design notes + +Hoare triples abstract away the internal state `Q`, reasoning purely about +tape contents and head positions. This makes them ideal for compositional +reasoning: the pre/postconditions of composed machines can be stated without +reference to the internal state types of the components. + +The precondition must imply that the starting configuration has the machine's +`qstart` state. The postcondition holds at halting. +-/ + + +@[expose] public section + +namespace Complexity + +/-- A predicate on the tape configuration: input tape, work tapes, output tape. -/ +abbrev TapePred (n : β„•) := Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop + +namespace TM + +variable {n : β„•} + +@[inherit_doc Complexity.TapePred] +abbrev TapePred (n : β„•) := Complexity.TapePred n + +/-- **Time-bounded Hoare triple**: for any tapes satisfying `pre`, starting + from `qstart`, the machine halts within `bound` steps with tapes satisfying + `post`. + + This is the core specification type for compositional TM reasoning. + Captures both correctness (pre/post) and efficiency (time bound). -/ +def HoareTime (tm : TM n) (pre post : TapePred n) (bound : β„•) : Prop := + βˆ€ inp work out, pre inp work out β†’ + βˆƒ c' t, t ≀ bound ∧ + tm.reachesIn t { state := tm.qstart, input := inp, work := work, output := out } c' ∧ + tm.halted c' ∧ post c'.input c'.work c'.output + +/-- **Unbounded Hoare triple**: the machine halts with tapes satisfying `post`, + without a time bound. Useful when only correctness matters. -/ +def Hoare (tm : TM n) (pre post : TapePred n) : Prop := + βˆ€ inp work out, pre inp work out β†’ + βˆƒ c', tm.reaches { state := tm.qstart, input := inp, work := work, output := out } c' ∧ + tm.halted c' ∧ post c'.input c'.work c'.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Structural rules +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Consequence rule**: weaken the precondition and strengthen the postcondition. -/ +theorem HoareTime.consequence {tm : TM n} + {pre pre' post post' : TapePred n} {b b' : β„•} + (h : tm.HoareTime pre post b) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) + (hbound : b ≀ b') : + tm.HoareTime pre' post' b' := by + intro inp work out hpre' + obtain ⟨c', t, ht, hreach, hhalt, hpost_c⟩ := h inp work out (hpre _ _ _ hpre') + exact ⟨c', t, le_trans ht hbound, hreach, hhalt, hpost _ _ _ hpost_c⟩ + +/-- **Precondition weakening**: if `pre'` implies `pre`, lift the Hoare triple. -/ +theorem HoareTime.weaken_pre {tm : TM n} + {pre pre' post : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) : + tm.HoareTime pre' post b := + h.consequence hpre (fun _ _ _ h => h) le_rfl + +/-- **Postcondition strengthening**: if `post` implies `post'`, lift the triple. -/ +theorem HoareTime.strengthen_post {tm : TM n} + {pre post post' : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) : + tm.HoareTime pre post' b := + h.consequence (fun _ _ _ h => h) hpost le_rfl + +/-- **Time monotonicity**: increase the time bound. -/ +theorem HoareTime.mono_bound {tm : TM n} + {pre post : TapePred n} {b b' : β„•} + (h : tm.HoareTime pre post b) (hle : b ≀ b') : + tm.HoareTime pre post b' := + h.consequence (fun _ _ _ h => h) (fun _ _ _ h => h) hle + +/-- Bounded implies unbounded. -/ +theorem HoareTime.toHoare {tm : TM n} + {pre post : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) : + tm.Hoare pre post := by + intro inp work out hpre + obtain ⟨c', t, _, hreach, hhalt, hpost⟩ := h inp work out hpre + exact ⟨c', TM.reaches_of_reachesIn hreach, hhalt, hpost⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Connection to DecidesInTime +-- ════════════════════════════════════════════════════════════════════════ + +/-- `DecidesInTime` implies a family of Hoare triples, one per input. -/ +theorem hoareTime_of_decidesInTime {tm : TM n} {L : Language} {T : β„• β†’ β„•} + (h : tm.DecidesInTime L T) (x : List Bool) : + tm.HoareTime + (fun inp work out => inp = Tape.init (x.map Ξ“.ofBool) ∧ + (work = fun _ => Tape.init []) ∧ + out = Tape.init []) + (fun _ _ out => (x ∈ L β†’ out.cells 1 = Ξ“.one) ∧ + (x βˆ‰ L β†’ out.cells 1 = Ξ“.zero)) + (T x.length) := by + intro inp work out ⟨hinp, hwork, hout⟩ + subst hinp; subst hout; subst hwork + obtain ⟨c', t, ht, hreach, hhalt, hmem, hnmem⟩ := h x + exact ⟨c', t, ht, hreach, hhalt, hmem, hnmem⟩ + +end TM + +namespace NTM + +variable {n : β„•} + +@[inherit_doc Complexity.TapePred] +abbrev TapePred (n : β„•) := Complexity.TapePred n + +/-- Time-bounded Hoare triple for nondeterministic machines: every choice + sequence of the given length reaches a halted configuration satisfying + `post`. `NTM.trace` already keeps halted configurations fixed, so this + also covers machines that halt earlier than the bound. -/ +def HoareTime (tm : NTM n) (pre post : TapePred n) (bound : β„•) : Prop := + βˆ€ inp work out, pre inp work out β†’ + βˆ€ choices : Fin bound β†’ Bool, + let c' := tm.trace bound choices + { state := tm.qstart, input := inp, work := work, output := out } + tm.halted c' ∧ post c'.input c'.work c'.output + +/-- Consequence rule for NTM Hoare triples. -/ +theorem HoareTime.consequence {tm : NTM n} + {pre pre' post post' : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) : + tm.HoareTime pre' post' b := by + intro inp work out hpre' choices + exact (h inp work out (hpre _ _ _ hpre') choices).imp + (fun hhalt => hhalt) (fun hp => hpost _ _ _ hp) + +/-- Precondition weakening for NTM Hoare triples. -/ +theorem HoareTime.weaken_pre {tm : NTM n} + {pre pre' post : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) : + tm.HoareTime pre' post b := + h.consequence hpre (fun _ _ _ h => h) + +/-- Postcondition strengthening for NTM Hoare triples. -/ +theorem HoareTime.strengthen_post {tm : NTM n} + {pre post post' : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) : + tm.HoareTime pre post' b := + h.consequence (fun _ _ _ h => h) hpost + +/-- Time monotonicity for NTM Hoare triples. Since `NTM.trace` is fixed after + halting, a proof for `b` steps also gives a proof for any larger bound. -/ +theorem HoareTime.mono_bound {tm : NTM n} + {pre post : TapePred n} {b b' : β„•} + (h : tm.HoareTime pre post b) (hle : b ≀ b') : + tm.HoareTime pre post b' := by + intro inp work out hpre choices' + let c0 : Cfg n tm.Q := { state := tm.qstart, input := inp, work := work, output := out } + let choices : Fin b β†’ Bool := fun i => choices' ⟨i.val, by omega⟩ + obtain ⟨hhalt, hpost⟩ := h inp work out hpre choices + have heq := tm.trace_mono hle (choices := choices) (choices' := choices') (c := c0) + (by intro i; rfl) hhalt + constructor + Β· change tm.halted (tm.trace b' choices' c0) + rw [heq] + exact hhalt + Β· change post (tm.trace b' choices' c0).input (tm.trace b' choices' c0).work + (tm.trace b' choices' c0).output + rw [heq] + exact hpost + +/-- Consequence rule plus time-bound weakening for NTM Hoare triples. -/ +theorem HoareTime.consequence_bound {tm : NTM n} + {pre pre' post post' : TapePred n} {b b' : β„•} + (h : tm.HoareTime pre post b) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) + (hbound : b ≀ b') : + tm.HoareTime pre' post' b' := + (h.consequence hpre hpost).mono_bound hbound + +/-- If a finite NTM trace is halted at time `T`, then it has a least halted + prefix time. This is useful for phase-composed machines: Hoare-time facts + give halting by a fixed bound, while phase exits need the first local halt + time. -/ +theorem exists_first_halt_time_of_trace_halted (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) + (hhalt : tm.halted (tm.trace T choices c)) : + βˆƒ t, βˆƒ ht : t ≀ T, + tm.halted (tm.trace t (fun i => choices (Fin.castLE ht i)) c) ∧ + βˆ€ s, (hs : s < t) β†’ + Β¬ tm.halted (tm.trace s + (fun i => choices (Fin.castLE (le_trans (Nat.le_of_lt hs) ht) i)) c) := by + classical + let P : β„• β†’ Prop := fun t => + βˆƒ ht : t ≀ T, tm.halted (tm.trace t (fun i => choices (Fin.castLE ht i)) c) + have hP : βˆƒ t, P t := by + refine ⟨T, le_rfl, ?_⟩ + simpa using hhalt + let t := Nat.find hP + obtain ⟨ht, hhalt_t⟩ : P t := Nat.find_spec hP + refine ⟨t, ht, hhalt_t, ?_⟩ + intro s hs hhalts + have hsP : P s := by + exact ⟨le_trans (Nat.le_of_lt hs) ht, hhalts⟩ + exact (Nat.find_min hP hs) hsP + +/-- Hoare-time corollary of `exists_first_halt_time_of_trace_halted`: every + all-path halting proof yields a least halting prefix for each fixed choice + sequence. -/ +theorem HoareTime.exists_first_halt_time {tm : NTM n} + {pre post : TapePred n} {bound : β„•} + (h : tm.HoareTime pre post bound) + {inp : Tape} {work : Fin n β†’ Tape} {out : Tape} + (hpre : pre inp work out) (choices : Fin bound β†’ Bool) : + βˆƒ t, βˆƒ ht : t ≀ bound, + tm.halted (tm.trace t (fun i => choices (Fin.castLE ht i)) + { state := tm.qstart, input := inp, work := work, output := out }) ∧ + βˆ€ s, (hs : s < t) β†’ + Β¬ tm.halted (tm.trace s + (fun i => choices (Fin.castLE (le_trans (Nat.le_of_lt hs) ht) i)) + { state := tm.qstart, input := inp, work := work, output := out }) := by + have hhalt := (h inp work out hpre choices).1 + exact exists_first_halt_time_of_trace_halted tm bound choices + { state := tm.qstart, input := inp, work := work, output := out } hhalt + +/-- Hoare-time first-halt extraction, preserving the Hoare postcondition at the + first halted prefix. -/ +theorem HoareTime.exists_first_halt_time_with_post {tm : NTM n} + {pre post : TapePred n} {bound : β„•} + (h : tm.HoareTime pre post bound) + {inp : Tape} {work : Fin n β†’ Tape} {out : Tape} + (hpre : pre inp work out) (choices : Fin bound β†’ Bool) : + βˆƒ t, βˆƒ ht : t ≀ bound, + let c0 : Cfg n tm.Q := + { state := tm.qstart, input := inp, work := work, output := out } + tm.halted (tm.trace t (fun i => choices (Fin.castLE ht i)) c0) ∧ + post (tm.trace t (fun i => choices (Fin.castLE ht i)) c0).input + (tm.trace t (fun i => choices (Fin.castLE ht i)) c0).work + (tm.trace t (fun i => choices (Fin.castLE ht i)) c0).output ∧ + βˆ€ s, (hs : s < t) β†’ + Β¬ tm.halted (tm.trace s + (fun i => choices (Fin.castLE (le_trans (Nat.le_of_lt hs) ht) i)) c0) := by + obtain ⟨t, ht, hhalt_t, hfirst⟩ := + h.exists_first_halt_time hpre choices + refine ⟨t, ht, ?_, ?_, ?_⟩ + Β· simpa using hhalt_t + Β· let c0 : Cfg n tm.Q := + { state := tm.qstart, input := inp, work := work, output := out } + let choicesT : Fin t β†’ Bool := fun i => choices (Fin.castLE ht i) + have hpost_bound := (h inp work out hpre choices).2 + have heq := tm.trace_mono ht (choices := choicesT) (choices' := choices) + (c := c0) (by intro i; rfl) (by simpa [c0, choicesT] using hhalt_t) + rw [heq] at hpost_bound + simpa [c0, choicesT] using hpost_bound + Β· intro s hs + simpa using hfirst s hs + +end NTM + +namespace TM + +variable {n : β„•} + +/-- A deterministic Hoare triple lifts to an NTM Hoare triple for `TM.toNTM`. + The bound is unchanged because `toNTM` ignores the choice bit. -/ +theorem HoareTime.toNTM {tm : TM n} {pre post : TapePred n} {b : β„•} + (h : tm.HoareTime pre post b) : + tm.toNTM.HoareTime pre post b := by + intro inp work out hpre choices + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp work out hpre + have htrace := tm.toNTM_trace_of_reachesIn hreach hhalt ht choices + constructor + Β· change (tm.toNTM.trace b choices + { state := tm.qstart, input := inp, work := work, output := out }).state = tm.qhalt + exact htrace β–Έ hhalt + Β· change post + (tm.toNTM.trace b choices + { state := tm.qstart, input := inp, work := work, output := out }).input + (tm.toNTM.trace b choices + { state := tm.qstart, input := inp, work := work, output := out }).work + (tm.toNTM.trace b choices + { state := tm.qstart, input := inp, work := work, output := out }).output + exact htrace β–Έ hpost + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/RetargetOutput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/RetargetOutput.lean new file mode 100644 index 0000000000..856d80dbfa --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/RetargetOutput.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift + +/-! +# Hoare contracts for output redirection + +This module lifts a framed contract through `TM.retargetOutput`, exposing the +source output as the fresh last work tape while pinning the real output to the +standard parked blank tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Lift a framed time contract while redirecting the source machine's output +to the fresh last work tape. -/ +theorem retargetOutput_hoareTime {n : β„•} {pre post : TapePred n} + {bound : β„•} (tm : TM n) (h : tm.HoareTime pre post bound) : + tm.retargetOutput.HoareTime + (fun inp work out => + pre inp (fun i => work (Fin.castSucc i)) (work (Fin.last n)) ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + post inp (fun i => work (Fin.castSucc i)) (work (Fin.last n)) ∧ + out = (Tape.init []).move Dir3.right) + bound := by + intro inp work out hpre + rcases hpre with ⟨hpre, hout⟩ + let baseWork : Fin n β†’ Tape := fun i => work (Fin.castSucc i) + let baseCfg : Cfg n tm.Q := + { state := tm.qstart + input := inp + work := baseWork + output := work (Fin.last n) } + have hstart : + ({ state := tm.retargetOutput.qstart + input := inp + work := work + output := out } : Cfg (n + 1) tm.retargetOutput.Q) = + tm.retargetCfg baseCfg := by + apply Cfg.ext + Β· rfl + Β· rfl + Β· funext i + by_cases hi : i.val < n + Β· rw [retargetCfg_work_lt tm baseCfg i hi] + change work i = work (Fin.castSucc ⟨i.val, hi⟩) + congr + Β· rw [show i = Fin.last n by + apply Fin.ext + simp only [Fin.val_last] + omega] + exact (retargetCfg_work_last tm baseCfg).symm + Β· change out = (Tape.init []).move Dir3.right + exact hout + obtain ⟨c', time, htime, hreach, hhalt, hpost⟩ := + h inp baseWork (work (Fin.last n)) hpre + refine ⟨tm.retargetCfg c', time, htime, ?_, hhalt, ?_⟩ + Β· rw [hstart] + exact retargetOutput_reachesIn_retargetCfg_frame tm hreach + Β· refine ⟨?_, rfl⟩ + simpa [retargetCfg_work_lt, retargetCfg_work_last] using hpost + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space.lean new file mode 100644 index 0000000000..a373cacf09 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Internal + +/-! +# Space-aware Hoare specifications + +`TM.HoareSpace` states the all-reachable auxiliary-space invariant required by +`TM.ComputesInSpace`; `TM.HoareTimeSpace` pairs it with a terminating +time-bounded Hoare triple. +The public API includes structural rules, sequential composition, transducer +closure, and a fresh-start computation bridge. + +## Main results + +- `TM.HoareTimeSpace.consequence` β€” weaken/strengthen every contract component. +- `TM.HoareSpace.weaken_pre`, `TM.HoareSpace.mono` β€” structural space rules. +- `Cfg.WithinAuxSpace.reachesIn` β€” bound head growth along a concrete run. +- `TM.HoareTime.and_hoareSpace` β€” pair existing endpoint and safety proofs. +- `TM.HoareTime.toHoareTimeSpace` β€” derive all-reachable space from time and + an initial head bound. +- `TM.seqTM_hoareTimeSpace` β€” compose two phases at one space budget. +- `TM.IsTransducer.seqTM` β€” sequential composition remains append-only. +- `TM.computesInSpace_of_hoareTimeSpace` β€” package per-input contracts. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cfg + +/-- Enlarging the logical input region and work-space budget preserves an +auxiliary-space bound. -/ +theorem WithinAuxSpace.mono {c : Cfg n Q} + {inputLength inputLength' space space' : β„•} + (h : c.WithinAuxSpace inputLength space) + (hinput : inputLength ≀ inputLength') (hspace : space ≀ space') : + c.WithinAuxSpace inputLength' space' := + h.mono_internal hinput hspace + +/-- The standard combinator phase transition moves input and work heads by at +most one, so one additional auxiliary-space cell covers the seam. -/ +theorem WithinAuxSpace.transition {c : Cfg n Q} + {inputLength space : β„•} (h : c.WithinAuxSpace inputLength space) : + ({ state := c.state, + input := TM.transitionInput c.input, + work := fun i => TM.transitionTape (c.work i), + output := TM.transitionTape c.output } : Cfg n Q).WithinAuxSpace + inputLength (space + 1) := + h.transition_internal + +/-- A `time`-step run can increase every charged head position by at most +`time`, so adding that many cells preserves the auxiliary-space bound. -/ +theorem WithinAuxSpace.reachesIn {tm : TM n} + {c c' : Cfg n tm.Q} {time inputLength space : β„•} + (h : c.WithinAuxSpace inputLength space) + (hreach : tm.reachesIn time c c') : + c'.WithinAuxSpace inputLength (space + time) := + h.reachesIn_internal hreach + +end Cfg + +namespace TM + +variable {n : β„•} + +/-- Strengthening the precondition preserves an all-reachable space contract. -/ +theorem HoareSpace.weaken_pre {tm : TM n} + {pre pre' : TapePred n} {inputLength space : β„•} + (h : tm.HoareSpace pre inputLength space) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) : + tm.HoareSpace pre' inputLength space := + h.weaken_pre_internal hpre + +/-- Enlarging the logical input region and auxiliary-space budget preserves a +space contract. -/ +theorem HoareSpace.mono {tm : TM n} + {pre : TapePred n} {inputLength inputLength' space space' : β„•} + (h : tm.HoareSpace pre inputLength space) + (hinput : inputLength ≀ inputLength') (hspace : space ≀ space') : + tm.HoareSpace pre inputLength' space' := + h.mono_internal hinput hspace + +/-- Pair an existing terminating Hoare proof with an all-reachable space +proof. This is the main entry point for upgrading established subroutine +contracts without reproving their endpoint behavior. -/ +theorem HoareTime.and_hoareSpace {tm : TM n} + {pre post : TapePred n} {time inputLength space : β„•} + (htime : tm.HoareTime pre post time) + (hspace : tm.HoareSpace pre inputLength space) : + tm.HoareTimeSpace pre post time inputLength space := + ⟨htime, hspace⟩ + +/-- Upgrade a terminating time-bounded Hoare triple to an all-reachable +time-and-space contract. If every starting configuration fits in +`initialSpace`, then at most one additional cell per machine step gives the +uniform bound `initialSpace + time`. -/ +theorem HoareTime.toHoareTimeSpace {tm : TM n} + {pre post : TapePred n} {time inputLength initialSpace : β„•} + (htime : tm.HoareTime pre post time) + (hinitial : βˆ€ inp work out, pre inp work out β†’ + ({ state := tm.qstart, input := inp, work := work, output := out } : + Cfg n tm.Q).WithinAuxSpace inputLength initialSpace) : + tm.HoareTimeSpace pre post time inputLength (initialSpace + time) := + htime.toHoareTimeSpace_internal hinitial + +/-- A time-and-space contract exposes its ordinary time-bounded Hoare triple. -/ +theorem HoareTimeSpace.toHoareTime {tm : TM n} + {pre post : TapePred n} {time inputLength space : β„•} + (h : tm.HoareTimeSpace pre post time inputLength space) : + tm.HoareTime pre post time := + h.1 + +/-- A time-and-space contract exposes its all-reachable space component. -/ +theorem HoareTimeSpace.toHoareSpace {tm : TM n} + {pre post : TapePred n} {time inputLength space : β„•} + (h : tm.HoareTimeSpace pre post time inputLength space) : + tm.HoareSpace pre inputLength space := + h.2 + +/-- Consequence rule: strengthen the precondition, weaken the postcondition, +and enlarge any of the three numerical bounds. -/ +theorem HoareTimeSpace.consequence {tm : TM n} + {pre pre' post post' : TapePred n} + {time time' inputLength inputLength' space space' : β„•} + (h : tm.HoareTimeSpace pre post time inputLength space) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) + (htime : time ≀ time') (hinput : inputLength ≀ inputLength') + (hspace : space ≀ space') : + tm.HoareTimeSpace pre' post' time' inputLength' space' := + h.consequence_internal hpre hpost htime hinput hspace + +/-- Sequentially composing one-way-output machines preserves the transducer +discipline. -/ +theorem IsTransducer.seqTM {tm₁ tmβ‚‚ : TM n} + (h₁ : tm₁.IsTransducer) (hβ‚‚ : tmβ‚‚.IsTransducer) : + (seqTM tm₁ tmβ‚‚).IsTransducer := + h₁.seqTM_internal hβ‚‚ + +/-- Sequential composition of time-and-space Hoare contracts. -/ +theorem seqTM_hoareTimeSpace (tm₁ tmβ‚‚ : TM n) + {pre mid mid' post : TapePred n} + {b₁ bβ‚‚ inputLength space₁ spaceβ‚‚ : β„•} + (h₁ : tm₁.HoareTimeSpace pre mid b₁ inputLength space₁) + (htrans : βˆ€ inp work out, mid inp work out β†’ + mid' (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) + (hβ‚‚ : tmβ‚‚.HoareTimeSpace mid' post bβ‚‚ inputLength spaceβ‚‚) : + (seqTM tm₁ tmβ‚‚).HoareTimeSpace pre post (b₁ + 1 + bβ‚‚) + inputLength (max space₁ spaceβ‚‚) := + seqTM_hoareTimeSpace_internal tm₁ tmβ‚‚ h₁ htrans hβ‚‚ + +/-- Per-input fresh-start time-and-space contracts package a total function +transducer satisfying `TM.ComputesInSpace`. -/ +theorem computesInSpace_of_hoareTimeSpace + {tm : TM n} {f : List Bool β†’ List Bool} {T S : β„• β†’ β„•} + (htrans : tm.IsTransducer) + (h : βˆ€ x, tm.HoareTimeSpace + (fun inp work out => + inp = Tape.init (x.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _ _ out => out.HasOutput (f x)) + (T x.length) x.length (S x.length)) : + tm.ComputesInSpace f S := + computesInSpace_of_hoareTimeSpace_internal htrans h + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Defs.lean new file mode 100644 index 0000000000..aa6ff8ac6e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Defs.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# Space-aware Hoare specifications β€” definitions + +Ordinary `TM.HoareTime` records a bounded terminating run, but logarithmic-space +computation requires a bound on every reachable configuration. This module +pairs those two obligations in one compositional contract. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- An all-reachable auxiliary-space contract from tapes satisfying `pre`. -/ +def HoareSpace (tm : TM n) (pre : TapePred n) + (inputLength spaceBound : β„•) : Prop := + βˆ€ inp work out, pre inp work out β†’ + βˆ€ c', tm.reaches + { state := tm.qstart, input := inp, work := work, output := out } c' β†’ + c'.WithinAuxSpace inputLength spaceBound + +/-- A time-and-space Hoare contract: ordinary terminating behavior paired with +an independent all-reachable auxiliary-space contract. -/ +def HoareTimeSpace (tm : TM n) (pre post : TapePred n) + (timeBound inputLength spaceBound : β„•) : Prop := + tm.HoareTime pre post timeBound ∧ tm.HoareSpace pre inputLength spaceBound + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean new file mode 100644 index 0000000000..63001c213e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Hoare/Space/Internal.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability + +/-! +# Space-aware Hoare specifications β€” proof internals + +This module supplies structural rules, sequential composition, and the bridge +from fresh-start contracts to `TM.ComputesInSpace`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cfg + +/-- Internal monotonicity of the honest auxiliary-space predicate. -/ +theorem WithinAuxSpace.mono_internal {c : Cfg n Q} + {inputLength inputLength' space space' : β„•} + (h : c.WithinAuxSpace inputLength space) + (hinput : inputLength ≀ inputLength') (hspace : space ≀ space') : + c.WithinAuxSpace inputLength' space' := by + constructor + Β· intro i + exact (h.1 i).trans hspace + Β· calc + c.input.head ≀ inputLength + space + 1 := h.2 + _ ≀ inputLength' + space' + 1 := by omega + +/-- Internal phase-boundary bound: the standard input/work tape transition +moves every head by at most one. -/ +theorem WithinAuxSpace.transition_internal {c : Cfg n Q} + {inputLength space : β„•} (h : c.WithinAuxSpace inputLength space) : + ({ state := c.state, + input := TM.transitionInput c.input, + work := fun i => TM.transitionTape (c.work i), + output := TM.transitionTape c.output } : Cfg n Q).WithinAuxSpace + inputLength (space + 1) := by + constructor + Β· intro i + calc + (TM.transitionTape (c.work i)).head ≀ (c.work i).head + 1 := + Tape.head_writeAndMove_le _ _ _ + _ ≀ space + 1 := Nat.add_le_add_right (h.1 i) 1 + Β· calc + (TM.transitionInput c.input).head ≀ c.input.head + 1 := + Tape.head_move_le _ _ + _ ≀ inputLength + space + 1 + 1 := Nat.add_le_add_right h.2 1 + _ = inputLength + (space + 1) + 1 := by omega + +/-- Internal reachability rule: after `time` concrete transitions, one extra +auxiliary-space cell per transition covers every input and work head. -/ +theorem WithinAuxSpace.reachesIn_internal {tm : TM n} + {c c' : Cfg n tm.Q} {time inputLength space : β„•} + (h : c.WithinAuxSpace inputLength space) + (hreach : tm.reachesIn time c c') : + c'.WithinAuxSpace inputLength (space + time) := by + constructor + Β· intro i + calc + (c'.work i).head ≀ (c.work i).head + time := + tm.work_head_reachesIn_bound hreach i + _ ≀ space + time := Nat.add_le_add_right (h.1 i) time + Β· calc + c'.input.head ≀ c.input.head + time := + tm.input_head_reachesIn_bound hreach + _ ≀ inputLength + (space + time) + 1 := by + have hinput := h.2 + omega + +end Cfg + +namespace TM + +variable {n : β„•} + +/-- Internal precondition weakening for all-reachable space contracts. -/ +theorem HoareSpace.weaken_pre_internal {tm : TM n} + {pre pre' : TapePred n} {inputLength space : β„•} + (h : tm.HoareSpace pre inputLength space) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) : + tm.HoareSpace pre' inputLength space := by + intro inp work out hpre' c' hreach + exact h inp work out (hpre inp work out hpre') c' hreach + +/-- Internal numerical monotonicity for all-reachable space contracts. -/ +theorem HoareSpace.mono_internal {tm : TM n} + {pre : TapePred n} {inputLength inputLength' space space' : β„•} + (h : tm.HoareSpace pre inputLength space) + (hinput : inputLength ≀ inputLength') (hspace : space ≀ space') : + tm.HoareSpace pre inputLength' space' := by + intro inp work out hpre c' hreach + exact (h inp work out hpre c' hreach).mono_internal hinput hspace + +/-- Internal time-to-space bridge. Determinism bounds every reachable prefix +by the terminating run supplied by the Hoare triple, and tape heads grow by at +most one cell per step. -/ +theorem HoareTime.toHoareTimeSpace_internal {tm : TM n} + {pre post : TapePred n} {time inputLength initialSpace : β„•} + (htime : tm.HoareTime pre post time) + (hinitial : βˆ€ inp work out, pre inp work out β†’ + ({ state := tm.qstart, input := inp, work := work, output := out } : + Cfg n tm.Q).WithinAuxSpace inputLength initialSpace) : + tm.HoareTimeSpace pre post time inputLength (initialSpace + time) := by + refine ⟨htime, ?_⟩ + intro inp work out hpre c hreach + obtain ⟨cHalt, haltTime, hhaltTime, hrun, hhalt, _hpost⟩ := + htime inp work out hpre + obtain ⟨t, hreachIn⟩ := tm.reaches_to_reachesIn hreach + have ht : t ≀ haltTime := tm.reachesIn_le_halt hreachIn hrun hhalt + have hstart := hinitial inp work out hpre + exact (hstart.reachesIn_internal hreachIn).mono_internal le_rfl (by omega) + +/-- Internal consequence rule for time-and-space Hoare contracts. -/ +theorem HoareTimeSpace.consequence_internal {tm : TM n} + {pre pre' post post' : TapePred n} + {time time' inputLength inputLength' space space' : β„•} + (h : tm.HoareTimeSpace pre post time inputLength space) + (hpre : βˆ€ inp work out, pre' inp work out β†’ pre inp work out) + (hpost : βˆ€ inp work out, post inp work out β†’ post' inp work out) + (htime : time ≀ time') (hinput : inputLength ≀ inputLength') + (hspace : space ≀ space') : + tm.HoareTimeSpace pre' post' time' inputLength' space' := by + constructor + Β· exact h.1.consequence hpre hpost htime + Β· intro inp work out hpre' c' hreach + exact (h.2 inp work out (hpre inp work out hpre') c' hreach).mono_internal + hinput hspace + +/-- Internal transducer closure under sequential composition. -/ +theorem IsTransducer.seqTM_internal {tm₁ tmβ‚‚ : TM n} + (h₁ : tm₁.IsTransducer) (hβ‚‚ : tmβ‚‚.IsTransducer) : + (seqTM tm₁ tmβ‚‚).IsTransducer := by + intro state iHead wHeads oHead + cases state with + | inl q => + simp only [seqTM] + split + Β· simp only [idleDir] + split <;> decide + Β· exact h₁ q iHead wHeads oHead + | inr q => + simp only [seqTM] + split + Β· simp only [allIdle, idleDir] + split <;> decide + Β· exact hβ‚‚ q iHead wHeads oHead + +/-- Internal sequential composition rule. Both phases use one shared logical +input length and auxiliary-space budget; the phase boundary is covered by the +second contract at its reflexive initial configuration. -/ +theorem seqTM_hoareTimeSpace_internal (tm₁ tmβ‚‚ : TM n) + {pre mid mid' post : TapePred n} {b₁ bβ‚‚ inputLength space₁ spaceβ‚‚ : β„•} + (h₁ : tm₁.HoareTimeSpace pre mid b₁ inputLength space₁) + (htrans : βˆ€ inp work out, mid inp work out β†’ + mid' (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) + (hβ‚‚ : tmβ‚‚.HoareTimeSpace mid' post bβ‚‚ inputLength spaceβ‚‚) : + (seqTM tm₁ tmβ‚‚).HoareTimeSpace pre post (b₁ + 1 + bβ‚‚) + inputLength (max space₁ spaceβ‚‚) := by + constructor + Β· exact seqTM_hoareTime tm₁ tmβ‚‚ h₁.1 htrans hβ‚‚.1 + Β· intro inp work out hpre c hreach + obtain ⟨c₁, t₁, _ht₁, hreach₁, hhalt₁, hmid⟩ := + h₁.1 inp work out hpre + have hmid' := htrans c₁.input c₁.work c₁.output hmid + obtain ⟨cβ‚‚, tβ‚‚, _htβ‚‚, hreachβ‚‚, hhaltβ‚‚, _hpost⟩ := + hβ‚‚.1 (transitionInput c₁.input) + (fun i => transitionTape (c₁.work i)) (transitionTape c₁.output) hmid' + have hfull := seqTM_reachesIn_of_reachesIn tm₁ tmβ‚‚ + hreach₁ hhalt₁ hreachβ‚‚ + have hfullHalt : + (seqTM tm₁ tmβ‚‚).halted (phase2Wrap tm₁ tmβ‚‚ cβ‚‚) := + (phase2Wrap_halted_iff tm₁ tmβ‚‚ cβ‚‚).2 hhaltβ‚‚ + obtain ⟨t, hreachT⟩ := (seqTM tm₁ tmβ‚‚).reaches_to_reachesIn hreach + have ht : t ≀ t₁ + 1 + tβ‚‚ := + (seqTM tm₁ tmβ‚‚).reachesIn_le_halt hreachT hfull hfullHalt + by_cases hphase₁ : t ≀ t₁ + Β· obtain ⟨d, hprefix, _hsuffix⟩ := + reachesIn_prefix_internal hreach₁ hphase₁ + have hwrapped := seqTM_reachesIn_phase1Wrap tm₁ tmβ‚‚ hprefix + have hwrapped' : + (seqTM tm₁ tmβ‚‚).reachesIn t + { state := (seqTM tm₁ tmβ‚‚).qstart, input := inp, + work := work, output := out } + (phase1Wrap tm₁ tmβ‚‚ d) := by + simpa [phase1Wrap, seqTM] using hwrapped + have hc : c = phase1Wrap tm₁ tmβ‚‚ d := + (seqTM tm₁ tmβ‚‚).reachesIn_right_unique hreachT hwrapped' + rw [hc] + have hd := h₁.2 inp work out hpre d + (TM.reaches_of_reachesIn hprefix) + exact hd.mono_internal le_rfl (le_max_left _ _) + Β· have hphaseβ‚‚ : t₁ + 1 ≀ t := by omega + let u := t - (t₁ + 1) + have hu : u ≀ tβ‚‚ := by + dsimp only [u] + omega + obtain ⟨d, hprefix, _hsuffix⟩ := + reachesIn_prefix_internal hreachβ‚‚ hu + have hwrapped := seqTM_reachesIn_of_reachesIn tm₁ tmβ‚‚ + hreach₁ hhalt₁ hprefix + have htime : t₁ + 1 + u = t := by + dsimp only [u] + omega + rw [htime] at hwrapped + have hc : c = phase2Wrap tm₁ tmβ‚‚ d := + (seqTM tm₁ tmβ‚‚).reachesIn_right_unique hreachT hwrapped + rw [hc] + have hd := hβ‚‚.2 (transitionInput c₁.input) + (fun i => transitionTape (c₁.work i)) (transitionTape c₁.output) + hmid' d (TM.reaches_of_reachesIn hprefix) + exact hd.mono_internal le_rfl (le_max_right _ _) + +/-- Internal bridge from fresh-start time-and-space contracts to function +computation in space. -/ +theorem computesInSpace_of_hoareTimeSpace_internal + {tm : TM n} {f : List Bool β†’ List Bool} {T S : β„• β†’ β„•} + (htrans : tm.IsTransducer) + (h : βˆ€ x, tm.HoareTimeSpace + (fun inp work out => + inp = Tape.init (x.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun _ _ out => out.HasOutput (f x)) + (T x.length) x.length (S x.length)) : + tm.ComputesInSpace f S := by + refine ⟨htrans, ?_, ?_⟩ + Β· intro x c' hreach + exact (h x).2 _ _ _ ⟨rfl, rfl, rfl⟩ c' hreach + Β· intro x + obtain ⟨c', t, _ht, hreach, hhalt, hout⟩ := + (h x).1 _ _ _ ⟨rfl, rfl, rfl⟩ + exact ⟨c', TM.reaches_of_reachesIn hreach, hhalt, hout⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal.lean new file mode 100644 index 0000000000..4054052a72 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal.lean @@ -0,0 +1,691 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine +public import Mathlib.Data.Finset.Lattice.Fold + +/-! +# TM–NTM embedding: proof internals + +Helper lemmas for `TM.toNTM_accepts_iff`, showing that the DTM step function +and the NTM trace on `toNTM` compute the same thing. +-/ + + +@[expose] public section + +namespace Complexity + +variable {n : β„•} + +private lemma TM.toNTM_trace_step (tm : TM n) {c : Cfg n tm.Q} + (T : β„•) (choices : Fin (T + 1) β†’ Bool) (hne : c.state β‰  tm.qhalt) : + tm.toNTM.trace (T + 1) choices c = + tm.toNTM.trace T (fun i => choices ⟨i.val + 1, by omega⟩) + ((tm.step c).get (by simp [TM.step, hne])) := by + simp [NTM.trace, hne, TM.toNTM, TM.step] + +private lemma TM.reaches_toNTM_trace (tm : TM n) {a c' : Cfg n tm.Q} + (hreach : tm.reaches a c') : + βˆƒ T, βˆ€ (ch : Fin T β†’ Bool), tm.toNTM.trace T ch a = c' := by + induction hreach using Relation.ReflTransGen.head_induction_on with + | refl => exact ⟨0, fun _ => rfl⟩ + | @head aβ‚€ bβ‚€ hstep _ ih => + obtain ⟨T, hT⟩ := ih + have hne : aβ‚€.state β‰  tm.qhalt := by + rw [TM.stepRel] at hstep; exact state_ne_qhalt_of_step hstep + refine ⟨T + 1, fun ch => ?_⟩ + rw [tm.toNTM_trace_step T ch hne] + have : (tm.step aβ‚€).get (by simp [TM.step, hne]) = bβ‚€ := by + simp [TM.stepRel] at hstep; simp [hstep] + rw [this]; exact hT _ + +lemma TM.toNTM_trace_reaches (tm : TM n) (c : Cfg n tm.Q) + (T : β„•) (choices : Fin T β†’ Bool) : + tm.reaches c (tm.toNTM.trace T choices c) := by + induction T generalizing c with + | zero => exact Relation.ReflTransGen.refl + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simpa [NTM.trace, TM.toNTM, TM.reaches, hhalt] using + (Relation.ReflTransGen.refl : tm.reaches c c) + Β· rw [tm.toNTM_trace_step T choices hhalt] + exact Relation.ReflTransGen.head + (show tm.stepRel c _ by simp [TM.stepRel, TM.step, hhalt]) (ih _ _) + +/-- For `toNTM`, the trace is independent of the choice sequence since both + transition functions are identical. -/ +lemma TM.toNTM_trace_choice_irrel (tm : TM n) (T : β„•) (c : Cfg n tm.Q) + (ch₁ chβ‚‚ : Fin T β†’ Bool) : + tm.toNTM.trace T ch₁ c = tm.toNTM.trace T chβ‚‚ c := by + induction T generalizing c with + | zero => rfl + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, TM.toNTM, hhalt] + Β· rw [tm.toNTM_trace_step T ch₁ hhalt, tm.toNTM_trace_step T chβ‚‚ hhalt] + exact ih _ _ _ + +/-- If a DTM reaches `c'` in exactly `t` steps, then `toNTM.trace t` agrees. -/ +private lemma TM.toNTM_reachesIn_trace (tm : TM n) {c c' : Cfg n tm.Q} {t : β„•} + (h : tm.reachesIn t c c') (ch : Fin t β†’ Bool) : + tm.toNTM.trace t ch c = c' := by + induction h with + | zero => rfl + | @step cβ‚€ c_mid _ _ hstep _ ih => + have hne := state_ne_qhalt_of_step hstep + rw [tm.toNTM_trace_step _ ch hne] + have : (tm.step cβ‚€).get (by simp [TM.step, hne]) = c_mid := by + simp [TM.step, hne] at hstep ⊒; exact hstep + rw [this]; exact ih _ + +/-- If a DTM halts within `t ≀ T` steps, then `toNTM.trace T` reaches the same + halted configuration regardless of choices. -/ +lemma TM.toNTM_trace_of_reachesIn (tm : TM n) {c c' : Cfg n tm.Q} + {t T : β„•} (h : tm.reachesIn t c c') (hhalt : tm.halted c') + (hle : t ≀ T) (ch : Fin T β†’ Bool) : + tm.toNTM.trace T ch c = c' := by + induction T generalizing c t with + | zero => + have : t = 0 := by omega + subst this; cases h; rfl + | succ T ih => + by_cases hh : c.state = tm.qhalt + Β· -- c is halted β†’ t = 0 β†’ c = c' + have : t = 0 := by + by_contra hp; obtain ⟨t', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hp + cases h with | step hs _ => simp [TM.step, hh] at hs + subst this; cases h; simp [NTM.trace, TM.toNTM, hh] + Β· -- c not halted β†’ t > 0 β†’ peel one step + have ht_pos : t β‰  0 := by + intro h0; subst h0; cases h; exact hh hhalt + obtain ⟨t', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ht_pos + obtain ⟨c_mid, hstep, hrest⟩ : + βˆƒ c_mid, tm.step c = some c_mid ∧ tm.reachesIn t' c_mid c' := by + cases h with | step hs hr => exact ⟨_, hs, hr⟩ + rw [tm.toNTM_trace_step T ch hh] + have : (tm.step c).get (by simp [TM.step, hh]) = c_mid := by + simp [hstep] + rw [this] + exact ih hrest (by omega) _ + +/-- The DTM and its NTM embedding agree on acceptance. -/ +theorem TM.toNTM_accepts_iff (tm : TM n) (x : List Bool) : + tm.Accepts x ↔ (tm.toNTM).Accepts x := by + constructor + Β· rintro ⟨c', hreach, hhalt, hout⟩ + obtain ⟨T, hT⟩ := tm.reaches_toNTM_trace hreach + exact ⟨T, fun _ => false, + by change (tm.toNTM.trace T _ (tm.initCfg x)).state = _; rw [hT]; exact hhalt, + by change (tm.toNTM.trace T _ (tm.initCfg x)).output.cells 1 = _; rw [hT]; exact hout⟩ + Β· rintro ⟨T, choices, hhalt, hout⟩ + exact ⟨_, tm.toNTM_trace_reaches _ T choices, hhalt, hout⟩ + +/-- If a DTM decides `L` in time `f`, then its NTM embedding also decides `L` + in time `f`. This is the key internal lemma for `DTIME βŠ† NTIME`. -/ +theorem TM.toNTM_decidesInTime (tm : TM n) {L : Language} {f : β„• β†’ β„•} + (h : tm.DecidesInTime L f) : tm.toNTM.DecidesInTime L f := by + refine ⟨?_, ?_⟩ + Β· -- AllPathsHaltIn + intro x choices + obtain ⟨c', t, hle, hreach, hhalt, _, _⟩ := h x + have htrace := tm.toNTM_trace_of_reachesIn hreach hhalt hle choices + change (tm.toNTM.trace _ choices (tm.initCfg x)).state = tm.qhalt + rw [htrace]; exact hhalt + Β· -- x ∈ L ↔ AcceptsInTime + intro x; constructor + Β· -- x ∈ L β†’ AcceptsInTime + intro hx + obtain ⟨c', t, hle, hreach, hhalt, hyes, _⟩ := h x + refine ⟨fun _ => false, ?_, ?_⟩ + Β· change (tm.toNTM.trace _ _ (tm.initCfg x)).state = _ + rw [tm.toNTM_trace_of_reachesIn hreach hhalt hle]; exact hhalt + Β· change (tm.toNTM.trace _ _ (tm.initCfg x)).output.cells 1 = _ + rw [tm.toNTM_trace_of_reachesIn hreach hhalt hle]; exact hyes hx + Β· -- AcceptsInTime β†’ x ∈ L + intro ⟨choices, hhalt_ch, hout_ch⟩ + obtain ⟨c', t, hle, hreach, hhalt, _, hno⟩ := h x + by_contra hxL + have htrace := tm.toNTM_trace_of_reachesIn hreach hhalt hle choices + change (tm.toNTM.trace _ choices (tm.initCfg x)).output.cells 1 = _ at hout_ch + rw [htrace] at hout_ch + have := hno hxL + simp_all + +/-- Work tape heads grow by at most 1 per step. -/ +private lemma TM.work_head_step_bound (tm : TM n) {c c' : Cfg n tm.Q} + (h : tm.step c = some c') (i : Fin n) : + (c'.work i).head ≀ (c.work i).head + 1 := by + simp only [TM.step] at h + split at h + Β· simp at h + Β· simp only [Option.some.injEq] at h + rw [← h] + exact Tape.head_writeAndMove_le _ _ _ + +/-- The input head grows by at most one in a machine step. -/ +private lemma TM.input_head_step_bound (tm : TM n) {c c' : Cfg n tm.Q} + (h : tm.step c = some c') : c'.input.head ≀ c.input.head + 1 := by + simp only [TM.step] at h + split at h + Β· simp at h + Β· simp only [Option.some.injEq] at h + rw [← h] + exact Tape.head_move_le _ _ + +/-- The output head grows by at most one in a machine step. -/ +private lemma TM.output_head_step_bound (tm : TM n) {c c' : Cfg n tm.Q} + (h : tm.step c = some c') : c'.output.head ≀ c.output.head + 1 := by + simp only [TM.step] at h + split at h + Β· simp at h + Β· simp only [Option.some.injEq] at h + rw [← h] + exact Tape.head_writeAndMove_le _ _ _ + +/-- After `t` steps, each work tape head is at most `t` plus its initial value. -/ +theorem TM.work_head_reachesIn_bound (tm : TM n) {c c' : Cfg n tm.Q} {t : β„•} + (h : tm.reachesIn t c c') (i : Fin n) : + (c'.work i).head ≀ (c.work i).head + t := by + induction h with + | zero => omega + | @step cβ‚€ c_mid _ _ hstep _ ih => + have := tm.work_head_step_bound hstep i + omega + +/-- After `t` steps, the input head is at most `t` plus its initial value. -/ +theorem TM.input_head_reachesIn_bound (tm : TM n) {c c' : Cfg n tm.Q} {t : β„•} + (h : tm.reachesIn t c c') : c'.input.head ≀ c.input.head + t := by + induction h with + | zero => omega + | @step cβ‚€ c_mid _ _ hstep _ ih => + have := tm.input_head_step_bound hstep + omega + +/-- After `t` steps, the output head is at most `t` plus its initial value. -/ +theorem TM.output_head_reachesIn_bound (tm : TM n) {c c' : Cfg n tm.Q} {t : β„•} + (h : tm.reachesIn t c c') : c'.output.head ≀ c.output.head + t := by + induction h with + | zero => omega + | @step cβ‚€ c_mid _ _ hstep _ ih => + have := tm.output_head_step_bound hstep + omega + +/-- Deterministic runs have unique endpoints: reaching two configurations in + the same number of steps forces them to coincide. -/ +theorem TM.reachesIn_right_unique {tm : TM n} {t : β„•} {c c' c'' : Cfg n tm.Q} + (h₁ : tm.reachesIn t c c') (hβ‚‚ : tm.reachesIn t c c'') : c' = c'' := by + induction h₁ with + | zero => cases hβ‚‚; rfl + | step hs₁ _ ih₁ => + cases hβ‚‚ with + | step hsβ‚‚ hβ‚‚' => + have heq : some _ = some _ := hs₁.symm.trans hsβ‚‚ + simp only [Option.some.injEq] at heq; subst heq + exact ih₁ hβ‚‚' + +/-- Convert `reaches` to `reachesIn`. -/ +theorem TM.reaches_to_reachesIn (tm : TM n) {c c' : Cfg n tm.Q} + (h : tm.reaches c c') : βˆƒ t, tm.reachesIn t c c' := by + induction h using Relation.ReflTransGen.head_induction_on with + | refl => exact ⟨0, .zero⟩ + | head hstep _ ih => + obtain ⟨t, ht⟩ := ih + exact ⟨t + 1, .step hstep ht⟩ + +/-- A DTM step is deterministic: `step` is a function. -/ +private lemma TM.step_det (tm : TM n) {c c₁ cβ‚‚ : Cfg n tm.Q} + (h₁ : tm.step c = some c₁) (hβ‚‚ : tm.step c = some cβ‚‚) : c₁ = cβ‚‚ := by + rw [h₁] at hβ‚‚; exact Option.some.inj hβ‚‚ + +/-- If a DTM halts at step `t_halt`, then any `reachesIn t` has `t ≀ t_halt`. -/ +theorem TM.reachesIn_le_halt (tm : TM n) {c c' c_halt : Cfg n tm.Q} + {t t_halt : β„•} (hr : tm.reachesIn t c c') + (hh : tm.reachesIn t_halt c c_halt) (hhalt : tm.halted c_halt) : + t ≀ t_halt := by + induction t generalizing c t_halt with + | zero => omega + | succ t ih => + cases hr with | @step cβ‚€ c_mid _ _ hs hr' => + cases t_halt with + | zero => + cases hh + simp [TM.step, hhalt] at hs + | succ t_halt' => + cases hh with | step hs' hh' => + have := tm.step_det hs hs' + subst this + exact Nat.succ_le_succ (ih hr' hh') + +/-- Initial work tape heads are all at position 0. -/ +lemma TM.initCfg_work_head_zero (tm : TM n) (x : List Bool) (i : Fin n) : + ((tm.initCfg x).work i).head = 0 := by + simp [Tape.init] + +/-- The initial input head is at position zero. -/ +lemma TM.initCfg_input_head_zero (tm : TM n) (x : List Bool) : + (tm.initCfg x).input.head = 0 := rfl + +/-- The initial output head is at position zero. -/ +lemma TM.initCfg_output_head_zero (tm : TM n) (x : List Bool) : + (tm.initCfg x).output.head = 0 := rfl + +/-- If a DTM is a transducer, so is its NTM embedding. -/ +theorem TM.toNTM_isTransducer (tm : TM n) (h : tm.IsTransducer) : tm.toNTM.IsTransducer := by + intro b q iHead wHeads oHead + simp only [TM.toNTM] + exact h q iHead wHeads oHead + +/-- If a DTM decides `L` in space `f`, then its NTM embedding also decides `L` + in space `f`. The uniform time bound is constructed as the maximum halting + time over all inputs of each length. -/ +theorem TM.toNTM_decidesInSpace (tm : TM n) {L : Language} {f : β„• β†’ β„•} + (h : tm.DecidesInSpace L f) : tm.toNTM.DecidesInSpace L f := by + -- Extract per-input halting times + have hdata : βˆ€ x, βˆƒ t c', tm.reachesIn t (tm.initCfg x) c' ∧ tm.halted c' ∧ + (x ∈ L β†’ c'.output.cells 1 = Ξ“.one) ∧ (x βˆ‰ L β†’ c'.output.cells 1 = Ξ“.zero) := by + intro x + obtain ⟨c', hreach, hhalt, hyes, hno⟩ := h.2 x + obtain ⟨t, hreachIn⟩ := tm.reaches_to_reachesIn hreach + exact ⟨t, c', hreachIn, hhalt, hyes, hno⟩ + choose t_fn c_fn hreachIn hhalt hyes hno using hdata + -- Uniform time bound: max halting time over all inputs of each length + let T : β„• β†’ β„• := fun m => + Finset.sup (Finset.univ : Finset (Fin m β†’ Bool)) (fun v => t_fn (List.ofFn v)) + have hle_T : βˆ€ x, t_fn x ≀ T x.length := by + intro x + show t_fn x ≀ Finset.sup Finset.univ (fun v => t_fn (List.ofFn v)) + conv_lhs => rw [show x = List.ofFn (fun i : Fin x.length => x[↑i]) from + (List.ofFn_getElem (xs := x)).symm] + exact Finset.le_sup (f := fun v => t_fn (List.ofFn v)) + (Finset.mem_univ (fun i : Fin x.length => x[↑i])) + refine ⟨T, ⟨?_, ?_⟩, ?_⟩ + Β· -- AllPathsHaltIn + intro x choices + have htrace := tm.toNTM_trace_of_reachesIn (hreachIn x) (hhalt x) (hle_T x) choices + change (tm.toNTM.trace _ choices (tm.initCfg x)).state = tm.qhalt + rw [htrace]; exact hhalt x + Β· -- x ∈ L ↔ AcceptsInTime + intro x; constructor + Β· intro hx + refine ⟨fun _ => false, ?_, ?_⟩ + Β· change (tm.toNTM.trace _ _ (tm.initCfg x)).state = tm.qhalt + rw [tm.toNTM_trace_of_reachesIn (hreachIn x) (hhalt x) (hle_T x)] + exact hhalt x + Β· change (tm.toNTM.trace _ _ (tm.initCfg x)).output.cells 1 = Ξ“.one + rw [tm.toNTM_trace_of_reachesIn (hreachIn x) (hhalt x) (hle_T x)] + exact hyes x hx + Β· intro ⟨choices, hhalt_ch, hout_ch⟩ + by_contra hxL + have htrace := tm.toNTM_trace_of_reachesIn (hreachIn x) (hhalt x) (hle_T x) choices + change (tm.toNTM.trace _ choices (tm.initCfg x)).output.cells 1 = _ at hout_ch + rw [htrace] at hout_ch + have := hno x hxL + simp_all + Β· -- Space bound + intro x choices t' ht' + have hreach := tm.toNTM_trace_reaches (tm.initCfg x) t' + (fun j : Fin t' => choices ⟨j.val, by omega⟩) + exact h.1 x _ hreach + + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape invariant helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Cell 0 stays Ξ“.start after write + move. -/ +private theorem tape_cell0_preserved (t : Tape) (s : Ξ“) (d : Dir3) + (h0 : t.cells 0 = Ξ“.start) : + ((t.write s).move d).cells 0 = Ξ“.start := by + rw [Tape.move_cells]; simp only [Tape.write] + split + Β· exact h0 + Β· simp only [Function.update, dite_eq_right (show (0 : β„•) β‰  t.head from fun h => by omega)] + exact h0 + +/-- Cells β‰₯ 1 stay non-Ξ“.start after writing a non-Ξ“.start value. -/ +private theorem tape_noStart_preserved (t : Tape) (s : Ξ“) (d : Dir3) + (hs : s β‰  Ξ“.start) (hno : βˆ€ i, i β‰₯ 1 β†’ t.cells i β‰  Ξ“.start) : + βˆ€ i, i β‰₯ 1 β†’ ((t.write s).move d).cells i β‰  Ξ“.start := by + intro i hi; rw [Tape.move_cells]; simp only [Tape.write] + split + Β· exact hno i hi + Β· simp only [Function.update]; split + Β· next heq => subst heq; exact hs + Β· exact hno i hi + +/-- Output cell 0 = Ξ“.start is preserved by one TM step. -/ +private theorem output_cell0_step {tm : TM n} {c c' : Cfg n tm.Q} + (hs : tm.step c = some c') (h0 : c.output.cells 0 = Ξ“.start) : + c'.output.cells 0 = Ξ“.start := by + have hne := state_ne_qhalt_of_step hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact tape_cell0_preserved _ _ _ h0 + +/-- Work-tape cell 0 is preserved by one TM step. -/ +private theorem work_cell0_step {tm : TM n} {c c' : Cfg n tm.Q} + (idx : Fin n) (hs : tm.step c = some c') + (h0 : (c.work idx).cells 0 = Ξ“.start) : + (c'.work idx).cells 0 = Ξ“.start := by + have hne := state_ne_qhalt_of_step hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs + subst hs + exact tape_cell0_preserved _ _ _ h0 + +/-- Output cells β‰₯ 1 β‰  Ξ“.start is preserved by one TM step. -/ +private theorem output_noStart_step {tm : TM n} {c c' : Cfg n tm.Q} + (hs : tm.step c = some c') (hno : βˆ€ i, i β‰₯ 1 β†’ c.output.cells i β‰  Ξ“.start) : + βˆ€ i, i β‰₯ 1 β†’ c'.output.cells i β‰  Ξ“.start := by + have hne := state_ne_qhalt_of_step hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact tape_noStart_preserved _ _ _ (Ξ“w.toΞ“_ne_start _) hno + +theorem output_cells_zero_eq_start_of_reachesIn {tm : TM n} {t : β„•} {cβ‚€ c : Cfg n tm.Q} + (h : tm.reachesIn t cβ‚€ c) (h0 : cβ‚€.output.cells 0 = Ξ“.start) : + c.output.cells 0 = Ξ“.start := by + induction h with + | zero => exact h0 + | step hs _ ih => exact ih (output_cell0_step hs h0) + +/-- Cell zero of any named work tape remains the left-end marker throughout a +deterministic run. -/ +theorem work_cells_zero_eq_start_of_reachesIn {tm : TM n} {t : β„•} + {cβ‚€ c : Cfg n tm.Q} (idx : Fin n) (h : tm.reachesIn t cβ‚€ c) + (h0 : (cβ‚€.work idx).cells 0 = Ξ“.start) : + (c.work idx).cells 0 = Ξ“.start := by + induction h with + | zero => exact h0 + | step hs _ ih => exact ih (work_cell0_step idx hs h0) + +theorem output_cells_ne_start_of_reachesIn {tm : TM n} {t : β„•} {cβ‚€ c : Cfg n tm.Q} + (h : tm.reachesIn t cβ‚€ c) + (hno : βˆ€ i, i β‰₯ 1 β†’ cβ‚€.output.cells i β‰  Ξ“.start) : + βˆ€ i, i β‰₯ 1 β†’ c.output.cells i β‰  Ξ“.start := by + induction h with + | zero => exact hno + | step hs _ ih => exact ih (output_noStart_step hs hno) + +theorem input_cells_eq_of_step {tm : TM n} {c c' : Cfg n tm.Q} + (hs : tm.step c = some c') : c'.input.cells = c.input.cells := by + have hne := state_ne_qhalt_of_step hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact Tape.move_cells _ _ + +theorem input_cells_eq_of_reachesIn {tm : TM n} {t : β„•} {cβ‚€ c : Cfg n tm.Q} + (h : tm.reachesIn t cβ‚€ c) : c.input.cells = cβ‚€.input.cells := by + induction h with + | zero => rfl + | step hs _ ih => rw [ih, input_cells_eq_of_step hs] + + + +/-- After one step, each tape head increases by at most 1. -/ +private theorem step_head_bound (tm : TM n) (c c' : Cfg n tm.Q) + (hs : tm.step c = some c') : + c'.input.head ≀ c.input.head + 1 ∧ + c'.output.head ≀ c.output.head + 1 ∧ + βˆ€ i, (c'.work i).head ≀ (c.work i).head + 1 := by + unfold TM.step at hs + split at hs + Β· simp at hs + Β· simp only [Option.some.injEq] at hs + subst hs + dsimp only [] + set Ξ΄r := tm.Ξ΄ c.state c.input.read (fun i => (c.work i).read) c.output.read + refine ⟨Tape.head_move_le _ Ξ΄r.2.2.2.1, ?_, fun i => ?_⟩ + Β· have hm := Tape.head_move_le (c.output.write Ξ΄r.2.2.1.toΞ“) Ξ΄r.2.2.2.2.2 + simp only [Tape.write_head] at hm + exact hm + Β· have hm := Tape.head_move_le ((c.work i).write (Ξ΄r.2.1 i).toΞ“) (Ξ΄r.2.2.2.2.1 i) + simp only [Tape.write_head] at hm + exact hm + +/-- A tape head moves at most one cell per step, relative to an arbitrary +starting configuration. -/ +theorem head_le_start_add_of_reachesIn (tm : TM n) + {t : β„•} {cβ‚€ c : Cfg n tm.Q} + (hreach : tm.reachesIn t cβ‚€ c) : + c.input.head ≀ cβ‚€.input.head + t ∧ + c.output.head ≀ cβ‚€.output.head + t ∧ + βˆ€ i, (c.work i).head ≀ (cβ‚€.work i).head + t := by + induction hreach with + | zero => simp + | step hstep _ ih => + obtain ⟨ih_in, ih_out, ih_work⟩ := ih + obtain ⟨hs_in, hs_out, hs_work⟩ := step_head_bound tm _ _ hstep + exact ⟨by omega, by omega, fun i => by + have := hs_work i + have := ih_work i + omega⟩ + +/-- A tape head moves at most 1 cell per step. After `t` steps starting + from `initCfg`, the head is at position ≀ `t`. -/ +theorem head_le_of_reachesIn (tm : TM n) + {t : β„•} {c : Cfg n tm.Q} + (hreach : tm.reachesIn t (tm.initCfg x) c) : + c.input.head ≀ t ∧ c.output.head ≀ t ∧ βˆ€ i, (c.work i).head ≀ t := by + have h := head_le_start_add_of_reachesIn tm hreach + simpa [Tape.init] using h +end TM + +/-- The invariant is preserved across one DTM step, on every tape. -/ +theorem Tape.StartInvariant.step {n : β„•} (tm : TM n) + {c c' : Cfg n tm.Q} (hstep : tm.step c = some c') + (hinp : c.input.StartInvariant) (hwork : βˆ€ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.StartInvariant ∧ (βˆ€ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + simp only [TM.step] at hstep + split at hstep + Β· simp at hstep + Β· simp only [Option.some.injEq] at hstep + subst hstep + refine ⟨?_, ?_, ?_⟩ + Β· constructor + Β· show (c.input.move _).cells 0 = _ + rw [Tape.move_cells]; exact hinp.1 + Β· intro j hj + show (c.input.move _).cells j β‰  _ + rw [Tape.move_cells]; exact hinp.2 j hj + Β· intro i + exact Tape.StartInvariant.writeAndMove (hwork i) _ _ + Β· exact Tape.StartInvariant.writeAndMove hout _ _ + +namespace NTM + +variable {n : β„•} + +/-- NTM traces never alter input tape cells; the input tape is read-only and + only its head moves. -/ +theorem input_cells_trace (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) : + (tm.trace T choices c).input.cells = c.input.cells := by + induction T generalizing c with + | zero => rfl + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + Β· simp only [NTM.trace, hhalt, ite_false] + rw [ih] + cases (tm.Ξ΄ (choices ⟨0, Nat.zero_lt_succ T⟩) c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.2.2.1 <;> rfl + +/-- During an NTM trace, the input head increases by at most one per step. -/ +theorem input_head_trace_le (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) : + (tm.trace T choices c).input.head ≀ c.input.head + T := by + induction T generalizing c with + | zero => + simp [NTM.trace] + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + Β· simp only [NTM.trace, hhalt, ite_false] + let b := choices ⟨0, Nat.zero_lt_succ T⟩ + let tr := tm.Ξ΄ b c.state c.input.read (fun i => (c.work i).read) c.output.read + let c' : Cfg n tm.Q := + { state := tr.1 + input := c.input.move tr.2.2.2.1 + work := fun i => (c.work i).writeAndMove (tr.2.1 i) (tr.2.2.2.2.1 i) + output := c.output.writeAndMove tr.2.2.1 tr.2.2.2.2.2 } + have hrec := ih (fun i => choices ⟨i.val + 1, by omega⟩) c' + have hstep : c'.input.head ≀ c.input.head + 1 := by + exact Tape.head_move_le c.input tr.2.2.2.1 + change (tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) c').input.head ≀ + c.input.head + (T + 1) + calc + (tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) c').input.head + ≀ c'.input.head + T := hrec + _ ≀ (c.input.head + 1) + T := by omega + _ ≀ c.input.head + (T + 1) := by omega + +/-- During an NTM trace, every work-tape head increases by at most one per step. -/ +theorem work_head_trace_le (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) (i : Fin n) : + ((tm.trace T choices c).work i).head ≀ (c.work i).head + T := by + induction T generalizing c with + | zero => simp [NTM.trace] + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + Β· simp only [NTM.trace, hhalt, ite_false] + let b := choices ⟨0, Nat.zero_lt_succ T⟩ + let tr := tm.Ξ΄ b c.state c.input.read (fun j => (c.work j).read) c.output.read + let c' : Cfg n tm.Q := + { state := tr.1 + input := c.input.move tr.2.2.2.1 + work := fun j => (c.work j).writeAndMove (tr.2.1 j) (tr.2.2.2.2.1 j) + output := c.output.writeAndMove tr.2.2.1 tr.2.2.2.2.2 } + have hrec := ih (fun j => choices ⟨j.val + 1, by omega⟩) c' + have hstep : (c'.work i).head ≀ (c.work i).head + 1 := by + exact Tape.head_writeAndMove_le _ _ _ + change ((tm.trace T (fun j => choices ⟨j.val + 1, by omega⟩) c').work i).head ≀ + (c.work i).head + (T + 1) + omega + +/-- During an NTM trace, the output-tape head increases by at most one per step. -/ +theorem output_head_trace_le (tm : NTM n) (T : β„•) + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) : + (tm.trace T choices c).output.head ≀ c.output.head + T := by + induction T generalizing c with + | zero => simp [NTM.trace] + | succ T ih => + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + Β· simp only [NTM.trace, hhalt, ite_false] + let b := choices ⟨0, Nat.zero_lt_succ T⟩ + let tr := tm.Ξ΄ b c.state c.input.read (fun i => (c.work i).read) c.output.read + let c' : Cfg n tm.Q := + { state := tr.1 + input := c.input.move tr.2.2.2.1 + work := fun i => (c.work i).writeAndMove (tr.2.1 i) (tr.2.2.2.2.1 i) + output := c.output.writeAndMove tr.2.2.1 tr.2.2.2.2.2 } + have hrec := ih (fun i => choices ⟨i.val + 1, by omega⟩) c' + have hstep : c'.output.head ≀ c.output.head + 1 := by + exact Tape.head_writeAndMove_le _ _ _ + change (tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) c').output.head ≀ + c.output.head + (T + 1) + omega + +/-- Split a two-step trace into two one-step traces. -/ +theorem trace_two (tm : NTM n) (choices : Fin 2 β†’ Bool) (c : Cfg n tm.Q) : + tm.trace 2 choices c = + tm.trace 1 (fun _ => choices ⟨1, by omega⟩) + (tm.trace 1 (fun _ => choices ⟨0, by omega⟩) c) := by + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + Β· simp [NTM.trace, hhalt] + +/-- Split the first step off a nonzero trace. If the machine is already + halted, both sides reduce to the starting configuration. -/ +theorem trace_succ (tm : NTM n) (T : β„•) + (choices : Fin (T + 1) β†’ Bool) (c : Cfg n tm.Q) : + tm.trace (T + 1) choices c = + tm.trace T (fun i => choices ⟨i.val + 1, by omega⟩) + (tm.trace 1 (fun _ => choices ⟨0, by omega⟩) c) := by + by_cases hhalt : c.state = tm.qhalt + Β· simp [NTM.trace, hhalt] + exact (tm.trace_halted T (fun i => choices ⟨i.val + 1, by omega⟩) hhalt).symm + Β· simp [NTM.trace, hhalt] + +/-- Split the first two steps off a trace. -/ +theorem trace_add_two (tm : NTM n) (T : β„•) + (choices : Fin (T + 2) β†’ Bool) (c : Cfg n tm.Q) : + tm.trace (T + 2) choices c = + tm.trace T (fun i => choices ⟨i.val + 2, by omega⟩) + (tm.trace 2 (fun i => choices ⟨i.val, by omega⟩) c) := by + change tm.trace ((T + 1) + 1) choices c = _ + rw [trace_succ tm (T + 1) choices c] + rw [trace_succ tm T + (fun i : Fin (T + 1) => choices ⟨i.val + 1, by omega⟩) + (tm.trace 1 (fun x => choices ⟨0, by omega⟩) c)] + rw [← trace_two tm (fun i : Fin 2 => choices ⟨i.val, by omega⟩) c] + +/-- Reindex a trace along an equality of time bounds. -/ +theorem trace_cast (tm : NTM n) {T T' : β„•} (h : T = T') + (choices : Fin T β†’ Bool) (c : Cfg n tm.Q) : + tm.trace T choices c = + tm.trace T' (fun i => choices (Fin.cast h.symm i)) c := by + cases h + rfl + +/-- Split the first `T` steps off a trace. + +This version uses `Fin.castLE`/`Fin.natAdd` for the prefix and suffix choice +sequences, which keeps later proofs away from ad-hoc dependent index casts. -/ +theorem trace_add (tm : NTM n) (T U : β„•) + (choices : Fin (T + U) β†’ Bool) (c : Cfg n tm.Q) : + tm.trace (T + U) choices c = + tm.trace U (fun i => choices (Fin.natAdd T i)) + (tm.trace T (fun i => choices (Fin.castLE (Nat.le_add_right T U) i)) c) := by + induction T generalizing U c with + | zero => + have h := trace_cast tm (Nat.zero_add U) choices c + rw [h] + congr 1 + funext i + apply congrArg choices + exact Fin.ext (by simp [Fin.natAdd]) + | succ T ih => + let choicesCast : Fin ((T + U) + 1) β†’ Bool := + fun i => choices (Fin.cast (by omega : (T + U) + 1 = (T + 1) + U) i) + have hcast := trace_cast tm (by omega : (T + 1) + U = (T + U) + 1) choices c + rw [hcast] + rw [trace_succ tm (T + U) choicesCast c] + rw [ih U (fun i : Fin (T + U) => choicesCast ⟨i.val + 1, by omega⟩) + (tm.trace 1 (fun _ => choicesCast ⟨0, by omega⟩) c)] + let prefixFinal : Fin (T + 1) β†’ Bool := + fun i => choices (Fin.castLE (Nat.le_add_right (T + 1) U) i) + have hprefix : + tm.trace (T + 1) prefixFinal c = + tm.trace T + (fun i : Fin T => + choicesCast ⟨(Fin.castLE (Nat.le_add_right T U) i).val + 1, by omega⟩) + (tm.trace 1 (fun _ => choicesCast ⟨0, by omega⟩) c) := by + simpa [choicesCast, prefixFinal, Fin.castLE, Fin.cast] using + trace_succ tm T prefixFinal c + rw [← hprefix] + congr 1 + funext i + apply congrArg choices + exact Fin.ext (by simp [Fin.val_natAdd]; omega) + +/-- Split a trace driven by an infinite choice stream at a natural-number +offset. This is the cast-free form used by fixed-schedule simulations. -/ +theorem trace_add_fun (tm : NTM n) (T U : β„•) + (choices : β„• β†’ Bool) (c : Cfg n tm.Q) : + tm.trace (T + U) (fun i => choices i.val) c = + tm.trace U (fun i => choices (T + i.val)) + (tm.trace T (fun i => choices i.val) c) := by + simpa [Fin.castLE, Fin.natAdd] using + tm.trace_add T U (fun i => choices i.val) c + +end NTM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal/OutputBounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal/OutputBounds.lean new file mode 100644 index 0000000000..46e2819599 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Internal/OutputBounds.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal + +/-! +# Output-length bounds β€” proof internals + +This module proves that a deterministic machine cannot produce more output +bits than the number of transitions it has taken. The key support lemma says +that an output cell beyond the initial head position plus the elapsed time is +unchanged. + +Public statements are in `Complexitylib.Models.TuringMachine.OutputBounds`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- One output-tape action leaves every cell other than the current head +unchanged. -/ +private theorem output_cells_ne_of_step {tm : TM n} {c c' : Cfg n tm.Q} + (hstep : tm.step c = some c') {j : β„•} (hj : j β‰  c.output.head) : + c'.output.cells j = c.output.cells j := by + simp only [TM.step] at hstep + split at hstep + Β· simp at hstep + Β· simp only [Option.some.injEq] at hstep + rw [← hstep] + simp only [Tape.move_cells, Tape.write] + split + Β· rfl + Β· change Function.update c.output.cells c.output.head _ j = c.output.cells j + rw [Function.update_of_ne hj] + +/-- Cells beyond the output head's maximum reach are never changed. -/ +theorem reachesIn_output_cells_far_internal {tm : TM n} : + βˆ€ {t : β„•} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' β†’ + βˆ€ j, c.output.head + t < j β†’ c'.output.cells j = c.output.cells j := by + intro t + induction t with + | zero => + intro c c' hreach j _hj + cases hreach + rfl + | succ t ih => + intro c c' hreach j hj + cases hreach with + | step hstep hrest => + next c'' => + have hhead : c''.output.head ≀ c.output.head + 1 := by + have hbound := tm.output_head_reachesIn_bound + (TM.reachesIn.step hstep TM.reachesIn.zero) + simpa using hbound + have hcell : c''.output.cells j = c.output.cells j := + output_cells_ne_of_step hstep (by omega) + rw [ih hrest j (by omega), hcell] + +/-- A run from an initial configuration needs at least one transition for +each bit present in its final output string. -/ +theorem output_length_le_of_reachesIn_internal {tm : TM n} {x y : List Bool} + {c' : Cfg n tm.Q} {t : β„•} + (hreach : tm.reachesIn t (tm.initCfg x) c') + (hout : c'.output.HasOutput y) : y.length ≀ t := by + by_contra hnle + have ht : t < y.length := Nat.lt_of_not_ge hnle + have hy : 0 < y.length := lt_of_le_of_lt (Nat.zero_le t) ht + let i := y.length - 1 + have hi : i < y.length := by + dsimp only [i] + omega + have hidx : i + 1 = y.length := by omega + have hbit := hout.1 i hi + have hfar := reachesIn_output_cells_far_internal hreach y.length (by simp; omega) + have hblank : c'.output.cells y.length = Ξ“.blank := by + rw [hfar] + simp [Tape.init, hy.ne'] + rw [hidx, hblank] at hbit + exact Ξ“.ofBool_ne_blank _ hbit.symm + +/-- A time-bounded function computation has output length bounded by its +advertised running time. -/ +theorem computesInTime_output_length_le_internal {tm : TM n} + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (h : tm.ComputesInTime f T) (x : List Bool) : + (f x).length ≀ T x.length := by + obtain ⟨c', t, ht, hreach, _hhalt, hout⟩ := h x + exact (output_length_le_of_reachesIn_internal hreach hout).trans ht + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Lift.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Lift.lean new file mode 100644 index 0000000000..0b378579a4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Lift.lean @@ -0,0 +1,600 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Tape-layout combinators: extra work tapes and output retargeting + +Two DTM combinators that change a machine's tape layout without changing +its behavior: + +- `TM.liftTM tm m` β€” pad `tm : TM n` with `m` never-used work tapes, giving + a `TM (n + m)` that decides/computes exactly as `tm` does, in the same + time bound. The extra tapes bounce off `β–·` on the first step (respecting + `Ξ΄_right_of_start`) and then park at cell 1 forever, writing `β–‘` over the + `β–‘` already there. +- `TM.retargetOutput tm` β€” redirect the output actions of `tm : TM n` to a + fresh work tape `n` (the `Fin.last n` tape), giving a `TM (n + 1)` whose + real output tape is idled. Used to "compute a value onto a work tape", + e.g. materializing a clock value for downstream composition. + +## Correspondence proofs + +Both combinators are proved correct by a step-commutation lemma through a +configuration embedding (`liftCfg` / `retargetCfg`): one step of the +derived machine on an embedded configuration equals one step of `tm`, +embedded. The embeddings park the dummy tapes at cell 1 with blank cells; +the initial configuration instead has dummy heads at cell 0 (on `β–·`), so +the step lemma is stated for any dummy tape with `cells = Tape.init []` and +`head ≀ 1` β€” covering both the initial bounce and the parked steady state +(mirroring `NTM.pad0`). + +The time bounds are preserved *exactly* (no `+ 1`): the dummy-tape bounce +happens during the simulated machine's own first step. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- Dummy-tape dynamics +-- ════════════════════════════════════════════════════════════════════════ + +/-- One idle action (`readBackWrite` of the read + `idleDir`) sends any + blank tape with head at cell 0 or 1 to the canonical *parked* tape + `(Tape.init []).move Dir3.right` (head 1, blank cells): at cell 0 the + write is a structural no-op and the head bounces right off `β–·`; at + cell 1 it writes `β–‘` over `β–‘` and stays. -/ +private theorem dummy_writeAndMove (w : Tape) + (hc : w.cells = (Tape.init []).cells) (hh : w.head ≀ 1) : + w.writeAndMove (readBackWrite w.read).toΞ“ (idleDir w.read) + = (Tape.init []).move Dir3.right := by + have hread : w.read = (Tape.init []).cells w.head := by rw [Tape.read, hc] + rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hh with h0 | h1 + Β· -- head at cell 0: `w` *is* `Tape.init []`, and the action is the bounce + have hw : w = Tape.init [] := by + calc w = ⟨w.head, w.cells⟩ := rfl + _ = Tape.init [] := by rw [h0, hc]; rfl + subst hw + rfl + Β· -- head at cell 1: write `β–‘` over `β–‘` and stay + have hr : w.read = Ξ“.blank := by rw [hread, h1]; rfl + rw [hr] + show w.write (readBackWrite Ξ“.blank).toΞ“ = (Tape.init []).move Dir3.right + rw [Tape.write, ite_eq_right (show Β¬ w.head = 0 by omega), h1, hc] + rw [show (readBackWrite Ξ“.blank).toΞ“ = (Tape.init []).cells 1 from rfl, + Function.update_eq_self] + rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- liftTM: extra never-used work tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- Pad `tm : TM n` with `m` never-used work tapes. Work tapes `0..n-1` + (indexed by `Fin.castAdd m i`) behave exactly as `tm`'s; the extra + tapes `n..n+m-1` write back what they read (`readBackWrite`) and idle + (`idleDir`): they bounce off `β–·` at the first step and then park at + cell 1 forever. Input and output behavior is unchanged. -/ +def liftTM (tm : TM n) (m : β„•) : TM (n + m) where + Q := tm.Q + qstart := tm.qstart + qhalt := tm.qhalt + Ξ΄ := fun q iHead wHeads oHead => + let r := tm.Ξ΄ q iHead (fun i => wHeads (Fin.castAdd m i)) oHead + ( r.1, + fun i => if h : i.val < n then r.2.1 ⟨i.val, h⟩ else readBackWrite (wHeads i), + r.2.2.1, + r.2.2.2.1, + fun i => if h : i.val < n then r.2.2.2.2.1 ⟨i.val, h⟩ else idleDir (wHeads i), + r.2.2.2.2.2 ) + Ξ΄_right_of_start := by + intro q iHead wHeads oHead + obtain ⟨hin, hwork, hout⟩ := + tm.Ξ΄_right_of_start q iHead (fun i => wHeads (Fin.castAdd m i)) oHead + refine ⟨hin, fun i hi => ?_, hout⟩ + dsimp only + split + Β· next hlt => exact hwork ⟨i.val, hlt⟩ hi + Β· next hlt => exact idleDir_right_of_start hi + +/-- Embed a configuration of `tm : TM n` into one of `tm.liftTM m`: + work tapes `i < n` are `c`'s, the extras are the canonical parked + blank tape (head 1, blank cells). State, input, and output are + shared. -/ +def liftCfg (tm : TM n) (m : β„•) (c : Cfg n tm.Q) : Cfg (n + m) tm.Q where + state := c.state + input := c.input + work := fun i => + if h : i.val < n then c.work ⟨i.val, h⟩ else (Tape.init []).move Dir3.right + output := c.output + +/-- `liftCfg` leaves the state unchanged. -/ +@[simp] theorem liftCfg_state (tm : TM n) (m : β„•) (c : Cfg n tm.Q) : + (tm.liftCfg m c).state = c.state := rfl + +/-- `liftCfg` leaves the input tape unchanged. -/ +@[simp] theorem liftCfg_input (tm : TM n) (m : β„•) (c : Cfg n tm.Q) : + (tm.liftCfg m c).input = c.input := rfl + +/-- `liftCfg` leaves the output tape unchanged. -/ +@[simp] theorem liftCfg_output (tm : TM n) (m : β„•) (c : Cfg n tm.Q) : + (tm.liftCfg m c).output = c.output := rfl + +/-- `liftCfg` maps the first `n` work tapes to `c`'s work tapes. -/ +theorem liftCfg_work_lt (tm : TM n) (m : β„•) (c : Cfg n tm.Q) + (i : Fin (n + m)) (h : i.val < n) : + (tm.liftCfg m c).work i = c.work ⟨i.val, h⟩ := dif_pos h + +/-- `liftCfg` maps the extra work tapes to the parked blank tape. -/ +theorem liftCfg_work_ge (tm : TM n) (m : β„•) (c : Cfg n tm.Q) + (i : Fin (n + m)) (h : n ≀ i.val) : + (tm.liftCfg m c).work i = (Tape.init []).move Dir3.right := + dite_eq_right (Nat.not_lt.mpr h) + +/-- **Unified step commutation** for `liftTM`. If the extra work tapes of + `C` are blank with head at cell 0 or 1 and the rest of `C` matches `c`, + then one step of `tm.liftTM m` from `C` is one step of `tm` from `c`, + embedded via `liftCfg` (extras parked). This covers both the initial + bounce (extra heads at 0, on `β–·`) and the parked steady state. -/ +private theorem liftTM_step_of_extras (tm : TM n) (m : β„•) {c : Cfg n tm.Q} + {C : Cfg (n + m) tm.Q} + (hs : C.state = c.state) (hi : C.input = c.input) (ho : C.output = c.output) + (hw : βˆ€ (i : Fin (n + m)) (h : i.val < n), C.work i = c.work ⟨i.val, h⟩) + (hd : βˆ€ i : Fin (n + m), n ≀ i.val β†’ + (C.work i).cells = (Tape.init []).cells ∧ (C.work i).head ≀ 1) : + (tm.liftTM m).step C = (tm.step c).map (tm.liftCfg m) := by + by_cases hh : c.state = tm.qhalt + Β· -- both machines are halted + have h1 : (tm.liftTM m).step C = none := by + exact step_eq_none_iff_halted.2 (hs.trans hh) + have h2 : tm.step c = none := by + simp only [step, hh, ↓reduceIte] + rw [h1, h2]; rfl + Β· cases hstep : tm.step c with + | none => exact absurd hstep (by simp [step, hh]) + | some c' => + -- extract the explicit stepped configuration + simp only [step, hh, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + have hinner : (fun i : Fin n => (C.work (Fin.castAdd m i)).read) + = fun i => (c.work i).read := + funext fun i => by rw [hw (Fin.castAdd m i) i.isLt]; rfl + have hnot : C.state β‰  (tm.liftTM m).qhalt := by + exact fun h => hh (hs.symm.trans h) + simp only [step, Option.map_some, ite_eq_right hnot] + dsimp only [liftTM, liftCfg] + rw [hs, hi, ho, hinner] + change (if c.state = tm.qhalt then (none : Option (Cfg (n + m) tm.Q)) else _) = _ + rw [ite_eq_right hh] + refine congrArg some (Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩) + funext i + by_cases hik : i.val < n + Β· rw [hw i hik, dif_pos hik, dif_pos hik, dif_pos hik] + Β· have hdi := hd i (Nat.le_of_not_lt hik) + rw [dite_eq_right hik, dite_eq_right hik, dite_eq_right hik] + exact dummy_writeAndMove (C.work i) hdi.1 hdi.2 + +/-- **Step commutation** on embedded configurations: once the extra tapes + are parked, `tm.liftTM m` steps exactly as `tm` does through + `liftCfg`. -/ +theorem liftTM_step_liftCfg (tm : TM n) (m : β„•) (c : Cfg n tm.Q) : + (tm.liftTM m).step (tm.liftCfg m c) = (tm.step c).map (tm.liftCfg m) := + liftTM_step_of_extras tm m rfl rfl rfl (fun _ h => dif_pos h) + (fun i h => by + rw [liftCfg_work_ge tm m c i h] + exact ⟨rfl, Nat.le_refl 1⟩) + +/-- The first step out of the lifted initial configuration: the extra + tapes bounce off `β–·` into the parked position while `tm` performs its + own first step. -/ +private theorem liftTM_step_initCfg (tm : TM n) (m : β„•) (x : List Bool) : + (tm.liftTM m).step ((tm.liftTM m).initCfg x) + = (tm.step (tm.initCfg x)).map (tm.liftCfg m) := + liftTM_step_of_extras tm m rfl rfl rfl (fun _ _ => rfl) + (fun _ _ => ⟨rfl, Nat.zero_le 1⟩) + +/-- Multi-step commutation through `liftCfg`. -/ +private theorem liftTM_reachesIn_liftCfg (tm : TM n) (m : β„•) {t : β„•} + {c c' : Cfg n tm.Q} (h : tm.reachesIn t c c') : + (tm.liftTM m).reachesIn t (tm.liftCfg m c) (tm.liftCfg m c') := by + induction h with + | zero => exact .zero + | step hstep _ ih => + exact .step (by rw [liftTM_step_liftCfg, hstep]; rfl) ih + +/-- Multi-step simulation from the initial configuration: the lifted run + tracks `tm`'s run in the same number of steps, agreeing on state and + output. -/ +private theorem liftTM_reachesIn_init (tm : TM n) (m : β„•) (x : List Bool) + {t : β„•} {c' : Cfg n tm.Q} (h : tm.reachesIn t (tm.initCfg x) c') : + βˆƒ C' : Cfg (n + m) tm.Q, + (tm.liftTM m).reachesIn t ((tm.liftTM m).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.output = c'.output := by + cases h with + | zero => exact ⟨(tm.liftTM m).initCfg x, .zero, rfl, rfl⟩ + | step hstep hrest => + exact ⟨tm.liftCfg m c', + .step (by rw [liftTM_step_initCfg, hstep]; rfl) + (liftTM_reachesIn_liftCfg tm m hrest), + rfl, rfl⟩ + +/-- A positive-length run of a lifted machine from genuine initialization has +the exact `liftCfg` endpoint of the underlying run. The positivity hypothesis +excludes the sole mismatch at time zero, when the extra tapes have not yet +bounced from cell `0` to their canonical parked position at cell `1`. -/ +theorem liftTM_reachesIn_initCfg_of_pos (tm : TM n) (m : β„•) (x : List Bool) + {t : β„•} {c' : Cfg n tm.Q} (ht : 0 < t) + (h : tm.reachesIn t (tm.initCfg x) c') : + (tm.liftTM m).reachesIn t ((tm.liftTM m).initCfg x) (tm.liftCfg m c') := by + cases h with + | zero => omega + | step hstep hrest => + exact .step (by rw [liftTM_step_initCfg, hstep]; rfl) + (liftTM_reachesIn_liftCfg tm m hrest) + +/-- Unbounded-reachability commutation through `liftCfg`. -/ +private theorem liftTM_reaches_liftCfg (tm : TM n) (m : β„•) {c c' : Cfg n tm.Q} + (h : tm.reaches c c') : + (tm.liftTM m).reaches (tm.liftCfg m c) (tm.liftCfg m c') := by + induction h with + | refl => exact Relation.ReflTransGen.refl + | @tail b cβ‚‚ _ hbc ih => + refine ih.tail ?_ + show (tm.liftTM m).step (tm.liftCfg m b) = some (tm.liftCfg m cβ‚‚) + have hb : tm.step b = some cβ‚‚ := hbc + rw [liftTM_step_liftCfg, hb]; rfl + +/-- Unbounded simulation from the initial configuration, agreeing on state + and output. -/ +private theorem liftTM_reaches_init (tm : TM n) (m : β„•) (x : List Bool) + {c' : Cfg n tm.Q} (h : tm.reaches (tm.initCfg x) c') : + βˆƒ C' : Cfg (n + m) tm.Q, + (tm.liftTM m).reaches ((tm.liftTM m).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.output = c'.output := by + rcases Relation.ReflTransGen.cases_head h with heq | ⟨c₁, hstep, hrest⟩ + Β· subst heq + exact ⟨(tm.liftTM m).initCfg x, Relation.ReflTransGen.refl, rfl, rfl⟩ + Β· refine ⟨tm.liftCfg m c', + Relation.ReflTransGen.head ?_ (liftTM_reaches_liftCfg tm m hrest), rfl, rfl⟩ + show (tm.liftTM m).step ((tm.liftTM m).initCfg x) = some (tm.liftCfg m c₁) + have h1 : tm.step (tm.initCfg x) = some c₁ := hstep + rw [liftTM_step_initCfg, h1]; rfl + +/-- Every configuration the lifted machine reaches from its initial + configuration is either that initial configuration or the `liftCfg` + image of a configuration `tm` reaches. -/ +private theorem liftTM_reaches_init_inv (tm : TM n) (m : β„•) (x : List Bool) + {C' : Cfg (n + m) tm.Q} + (h : (tm.liftTM m).reaches ((tm.liftTM m).initCfg x) C') : + C' = (tm.liftTM m).initCfg x ∨ + βˆƒ c' : Cfg n tm.Q, tm.reaches (tm.initCfg x) c' ∧ C' = tm.liftCfg m c' := by + induction h with + | refl => exact Or.inl rfl + | @tail b Cβ‚‚ _ hbc ih => + have hstep' : (tm.liftTM m).step b = some Cβ‚‚ := hbc + rcases ih with rfl | ⟨cβ‚€, hcβ‚€, rfl⟩ + Β· rw [liftTM_step_initCfg] at hstep' + cases hmc : tm.step (tm.initCfg x) with + | none => rw [hmc] at hstep'; simp at hstep' + | some c₁ => + rw [hmc] at hstep' + exact Or.inr ⟨c₁, Relation.ReflTransGen.single hmc, + (Option.some.inj hstep').symm⟩ + Β· rw [liftTM_step_liftCfg] at hstep' + cases hmc : tm.step cβ‚€ with + | none => rw [hmc] at hstep'; simp at hstep' + | some c₁ => + rw [hmc] at hstep' + exact Or.inr ⟨c₁, hcβ‚€.tail hmc, (Option.some.inj hstep').symm⟩ + +/-- **Lifting preserves deciding, with the same time bound.** The extra + work tapes never interfere: the lifted machine's run tracks `tm`'s run + step for step. -/ +theorem liftTM_decidesInTime (tm : TM n) (m : β„•) {L : Language} {T : β„• β†’ β„•} + (h : tm.DecidesInTime L T) : (tm.liftTM m).DecidesInTime L T := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hyes, hno⟩ := h x + obtain ⟨C', hR, hstate, hout⟩ := liftTM_reachesIn_init tm m x hreach + refine ⟨C', t, ht, hR, ?_, fun hx => ?_, fun hx => ?_⟩ + Β· show C'.state = (tm.liftTM m).qhalt + rw [hstate]; exact hhalt + Β· rw [hout]; exact hyes hx + Β· rw [hout]; exact hno hx + +/-- **Lifting preserves function computation, with the same time bound.** -/ +theorem liftTM_computesInTime (tm : TM n) (m : β„•) {f : List Bool β†’ List Bool} + {T : β„• β†’ β„•} (h : tm.ComputesInTime f T) : + (tm.liftTM m).ComputesInTime f T := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := h x + obtain ⟨C', hR, hstate, houtC⟩ := liftTM_reachesIn_init tm m x hreach + refine ⟨C', t, ht, hR, ?_, ?_⟩ + Β· show C'.state = (tm.liftTM m).qhalt + rw [hstate]; exact hhalt + Β· rw [houtC]; exact hout + +/-- **Lifting preserves space bounds up to the parked cell.** The extra + work tapes' heads never move past cell 1, so `tm.liftTM m` decides `L` + in space `max (S Β·) 1`. -/ +theorem liftTM_decidesInSpace (tm : TM n) (m : β„•) {L : Language} {S : β„• β†’ β„•} + (h : tm.DecidesInSpace L S) : + (tm.liftTM m).DecidesInSpace L (fun k => max (S k) 1) := by + obtain ⟨hspace, hdec⟩ := h + constructor + Β· intro x C' hreach + rcases liftTM_reaches_init_inv tm m x hreach with rfl | ⟨c', hc', rfl⟩ + Β· simp [Cfg.WithinDecisionSpace, Cfg.WithinAuxSpace] + Β· obtain ⟨⟨hwork, hin⟩, hout⟩ := hspace x c' hc' + refine ⟨⟨?_, ?_⟩, ?_⟩ + Β· intro j + by_cases hj : j.val < n + Β· rw [liftCfg_work_lt tm m c' j hj] + exact (hwork ⟨j.val, hj⟩).trans (le_max_left _ _) + Β· rw [liftCfg_work_ge tm m c' j (Nat.le_of_not_lt hj)] + exact le_max_right _ _ + Β· simp only [liftCfg_input] + have := le_max_left (S x.length) 1 + omega + Β· simp only [liftCfg_output] + have := le_max_left (S x.length) 1 + omega + Β· intro x + obtain ⟨c', hreach, hhalt, hyes, hno⟩ := hdec x + obtain ⟨C', hR, hstate, hout⟩ := liftTM_reaches_init tm m x hreach + refine ⟨C', hR, ?_, fun hx => ?_, fun hx => ?_⟩ + Β· show C'.state = (tm.liftTM m).qhalt + rw [hstate]; exact hhalt + Β· rw [hout]; exact hyes hx + Β· rw [hout]; exact hno hx + +-- ════════════════════════════════════════════════════════════════════════ +-- retargetOutput: write the output onto a fresh work tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- Redirect `tm`'s output actions to a fresh work tape. `retargetOutput + tm : TM (n + 1)` behaves like `tm`, except that the output write and + direction are applied to work tape `n` (the `Fin.last n` tape), whose + read is fed to `tm.Ξ΄` as the virtual output head; the real output tape + is idled (`readBackWrite`/`idleDir`). Work tapes `0..n-1` (indexed by + `Fin.castSucc i`) and the input tape behave as before. -/ +def retargetOutput (tm : TM n) : TM (n + 1) where + Q := tm.Q + qstart := tm.qstart + qhalt := tm.qhalt + Ξ΄ := fun q iHead wHeads oHead => + let r := tm.Ξ΄ q iHead (fun i => wHeads (Fin.castSucc i)) (wHeads (Fin.last n)) + ( r.1, + fun i => if h : i.val < n then r.2.1 ⟨i.val, h⟩ else r.2.2.1, + readBackWrite oHead, + r.2.2.2.1, + fun i => if h : i.val < n then r.2.2.2.2.1 ⟨i.val, h⟩ else r.2.2.2.2.2, + idleDir oHead ) + Ξ΄_right_of_start := by + intro q iHead wHeads oHead + obtain ⟨hin, hwork, hout⟩ := + tm.Ξ΄_right_of_start q iHead (fun i => wHeads (Fin.castSucc i)) + (wHeads (Fin.last n)) + refine ⟨hin, fun i hi => ?_, fun hoh => idleDir_right_of_start hoh⟩ + dsimp only + split + Β· next hlt => exact hwork ⟨i.val, hlt⟩ hi + Β· next hlt => + have hi_last : i = Fin.last n := by + apply Fin.ext + have := i.isLt + simp only [Fin.val_last] + omega + exact hout (hi_last β–Έ hi) + +/-- Embed a configuration of `tm : TM n` into one of `tm.retargetOutput`: + work tapes `i < n` are `c`'s, work tape `n` is `c`'s output tape, and + the real output tape is the canonical parked blank tape. -/ +def retargetCfg (tm : TM n) (c : Cfg n tm.Q) : Cfg (n + 1) tm.Q where + state := c.state + input := c.input + work := fun i => if h : i.val < n then c.work ⟨i.val, h⟩ else c.output + output := (Tape.init []).move Dir3.right + +/-- `retargetCfg` leaves the state unchanged. -/ +@[simp] theorem retargetCfg_state (tm : TM n) (c : Cfg n tm.Q) : + (tm.retargetCfg c).state = c.state := rfl + +/-- `retargetCfg` leaves the input tape unchanged. -/ +@[simp] theorem retargetCfg_input (tm : TM n) (c : Cfg n tm.Q) : + (tm.retargetCfg c).input = c.input := rfl + +/-- `retargetCfg` maps the first `n` work tapes to `c`'s work tapes. -/ +theorem retargetCfg_work_lt (tm : TM n) (c : Cfg n tm.Q) + (i : Fin (n + 1)) (h : i.val < n) : + (tm.retargetCfg c).work i = c.work ⟨i.val, h⟩ := dif_pos h + +/-- `retargetCfg` maps the last work tape to `c`'s output tape. -/ +theorem retargetCfg_work_last (tm : TM n) (c : Cfg n tm.Q) : + (tm.retargetCfg c).work (Fin.last n) = c.output := dite_eq_right (Nat.lt_irrefl n) + +/-- **Unified step commutation** for `retargetOutput`: if `C`'s real + output tape is blank with head at cell 0 or 1, work tape `n` matches + `c`'s output tape, and the rest of `C` matches `c`, then one step of + `tm.retargetOutput` from `C` is one step of `tm` from `c`, embedded + via `retargetCfg`. -/ +private theorem retargetOutput_step_of_extras (tm : TM n) {c : Cfg n tm.Q} + {C : Cfg (n + 1) tm.Q} + (hs : C.state = c.state) (hi : C.input = c.input) + (hw : βˆ€ (i : Fin (n + 1)) (h : i.val < n), C.work i = c.work ⟨i.val, h⟩) + (hlast : C.work (Fin.last n) = c.output) + (ho : C.output.cells = (Tape.init []).cells ∧ C.output.head ≀ 1) : + (tm.retargetOutput).step C = (tm.step c).map tm.retargetCfg := by + by_cases hh : c.state = tm.qhalt + Β· -- both machines are halted + have h1 : (tm.retargetOutput).step C = none := by + exact step_eq_none_iff_halted.2 (hs.trans hh) + have h2 : tm.step c = none := by + simp only [step, hh, ↓reduceIte] + rw [h1, h2]; rfl + Β· cases hstep : tm.step c with + | none => exact absurd hstep (by simp [step, hh]) + | some c' => + -- extract the explicit stepped configuration + simp only [step, hh, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + have hinner : (fun i : Fin n => (C.work (Fin.castSucc i)).read) + = fun i => (c.work i).read := + funext fun i => by rw [hw (Fin.castSucc i) i.isLt]; rfl + have hvirt : (C.work (Fin.last n)).read = c.output.read := by rw [hlast] + have hnot : C.state β‰  tm.retargetOutput.qhalt := by + exact fun h => hh (hs.symm.trans h) + simp only [step, Option.map_some, ite_eq_right hnot] + dsimp only [retargetOutput, retargetCfg] + rw [hs, hi, hinner, hvirt] + change (if c.state = tm.qhalt then (none : Option (Cfg (n + 1) tm.Q)) else _) = _ + rw [ite_eq_right hh] + refine congrArg some (Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + by_cases hik : i.val < n + Β· rw [hw i hik, dif_pos hik, dif_pos hik, dif_pos hik] + Β· have hi_last : i = Fin.last n := by + apply Fin.ext + have := i.isLt + simp only [Fin.val_last] + omega + rw [dite_eq_right hik, dite_eq_right hik, dite_eq_right hik, hi_last, hlast] + Β· exact dummy_writeAndMove C.output ho.1 ho.2 + +/-- **Step commutation** on embedded configurations: once the real output + tape is parked, `tm.retargetOutput` steps exactly as `tm` does through + `retargetCfg`. -/ +theorem retargetOutput_step_retargetCfg (tm : TM n) (c : Cfg n tm.Q) : + (tm.retargetOutput).step (tm.retargetCfg c) = (tm.step c).map tm.retargetCfg := + retargetOutput_step_of_extras tm rfl rfl (fun _ h => dif_pos h) + (retargetCfg_work_last tm c) + ⟨rfl, Nat.le_refl 1⟩ + +/-- The first step out of the retargeted initial configuration: the real + output tape bounces off `β–·` into the parked position while `tm` + performs its own first step (work tape `n` mirrors `tm`'s output tape, + which also starts at `Tape.init []`). -/ +private theorem retargetOutput_step_initCfg (tm : TM n) (x : List Bool) : + (tm.retargetOutput).step ((tm.retargetOutput).initCfg x) + = (tm.step (tm.initCfg x)).map tm.retargetCfg := + retargetOutput_step_of_extras tm rfl rfl (fun _ _ => rfl) rfl + ⟨rfl, Nat.zero_le 1⟩ + +/-- Multi-step commutation through `retargetCfg`. -/ +private theorem retargetOutput_reachesIn_retargetCfg (tm : TM n) {t : β„•} + {c c' : Cfg n tm.Q} (h : tm.reachesIn t c c') : + (tm.retargetOutput).reachesIn t (tm.retargetCfg c) (tm.retargetCfg c') := by + induction h with + | zero => exact .zero + | step hstep _ ih => + exact .step (by rw [retargetOutput_step_retargetCfg, hstep]; rfl) ih + +/-- Redirecting output to a fresh work tape preserves every exact run through +the canonical configuration embedding. -/ +theorem retargetOutput_reachesIn_retargetCfg_frame (tm : TM n) {t : β„•} + {c c' : Cfg n tm.Q} (h : tm.reachesIn t c c') : + (tm.retargetOutput).reachesIn t (tm.retargetCfg c) (tm.retargetCfg c') := + retargetOutput_reachesIn_retargetCfg tm h + +/-- Multi-step simulation from the initial configuration: the retargeted + run tracks `tm`'s run in the same number of steps, with work tape `n` + holding `tm`'s output tape. -/ +private theorem retargetOutput_reachesIn_init (tm : TM n) (x : List Bool) + {t : β„•} {c' : Cfg n tm.Q} (h : tm.reachesIn t (tm.initCfg x) c') : + βˆƒ C' : Cfg (n + 1) tm.Q, + (tm.retargetOutput).reachesIn t ((tm.retargetOutput).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.work (Fin.last n) = c'.output := by + cases h with + | zero => exact ⟨(tm.retargetOutput).initCfg x, .zero, rfl, rfl⟩ + | step hstep hrest => + exact ⟨tm.retargetCfg c', + .step (by rw [retargetOutput_step_initCfg, hstep]; rfl) + (retargetOutput_reachesIn_retargetCfg tm hrest), + rfl, retargetCfg_work_last tm c'⟩ + +/-- A run of an output-retargeted machine leaves the virtual output on the +last work tape and keeps the real output blank with its head at cell zero or +one. A subsequent combinator transition therefore parks it at cell one. -/ +theorem retargetOutput_reachesIn_init_boundary (tm : TM n) (x : List Bool) + {t : β„•} {c' : Cfg n tm.Q} (h : tm.reachesIn t (tm.initCfg x) c') : + βˆƒ C' : Cfg (n + 1) tm.Q, + (tm.retargetOutput).reachesIn t ((tm.retargetOutput).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.work (Fin.last n) = c'.output ∧ + C'.output.cells = (Tape.init []).cells ∧ C'.output.head ≀ 1 := by + cases h with + | zero => + exact ⟨(tm.retargetOutput).initCfg x, .zero, rfl, rfl, rfl, + Nat.zero_le 1⟩ + | step hstep hrest => + refine ⟨tm.retargetCfg c', + .step (by rw [retargetOutput_step_initCfg, hstep]; rfl) + (retargetOutput_reachesIn_retargetCfg tm hrest), + rfl, retargetCfg_work_last tm c', rfl, le_rfl⟩ + +/-- **Output retargeting preserves computation, with the same time + bound.** If `tm` computes `f` within time `T`, then `retargetOutput + tm` halts within `T(|x|)` steps with `f x` written on work tape `n` + (the `Fin.last n` tape). This is the form needed to compose "compute a + clock value onto a work tape". -/ +theorem retargetOutput_computesInTime (tm : TM n) {f : List Bool β†’ List Bool} + {T : β„• β†’ β„•} (h : tm.ComputesInTime f T) (x : List Bool) : + βˆƒ (c' : Cfg (n + 1) tm.Q) (t : β„•), t ≀ T x.length ∧ + (tm.retargetOutput).reachesIn t ((tm.retargetOutput).initCfg x) c' ∧ + (tm.retargetOutput).halted c' ∧ + (c'.work (Fin.last n)).HasOutput (f x) := by + obtain ⟨cβ‚€, t, ht, hreach, hhalt, hout⟩ := h x + obtain ⟨C', hR, hstate, hwork⟩ := retargetOutput_reachesIn_init tm x hreach + refine ⟨C', t, ht, hR, ?_, ?_⟩ + Β· show C'.state = (tm.retargetOutput).qhalt + rw [hstate]; exact hhalt + Β· rw [hwork]; exact hout + +/-- Output retargeting with the blank real-output frame exposed. This is the +form used by sequential function composition. -/ +theorem retargetOutput_computesInTime_boundary (tm : TM n) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (h : tm.ComputesInTime f T) (x : List Bool) : + βˆƒ (c' : Cfg (n + 1) tm.Q) (t : β„•), t ≀ T x.length ∧ + (tm.retargetOutput).reachesIn t ((tm.retargetOutput).initCfg x) c' ∧ + (tm.retargetOutput).halted c' ∧ + (c'.work (Fin.last n)).HasOutput (f x) ∧ + c'.output.cells = (Tape.init []).cells ∧ c'.output.head ≀ 1 := by + obtain ⟨cβ‚€, t, ht, hreach, hhalt, hout⟩ := h x + obtain ⟨C', hR, hstate, hwork, houtCells, houtHead⟩ := + retargetOutput_reachesIn_init_boundary tm x hreach + refine ⟨C', t, ht, hR, ?_, ?_, houtCells, houtHead⟩ + Β· show C'.state = (tm.retargetOutput).qhalt + rw [hstate] + exact hhalt + Β· rw [hwork] + exact hout + +/-- Padding by unused work tapes preserves one-way output behavior. -/ +theorem IsTransducer.liftTM {tm : TM n} (h : tm.IsTransducer) (m : β„•) : + (tm.liftTM m).IsTransducer := by + intro q iHead wHeads oHead + simpa only [liftTM] using! h q iHead + (fun i => wHeads (Fin.castAdd m i)) oHead + +/-- Redirecting output to a work tape leaves the real output direction idle, +so the resulting machine is always a one-way-output transducer. -/ +theorem retargetOutput_isTransducer (tm : TM n) : + tm.retargetOutput.IsTransducer := by + intro q iHead wHeads oHead + simp only [retargetOutput] + unfold idleDir + split <;> decide + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/OutputBounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/OutputBounds.lean new file mode 100644 index 0000000000..c641c4e99a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/OutputBounds.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Internal.OutputBounds + +/-! +# Output-length bounds + +A deterministic machine can change only the output cell currently under its +head. Consequently, a run of `t` transitions from a blank output tape can +produce at most `t` output bits. + +## Main results + +- `TM.reachesIn_output_cells_far` β€” sufficiently distant output cells are unchanged +- `TM.output_length_le_of_reachesIn` β€” a run bounds its output length +- `TM.ComputesInTime.output_length_le` β€” a time bound also bounds output length +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Cells beyond the output head's maximum reach are never changed. -/ +theorem reachesIn_output_cells_far {tm : TM n} {t : β„•} + {c c' : Cfg n tm.Q} (hreach : tm.reachesIn t c c') + (j : β„•) (hj : c.output.head + t < j) : + c'.output.cells j = c.output.cells j := by + exact reachesIn_output_cells_far_internal hreach j hj + +/-- A run from an initial configuration needs at least one transition for +each bit present in its final output string. -/ +theorem output_length_le_of_reachesIn {tm : TM n} {x y : List Bool} + {c' : Cfg n tm.Q} {t : β„•} + (hreach : tm.reachesIn t (tm.initCfg x) c') + (hout : c'.output.HasOutput y) : y.length ≀ t := by + exact output_length_le_of_reachesIn_internal hreach hout + +/-- The output of a time-bounded function computation is no longer than the +advertised running-time bound. -/ +theorem ComputesInTime.output_length_le {tm : TM n} + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (h : tm.ComputesInTime f T) (x : List Bool) : + (f x).length ≀ T x.length := by + exact computesInTime_output_length_le_internal h x + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement.lean new file mode 100644 index 0000000000..eba13476db --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Internal + +/-! +# Work-tape placement + +This public surface exposes exact simulation theorems for `TM.placeWorkTM`. +The source machine occupies a contiguous middle block of physical work tapes; +prefix and suffix tapes form an arbitrary preserved frame whenever their heads +are parked away from the left-end marker. + +## Main results + +- `TM.placeWorkTM_step_placeWorkCfg` β€” exact step with an evolving frame +- `TM.placeWorkTM_reachesIn_placeWorkCfg_stable` β€” exact stable-frame simulation +- `TM.placeWorkTM_reachesIn_placeWorkParkedCfg` β€” canonical parked simulation +- `TM.placeWorkTM_computesInTime` β€” same-time preservation of computation +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- A placed step simulates one source step while applying the prescribed idle +action to the arbitrary physical extra-tape frame. -/ +theorem placeWorkTM_step_placeWorkCfg (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) = + (tm.step c).map + (placeWorkCfg tm pre post (placeWorkFrameStep extras)) := + placeWorkTM_step_placeWorkCfg_internal tm pre post extras c + +/-- If every extra tape reads a non-left-end symbol, its idle action is a +no-op and a placed step commutes through the unchanged frame. -/ +theorem placeWorkTM_step_placeWorkCfg_stable (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) + (hextra : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ (extras i).read β‰  Ξ“.start) : + (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) = + (tm.step c).map (placeWorkCfg tm pre post extras) := + placeWorkTM_step_placeWorkCfg_stable_internal tm pre post extras c hextra + +/-- Start-invariant extra tapes whose heads are at positive positions form a +stable frame for one placed step. -/ +theorem placeWorkTM_step_placeWorkCfg_of_startInvariant (tm : TM n) + (pre post : β„•) (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ 1 ≀ (extras i).head) : + (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) = + (tm.step c).map (placeWorkCfg tm pre post extras) := by + apply placeWorkTM_step_placeWorkCfg_stable tm pre post extras c + intro i hi + show (extras i).cells (extras i).head β‰  Ξ“.start + exact (hinv i hi).2 (extras i).head (hhead i hi) + +/-- A stable arbitrary frame is preserved exactly throughout a bounded source +run, with no time overhead. -/ +theorem placeWorkTM_reachesIn_placeWorkCfg_stable (tm : TM n) + (pre post : β„•) (extras : Fin (pre + n + post) β†’ Tape) + {t : β„•} {c c' : Cfg n tm.Q} (hreach : tm.reachesIn t c c') + (hextra : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ (extras i).read β‰  Ξ“.start) : + (placeWorkTM pre post tm).reachesIn t + (placeWorkCfg tm pre post extras c) + (placeWorkCfg tm pre post extras c') := + placeWorkTM_reachesIn_placeWorkCfg_stable_internal tm pre post extras hreach hextra + +/-- Start-invariant positive-head extras remain an exact frame throughout a +bounded source run. -/ +theorem placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant (tm : TM n) + (pre post : β„•) (extras : Fin (pre + n + post) β†’ Tape) + {t : β„•} {c c' : Cfg n tm.Q} (hreach : tm.reachesIn t c c') + (hinv : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ Tape.StartInvariant (extras i)) + (hhead : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ 1 ≀ (extras i).head) : + (placeWorkTM pre post tm).reachesIn t + (placeWorkCfg tm pre post extras c) + (placeWorkCfg tm pre post extras c') := by + apply placeWorkTM_reachesIn_placeWorkCfg_stable tm pre post extras hreach + intro i hi + show (extras i).cells (extras i).head β‰  Ξ“.start + exact (hinv i hi).2 (extras i).head (hhead i hi) + +/-- The canonical parked embedding commutes with one source step. -/ +theorem placeWorkTM_step_placeWorkParkedCfg (tm : TM n) (pre post : β„•) + (c : Cfg n tm.Q) : + (placeWorkTM pre post tm).step (placeWorkParkedCfg tm pre post c) = + (tm.step c).map (placeWorkParkedCfg tm pre post) := + placeWorkTM_step_placeWorkParkedCfg_internal tm pre post c + +/-- The canonical parked embedding simulates a bounded source run exactly. -/ +theorem placeWorkTM_reachesIn_placeWorkParkedCfg (tm : TM n) + (pre post : β„•) {t : β„•} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn t c c') : + (placeWorkTM pre post tm).reachesIn t + (placeWorkParkedCfg tm pre post c) + (placeWorkParkedCfg tm pre post c') := + placeWorkTM_reachesIn_placeWorkParkedCfg_internal tm pre post hreach + +/-- A placed embedded configuration is halted exactly when its source +configuration is halted. -/ +@[simp] theorem placeWorkCfg_halted_iff (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkTM pre post tm).halted (placeWorkCfg tm pre post extras c) ↔ + tm.halted c := by + rfl + +/-- A bounded run from the source's ordinary initial configuration lifts with +the same duration. A positive run ends in the canonical parked embedding; at +time zero the placed machine remains at its own ordinary initial configuration. -/ +theorem placeWorkTM_reachesIn_init (tm : TM n) (pre post : β„•) + (x : List Bool) {t : β„•} {c' : Cfg n tm.Q} + (hreach : tm.reachesIn t (tm.initCfg x) c') : + βˆƒ C' : Cfg (pre + n + post) (placeWorkTM pre post tm).Q, + (placeWorkTM pre post tm).reachesIn t ((placeWorkTM pre post tm).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.input = c'.input ∧ C'.output = c'.output ∧ + (t = 0 ∨ C' = placeWorkParkedCfg tm pre post c') := + placeWorkTM_reachesIn_init_internal tm pre post x hreach + +/-- Work-tape placement preserves deterministic function computation with +exactly the same time bound. The surrounding blank tapes bounce off `β–·` +during the source machine's own first step and then remain parked. -/ +theorem placeWorkTM_computesInTime (tm : TM n) (pre post : β„•) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : tm.ComputesInTime f T) : + (placeWorkTM pre post tm).ComputesInTime f T := + placeWorkTM_computesInTime_internal tm pre post hcomp + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Defs.lean new file mode 100644 index 0000000000..eee7d9ec82 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Defs.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Work-tape placement + +This file defines a layout combinator that places the work tapes of a machine +inside a larger, contiguous middle block. The surrounding physical tapes are +idled, so later phases can reserve disjoint tape regions without changing the +source machine. + +## Main definitions + +- `TM.placeWorkIdx` β€” physical index of a source work tape +- `TM.placeWorkCoord` β€” source coordinate of a physical middle-block tape +- `TM.placeWorkTM` β€” place a machine between `pre` prefix and `post` suffix tapes +- `TM.placeWorkCfg` β€” embed a configuration with an arbitrary extra-tape frame +- `TM.placeWorkFrameStep` β€” one idle action on every physical frame tape +- `TM.placeWorkParkedCfg` β€” the canonical embedding with parked blank extras +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n pre post : β„•} + +/-- Physical work-tape index occupied by source work tape `i` after placement. -/ +def placeWorkIdx (pre post : β„•) (i : Fin n) : Fin (pre + n + post) := + ⟨pre + i.val, by omega⟩ + +/-- A physical work tape lies in the block occupied by the source machine. -/ +def placeWorkInMiddle (pre n : β„•) {post : β„•} (i : Fin (pre + n + post)) : Prop := + pre ≀ i.val ∧ i.val < pre + n + +instance instDecidablePlaceWorkInMiddle (pre n : β„•) {post : β„•} + (i : Fin (pre + n + post)) : Decidable (placeWorkInMiddle pre n i) := by + unfold placeWorkInMiddle + infer_instance + +/-- Source coordinate corresponding to a physical tape in the middle block. -/ +def placeWorkCoord (pre n : β„•) {post : β„•} (i : Fin (pre + n + post)) + (h : placeWorkInMiddle pre n i) : Fin n := + ⟨i.val - pre, by + unfold placeWorkInMiddle at h + omega⟩ + +@[simp] theorem placeWorkIdx_val (pre post : β„•) (i : Fin n) : + (placeWorkIdx pre post i).val = pre + i.val := rfl + +@[simp] theorem placeWorkInMiddle_placeWorkIdx (pre post : β„•) (i : Fin n) : + placeWorkInMiddle pre n (placeWorkIdx pre post i) := by + unfold placeWorkInMiddle + simp only [placeWorkIdx_val] + exact ⟨by omega, by omega⟩ + +@[simp] theorem placeWorkCoord_placeWorkIdx (pre post : β„•) (i : Fin n) : + placeWorkCoord pre n (placeWorkIdx pre post i) + (placeWorkInMiddle_placeWorkIdx pre post i) = i := by + apply Fin.ext + simp [placeWorkCoord] + +theorem placeWorkIdx_placeWorkCoord (i : Fin (pre + n + post)) + (h : placeWorkInMiddle pre n i) : + placeWorkIdx pre post (placeWorkCoord pre n i h) = i := by + apply Fin.ext + unfold placeWorkInMiddle at h + simp [placeWorkIdx, placeWorkCoord] + omega + +theorem placeWorkIdx_injective (pre post : β„•) : + Function.Injective (placeWorkIdx (n := n) pre post) := by + intro i j h + apply Fin.ext + have := congrArg Fin.val h + simp only [placeWorkIdx_val] at this + omega + +/-- Place `tm` after `pre` reserved work tapes and before `post` reserved work +tapes. Physical tapes in the middle block simulate `tm`; every other work tape +writes back the symbol it reads and idles. Input and output actions are unchanged. -/ +def placeWorkTM (pre post : β„•) (tm : TM n) : TM (pre + n + post) where + Q := tm.Q + qstart := tm.qstart + qhalt := tm.qhalt + Ξ΄ := fun q iHead wHeads oHead => + let r := tm.Ξ΄ q iHead (fun i => wHeads (placeWorkIdx pre post i)) oHead + (r.1, + fun i => + if h : placeWorkInMiddle pre n i then r.2.1 (placeWorkCoord pre n i h) + else readBackWrite (wHeads i), + r.2.2.1, + r.2.2.2.1, + fun i => + if h : placeWorkInMiddle pre n i then r.2.2.2.2.1 (placeWorkCoord pre n i h) + else idleDir (wHeads i), + r.2.2.2.2.2) + Ξ΄_right_of_start := by + intro q iHead wHeads oHead + obtain ⟨hin, hwork, hout⟩ := + tm.Ξ΄_right_of_start q iHead (fun i => wHeads (placeWorkIdx pre post i)) oHead + refine ⟨hin, fun i hi => ?_, hout⟩ + dsimp only + split + Β· rename_i hmid + apply hwork (placeWorkCoord pre n i hmid) + rw [placeWorkIdx_placeWorkCoord i hmid] + exact hi + Β· exact idleDir_right_of_start hi + +/-- Embed `c` into the placed layout. The supplied physical `extras` frame is +used outside the middle block and ignored inside it. -/ +def placeWorkCfg (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + Cfg (pre + n + post) (placeWorkTM pre post tm).Q where + state := c.state + input := c.input + work := fun i => + if h : placeWorkInMiddle pre n i then c.work (placeWorkCoord pre n i h) + else extras i + output := c.output + +/-- Apply the placement machine's idle work-tape action to an extra-tape frame. +Only values outside the middle block are observable through `placeWorkCfg`. -/ +def placeWorkFrameStep {pre n post : β„•} + (extras : Fin (pre + n + post) β†’ Tape) : Fin (pre + n + post) β†’ Tape := + fun i => (extras i).writeAndMove (readBackWrite (extras i).read) + (idleDir (extras i).read) + +/-- Canonical embedding whose prefix and suffix tapes are parked and blank. -/ +def placeWorkParkedCfg (tm : TM n) (pre post : β„•) (c : Cfg n tm.Q) : + Cfg (pre + n + post) (placeWorkTM pre post tm).Q := + placeWorkCfg tm pre post (fun _ => (Tape.init []).move Dir3.right) c + +@[simp] theorem placeWorkCfg_state (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkCfg tm pre post extras c).state = c.state := rfl + +@[simp] theorem placeWorkCfg_input (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkCfg tm pre post extras c).input = c.input := rfl + +@[simp] theorem placeWorkCfg_output (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkCfg tm pre post extras c).output = c.output := rfl + +@[simp] theorem placeWorkCfg_work_middle (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) (i : Fin n) : + (placeWorkCfg tm pre post extras c).work (placeWorkIdx pre post i) = c.work i := by + simp only [placeWorkCfg, placeWorkInMiddle_placeWorkIdx, dite_true] + rw [placeWorkCoord_placeWorkIdx] + +theorem placeWorkCfg_work_extra (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) + (i : Fin (pre + n + post)) (h : Β¬placeWorkInMiddle pre n i) : + (placeWorkCfg tm pre post extras c).work i = extras i := by + simp [placeWorkCfg, h] + +theorem placeWorkCfg_work_prefix (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) (i : Fin pre) : + (placeWorkCfg tm pre post extras c).work ⟨i.val, by omega⟩ = + extras ⟨i.val, by omega⟩ := by + apply placeWorkCfg_work_extra + simp [placeWorkInMiddle] + +theorem placeWorkCfg_work_suffix (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) (i : Fin post) : + (placeWorkCfg tm pre post extras c).work ⟨pre + n + i.val, by omega⟩ = + extras ⟨pre + n + i.val, by omega⟩ := by + apply placeWorkCfg_work_extra + simp [placeWorkInMiddle] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Internal.lean new file mode 100644 index 0000000000..566acdf0f9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Placement/Internal.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Placement.Defs + +/-! +# Work-tape placement correctness internals + +This file proves exact step and bounded-reachability commutation for +`TM.placeWorkTM`. The strongest one-step theorem evolves an arbitrary physical +extra-tape frame by its prescribed idle action. Stable frames and the canonical +parked frame are fixed points of that action. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n pre post : β„•} + +/-- The idle extra-tape action is the identity away from the left-end marker. -/ +private theorem placeWorkFrameStep_eq_self_of_read_ne_start (t : Tape) + (hread : t.read β‰  Ξ“.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t hread] + simp [idleDir, hread, Tape.move] + +/-- A blank tape at head zero or one is sent to the canonical parked blank tape. -/ +private theorem placeWorkFrameStep_blank (t : Tape) + (hcells : t.cells = (Tape.init []).cells) (hhead : t.head ≀ 1) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = + (Tape.init []).move Dir3.right := by + have hread : t.read = (Tape.init []).cells t.head := by rw [Tape.read, hcells] + rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hhead with h0 | h1 + Β· have ht : t = Tape.init [] := Tape.ext h0 hcells + subst ht + rfl + Β· have hr : t.read = Ξ“.blank := by rw [hread, h1]; rfl + rw [hr] + show t.write (readBackWrite Ξ“.blank) = (Tape.init []).move Dir3.right + rw [Tape.write, ite_eq_right (show Β¬t.head = 0 by omega), h1, hcells] + rw [show (readBackWrite Ξ“.blank).toΞ“ = (Tape.init []).cells 1 from rfl, + Function.update_eq_self] + rfl + +/-- Exact one-step commutation with an arbitrary extra-tape frame. The source +machine takes one step while every physical extra tape takes its idle action. -/ +theorem placeWorkTM_step_placeWorkCfg_internal (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) : + (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) = + (tm.step c).map + (placeWorkCfg tm pre post (placeWorkFrameStep extras)) := by + by_cases hhalt : c.state = tm.qhalt + Β· simp [TM.step, placeWorkCfg, placeWorkTM, hhalt] + rfl + Β· cases hstep : tm.step c with + | none => exact absurd hstep (by simp [TM.step, hhalt]) + | some c' => + simp only [TM.step, hhalt, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + have hreads : + (fun i : Fin n => + ((placeWorkCfg tm pre post extras c).work (placeWorkIdx pre post i)).read) = + (fun i => (c.work i).read) := by + funext i + rw [placeWorkCfg_work_middle] + simp only [TM.step, Option.map_some, + show (placeWorkCfg tm pre post extras c).state = c.state from rfl, + show (placeWorkTM pre post tm).qhalt = tm.qhalt from rfl] + split + Β· rename_i heq + exact (hhalt heq).elim + Β· dsimp only [placeWorkTM] + rw [placeWorkCfg_input, placeWorkCfg_output, hreads] + refine congrArg some + (Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩) + funext i + by_cases hmid : placeWorkInMiddle pre n i + Β· simp only [hmid, ↓reduceDIte, placeWorkCfg] + Β· simp only [hmid, ↓reduceDIte, placeWorkCfg, placeWorkFrameStep] + +/-- If every observable extra tape is off the left-end marker, the extra frame +is fixed and one placed step commutes through the same embedding. -/ +theorem placeWorkTM_step_placeWorkCfg_stable_internal (tm : TM n) (pre post : β„•) + (extras : Fin (pre + n + post) β†’ Tape) (c : Cfg n tm.Q) + (hextra : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ (extras i).read β‰  Ξ“.start) : + (placeWorkTM pre post tm).step (placeWorkCfg tm pre post extras c) = + (tm.step c).map (placeWorkCfg tm pre post extras) := by + rw [placeWorkTM_step_placeWorkCfg_internal] + cases hstep : tm.step c with + | none => rfl + | some c' => + simp only [Option.map_some] + refine congrArg some + (Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩) + funext i + by_cases hmid : placeWorkInMiddle pre n i + Β· simp only [hmid, ↓reduceDIte] + Β· simp only [hmid, ↓reduceDIte] + exact placeWorkFrameStep_eq_self_of_read_ne_start _ (hextra i hmid) + +/-- Bounded reachability commutes exactly while a stable arbitrary frame is +preserved around the source work tapes. -/ +theorem placeWorkTM_reachesIn_placeWorkCfg_stable_internal (tm : TM n) + (pre post : β„•) (extras : Fin (pre + n + post) β†’ Tape) + {t : β„•} {c c' : Cfg n tm.Q} (hreach : tm.reachesIn t c c') + (hextra : βˆ€ i, Β¬placeWorkInMiddle pre n i β†’ (extras i).read β‰  Ξ“.start) : + (placeWorkTM pre post tm).reachesIn t + (placeWorkCfg tm pre post extras c) + (placeWorkCfg tm pre post extras c') := by + induction hreach with + | zero => exact .zero + | step hstep _ ih => + exact .step (by + rw [placeWorkTM_step_placeWorkCfg_stable_internal tm pre post extras _ hextra, + hstep] + rfl) ih + +/-- The canonical parked frame is fixed by a placed source step. -/ +theorem placeWorkTM_step_placeWorkParkedCfg_internal (tm : TM n) (pre post : β„•) + (c : Cfg n tm.Q) : + (placeWorkTM pre post tm).step (placeWorkParkedCfg tm pre post c) = + (tm.step c).map (placeWorkParkedCfg tm pre post) := by + apply placeWorkTM_step_placeWorkCfg_stable_internal + intro i _ + decide + +/-- Bounded reachability commutes through the canonical parked embedding. -/ +theorem placeWorkTM_reachesIn_placeWorkParkedCfg_internal (tm : TM n) + (pre post : β„•) {t : β„•} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn t c c') : + (placeWorkTM pre post tm).reachesIn t + (placeWorkParkedCfg tm pre post c) + (placeWorkParkedCfg tm pre post c') := by + apply placeWorkTM_reachesIn_placeWorkCfg_stable_internal tm pre post _ hreach + intro i _ + decide + +/-- The first placed step from the ordinary initial configuration performs the +source machine's first step and parks every surrounding blank tape. -/ +theorem placeWorkTM_step_initCfg_internal (tm : TM n) (pre post : β„•) + (x : List Bool) : + (placeWorkTM pre post tm).step ((placeWorkTM pre post tm).initCfg x) = + (tm.step (tm.initCfg x)).map (placeWorkParkedCfg tm pre post) := by + let initialExtras : Fin (pre + n + post) β†’ Tape := fun _ => Tape.init [] + have hcfg : (placeWorkTM pre post tm).initCfg x = + placeWorkCfg tm pre post initialExtras (tm.initCfg x) := by + refine Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩ + funext i + by_cases hmid : placeWorkInMiddle pre n i + Β· simp only [hmid, ↓reduceDIte] + Β· simp only [hmid, ↓reduceDIte, initialExtras] + rw [hcfg, placeWorkTM_step_placeWorkCfg_internal] + cases hstep : tm.step (tm.initCfg x) with + | none => rfl + | some c => + simp only [Option.map_some] + refine congrArg some + (Cfg.mk.injEq _ _ _ _ _ _ _ _ |>.mpr ⟨rfl, rfl, ?_, rfl⟩) + funext i + by_cases hmid : placeWorkInMiddle pre n i + Β· simp only [hmid, ↓reduceDIte] + Β· simp only [hmid, ↓reduceDIte] + exact placeWorkFrameStep_blank _ rfl (Nat.zero_le 1) + +/-- Simulation from an ordinary initial configuration. At time zero the placed +configuration is its ordinary initial configuration; every positive run ends +in the canonical parked embedding of the source configuration. -/ +theorem placeWorkTM_reachesIn_init_internal (tm : TM n) (pre post : β„•) + (x : List Bool) {t : β„•} {c' : Cfg n tm.Q} + (hreach : tm.reachesIn t (tm.initCfg x) c') : + βˆƒ C' : Cfg (pre + n + post) (placeWorkTM pre post tm).Q, + (placeWorkTM pre post tm).reachesIn t ((placeWorkTM pre post tm).initCfg x) C' ∧ + C'.state = c'.state ∧ C'.input = c'.input ∧ C'.output = c'.output ∧ + (t = 0 ∨ C' = placeWorkParkedCfg tm pre post c') := by + cases hreach with + | zero => + exact ⟨(placeWorkTM pre post tm).initCfg x, .zero, rfl, rfl, rfl, Or.inl rfl⟩ + | @step _ cMid _ _ hstep hrest => + refine ⟨placeWorkParkedCfg tm pre post c', .step (c'' := + placeWorkParkedCfg tm pre post cMid) ?_ ?_, rfl, rfl, rfl, Or.inr rfl⟩ + Β· rw [placeWorkTM_step_initCfg_internal, hstep] + rfl + Β· exact placeWorkTM_reachesIn_placeWorkParkedCfg_internal tm pre post hrest + +/-- Work-tape placement preserves deterministic function computation with the +same time bound. -/ +theorem placeWorkTM_computesInTime_internal (tm : TM n) (pre post : β„•) + {f : List Bool β†’ List Bool} {T : β„• β†’ β„•} + (hcomp : tm.ComputesInTime f T) : + (placeWorkTM pre post tm).ComputesInTime f T := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := hcomp x + obtain ⟨C', hreach', hstate, _hinput, houtput, _hshape⟩ := + placeWorkTM_reachesIn_init_internal tm pre post x hreach + refine ⟨C', t, ht, hreach', ?_, ?_⟩ + Β· show C'.state = (placeWorkTM pre post tm).qhalt + rw [hstate] + exact hhalt + Β· rw [houtput] + exact hout + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers.lean new file mode 100644 index 0000000000..bdd555053f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers.lean @@ -0,0 +1,260 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Counter +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Unary registers + +A *register* is a work tape holding a natural number in unary: cells `1..v` +hold `1`, everything beyond is blank, and the head is parked at cell 1. All +arithmetic in the Cook–Levin reduction emitter (`docs/A5-ReductionEmitter.md`) +is over registers β€” the CNF encoding is unary, so no binary arithmetic is +ever needed. + +`IsReg` strengthens `Tape.HasUnaryCounter` with the cell-0 sentinel and +all-blanks-beyond, making registers literally preserved by parked no-op +actions and stable under the combinator phase transitions. + +## Main definitions + +- `TM.Parked` β€” a tape whose head is off `β–·` and which has no spurious `β–·`s +- `TM.IsReg` β€” the register predicate + +## Main results + +- `TM.IsReg.parked`, `TM.IsReg.hasUnaryCounter` β€” bridges +- `TM.reg_zero_init_bumped` β€” a freshly bumped blank tape is `IsReg 0` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Parked tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- A tape parked for preservation: head off `β–·` (so `idleDir` stays put and + `Ξ΄_right_of_start` is moot) and no `β–·` outside cell 0 (so `readBackWrite` + writes back the read symbol verbatim). Machines that do not use a tape + keep it parked and literally unchanged. -/ +def Parked (t : Tape) : Prop := + 1 ≀ t.head ∧ βˆ€ j, 1 ≀ j β†’ t.cells j β‰  Ξ“.start + +/-- A binary prefix has its head past the start marker and no later start cells. -/ +theorem hasBinaryPrefix_parked {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : Parked t := by + refine ⟨by rw [h.1]; omega, ?_⟩ + intro j hj + obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + by_cases hi : i < bits.length + Β· rw [h.2.1 i hi] + exact Ξ“.ofBool_ne_start _ + Β· rw [h.2.2 i (Nat.le_of_not_gt hi)] + decide + +/-- A parked tape never reads the start symbol `β–·`. -/ +theorem Parked.read_ne_start {t : Tape} (h : Parked t) : t.read β‰  Ξ“.start := + h.2 t.head h.1 + +/-- A parked tape is untouched by the no-op action `writeAndMove (readBackWrite + read) (idleDir read)`. -/ +theorem Parked.writeAndMove_readBack_idle {t : Tape} (h : Parked t) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := + Tape.writeAndMove_readBack_idle_of_ne_start t h.read_ne_start + +/-- A parked tape's head does not move under `idleDir`. -/ +theorem Parked.move_idle {t : Tape} (h : Parked t) : + t.move (idleDir t.read) = t := by + rw [idleDir, ite_eq_right h.read_ne_start] + rfl + +/-- Parked tapes pass through combinator phase boundaries unchanged. -/ +theorem Parked.transitionTape_eq_self {t : Tape} (h : Parked t) : transitionTape t = t := + TM.transitionTape_eq_self h.read_ne_start + +/-- Parked input tapes pass through combinator phase boundaries unchanged. -/ +theorem Parked.transitionInput_eq_self {t : Tape} (h : Parked t) : transitionInput t = t := + TM.transitionInput_eq_self h.read_ne_start + +/-- Parked input, work, and output tapes are fixed by a phase transition. -/ +theorem phaseTransition_of_parked {n : β„•} + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : Parked inp) (hwork : βˆ€ i, Parked (work i)) + (houtput : Parked out) : + transitionInput inp = inp ∧ + (fun i => transitionTape (work i)) = work ∧ + transitionTape out = out := + ⟨hinput.transitionInput_eq_self, + funext fun i => (hwork i).transitionTape_eq_self, + houtput.transitionTape_eq_self⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Registers +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Register.** The tape holds `v` in unary: `β–·` at cell 0, `1` at cells + `1..v`, blank everywhere beyond, head parked at cell 1. -/ +def IsReg (v : β„•) (t : Tape) : Prop := + t.head = 1 ∧ + t.cells 0 = Ξ“.start ∧ + (βˆ€ i, i < v β†’ t.cells (i + 1) = Ξ“.one) ∧ + (βˆ€ j, v + 1 ≀ j β†’ t.cells j = Ξ“.blank) + +namespace IsReg + +/-- A register tape's head is parked at cell 1. -/ +theorem head_eq {v : β„•} {t : Tape} (h : IsReg v t) : t.head = 1 := h.1 + +/-- A register tape's cell 0 holds the sentinel `β–·`. -/ +theorem cell0 {v : β„•} {t : Tape} (h : IsReg v t) : t.cells 0 = Ξ“.start := h.2.1 + +/-- Cells `1..v` of a register holding `v` contain `1`. -/ +theorem cells_one {v : β„•} {t : Tape} (h : IsReg v t) {i : β„•} (hi : i < v) : + t.cells (i + 1) = Ξ“.one := h.2.2.1 i hi + +/-- Cells beyond position `v` of a register holding `v` are blank. -/ +theorem cells_blank {v : β„•} {t : Tape} (h : IsReg v t) {j : β„•} (hj : v + 1 ≀ j) : + t.cells j = Ξ“.blank := h.2.2.2 j hj + +/-- Register cells off the sentinel are `1` or blank β€” never `β–·`. -/ +theorem cells_ne_start {v : β„•} {t : Tape} (h : IsReg v t) {j : β„•} (hj : 1 ≀ j) : + t.cells j β‰  Ξ“.start := by + rcases Nat.lt_or_ge j (v + 1) with hlt | hge + Β· obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [h.cells_one (by omega)]; decide + Β· rw [h.cells_blank hge]; decide + +/-- A register tape is parked. -/ +theorem parked {v : β„•} {t : Tape} (h : IsReg v t) : Parked t := + ⟨by rw [h.head_eq], fun _ hj => h.cells_ne_start hj⟩ + +/-- A register is a unary counter (the weaker shape used by the counter + subroutines). -/ +theorem hasUnaryCounter {v : β„•} {t : Tape} (h : IsReg v t) : + t.HasUnaryCounter v := + ⟨h.head_eq, fun _ hi => h.cells_one hi, h.cells_blank (le_refl _)⟩ + +/-- The register's read: `1` when nonempty, blank when zero. -/ +theorem read_eq {v : β„•} {t : Tape} (h : IsReg v t) : + t.read = if v = 0 then Ξ“.blank else Ξ“.one := by + rw [Tape.read, h.head_eq] + rcases Nat.eq_zero_or_pos v with rfl | hv + Β· rw [ite_eq_left rfl]; exact h.cells_blank (le_refl _) + Β· rw [ite_eq_right (by omega)]; exact h.cells_one hv + +end IsReg + +/-- A blank tape with the head bumped to cell 1 is the zero register. -/ +theorem reg_zero_init_bumped : IsReg 0 { head := 1, cells := (Tape.init []).cells } := by + refine ⟨rfl, by simp [Tape.init], fun _ hi => by omega, fun j hj => ?_⟩ + change (Tape.init []).cells j = Ξ“.blank + simp only [Tape.init] + rw [ite_eq_right (by omega : Β¬ j = 0)] + simp + +-- ════════════════════════════════════════════════════════════════════════ +-- The canonical register tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- Canonical register cells holding `v` in unary. -/ +def regCells (v : β„•) : β„• β†’ Ξ“ := fun j => + if j = 0 then Ξ“.start else if j ≀ v then Ξ“.one else Ξ“.blank + +/-- The canonical register tape holding `v`. -/ +def regTape (v : β„•) : Tape := ⟨1, regCells v⟩ + +/-- The canonical register tape's head sits at cell 1. -/ +@[simp] theorem regT_head (v : β„•) : (regTape v).head = 1 := rfl + +/-- The canonical register tape's cells are `regCells v`. -/ +@[simp] theorem regT_cells (v : β„•) : (regTape v).cells = regCells v := rfl + +/-- Cell 0 of the canonical register cells is the sentinel `β–·`. -/ +@[simp] theorem regCells_zero (v : β„•) : regCells v 0 = Ξ“.start := rfl + +/-- Cells `1..v` of the canonical register cells for `v` hold `1`. -/ +theorem regCells_one {v j : β„•} (h1 : 1 ≀ j) (h2 : j ≀ v) : regCells v j = Ξ“.one := by + rw [regCells, ite_eq_right (by omega), ite_eq_left h2] + +/-- Cells beyond position `v` of the canonical register cells for `v` are blank. -/ +theorem regCells_blank {v j : β„•} (h : v + 1 ≀ j) : regCells v j = Ξ“.blank := by + rw [regCells, ite_eq_right (by omega), ite_eq_right (by omega)] + +/-- Register cells away from the sentinel are never `β–·`. -/ +theorem regCells_ne_start {v j : β„•} (hj : 1 ≀ j) : + regCells v j β‰  Ξ“.start := by + rw [regCells, ite_eq_right (by omega)] + split <;> decide + +/-- The canonical register tape `regTape v` satisfies `IsReg v`. -/ +theorem reg_regT (v : β„•) : IsReg v (regTape v) := + ⟨rfl, rfl, fun _ hi => by rw [regT_cells]; exact regCells_one (by omega) (by omega), + fun _ hj => by rw [regT_cells]; exact regCells_blank hj⟩ + +/-- **A register's tape is canonical**: the `IsReg` predicate pins every cell and + the head, so it is an equation. -/ +theorem IsReg.eq_regT {v : β„•} {t : Tape} (h : IsReg v t) : t = regTape v := by + refine Tape.ext h.head_eq ?_ + funext j + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rw [h.cell0]; rfl + Β· rcases Nat.lt_or_ge v j with hlt | hge + Β· rw [h.cells_blank (by omega), regT_cells] + exact (regCells_blank (by omega)).symm + Β· obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [h.cells_one (by omega), regT_cells] + exact (regCells_one (by omega) (by omega)).symm + +/-- The canonical register tape is parked. -/ +theorem parked_regTape (v : β„•) : Parked (regTape v) := (reg_regT v).parked + +/-- Register cells with the head anywhere off `β–·` form a parked tape. -/ +theorem parked_regCells {h v : β„•} (hh : 1 ≀ h) : + Parked (⟨h, regCells v⟩ : Tape) := by + exact ⟨hh, fun _ hj => regCells_ne_start hj⟩ + +/-- Writing the next mark turns `regCells d` into `regCells (d + 1)`. -/ +theorem regCells_update_succ (d : β„•) : + Function.update (regCells d) (d + 1) Ξ“.one = regCells (d + 1) := by + funext j + rw [Function.update_apply] + split + Β· next h => + subst h + exact (regCells_one (by omega) (by omega)).symm + Β· next h => + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rfl + Β· rcases Nat.lt_or_ge d j with hlt | hge + Β· rw [regCells_blank (by omega), regCells_blank (by omega)] + Β· rw [regCells_one (by omega) (by omega), regCells_one (by omega) (by omega)] + +/-- Erasing the final mark turns `regCells (d + 1)` into `regCells d`. -/ +theorem regCells_update_blank_succ (d : β„•) : + Function.update (regCells (d + 1)) (d + 1) Ξ“.blank = regCells d := by + funext j + rw [Function.update_apply] + split + Β· next hj => + subst hj + exact (regCells_blank (by omega)).symm + Β· next hj => + rcases Nat.eq_zero_or_pos j with rfl | hj1 + Β· rfl + Β· rcases Nat.lt_or_ge d j with hlt | hge + Β· rw [regCells_blank (by omega), regCells_blank (by omega)] + Β· rw [regCells_one (by omega) (by omega), regCells_one (by omega) (by omega)] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Arith.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Arith.lean new file mode 100644 index 0000000000..d2eb28d363 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Arith.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.ForReg +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps + +/-! +# Derived register arithmetic + +Addition, copying, and multiply-accumulate over unary registers, composed from +`forRegTM`, `incRegTM`, and `clearRegTM` β€” no new hand-rolled machines. Each +spec is one application of `forRegTM_hoareTime` with an iteration-indexed +ghost family, plus `Function.update` bookkeeping. + +Time bounds are deliberately loose (rounded up via `HoareTime.mono_bound`); +only their polynomial shape matters downstream. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- `dst += src` (repeat-increment, fueled by `src`). -/ +def addIntoTM (src dst : Fin n) : TM n := forRegTM (incRegTM dst) src + +/-- **`addIntoTM` Hoare specification.** From `regTape a` in `src` and `regTape b` in + `dst`, reach `regTape (b + a)` in `dst`; `src` and everything else untouched. -/ +theorem addIntoTM_hoareTime (src dst : Fin n) (hne : src β‰  dst) (a b : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  src β†’ Parked (workβ‚€ i)) + (hsrc : workβ‚€ src = regTape a) (hdst : workβ‚€ dst = regTape b) : + (addIntoTM src dst).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ dst (regTape (b + a))) ys) + (a * ((2 * (b + a) + 4) + 2) + (a + 2)) := by + have hbody : βˆ€ i, i < a β†’ (incRegTM dst).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (Function.update workβ‚€ dst (regTape (b + i))) src + ⟨i + 2, regCells a⟩ ∧ OutAcc ys out) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (Function.update workβ‚€ dst (regTape (b + (i + 1)))) src + ⟨i + 2, regCells a⟩ ∧ OutAcc ys out) + (2 * (b + a) + 4) := by + intro i hi + have hspec := incRegTM_hoareTime dst (b + i) inpβ‚€ + (Function.update (Function.update workβ‚€ dst (regTape (b + i))) src + ⟨i + 2, regCells a⟩) ys hinpβ‚€ + (fun j hj => by + by_cases hjs : j = src + Β· subst hjs + rw [Function.update_self] + exact parked_regCells (by omega) + Β· rw [Function.update_of_ne hjs] + by_cases hjd : j = dst + Β· subst hjd + rw [Function.update_self] + exact parked_regTape _ + Β· rw [Function.update_of_ne hjd] + exact hworkβ‚€ j hjs) + (by + rw [Function.update_of_ne (fun h => hne h.symm), Function.update_self]) + have hfun : Function.update + (Function.update (Function.update workβ‚€ dst (regTape (b + i))) src + ⟨i + 2, regCells a⟩) dst (regTape (b + i + 1)) + = Function.update (Function.update workβ‚€ dst (regTape (b + (i + 1)))) src + ⟨i + 2, regCells a⟩ := by + rw [Function.update_comm hne, Function.update_idem] + rfl + refine (hspec.consequence (fun inp work out h => h) ?_ ?_) + Β· rintro inp work out ⟨h1, h2, h3⟩ + exact ⟨h1, by rw [h2, hfun], h3⟩ + Β· omega + have hrule := forRegTM_hoareTime (incRegTM dst) src a inpβ‚€ + (fun i => Function.update workβ‚€ dst (regTape (b + i))) (fun _ => ys) + (2 * (b + a) + 4) hinpβ‚€ + (fun i => by + show Function.update workβ‚€ dst (regTape (b + i)) src = regTape a + rw [Function.update_of_ne hne] + exact hsrc) + (fun i j hj => by + show Parked (Function.update workβ‚€ dst (regTape (b + i)) j) + by_cases hjd : j = dst + Β· subst hjd + rw [Function.update_self] + exact parked_regTape _ + Β· rw [Function.update_of_ne hjd] + exact hworkβ‚€ j hj) + hbody + have hw0 : Function.update workβ‚€ dst (regTape (b + 0)) = workβ‚€ := by + rw [show regTape (b + 0) = workβ‚€ dst from by rw [Nat.add_zero, hdst], + Function.update_eq_self] + exact hrule.weaken_pre (fun inp work out h => by + show EmitPred inpβ‚€ (Function.update workβ‚€ dst (regTape (b + 0))) ys inp work out + rw [hw0] + exact h) + +/-- `dst := src` (clear then add). -/ +def copyIntoTM (src dst : Fin n) : TM n := seqTM (clearRegTM dst) (addIntoTM src dst) + +/-- **`copyIntoTM` Hoare specification.** -/ +theorem copyIntoTM_hoareTime (src dst : Fin n) (hne : src β‰  dst) (a b : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  src β†’ Parked (workβ‚€ i)) + (hsrc : workβ‚€ src = regTape a) (hdst : workβ‚€ dst = regTape b) : + (copyIntoTM src dst).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ dst (regTape a)) ys) + ((2 * b + 4) + 1 + (a * ((2 * (0 + a) + 4) + 2) + (a + 2))) := by + have hclear := clearRegTM_hoareTime dst b inpβ‚€ workβ‚€ ys hinpβ‚€ + (fun i hi => by + by_cases his : i = src + Β· subst his; rw [hsrc]; exact parked_regTape _ + Β· exact hworkβ‚€ i (fun h => his h)) hdst + have hadd := addIntoTM_hoareTime src dst hne a 0 inpβ‚€ + (Function.update workβ‚€ dst (regTape 0)) ys hinpβ‚€ + (fun i hi => by + by_cases hid : i = dst + Β· subst hid; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hid]; exact hworkβ‚€ i hi) + (by rw [Function.update_of_ne hne]; exact hsrc) + (by rw [Function.update_self]) + have hmidP : βˆ€ i, Parked (Function.update workβ‚€ dst (regTape 0) i) := by + intro i + by_cases hid : i = dst + Β· subst hid; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hid] + by_cases his : i = src + Β· subst his; rw [hsrc]; exact parked_regTape _ + Β· exact hworkβ‚€ i his + have hseq := seqTM_hoareTime (clearRegTM dst) (addIntoTM src dst) hclear + (emitPred_transition hinpβ‚€ hmidP ys) hadd + refine hseq.strengthen_post ?_ + rintro inp work out ⟨h1, h2, h3⟩ + refine ⟨h1, ?_, h3⟩ + rw [h2, Function.update_idem, Nat.zero_add] + +/-- `dst += src₁ * srcβ‚‚` (repeat-add, fueled by `src₁`). -/ +def mulAddIntoTM (src₁ srcβ‚‚ dst : Fin n) : TM n := + forRegTM (addIntoTM srcβ‚‚ dst) src₁ + +/-- The (loose) per-iteration budget of `mulAddIntoTM`. -/ +def mulAddBound (a b d : β„•) : β„• := b * ((2 * (d + a * b + b) + 4) + 2) + (b + 2) + +/-- **`mulAddIntoTM` Hoare specification.** From `regTape a`, `regTape b`, `regTape d` + in `src₁`, `srcβ‚‚`, `dst`, reach `regTape (d + aΒ·b)` in `dst`. -/ +theorem mulAddIntoTM_hoareTime (src₁ srcβ‚‚ dst : Fin n) + (h12 : src₁ β‰  srcβ‚‚) (h1d : src₁ β‰  dst) (h2d : srcβ‚‚ β‰  dst) (a b d : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  src₁ β†’ Parked (workβ‚€ i)) + (h1 : workβ‚€ src₁ = regTape a) (h2 : workβ‚€ srcβ‚‚ = regTape b) + (hd : workβ‚€ dst = regTape d) : + (mulAddIntoTM src₁ srcβ‚‚ dst).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ dst (regTape (d + a * b))) ys) + (a * (mulAddBound a b d + 2) + (a + 2)) := by + have hbody : βˆ€ i, i < a β†’ (addIntoTM srcβ‚‚ dst).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (Function.update workβ‚€ dst (regTape (d + i * b))) src₁ + ⟨i + 2, regCells a⟩ ∧ OutAcc ys out) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (Function.update workβ‚€ dst (regTape (d + (i + 1) * b))) + src₁ ⟨i + 2, regCells a⟩ ∧ OutAcc ys out) + (mulAddBound a b d) := by + intro i hi + have hspec := addIntoTM_hoareTime srcβ‚‚ dst h2d b (d + i * b) inpβ‚€ + (Function.update (Function.update workβ‚€ dst (regTape (d + i * b))) src₁ + ⟨i + 2, regCells a⟩) ys hinpβ‚€ + (fun j hj => by + by_cases hj1 : j = src₁ + Β· subst hj1 + rw [Function.update_self] + exact parked_regCells (by omega) + Β· rw [Function.update_of_ne hj1] + by_cases hjd : j = dst + Β· subst hjd + rw [Function.update_self] + exact parked_regTape _ + Β· rw [Function.update_of_ne hjd] + exact hworkβ‚€ j hj1) + (by + rw [Function.update_of_ne (fun h => h12 h.symm), + Function.update_of_ne h2d] + exact h2) + (by + rw [Function.update_of_ne (fun h => h1d h.symm), Function.update_self]) + have hfun : Function.update + (Function.update (Function.update workβ‚€ dst (regTape (d + i * b))) src₁ + ⟨i + 2, regCells a⟩) dst (regTape (d + i * b + b)) + = Function.update (Function.update workβ‚€ dst (regTape (d + (i + 1) * b))) + src₁ ⟨i + 2, regCells a⟩ := by + rw [Function.update_comm h1d, Function.update_idem, + show d + i * b + b = d + (i + 1) * b from by rw [Nat.succ_mul]; omega] + have him : i * b ≀ a * b := Nat.mul_le_mul_right b (le_of_lt hi) + have hinner : (2 * (d + i * b + b) + 4) + 2 ≀ (2 * (d + a * b + b) + 4) + 2 := by + omega + have hbnd := Nat.mul_le_mul_left b hinner + refine hspec.consequence (fun _ _ _ h => h) ?_ ?_ + Β· rintro inp work out ⟨g1, g2, g3⟩ + exact ⟨g1, by rw [g2, hfun], g3⟩ + Β· show b * ((2 * (d + i * b + b) + 4) + 2) + (b + 2) ≀ mulAddBound a b d + rw [mulAddBound] + omega + have hrule := forRegTM_hoareTime (addIntoTM srcβ‚‚ dst) src₁ a inpβ‚€ + (fun i => Function.update workβ‚€ dst (regTape (d + i * b))) (fun _ => ys) + (mulAddBound a b d) hinpβ‚€ + (fun i => by + show Function.update workβ‚€ dst (regTape (d + i * b)) src₁ = regTape a + rw [Function.update_of_ne h1d] + exact h1) + (fun i j hj => by + show Parked (Function.update workβ‚€ dst (regTape (d + i * b)) j) + by_cases hjd : j = dst + Β· subst hjd + rw [Function.update_self] + exact parked_regTape _ + Β· rw [Function.update_of_ne hjd] + exact hworkβ‚€ j hj) + hbody + have hw0 : Function.update workβ‚€ dst (regTape (d + 0 * b)) = workβ‚€ := by + rw [show regTape (d + 0 * b) = workβ‚€ dst from by + rw [Nat.zero_mul, Nat.add_zero, hd], + Function.update_eq_self] + exact hrule.weaken_pre (fun inp work out h => by + show EmitPred inpβ‚€ (Function.update workβ‚€ dst (regTape (d + 0 * b))) ys inp work out + rw [hw0] + exact h) + +-- ════════════════════════════════════════════════════════════════════════ +-- Iterated machines (constant-building) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Run `m` in sequence `c` times. -/ +def iterTM (m : TM n) : β„• β†’ TM n + | 0 => skipTM + | c + 1 => seqTM m (iterTM m c) + +/-- **Iterated increment**: add the constant `c` to register `q`. -/ +theorem iterTM_incRegTM_hoareTime (q : Fin n) (c : β„•) : + βˆ€ (d : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool), + Parked inpβ‚€ β†’ (βˆ€ i, Parked (workβ‚€ i)) β†’ workβ‚€ q = regTape d β†’ + (iterTM (incRegTM q) c).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ q (regTape (d + c))) ys) + (c * (2 * (d + c) + 5) + 1) := by + induction c with + | zero => + intro d inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ hq + have hskip := skipTM_hoareTime inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ + refine hskip.consequence (fun _ _ _ h => h) ?_ (by omega) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, show regTape (d + 0) = workβ‚€ q from by rw [Nat.add_zero, hq], + Function.update_eq_self] + | succ c ih => + intro d inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ hq + have hinc := incRegTM_hoareTime q d inpβ‚€ workβ‚€ ys hinpβ‚€ + (fun i _ => hworkβ‚€ i) hq + have hmidP : βˆ€ i, Parked (Function.update workβ‚€ q (regTape (d + 1)) i) := by + intro i + by_cases hiq : i = q + Β· subst hiq; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hiq]; exact hworkβ‚€ i + have hrest := ih (d + 1) inpβ‚€ (Function.update workβ‚€ q (regTape (d + 1))) ys + hinpβ‚€ hmidP (by rw [Function.update_self]) + have hseq := seqTM_hoareTime (incRegTM q) (iterTM (incRegTM q) c) hinc + (emitPred_transition hinpβ‚€ hmidP ys) hrest + refine hseq.consequence (fun _ _ _ h => h) ?_ ?_ + Β· rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, Function.update_idem, + show d + 1 + c = d + (c + 1) from by omega] + Β· have hmul : (c + 1) * (2 * (d + (c + 1)) + 5) + = c * (2 * (d + (c + 1)) + 5) + (2 * (d + (c + 1)) + 5) := + Nat.succ_mul .. + have hmono : c * (2 * (d + 1 + c) + 5) ≀ c * (2 * (d + (c + 1)) + 5) := + Nat.mul_le_mul_left c (by omega) + omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Emit.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Emit.lean new file mode 100644 index 0000000000..d36fd0e229 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Emit.lean @@ -0,0 +1,878 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare + +/-! +# Output-emission subroutines + +Building blocks for machines that *compute string functions* (`ComputesInTime`): +the output tape is treated as an append-only accumulator, written left to +right. The central predicate `OutAcc ys out` says the output tape holds +exactly the bits `ys` (after the `β–·` at cell 0) with the head parked on the +first blank, ready to append; emitters have Hoare specs of the shape + + {OutAcc ys ∧ …} emit {OutAcc (ys ++ w) ∧ …} + +which compose by `seqTM` along `List.append` associativity. The final bridge +to `ComputesInTime` is `OutAcc.hasOutput`. + +This layer is the foundation for the Cook–Levin reduction emitter +(`docs/A5-ReductionEmitter.md`). + +## Main definitions + +- `TM.OutAcc` β€” the output-accumulator predicate +- `TM.bumpTM` β€” entry adapter: bump every head from `β–·` to cell 1 +- `TM.emitBitsTM` β€” append a fixed word to the output +- `TM.emitUnaryTM` β€” append a register's value as a doubled-unary run +- `TM.emitLitTM` β€” append one encoded literal (sign bits, unary body, terminator) + +## Main results + +- `TM.OutAcc.hasOutput` β€” accumulated output is `HasOutput` +- `TM.OutAcc.eq` β€” the accumulated word uniquely determines its output tape +- `TM.outAcc_append_bit` β€” one `writeAndMove _ .right` extends the accumulator +- `TM.emitBitsTM_reachesIn_frame` β€” exact emission with a complete input/work frame +- `TM.emitBitsTM_hoareTime` β€” `emitBitsTM w` appends `w` in `|w|` steps, + preserving the input and work tapes +- `TM.emitBitsTM_isTransducer` β€” fixed-word emission never moves output left +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- The output accumulator +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Output accumulator.** The output tape holds exactly the bits `ys` + (cells `1..|ys|`, after the `β–·` at cell 0), all cells beyond are blank, + and the head is parked on the first blank β€” ready to append. -/ +def OutAcc (ys : List Bool) (out : Tape) : Prop := + out.head = ys.length + 1 ∧ + out.cells 0 = Ξ“.start ∧ + (βˆ€ i, (h : i < ys.length) β†’ out.cells (i + 1) = Ξ“.ofBool ys[i]) ∧ + (βˆ€ j, ys.length + 1 ≀ j β†’ out.cells j = Ξ“.blank) + +namespace OutAcc + +/-- The accumulator head sits just past the `|ys|` stored bits, at cell `|ys| + 1`. -/ +theorem head_eq {ys : List Bool} {out : Tape} (h : OutAcc ys out) : + out.head = ys.length + 1 := h.1 + +/-- The accumulator reads the first blank. -/ +theorem read_blank {ys : List Bool} {out : Tape} (h : OutAcc ys out) : + out.read = Ξ“.blank := by + rw [Tape.read, h.1]; exact h.2.2.2 _ (le_refl _) + +/-- An accumulator tape is parked (bits and blanks are never `β–·`). -/ +theorem parked {ys : List Bool} {out : Tape} (h : OutAcc ys out) : Parked out := by + refine ⟨by rw [h.1]; omega, fun j hj => ?_⟩ + rcases Nat.lt_or_ge j (ys.length + 1) with hlt | hge + Β· obtain ⟨i, rfl⟩ : βˆƒ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [h.2.2.1 i (by omega)] + cases ys[i] <;> decide + Β· rw [h.2.2.2 j hge]; decide + +/-- The bridge to `ComputesInTime`: an accumulated output `HasOutput` its bits. -/ +theorem hasOutput {ys : List Bool} {out : Tape} (h : OutAcc ys out) : + out.HasOutput ys := + ⟨fun i hi => h.2.2.1 i hi, h.2.2.2 _ (le_refl _)⟩ + +/-- An output accumulator is uniquely determined by its accumulated word. -/ +theorem eq {ys : List Bool} {first second : Tape} + (hfirst : OutAcc ys first) (hsecond : OutAcc ys second) : + first = second := by + apply Tape.ext + Β· rw [hfirst.1, hsecond.1] + Β· funext j + by_cases hj0 : j = 0 + Β· subst j + rw [hfirst.2.1, hsecond.2.1] + Β· by_cases hj : j ≀ ys.length + Β· obtain ⟨i, hi, rfl⟩ : βˆƒ i, i < ys.length ∧ j = i + 1 := by + refine ⟨j - 1, by omega, by omega⟩ + rw [hfirst.2.2.1 i hi, hsecond.2.2.1 i hi] + Β· rw [hfirst.2.2.2 j (by omega), hsecond.2.2.2 j (by omega)] + +end OutAcc + +/-- The empty accumulator: a blank output tape with the head bumped to cell 1. -/ +theorem outAcc_nil_init : OutAcc [] { head := 1, cells := (Tape.init []).cells } := by + refine ⟨rfl, by simp [Tape.init], fun i hi => absurd hi (by simp), fun j hj => ?_⟩ + show (Tape.init []).cells j = Ξ“.blank + simp only [Tape.init] + rw [ite_eq_right (by omega : Β¬ j = 0)] + simp + +/-- **Appending one bit.** Writing `Ξ“.ofBool b` at the accumulator head and + moving right extends the accumulator by `b`. -/ +theorem outAcc_append_bit {ys : List Bool} {out : Tape} (h : OutAcc ys out) (b : Bool) : + OutAcc (ys ++ [b]) (out.writeAndMove (Ξ“.ofBool b) .right) := by + obtain ⟨hhead, hc0, hbits, hblank⟩ := h + have hne : Β¬ out.head = 0 := by omega + have hcells : (out.writeAndMove (Ξ“.ofBool b) .right).cells + = Function.update out.cells (ys.length + 1) (Ξ“.ofBool b) := by + show ((out.write _).move _).cells = _ + rw [Tape.move] + show (out.write _).cells = _ + rw [Tape.write, ite_eq_right hne, hhead] + have hhead' : (out.writeAndMove (Ξ“.ofBool b) .right).head = out.head + 1 := by + show ((out.write _).move _).head = _ + rw [Tape.move] + show (out.write _).head + 1 = _ + rw [Tape.write, ite_eq_right hne] + refine ⟨?_, ?_, ?_, ?_⟩ + Β· rw [hhead', hhead]; simp + Β· rw [hcells, Function.update_of_ne (by omega : Β¬ (0 : β„•) = ys.length + 1)] + exact hc0 + Β· intro i hi + rw [List.length_append, List.length_cons, List.length_nil] at hi + rcases Nat.lt_or_ge i ys.length with hlt | hge + Β· rw [hcells, Function.update_of_ne (by omega : Β¬ i + 1 = ys.length + 1), + List.getElem_append_left hlt] + exact hbits i hlt + Β· obtain rfl : i = ys.length := by omega + rw [hcells, Function.update_self, + List.getElem_append_right (le_refl _)] + simp + Β· intro j hj + rw [List.length_append, List.length_cons, List.length_nil] at hj + rw [hcells, Function.update_of_ne (by omega : Β¬ j = ys.length + 1)] + exact hblank j (by omega) + +-- ════════════════════════════════════════════════════════════════════════ +-- bumpTM: the entry adapter +-- ════════════════════════════════════════════════════════════════════════ + +/-- The two states of `bumpTM`: `go` (initial, about to bump every head right) + and `done` (halted). -/ +inductive BumpPhase where + | go | done + deriving DecidableEq + +/-- `BumpPhase` is a finite type, as required for TM state spaces. -/ +instance : Fintype BumpPhase where + elems := {.go, .done} + complete := fun x => by cases x <;> simp + +/-- **Entry adapter**: one step moving every head from `β–·` (cell 0, the + initial configuration) to cell 1, establishing the parked discipline: + blank work tapes become zero registers and the blank output becomes the + empty accumulator. -/ +def bumpTM : TM n where + Q := BumpPhase + qstart := .go + qhalt := .done + Ξ΄ := fun _ _ wHeads _ => + (.done, fun i => readBackWrite (wHeads i), .blank, + Dir3.right, fun _ => Dir3.right, Dir3.right) + Ξ΄_right_of_start := fun _ _ _ _ => ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + +/-- The input tape of the initial configuration, bumped to cell 1, is parked. -/ +theorem parked_init_input (x : List Bool) : + Parked { head := 1, cells := (Tape.init (x.map Ξ“.ofBool)).cells } := by + refine ⟨le_refl 1, fun j hj => ?_⟩ + show (Tape.init (x.map Ξ“.ofBool)).cells j β‰  Ξ“.start + simp only [Tape.init] + rw [ite_eq_right (by omega : Β¬ j = 0)] + cases h : (x.map Ξ“.ofBool)[j - 1]? with + | none => decide + | some g => + obtain ⟨b, _, rfl⟩ := List.mem_map.mp (List.mem_of_getElem? h) + cases b <;> decide + +/-- **`bumpTM` Hoare specification.** From the initial configuration's tapes, + one step establishes: parked input (cells intact), zero registers on all + work tapes, and the empty output accumulator. -/ +theorem bumpTM_hoareTime (x : List Bool) : + (bumpTM (n := n)).HoareTime + (fun inp work out => + inp = Tape.init (x.map Ξ“.ofBool) ∧ (βˆ€ i, work i = Tape.init []) ∧ + out = Tape.init []) + (fun inp work out => + inp = { head := 1, cells := (Tape.init (x.map Ξ“.ofBool)).cells } ∧ + (βˆ€ i, IsReg 0 (work i)) ∧ OutAcc [] out) + 1 := by + rintro inp work out ⟨rfl, hwork, rfl⟩ + obtain rfl : work = fun _ => Tape.init [] := funext hwork + refine ⟨⟨BumpPhase.done, ⟨1, (Tape.init (x.map Ξ“.ofBool)).cells⟩, + fun _ => ⟨1, (Tape.init []).cells⟩, ⟨1, (Tape.init []).cells⟩⟩, 1, le_refl 1, + .step ?_ .zero, rfl, rfl, fun _ => reg_zero_init_bumped, outAcc_nil_init⟩ + rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- emitBitsTM: append a fixed word to the output +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Append the fixed word `w` to the output** and halt. State `k` = number of + bits already emitted; each step writes bit `k` and moves the output head + right; input and work tapes are parked and untouched. -/ +def emitBitsTM (w : List Bool) : TM n where + Q := Fin (w.length + 1) + qstart := ⟨0, by omega⟩ + qhalt := ⟨w.length, by omega⟩ + Ξ΄ := fun k iHead wHeads oHead => + if h : k.val < w.length then + (⟨k.val + 1, by omega⟩, fun i => readBackWrite (wHeads i), Ξ“w.ofBool w[k.val], + idleDir iHead, fun i => idleDir (wHeads i), Dir3.right) + else + allIdle k iHead wHeads oHead + Ξ΄_right_of_start := by + intro k iHead wHeads oHead + by_cases h : k.val < w.length + Β· simp only [h, ↓reduceDIte] + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => trivial⟩ + Β· simp only [h, ↓reduceDIte] + exact rightOfStart_allIdle iHead wHeads oHead + +/-- One emit step: from state `k < |w|`, the machine writes bit `k`, advances + the accumulator, and leaves the parked input and work tapes unchanged. -/ +private theorem emitBitsTM_step (w : List Bool) (c : Cfg n (emitBitsTM (n := n) w).Q) + (k : β„•) (hk : k < w.length) (hst : c.state = ⟨k, by omega⟩) + (hinp : Parked c.input) (hwork : βˆ€ i, Parked (c.work i)) : + (emitBitsTM (n := n) w).step c = some + { state := ⟨k + 1, by omega⟩, input := c.input, work := c.work, + output := c.output.writeAndMove (Ξ“.ofBool w[k]) .right } := by + have hne : Β¬ c.state = (emitBitsTM (n := n) w).qhalt := by + rw [hst] + simp only [emitBitsTM, Fin.mk.injEq] + omega + rw [TM.step, ite_eq_right hne] + simp only [emitBitsTM, hst, hk, ↓reduceDIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· rw [Ξ“w.ofBool_toΞ“] + +/-- The emit loop: from state `k` with `|w| = k + m`, the machine reaches the + halt state in exactly `m` steps, appending `w.drop k` and preserving the + input and work tapes. -/ +private theorem emitBitsTM_run (w : List Bool) (m : β„•) : + βˆ€ (k : β„•) (hk : w.length = k + m), + βˆ€ (c : Cfg n (emitBitsTM (n := n) w).Q) (ys : List Bool), + c.state = ⟨k, by omega⟩ β†’ Parked c.input β†’ (βˆ€ i, Parked (c.work i)) β†’ + OutAcc ys c.output β†’ + βˆƒ c', (emitBitsTM (n := n) w).reachesIn m c c' ∧ + c'.state = ⟨w.length, by omega⟩ ∧ c'.input = c.input ∧ c'.work = c.work ∧ + OutAcc (ys ++ w.drop k) c'.output := by + induction m with + | zero => + intro k hk c ys hst hinp hwork hout + refine ⟨c, .zero, ?_, rfl, rfl, ?_⟩ + Β· rw [hst]; congr 1; omega + Β· rw [List.drop_of_length_le (by omega), List.append_nil] + exact hout + | succ m ih => + intro k hk c ys hst hinp hwork hout + have hklt : k < w.length := by omega + have hstep := emitBitsTM_step w c k hklt hst hinp hwork + set c₁ : Cfg n (emitBitsTM (n := n) w).Q := + { state := ⟨k + 1, by omega⟩, input := c.input, work := c.work, + output := c.output.writeAndMove (Ξ“.ofBool w[k]) .right } with hc₁ + obtain ⟨c', hreach, hst', hinp', hwork', hout'⟩ := + ih (k + 1) (by omega) c₁ (ys ++ [w[k]]) rfl hinp hwork + (outAcc_append_bit hout w[k]) + refine ⟨c', .step hstep hreach, hst', hinp', hwork', ?_⟩ + rwa [List.append_assoc, List.singleton_append, + List.getElem_cons_drop] at hout' + +/-- Exact fixed-word emission appends `w`, preserves the complete input/work +frame, and reaches the halt state in exactly `|w|` steps. -/ +theorem emitBitsTM_reachesIn_frame (w : List Bool) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) + (houtβ‚€ : OutAcc ys outβ‚€) : + βˆƒ c', + (emitBitsTM (n := n) w).reachesIn w.length + { state := (emitBitsTM (n := n) w).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (emitBitsTM (n := n) w).halted c' ∧ + c'.input = inpβ‚€ ∧ + c'.work = workβ‚€ ∧ + OutAcc (ys ++ w) c'.output := by + obtain ⟨c', hreach, hhalt, hinput, hwork, houtput⟩ := + emitBitsTM_run w w.length 0 (by omega) + { state := ⟨0, by omega⟩, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } + ys rfl hinpβ‚€ hworkβ‚€ houtβ‚€ + refine ⟨c', hreach, hhalt, hinput, hwork, ?_⟩ + rwa [List.drop_zero] at houtput + +/-- Fixed-word emission satisfies the one-way-output transducer discipline. -/ +theorem emitBitsTM_isTransducer (w : List Bool) : + (emitBitsTM (n := n) w).IsTransducer := by + intro k iHead wHeads oHead + by_cases h : k.val < w.length + Β· simp [emitBitsTM, h] + Β· simp [emitBitsTM, h, allIdle, idleDir] + split <;> decide + +/-- **`emitBitsTM` Hoare specification.** Appends the word `w` to the output + accumulator in `|w|` steps, leaving the (parked) input and work tapes + literally unchanged. Ghost-parametrized by the initial tapes for + `seqTM` composition. -/ +theorem emitBitsTM_hoareTime (w : List Bool) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (ys : List Bool) (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) : + (emitBitsTM (n := n) w).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ OutAcc ys out) + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ OutAcc (ys ++ w) out) + w.length := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c', hreach, hst', hinp', hwork', hout'⟩ := + emitBitsTM_run w w.length 0 (by omega) + { state := ⟨0, by omega⟩, input := inp, work := work, output := out } + ys rfl hinpβ‚€ hworkβ‚€ hout + refine ⟨c', w.length, le_refl _, hreach, ?_, hinp', hwork', ?_⟩ + Β· exact hst' + Β· rw [List.drop_zero] at hout' + exact hout' + +-- ════════════════════════════════════════════════════════════════════════ +-- emitUnaryTM: append a register's value as a doubled-unary run +-- ════════════════════════════════════════════════════════════════════════ + +/-- The states of `emitUnaryTM`: `emitA`/`emitB` alternate to emit two trues per + register mark, `back` rewinds the register head to `β–·`, `park` steps it to + cell 1, and `done` halts. -/ +inductive EmitUnaryPhase where + | emitA | emitB | back | park | done + deriving DecidableEq + +/-- `EmitUnaryPhase` is a finite type, as required for TM state spaces. -/ +instance : Fintype EmitUnaryPhase where + elems := {.emitA, .emitB, .back, .park, .done} + complete := fun x => by cases x <;> simp + +/-- **Append `2v` trues to the output, where `v` is the value of register `r`** + (the doubled-unary body `doubleBits (Unary.encode v)` of a literal's + variable index), restoring the register exactly. The head sweeps right + over the register's marks emitting two trues per mark (`emitA`/`emitB`), + then rewinds to cell 1 (`back`/`park`). -/ +def emitUnaryTM (r : Fin n) : TM n where + Q := EmitUnaryPhase + qstart := .emitA + qhalt := .done + Ξ΄ := fun s iHead wHeads oHead => + match s with + | .emitA => + if wHeads r = Ξ“.one then + (.emitB, fun i => readBackWrite (wHeads i), Ξ“w.one, + idleDir iHead, fun i => if i = r then Dir3.stay else idleDir (wHeads i), + Dir3.right) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = r then (if wHeads r = Ξ“.start then Dir3.right else Dir3.left) + else idleDir (wHeads i), + idleDir oHead) + | .emitB => + (.emitA, fun i => readBackWrite (wHeads i), Ξ“w.one, + idleDir iHead, fun i => if i = r then Dir3.right else idleDir (wHeads i), + Dir3.right) + | .back => + if wHeads r = Ξ“.start then + (.park, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = r then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = r then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .park => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle s iHead wHeads oHead + Ξ΄_right_of_start := by + intro s iHead wHeads oHead + match s with + | .emitA => + dsimp only [] + split + Β· next hone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, fun _ => rfl⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; rw [hone] at hi; exact absurd hi (by decide) + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hnone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; rw [ite_eq_left rfl, ite_eq_left hi] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .emitB => + refine ⟨idleDir_right_of_start, fun i hi => ?_, fun _ => rfl⟩ + dsimp only [] + by_cases hir : i = r + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .back => + dsimp only [] + split + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hns => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; exact absurd hi hns + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .park => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +section EmitUnary + +variable {r : Fin n} + +/-- Not yet halted, from any of the four working phases. -/ +private theorem emitUnaryTM_ne_halt {s : EmitUnaryPhase} (h : s β‰  .done) + {c : Cfg n (emitUnaryTM (n := n) r).Q} (hst : c.state = s) : + Β¬ c.state = (emitUnaryTM (n := n) r).qhalt := by + rw [hst] + show Β¬ s = EmitUnaryPhase.done + exact h + +/-- `emitA` over a mark: write one `true`, output right, register stays. -/ +private theorem emitUnaryTM_step_emitA_one (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .emitA) (hone : (c.work r).read = Ξ“.one) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) : + (emitUnaryTM (n := n) r).step c = some + { state := .emitB, input := c.input, work := c.work, + output := c.output.writeAndMove (Ξ“.ofBool true) .right } := by + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst, hone, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, writeAndMove_readBack _ (by rw [hone]; decide)] + rfl + Β· rw [ite_eq_right hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· rfl + +/-- `emitB`: write the second `true`, output right, register advances right. -/ +private theorem emitUnaryTM_step_emitB (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .emitB) (hone : (c.work r).read = Ξ“.one) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) : + (emitUnaryTM (n := n) r).step c = some + { state := .emitA, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := c.output.writeAndMove (Ξ“.ofBool true) .right } := by + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hone]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· rfl + +/-- `emitA` over the sentinel blank: turn around (register head left), output + untouched. -/ +private theorem emitUnaryTM_step_emitA_blank (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .emitA) (hblank : (c.work r).read = Ξ“.blank) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (emitUnaryTM (n := n) r).step c = some + { state := .back, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst, hblank, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hblank]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` off the sentinel: keep rewinding left, everything else untouched. -/ +private theorem emitUnaryTM_step_back_left (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .back) (hns : (c.work r).read β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (emitUnaryTM (n := n) r).step c = some + { state := .back, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst, hns, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, writeAndMove_readBack _ hns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` on the sentinel `β–·` (which, absent spurious `β–·`s, means cell 0): + step right to cell 1 and park. The write is structurally void at cell 0. -/ +private theorem emitUnaryTM_step_back_start (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .back) (hs : (c.work r).read = Ξ“.start) + (hcr : βˆ€ j, 1 ≀ j β†’ (c.work r).cells j β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (emitUnaryTM (n := n) r).step c = some + { state := .park, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := c.output } := by + have h0 : (c.work r).head = 0 := by + by_contra hc + exact hcr _ (by omega) hs + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst, hs, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self] + show ((c.work i).write _).move Dir3.right = (c.work i).move .right + congr 1 + rw [Tape.write, ite_eq_left h0] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `park`: one idle step into `done`; nothing changes. -/ +private theorem emitUnaryTM_step_park (c : Cfg n (emitUnaryTM (n := n) r).Q) + (hst : c.state = .park) (hinp : Parked c.input) (hwork : βˆ€ i, Parked (c.work i)) + (hout : Parked c.output) : + (emitUnaryTM (n := n) r).step c = some + { state := .done, input := c.input, work := c.work, output := c.output } := by + rw [TM.step, ite_eq_right (emitUnaryTM_ne_halt (by decide) hst)] + simp only [emitUnaryTM, hst] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The emit loop: from `emitA` mid-scan (register head at `k + 1`, register + value `v = k + m`), the machine emits `2m` trues in `2m` steps and lands + back in `emitA` on the sentinel blank, register cells untouched. -/ +private theorem emitUnaryTM_emit_run (v m : β„•) : + βˆ€ (k : β„•), v = k + m β†’ + βˆ€ (c : Cfg n (emitUnaryTM (n := n) r).Q) (ys : List Bool), + c.state = .emitA β†’ + Parked c.input β†’ (βˆ€ i, i β‰  r β†’ Parked (c.work i)) β†’ + (βˆ€ i, i < v β†’ (c.work r).cells (i + 1) = Ξ“.one) β†’ + (βˆ€ j, v + 1 ≀ j β†’ (c.work r).cells j = Ξ“.blank) β†’ + (c.work r).head = k + 1 β†’ + OutAcc ys c.output β†’ + βˆƒ c', (emitUnaryTM (n := n) r).reachesIn (2 * m) c c' ∧ + c'.state = .emitA ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  r β†’ c'.work i = c.work i) ∧ + (c'.work r).cells = (c.work r).cells ∧ + (c'.work r).head = v + 1 ∧ + OutAcc (ys ++ List.replicate (2 * m) true) c'.output := by + induction m with + | zero => + intro k hk c ys hst hinp hwork _ _ hhead hout + refine ⟨c, .zero, hst, rfl, fun _ _ => rfl, rfl, ?_, by simpa using hout⟩ + rw [hhead, hk] + | succ m ih => + intro k hk c ys hst hinp hwork hones hblanks hhead hout + have hone : (c.work r).read = Ξ“.one := by + rw [Tape.read, hhead]; exact hones k (by omega) + have hstepA := emitUnaryTM_step_emitA_one c hst hone hinp hwork + set c₁ : Cfg n (emitUnaryTM (n := n) r).Q := + { state := .emitB, input := c.input, work := c.work, + output := c.output.writeAndMove (Ξ“.ofBool true) .right } with hc₁ + have hstepB := emitUnaryTM_step_emitB c₁ rfl hone hinp hwork + set cβ‚‚ : Cfg n (emitUnaryTM (n := n) r).Q := + { state := .emitA, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := (c.output.writeAndMove (Ξ“.ofBool true) .right).writeAndMove + (Ξ“.ofBool true) .right } with hcβ‚‚ + have hmove_cells : ((c.work r).move .right).cells = (c.work r).cells := rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih (k + 1) (by omega) cβ‚‚ (ys ++ [true] ++ [true]) rfl hinp + (fun i hi => by + show Parked (Function.update c.work r ((c.work r).move .right) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + (fun i hi => by + show (Function.update c.work r ((c.work r).move .right) r).cells (i + 1) = Ξ“.one + rw [Function.update_self, hmove_cells] + exact hones i hi) + (fun j hj => by + show (Function.update c.work r ((c.work r).move .right) r).cells j = Ξ“.blank + rw [Function.update_self, hmove_cells] + exact hblanks j hj) + (by + show (Function.update c.work r ((c.work r).move .right) r).head = (k + 1) + 1 + rw [Function.update_self] + show (c.work r).head + 1 = (k + 1) + 1 + rw [hhead]) + (outAcc_append_bit (outAcc_append_bit hout true) true) + refine ⟨c', .step hstepA (.step hstepB hreach), hst', hinp', ?_, ?_, hhead', ?_⟩ + Β· intro i hi + rw [hwork' i hi] + show Function.update c.work r ((c.work r).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [hcells'] + show (Function.update c.work r ((c.work r).move .right) r).cells = (c.work r).cells + rw [Function.update_self, hmove_cells] + Β· have he : ys ++ [true] ++ [true] ++ List.replicate (2 * m) true + = ys ++ List.replicate (2 * (m + 1)) true := by + rw [show 2 * (m + 1) = 2 * m + 1 + 1 from by omega, List.replicate_succ, + List.replicate_succ] + simp [List.append_assoc] + rwa [he] at hout' + +/-- The rewind loop: from `back` with the register head at `h` (cell 0 holds + `β–·`, no spurious `β–·`s beyond), the machine reaches `done` in `h + 2` steps + with the register parked at cell 1 and everything else untouched. -/ +private theorem emitUnaryTM_back_run (h : β„•) : + βˆ€ (c : Cfg n (emitUnaryTM (n := n) r).Q) (ys : List Bool), + c.state = .back β†’ + Parked c.input β†’ (βˆ€ i, i β‰  r β†’ Parked (c.work i)) β†’ + (c.work r).cells 0 = Ξ“.start β†’ + (βˆ€ j, 1 ≀ j β†’ (c.work r).cells j β‰  Ξ“.start) β†’ + (c.work r).head = h β†’ + OutAcc ys c.output β†’ + βˆƒ c', (emitUnaryTM (n := n) r).reachesIn (h + 2) c c' ∧ + c'.state = .done ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  r β†’ c'.work i = c.work i) ∧ + (c'.work r).cells = (c.work r).cells ∧ + (c'.work r).head = 1 ∧ + c'.output = c.output := by + induction h with + | zero => + intro c ys hst hinp hwork hc0 hcr hhead hout + have hs : (c.work r).read = Ξ“.start := by rw [Tape.read, hhead]; exact hc0 + have hstep₁ := emitUnaryTM_step_back_start c hst hs hcr hinp hwork hout.parked + set c₁ : Cfg n (emitUnaryTM (n := n) r).Q := + { state := .park, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := c.output } with hc₁ + have hworkP : βˆ€ i, Parked (c₁.work i) := by + intro i + by_cases hir : i = r + Β· subst hir + show Parked (Function.update c.work i ((c.work i).move .right) i) + rw [Function.update_self] + exact ⟨by show (c.work i).head + 1 β‰₯ 1; omega, fun j hj => hcr j hj⟩ + Β· show Parked (Function.update c.work r ((c.work r).move .right) i) + rw [Function.update_of_ne hir] + exact hwork i hir + have hstepβ‚‚ := emitUnaryTM_step_park c₁ rfl hinp hworkP hout.parked + refine ⟨_, .step hstep₁ (.step hstepβ‚‚ .zero), rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· intro i hi + show Function.update c.work r ((c.work r).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· show (Function.update c.work r ((c.work r).move .right) r).cells = (c.work r).cells + rw [Function.update_self] + rfl + Β· show (Function.update c.work r ((c.work r).move .right) r).head = 1 + rw [Function.update_self] + show (c.work r).head + 1 = 1 + rw [hhead] + | succ h ih => + intro c ys hst hinp hwork hc0 hcr hhead hout + have hns : (c.work r).read β‰  Ξ“.start := by + rw [Tape.read, hhead]; exact hcr (h + 1) (by omega) + have hstep₁ := emitUnaryTM_step_back_left c hst hns hinp hwork hout.parked + set c₁ : Cfg n (emitUnaryTM (n := n) r).Q := + { state := .back, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } with hc₁ + have hupd_cells : (c₁.work r).cells = (c.work r).cells := by + show (Function.update c.work r ((c.work r).move .left) r).cells = _ + rw [Function.update_self] + rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih c₁ ys rfl hinp + (fun i hi => by + show Parked (Function.update c.work r ((c.work r).move .left) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + (by rw [hupd_cells]; exact hc0) + (fun j hj => by rw [hupd_cells]; exact hcr j hj) + (by + show (Function.update c.work r ((c.work r).move .left) r).head = h + rw [Function.update_self] + show (c.work r).head - 1 = h + rw [hhead] + omega) + hout + refine ⟨c', .step hstep₁ hreach, hst', hinp', ?_, ?_, hhead', hout'⟩ + Β· intro i hi + rw [hwork' i hi] + show Function.update c.work r ((c.work r).move .left) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [hcells', hupd_cells] + +/-- **`emitUnaryTM` Hoare specification.** Appends `2v` trues (the doubled + unary body of a literal with variable index `v`) to the output accumulator + in `3v + 3` steps, restoring all tapes exactly: the scanned register `r` + included. -/ +theorem emitUnaryTM_hoareTime (r : Fin n) (v : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (ys : List Bool) (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  r β†’ Parked (workβ‚€ i)) + (hreg : IsReg v (workβ‚€ r)) : + (emitUnaryTM (n := n) r).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ OutAcc ys out) + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ + OutAcc (ys ++ List.replicate (2 * v) true) out) + (3 * v + 3) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c₁, hreach₁, hst₁, hinp₁, hwork₁, hcells₁, hhead₁, houtβ‚βŸ© := + emitUnaryTM_emit_run v v 0 (by omega) + { state := .emitA, input := inp, work := work, output := out } ys rfl + hinpβ‚€ hworkβ‚€ (fun i hi => hreg.cells_one hi) (fun j hj => hreg.cells_blank hj) + (by show (work r).head = 0 + 1; rw [hreg.head_eq]) hout + have hinpP₁ : Parked c₁.input := by rw [hinp₁]; exact hinpβ‚€ + have hworkP₁ : βˆ€ i, i β‰  r β†’ Parked (c₁.work i) := fun i hi => by + rw [hwork₁ i hi] + exact hworkβ‚€ i hi + have hblank₁ : (c₁.work r).read = Ξ“.blank := by + rw [Tape.read, hhead₁, hcells₁] + exact hreg.cells_blank (le_refl _) + have hstepβ‚‚ := emitUnaryTM_step_emitA_blank c₁ hst₁ hblank₁ hinpP₁ hworkP₁ hout₁.parked + set cβ‚‚ : Cfg n (emitUnaryTM (n := n) r).Q := + { state := .back, input := c₁.input, + work := Function.update c₁.work r ((c₁.work r).move .left), + output := c₁.output } with hcβ‚‚ + have hupd_cellsβ‚‚ : (cβ‚‚.work r).cells = (work r).cells := by + show (Function.update c₁.work r ((c₁.work r).move .left) r).cells = _ + rw [Function.update_self] + show (c₁.work r).cells = _ + rw [hcells₁] + obtain ⟨c₃, hreach₃, hst₃, hinp₃, hwork₃, hcells₃, hhead₃, houtβ‚ƒβŸ© := + emitUnaryTM_back_run v cβ‚‚ (ys ++ List.replicate (2 * v) true) rfl hinpP₁ + (fun i hi => by + show Parked (Function.update c₁.work r ((c₁.work r).move .left) i) + rw [Function.update_of_ne hi] + exact hworkP₁ i hi) + (by rw [hupd_cellsβ‚‚]; exact hreg.cell0) + (fun j hj => by rw [hupd_cellsβ‚‚]; exact hreg.cells_ne_start hj) + (by + show (Function.update c₁.work r ((c₁.work r).move .left) r).head = v + rw [Function.update_self] + show (c₁.work r).head - 1 = v + rw [hhead₁] + omega) + hout₁ + refine ⟨c₃, 2 * v + ((v + 2) + 1), by omega, + reachesIn_trans _ hreach₁ (.step hstepβ‚‚ hreach₃), hst₃, ?_, ?_, ?_⟩ + Β· rw [hinp₃]; exact hinp₁ + Β· funext i + by_cases hir : i = r + Β· subst hir + refine Tape.ext ?_ ?_ + Β· rw [hhead₃, hreg.head_eq] + Β· rw [hcells₃, hupd_cellsβ‚‚] + Β· rw [hwork₃ i hir] + show Function.update c₁.work r ((c₁.work r).move .left) i = work i + rw [Function.update_of_ne hir] + exact hwork₁ i hir + Β· rw [hout₃] + exact hout₁ + +end EmitUnary + +-- ════════════════════════════════════════════════════════════════════════ +-- seqTM composition glue for ghost-parametrized emit specs +-- ════════════════════════════════════════════════════════════════════════ + +/-- The standard emit-spec shape: ghost-fixed input and work tapes, output + accumulator holding `ys`. -/ +def EmitPred (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) : TapePred n := + fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ OutAcc ys out + +/-- Emit-spec states pass through combinator phase boundaries unchanged: + parked ghosts and the accumulator are fixed points of + `transitionTape` / `transitionInput`. The `h_trans` obligation of + `seqTM_hoareTime` for any two composed emitters. -/ +theorem emitPred_transition {inpβ‚€ : Tape} {workβ‚€ : Fin n β†’ Tape} + (hinpβ‚€ : Parked inpβ‚€) (hworkAll : βˆ€ i, Parked (workβ‚€ i)) (ys : List Bool) : + βˆ€ inp work out, EmitPred inpβ‚€ workβ‚€ ys inp work out β†’ + EmitPred inpβ‚€ workβ‚€ ys (transitionInput inp) + (fun i => transitionTape (work i)) (transitionTape out) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + refine ⟨Parked.transitionInput_eq_self hinpβ‚€, ?_, ?_⟩ + Β· funext i + exact Parked.transitionTape_eq_self (hworkAll i) + Β· rw [Parked.transitionTape_eq_self hout.parked] + exact hout + +-- ════════════════════════════════════════════════════════════════════════ +-- emitLitTM: append one encoded literal +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Append one encoded literal** with sign `s` and variable index read from + register `r`: the bits `[s, s] ++ (2v trues) ++ [false, true]` + (= `doubleBits (Lit.encodeRaw ⟨s, v⟩) ++ [false, true]`, the form literals + take inside `Clause.encode`). -/ +def emitLitTM (s : Bool) (r : Fin n) : TM n := + seqTM (emitBitsTM [s, s]) (seqTM (emitUnaryTM r) (emitBitsTM [false, true])) + +/-- **`emitLitTM` Hoare specification.** Appends the encoded literal in + `3v + 9` steps, preserving the input and work tapes (the scanned register + included). The first `seqTM`-composed emitter spec; later emitters chain + the same way. -/ +theorem emitLitTM_hoareTime (s : Bool) (r : Fin n) (v : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) (hinpβ‚€ : Parked inpβ‚€) + (hworkβ‚€ : βˆ€ i, i β‰  r β†’ Parked (workβ‚€ i)) (hreg : IsReg v (workβ‚€ r)) : + (emitLitTM s r).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ workβ‚€ + (ys ++ ([s, s] ++ List.replicate (2 * v) true ++ [false, true]))) + (3 * v + 9) := by + have hworkAll : βˆ€ i, Parked (workβ‚€ i) := by + intro i + by_cases hir : i = r + Β· subst hir; exact hreg.parked + Β· exact hworkβ‚€ i hir + have h₂₃ := seqTM_hoareTime (emitUnaryTM r) (emitBitsTM [false, true]) + (emitUnaryTM_hoareTime r v inpβ‚€ workβ‚€ (ys ++ [s, s]) hinpβ‚€ hworkβ‚€ hreg) + (emitPred_transition hinpβ‚€ hworkAll _) + (emitBitsTM_hoareTime [false, true] inpβ‚€ workβ‚€ + (ys ++ [s, s] ++ List.replicate (2 * v) true) hinpβ‚€ hworkAll) + have h := seqTM_hoareTime (emitBitsTM [s, s]) + (seqTM (emitUnaryTM r) (emitBitsTM [false, true])) + (emitBitsTM_hoareTime [s, s] inpβ‚€ workβ‚€ ys hinpβ‚€ hworkAll) + (emitPred_transition hinpβ‚€ hworkAll _) + h₂₃ + refine h.consequence (fun _ _ _ hp => hp) ?_ (by simp; omega) + rintro inp work out ⟨rfl, rfl, hout⟩ + refine ⟨rfl, rfl, ?_⟩ + rwa [List.append_assoc (ys ++ [s, s]), List.append_assoc ys, + ← List.append_assoc [s, s]] at hout + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/EmitSeq.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/EmitSeq.lean new file mode 100644 index 0000000000..486aa849e1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/EmitSeq.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps + +/-! +# Sequencing emitter stages + +`bigSeqTM` folds a list of machines with `seqTM`, and `bigSeqTM_hoareTime` +chains their `EmitPred` specs: stage `k` carries the ghost state `(W k, Y k)` +to `(W (k+1), Y (k+1))`. All the finite-tuple folds of the reduction emitter +(literal chains, clause chains, the per-state/symbol/choice unrollings of the +transition family) are instances of this single rule. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Sequence a list of machines (right fold, `skipTM` base). -/ +def bigSeqTM : List (TM n) β†’ TM n + | [] => skipTM + | m :: ms => seqTM m (bigSeqTM ms) + +/-- **Indexed chain rule.** Machine `ms[k]` carries the `EmitPred` state from + stage `k` to stage `k + 1`; the fold carries stage `0` to stage + `ms.length`, in `|ms| Β· (b + 1) + 1` steps. -/ +theorem bigSeqTM_hoareTime (ms : List (TM n)) (inpβ‚€ : Tape) + (W : β„• β†’ Fin n β†’ Tape) (Y : β„• β†’ List Bool) (b : β„•) + (hinpβ‚€ : Parked inpβ‚€) + (hWP : βˆ€ k j, Parked (W k j)) + (hms : βˆ€ k, (hk : k < ms.length) β†’ ms[k].HoareTime + (EmitPred inpβ‚€ (W k) (Y k)) (EmitPred inpβ‚€ (W (k + 1)) (Y (k + 1))) b) : + (bigSeqTM ms).HoareTime + (EmitPred inpβ‚€ (W 0) (Y 0)) + (EmitPred inpβ‚€ (W ms.length) (Y ms.length)) + (ms.length * (b + 1) + 1) := by + induction ms generalizing W Y with + | nil => + exact (skipTM_hoareTime inpβ‚€ (W 0) (Y 0) hinpβ‚€ (hWP 0)).mono_bound (by omega) + | cons m ms ih => + have hhead := hms 0 (by simp) + have hrest := ih (fun k => W (k + 1)) (fun k => Y (k + 1)) + (fun k j => hWP (k + 1) j) + (fun k hk => by + have h := hms (k + 1) (by simpa using Nat.succ_lt_succ hk) + simpa using h) + have hseq := seqTM_hoareTime m (bigSeqTM ms) hhead + (emitPred_transition hinpβ‚€ (hWP 1) (Y 1)) hrest + refine hseq.consequence (fun _ _ _ h => h) (fun _ _ _ h => ?_) ?_ + Β· show EmitPred inpβ‚€ (W (m :: ms).length) (Y (m :: ms).length) _ _ _ + rw [List.length_cons] + exact h + Β· rw [List.length_cons] + have hmul : (ms.length + 1) * (b + 1) = ms.length * (b + 1) + (b + 1) := + Nat.succ_mul .. + omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/ForReg.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/ForReg.lean new file mode 100644 index 0000000000..181bf11191 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/ForReg.lean @@ -0,0 +1,522 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Emit + +/-! +# forRegTM: the register-fueled loop combinator + +`forRegTM body r` runs `body` once per mark of register `r`. The fuel is the +*head position* on `r`: the register's cells are never written; the test reads +the cell under the head β€” a mark means "iterate" (consume = move right, run +the body), the first blank means "exit" (rewind `r` to cell 1 and halt). The +body must leave `r` untouched (our ghost-style specs guarantee this for free, +since bodies preserve every non-target tape literally). + +This is the only loop mechanism of the reduction emitter +(`docs/A5-ReductionEmitter.md`): unlike `loopTM`, its test reads a *work* +tape, so the output tape remains an append-only accumulator throughout. + +The Hoare rule `forRegTM_hoareTime` threads an iteration-indexed family of +ghost work-tape functions and output words through the loop. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Driver phases of `forRegTM`: `test` reads the fuel register's cell (mark = iterate, + blank = exit), `rewind` returns the register head to cell 1, `done` is the halt state. -/ +inductive ForPhase where + | test | rewind | done + deriving DecidableEq + +/-- `ForPhase` is a finite type (it has exactly three constructors). -/ +instance : Fintype ForPhase where + elems := {.test, .rewind, .done} + complete := fun x => by cases x <;> simp + +/-- **Register-fueled loop**: run `body` once per mark of register `r`. + States: the driver phases on the left, the body's states on the right. -/ +def forRegTM (body : TM n) (r : Fin n) : TM n where + Q := ForPhase βŠ• body.Q + qstart := .inl .test + qhalt := .inl .done + Ξ΄ := fun s iHead wHeads oHead => + match s with + | .inl .test => + if wHeads r = Ξ“.one then + (.inr body.qstart, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = r then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.inl .rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = r then (if wHeads r = Ξ“.start then Dir3.right else Dir3.left) + else idleDir (wHeads i), + idleDir oHead) + | .inl .rewind => + if wHeads r = Ξ“.start then + (.inl .done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = r then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.inl .rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = r then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .inl .done => allIdle s iHead wHeads oHead + | .inr q => + if q = body.qhalt then + (.inl .test, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + ((Sum.inr (body.Ξ΄ q iHead wHeads oHead).1 : ForPhase βŠ• body.Q), + (body.Ξ΄ q iHead wHeads oHead).2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.2.1, + (body.Ξ΄ q iHead wHeads oHead).2.2.2.2.2) + Ξ΄_right_of_start := by + intro s iHead wHeads oHead + match s with + | .inl .test => + dsimp only [] + split + Β· next hone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; rw [hone] at hi; exact absurd hi (by decide) + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hnone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; rw [ite_eq_left rfl, ite_eq_left hi] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .inl .rewind => + dsimp only [] + split + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hns => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = r + Β· subst hir; exact absurd hi hns + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr q => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact body.Ξ΄_right_of_start q iHead wHeads oHead + +section ForReg + +variable {body : TM n} {r : Fin n} + +/-- Retag a body configuration as a composite configuration. -/ +private def wrapCfg (body : TM n) (r : Fin n) (c : Cfg n body.Q) : + Cfg n (forRegTM body r).Q := + { state := .inr c.state, input := c.input, work := c.work, output := c.output } + +/-- Body steps lift to composite steps. -/ +private theorem forRegTM_lift_step (c c' : Cfg n body.Q) + (hstep : body.step c = some c') : + (forRegTM body r).step (wrapCfg body r c) = some (wrapCfg body r c') := by + have hne : Β¬ c.state = body.qhalt := by + intro h + rw [TM.step, ite_eq_left h] at hstep + simp at hstep + rw [TM.step, ite_eq_right hne] at hstep + rw [TM.step, ite_eq_right (show Β¬ (wrapCfg body r c).state = (forRegTM body r).qhalt from + by simp [wrapCfg, forRegTM])] + simp only [wrapCfg, forRegTM, hne, ↓reduceIte] + revert hstep + generalize body.Ξ΄ c.state c.input.read (fun i => (c.work i).read) c.output.read = bd + obtain ⟨q', ww, ow, iD, wD, oD⟩ := bd + intro hstep + cases Option.some.inj hstep + rfl + +private theorem forRegTM_ne_halt {s : ForPhase βŠ• body.Q} (h : s β‰  .inl .done) + {c : Cfg n (forRegTM body r).Q} (hst : c.state = s) : + Β¬ c.state = (forRegTM body r).qhalt := by + rw [hst] + show Β¬ s = Sum.inl ForPhase.done + exact h + +/-- `test` over a mark: consume it (register head right) and enter the body. -/ +private theorem forRegTM_step_test_one (c : Cfg n (forRegTM body r).Q) + (hst : c.state = .inl .test) (hone : (c.work r).read = Ξ“.one) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (forRegTM body r).step c = some + { state := .inr body.qstart, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := c.output } := by + rw [TM.step, ite_eq_right (forRegTM_ne_halt (by simp) hst)] + simp only [forRegTM, hst, hone, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hone]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `test` at the first blank: exit toward the rewind. -/ +private theorem forRegTM_step_test_blank (c : Cfg n (forRegTM body r).Q) + (hst : c.state = .inl .test) (hblank : (c.work r).read = Ξ“.blank) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (forRegTM body r).step c = some + { state := .inl .rewind, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (forRegTM_ne_halt (by simp) hst)] + simp only [forRegTM, hst, hblank, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + simp only [↓reduceIte, Function.update_self] + rw [writeAndMove_readBack _ (by rw [hblank]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `rewind` off the sentinel: keep rewinding. -/ +private theorem forRegTM_step_rewind_left (c : Cfg n (forRegTM body r).Q) + (hst : c.state = .inl .rewind) (hns : (c.work r).read β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (forRegTM body r).step c = some + { state := .inl .rewind, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (forRegTM_ne_halt (by simp) hst)] + simp only [forRegTM, hst, hns, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, writeAndMove_readBack _ hns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `rewind` on the sentinel: step right to cell 1 and halt. -/ +private theorem forRegTM_step_rewind_start (c : Cfg n (forRegTM body r).Q) + (hst : c.state = .inl .rewind) (hs : (c.work r).read = Ξ“.start) + (hcr : βˆ€ j, 1 ≀ j β†’ (c.work r).cells j β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  r β†’ Parked (c.work i)) + (hout : Parked c.output) : + (forRegTM body r).step c = some + { state := .inl .done, input := c.input, + work := Function.update c.work r ((c.work r).move .right), + output := c.output } := by + have h0 : (c.work r).head = 0 := by + by_contra hc + exact hcr _ (by omega) hs + rw [TM.step, ite_eq_right (forRegTM_ne_halt (by simp) hst)] + simp only [forRegTM, hst, hs, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = r + Β· subst hir + rw [ite_eq_left rfl, Function.update_self] + show ((c.work i).write _).move Dir3.right = (c.work i).move .right + congr 1 + rw [Tape.write, ite_eq_left h0] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The body has halted: one idle step loops back to the test. -/ +private theorem forRegTM_step_loopback (c : Cfg n (forRegTM body r).Q) + (hst : c.state = .inr body.qhalt) + (hinp : Parked c.input) (hwork : βˆ€ i, Parked (c.work i)) + (hout : Parked c.output) : + (forRegTM body r).step c = some + { state := .inl .test, input := c.input, work := c.work, + output := c.output } := by + rw [TM.step, ite_eq_right (forRegTM_ne_halt (by simp) hst)] + simp only [forRegTM, hst, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The rewind loop: from `rewind` at head `h`, halt parked at cell 1 in + `h + 1` steps. -/ +private theorem forRegTM_rewind_run (h : β„•) : + βˆ€ (c : Cfg n (forRegTM body r).Q), + c.state = .inl .rewind β†’ Parked c.input β†’ (βˆ€ i, i β‰  r β†’ Parked (c.work i)) β†’ + Parked c.output β†’ + (c.work r).cells 0 = Ξ“.start β†’ + (βˆ€ j, 1 ≀ j β†’ (c.work r).cells j β‰  Ξ“.start) β†’ + (c.work r).head = h β†’ + βˆƒ c', (forRegTM body r).reachesIn (h + 1) c c' ∧ + c'.state = .inl .done ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  r β†’ c'.work i = c.work i) ∧ + (c'.work r).cells = (c.work r).cells ∧ (c'.work r).head = 1 ∧ + c'.output = c.output := by + induction h with + | zero => + intro c hst hinp hwork hout hc0 hcr hhead + have hs : (c.work r).read = Ξ“.start := by rw [Tape.read, hhead]; exact hc0 + have hstep := forRegTM_step_rewind_start c hst hs hcr hinp hwork hout + refine ⟨_, .step hstep .zero, rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· intro i hi + show Function.update c.work r ((c.work r).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· show (Function.update c.work r ((c.work r).move .right) r).cells = _ + rw [Function.update_self] + rfl + Β· show (Function.update c.work r ((c.work r).move .right) r).head = 1 + rw [Function.update_self] + show (c.work r).head + 1 = 1 + rw [hhead] + | succ h ih => + intro c hst hinp hwork hout hc0 hcr hhead + have hns : (c.work r).read β‰  Ξ“.start := by + rw [Tape.read, hhead]; exact hcr (h + 1) (by omega) + have hstep := forRegTM_step_rewind_left c hst hns hinp hwork hout + have hupd : (Function.update c.work r ((c.work r).move .left) r).cells + = (c.work r).cells := by + rw [Function.update_self] + rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih { state := .inl .rewind, input := c.input, + work := Function.update c.work r ((c.work r).move .left), + output := c.output } rfl hinp + (fun i hi => by + show Parked (Function.update c.work r ((c.work r).move .left) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by rw [hupd]; exact hc0) + (fun j hj => by rw [hupd]; exact hcr j hj) + (by + show (Function.update c.work r ((c.work r).move .left) r).head = h + rw [Function.update_self] + show (c.work r).head - 1 = h + rw [hhead] + omega) + refine ⟨c', .step hstep hreach, hst', hinp', ?_, ?_, hhead', hout'⟩ + Β· intro i hi + rw [hwork' i hi] + show Function.update c.work r ((c.work r).move .left) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [hcells', hupd] + +/-- The iteration loop: from the `i`-th test entry, run the remaining `m` + iterations and the exit rewind. -/ +private theorem forRegTM_loop_run (inpβ‚€ : Tape) (w : β„• β†’ Fin n β†’ Tape) + (ys : β„• β†’ List Bool) (b_iter v : β„•) + (hinpβ‚€ : Parked inpβ‚€) + (hwP : βˆ€ i j, j β‰  r β†’ Parked (w i j)) + (hbody : βˆ€ i, i < v β†’ body.HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w i) r ⟨i + 2, regCells v⟩ ∧ OutAcc (ys i) out) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w (i + 1)) r ⟨i + 2, regCells v⟩ ∧ + OutAcc (ys (i + 1)) out) + b_iter) : + βˆ€ (m i : β„•), v = i + m β†’ + βˆ€ c : Cfg n (forRegTM body r).Q, + c.state = .inl .test β†’ c.input = inpβ‚€ β†’ + c.work = Function.update (w i) r ⟨i + 1, regCells v⟩ β†’ + OutAcc (ys i) c.output β†’ + βˆƒ c' t, t ≀ m * (b_iter + 2) + (v + 2) ∧ + (forRegTM body r).reachesIn t c c' ∧ + c'.state = .inl .done ∧ c'.input = inpβ‚€ ∧ + c'.work = Function.update (w v) r (regTape v) ∧ + OutAcc (ys v) c'.output := by + intro m + induction m with + | zero => + intro i hi c hst hcin hcw hout + obtain rfl : v = i := by omega + have hcwr : c.work r = ⟨v + 1, regCells v⟩ := by + rw [hcw, Function.update_self] + have hblank : (c.work r).read = Ξ“.blank := by + rw [hcwr] + show regCells v (v + 1) = Ξ“.blank + exact regCells_blank (le_refl _) + have hworkP : βˆ€ j, j β‰  r β†’ Parked (c.work j) := by + intro j hj + rw [hcw, Function.update_of_ne hj] + exact hwP v j hj + have hinpP : Parked c.input := by rw [hcin]; exact hinpβ‚€ + have hstep₁ := forRegTM_step_test_blank c hst hblank hinpP hworkP hout.parked + have hw₁ : Function.update c.work r ((c.work r).move .left) + = Function.update (w v) r ⟨v, regCells v⟩ := by + rw [hcwr, hcw, Function.update_idem] + rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + forRegTM_rewind_run (body := body) v + { state := .inl .rewind, input := c.input, + work := Function.update (w v) r ⟨v, regCells v⟩, output := c.output } + rfl hinpP + (fun j hj => by + show Parked (Function.update (w v) r (⟨v, regCells v⟩ : Tape) j) + rw [Function.update_of_ne hj] + exact hwP v j hj) + hout.parked + (by + show (Function.update (w v) r (⟨v, regCells v⟩ : Tape) r).cells 0 = Ξ“.start + rw [Function.update_self] + rfl) + (fun j hj => by + show (Function.update (w v) r (⟨v, regCells v⟩ : Tape) r).cells j β‰  Ξ“.start + rw [Function.update_self] + show regCells v j β‰  Ξ“.start + rw [regCells, ite_eq_right (by omega)] + split <;> decide) + (by + show (Function.update (w v) r (⟨v, regCells v⟩ : Tape) r).head = v + rw [Function.update_self]) + have hb0 : (v + 1) + 1 ≀ 0 * (b_iter + 2) + (v + 2) := by omega + refine ⟨c', (v + 1) + 1, hb0, .step hstep₁ ?_, hst', ?_, ?_, ?_⟩ + Β· rw [hw₁] + exact hreach + Β· rw [hinp'] + show c.input = inpβ‚€ + exact hcin + Β· funext j + by_cases hjr : j = r + Β· subst hjr + rw [Function.update_self] + refine Tape.ext ?_ ?_ + Β· rw [hhead'] + rfl + Β· rw [hcells'] + show (Function.update (w v) j (⟨v, regCells v⟩ : Tape) j).cells = _ + rw [Function.update_self, regT_cells] + Β· rw [hwork' j hjr, Function.update_of_ne hjr] + show Function.update (w v) r (⟨v, regCells v⟩ : Tape) j = w v j + rw [Function.update_of_ne hjr] + Β· rw [hout'] + exact hout + | succ m ih => + intro i hi c hst hcin hcw hout + have hcwr : c.work r = ⟨i + 1, regCells v⟩ := by + rw [hcw, Function.update_self] + have hone : (c.work r).read = Ξ“.one := by + rw [hcwr] + show regCells v (i + 1) = Ξ“.one + exact regCells_one (by omega) (by omega) + have hworkP : βˆ€ j, j β‰  r β†’ Parked (c.work j) := by + intro j hj + rw [hcw, Function.update_of_ne hj] + exact hwP i j hj + have hinpP : Parked c.input := by rw [hcin]; exact hinpβ‚€ + have hstep₁ := forRegTM_step_test_one c hst hone hinpP hworkP hout.parked + have hw₁ : Function.update c.work r ((c.work r).move .right) + = Function.update (w i) r ⟨i + 2, regCells v⟩ := by + rw [hcwr, hcw, Function.update_idem] + rfl + obtain ⟨cb, tb, htb, hbreach, hbhalt, hbinp, hbwork, hbout⟩ := + hbody i (by omega) inpβ‚€ (Function.update (w i) r ⟨i + 2, regCells v⟩) c.output + ⟨rfl, rfl, hout⟩ + have hlift := reachesIn_map (wrapCfg body r) + (fun a b h => forRegTM_lift_step a b h) hbreach + have hbworkP : βˆ€ j, Parked (cb.work j) := by + intro j + rw [hbwork] + by_cases hjr : j = r + Β· subst hjr + rw [Function.update_self] + refine ⟨by show (1 : β„•) ≀ i + 2; omega, fun p hp => ?_⟩ + show regCells v p β‰  Ξ“.start + rw [regCells, ite_eq_right (by omega)] + split <;> decide + Β· rw [Function.update_of_ne hjr] + exact hwP (i + 1) j hjr + have hstepβ‚‚ := forRegTM_step_loopback (wrapCfg body r cb) + (by show Sum.inr cb.state = Sum.inr body.qhalt; rw [hbhalt]) + (by show Parked cb.input; rw [hbinp]; exact hinpβ‚€) + (fun j => hbworkP j) + (by show Parked cb.output; exact hbout.parked) + obtain ⟨c', t', ht', hreach', hst', hinp', hwork', hout'⟩ := + ih (i + 1) (by omega) + { state := .inl .test, input := inpβ‚€, + work := Function.update (w (i + 1)) r ⟨i + 2, regCells v⟩, + output := cb.output } + rfl rfl rfl hbout + have hbS : tb + (t' + 1) + 1 ≀ (m + 1) * (b_iter + 2) + (v + 2) := by + have hmul : (m + 1) * (b_iter + 2) = m * (b_iter + 2) + (b_iter + 2) := + Nat.succ_mul .. + omega + refine ⟨c', tb + (t' + 1) + 1, hbS, .step hstep₁ ?_, hst', hinp', hwork', hout'⟩ + rw [hw₁, hcin] + refine reachesIn_trans _ hlift (.step hstepβ‚‚ ?_) + rw [show (⟨.inl .test, (wrapCfg body r cb).input, (wrapCfg body r cb).work, + (wrapCfg body r cb).output⟩ : Cfg n (forRegTM body r).Q) + = ⟨.inl .test, inpβ‚€, Function.update (w (i + 1)) r ⟨i + 2, regCells v⟩, + cb.output⟩ from by + simp only [wrapCfg] + rw [hbinp, hbwork]] + exact hreach' + +/-- **`forRegTM` Hoare rule.** Given a fuel register holding `v` (whose tape the + iteration-indexed ghost family `w` never changes) and a body spec carrying + `w i / ys i` to `w (i+1) / ys (i+1)`, the loop carries `w 0 / ys 0` to + `w v / ys v` in at most `vΒ·(b_iter + 2) + v + 3` steps. -/ +theorem forRegTM_hoareTime (body : TM n) (r : Fin n) (v : β„•) (inpβ‚€ : Tape) + (w : β„• β†’ Fin n β†’ Tape) (ys : β„• β†’ List Bool) (b_iter : β„•) + (hinpβ‚€ : Parked inpβ‚€) + (hwreg : βˆ€ i, w i r = regTape v) + (hwP : βˆ€ i j, j β‰  r β†’ Parked (w i j)) + (hbody : βˆ€ i, i < v β†’ body.HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w i) r ⟨i + 2, regCells v⟩ ∧ OutAcc (ys i) out) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w (i + 1)) r ⟨i + 2, regCells v⟩ ∧ + OutAcc (ys (i + 1)) out) + b_iter) : + (forRegTM body r).HoareTime + (EmitPred inpβ‚€ (w 0) (ys 0)) + (EmitPred inpβ‚€ (w v) (ys v)) + (v * (b_iter + 2) + (v + 2)) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c', t, ht, hreach, hst', hinp', hwork', hout'⟩ := + forRegTM_loop_run inp w ys b_iter v hinpβ‚€ hwP hbody v 0 (by omega) + { state := .inl .test, input := inp, work := w 0, output := out } + rfl rfl + (by + show w 0 = Function.update (w 0) r ⟨0 + 1, regCells v⟩ + rw [show (⟨0 + 1, regCells v⟩ : Tape) = w 0 r from by rw [hwreg 0]; rfl, + Function.update_eq_self]) + hout + refine ⟨c', t, ht, hreach, hst', hinp', ?_, hout'⟩ + rw [hwork', show regTape v = w v r from (hwreg v).symm, Function.update_eq_self] + +end ForReg + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Horner.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Horner.lean new file mode 100644 index 0000000000..9e1587c3d7 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/Horner.lean @@ -0,0 +1,610 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import Mathlib.Algebra.Polynomial.Eval.Defs +public import Mathlib.Algebra.Polynomial.Eval.Degree +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Arith + +/-! +# Horner layers: polynomial register evaluation + +The reduction emitter's variable indices are mixed-radix numerals +(`flatVar`), and its time budget is `p.eval n` β€” both are computed by +iterating the single **Horner layer** `tmp := tmp Β· X + c` over unary +registers. This file builds that layer from the `Arith` register calculus +and folds it into `polyEvalTM`. + +To keep the time accounting sane across long `seqTM` chains, every stage +bound is rounded up to the single monotone budget `opBudget M`, where `M` +bounds every register value in play. Only the polynomial shape of the final +bound matters (`FP` quantifies the degree existentially), so all budgets +are deliberately loose. + +## Main definitions + +- `TM.opBudget` β€” the uniform per-operation time budget +- `TM.setConstTM` β€” `q := c` +- `TM.hornerLayerRegTM` β€” `tmp := tmp Β· X + comp` (register addend) +- `TM.hornerLayerConstTM` β€” `tmp := tmp Β· X + c` (constant addend) + +## Main results + +- the `_hoareTime` specification of each machine +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- The uniform operation budget +-- ════════════════════════════════════════════════════════════════════════ + +/-- One budget bounds every register operation whose values are at most `M`: + increments, clears, copies, additions, multiply-accumulates, and literal + emissions. Cubic in `M` because `mulAddIntoTM`'s bound is (product value) + Γ— (per-mark sweep length). -/ +def opBudget (M : β„•) : β„• := 32 * ((M + 2) * (M + 2) * (M + 2)) + +/-- Anything at most quadratic in `M + 2` (with constant `6`) fits in `opBudget M`. -/ +theorem le_opBudget_of_le {a M : β„•} (h : a ≀ 6 * (M + 2) * (M + 2)) : + a ≀ opBudget M := by + refine le_trans h ?_ + rw [opBudget] + have h2 : 2 ≀ M + 2 := by omega + calc 6 * (M + 2) * (M + 2) = 6 * ((M + 2) * (M + 2)) := by ring + _ ≀ 32 * ((M + 2) * ((M + 2) * (M + 2))) := by + have : (M + 2) * (M + 2) ≀ (M + 2) * ((M + 2) * (M + 2)) := + Nat.le_mul_of_pos_left _ (by omega) + omega + _ = 32 * ((M + 2) * (M + 2) * (M + 2)) := by ring + +/-- `incRegTM` fits the budget. -/ +theorem incRegTM_le_opBudget {d M : β„•} (h : d ≀ M) : 2 * d + 4 ≀ opBudget M := + le_opBudget_of_le (by nlinarith) + +/-- `clearRegTM` fits the budget. -/ +theorem clearRegTM_le_opBudget {d M : β„•} (h : d ≀ M) : 2 * d + 4 ≀ opBudget M := + incRegTM_le_opBudget h + +/-- `skipTM` fits the budget. -/ +theorem one_le_opBudget {M : β„•} : 1 ≀ opBudget M := + le_opBudget_of_le (by nlinarith) + +/-- `addIntoTM` fits the budget. -/ +theorem addIntoTM_le_opBudget {a b M : β„•} (ha : a ≀ M) (hab : b + a ≀ M) : + a * ((2 * (b + a) + 4) + 2) + (a + 2) ≀ opBudget M := by + refine le_opBudget_of_le ?_ + have h1 : a * ((2 * (b + a) + 4) + 2) ≀ M * (2 * M + 6) := + Nat.mul_le_mul ha (by omega) + nlinarith + +/-- `iterTM (incRegTM q) c` fits the budget. -/ +theorem iterTM_incRegTM_le_opBudget {c d M : β„•} (h : d + c ≀ M) : + c * (2 * (d + c) + 5) + 1 ≀ opBudget M := by + refine le_opBudget_of_le ?_ + have h1 : c * (2 * (d + c) + 5) ≀ M * (2 * M + 5) := + Nat.mul_le_mul (by omega) (by omega) + nlinarith + +/-- `copyIntoTM` fits the budget. -/ +theorem copyIntoTM_le_opBudget {a b M : β„•} (ha : a ≀ M) (hb : b ≀ M) : + (2 * b + 4) + 1 + (a * ((2 * (0 + a) + 4) + 2) + (a + 2)) ≀ opBudget M := by + refine le_opBudget_of_le ?_ + have h1 : a * ((2 * (0 + a) + 4) + 2) ≀ M * (2 * M + 6) := + Nat.mul_le_mul ha (by omega) + nlinarith + +/-- `setConstTM` fits the budget. -/ +theorem setConstTM_le_opBudget {c d M : β„•} (hc : c ≀ M) (hd : d ≀ M) : + (2 * d + 4) + 1 + (c * (2 * c + 5) + 1) ≀ opBudget M := by + refine le_opBudget_of_le ?_ + have h1 : c * (2 * c + 5) ≀ M * (2 * M + 5) := Nat.mul_le_mul hc (by omega) + nlinarith + +/-- `emitLitTM` fits the budget. -/ +theorem emitLitTM_le_opBudget {v M : β„•} (h : v ≀ M) : 3 * v + 9 ≀ opBudget M := + le_opBudget_of_le (by nlinarith) + +/-- `mulAddIntoTM` fits the budget, provided the accumulated product stays + below `M`. -/ +theorem mulAddIntoTM_le_opBudget {a b d M : β„•} (ha : a ≀ M) (hb : b ≀ M) + (hd : d + a * b ≀ M) : + a * (mulAddBound a b d + 2) + (a + 2) ≀ opBudget M := by + have h1 : mulAddBound a b d ≀ M * (4 * M + 10) + (M + 2) := by + rw [mulAddBound] + exact Nat.add_le_add (Nat.mul_le_mul hb (by omega)) (by omega) + have h2 : a * (mulAddBound a b d + 2) + (a + 2) + ≀ M * ((M * (4 * M + 10) + (M + 2)) + 2) + (M + 2) := + Nat.add_le_add (Nat.mul_le_mul ha (by omega)) (by omega) + refine le_trans h2 ?_ + rw [opBudget] + nlinarith + +-- ════════════════════════════════════════════════════════════════════════ +-- setConstTM: load a constant into a register +-- ════════════════════════════════════════════════════════════════════════ + +/-- `q := c` (clear, then increment `c` times). -/ +def setConstTM (q : Fin n) (c : β„•) : TM n := + seqTM (clearRegTM q) (iterTM (incRegTM q) c) + +/-- **`setConstTM` Hoare specification.** -/ +theorem setConstTM_hoareTime (q : Fin n) (c d : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) + (hq : workβ‚€ q = regTape d) : + (setConstTM q c).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ q (regTape c)) ys) + ((2 * d + 4) + 1 + (c * (2 * c + 5) + 1)) := by + have hclear := clearRegTM_hoareTime q d inpβ‚€ workβ‚€ ys hinpβ‚€ + (fun i _ => hworkβ‚€ i) hq + have hmidP : βˆ€ i, Parked (Function.update workβ‚€ q (regTape 0) i) := by + intro i + by_cases hiq : i = q + Β· subst hiq; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hiq]; exact hworkβ‚€ i + have hiter := iterTM_incRegTM_hoareTime q c 0 inpβ‚€ (Function.update workβ‚€ q (regTape 0)) + ys hinpβ‚€ hmidP (by rw [Function.update_self]) + have hseq := seqTM_hoareTime (clearRegTM q) (iterTM (incRegTM q) c) hclear + (emitPred_transition hinpβ‚€ hmidP ys) hiter + refine hseq.consequence (fun _ _ _ h => h) ?_ + (by simp only [Nat.zero_add]; exact le_refl _) + rintro inp work out ⟨h1, h2, h3⟩ + refine ⟨h1, ?_, h3⟩ + rw [h2, Function.update_idem, Nat.zero_add] + +-- ════════════════════════════════════════════════════════════════════════ +-- Horner layers: tmp := tmp Β· X + addend +-- ════════════════════════════════════════════════════════════════════════ + +/-- One Horner layer with a **register** addend: + `tmp := tmp Β· X + comp` (scratch `tmp2` ends holding the same value). -/ +def hornerLayerRegTM (X comp tmp tmp2 : Fin n) : TM n := + seqTM (clearRegTM tmp2) + (seqTM (mulAddIntoTM tmp X tmp2) + (seqTM (addIntoTM comp tmp2) (copyIntoTM tmp2 tmp))) + +/-- One Horner layer with a **constant** addend: + `tmp := tmp Β· X + c` (scratch `tmp2` ends holding the same value). -/ +def hornerLayerConstTM (X tmp tmp2 : Fin n) (c : β„•) : TM n := + seqTM (clearRegTM tmp2) + (seqTM (mulAddIntoTM tmp X tmp2) + (seqTM (iterTM (incRegTM tmp2) c) (copyIntoTM tmp2 tmp))) + +/-- The (uniform) time budget of one Horner layer. -/ +def layerBudget (M : β„•) : β„• := 4 * opBudget M + 3 + +section HornerLayer + +variable {X comp tmp tmp2 : Fin n} + +/-- **`hornerLayerRegTM` Hoare specification.** From `tmp = v`, `X = x`, + `comp = w` (and any `tmp2 = u`), reach `tmp = tmp2 = vΒ·x + w` with all + other tapes untouched, within `layerBudget M` steps, provided every value + in play is at most `M`. -/ +theorem hornerLayerRegTM_hoareTime + (hXt : X β‰  tmp) (hXt2 : X β‰  tmp2) (htt2 : tmp β‰  tmp2) + (hct2 : comp β‰  tmp2) + (M x v w u : β„•) (hx : x ≀ M) (hv : v ≀ M) (hu : u ≀ M) + (hres : v * x + w ≀ M) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) + (hX : workβ‚€ X = regTape x) (hc : workβ‚€ comp = regTape w) + (ht : workβ‚€ tmp = regTape v) (ht2 : workβ‚€ tmp2 = regTape u) : + (hornerLayerRegTM X comp tmp tmp2).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ + (Function.update (Function.update workβ‚€ tmp2 (regTape (v * x + w))) tmp + (regTape (v * x + w))) ys) + (layerBudget M) := by + set A : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape 0) with hA + set B : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape (v * x)) with hB + set C : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape (v * x + w)) with hC + have hAP : βˆ€ i, Parked (A i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hA, Function.update_self]; exact parked_regTape _ + Β· rw [hA, Function.update_of_ne hi]; exact hworkβ‚€ i + have hBP : βˆ€ i, Parked (B i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hB, Function.update_self]; exact parked_regTape _ + Β· rw [hB, Function.update_of_ne hi]; exact hworkβ‚€ i + have hCP : βˆ€ i, Parked (C i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hC, Function.update_self]; exact parked_regTape _ + Β· rw [hC, Function.update_of_ne hi]; exact hworkβ‚€ i + -- Stage 1: clear tmp2. + have h₁ : (clearRegTM tmp2).HoareTime (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ A ys) (opBudget M) := + (clearRegTM_hoareTime tmp2 u inpβ‚€ workβ‚€ ys hinpβ‚€ + (fun i _ => hworkβ‚€ i) ht2).mono_bound (clearRegTM_le_opBudget hu) + -- Stage 2: tmp2 += tmp Β· X. + have hβ‚‚ : (mulAddIntoTM tmp X tmp2).HoareTime (EmitPred inpβ‚€ A ys) + (EmitPred inpβ‚€ B ys) (opBudget M) := by + refine (mulAddIntoTM_hoareTime tmp X tmp2 (fun h => hXt h.symm) htt2 hXt2 + v x 0 inpβ‚€ A ys hinpβ‚€ (fun i _ => hAP i) + (by rw [hA, Function.update_of_ne htt2]; exact ht) + (by rw [hA, Function.update_of_ne hXt2]; exact hX) + (by rw [hA, Function.update_self])).consequence + (fun _ _ _ h => h) ?_ (mulAddIntoTM_le_opBudget hv hx (by omega)) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hA, Function.update_idem, Nat.zero_add, hB] + -- Stage 3: tmp2 += comp. + have h₃ : (addIntoTM comp tmp2).HoareTime (EmitPred inpβ‚€ B ys) + (EmitPred inpβ‚€ C ys) (opBudget M) := by + refine (addIntoTM_hoareTime comp tmp2 hct2 w (v * x) inpβ‚€ B ys hinpβ‚€ + (fun i _ => hBP i) + (by rw [hB, Function.update_of_ne hct2]; exact hc) + (by rw [hB, Function.update_self])).consequence + (fun _ _ _ h => h) ?_ (addIntoTM_le_opBudget (by omega) hres) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hB, Function.update_idem, hC] + -- Stage 4: tmp := tmp2. + have hβ‚„ : (copyIntoTM tmp2 tmp).HoareTime (EmitPred inpβ‚€ C ys) + (EmitPred inpβ‚€ (Function.update C tmp (regTape (v * x + w))) ys) + (opBudget M) := by + refine (copyIntoTM_hoareTime tmp2 tmp (fun h => htt2 h.symm) (v * x + w) v + inpβ‚€ C ys hinpβ‚€ (fun i _ => hCP i) + (by rw [hC, Function.update_self]) + (by rw [hC, Function.update_of_ne htt2]; exact ht)).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (copyIntoTM_le_opBudget hres hv) + -- Glue. + have h₃₄ := seqTM_hoareTime (addIntoTM comp tmp2) (copyIntoTM tmp2 tmp) h₃ + (emitPred_transition hinpβ‚€ hCP ys) hβ‚„ + have h₂₃₄ := seqTM_hoareTime (mulAddIntoTM tmp X tmp2) _ hβ‚‚ + (emitPred_transition hinpβ‚€ hBP ys) h₃₄ + have h := seqTM_hoareTime (clearRegTM tmp2) _ h₁ + (emitPred_transition hinpβ‚€ hAP ys) h₂₃₄ + refine h.consequence (fun _ _ _ hp => hp) ?_ (by rw [layerBudget]; omega) + rintro inp work out ⟨g1, g2, g3⟩ + exact ⟨g1, by rw [g2, hC], g3⟩ + +/-- **`hornerLayerConstTM` Hoare specification.** From `tmp = v`, `X = x` + (and any `tmp2 = u`), reach `tmp = tmp2 = vΒ·x + c`. -/ +theorem hornerLayerConstTM_hoareTime + (hXt : X β‰  tmp) (hXt2 : X β‰  tmp2) (htt2 : tmp β‰  tmp2) + (M x v c u : β„•) (hx : x ≀ M) (hv : v ≀ M) (hu : u ≀ M) + (hres : v * x + c ≀ M) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) + (hX : workβ‚€ X = regTape x) + (ht : workβ‚€ tmp = regTape v) (ht2 : workβ‚€ tmp2 = regTape u) : + (hornerLayerConstTM X tmp tmp2 c).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ + (Function.update (Function.update workβ‚€ tmp2 (regTape (v * x + c))) tmp + (regTape (v * x + c))) ys) + (layerBudget M) := by + set A : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape 0) with hA + set B : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape (v * x)) with hB + set C : Fin n β†’ Tape := Function.update workβ‚€ tmp2 (regTape (v * x + c)) with hC + have hAP : βˆ€ i, Parked (A i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hA, Function.update_self]; exact parked_regTape _ + Β· rw [hA, Function.update_of_ne hi]; exact hworkβ‚€ i + have hBP : βˆ€ i, Parked (B i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hB, Function.update_self]; exact parked_regTape _ + Β· rw [hB, Function.update_of_ne hi]; exact hworkβ‚€ i + have hCP : βˆ€ i, Parked (C i) := by + intro i + by_cases hi : i = tmp2 + Β· subst hi; rw [hC, Function.update_self]; exact parked_regTape _ + Β· rw [hC, Function.update_of_ne hi]; exact hworkβ‚€ i + -- Stage 1: clear tmp2. + have h₁ : (clearRegTM tmp2).HoareTime (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ A ys) (opBudget M) := + (clearRegTM_hoareTime tmp2 u inpβ‚€ workβ‚€ ys hinpβ‚€ + (fun i _ => hworkβ‚€ i) ht2).mono_bound (clearRegTM_le_opBudget hu) + -- Stage 2: tmp2 += tmp Β· X. + have hβ‚‚ : (mulAddIntoTM tmp X tmp2).HoareTime (EmitPred inpβ‚€ A ys) + (EmitPred inpβ‚€ B ys) (opBudget M) := by + refine (mulAddIntoTM_hoareTime tmp X tmp2 (fun h => hXt h.symm) htt2 hXt2 + v x 0 inpβ‚€ A ys hinpβ‚€ (fun i _ => hAP i) + (by rw [hA, Function.update_of_ne htt2]; exact ht) + (by rw [hA, Function.update_of_ne hXt2]; exact hX) + (by rw [hA, Function.update_self])).consequence + (fun _ _ _ h => h) ?_ (mulAddIntoTM_le_opBudget hv hx (by omega)) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hA, Function.update_idem, Nat.zero_add, hB] + -- Stage 3: tmp2 += c. + have h₃ : (iterTM (incRegTM tmp2) c).HoareTime (EmitPred inpβ‚€ B ys) + (EmitPred inpβ‚€ C ys) (opBudget M) := by + refine (iterTM_incRegTM_hoareTime tmp2 c (v * x) inpβ‚€ B ys hinpβ‚€ hBP + (by rw [hB, Function.update_self])).consequence + (fun _ _ _ h => h) ?_ (iterTM_incRegTM_le_opBudget hres) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hB, Function.update_idem, hC] + -- Stage 4: tmp := tmp2. + have hβ‚„ : (copyIntoTM tmp2 tmp).HoareTime (EmitPred inpβ‚€ C ys) + (EmitPred inpβ‚€ (Function.update C tmp (regTape (v * x + c))) ys) + (opBudget M) := by + refine (copyIntoTM_hoareTime tmp2 tmp (fun h => htt2 h.symm) (v * x + c) v + inpβ‚€ C ys hinpβ‚€ (fun i _ => hCP i) + (by rw [hC, Function.update_self]) + (by rw [hC, Function.update_of_ne htt2]; exact ht)).consequence + (fun _ _ _ h => h) (fun _ _ _ h => h) (copyIntoTM_le_opBudget hres hv) + -- Glue. + have h₃₄ := seqTM_hoareTime (iterTM (incRegTM tmp2) c) (copyIntoTM tmp2 tmp) h₃ + (emitPred_transition hinpβ‚€ hCP ys) hβ‚„ + have h₂₃₄ := seqTM_hoareTime (mulAddIntoTM tmp X tmp2) _ hβ‚‚ + (emitPred_transition hinpβ‚€ hBP ys) h₃₄ + have h := seqTM_hoareTime (clearRegTM tmp2) _ h₁ + (emitPred_transition hinpβ‚€ hAP ys) h₂₃₄ + refine h.consequence (fun _ _ _ hp => hp) ?_ (by rw [layerBudget]; omega) + rintro inp work out ⟨g1, g2, g3⟩ + exact ⟨g1, by rw [g2, hC], g3⟩ + +end HornerLayer + +-- ════════════════════════════════════════════════════════════════════════ +-- Folding layers: polynomial evaluation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Horner accumulator over a coefficient list (highest degree first). -/ +def hornerFold (x : β„•) : List β„• β†’ β„• β†’ β„• + | [], a => a + | c :: cs, a => hornerFold x cs (a * x + c) + +/-- `hornerFold` over the empty coefficient list returns the accumulator. -/ +@[simp] theorem hornerFold_nil (x a : β„•) : hornerFold x [] a = a := rfl + +/-- Unfolding lemma: one Horner layer replaces the accumulator `a` by `a * x + c`. -/ +theorem hornerFold_cons (x c a : β„•) (cs : List β„•) : + hornerFold x (c :: cs) a = hornerFold x cs (a * x + c) := rfl + +/-- The Horner fold of a reversed coefficient window is the polynomial sum. -/ +theorem hornerFold_reverse_range (f : β„• β†’ β„•) (x : β„•) : + βˆ€ (k a : β„•), + hornerFold x ((List.range k).map f).reverse a + = a * x ^ k + βˆ‘ i ∈ Finset.range k, f i * x ^ i := by + intro k + induction k with + | zero => intro a; simp + | succ k ih => + intro a + rw [List.range_succ, List.map_append, List.reverse_append] + simp only [List.map_cons, List.map_nil, List.reverse_cons, List.reverse_nil, + List.nil_append, List.singleton_append] + rw [hornerFold_cons, ih, Finset.sum_range_succ] + ring + +/-- Crude but monotone bound on the Horner accumulator. -/ +theorem hornerFold_le (x : β„•) : βˆ€ (cs : List β„•) (a : β„•), + hornerFold x cs a ≀ (a + cs.sum) * (x + 1) ^ cs.length := by + intro cs + induction cs with + | nil => intro a; simp + | cons c cs ih => + intro a + rw [hornerFold_cons] + refine le_trans (ih (a * x + c)) ?_ + rw [List.sum_cons, List.length_cons, pow_succ] + have h1 : a * x + c + cs.sum ≀ (a + (c + cs.sum)) * (x + 1) := by + have hexp : (a + (c + cs.sum)) * (x + 1) + = a * x + a + ((c + cs.sum) * x + (c + cs.sum)) := by ring + omega + calc (a * x + c + cs.sum) * (x + 1) ^ cs.length + ≀ ((a + (c + cs.sum)) * (x + 1)) * (x + 1) ^ cs.length := + Nat.mul_le_mul_right _ h1 + _ = (a + (c + cs.sum)) * ((x + 1) ^ cs.length * (x + 1)) := by ring + +/-- Every prefix of the Horner fold is bounded by the full coefficient sum + times the dominating power β€” the hypothesis-discharger for + `hornerLayersTM_hoareTime`'s value cap. -/ +theorem hornerFold_take_le (x : β„•) (cs : List β„•) (k : β„•) : + hornerFold x (cs.take k) 0 ≀ (cs.sum + 1) * (x + 1) ^ cs.length := by + refine le_trans (hornerFold_le x _ 0) ?_ + have h1 : (cs.take k).sum ≀ cs.sum := by + conv_rhs => rw [← List.take_append_drop k cs] + rw [List.sum_append] + omega + have h2 : (x + 1) ^ (cs.take k).length ≀ (x + 1) ^ cs.length := + Nat.pow_le_pow_right (by omega) + (by rw [List.length_take]; omega) + calc (0 + (cs.take k).sum) * (x + 1) ^ (cs.take k).length + ≀ (cs.sum + 1) * (x + 1) ^ cs.length := + Nat.mul_le_mul (by omega) h2 + +/-- Fold Horner layers (constant addends, highest first) over a register. -/ +def hornerLayersTM (X tmp tmp2 : Fin n) (cs : List β„•) : TM n := + bigSeqTM (cs.map (hornerLayerConstTM X tmp tmp2)) + +/-- **`hornerLayersTM` Hoare specification** (nonempty coefficient list). + From `tmp = v`, reach `tmp = tmp2 = hornerFold x (c :: cs) v`, provided + every intermediate accumulator value is at most `M`. -/ +theorem hornerLayersTM_hoareTime (X tmp tmp2 : Fin n) + (hXt : X β‰  tmp) (hXt2 : X β‰  tmp2) (htt2 : tmp β‰  tmp2) + (M x : β„•) (hx : x ≀ M) (inpβ‚€ : Tape) (hinpβ‚€ : Parked inpβ‚€) : + βˆ€ (c : β„•) (cs : List β„•) (v u : β„•) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool), + (βˆ€ k, k ≀ (c :: cs).length β†’ hornerFold x (List.take k (c :: cs)) v ≀ M) β†’ + u ≀ M β†’ + (βˆ€ i, Parked (workβ‚€ i)) β†’ + workβ‚€ X = regTape x β†’ workβ‚€ tmp = regTape v β†’ workβ‚€ tmp2 = regTape u β†’ + (hornerLayersTM X tmp tmp2 (c :: cs)).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ + (Function.update (Function.update workβ‚€ tmp2 + (regTape (hornerFold x (c :: cs) v))) tmp + (regTape (hornerFold x (c :: cs) v))) ys) + ((c :: cs).length * (layerBudget M + 1) + 1) := by + intro c cs + induction cs generalizing c with + | nil => + intro v u workβ‚€ ys hpre hu hworkβ‚€ hX ht ht2 + have hv : v ≀ M := by + have := hpre 0 (by omega) + simpa using this + have hres : v * x + c ≀ M := by + have := hpre 1 (by simp) + simpa [hornerFold_cons] using this + have hlayer := hornerLayerConstTM_hoareTime hXt hXt2 htt2 M x v c u + hx hv hu hres inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ hX ht ht2 + set P : Fin n β†’ Tape := + Function.update (Function.update workβ‚€ tmp2 (regTape (v * x + c))) tmp + (regTape (v * x + c)) with hP + have hPP : βˆ€ i, Parked (P i) := by + intro i + by_cases hi : i = tmp + Β· subst hi; rw [hP, Function.update_self]; exact parked_regTape _ + Β· rw [hP, Function.update_of_ne hi] + by_cases hi2 : i = tmp2 + Β· subst hi2; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hi2]; exact hworkβ‚€ i + have hskip := skipTM_hoareTime inpβ‚€ P ys hinpβ‚€ hPP + have hseq := seqTM_hoareTime (hornerLayerConstTM X tmp tmp2 c) skipTM hlayer + (emitPred_transition hinpβ‚€ hPP ys) hskip + refine hseq.consequence (fun _ _ _ h => h) ?_ + (by simp only [List.length_cons, List.length_nil, Nat.zero_add, + Nat.one_mul]; omega) + rintro inp work out ⟨g1, g2, g3⟩ + exact ⟨g1, by rw [g2, hP, hornerFold_cons, hornerFold_nil], g3⟩ + | cons c' cs' ih => + intro v u workβ‚€ ys hpre hu hworkβ‚€ hX ht ht2 + have hv : v ≀ M := by + have := hpre 0 (by omega) + simpa using this + have hv₁ : v * x + c ≀ M := by + have := hpre 1 (by simp) + simpa [hornerFold_cons] using this + have hlayer := hornerLayerConstTM_hoareTime hXt hXt2 htt2 M x v c u + hx hv hu hv₁ inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ hX ht ht2 + set P : Fin n β†’ Tape := + Function.update (Function.update workβ‚€ tmp2 (regTape (v * x + c))) tmp + (regTape (v * x + c)) with hP + have hPP : βˆ€ i, Parked (P i) := by + intro i + by_cases hi : i = tmp + Β· subst hi; rw [hP, Function.update_self]; exact parked_regTape _ + Β· rw [hP, Function.update_of_ne hi] + by_cases hi2 : i = tmp2 + Β· subst hi2; rw [Function.update_self]; exact parked_regTape _ + Β· rw [Function.update_of_ne hi2]; exact hworkβ‚€ i + have hpre' : βˆ€ k, k ≀ (c' :: cs').length β†’ + hornerFold x (List.take k (c' :: cs')) (v * x + c) ≀ M := by + intro k hk + have := hpre (k + 1) (by simpa using Nat.succ_le_succ hk) + rwa [List.take_succ_cons, hornerFold_cons] at this + have hrest := ih c' (v * x + c) (v * x + c) P ys hpre' hv₁ hPP + (by rw [hP, Function.update_of_ne hXt, Function.update_of_ne hXt2]; exact hX) + (by rw [hP, Function.update_self]) + (by rw [hP, Function.update_of_ne (fun h => htt2 h.symm), + Function.update_self]) + have hseq := seqTM_hoareTime (hornerLayerConstTM X tmp tmp2 c) + (hornerLayersTM X tmp tmp2 (c' :: cs')) hlayer + (emitPred_transition hinpβ‚€ hPP ys) hrest + refine hseq.consequence (fun _ _ _ h => h) ?_ ?_ + Β· rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hP, Function.update_comm htt2, Function.update_idem, + Function.update_idem, + show hornerFold x (c' :: cs') (v * x + c) + = hornerFold x (c :: c' :: cs') v from rfl] + Β· have hmul : (c :: c' :: cs').length * (layerBudget M + 1) + = (c' :: cs').length * (layerBudget M + 1) + (layerBudget M + 1) := by + rw [List.length_cons] + exact Nat.succ_mul .. + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- polyEvalTM +-- ════════════════════════════════════════════════════════════════════════ + +/-- The coefficient list of `p`, highest degree first. -/ +def polyCoeffs (p : Polynomial β„•) : List β„• := + ((List.range (p.natDegree + 1)).map p.coeff).reverse + +/-- The coefficient list of a polynomial is never empty (it has `natDegree + 1` entries). -/ +theorem polyCoeffs_ne_nil (p : Polynomial β„•) : polyCoeffs p β‰  [] := by + simp [polyCoeffs] + +/-- `polyCoeffs p` has exactly `p.natDegree + 1` entries. -/ +@[simp] theorem polyCoeffs_length (p : Polynomial β„•) : + (polyCoeffs p).length = p.natDegree + 1 := by + simp [polyCoeffs] + +/-- **The Horner fold computes `p.eval`.** -/ +theorem hornerFold_polyCoeffs (p : Polynomial β„•) (x : β„•) : + hornerFold x (polyCoeffs p) 0 = p.eval x := by + rw [polyCoeffs, hornerFold_reverse_range, Polynomial.eval_eq_sum_range] + simp + +/-- `tmp := p.eval x`, reading `x` from register `X` (Horner's rule over the + hardwired coefficient list; `tmp2` is scratch and ends equal to `tmp`). -/ +def polyEvalTM (X tmp tmp2 : Fin n) (p : Polynomial β„•) : TM n := + seqTM (setConstTM tmp 0) (hornerLayersTM X tmp tmp2 (polyCoeffs p)) + +/-- **`polyEvalTM` Hoare specification.** From `X = x` (and any `tmp = v`, + `tmp2 = u`), reach `tmp = tmp2 = p.eval x`, provided `M` caps `x`, the + starting scratch values, and every Horner prefix value. -/ +theorem polyEvalTM_hoareTime (X tmp tmp2 : Fin n) + (hXt : X β‰  tmp) (hXt2 : X β‰  tmp2) (htt2 : tmp β‰  tmp2) + (p : Polynomial β„•) (M x v u : β„•) (hx : x ≀ M) (hv : v ≀ M) (hu : u ≀ M) + (hpre : βˆ€ k, k ≀ p.natDegree + 1 β†’ + hornerFold x (List.take k (polyCoeffs p)) 0 ≀ M) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) + (hX : workβ‚€ X = regTape x) (ht : workβ‚€ tmp = regTape v) + (ht2 : workβ‚€ tmp2 = regTape u) : + (polyEvalTM X tmp tmp2 p).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ + (Function.update (Function.update workβ‚€ tmp2 (regTape (p.eval x))) tmp + (regTape (p.eval x))) ys) + (opBudget M + 1 + ((p.natDegree + 1) * (layerBudget M + 1) + 1)) := by + have hset := (setConstTM_hoareTime tmp 0 v inpβ‚€ workβ‚€ ys hinpβ‚€ hworkβ‚€ + ht).mono_bound (setConstTM_le_opBudget (by omega) hv) + set A : Fin n β†’ Tape := Function.update workβ‚€ tmp (regTape 0) with hA + have hAP : βˆ€ i, Parked (A i) := by + intro i + by_cases hi : i = tmp + Β· subst hi; rw [hA, Function.update_self]; exact parked_regTape _ + Β· rw [hA, Function.update_of_ne hi]; exact hworkβ‚€ i + obtain ⟨c, cs, hcs⟩ := List.exists_cons_of_ne_nil (polyCoeffs_ne_nil p) + have hlen : (c :: cs).length = p.natDegree + 1 := by + rw [← hcs, polyCoeffs_length] + have hrest := hornerLayersTM_hoareTime X tmp tmp2 hXt hXt2 htt2 M x hx inpβ‚€ + hinpβ‚€ c cs 0 u A ys + (by rw [← hcs, polyCoeffs_length]; exact hpre) + hu hAP + (by rw [hA, Function.update_of_ne hXt]; exact hX) + (by rw [hA, Function.update_self]) + (by rw [hA, Function.update_of_ne (fun h => htt2 h.symm)]; exact ht2) + have heval : hornerFold x (c :: cs) 0 = p.eval x := by + rw [← hcs, hornerFold_polyCoeffs] + rw [heval] at hrest + have hseq := seqTM_hoareTime (setConstTM tmp 0) + (hornerLayersTM X tmp tmp2 (c :: cs)) hset + (emitPred_transition hinpβ‚€ hAP ys) hrest + have hmach : polyEvalTM X tmp tmp2 p + = seqTM (setConstTM tmp 0) (hornerLayersTM X tmp tmp2 (c :: cs)) := by + rw [polyEvalTM, hcs] + rw [hmach] + refine hseq.consequence (fun _ _ _ h => h) ?_ (by rw [hlen]) + rintro inp work out ⟨g1, g2, g3⟩ + refine ⟨g1, ?_, g3⟩ + rw [g2, hA, Function.update_comm htt2, Function.update_idem] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/InputLen.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/InputLen.lean new file mode 100644 index 0000000000..ec1c25a3ac --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/InputLen.lean @@ -0,0 +1,486 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps + +/-! +# Input length into a register + +`inputLenRegTM q` scans the input tape in lockstep with register `q`, writing +one mark per input bit, then rewinds both heads to cell 1: from the bumped +initial configuration it puts `regTape |x|` in register `q`, restoring the input +tape exactly. This is the reduction emitter's only input-reading machine +besides the start-clause emitter, and the last hand-rolled machine of the +campaign (`docs/A5-ReductionEmitter.md`). +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- **Measure the input length into register `q`**: lockstep scan right over + the input bits writing marks, then lockstep rewind. -/ +def inputLenRegTM (q : Fin n) : TM n where + Q := IncPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun s iHead wHeads oHead => + match s with + | .scan => + if iHead = Ξ“.blank then + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.left, + fun i => if i = q then (if wHeads q = Ξ“.start then Dir3.right else Dir3.left) + else idleDir (wHeads i), + idleDir oHead) + else if iHead = Ξ“.start then + (.scan, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + else + (.scan, fun i => if i = q then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, Dir3.right, + fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .back => + if wHeads q = Ξ“.start then + (.park, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + (if iHead = Ξ“.start then Dir3.right else Dir3.left), + fun i => if i = q then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .park => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle s iHead wHeads oHead + Ξ΄_right_of_start := by + intro s iHead wHeads oHead + match s with + | .scan => + dsimp only [] + split + Β· next hbl => + refine ⟨fun hi => absurd hi (by rw [hbl]; decide), fun i hi => ?_, + idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; rw [ite_eq_left rfl, ite_eq_left hi] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· split + Β· exact ⟨fun _ => rfl, fun i hi => idleDir_right_of_start hi, + idleDir_right_of_start⟩ + Β· refine ⟨fun _ => rfl, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .back => + dsimp only [] + split + Β· refine ⟨fun _ => rfl, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hns => + refine ⟨fun hi => by rw [ite_eq_left hi], fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; exact absurd hi hns + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .park => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +section InputLen + +variable {q : Fin n} + +private theorem inputLenRegTM_ne_halt {s : IncPhase} (h : s β‰  .done) + {c : Cfg n (inputLenRegTM (n := n) q).Q} (hst : c.state = s) : + Β¬ c.state = (inputLenRegTM (n := n) q).qhalt := by + rw [hst] + show Β¬ s = IncPhase.done + exact h + +/-- `scan` over a bit: mark the register, advance both heads. -/ +private theorem inputLenRegTM_step_scan_bit (c : Cfg n (inputLenRegTM (n := n) q).Q) + (hst : c.state = .scan) (hbl : c.input.read β‰  Ξ“.blank) + (hns : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) (hout : Parked c.output) : + (inputLenRegTM (n := n) q).step c = some + { state := .scan, input := c.input.move .right, + work := Function.update c.work q + (((c.work q).write Ξ“w.one).move .right), + output := c.output } := by + rw [TM.step, ite_eq_right (inputLenRegTM_ne_halt (by decide) hst)] + simp only [inputLenRegTM, hst, hbl, hns, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + by_cases hir : i = q + Β· subst hir + simp only [↓reduceIte, Function.update_self] + Β· rw [ite_eq_right hir, ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `scan` at the input's first blank: turn both heads around. -/ +private theorem inputLenRegTM_step_scan_blank (c : Cfg n (inputLenRegTM (n := n) q).Q) + (hst : c.state = .scan) (hbl : c.input.read = Ξ“.blank) + (hqns : (c.work q).read β‰  Ξ“.start) + (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) (hout : Parked c.output) : + (inputLenRegTM (n := n) q).step c = some + { state := .back, input := c.input.move .left, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (inputLenRegTM_ne_halt (by decide) hst)] + simp only [inputLenRegTM, hst, hbl, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, ite_eq_right hqns, Function.update_self, + writeAndMove_readBack _ hqns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` off the sentinel: both heads keep rewinding. -/ +private theorem inputLenRegTM_step_back_left (c : Cfg n (inputLenRegTM (n := n) q).Q) + (hst : c.state = .back) (hqns : (c.work q).read β‰  Ξ“.start) + (hins : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) (hout : Parked c.output) : + (inputLenRegTM (n := n) q).step c = some + { state := .back, input := c.input.move .left, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (inputLenRegTM_ne_halt (by decide) hst)] + simp only [inputLenRegTM, hst, hqns, hins, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, writeAndMove_readBack _ hqns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` on the sentinel: both heads step right to cell 1 and park. -/ +private theorem inputLenRegTM_step_back_start (c : Cfg n (inputLenRegTM (n := n) q).Q) + (hst : c.state = .back) (hs : (c.work q).read = Ξ“.start) + (hcr : βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) + (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) (hout : Parked c.output) : + (inputLenRegTM (n := n) q).step c = some + { state := .park, input := c.input.move .right, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } := by + have h0 : (c.work q).head = 0 := by + by_contra hc + exact hcr _ (by omega) hs + rw [TM.step, ite_eq_right (inputLenRegTM_ne_halt (by decide) hst)] + simp only [inputLenRegTM, hst, hs, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, rfl, ?_, ?_⟩) + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self] + show ((c.work i).write _).move Dir3.right = (c.work i).move .right + congr 1 + rw [Tape.write, ite_eq_left h0] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `park`: one idle step into `done` (parked tapes everywhere). -/ +private theorem inputLenRegTM_step_park (c : Cfg n (inputLenRegTM (n := n) q).Q) + (hst : c.state = .park) (hinp : Parked c.input) + (hwork : βˆ€ i, Parked (c.work i)) (hout : Parked c.output) : + (inputLenRegTM (n := n) q).step c = some + { state := .done, input := c.input, work := c.work, output := c.output } := by + rw [TM.step, ite_eq_right (inputLenRegTM_ne_halt (by decide) hst)] + simp only [inputLenRegTM, hst] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The lockstep scan: one mark per input bit. -/ +private theorem inputLenRegTM_scan_run (x : List Bool) (m : β„•) : + βˆ€ (k : β„•), x.length = k + m β†’ + βˆ€ (c : Cfg n (inputLenRegTM (n := n) q).Q), + c.state = .scan β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ c.input.head = k + 1 β†’ + (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ Parked c.output β†’ + (c.work q).cells = regCells k β†’ (c.work q).head = k + 1 β†’ + βˆƒ c', (inputLenRegTM (n := n) q).reachesIn m c c' ∧ + c'.state = .scan ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = x.length + 1 ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = regCells x.length ∧ + (c'.work q).head = x.length + 1 ∧ + c'.output = c.output := by + induction m with + | zero => + intro k hk c hst hic hih hwork hout hqc hqh + obtain rfl : x.length = k := by omega + exact ⟨c, .zero, hst, hic, hih, fun _ _ => rfl, hqc, hqh, rfl⟩ + | succ m ih => + intro k hk c hst hic hih hwork hout hqc hqh + have hread : c.input.read = Ξ“.ofBool (x[k]'(by omega)) := by + rw [Tape.read, hih, hic] + exact Tape.init_ofBool_cells_lt x k (by omega) + have hbl : c.input.read β‰  Ξ“.blank := by + rw [hread] + exact Ξ“.ofBool_ne_blank _ + have hns : c.input.read β‰  Ξ“.start := by + rw [hread] + exact Ξ“.ofBool_ne_start _ + have hstep := inputLenRegTM_step_scan_bit c hst hbl hns hwork hout + have hq₁cells : (((c.work q).write Ξ“w.one).move .right).cells + = regCells (k + 1) := by + show ((c.work q).write Ξ“w.one).cells = _ + rw [Tape.write, ite_eq_right (by rw [hqh]; omega)] + show Function.update (c.work q).cells (c.work q).head Ξ“w.one.toΞ“ = _ + rw [hqh, hqc] + exact regCells_update_succ k + have hq₁head : (((c.work q).write Ξ“w.one).move .right).head = (k + 1) + 1 := by + show ((c.work q).write Ξ“w.one).head + 1 = _ + rw [Tape.write_head, hqh] + obtain ⟨c', hreach, h1, h2, h3, h4, h5, h6, h7⟩ := + ih (k + 1) (by omega) + { state := .scan, input := c.input.move .right, + work := Function.update c.work q (((c.work q).write Ξ“w.one).move .right), + output := c.output } rfl + (by show (c.input.move .right).cells = _ + rw [Tape.move_cells] + exact hic) + (by show c.input.head + 1 = (k + 1) + 1 + rw [hih]) + (fun i hi => by + show Parked (Function.update c.work q _ i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by show (Function.update c.work q _ q).cells = _ + rw [Function.update_self] + exact hq₁cells) + (by show (Function.update c.work q _ q).head = _ + rw [Function.update_self] + exact hq₁head) + refine ⟨c', .step hstep hreach, h1, h2, h3, ?_, h5, h6, h7⟩ + intro i hi + rw [h4 i hi] + show Function.update c.work q _ i = c.work i + rw [Function.update_of_ne hi] + +/-- The lockstep rewind: both heads return to cell 1. -/ +private theorem inputLenRegTM_back_run (x : List Bool) (h : β„•) : + βˆ€ (c : Cfg n (inputLenRegTM (n := n) q).Q), + c.state = .back β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ c.input.head = h β†’ + (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ Parked c.output β†’ + (c.work q).cells 0 = Ξ“.start β†’ + (βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) β†’ + (c.work q).head = h β†’ + βˆƒ c', (inputLenRegTM (n := n) q).reachesIn (h + 2) c c' ∧ + c'.state = .done ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ c'.input.head = 1 ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = (c.work q).cells ∧ (c'.work q).head = 1 ∧ + c'.output = c.output := by + induction h with + | zero => + intro c hst hic hih hwork hout hc0 hcr hqh + have hs : (c.work q).read = Ξ“.start := by rw [Tape.read, hqh]; exact hc0 + have hstep₁ := inputLenRegTM_step_back_start c hst hs hcr hwork hout + have hparkP : Parked (c.input.move .right) := by + refine ⟨?_, fun j hj => ?_⟩ + Β· show c.input.head + 1 β‰₯ 1 + omega + Β· show (c.input.move .right).cells j β‰  Ξ“.start + rw [Tape.move_cells, hic] + exact Tape.init_ofBool_cells_ne_start x j hj + have hstepβ‚‚ := inputLenRegTM_step_park (q := q) + { state := .park, input := c.input.move .right, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } rfl hparkP + (fun i => by + by_cases hir : i = q + Β· subst hir + show Parked (Function.update c.work i ((c.work i).move .right) i) + rw [Function.update_self] + exact ⟨by show (c.work i).head + 1 β‰₯ 1; omega, fun j hj => hcr j hj⟩ + Β· show Parked (Function.update c.work q ((c.work q).move .right) i) + rw [Function.update_of_ne hir] + exact hwork i hir) + hout + refine ⟨_, .step hstep₁ (.step hstepβ‚‚ .zero), rfl, ?_, ?_, ?_, ?_, ?_, rfl⟩ + Β· show (c.input.move .right).cells = _ + rw [Tape.move_cells] + exact hic + Β· show c.input.head + 1 = 1 + rw [hih] + Β· intro i hi + show Function.update c.work q ((c.work q).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· show (Function.update c.work q ((c.work q).move .right) q).cells = _ + rw [Function.update_self] + rfl + Β· show (Function.update c.work q ((c.work q).move .right) q).head = 1 + rw [Function.update_self] + show (c.work q).head + 1 = 1 + rw [hqh] + | succ h ih => + intro c hst hic hih hwork hout hc0 hcr hqh + have hqns : (c.work q).read β‰  Ξ“.start := by + rw [Tape.read, hqh] + exact hcr (h + 1) (by omega) + have hins : c.input.read β‰  Ξ“.start := by + rw [Tape.read, hih, hic] + exact Tape.init_ofBool_cells_ne_start x _ (by omega) + have hstep₁ := inputLenRegTM_step_back_left c hst hqns hins hwork hout + obtain ⟨c', hreach, h1, h2, h3, h4, h5, h6, h7⟩ := + ih { state := .back, input := c.input.move .left, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } rfl + (by show (c.input.move .left).cells = _ + rw [Tape.move_cells] + exact hic) + (by show c.input.head - 1 = h + rw [hih] + omega) + (fun i hi => by + show Parked (Function.update c.work q ((c.work q).move .left) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by show (Function.update c.work q _ q).cells 0 = _ + rw [Function.update_self] + exact hc0) + (fun j hj => by + show (Function.update c.work q _ q).cells j β‰  _ + rw [Function.update_self] + exact hcr j hj) + (by show (Function.update c.work q _ q).head = h + rw [Function.update_self] + show (c.work q).head - 1 = h + rw [hqh] + omega) + refine ⟨c', .step hstep₁ hreach, h1, h2, h3, ?_, ?_, h6, h7⟩ + Β· intro i hi + rw [h4 i hi] + show Function.update c.work q ((c.work q).move .left) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [h5] + show (Function.update c.work q ((c.work q).move .left) q).cells = _ + rw [Function.update_self] + rfl + +/-- **`inputLenRegTM` Hoare specification.** From the bumped initial input and + `regTape 0` in `q`, reach `regTape |x|` in `q`, restoring the input exactly. -/ +theorem inputLenRegTM_hoareTime (q : Fin n) (x : List Bool) + (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hworkβ‚€ : βˆ€ i, i β‰  q β†’ Parked (workβ‚€ i)) (hq : workβ‚€ q = regTape 0) : + (inputLenRegTM (n := n) q).HoareTime + (EmitPred ⟨1, (Tape.init (x.map Ξ“.ofBool)).cells⟩ workβ‚€ ys) + (EmitPred ⟨1, (Tape.init (x.map Ξ“.ofBool)).cells⟩ + (Function.update workβ‚€ q (regTape x.length)) ys) + (2 * x.length + 4) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c₁, hreach₁, h1, h2, h3, h4, h5, h6, h7⟩ := + inputLenRegTM_scan_run x x.length 0 (by omega) + { state := .scan, input := ⟨1, (Tape.init (x.map Ξ“.ofBool)).cells⟩, + work := work, output := out } rfl rfl rfl + hworkβ‚€ hout.parked + (by show (work q).cells = regCells 0; rw [hq, regT_cells]) + (by show (work q).head = 0 + 1; rw [hq, regT_head]) + have hworkP₁ : βˆ€ i, i β‰  q β†’ Parked (c₁.work i) := fun i hi => by + rw [h4 i hi] + exact hworkβ‚€ i hi + have houtP₁ : Parked c₁.output := by rw [h7]; exact hout.parked + have hibl : c₁.input.read = Ξ“.blank := by + rw [Tape.read, h3, h2] + exact Tape.init_ofBool_cells_ge x x.length (le_refl _) + have hqns₁ : (c₁.work q).read β‰  Ξ“.start := by + rw [Tape.read, h6, h5] + show regCells x.length (x.length + 1) β‰  Ξ“.start + rw [regCells_blank (le_refl _)] + decide + have hstepβ‚‚ := inputLenRegTM_step_scan_blank c₁ h1 hibl hqns₁ hworkP₁ houtP₁ + obtain ⟨c₃, hreach₃, g1, g2, g3, g4, g5, g6, g7⟩ := + inputLenRegTM_back_run x x.length + { state := .back, input := c₁.input.move .left, + work := Function.update c₁.work q ((c₁.work q).move .left), + output := c₁.output } rfl + (by show (c₁.input.move .left).cells = _ + rw [Tape.move_cells] + exact h2) + (by show c₁.input.head - 1 = x.length + rw [h3] + omega) + (fun i hi => by + show Parked (Function.update c₁.work q ((c₁.work q).move .left) i) + rw [Function.update_of_ne hi] + exact hworkP₁ i hi) + houtP₁ + (by show (Function.update c₁.work q _ q).cells 0 = _ + rw [Function.update_self] + show (c₁.work q).cells 0 = _ + rw [h5] + rfl) + (fun j hj => by + show (Function.update c₁.work q _ q).cells j β‰  _ + rw [Function.update_self] + show (c₁.work q).cells j β‰  _ + rw [h5] + show regCells x.length j β‰  Ξ“.start + rw [regCells, ite_eq_right (by omega)] + split <;> decide) + (by show (Function.update c₁.work q _ q).head = x.length + rw [Function.update_self] + show (c₁.work q).head - 1 = x.length + rw [h6] + omega) + refine ⟨c₃, x.length + ((x.length + 2) + 1), by omega, + reachesIn_trans _ hreach₁ (.step hstepβ‚‚ hreach₃), g1, ?_, ?_, ?_⟩ + Β· refine Tape.ext ?_ ?_ + Β· rw [g3] + Β· rw [g2] + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [Function.update_self] + refine Tape.ext ?_ ?_ + Β· rw [g6] + rfl + Β· rw [g5] + show (Function.update c₁.work i ((c₁.work i).move .left) i).cells = _ + rw [Function.update_self] + show (c₁.work i).cells = _ + rw [h5, regT_cells] + Β· rw [Function.update_of_ne hir, g4 i hir] + show Function.update c₁.work q ((c₁.work q).move .left) i = work i + rw [Function.update_of_ne hir] + exact h4 i hir + Β· rw [g7, h7] + exact hout + +end InputLen + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/RegisterOps.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/RegisterOps.lean new file mode 100644 index 0000000000..3098f2f6d8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Registers/RegisterOps.lean @@ -0,0 +1,961 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.Emit + +/-! +# Register operations + +The hand-rolled core machines of the reduction emitter's register calculus +(`docs/A5-ReductionEmitter.md`): `skipTM` (a one-step no-op, the fold +identity), `incRegTM` (append one mark to a register), and `clearRegTM` +(blank a register). All register arithmetic (addition, multiplication, +polynomial evaluation) composes from these via the `forRegTM` loop +combinator. + +Specs are in the ghost-parametrized `EmitPred` style: registers are the +canonical tapes `regTape v`, and posts are `Function.update` equations. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- skipTM: the one-step no-op +-- ════════════════════════════════════════════════════════════════════════ + +/-- One idle step and halt: the identity for `seqTM` folds. -/ +def skipTM : TM n where + Q := BumpPhase + qstart := .go + qhalt := .done + Ξ΄ := fun _ iHead wHeads oHead => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + Ξ΄_right_of_start := fun _ _ _ _ => + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + +/-- `skipTM` changes nothing (parked tapes). -/ +theorem skipTM_hoareTime (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (ys : List Bool) + (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i)) : + (skipTM (n := n)).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) (EmitPred inpβ‚€ workβ‚€ ys) 1 := by + rintro inp work out ⟨rfl, rfl, hout⟩ + have hstep : (skipTM (n := n)).step + { state := .go, input := inp, work := work, output := out } = some + { state := .done, input := inp, work := work, output := out } := by + simp only [TM.step, skipTM, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinpβ‚€.move_idle + Β· funext i + exact (hworkβ‚€ i).writeAndMove_readBack_idle + Β· exact hout.parked.writeAndMove_readBack_idle + exact ⟨_, 1, le_refl 1, .step hstep .zero, rfl, rfl, rfl, hout⟩ + +/-- `skipTM` preserves an arbitrary fully parked tape frame exactly. -/ +theorem skipTM_hoareTime_frame (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (skipTM (n := n)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + 1 := by + rintro inp work out ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + let c' : Cfg n (skipTM (n := n)).Q := + { state := (skipTM (n := n)).qhalt + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + have hstep : (skipTM (n := n)).step + { state := (skipTM (n := n)).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } = some c' := by + simp only [TM.step, skipTM, reduceCtorEq, ↓reduceIte, c'] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinput.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact houtput.writeAndMove_readBack_idle + exact ⟨c', 1, le_rfl, .step hstep .zero, rfl, rfl, rfl, rfl⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- incRegTM: append one mark to a register +-- ════════════════════════════════════════════════════════════════════════ + +/-- State set shared by `incRegTM` and `clearRegTM`: `scan` sweeps right over + the marks, `back` rewinds to the sentinel, `park` steps onto cell 1, and + `done` halts. -/ +inductive IncPhase where + | scan | back | park | done + deriving DecidableEq + +/-- `IncPhase` is finite (it has exactly four states). -/ +instance : Fintype IncPhase where + elems := {.scan, .back, .park, .done} + complete := fun x => by cases x <;> simp + +/-- **Increment register `q`**: scan right over the marks, write a mark on the + first blank, rewind to cell 1. From `regTape d` to `regTape (d + 1)` in + `2d + 4` steps; every other tape untouched. -/ +def incRegTM (q : Fin n) : TM n where + Q := IncPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun s iHead wHeads oHead => + match s with + | .scan => + if wHeads q = Ξ“.one then + (.scan, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => if i = q then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = q then (if wHeads q = Ξ“.start then Dir3.right else Dir3.left) + else idleDir (wHeads i), + idleDir oHead) + | .back => + if wHeads q = Ξ“.start then + (.park, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = q then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .park => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle s iHead wHeads oHead + Ξ΄_right_of_start := by + intro s iHead wHeads oHead + match s with + | .scan => + dsimp only [] + split + Β· next hone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; rw [hone] at hi; exact absurd hi (by decide) + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hnone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; rw [ite_eq_left rfl, ite_eq_left hi] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .back => + dsimp only [] + split + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hns => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; exact absurd hi hns + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .park => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +section IncReg + +variable {q : Fin n} + +private theorem incRegTM_ne_halt {s : IncPhase} (h : s β‰  .done) + {c : Cfg n (incRegTM (n := n) q).Q} (hst : c.state = s) : + Β¬ c.state = (incRegTM (n := n) q).qhalt := by + rw [hst] + show Β¬ s = IncPhase.done + exact h + +/-- `scan` over a mark: the register head advances; nothing else changes. -/ +private theorem incRegTM_step_scan_one (c : Cfg n (incRegTM (n := n) q).Q) + (hst : c.state = .scan) (hone : (c.work q).read = Ξ“.one) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (incRegTM (n := n) q).step c = some + { state := .scan, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } := by + rw [TM.step, ite_eq_right (incRegTM_ne_halt (by decide) hst)] + simp only [incRegTM, hst, hone, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hone]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `scan` at the first blank: write the new mark and turn around. -/ +private theorem incRegTM_step_scan_blank (c : Cfg n (incRegTM (n := n) q).Q) + (hst : c.state = .scan) (hblank : (c.work q).read = Ξ“.blank) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (incRegTM (n := n) q).step c = some + { state := .back, input := c.input, + work := Function.update c.work q + (((c.work q).write Ξ“w.one).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (incRegTM_ne_halt (by decide) hst)] + simp only [incRegTM, hst, hblank, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + simp only [↓reduceIte, Function.update_self] + Β· rw [ite_eq_right hir, ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` off the sentinel: keep rewinding. -/ +private theorem incRegTM_step_back_left (c : Cfg n (incRegTM (n := n) q).Q) + (hst : c.state = .back) (hns : (c.work q).read β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (incRegTM (n := n) q).step c = some + { state := .back, input := c.input, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (incRegTM_ne_halt (by decide) hst)] + simp only [incRegTM, hst, hns, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, writeAndMove_readBack _ hns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` on the sentinel: step right to cell 1 and park. -/ +private theorem incRegTM_step_back_start (c : Cfg n (incRegTM (n := n) q).Q) + (hst : c.state = .back) (hs : (c.work q).read = Ξ“.start) + (hcr : βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (incRegTM (n := n) q).step c = some + { state := .park, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } := by + have h0 : (c.work q).head = 0 := by + by_contra hc + exact hcr _ (by omega) hs + rw [TM.step, ite_eq_right (incRegTM_ne_halt (by decide) hst)] + simp only [incRegTM, hst, hs, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self] + show ((c.work i).write _).move Dir3.right = (c.work i).move .right + congr 1 + rw [Tape.write, ite_eq_left h0] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `park`: one idle step into `done`. -/ +private theorem incRegTM_step_park (c : Cfg n (incRegTM (n := n) q).Q) + (hst : c.state = .park) (hinp : Parked c.input) (hwork : βˆ€ i, Parked (c.work i)) + (hout : Parked c.output) : + (incRegTM (n := n) q).step c = some + { state := .done, input := c.input, work := c.work, output := c.output } := by + rw [TM.step, ite_eq_right (incRegTM_ne_halt (by decide) hst)] + simp only [incRegTM, hst] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The scan loop: from `scan` with the register head at `k + 1` over + `regCells d` cells (`k ≀ d`), reach the first blank in `d - k` steps. -/ +private theorem incRegTM_scan_run (d m : β„•) : + βˆ€ (k : β„•), d = k + m β†’ + βˆ€ (c : Cfg n (incRegTM (n := n) q).Q), + c.state = .scan β†’ Parked c.input β†’ (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ + Parked c.output β†’ + (c.work q).cells = regCells d β†’ (c.work q).head = k + 1 β†’ + βˆƒ c', (incRegTM (n := n) q).reachesIn m c c' ∧ + c'.state = .scan ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = regCells d ∧ (c'.work q).head = d + 1 ∧ + c'.output = c.output := by + induction m with + | zero => + intro k hk c hst hinp hwork hout hcells hhead + exact ⟨c, .zero, hst, rfl, fun _ _ => rfl, hcells, by rw [hhead, hk], rfl⟩ + | succ m ih => + intro k hk c hst hinp hwork hout hcells hhead + have hone : (c.work q).read = Ξ“.one := by + rw [Tape.read, hhead, hcells] + exact regCells_one (by omega) (by omega) + have hstep := incRegTM_step_scan_one c hst hone hinp hwork hout + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih (k + 1) (by omega) + { state := .scan, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } rfl hinp + (fun i hi => by + show Parked (Function.update c.work q ((c.work q).move .right) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by + show (Function.update c.work q ((c.work q).move .right) q).cells = _ + rw [Function.update_self] + show (c.work q).cells = _ + exact hcells) + (by + show (Function.update c.work q ((c.work q).move .right) q).head = _ + rw [Function.update_self] + show (c.work q).head + 1 = _ + rw [hhead]) + refine ⟨c', .step hstep hreach, hst', hinp', ?_, hcells', hhead', hout'⟩ + intro i hi + rw [hwork' i hi] + show Function.update c.work q ((c.work q).move .right) i = c.work i + rw [Function.update_of_ne hi] + +/-- The rewind loop: from `back` at head `h` over `β–·`-clean cells, reach + `done` parked at cell 1 in `h + 2` steps. -/ +private theorem incRegTM_back_run (h : β„•) : + βˆ€ (c : Cfg n (incRegTM (n := n) q).Q), + c.state = .back β†’ Parked c.input β†’ (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ + Parked c.output β†’ + (c.work q).cells 0 = Ξ“.start β†’ + (βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) β†’ + (c.work q).head = h β†’ + βˆƒ c', (incRegTM (n := n) q).reachesIn (h + 2) c c' ∧ + c'.state = .done ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = (c.work q).cells ∧ (c'.work q).head = 1 ∧ + c'.output = c.output := by + induction h with + | zero => + intro c hst hinp hwork hout hc0 hcr hhead + have hs : (c.work q).read = Ξ“.start := by rw [Tape.read, hhead]; exact hc0 + have hstep₁ := incRegTM_step_back_start c hst hs hcr hinp hwork hout + have hworkP : βˆ€ i, Parked (Function.update c.work q ((c.work q).move .right) i) := by + intro i + by_cases hir : i = q + Β· subst hir + rw [Function.update_self] + exact ⟨by show (c.work i).head + 1 β‰₯ 1; omega, fun j hj => hcr j hj⟩ + Β· rw [Function.update_of_ne hir] + exact hwork i hir + have hstepβ‚‚ := incRegTM_step_park (q := q) + { state := .park, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } rfl hinp hworkP hout + refine ⟨_, .step hstep₁ (.step hstepβ‚‚ .zero), rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· intro i hi + show Function.update c.work q ((c.work q).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· show (Function.update c.work q ((c.work q).move .right) q).cells = _ + rw [Function.update_self] + rfl + Β· show (Function.update c.work q ((c.work q).move .right) q).head = 1 + rw [Function.update_self] + show (c.work q).head + 1 = 1 + rw [hhead] + | succ h ih => + intro c hst hinp hwork hout hc0 hcr hhead + have hns : (c.work q).read β‰  Ξ“.start := by + rw [Tape.read, hhead]; exact hcr (h + 1) (by omega) + have hstep₁ := incRegTM_step_back_left c hst hns hinp hwork hout + have hupd : (Function.update c.work q ((c.work q).move .left) q).cells + = (c.work q).cells := by + rw [Function.update_self] + rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih { state := .back, input := c.input, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } rfl hinp + (fun i hi => by + show Parked (Function.update c.work q ((c.work q).move .left) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by rw [hupd]; exact hc0) + (fun j hj => by rw [hupd]; exact hcr j hj) + (by + show (Function.update c.work q ((c.work q).move .left) q).head = h + rw [Function.update_self] + show (c.work q).head - 1 = h + rw [hhead] + omega) + refine ⟨c', .step hstep₁ hreach, hst', hinp', ?_, ?_, hhead', hout'⟩ + Β· intro i hi + rw [hwork' i hi] + show Function.update c.work q ((c.work q).move .left) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [hcells', hupd] + +/-- **`incRegTM` Hoare specification.** From `regTape d` in register `q`, reach + `regTape (d + 1)` in `2d + 4` steps; the input, output, and every other work + tape are untouched. -/ +theorem incRegTM_hoareTime (q : Fin n) (d : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (ys : List Bool) (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  q β†’ Parked (workβ‚€ i)) + (hq : workβ‚€ q = regTape d) : + (incRegTM (n := n) q).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ q (regTape (d + 1))) ys) + (2 * d + 4) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c₁, hreach₁, hst₁, hinp₁, hwork₁, hcells₁, hhead₁, houtβ‚βŸ© := + incRegTM_scan_run d d 0 (by omega) + { state := .scan, input := inp, work := work, output := out } rfl + hinpβ‚€ hworkβ‚€ hout.parked + (by show (work q).cells = regCells d; rw [hq, regT_cells]) + (by show (work q).head = 0 + 1; rw [hq, regT_head]) + have hinpP₁ : Parked c₁.input := by rw [hinp₁]; exact hinpβ‚€ + have hworkP₁ : βˆ€ i, i β‰  q β†’ Parked (c₁.work i) := fun i hi => by + rw [hwork₁ i hi] + exact hworkβ‚€ i hi + have houtP₁ : Parked c₁.output := by rw [hout₁]; exact hout.parked + have hblank₁ : (c₁.work q).read = Ξ“.blank := by + rw [Tape.read, hhead₁, hcells₁] + exact regCells_blank (le_refl _) + have hstepβ‚‚ := incRegTM_step_scan_blank c₁ hst₁ hblank₁ hinpP₁ hworkP₁ houtP₁ + set wqβ‚‚ : Tape := ((c₁.work q).write Ξ“w.one).move .left with hwqβ‚‚ + have hwqβ‚‚cells : wqβ‚‚.cells = regCells (d + 1) := by + rw [hwqβ‚‚] + show ((c₁.work q).write Ξ“w.one).cells = _ + rw [Tape.write, ite_eq_right (by rw [hhead₁]; omega)] + show Function.update (c₁.work q).cells (c₁.work q).head Ξ“w.one.toΞ“ = _ + rw [hhead₁, hcells₁] + exact regCells_update_succ d + have hwqβ‚‚head : wqβ‚‚.head = d := by + rw [hwqβ‚‚] + show ((c₁.work q).write Ξ“w.one).head - 1 = d + rw [Tape.write_head, hhead₁] + omega + obtain ⟨c₃, hreach₃, hst₃, hinp₃, hwork₃, hcells₃, hhead₃, houtβ‚ƒβŸ© := + incRegTM_back_run d + { state := .back, input := c₁.input, + work := Function.update c₁.work q wqβ‚‚, + output := c₁.output } rfl hinpP₁ + (fun i hi => by + show Parked (Function.update c₁.work q wqβ‚‚ i) + rw [Function.update_of_ne hi] + exact hworkP₁ i hi) + houtP₁ + (by + show (Function.update c₁.work q wqβ‚‚ q).cells 0 = Ξ“.start + rw [Function.update_self, hwqβ‚‚cells] + rfl) + (fun j hj => by + show (Function.update c₁.work q wqβ‚‚ q).cells j β‰  Ξ“.start + rw [Function.update_self, hwqβ‚‚cells] + exact (reg_regT (d + 1)).cells_ne_start hj) + (by + show (Function.update c₁.work q wqβ‚‚ q).head = d + rw [Function.update_self, hwqβ‚‚head]) + refine ⟨c₃, d + ((d + 2) + 1), by omega, + reachesIn_trans _ hreach₁ (.step hstepβ‚‚ hreach₃), hst₃, ?_, ?_, ?_⟩ + Β· rw [hinp₃]; exact hinp₁ + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [Function.update_self] + refine Tape.ext ?_ ?_ + Β· rw [hhead₃] + rfl + Β· rw [hcells₃] + show (Function.update c₁.work i wqβ‚‚ i).cells = _ + rw [Function.update_self, hwqβ‚‚cells, regT_cells] + Β· rw [Function.update_of_ne hir, hwork₃ i hir] + show Function.update c₁.work q wqβ‚‚ i = work i + rw [Function.update_of_ne hir] + exact hwork₁ i hir + Β· rw [hout₃, hout₁] + exact hout + +end IncReg + +-- ════════════════════════════════════════════════════════════════════════ +-- clearRegTM: blank a register +-- ════════════════════════════════════════════════════════════════════════ + +/-- Cells of a register holding `d` mid-clear: positions `1..k` blanked, + `k+1..d` still marked. -/ +def clearRegCells (d k : β„•) : β„• β†’ Ξ“ := fun j => + if j = 0 then Ξ“.start + else if j ≀ k then Ξ“.blank + else if j ≀ d then Ξ“.one + else Ξ“.blank + +/-- Before any blanking (`k = 0`), a mid-clear register is exactly `regCells d`. -/ +theorem clearCells_zero (d : β„•) : clearRegCells d 0 = regCells d := by + funext j + simp only [clearRegCells, regCells] + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rfl + Β· rw [ite_eq_right (show Β¬ j = 0 from by omega), ite_eq_right (show Β¬ j ≀ 0 from by omega), + ite_eq_right (show Β¬ j = 0 from by omega)] + +/-- After blanking all `d` marks (`k = d`), a mid-clear register is `regCells 0`. -/ +theorem clearCells_last (d : β„•) : clearRegCells d d = regCells 0 := by + funext j + simp only [clearRegCells, regCells] + rcases Nat.eq_zero_or_pos j with rfl | hj + Β· rfl + Β· rw [ite_eq_right (show Β¬ j = 0 from by omega), ite_eq_right (show Β¬ j = 0 from by omega), + ite_eq_right (show Β¬ j ≀ 0 from by omega)] + by_cases hd : j ≀ d + Β· rw [ite_eq_left hd] + Β· rw [ite_eq_right hd, ite_eq_right hd] + +/-- No mid-clear cell at position `j β‰₯ 1` is the `β–·` sentinel. -/ +theorem clearCells_ne_start {d k j : β„•} (hj : 1 ≀ j) : + clearRegCells d k j β‰  Ξ“.start := by + simp only [clearRegCells] + rw [ite_eq_right (show Β¬ j = 0 from by omega)] + split + Β· decide + Β· split <;> decide + +/-- Blanking cell `k + 1` of `clearRegCells d k` advances the sweep to + `clearRegCells d (k + 1)`. -/ +theorem clearCells_update_succ (d k : β„•) : + Function.update (clearRegCells d k) (k + 1) Ξ“.blank = clearRegCells d (k + 1) := by + funext j + rw [Function.update_apply] + by_cases hj : j = k + 1 + Β· subst hj + rw [ite_eq_left rfl] + show Ξ“.blank = clearRegCells d (k + 1) (k + 1) + simp only [clearRegCells] + rw [ite_eq_right (show Β¬ k + 1 = 0 from by omega), ite_eq_left (le_refl (k + 1))] + Β· rw [ite_eq_right hj] + simp only [clearRegCells] + rcases Nat.eq_zero_or_pos j with rfl | hj1 + Β· rfl + Β· rcases Nat.lt_or_ge j (k + 1) with hlt | hge + Β· rw [ite_eq_right (show Β¬ j = 0 from by omega), ite_eq_right (show Β¬ j = 0 from by omega), + ite_eq_left (show j ≀ k from by omega), ite_eq_left (show j ≀ k + 1 from by omega)] + Β· rw [ite_eq_right (show Β¬ j = 0 from by omega), ite_eq_right (show Β¬ j = 0 from by omega), + ite_eq_right (show Β¬ j ≀ k from by omega), ite_eq_right (show Β¬ j ≀ k + 1 from by omega)] + +/-- **Clear register `q`**: sweep right blanking the marks, rewind to cell 1. + From `regTape d` to `regTape 0` in `2d + 4` steps; every other tape untouched. -/ +def clearRegTM (q : Fin n) : TM n where + Q := IncPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun s iHead wHeads oHead => + match s with + | .scan => + if wHeads q = Ξ“.one then + (.scan, fun i => if i = q then Ξ“w.blank else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = q then (if wHeads q = Ξ“.start then Dir3.right else Dir3.left) + else idleDir (wHeads i), + idleDir oHead) + | .back => + if wHeads q = Ξ“.start then + (.park, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = q then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.back, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => if i = q then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .park => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle s iHead wHeads oHead + Ξ΄_right_of_start := by + intro s iHead wHeads oHead + match s with + | .scan => + dsimp only [] + split + Β· next hone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; rw [hone] at hi; exact absurd hi (by decide) + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hnone => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; rw [ite_eq_left rfl, ite_eq_left hi] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .back => + dsimp only [] + split + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· rw [ite_eq_left hir] + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + Β· next hns => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only [] + by_cases hir : i = q + Β· subst hir; exact absurd hi hns + Β· rw [ite_eq_right hir]; exact idleDir_right_of_start hi + | .park => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +section ClearReg + +variable {q : Fin n} + +private theorem clearRegTM_ne_halt {s : IncPhase} (h : s β‰  .done) + {c : Cfg n (clearRegTM (n := n) q).Q} (hst : c.state = s) : + Β¬ c.state = (clearRegTM (n := n) q).qhalt := by + rw [hst] + show Β¬ s = IncPhase.done + exact h + +/-- `scan` over a mark: blank it and advance. -/ +private theorem clearRegTM_step_scan_one (c : Cfg n (clearRegTM (n := n) q).Q) + (hst : c.state = .scan) (hone : (c.work q).read = Ξ“.one) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (clearRegTM (n := n) q).step c = some + { state := .scan, input := c.input, + work := Function.update c.work q + (((c.work q).write Ξ“w.blank).move .right), + output := c.output } := by + rw [TM.step, ite_eq_right (clearRegTM_ne_halt (by decide) hst)] + simp only [clearRegTM, hst, hone, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + simp only [↓reduceIte, Function.update_self] + Β· rw [ite_eq_right hir, ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `scan` at the first blank: turn around (no write). -/ +private theorem clearRegTM_step_scan_blank (c : Cfg n (clearRegTM (n := n) q).Q) + (hst : c.state = .scan) (hblank : (c.work q).read = Ξ“.blank) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (clearRegTM (n := n) q).step c = some + { state := .back, input := c.input, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (clearRegTM_ne_halt (by decide) hst)] + simp only [clearRegTM, hst, hblank, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + simp only [↓reduceIte, Function.update_self] + rw [writeAndMove_readBack _ (by rw [hblank]; decide)] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` off the sentinel: keep rewinding. -/ +private theorem clearRegTM_step_back_left (c : Cfg n (clearRegTM (n := n) q).Q) + (hst : c.state = .back) (hns : (c.work q).read β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (clearRegTM (n := n) q).step c = some + { state := .back, input := c.input, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } := by + rw [TM.step, ite_eq_right (clearRegTM_ne_halt (by decide) hst)] + simp only [clearRegTM, hst, hns, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self, writeAndMove_readBack _ hns] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `back` on the sentinel: step right to cell 1 and park. -/ +private theorem clearRegTM_step_back_start (c : Cfg n (clearRegTM (n := n) q).Q) + (hst : c.state = .back) (hs : (c.work q).read = Ξ“.start) + (hcr : βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) + (hinp : Parked c.input) (hwork : βˆ€ i, i β‰  q β†’ Parked (c.work i)) + (hout : Parked c.output) : + (clearRegTM (n := n) q).step c = some + { state := .park, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } := by + have h0 : (c.work q).head = 0 := by + by_contra hc + exact hcr _ (by omega) hs + rw [TM.step, ite_eq_right (clearRegTM_ne_halt (by decide) hst)] + simp only [clearRegTM, hst, hs, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [ite_eq_left rfl, Function.update_self] + show ((c.work i).write _).move Dir3.right = (c.work i).move .right + congr 1 + rw [Tape.write, ite_eq_left h0] + Β· rw [ite_eq_right hir, Function.update_of_ne hir] + exact (hwork i hir).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- `park`: one idle step into `done`. -/ +private theorem clearRegTM_step_park (c : Cfg n (clearRegTM (n := n) q).Q) + (hst : c.state = .park) (hinp : Parked c.input) (hwork : βˆ€ i, Parked (c.work i)) + (hout : Parked c.output) : + (clearRegTM (n := n) q).step c = some + { state := .done, input := c.input, work := c.work, output := c.output } := by + rw [TM.step, ite_eq_right (clearRegTM_ne_halt (by decide) hst)] + simp only [clearRegTM, hst] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + +/-- The clearing sweep: from `scan` at head `k + 1` over `clearRegCells d k`, + blank the remaining `d - k` marks. -/ +private theorem clearRegTM_scan_run (d m : β„•) : + βˆ€ (k : β„•), d = k + m β†’ + βˆ€ (c : Cfg n (clearRegTM (n := n) q).Q), + c.state = .scan β†’ Parked c.input β†’ (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ + Parked c.output β†’ + (c.work q).cells = clearRegCells d k β†’ (c.work q).head = k + 1 β†’ + βˆƒ c', (clearRegTM (n := n) q).reachesIn m c c' ∧ + c'.state = .scan ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = clearRegCells d d ∧ (c'.work q).head = d + 1 ∧ + c'.output = c.output := by + induction m with + | zero => + intro k hk c hst hinp hwork hout hcells hhead + obtain rfl : k = d := by omega + exact ⟨c, .zero, hst, rfl, fun _ _ => rfl, hcells, hhead, rfl⟩ + | succ m ih => + intro k hk c hst hinp hwork hout hcells hhead + have hone : (c.work q).read = Ξ“.one := by + rw [Tape.read, hhead, hcells, clearRegCells, ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_left (by omega)] + have hstep := clearRegTM_step_scan_one c hst hone hinp hwork hout + set wq₁ : Tape := ((c.work q).write Ξ“w.blank).move .right with hwq₁ + have hwq₁cells : wq₁.cells = clearRegCells d (k + 1) := by + rw [hwq₁] + show ((c.work q).write Ξ“w.blank).cells = _ + rw [Tape.write, ite_eq_right (by rw [hhead]; omega)] + show Function.update (c.work q).cells (c.work q).head Ξ“w.blank.toΞ“ = _ + rw [hhead, hcells] + exact clearCells_update_succ d k + have hwq₁head : wq₁.head = (k + 1) + 1 := by + rw [hwq₁] + show ((c.work q).write Ξ“w.blank).head + 1 = _ + rw [Tape.write_head, hhead] + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih (k + 1) (by omega) + { state := .scan, input := c.input, + work := Function.update c.work q wq₁, + output := c.output } rfl hinp + (fun i hi => by + show Parked (Function.update c.work q wq₁ i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by + show (Function.update c.work q wq₁ q).cells = _ + rw [Function.update_self, hwq₁cells]) + (by + show (Function.update c.work q wq₁ q).head = _ + rw [Function.update_self, hwq₁head]) + refine ⟨c', .step hstep hreach, hst', hinp', ?_, hcells', hhead', hout'⟩ + intro i hi + rw [hwork' i hi] + show Function.update c.work q wq₁ i = c.work i + rw [Function.update_of_ne hi] + +/-- The rewind loop (identical shape to `incRegTM`'s). -/ +private theorem clearRegTM_back_run (h : β„•) : + βˆ€ (c : Cfg n (clearRegTM (n := n) q).Q), + c.state = .back β†’ Parked c.input β†’ (βˆ€ i, i β‰  q β†’ Parked (c.work i)) β†’ + Parked c.output β†’ + (c.work q).cells 0 = Ξ“.start β†’ + (βˆ€ j, 1 ≀ j β†’ (c.work q).cells j β‰  Ξ“.start) β†’ + (c.work q).head = h β†’ + βˆƒ c', (clearRegTM (n := n) q).reachesIn (h + 2) c c' ∧ + c'.state = .done ∧ c'.input = c.input ∧ + (βˆ€ i, i β‰  q β†’ c'.work i = c.work i) ∧ + (c'.work q).cells = (c.work q).cells ∧ (c'.work q).head = 1 ∧ + c'.output = c.output := by + induction h with + | zero => + intro c hst hinp hwork hout hc0 hcr hhead + have hs : (c.work q).read = Ξ“.start := by rw [Tape.read, hhead]; exact hc0 + have hstep₁ := clearRegTM_step_back_start c hst hs hcr hinp hwork hout + have hworkP : βˆ€ i, Parked (Function.update c.work q ((c.work q).move .right) i) := by + intro i + by_cases hir : i = q + Β· subst hir + rw [Function.update_self] + exact ⟨by show (c.work i).head + 1 β‰₯ 1; omega, fun j hj => hcr j hj⟩ + Β· rw [Function.update_of_ne hir] + exact hwork i hir + have hstepβ‚‚ := clearRegTM_step_park (q := q) + { state := .park, input := c.input, + work := Function.update c.work q ((c.work q).move .right), + output := c.output } rfl hinp hworkP hout + refine ⟨_, .step hstep₁ (.step hstepβ‚‚ .zero), rfl, rfl, ?_, ?_, ?_, rfl⟩ + Β· intro i hi + show Function.update c.work q ((c.work q).move .right) i = c.work i + rw [Function.update_of_ne hi] + Β· show (Function.update c.work q ((c.work q).move .right) q).cells = _ + rw [Function.update_self] + rfl + Β· show (Function.update c.work q ((c.work q).move .right) q).head = 1 + rw [Function.update_self] + show (c.work q).head + 1 = 1 + rw [hhead] + | succ h ih => + intro c hst hinp hwork hout hc0 hcr hhead + have hns : (c.work q).read β‰  Ξ“.start := by + rw [Tape.read, hhead]; exact hcr (h + 1) (by omega) + have hstep₁ := clearRegTM_step_back_left c hst hns hinp hwork hout + have hupd : (Function.update c.work q ((c.work q).move .left) q).cells + = (c.work q).cells := by + rw [Function.update_self] + rfl + obtain ⟨c', hreach, hst', hinp', hwork', hcells', hhead', hout'⟩ := + ih { state := .back, input := c.input, + work := Function.update c.work q ((c.work q).move .left), + output := c.output } rfl hinp + (fun i hi => by + show Parked (Function.update c.work q ((c.work q).move .left) i) + rw [Function.update_of_ne hi] + exact hwork i hi) + hout + (by rw [hupd]; exact hc0) + (fun j hj => by rw [hupd]; exact hcr j hj) + (by + show (Function.update c.work q ((c.work q).move .left) q).head = h + rw [Function.update_self] + show (c.work q).head - 1 = h + rw [hhead] + omega) + refine ⟨c', .step hstep₁ hreach, hst', hinp', ?_, ?_, hhead', hout'⟩ + Β· intro i hi + rw [hwork' i hi] + show Function.update c.work q ((c.work q).move .left) i = c.work i + rw [Function.update_of_ne hi] + Β· rw [hcells', hupd] + +/-- **`clearRegTM` Hoare specification.** From `regTape d` in register `q`, reach + `regTape 0` in `2d + 4` steps; everything else untouched. -/ +theorem clearRegTM_hoareTime (q : Fin n) (d : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (ys : List Bool) (hinpβ‚€ : Parked inpβ‚€) (hworkβ‚€ : βˆ€ i, i β‰  q β†’ Parked (workβ‚€ i)) + (hq : workβ‚€ q = regTape d) : + (clearRegTM (n := n) q).HoareTime + (EmitPred inpβ‚€ workβ‚€ ys) + (EmitPred inpβ‚€ (Function.update workβ‚€ q (regTape 0)) ys) + (2 * d + 4) := by + rintro inp work out ⟨rfl, rfl, hout⟩ + obtain ⟨c₁, hreach₁, hst₁, hinp₁, hwork₁, hcells₁, hhead₁, houtβ‚βŸ© := + clearRegTM_scan_run d d 0 (by omega) + { state := .scan, input := inp, work := work, output := out } rfl + hinpβ‚€ hworkβ‚€ hout.parked + (by show (work q).cells = clearRegCells d 0; rw [hq, regT_cells, clearCells_zero]) + (by show (work q).head = 0 + 1; rw [hq, regT_head]) + have hinpP₁ : Parked c₁.input := by rw [hinp₁]; exact hinpβ‚€ + have hworkP₁ : βˆ€ i, i β‰  q β†’ Parked (c₁.work i) := fun i hi => by + rw [hwork₁ i hi] + exact hworkβ‚€ i hi + have houtP₁ : Parked c₁.output := by rw [hout₁]; exact hout.parked + have hblank₁ : (c₁.work q).read = Ξ“.blank := by + rw [Tape.read, hhead₁, hcells₁, clearCells_last] + exact regCells_blank (by omega) + have hstepβ‚‚ := clearRegTM_step_scan_blank c₁ hst₁ hblank₁ hinpP₁ hworkP₁ houtP₁ + have hupdβ‚‚ : (Function.update c₁.work q ((c₁.work q).move .left) q).cells + = regCells 0 := by + rw [Function.update_self] + show (c₁.work q).cells = _ + rw [hcells₁, clearCells_last] + obtain ⟨c₃, hreach₃, hst₃, hinp₃, hwork₃, hcells₃, hhead₃, houtβ‚ƒβŸ© := + clearRegTM_back_run d + { state := .back, input := c₁.input, + work := Function.update c₁.work q ((c₁.work q).move .left), + output := c₁.output } rfl hinpP₁ + (fun i hi => by + show Parked (Function.update c₁.work q ((c₁.work q).move .left) i) + rw [Function.update_of_ne hi] + exact hworkP₁ i hi) + houtP₁ + (by rw [hupdβ‚‚]; rfl) + (fun j hj => by rw [hupdβ‚‚]; exact (reg_regT 0).cells_ne_start hj) + (by + show (Function.update c₁.work q ((c₁.work q).move .left) q).head = d + rw [Function.update_self] + show (c₁.work q).head - 1 = d + rw [hhead₁] + omega) + refine ⟨c₃, d + ((d + 2) + 1), by omega, + reachesIn_trans _ hreach₁ (.step hstepβ‚‚ hreach₃), hst₃, ?_, ?_, ?_⟩ + Β· rw [hinp₃]; exact hinp₁ + Β· funext i + by_cases hir : i = q + Β· subst hir + rw [Function.update_self] + refine Tape.ext ?_ ?_ + Β· rw [hhead₃] + rfl + Β· rw [hcells₃] + show (Function.update c₁.work i ((c₁.work i).move .left) i).cells = _ + rw [hupdβ‚‚, regT_cells] + Β· rw [Function.update_of_ne hir, hwork₃ i hir] + show Function.update c₁.work q ((c₁.work q).move .left) i = work i + rw [Function.update_of_ne hir] + exact hwork₁ i hir + Β· rw [hout₃, hout₁] + exact hout + +end ClearReg + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime.lean new file mode 100644 index 0000000000..4245eed95d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal.lean new file mode 100644 index 0000000000..b447c0be66 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.SpaceTime.Internal.Reachability + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal/Reachability.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal/Reachability.lean new file mode 100644 index 0000000000..25f3247684 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/SpaceTime/Internal/Reachability.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine + +/-! +# Exact-run decomposition β€” proof internals + +These small deterministic-run lemmas expose configurations at chosen time +indices. They support the finite reduced-configuration argument without adding +execution choices to the machine model. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Split an exact run at a prescribed prefix length. -/ +theorem reachesIn_split_internal {tm : TM n} {a b : β„•} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn (a + b) c c') : + βˆƒ d, tm.reachesIn a c d ∧ tm.reachesIn b d c' := by + induction a generalizing c with + | zero => + exact ⟨c, .zero, by simpa using hreach⟩ + | succ a ih => + have hlength : Nat.succ a + b = (a + b) + 1 := by omega + rw [hlength] at hreach + cases hreach with + | step hstep hrest => + obtain ⟨d, hprefix, hsuffix⟩ := ih hrest + exact ⟨d, .step hstep hprefix, hsuffix⟩ + +/-- Expose the configuration at time `i` of an exact `t`-step run. -/ +theorem reachesIn_prefix_internal {tm : TM n} {t i : β„•} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn t c c') (hi : i ≀ t) : + βˆƒ d, tm.reachesIn i c d ∧ tm.reachesIn (t - i) d c' := by + have hlength : i + (t - i) = t := Nat.add_sub_of_le hi + rw [← hlength] at hreach + exact reachesIn_split_internal hreach + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines.lean new file mode 100644 index 0000000000..7ffa37d18e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines.lean @@ -0,0 +1,482 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# TM Subroutines + +Small concrete Turing machines used as composable building blocks for +constructing larger machines via `seqTM`, `ifTM`, and `loopTM`. + +Subroutine correctness theorems live in the proof modules under +`Complexitylib.Models.TuringMachine.Subroutines.Internal`; reusable public +statements are re-exported by focused surface modules when needed. + +## Main definitions + +- `TM.writeTM` β€” write a symbol to output cell 1 and halt +- `TM.rewindWorkTM` β€” rewind a work tape head to cell 1 +- `TM.rewindInputTM` β€” rewind the input tape head to cell 1 +- `TM.scanRightTM` β€” scan a work tape right until blank +- `TM.blankWorkTM` β€” blank a started work tape while scanning right +- `TM.clearWorkTM` β€” blank a started work tape and rewind it to cell 1 +- `TM.copyInputToWorkTM` β€” copy input tape contents to a work tape +- `TM.copyInputToOutputTM` β€” copy input tape contents to the output tape +- `TM.copyWorkToWorkTM` β€” copy one work tape's contents to another +- `TM.compareWorkTapesTM` β€” compare two work tapes cell by cell +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: write a symbol to output cell 1 and halt +-- ════════════════════════════════════════════════════════════════════════ + +/-- State space of `writeTM`: rewind the output head to `β–·`, step right to +cell 1, write the symbol, then halt. -/ +inductive WritePhase where + | rewind | goRight | write | done + deriving DecidableEq + +instance : Fintype WritePhase where + elems := {.rewind, .goRight, .write, .done} + complete := fun x => by cases x <;> simp + +/-- Write `sym` to output cell 1 and halt. + Phases: rewind output to β–· β†’ move right to cell 1 β†’ write β†’ halt. -/ +def writeTM (sym : Ξ“w) : TM n where + Q := WritePhase + qstart := .rewind + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .rewind => + if oHead = Ξ“.start then + (.goRight, fun _ => .blank, .blank, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.right) + else + (.rewind, fun _ => .blank, readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.left) + | .goRight => + (.write, fun _ => .blank, .blank, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .write => + (.done, fun _ => .blank, sym, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .rewind => + dsimp only []; split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + Β· refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .goRight => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .write => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- `writeTM` specialized to write `Ξ“w.one` to output cell 1 (accept). -/ +abbrev writeOneTM : TM n := writeTM .one + +/-- `writeTM` specialized to write `Ξ“w.zero` to output cell 1 (reject). -/ +abbrev writeZeroTM : TM n := writeTM .zero + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rewind a work tape to cell 1 +-- ════════════════════════════════════════════════════════════════════════ + +/-- State space of `rewindWorkTM`/`rewindInputTM`: move the head left until it +reads `β–·`, then move right once to land on cell 1 and halt. -/ +inductive RewindPhase where + | moveLeft | moveRight | done + deriving DecidableEq + +instance : Fintype RewindPhase where + elems := {.moveLeft, .moveRight, .done} + complete := fun x => by cases x <;> simp + +/-- Rewind work tape `idx` to cell 1 (first data cell after β–·). -/ +def rewindWorkTM (idx : Fin n) : TM n where + Q := RewindPhase + qstart := .moveLeft + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .moveLeft => + if wHeads idx = Ξ“.start then + (.moveRight, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.moveLeft, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .moveRight => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .moveLeft => + dsimp only []; split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rfl + Β· exact idleDir_right_of_start hwi + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rename_i heq; subst heq; contradiction + Β· exact idleDir_right_of_start hwi + | .moveRight => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindInputTM: rewind the input tape to cell 1 +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind the input tape to cell 1 (first data cell after β–·). Work and + output tapes are only written with `readBackWrite`, so their contents are + preserved under the usual no-start-under-head side conditions. -/ +def rewindInputTM : TM n where + Q := RewindPhase + qstart := .moveLeft + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .moveLeft => + if iHead = Ξ“.start then + (.moveRight, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + else + (.moveLeft, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, moveLeftDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + | .moveRight => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .moveLeft => + dsimp only []; split + Β· refine ⟨fun _ => rfl, ?_, idleDir_right_of_start⟩ + intro i hwi + exact idleDir_right_of_start hwi + Β· rename_i hne + refine ⟨?_, ?_, idleDir_right_of_start⟩ + Β· intro hi; exact (hne hi).elim + Β· intro i hwi; exact idleDir_right_of_start hwi + | .moveRight => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- scanRightTM: scan a work tape right until blank +-- ════════════════════════════════════════════════════════════════════════ + +/-- State space of `scanRightTM`/`blankWorkTM`: scan right until reading +`Ξ“.blank`, then halt. -/ +inductive ScanPhase where + | scanning | done + deriving DecidableEq + +instance : Fintype ScanPhase where + elems := {.scanning, .done} + complete := fun x => by cases x <;> simp + +/-- Scan work tape `idx` right until finding `Ξ“.blank`. On canonical binary +tapes, its exact content- and frame-preserving behavior is specified by +`scanRightTM_reachesIn_frame` and `scanRightTM_hoareTime_frame`. -/ +def scanRightTM (idx : Fin n) : TM n where + Q := ScanPhase + qstart := .scanning + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scanning => + if wHeads idx = Ξ“.blank then + (.done, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.scanning, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => + (.done, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .scanning => + dsimp only []; split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rfl + Β· exact idleDir_right_of_start hwi + | .done => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- blankWorkTM: blank a work tape while scanning right +-- ════════════════════════════════════════════════════════════════════════ + +/-- Scan work tape `idx` right until finding `Ξ“.blank`, overwriting every +visited nonblank cell with `Ξ“.blank`. This consumes a started Boolean string +and leaves the tape blank to the right of the current head. -/ +def blankWorkTM (idx : Fin n) : TM n where + Q := ScanPhase + qstart := .scanning + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scanning => + if wHeads idx = Ξ“.blank then + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + else + (.scanning, + fun i => if i = idx then .blank else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .scanning => + dsimp only []; split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rfl + Β· exact idleDir_right_of_start hwi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Blank a started work tape and rewind it to cell `1`, yielding the standard +started blank tape shape. -/ +def clearWorkTM (idx : Fin n) : TM n := + seqTM (blankWorkTM idx) (rewindWorkTM idx) + +-- ════════════════════════════════════════════════════════════════════════ +-- copyInputToWorkTM: copy input tape to a work tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- State space shared by the input/work/output copy machines: copy symbols +rightward until the source reads `Ξ“.blank`, then halt. -/ +inductive CopyPhase where + | copying | done + deriving DecidableEq + +instance : Fintype CopyPhase where + elems := {.copying, .done} + complete := fun x => by cases x <;> simp + +/-- Copy input tape data to work tape `idx`. Reads input right, writes to work tape. + Stops when input reads `Ξ“.blank`. Skips β–· at cell 0. -/ +def copyInputToWorkTM (idx : Fin n) : TM n where + Q := CopyPhase + qstart := .copying + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .copying => + if iHead = Ξ“.blank then + allIdle .done iHead wHeads oHead + else + let w : Ξ“w := match iHead with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + (.copying, + fun i => if i = idx then w else .blank, + .blank, Dir3.right, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copying => + dsimp only []; split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· refine ⟨fun _ => rfl, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rfl + Β· exact idleDir_right_of_start hwi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Copy the Boolean input to the output tape while scanning both tapes +rightward. The first transition skips the left-end markers, each subsequent +nonblank input symbol is written to the output, and the machine halts at the +first input blank. Work-tape contents are preserved; heads reading the +left-end marker take their required one-cell rightward bounce. -/ +def copyInputToOutputTM : TM n where + Q := CopyPhase + qstart := .copying + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .copying => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.copying, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copying => + dsimp only [] + split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Copy the contents of work tape `src` to work tape `dst`. Reads `src` +right, writes the same bits to `dst`, and stops when `src` reads `Ξ“.blank`. +The source tape contents are preserved by writing the currently read symbol +back before moving right. -/ +def copyWorkToWorkTM (src dst : Fin n) : TM n where + Q := CopyPhase + qstart := .copying + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .copying => + if wHeads src = Ξ“.blank then + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + else + let w : Ξ“w := match wHeads src with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + (.copying, + fun i => if i = dst then w else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = dst then Dir3.right + else if i = src then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copying => + dsimp only []; split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi + simp only [] + split + Β· rfl + Β· split + Β· rfl + Β· exact idleDir_right_of_start hwi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWorkTapesTM: compare two work tapes cell by cell +-- ════════════════════════════════════════════════════════════════════════ + +/-- State space of `compareWorkTapesTM`: compare cells while both tapes agree, +ending in `matchDone` (equal) or `mismatch` (unequal) before halting. -/ +inductive ComparePhase where + | comparing | mismatch | matchDone | done + deriving DecidableEq + +instance : Fintype ComparePhase where + elems := {.comparing, .mismatch, .matchDone, .done} + complete := fun x => by cases x <;> simp + +/-- Compare work tapes `idx₁` and `idxβ‚‚` cell by cell. + Both advance right together. Stops when both read `Ξ“.blank`. + Writes `Ξ“.one` to output if match, `Ξ“.zero` if mismatch. + Assumes output head is at cell 1. -/ +def compareWorkTapesTM (idx₁ idxβ‚‚ : Fin n) : TM n where + Q := ComparePhase + qstart := .comparing + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .comparing => + if wHeads idx₁ = Ξ“.blank ∧ wHeads idxβ‚‚ = Ξ“.blank then + (.matchDone, fun _ => .blank, .one, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else if wHeads idx₁ = wHeads idxβ‚‚ then + (.comparing, + fun i => if i = idx₁ then readBackWrite (wHeads idx₁) + else if i = idxβ‚‚ then readBackWrite (wHeads idxβ‚‚) + else .blank, + .blank, idleDir iHead, + fun i => if i = idx₁ then Dir3.right + else if i = idxβ‚‚ then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + (.mismatch, fun _ => .blank, .zero, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .mismatch => allIdle .done iHead wHeads oHead + | .matchDone => allIdle .done iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .comparing => + dsimp only []; split + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + Β· split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + Β· rfl + Β· split + Β· rfl + Β· exact idleDir_right_of_start hwi + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .mismatch => exact rightOfStart_allIdle iHead wHeads oHead + | .matchDone => exact rightOfStart_allIdle iHead wHeads oHead + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst.lean new file mode 100644 index 0000000000..f1f3238697 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Tactic.Linarith +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Internal + +/-! +# Addition of a fixed natural to a canonical binary tape + +This module exposes the literal-frame and resource contracts for a finite +sequence of binary successors compiled from a hardwired natural constant. + +## Main results + +- `binaryAddConstTM_reachesIn_frame` gives the exact runtime and endpoint. +- `binaryAddConstTM_hoareTime_frame` packages the exact literal frame. +- `binaryAddConstTM_hoareTimeSpace_frame` gives a width-based prefix bound. +- `binaryAddConstTM_isTransducer` proves append-only-output safety. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Adding a fixed constant to zero has a quadratic time bound. -/ +theorem binaryAddConstTime_zero_le (fixedValue : β„•) : + binaryAddConstTime fixedValue 0 ≀ 4 * (fixedValue + 1) ^ 2 := by + induction fixedValue with + | zero => simp [binaryAddConstTime] + | succ fixedValue ih => + rw [binaryAddConstTime] + have hsucc := binarySuccTime_le fixedValue + have hsize : fixedValue.size ≀ fixedValue := by + rw [Nat.size_le] + exact Nat.lt_pow_self (by decide) + calc + binaryAddConstTime fixedValue 0 + 1 + + binarySuccTime (0 + fixedValue) ≀ + 4 * (fixedValue + 1) ^ 2 + 1 + (2 * fixedValue + 2) := by + simp only [Nat.zero_add] + exact Nat.add_le_add (Nat.add_le_add ih le_rfl) + (le_trans hsucc (by omega)) + _ ≀ 4 * (fixedValue + 1 + 1) ^ 2 := by nlinarith + +/-- Fixed-constant addition has the advertised exact runtime and changes only +the destination tape. -/ +theorem binaryAddConstTM_reachesIn_frame + (idx : Fin n) (fixedValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryAddConstTM idx fixedValue).reachesIn + (binaryAddConstTime fixedValue dstValue) + { state := (binaryAddConstTM idx fixedValue).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + { state := (binaryAddConstTM idx fixedValue).qhalt + input := inpβ‚€ + work := Function.update workβ‚€ idx + ((Tape.init ((dstValue + fixedValue).bits.map Ξ“.ofBool)).move + Dir3.right) + output := outβ‚€ } := + binaryAddConstTM_reachesIn_frame_internal idx fixedValue dstValue inpβ‚€ workβ‚€ + outβ‚€ hdst hinp hother hout + +/-- Time-bounded literal-frame contract for fixed-constant addition. -/ +theorem binaryAddConstTM_hoareTime_frame + (idx : Fin n) (fixedValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryAddConstTM idx fixedValue).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init ((dstValue + fixedValue).bits.map Ξ“.ofBool)).move + Dir3.right) ∧ + out = outβ‚€) + (binaryAddConstTime fixedValue dstValue) := + binaryAddConstTM_hoareTime_frame_internal idx fixedValue dstValue inpβ‚€ workβ‚€ + outβ‚€ hdst hinp hother hout + +/-- Every prefix of fixed-constant addition respects a bound controlled by +the final destination width. -/ +theorem binaryAddConstTM_hoareTimeSpace_frame + (idx : Fin n) (fixedValue dstValue inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hworkSpace : βˆ€ i, (workβ‚€ i).head ≀ initialSpace) + (hinputSpace : inpβ‚€.head ≀ inputLength + initialSpace + 1) : + (binaryAddConstTM idx fixedValue).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init ((dstValue + fixedValue).bits.map Ξ“.ofBool)).move + Dir3.right) ∧ + out = outβ‚€) + (binaryAddConstTime fixedValue dstValue) inputLength + (binaryAddConstSpace initialSpace fixedValue dstValue) := + binaryAddConstTM_hoareTimeSpace_frame_internal idx fixedValue dstValue + inputLength initialSpace inpβ‚€ workβ‚€ outβ‚€ hdst hinp hother hout + hworkSpace hinputSpace + +/-- Fixed-constant addition never moves its output head left. -/ +theorem binaryAddConstTM_isTransducer (idx : Fin n) (fixedValue : β„•) : + (binaryAddConstTM idx fixedValue).IsTransducer := + binaryAddConstTM_isTransducer_internal idx fixedValue + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Defs.lean new file mode 100644 index 0000000000..afba95589f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Defs.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs + +/-! +# Addition of a fixed natural to a canonical binary tape β€” definitions + +A fixed constant is compiled into finitely many sequential applications of +canonical binary successor. No work tape is needed for the hardwired value, +so the construction preserves every tape except its destination. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Add a hardwired natural to one canonical binary work tape. -/ +def binaryAddConstTM {n : β„•} (idx : Fin n) : β„• β†’ TM n + | 0 => skipTM + | fixedValue + 1 => + seqTM (binaryAddConstTM idx fixedValue) (binarySuccTM idx) + +/-- Exact runtime of fixed-constant binary addition. -/ +def binaryAddConstTime (fixedValue dstValue : β„•) : β„• := + match fixedValue with + | 0 => 1 + | fixedValue + 1 => + binaryAddConstTime fixedValue dstValue + 1 + + binarySuccTime (dstValue + fixedValue) + +/-- All-prefix width-based space bound for fixed-constant addition. -/ +def binaryAddConstSpace + (initialSpace fixedValue dstValue : β„•) : β„• := + initialSpace + 2 * (dstValue + fixedValue).size + 3 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Internal.lean new file mode 100644 index 0000000000..828488f430 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryAddConst/Internal.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryAddConst.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc + +/-! +# Addition of a fixed natural to a canonical binary tape β€” proof internals + +The proof follows the definition-level finite successor chain. Exact runs +compose through `seqTM`; the all-prefix space induction uses the largest +destination width rather than the total successor-chain runtime. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Canonical parked tape encoding of a natural for constant addition. -/ +def binaryAddConstNatTape (value : β„•) : Tape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + +private theorem binaryAddConstNatTape_hasBinaryNat (value : β„•) : + (binaryAddConstNatTape value).HasBinaryNat value := + Tape.init_move_right_hasBinaryNat value + +private theorem binaryAddConstHasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem binaryAddConstNatTape_parked (value : β„•) : + Parked (binaryAddConstNatTape value) := + binaryAddConstHasBinaryNat_parked + (binaryAddConstNatTape_hasBinaryNat value) + +private def binaryAddConstWorkAt (work : Fin n β†’ Tape) (idx : Fin n) + (dstValue current : β„•) : Fin n β†’ Tape := + Function.update work idx (binaryAddConstNatTape (dstValue + current)) + +private theorem binaryAddConstWorkAt_target + (work : Fin n β†’ Tape) (idx : Fin n) (dstValue current : β„•) : + binaryAddConstWorkAt work idx dstValue current idx = + binaryAddConstNatTape (dstValue + current) := by + simp [binaryAddConstWorkAt] + +private theorem binaryAddConstWorkAt_other + (work : Fin n β†’ Tape) {idx i : Fin n} (hne : i β‰  idx) + (dstValue current : β„•) : + binaryAddConstWorkAt work idx dstValue current i = work i := by + simp [binaryAddConstWorkAt, hne] + +private theorem binaryAddConstWorkAt_target_hasBinaryNat + (work : Fin n β†’ Tape) (idx : Fin n) (dstValue current : β„•) : + (binaryAddConstWorkAt work idx dstValue current idx).HasBinaryNat + (dstValue + current) := by + rw [binaryAddConstWorkAt_target] + exact binaryAddConstNatTape_hasBinaryNat _ + +private theorem binaryAddConstWorkAt_parked + (work : Fin n β†’ Tape) (idx : Fin n) (dstValue current : β„•) + (hwork : βˆ€ i, Parked (work i)) : + βˆ€ i, Parked (binaryAddConstWorkAt work idx dstValue current i) := by + intro i + by_cases hi : i = idx + Β· subst i + rw [binaryAddConstWorkAt_target] + exact binaryAddConstNatTape_parked _ + Β· rw [binaryAddConstWorkAt_other work hi] + exact hwork i + +private theorem binaryAddConstWorkAt_zero_eq + (work : Fin n β†’ Tape) (idx : Fin n) (dstValue : β„•) + (hdst : (work idx).HasBinaryNat dstValue) : + binaryAddConstWorkAt work idx dstValue 0 = work := by + funext i + by_cases hi : i = idx + Β· subst i + rw [binaryAddConstWorkAt_target] + simpa [binaryAddConstNatTape] using hdst.eq_init_move_right.symm + Β· exact binaryAddConstWorkAt_other work hi dstValue 0 + +private theorem binaryAddConstWorkAt_succ_eq + (work : Fin n β†’ Tape) (idx : Fin n) (dstValue current : β„•) : + Function.update (binaryAddConstWorkAt work idx dstValue current) idx + (binaryAddConstNatTape (dstValue + current + 1)) = + binaryAddConstWorkAt work idx dstValue (current + 1) := by + funext i + by_cases hi : i = idx + Β· subst i + simp [binaryAddConstWorkAt, Nat.add_assoc] + Β· simp [binaryAddConstWorkAt, hi] + +private theorem binaryAddConstInitialWork_parked + (work : Fin n β†’ Tape) (idx : Fin n) {dstValue : β„•} + (hdst : (work idx).HasBinaryNat dstValue) + (hother : βˆ€ i, i β‰  idx β†’ Parked (work i)) : + βˆ€ i, Parked (work i) := by + intro i + by_cases hi : i = idx + Β· subst i + exact binaryAddConstHasBinaryNat_parked hdst + Β· exact hother i hi + +/-- Predicate fixing the tapes framing a constant-addition execution. -/ +abbrev binaryAddConstFramePred + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€ + +private theorem skipTM_reachesIn_frame + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp : Parked inp) (hwork : βˆ€ i, Parked (work i)) + (hout : Parked out) : + (skipTM (n := n)).reachesIn 1 + { state := (skipTM (n := n)).qstart + input := inp + work := work + output := out } + { state := (skipTM (n := n)).qhalt + input := inp + work := work + output := out } := by + have hstep : (skipTM (n := n)).step + { state := .go, input := inp, work := work, output := out } = some + { state := .done, input := inp, work := work, output := out } := by + simp only [TM.step, skipTM, reduceCtorEq, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact hinp.move_idle + Β· funext i + exact (hwork i).writeAndMove_readBack_idle + Β· exact hout.writeAndMove_readBack_idle + exact .step hstep .zero + +private theorem binaryAddConstSucc_reachesIn + (idx : Fin n) (dstValue current : β„•) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp : Parked inp) (hwork : βˆ€ i, Parked (work i)) + (hout : Parked out) : + (binarySuccTM idx).reachesIn (binarySuccTime (dstValue + current)) + { state := (binarySuccTM idx).qstart + input := inp + work := binaryAddConstWorkAt work idx dstValue current + output := out } + { state := (binarySuccTM idx).qhalt + input := inp + work := binaryAddConstWorkAt work idx dstValue (current + 1) + output := out } := by + have hworkAt := binaryAddConstWorkAt_parked work idx dstValue current hwork + obtain ⟨c', hreach, hhalt, hinput, hother, htarget, houtput⟩ := + binarySuccTM_reachesIn_frame idx (dstValue + current) inp + (binaryAddConstWorkAt work idx dstValue current) out + (binaryAddConstWorkAt_target_hasBinaryNat work idx dstValue current) + hinp.read_ne_start (fun i _ => (hworkAt i).read_ne_start) + hout.read_ne_start + have hworkEq : c'.work = + binaryAddConstWorkAt work idx dstValue (current + 1) := by + have hupdate : c'.work = Function.update + (binaryAddConstWorkAt work idx dstValue current) idx + (binaryAddConstNatTape (dstValue + current + 1)) := by + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + exact htarget.eq_init_move_right + Β· rw [Function.update_of_ne hi, hother i hi] + rw [hupdate, binaryAddConstWorkAt_succ_eq] + have hc' : c' = + { state := (binarySuccTM idx).qhalt + input := inp + work := binaryAddConstWorkAt work idx dstValue (current + 1) + output := out } := + Cfg.ext hhalt hinput hworkEq houtput + simpa [hc'] using hreach + +theorem binaryAddConstTM_reachesIn_frame_internal + (idx : Fin n) (fixedValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryAddConstTM idx fixedValue).reachesIn + (binaryAddConstTime fixedValue dstValue) + { state := (binaryAddConstTM idx fixedValue).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + { state := (binaryAddConstTM idx fixedValue).qhalt + input := inpβ‚€ + work := Function.update workβ‚€ idx + (binaryAddConstNatTape (dstValue + fixedValue)) + output := outβ‚€ } := by + have hwork := binaryAddConstInitialWork_parked workβ‚€ idx hdst hother + induction fixedValue with + | zero => + have hrun := skipTM_reachesIn_frame inpβ‚€ workβ‚€ outβ‚€ hinp hwork hout + simp only [binaryAddConstTM, binaryAddConstTime] + have heq : Function.update workβ‚€ idx + (binaryAddConstNatTape (dstValue + 0)) = workβ‚€ := by + simpa [binaryAddConstWorkAt] using + binaryAddConstWorkAt_zero_eq workβ‚€ idx dstValue hdst + rw [heq] + exact hrun + | succ fixedValue ih => + have hprev := ih + have hprevWork := binaryAddConstWorkAt_parked workβ‚€ idx dstValue + fixedValue hwork + have hnext := binaryAddConstSucc_reachesIn idx dstValue fixedValue inpβ‚€ + workβ‚€ outβ‚€ hinp hwork hout + have hnext' : (binarySuccTM idx).reachesIn + (binarySuccTime (dstValue + fixedValue)) + { state := (binarySuccTM idx).qstart + input := transitionInput inpβ‚€ + work := fun i => transitionTape + (binaryAddConstWorkAt workβ‚€ idx dstValue fixedValue i) + output := transitionTape outβ‚€ } + { state := (binarySuccTM idx).qhalt + input := inpβ‚€ + work := binaryAddConstWorkAt workβ‚€ idx dstValue (fixedValue + 1) + output := outβ‚€ } := by + simpa only [hinp.transitionInput_eq_self, + hout.transitionTape_eq_self, + funext fun i => (hprevWork i).transitionTape_eq_self] using hnext + have hseq := seqTM_reachesIn_of_reachesIn + (binaryAddConstTM idx fixedValue) (binarySuccTM idx) hprev rfl hnext' + simpa [binaryAddConstTM, binaryAddConstTime, binaryAddConstNatTape, + binaryAddConstWorkAt] using! hseq + +theorem binaryAddConstTM_hoareTime_frame_internal + (idx : Fin n) (fixedValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryAddConstTM idx fixedValue).HoareTime + (binaryAddConstFramePred inpβ‚€ workβ‚€ outβ‚€) + (binaryAddConstFramePred inpβ‚€ + (Function.update workβ‚€ idx + (binaryAddConstNatTape (dstValue + fixedValue))) outβ‚€) + (binaryAddConstTime fixedValue dstValue) := by + intro inp work out hpre + obtain ⟨hinput, hworkEq, houtput⟩ := hpre + subst inp + subst work + subst out + let c' : Cfg n (binaryAddConstTM idx fixedValue).Q := + { state := (binaryAddConstTM idx fixedValue).qhalt + input := inpβ‚€ + work := Function.update workβ‚€ idx + (binaryAddConstNatTape (dstValue + fixedValue)) + output := outβ‚€ } + refine ⟨c', binaryAddConstTime fixedValue dstValue, le_rfl, ?_, rfl, ?_⟩ + Β· exact binaryAddConstTM_reachesIn_frame_internal idx fixedValue dstValue + inpβ‚€ workβ‚€ outβ‚€ hdst hinp hother hout + Β· exact ⟨rfl, rfl, rfl⟩ + +private theorem binaryAddConstWorkAt_cfg_withinAuxSpace + {Q : Type} (state : Q) (inp : Tape) (work : Fin n β†’ Tape) + (out : Tape) (idx : Fin n) (dstValue current inputLength initialSpace : β„•) + (hdst : (work idx).HasBinaryNat dstValue) + (hworkSpace : βˆ€ i, (work i).head ≀ initialSpace) + (hinputSpace : inp.head ≀ inputLength + initialSpace + 1) : + ({ state := state + input := inp + work := binaryAddConstWorkAt work idx dstValue current + output := out } : Cfg n Q).WithinAuxSpace inputLength initialSpace := by + constructor + Β· intro i + change (binaryAddConstWorkAt work idx dstValue current i).head ≀ + initialSpace + by_cases hi : i = idx + Β· subst i + rw [binaryAddConstWorkAt_target, + (binaryAddConstNatTape_hasBinaryNat (dstValue + current)).2.1, + ← hdst.2.1] + exact hworkSpace idx + Β· rw [binaryAddConstWorkAt_other work hi] + exact hworkSpace i + Β· exact hinputSpace + +private theorem binaryAddConstFrame_transition + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + βˆ€ inp work out, binaryAddConstFramePred inpβ‚€ workβ‚€ outβ‚€ inp work out β†’ + binaryAddConstFramePred inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + rintro _ _ _ ⟨rfl, rfl, rfl⟩ + refine ⟨hinp.transitionInput_eq_self, ?_, hout.transitionTape_eq_self⟩ + funext i + exact (hwork i).transitionTape_eq_self + +theorem binaryAddConstTM_hoareTimeSpace_frame_internal + (idx : Fin n) (fixedValue dstValue inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hdst : (workβ‚€ idx).HasBinaryNat dstValue) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hworkSpace : βˆ€ i, (workβ‚€ i).head ≀ initialSpace) + (hinputSpace : inpβ‚€.head ≀ inputLength + initialSpace + 1) : + (binaryAddConstTM idx fixedValue).HoareTimeSpace + (binaryAddConstFramePred inpβ‚€ workβ‚€ outβ‚€) + (binaryAddConstFramePred inpβ‚€ + (Function.update workβ‚€ idx + (binaryAddConstNatTape (dstValue + fixedValue))) outβ‚€) + (binaryAddConstTime fixedValue dstValue) inputLength + (binaryAddConstSpace initialSpace fixedValue dstValue) := by + have hwork := binaryAddConstInitialWork_parked workβ‚€ idx hdst hother + induction fixedValue with + | zero => + have htime := binaryAddConstTM_hoareTime_frame_internal idx 0 dstValue + inpβ‚€ workβ‚€ outβ‚€ hdst hinp hother hout + have hrun := htime.toHoareTimeSpace (by + rintro _ _ _ ⟨rfl, rfl, rfl⟩ + constructor + Β· exact hworkSpace + Β· exact hinputSpace) + exact hrun.consequence (fun _ _ _ h => h) (fun _ _ _ h => h) + le_rfl le_rfl (by + simp [binaryAddConstSpace, binaryAddConstTime] + omega) + | succ fixedValue ih => + let midWork := binaryAddConstWorkAt workβ‚€ idx dstValue fixedValue + have hmidWork := binaryAddConstWorkAt_parked workβ‚€ idx dstValue + fixedValue hwork + have hmidTarget := binaryAddConstWorkAt_target_hasBinaryNat workβ‚€ idx + dstValue fixedValue + have hmidSpace : βˆ€ i, (midWork i).head ≀ initialSpace := by + have hcfg := binaryAddConstWorkAt_cfg_withinAuxSpace Unit.unit inpβ‚€ + workβ‚€ outβ‚€ idx dstValue fixedValue inputLength initialSpace hdst + hworkSpace hinputSpace + exact hcfg.1 + have hsucc := binarySuccTM_hoareTimeSpace_frame idx + (dstValue + fixedValue) inputLength initialSpace inpβ‚€ midWork outβ‚€ + (by simpa [midWork] using hmidTarget) hinp.read_ne_start + (fun i _ => (hmidWork i).read_ne_start) hout.read_ne_start + (by + constructor + Β· exact hmidSpace + Β· exact hinputSpace) + have hsucc' : (binarySuccTM idx).HoareTimeSpace + (binaryAddConstFramePred inpβ‚€ midWork outβ‚€) + (binaryAddConstFramePred inpβ‚€ + (binaryAddConstWorkAt workβ‚€ idx dstValue (fixedValue + 1)) outβ‚€) + (binarySuccTime (dstValue + fixedValue)) inputLength + (initialSpace + binarySuccTime (dstValue + fixedValue)) := by + refine hsucc.consequence (fun _ _ _ h => h) (fun inp work out h => ?_) + le_rfl le_rfl le_rfl + refine ⟨h.1, ?_, h.2.2.2⟩ + have hworkEq : work = Function.update midWork idx + (binaryAddConstNatTape (dstValue + fixedValue + 1)) := by + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + exact h.2.2.1.eq_init_move_right + Β· rw [Function.update_of_ne hi, h.2.1 i hi] + rw [hworkEq] + simpa [midWork] using + binaryAddConstWorkAt_succ_eq workβ‚€ idx dstValue fixedValue + have hseq := seqTM_hoareTimeSpace (binaryAddConstTM idx fixedValue) + (binarySuccTM idx) ih + (binaryAddConstFrame_transition inpβ‚€ midWork outβ‚€ hinp hmidWork hout) + hsucc' + refine hseq.consequence (fun _ _ _ h => h) (fun _ _ _ h => h) + (by simp [binaryAddConstTime]) le_rfl ?_ + have hprevSize : (dstValue + fixedValue).size ≀ + (dstValue + (fixedValue + 1)).size := + Nat.size_le_size (by omega) + have hsuccTime := binarySuccTime_le (dstValue + fixedValue) + simp [binaryAddConstSpace] at ⊒ + omega + +theorem binaryAddConstTM_isTransducer_internal + (idx : Fin n) (fixedValue : β„•) : + (binaryAddConstTM idx fixedValue).IsTransducer := by + induction fixedValue with + | zero => + intro state iHead wHeads oHead + cases state + all_goals + simp [binaryAddConstTM, skipTM, idleDir] + split <;> decide + | succ fixedValue ih => + simpa [binaryAddConstTM] using + ih.seqTM (binarySuccTM_isTransducer idx) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy.lean new file mode 100644 index 0000000000..a85d971d93 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Internal + +/-! +# Copying canonical binary naturals + +This module exposes a literal-frame copy operation assembled from work-tape +clearing and width-linear ripple addition. The source is preserved, the +destination becomes an exact copy, and the zero scratch is restored literally. + +## Main results + +- `TM.binaryCopyIntoTM_hoareTime_frame` gives the literal endpoint and time bound. +- `TM.binaryCopyIntoTM_hoareTimeSpace_frame` adds an all-prefix width bound. +- `TM.binaryCopyTime_le` exposes the linear operand-width envelope. +- `TM.binaryCopyIntoTM_isTransducer` proves append-only-output safety. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Canonical binary copying is linear in the source and old-destination +widths. -/ +theorem binaryCopyTime_le (srcValue dstValue : β„•) : + binaryCopyTime srcValue dstValue ≀ + 3 * srcValue.size + 2 * dstValue.size + 20 := + binaryCopyTime_le_internal srcValue dstValue + +/-- Binary copying changes only the destination tape. The source, zero +counter, input, output, and every unrelated work tape are preserved literally. -/ +theorem binaryCopyIntoTM_hoareTime_frame + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hsrcCounter : srcIdx β‰  counterIdx) + (hdstCounter : dstIdx β‰  counterIdx) + (srcValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrc : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hdst : (workβ‚€ dstIdx).HasBinaryNat dstValue) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  dstIdx β†’ i β‰  counterIdx β†’ + Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ dstIdx + ((Tape.init (srcValue.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + out = outβ‚€) + (binaryCopyTime srcValue dstValue) := + binaryCopyIntoTM_hoareTime_frame_internal srcIdx dstIdx counterIdx + hsrcDst hsrcCounter hdstCounter srcValue dstValue inpβ‚€ workβ‚€ outβ‚€ + hsrc hdst hcounter hinp hother hout + +/-- Time-and-space form of canonical binary copying. Every reachable +configuration stays within the maximum of the clearing and ripple-addition +bounds. -/ +theorem binaryCopyIntoTM_hoareTimeSpace_frame + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hsrcCounter : srcIdx β‰  counterIdx) + (hdstCounter : dstIdx β‰  counterIdx) + (srcValue dstValue inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrc : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hdst : (workβ‚€ dstIdx).HasBinaryNat dstValue) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  dstIdx β†’ i β‰  counterIdx β†’ + Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hworkSpace : βˆ€ i, (workβ‚€ i).head ≀ initialSpace) + (hinputSpace : inpβ‚€.head ≀ inputLength + initialSpace + 1) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ dstIdx + ((Tape.init (srcValue.bits.map Ξ“.ofBool)).move Dir3.right) ∧ + out = outβ‚€) + (binaryCopyTime srcValue dstValue) inputLength + (binaryCopySpace initialSpace srcValue dstValue) := + binaryCopyIntoTM_hoareTimeSpace_frame_internal srcIdx dstIdx counterIdx + hsrcDst hsrcCounter hdstCounter srcValue dstValue inputLength + initialSpace inpβ‚€ workβ‚€ outβ‚€ hsrc hdst hcounter hinp hother hout + hworkSpace hinputSpace + +/-- Canonical binary copying never moves the output head left. -/ +theorem binaryCopyIntoTM_isTransducer + (srcIdx dstIdx counterIdx : Fin n) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).IsTransducer := + binaryCopyIntoTM_isTransducer_internal srcIdx dstIdx counterIdx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Defs.lean new file mode 100644 index 0000000000..81170a9cd5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Defs.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs + +/-! +# Copying canonical binary naturals + +This definitions layer composes work-tape clearing with width-linear canonical +binary addition. The source and zero scratch tapes are preserved, while the +destination is replaced by an exact copy of the source. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Clear `dstIdx`, then copy the canonical binary natural on `srcIdx` into it. +The distinct `counterIdx` supplies the preserved zero operand to ripple +addition, and `dstIdx` is its fresh result tape. -/ +def binaryCopyIntoTM {n : β„•} + (srcIdx dstIdx counterIdx : Fin n) : TM n := + seqTM (clearWorkTM dstIdx) + (binaryRippleAddTM srcIdx counterIdx dstIdx) + +/-- Compositional running-time bound for canonical binary copying. -/ +def binaryCopyTime (srcValue dstValue : β„•) : β„• := + clearWorkTimeBound dstValue.size + 1 + binaryRippleAddTime srcValue 0 + +/-- All-prefix auxiliary-space bound for canonical binary copying. -/ +def binaryCopySpace (initialSpace srcValue dstValue : β„•) : β„• := + max (initialSpace + clearWorkTimeBound dstValue.size) + (initialSpace + binaryRippleAddTime srcValue 0) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Internal.lean new file mode 100644 index 0000000000..0a6a17c322 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryCopy/Internal.lean @@ -0,0 +1,314 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork + +/-! +# Copying canonical binary naturals -- proof internals + +The copy machine first clears its destination and then invokes width-linear +ripple addition with the source and zero counter as preserved operands. These +proofs compose the public literal-frame and all-prefix contracts of both +phases, then recover the original literal copy frame from canonicality. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Canonical parked tape encoding of a natural for binary copying. -/ +def binaryCopyNatTape (value : β„•) : Tape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + +private theorem binaryCopyNatTape_hasBinaryNat (value : β„•) : + (binaryCopyNatTape value).HasBinaryNat value := + Tape.init_move_right_hasBinaryNat value + +private theorem binaryCopyHasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : Parked t := by + refine ⟨by rw [h.2.1], ?_⟩ + exact Tape.HasBinaryContent.cells_ne_start h.2.2 + +private theorem binaryCopyNatTape_parked (value : β„•) : + Parked (binaryCopyNatTape value) := + binaryCopyHasBinaryNat_parked (binaryCopyNatTape_hasBinaryNat value) + +private theorem binaryCopyInitialWork_parked + (srcIdx dstIdx counterIdx : Fin n) (srcValue dstValue : β„•) + (workβ‚€ : Fin n β†’ Tape) + (hsrc : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hdst : (workβ‚€ dstIdx).HasBinaryNat dstValue) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  dstIdx β†’ i β‰  counterIdx β†’ + Parked (workβ‚€ i)) : + βˆ€ i, Parked (workβ‚€ i) := by + intro i + by_cases hsrcIdx : i = srcIdx + Β· subst i + exact binaryCopyHasBinaryNat_parked hsrc + by_cases hdstIdx : i = dstIdx + Β· subst i + exact binaryCopyHasBinaryNat_parked hdst + by_cases hcounterIdx : i = counterIdx + Β· subst i + exact binaryCopyHasBinaryNat_parked hcounter + exact hother i hsrcIdx hdstIdx hcounterIdx + +private def binaryCopyMidWork (workβ‚€ : Fin n β†’ Tape) (dstIdx : Fin n) : + Fin n β†’ Tape := + Function.update workβ‚€ dstIdx (binaryCopyNatTape 0) + +private theorem binaryCopyMidWork_parked + (workβ‚€ : Fin n β†’ Tape) (dstIdx : Fin n) + (hwork : βˆ€ i, Parked (workβ‚€ i)) : + βˆ€ i, Parked (binaryCopyMidWork workβ‚€ dstIdx i) := by + intro i + by_cases hi : i = dstIdx + Β· subst i + simp only [binaryCopyMidWork, Function.update_self] + exact binaryCopyNatTape_parked 0 + Β· rw [binaryCopyMidWork, Function.update_of_ne hi] + exact hwork i + +private theorem binaryCopyFrame_transition + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + transitionInput inp = inpβ‚€ ∧ + (fun i => transitionTape (work i)) = workβ‚€ ∧ + transitionTape out = outβ‚€ := by + rintro _ _ _ ⟨rfl, rfl, rfl⟩ + refine ⟨hinp.transitionInput_eq_self, ?_, hout.transitionTape_eq_self⟩ + funext i + exact (hwork i).transitionTape_eq_self + +private theorem binaryCopyDistinct + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hsrcCounter : srcIdx β‰  counterIdx) + (hdstCounter : dstIdx β‰  counterIdx) : + BinaryRippleAddDistinct srcIdx counterIdx dstIdx := + ⟨hsrcCounter, hsrcDst, hdstCounter.symm⟩ + +private theorem binaryCopyRipplePost_eq + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hdstCounter : dstIdx β‰  counterIdx) + (srcValue : β„•) (workβ‚€ work : Fin n β†’ Tape) + (hsrcβ‚€ : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hcounterβ‚€ : (workβ‚€ counterIdx).HasBinaryNat 0) + (hsrc : (work srcIdx).HasBinaryNat srcValue) + (hcounter : (work counterIdx).HasBinaryNat 0) + (hdst : (work dstIdx).HasBinaryNat srcValue) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  counterIdx β†’ i β‰  dstIdx β†’ + work i = binaryCopyMidWork workβ‚€ dstIdx i) : + work = Function.update workβ‚€ dstIdx (binaryCopyNatTape srcValue) := by + funext i + by_cases hdstIdx : i = dstIdx + Β· subst i + rw [Function.update_self] + simpa [binaryCopyNatTape] using hdst.eq_init_move_right + by_cases hsrcIdx : i = srcIdx + Β· subst i + rw [Function.update_of_ne hsrcDst] + exact hsrc.eq_init_move_right.trans hsrcβ‚€.eq_init_move_right.symm + by_cases hcounterIdx : i = counterIdx + Β· subst i + rw [Function.update_of_ne hdstCounter.symm] + exact hcounter.eq_init_move_right.trans hcounterβ‚€.eq_init_move_right.symm + rw [Function.update_of_ne hdstIdx] + simpa [binaryCopyMidWork, hdstIdx] using + hother i hsrcIdx hcounterIdx hdstIdx + +theorem binaryCopyTime_le_internal (srcValue dstValue : β„•) : + binaryCopyTime srcValue dstValue ≀ + 3 * srcValue.size + 2 * dstValue.size + 20 := by + have hadd := binaryRippleAddTime_le srcValue 0 + have hadd' : binaryRippleAddTime srcValue 0 ≀ + 3 * srcValue.size + 14 := by + simpa using hadd + simp only [binaryCopyTime, clearWorkTimeBound] + omega + +theorem binaryCopyIntoTM_hoareTime_frame_internal + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hsrcCounter : srcIdx β‰  counterIdx) + (hdstCounter : dstIdx β‰  counterIdx) + (srcValue dstValue : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrc : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hdst : (workβ‚€ dstIdx).HasBinaryNat dstValue) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  dstIdx β†’ i β‰  counterIdx β†’ + Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ dstIdx (binaryCopyNatTape srcValue) ∧ + out = outβ‚€) + (binaryCopyTime srcValue dstValue) := by + let midWork := binaryCopyMidWork workβ‚€ dstIdx + have hwork := binaryCopyInitialWork_parked srcIdx dstIdx counterIdx + srcValue dstValue workβ‚€ hsrc hdst hcounter hother + have hmidWork : βˆ€ i, Parked (midWork i) := by + exact binaryCopyMidWork_parked workβ‚€ dstIdx hwork + have hclear := clearWorkTM_hoareTime_frame dstIdx dstValue.bits + inpβ‚€ workβ‚€ outβ‚€ hdst.eq_init_move_right hinp + (fun i _ => hwork i) hout + have hclear' : (clearWorkTM dstIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = midWork ∧ out = outβ‚€) + (clearWorkTimeBound dstValue.size) := by + simpa [midWork, binaryCopyMidWork, binaryCopyNatTape, + Nat.size_eq_bits_len] using hclear + have hmidSrc : (midWork srcIdx).HasBinaryNat srcValue := by + simpa [midWork, binaryCopyMidWork, hsrcDst] using hsrc + have hmidDst : (midWork dstIdx).HasBinaryNat 0 := by + simpa [midWork, binaryCopyMidWork] using + binaryCopyNatTape_hasBinaryNat 0 + have hmidCounter : (midWork counterIdx).HasBinaryNat 0 := by + simpa [midWork, binaryCopyMidWork, hdstCounter.symm] using hcounter + have hdistinct := binaryCopyDistinct srcIdx dstIdx counterIdx + hsrcDst hsrcCounter hdstCounter + have hadd := binaryRippleAddTM_hoareTime_frame + srcIdx counterIdx dstIdx hdistinct srcValue 0 inpβ‚€ midWork outβ‚€ + hmidSrc hmidCounter hmidDst hinp + (fun i _ _ _ => hmidWork i) hout + have hseq := seqTM_hoareTime (clearWorkTM dstIdx) + (binaryRippleAddTM srcIdx counterIdx dstIdx) hclear' + (binaryCopyFrame_transition inpβ‚€ midWork outβ‚€ hinp hmidWork hout) + hadd + apply hseq.consequence (b' := binaryCopyTime srcValue dstValue) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hinput, hfinalSrc, hfinalCounter, hfinalDst, + hfinalOther, houtput⟩ + exact ⟨hinput, binaryCopyRipplePost_eq srcIdx dstIdx counterIdx + hsrcDst hdstCounter srcValue workβ‚€ work hsrc hcounter + hfinalSrc hfinalCounter (by simpa using hfinalDst) (by + intro i hiSrc hiCounter hiDst + exact hfinalOther i hiSrc hiCounter hiDst), houtput⟩ + Β· simp [binaryCopyTime] + +theorem binaryCopyIntoTM_hoareTimeSpace_frame_internal + (srcIdx dstIdx counterIdx : Fin n) + (hsrcDst : srcIdx β‰  dstIdx) (hsrcCounter : srcIdx β‰  counterIdx) + (hdstCounter : dstIdx β‰  counterIdx) + (srcValue dstValue inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrc : (workβ‚€ srcIdx).HasBinaryNat srcValue) + (hdst : (workβ‚€ dstIdx).HasBinaryNat dstValue) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat 0) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  srcIdx β†’ i β‰  dstIdx β†’ i β‰  counterIdx β†’ + Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hworkSpace : βˆ€ i, (workβ‚€ i).head ≀ initialSpace) + (hinputSpace : inpβ‚€.head ≀ inputLength + initialSpace + 1) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ dstIdx (binaryCopyNatTape srcValue) ∧ + out = outβ‚€) + (binaryCopyTime srcValue dstValue) inputLength + (binaryCopySpace initialSpace srcValue dstValue) := by + let midWork := binaryCopyMidWork workβ‚€ dstIdx + have hwork := binaryCopyInitialWork_parked srcIdx dstIdx counterIdx + srcValue dstValue workβ‚€ hsrc hdst hcounter hother + have hmidWork : βˆ€ i, Parked (midWork i) := by + exact binaryCopyMidWork_parked workβ‚€ dstIdx hwork + have hinitial : + ({ state := (clearWorkTM dstIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (clearWorkTM dstIdx).Q).WithinAuxSpace + inputLength initialSpace := + ⟨hworkSpace, hinputSpace⟩ + have hclear := clearWorkTM_hoareTimeSpace_frame dstIdx dstValue.bits + inputLength initialSpace inpβ‚€ workβ‚€ outβ‚€ + hdst.eq_init_move_right hinp (fun i _ => hwork i) hout hinitial + have hclear' : (clearWorkTM dstIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = midWork ∧ out = outβ‚€) + (clearWorkTimeBound dstValue.size) inputLength + (initialSpace + clearWorkTimeBound dstValue.size) := by + simpa [midWork, binaryCopyMidWork, binaryCopyNatTape, + Nat.size_eq_bits_len] using hclear + have hmidSrc : (midWork srcIdx).HasBinaryNat srcValue := by + simpa [midWork, binaryCopyMidWork, hsrcDst] using hsrc + have hmidDst : (midWork dstIdx).HasBinaryNat 0 := by + simpa [midWork, binaryCopyMidWork] using + binaryCopyNatTape_hasBinaryNat 0 + have hmidCounter : (midWork counterIdx).HasBinaryNat 0 := by + simpa [midWork, binaryCopyMidWork, hdstCounter.symm] using hcounter + have hone : 1 ≀ initialSpace := by + have h := hworkSpace srcIdx + rw [hsrc.2.1] at h + exact h + have hmidWorkSpace : βˆ€ i, (midWork i).head ≀ initialSpace := by + intro i + by_cases hi : i = dstIdx + Β· subst i + simpa [midWork, binaryCopyMidWork, binaryCopyNatTape, Tape.move] + using hone + Β· simpa [midWork, binaryCopyMidWork, hi] using hworkSpace i + have hdistinct := binaryCopyDistinct srcIdx dstIdx counterIdx + hsrcDst hsrcCounter hdstCounter + have haddInitial : + ({ state := (binaryRippleAddTM srcIdx counterIdx dstIdx).qstart + input := inpβ‚€ + work := midWork + output := outβ‚€ } : + Cfg n (binaryRippleAddTM srcIdx counterIdx dstIdx).Q).WithinAuxSpace + inputLength initialSpace := + ⟨hmidWorkSpace, hinputSpace⟩ + have hadd := binaryRippleAddTM_hoareTimeSpace_frame + srcIdx counterIdx dstIdx hdistinct srcValue 0 inputLength initialSpace + inpβ‚€ midWork outβ‚€ hmidSrc hmidCounter hmidDst hinp + (fun i _ _ _ => hmidWork i) hout haddInitial + have hseq := seqTM_hoareTimeSpace (clearWorkTM dstIdx) + (binaryRippleAddTM srcIdx counterIdx dstIdx) hclear' + (binaryCopyFrame_transition inpβ‚€ midWork outβ‚€ hinp hmidWork hout) + hadd + apply hseq.consequence + (time' := binaryCopyTime srcValue dstValue) + (inputLength' := inputLength) + (space' := binaryCopySpace initialSpace srcValue dstValue) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hfinalInput, hfinalSrc, hfinalCounter, + hfinalDst, hfinalOther, hfinalOutput⟩ + exact ⟨hfinalInput, binaryCopyRipplePost_eq srcIdx dstIdx counterIdx + hsrcDst hdstCounter srcValue workβ‚€ work hsrc hcounter + hfinalSrc hfinalCounter (by simpa using hfinalDst) (by + intro i hiSrc hiCounter hiDst + exact hfinalOther i hiSrc hiCounter hiDst), hfinalOutput⟩ + Β· simp [binaryCopyTime] + Β· exact le_rfl + Β· simp [binaryCopySpace] + +theorem binaryCopyIntoTM_isTransducer_internal + (srcIdx dstIdx counterIdx : Fin n) : + (binaryCopyIntoTM srcIdx dstIdx counterIdx).IsTransducer := by + exact (clearWorkTM_isTransducer dstIdx).seqTM + (binaryRippleAddTM_isTransducer srcIdx counterIdx dstIdx) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq.lean new file mode 100644 index 0000000000..da05687dd9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Internal + +/-! +# Binary work-tape equality + +This module exposes a framed linear-time correctness theorem for the concrete +binary equality routine used by RAM register-store scans. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Two canonical binary strings are compared in linear time. The Boolean +answer is appended to `resultIdx`; input, output, unrelated tapes, and all +binary contents are preserved. -/ +theorem binaryEqTM_reachesIn_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryEqDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryString lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryString rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c' t, + t ≀ binaryEqTime lhs rhs ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).reachesIn t + { state := (binaryEqTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix [decide (lhs = rhs)] ∧ + (c'.work lhsIdx).HasBinaryContent lhs ∧ + 1 ≀ (c'.work lhsIdx).head ∧ + (c'.work rhsIdx).HasBinaryContent rhs ∧ + 1 ≀ (c'.work rhsIdx).head ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := + binaryEqTM_reachesIn_frame_internal lhsIdx rhsIdx resultIdx hdistinct + lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother houtput + +/-- Binary equality preserves one-way output safety. -/ +theorem binaryEqTM_isTransducer {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryEqTM lhsIdx rhsIdx resultIdx).IsTransducer := + binaryEqTM_isTransducer_internal lhsIdx rhsIdx resultIdx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Defs.lean new file mode 100644 index 0000000000..5adb75867e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Defs.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Binary work-tape equality β€” definitions + +`TM.binaryEqTM` compares two canonical binary strings and writes the Boolean +result on a third work tape. Unlike the legacy output-oriented comparator, it +preserves the public output tape and every unrelated work tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The binary comparator scans until the first mismatch or simultaneous +termination, then halts immediately. -/ +inductive BinaryEqPhase where + | scan + | done + deriving DecidableEq + +instance : Fintype BinaryEqPhase where + elems := {.scan, .done} + complete := fun state => by cases state <;> simp + +/-- Pairwise distinct work tapes used by `binaryEqTM`. -/ +structure BinaryEqDistinct {n : β„•} (lhsIdx rhsIdx resultIdx : Fin n) : Prop where + lhs_rhs : lhsIdx β‰  rhsIdx + lhs_result : lhsIdx β‰  resultIdx + rhs_result : rhsIdx β‰  resultIdx + +/-- Compare canonical binary strings on `lhsIdx` and `rhsIdx`, writing one to +`resultIdx` exactly when they agree. The compared heads advance together over +matching bits; all tape contents are preserved except the single result cell. -/ +def binaryEqTM {n : β„•} (lhsIdx rhsIdx resultIdx : Fin n) : TM n where + Q := BinaryEqPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scan => + if wHeads lhsIdx = Ξ“.blank ∧ wHeads rhsIdx = Ξ“.blank then + (.done, + fun i => if i = resultIdx then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else if wHeads lhsIdx = wHeads rhsIdx then + (.scan, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = lhsIdx then Dir3.right + else if i = rhsIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.done, + fun i => if i = resultIdx then Ξ“w.zero else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | scan => + dsimp only [] + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hstart + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hstart + Β· split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hstart + simp only + split + Β· rfl + Β· split + Β· rfl + Β· exact idleDir_right_of_start hstart + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hstart + simp only + split + Β· rfl + Β· exact idleDir_right_of_start hstart + | done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Linear scan bound for binary equality. -/ +def binaryEqTime (lhs rhs : List Bool) : β„• := + max lhs.length rhs.length + 1 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Internal.lean new file mode 100644 index 0000000000..fafb1ef685 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryEq/Internal.lean @@ -0,0 +1,401 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryEq.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Binary work-tape equality β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private def binaryEqResultWork {n : β„•} (resultIdx : Fin n) + (work : Fin n β†’ Tape) (result : Bool) : Fin n β†’ Tape := + Function.update work resultIdx + ((work resultIdx).writeAndMove (Ξ“w.ofBool result) Dir3.right) + +private def binaryEqAdvanceWork {n : β„•} (lhsIdx rhsIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := + fun i => if i = lhsIdx then (work i).move Dir3.right + else if i = rhsIdx then (work i).move Dir3.right else work i + +private def binaryEqResultCfg {n : β„•} (resultIdx : Fin n) + (result : Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Cfg n BinaryEqPhase where + state := .done + input := inp + work := binaryEqResultWork resultIdx work result + output := out + +private def binaryEqAdvanceCfg {n : β„•} (lhsIdx rhsIdx : Fin n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : Cfg n BinaryEqPhase where + state := .scan + input := inp + work := binaryEqAdvanceWork lhsIdx rhsIdx work + output := out + +private theorem writeAndMove_readBack_right {tape : Tape} + (hread : tape.read β‰  Ξ“.start) : + tape.writeAndMove (readBackWrite tape.read) Dir3.right = + tape.move Dir3.right := by + cases tape with + | mk head cells => + simp only [Tape.writeAndMove, Tape.read] at hread ⊒ + rw [toΞ“_readBackWrite_of_ne_start hread] + simp [Tape.write, Tape.move, Function.update_eq_self] + +private theorem binaryEq_terminal_step {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (result : Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hterminal : if result then + (work lhsIdx).read = Ξ“.blank ∧ (work rhsIdx).read = Ξ“.blank + else Β¬((work lhsIdx).read = (work rhsIdx).read)) + (hinput : inp.read β‰  Ξ“.start) + (hwork : βˆ€ i, i β‰  resultIdx β†’ (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + (binaryEqTM lhsIdx rhsIdx resultIdx).step + { state := .scan, input := inp, work := work, output := out } = + some (binaryEqResultCfg resultIdx result inp work out) := by + simp only [TM.step, binaryEqTM] + cases result with + | false => + simp only [Bool.false_eq_true, ite_false] at hterminal + have hnotBlank : Β¬((work lhsIdx).read = Ξ“.blank ∧ + (work rhsIdx).read = Ξ“.blank) := by + intro hblank + exact hterminal (hblank.1.trans hblank.2.symm) + rw [ite_eq_right hnotBlank, ite_eq_right hterminal] + simp only [show BinaryEqPhase.scan β‰  BinaryEqPhase.done by decide, + ite_false] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hi : i = resultIdx + Β· subst i + simp [binaryEqResultCfg, binaryEqResultWork, Ξ“w.ofBool] + Β· simpa [binaryEqResultCfg, binaryEqResultWork, hi] using! + transitionTape_eq_self (hwork i hi) + + | true => + simp only [if_true] at hterminal + rw [ite_eq_left hterminal] + simp only [show BinaryEqPhase.scan β‰  BinaryEqPhase.done by decide, + ite_false] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hi : i = resultIdx + Β· subst i + simp [binaryEqResultCfg, binaryEqResultWork, Ξ“w.ofBool] + Β· simpa [binaryEqResultCfg, binaryEqResultWork, hi] using! + transitionTape_eq_self (hwork i hi) + +private theorem binaryEq_scan_step {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hreadEq : (work lhsIdx).read = (work rhsIdx).read) + (hnotBlank : Β¬((work lhsIdx).read = Ξ“.blank ∧ + (work rhsIdx).read = Ξ“.blank)) + (hinput : inp.read β‰  Ξ“.start) + (hwork : βˆ€ i, (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + (binaryEqTM lhsIdx rhsIdx resultIdx).step + { state := .scan, input := inp, work := work, output := out } = + some (binaryEqAdvanceCfg lhsIdx rhsIdx inp work out) := by + simp only [TM.step, binaryEqTM] + rw [ite_eq_right hnotBlank, ite_eq_left hreadEq] + simp only [show BinaryEqPhase.scan β‰  BinaryEqPhase.done by decide, ite_false] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hil : i = lhsIdx + Β· subst i + simp only [binaryEqAdvanceCfg, binaryEqAdvanceWork, ite_eq_left] + exact writeAndMove_readBack_right (hwork lhsIdx) + Β· by_cases hir : i = rhsIdx + Β· subst i + simp only [binaryEqAdvanceCfg, binaryEqAdvanceWork, ite_eq_right hil, ite_eq_left] + exact writeAndMove_readBack_right (hwork rhsIdx) + Β· simpa [binaryEqAdvanceCfg, binaryEqAdvanceWork, hil, hir] using! + transitionTape_eq_self (hwork i) + +private theorem binaryEq_terminal_reachesIn {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryEqDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) (result : Bool) + (hdecision : decide (lhs = rhs) = result) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hterminal : if result then + (workβ‚€ lhsIdx).read = Ξ“.blank ∧ (workβ‚€ rhsIdx).read = Ξ“.blank + else Β¬((workβ‚€ lhsIdx).read = (workβ‚€ rhsIdx).read)) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c' t, + t ≀ binaryEqTime lhs rhs ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).reachesIn t + { state := (binaryEqTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix [decide (lhs = rhs)] ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + 1 ≀ (c'.work lhsIdx).head ∧ + 1 ≀ (c'.work rhsIdx).head ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + have hwork : βˆ€ i, i β‰  resultIdx β†’ (workβ‚€ i).read β‰  Ξ“.start := by + intro i hir + by_cases hil : i = lhsIdx + Β· subst i + exact hlhs.read_ne_start + Β· by_cases hirhs : i = rhsIdx + Β· subst i + exact hrhs.read_ne_start + Β· exact hother i hil hirhs hir + have hstep := binaryEq_terminal_step lhsIdx rhsIdx resultIdx result + inpβ‚€ workβ‚€ outβ‚€ hterminal hinput hwork houtput + let c' := binaryEqResultCfg resultIdx result inpβ‚€ workβ‚€ outβ‚€ + refine ⟨c', 1, by simp [binaryEqTime], .step hstep .zero, rfl, rfl, ?_, ?_, + ?_, ?_, ?_, ?_, rfl⟩ + Β· rw [hdecision] + cases result with + | false => + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, c', binaryEqResultCfg, + binaryEqResultWork, Ξ“w.ofBool] using + Tape.hasBinaryPrefix_write_bit false hresult + | true => + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, c', binaryEqResultCfg, + binaryEqResultWork, Ξ“w.ofBool] using + Tape.hasBinaryPrefix_write_bit true hresult + Β· change (Function.update workβ‚€ resultIdx _ lhsIdx).cells = _ + rw [Function.update_of_ne hdistinct.lhs_result] + Β· change (Function.update workβ‚€ resultIdx _ rhsIdx).cells = _ + rw [Function.update_of_ne hdistinct.rhs_result] + Β· change 1 ≀ (Function.update workβ‚€ resultIdx _ lhsIdx).head + rw [Function.update_of_ne hdistinct.lhs_result] + exact hlhs.1 + Β· change 1 ≀ (Function.update workβ‚€ resultIdx _ rhsIdx).head + rw [Function.update_of_ne hdistinct.rhs_result] + exact hrhs.1 + Β· intro i hil hirhs hir + simp [c', binaryEqResultCfg, binaryEqResultWork, hir] + +private theorem binaryEq_suffix_reachesIn {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryEqDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c' t, + t ≀ binaryEqTime lhs rhs ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).reachesIn t + { state := (binaryEqTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix [decide (lhs = rhs)] ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + 1 ≀ (c'.work lhsIdx).head ∧ + 1 ≀ (c'.work rhsIdx).head ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + induction lhs generalizing rhs inpβ‚€ workβ‚€ outβ‚€ with + | nil => + cases rhs with + | nil => + apply binaryEq_terminal_reachesIn lhsIdx rhsIdx resultIdx hdistinct + [] [] true (by simp) inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult + Β· simp [hlhs.read_nil, hrhs.read_nil] + Β· exact hinput + Β· exact hother + Β· exact houtput + | cons rhsBit rhsTail => + apply binaryEq_terminal_reachesIn lhsIdx rhsIdx resultIdx hdistinct + [] (rhsBit :: rhsTail) false (by simp) inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult + Β· rw [hlhs.read_nil, hrhs.read_cons] + cases rhsBit <;> decide + Β· exact hinput + Β· exact hother + Β· exact houtput + | cons lhsBit lhsTail ih => + cases rhs with + | nil => + apply binaryEq_terminal_reachesIn lhsIdx rhsIdx resultIdx hdistinct + (lhsBit :: lhsTail) [] false (by simp) inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult + Β· rw [hlhs.read_cons, hrhs.read_nil] + cases lhsBit <;> decide + Β· exact hinput + Β· exact hother + Β· exact houtput + | cons rhsBit rhsTail => + by_cases hbit : lhsBit = rhsBit + Β· subst rhsBit + have hworkRead : βˆ€ i, (workβ‚€ i).read β‰  Ξ“.start := by + intro i + by_cases hil : i = lhsIdx + Β· subst i + exact hlhs.read_ne_start + Β· by_cases hir : i = rhsIdx + Β· subst i + exact hrhs.read_ne_start + Β· by_cases hires : i = resultIdx + Β· subst i + rw [hresult.read_blank] + decide + Β· exact hother i hil hir hires + have hreadEq : (workβ‚€ lhsIdx).read = (workβ‚€ rhsIdx).read := by + rw [hlhs.read_cons, hrhs.read_cons] + have hnotBlank : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hlhs.read_cons] at hblank + cases lhsBit <;> simp [Ξ“.ofBool] at hblank + have hstep := binaryEq_scan_step lhsIdx rhsIdx resultIdx inpβ‚€ workβ‚€ + outβ‚€ hreadEq hnotBlank hinput hworkRead houtput + let work₁ := binaryEqAdvanceWork lhsIdx rhsIdx workβ‚€ + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix lhsTail := by + simpa [work₁, binaryEqAdvanceWork] using hlhs.move_right_cons + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix rhsTail := by + simp only [work₁, binaryEqAdvanceWork, + ite_eq_right (Ne.symm hdistinct.lhs_rhs), ite_eq_left] + exact hrhs.move_right_cons + have hresult₁ : (work₁ resultIdx).HasBinaryPrefix [] := by + simpa [work₁, binaryEqAdvanceWork, + Ne.symm hdistinct.lhs_result, + Ne.symm hdistinct.rhs_result] using hresult + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryEqAdvanceWork, hil, hir] using + hother i hil hir hires + obtain ⟨c', t, htime, hreach, hhalt, hfinalInput, hfinalResult, + hfinalLhs, hfinalRhs, hfinalLhsHead, hfinalRhsHead, + hfinalOther, hfinalOutput⟩ := + ih rhsTail inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ hresult₁ hinput hother₁ + houtput + have hreach' : (binaryEqTM lhsIdx rhsIdx resultIdx).reachesIn (t + 1) + { state := (binaryEqTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' := by + exact .step hstep (by + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, work₁, binaryEqAdvanceCfg] using! hreach) + refine ⟨c', t + 1, ?_, hreach', hhalt, hfinalInput, ?_, ?_, ?_, + hfinalLhsHead, hfinalRhsHead, ?_, hfinalOutput⟩ + Β· simp only [binaryEqTime, List.length_cons] at htime ⊒ + omega + Β· simpa using hfinalResult + Β· simpa [work₁, binaryEqAdvanceWork, Tape.move_cells] using hfinalLhs + Β· simpa [work₁, binaryEqAdvanceWork, Tape.move_cells, + Ne.symm hdistinct.lhs_rhs] using hfinalRhs + Β· intro i hil hir hires + simpa [work₁, binaryEqAdvanceWork, hil, hir] using + hfinalOther i hil hir hires + Β· apply binaryEq_terminal_reachesIn lhsIdx rhsIdx resultIdx hdistinct + (lhsBit :: lhsTail) (rhsBit :: rhsTail) false (by simp [hbit]) + inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult + Β· rw [hlhs.read_cons, hrhs.read_cons] + intro heq + cases lhsBit <;> cases rhsBit <;> simp_all [Ξ“.ofBool] + Β· exact hinput + Β· exact hother + Β· exact houtput + +theorem binaryEqTM_reachesIn_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryEqDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryString lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryString rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c' t, + t ≀ binaryEqTime lhs rhs ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).reachesIn t + { state := (binaryEqTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryEqTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work resultIdx).HasBinaryPrefix [decide (lhs = rhs)] ∧ + (c'.work lhsIdx).HasBinaryContent lhs ∧ + 1 ≀ (c'.work lhsIdx).head ∧ + (c'.work rhsIdx).HasBinaryContent rhs ∧ + 1 ≀ (c'.work rhsIdx).head ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + obtain ⟨c', t, htime, hreach, hhalt, hfinalInput, hfinalResult, + hfinalLhs, hfinalRhs, hfinalLhsHead, hfinalRhsHead, hfinalOther, + hfinalOutput⟩ := + binaryEq_suffix_reachesIn lhsIdx rhsIdx resultIdx hdistinct lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hlhs.hasBinarySuffix hrhs.hasBinarySuffix hresult + hinput hother houtput + refine ⟨c', t, htime, hreach, hhalt, hfinalInput, hfinalResult, ?_, + hfinalLhsHead, ?_, hfinalRhsHead, hfinalOther, hfinalOutput⟩ + Β· simpa only [Tape.HasBinaryContent, hfinalLhs] using hlhs.hasBinaryContent + Β· simpa only [Tape.HasBinaryContent, hfinalRhs] using hrhs.hasBinaryContent + +theorem binaryEqTM_isTransducer_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryEqTM lhsIdx rhsIdx resultIdx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | scan => + simp only [binaryEqTM] + split + Β· simp only + simp only [idleDir] + split <;> decide + Β· split + Β· simp only + simp only [idleDir] + split <;> decide + Β· simp only + simp only [idleDir] + split <;> decide + | done => + simp only [binaryEqTM, allIdle, idleDir] + split <;> decide + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean new file mode 100644 index 0000000000..f83e8907ab --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean new file mode 100644 index 0000000000..a36a82f3fd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Defs.lean @@ -0,0 +1,285 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs + +/-! +# Canonical binary count-up loops β€” definitions + +This module defines an output-safe loop driver for a body indexed by a +canonical little-endian binary counter. A second, distinct work tape stores a +preserved limit. Before each iteration, the driver compares the two tapes in +lockstep, remembers whether every scanned symbol agreed, and rewinds both +heads to cell one. Equality halts the loop; inequality runs the body and then +increments the counter with `TM.binarySuccTM`. + +The comparison deliberately scans through the full limit width even after a +mismatch. Under the intended invariant `counter ≀ limit`, this gives the +value-independent exact comparison time `2 * limit.size + 2`. The controller +never moves the output head left and does not alter its contents; output +behavior during an iteration is entirely delegated to the body. + +The wrapper-free certificate structures at the end of the file separate the +executable controller from later correctness and all-prefix space proofs. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Controller phases for a canonical binary count-up loop. + +The Boolean carried by `scan` and `rewind` records whether the counter and +limit symbols seen so far were equal. -/ +inductive BinaryForPhase where + | scan (equalSoFar : Bool) + | rewind (equalSoFar : Bool) + | done + deriving DecidableEq + +/-- `BinaryForPhase` is finite, as required by the concrete machine model. -/ +instance instFintypeBinaryForPhase : Fintype BinaryForPhase where + elems := {.scan false, .scan true, .rewind false, .rewind true, .done} + complete := by + intro phase + cases phase with + | scan equalSoFar => cases equalSoFar <;> simp + | rewind equalSoFar => cases equalSoFar <;> simp + | done => simp + +/-- One count-up iteration: run `body`, take the `seqTM` seam, and increment +the designated canonical binary counter. -/ +def binaryForIterationTM {n : β„•} (body : TM n) (counterIdx : Fin n) : TM n := + seqTM body (binarySuccTM counterIdx) + +/-- Count upward from a canonical binary counter to a preserved canonical +binary limit. + +The intended correctness interface assumes `counterIdx β‰  limitIdx`. In the +driver phases both work heads move in lockstep. A complete scan records tape +equality without writing a verdict, and a complete rewind either halts or +enters `binaryForIterationTM body counterIdx`. When that composite iteration +halts, one content-preserving seam returns to a fresh equality scan. + +Input, unrelated work tapes, and output use read-back/idle actions throughout +the controller. In particular, the driver itself is compatible with +append-only output; any output writes come only from `body`. -/ +def binaryForTM {n : β„•} (body : TM n) (counterIdx limitIdx : Fin n) : TM n := + let iteration := binaryForIterationTM body counterIdx + haveI : Fintype iteration.Q := iteration.finQ + haveI : DecidableEq iteration.Q := iteration.decEq + { Q := BinaryForPhase βŠ• iteration.Q + qstart := .inl (.scan true) + qhalt := .inl .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .inl (.scan equalSoFar) => + if wHeads counterIdx = Ξ“.blank ∧ wHeads limitIdx = Ξ“.blank then + (.inl (.rewind equalSoFar), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => + if i = counterIdx then Dir3.left + else if i = limitIdx then Dir3.left + else idleDir (wHeads i), + idleDir oHead) + else + let equal' := + equalSoFar && decide (wHeads counterIdx = wHeads limitIdx) + (.inl (.scan equal'), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => + if i = counterIdx then Dir3.right + else if i = limitIdx then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .inl (.rewind equalSoFar) => + if wHeads counterIdx = Ξ“.start ∧ wHeads limitIdx = Ξ“.start then + let nextState : BinaryForPhase βŠ• iteration.Q := + if equalSoFar then .inl .done else .inr iteration.qstart + (nextState, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => + if i = counterIdx then Dir3.right + else if i = limitIdx then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + (.inl (.rewind equalSoFar), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => + if i = counterIdx then moveLeftDir (wHeads i) + else if i = limitIdx then moveLeftDir (wHeads i) + else idleDir (wHeads i), + idleDir oHead) + | .inl .done => allIdle (.inl .done) iHead wHeads oHead + | .inr q => + if q = iteration.qhalt then + allReadBack (.inl (.scan true)) iHead wHeads oHead + else + let (q', workWrite, outputWrite, inputDir, workDir, outputDir) := + iteration.Ξ΄ q iHead wHeads oHead + (.inr q', workWrite, outputWrite, inputDir, workDir, outputDir) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .inl (.scan equalSoFar) => + dsimp only + split + Β· next hblank => + refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + dsimp only + by_cases hic : i = counterIdx + Β· subst i + rw [hblank.1] at hi + exact absurd hi (by decide) + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [hblank.2] at hi + exact absurd hi (by decide) + Β· rw [ite_eq_right hil] + exact idleDir_right_of_start hi + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + dsimp only + by_cases hic : i = counterIdx + Β· rw [ite_eq_left hic] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· rw [ite_eq_left hil] + Β· rw [ite_eq_right hil] + exact idleDir_right_of_start hi + | .inl (.rewind equalSoFar) => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + dsimp only + by_cases hic : i = counterIdx + Β· rw [ite_eq_left hic] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· rw [ite_eq_left hil] + Β· rw [ite_eq_right hil] + exact idleDir_right_of_start hi + Β· refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + dsimp only + by_cases hic : i = counterIdx + Β· rw [ite_eq_left hic] + exact moveLeftDir_right_of_start hi + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· rw [ite_eq_left hil] + exact moveLeftDir_right_of_start hi + Β· rw [ite_eq_right hil] + exact idleDir_right_of_start hi + | .inl .done => exact rightOfStart_allIdle iHead wHeads oHead + | .inr q => + dsimp only + split + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· exact iteration.Ξ΄_right_of_start q iHead wHeads oHead } + +/-- Exact time for one full-width equality scan and synchronized rewind when +the counter is bounded by `limit`. -/ +def binaryForCompareTime (limit : β„•) : β„• := + 2 * limit.size + 2 + +/-- Exact time of the composite iteration before the outer loopback seam: +the body run, one `seqTM` transition, and canonical binary successor. -/ +def binaryForIterationTime (bodyTime : β„• β†’ β„•) (value : β„•) : β„• := + bodyTime value + 1 + binarySuccTime value + +/-- Exact remaining count-up-loop time. + +`value` is the current counter and `count` is the number of nonterminal +iterations remaining. The zero case performs the final successful comparison. +Each successor case performs one unsuccessful comparison, one composite +iteration, one outer loopback seam, and the remaining loop. Intended uses +supply `value + count = limit`. -/ +def binaryForLoopTime (bodyTime : β„• β†’ β„•) (limit value : β„•) : β„• β†’ β„• + | 0 => binaryForCompareTime limit + | count + 1 => + binaryForCompareTime limit + binaryForIterationTime bodyTime value + 1 + + binaryForLoopTime bodyTime limit (value + 1) count + +/-- Wrapper-free certificate for exact control flow of a canonical binary +count-up loop. + +All configurations use the public state type of +`binaryForTM body counterIdx limitIdx`. The client supplies the intended +canonical configuration family and proves that a nonterminal test reaches the +composite iteration, which runs the body and successor before one loopback +step advances to the next scanner configuration. At `limitValue`, the client +supplies the final comparison run. -/ +structure BinaryForLoopSpec {n : β„•} (body : TM n) + (counterIdx limitIdx : Fin n) (bodyTime : β„• β†’ β„•) + (limitValue : β„•) where + /-- The counter and preserved-limit tapes are distinct. -/ + counter_ne_limit : counterIdx β‰  limitIdx + /-- Client-supplied canonical combined-machine configuration before testing + `value`. -/ + scanCfg : β„• β†’ Cfg n (binaryForTM body counterIdx limitIdx).Q + /-- Client-supplied canonical configuration at the composite iteration start. -/ + iterationStartCfg : β„• β†’ Cfg n (binaryForTM body counterIdx limitIdx).Q + /-- Client-supplied canonical configuration after the exact composite iteration. -/ + iterationDoneCfg : β„• β†’ Cfg n (binaryForTM body counterIdx limitIdx).Q + /-- Client-supplied canonical final driver configuration. -/ + doneCfg : Cfg n (binaryForTM body counterIdx limitIdx).Q + /-- A nonterminal comparison and rewind enter the composite iteration. -/ + testRun : βˆ€ value, value < limitValue β†’ + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForCompareTime limitValue) (scanCfg value) + (iterationStartCfg value) + /-- The body, `seqTM` seam, and successor have the advertised exact runtime. -/ + iterationRun : βˆ€ value, value < limitValue β†’ + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForIterationTime bodyTime value) (iterationStartCfg value) + (iterationDoneCfg value) + /-- The preserving outer seam returns to the next comparison. -/ + loopbackStep : βˆ€ value, value < limitValue β†’ + (binaryForTM body counterIdx limitIdx).step (iterationDoneCfg value) = + some (scanCfg (value + 1)) + /-- Equality at the limit completes one final comparison and rewind. -/ + doneRun : + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForCompareTime limitValue) (scanCfg limitValue) doneCfg + +/-- All-prefix auxiliary-space obligations for a certified binary count-up +loop. The comparison and composite-iteration obligations concern prefixes of +their advertised exact runs; later execution may already have crossed the +corresponding seam. -/ +structure BinaryForLoopSpaceSpec {n : β„•} {body : TM n} + {counterIdx limitIdx : Fin n} {bodyTime : β„• β†’ β„•} + {limitValue : β„•} + (spec : BinaryForLoopSpec body counterIdx limitIdx bodyTime limitValue) + (inputLength spaceBound : β„•) where + /-- Every prefix of each full-width comparison and rewind respects the budget. -/ + testPrefixWithin : βˆ€ value time cfg, value ≀ limitValue β†’ + time ≀ binaryForCompareTime limitValue β†’ + (binaryForTM body counterIdx limitIdx).reachesIn time + (spec.scanCfg value) cfg β†’ + cfg.WithinAuxSpace inputLength spaceBound + /-- Every prefix of each body-plus-successor iteration respects the budget. -/ + iterationPrefixWithin : βˆ€ value time cfg, value < limitValue β†’ + time ≀ binaryForIterationTime bodyTime value β†’ + (binaryForTM body counterIdx limitIdx).reachesIn time + (spec.iterationStartCfg value) cfg β†’ + cfg.WithinAuxSpace inputLength spaceBound + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean new file mode 100644 index 0000000000..24aeb0d2b0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Comparison +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Control +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Loop + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Comparison.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Comparison.lean new file mode 100644 index 0000000000..d3c01a5b00 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Comparison.lean @@ -0,0 +1,724 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Internal.Control +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import Mathlib.Algebra.Order.Group.Nat +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# Canonical binary count-up loops β€” comparison internals + +This module proves the exact full-width comparison run used by +`TM.binaryForTM`. The scanner compares two canonical little-endian natural +numbers without changing their contents, then rewinds both cursors. Under +the loop invariant `value ≀ limitValue`, the run takes exactly +`binaryForCompareTime limitValue` steps and branches to the composite +iteration precisely below the limit, or to `done` precisely at equality. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- The alphabet symbol at one zero-based position of a blank-padded binary +string. -/ +private def paddedBinarySymbol (bits : List Bool) (i : β„•) : Ξ“ := + if h : i < bits.length then Ξ“.ofBool bits[i] else Ξ“.blank + +private theorem paddedBinarySymbol_of_lt {bits : List Bool} {i : β„•} + (h : i < bits.length) : + paddedBinarySymbol bits i = Ξ“.ofBool bits[i] := by + simp only [paddedBinarySymbol, dif_pos h] + +private theorem paddedBinarySymbol_of_ge {bits : List Bool} {i : β„•} + (h : bits.length ≀ i) : + paddedBinarySymbol bits i = Ξ“.blank := by + simp only [paddedBinarySymbol, dite_eq_right (Nat.not_lt.mpr h)] + +/-- Boolean equality accumulated through the first `width` padded symbols. -/ +private def paddedBinaryPrefixEq (left right : List Bool) : β„• β†’ Bool + | 0 => true + | width + 1 => + paddedBinaryPrefixEq left right width && + decide (paddedBinarySymbol left width = paddedBinarySymbol right width) + +private theorem paddedBinaryPrefixEq_symbol_eq {left right : List Bool} + {width i : β„•} (heq : paddedBinaryPrefixEq left right width = true) + (hi : i < width) : + paddedBinarySymbol left i = paddedBinarySymbol right i := by + induction width with + | zero => omega + | succ width ih => + simp only [paddedBinaryPrefixEq, Bool.and_eq_true, decide_eq_true_eq] at heq + by_cases hlast : i = width + Β· simpa [hlast] using heq.2 + Β· exact ih heq.1 (by omega) + +private theorem paddedBinaryPrefixEq_self (bits : List Bool) (width : β„•) : + paddedBinaryPrefixEq bits bits width = true := by + induction width with + | zero => rfl + | succ width ih => simp [paddedBinaryPrefixEq, ih] + +private theorem ofBool_injective {left right : Bool} + (h : Ξ“.ofBool left = Ξ“.ofBool right) : left = right := by + cases left <;> cases right <;> simp [Ξ“.ofBool] at h ⊒ + +private theorem paddedBinaryPrefixEq_eq_true_iff {left right : List Bool} + {width : β„•} (hleft : left.length ≀ width) + (hright : right.length ≀ width) : + paddedBinaryPrefixEq left right width = true ↔ left = right := by + constructor + Β· intro heq + have hlen : left.length = right.length := by + apply Nat.le_antisymm + Β· by_contra hnot + have hlt : right.length < left.length := Nat.lt_of_not_ge hnot + have hsymbol := paddedBinaryPrefixEq_symbol_eq heq + (lt_of_lt_of_le hlt hleft) + rw [paddedBinarySymbol_of_lt hlt, + paddedBinarySymbol_of_ge le_rfl] at hsymbol + exact Ξ“.ofBool_ne_blank _ hsymbol + Β· by_contra hnot + have hlt : left.length < right.length := Nat.lt_of_not_ge hnot + have hsymbol := paddedBinaryPrefixEq_symbol_eq heq + (lt_of_lt_of_le hlt hright) + rw [paddedBinarySymbol_of_ge le_rfl, + paddedBinarySymbol_of_lt hlt] at hsymbol + exact Ξ“.ofBool_ne_blank _ hsymbol.symm + apply List.ext_get hlen + intro i hli hri + have hsymbol := paddedBinaryPrefixEq_symbol_eq heq + (lt_of_lt_of_le hli hleft) + rw [paddedBinarySymbol_of_lt hli, + paddedBinarySymbol_of_lt hri] at hsymbol + exact ofBool_injective hsymbol + Β· intro heq + subst right + exact paddedBinaryPrefixEq_self left width + +private theorem HasBinaryContent.cells_paddedBinarySymbol {t : Tape} + {bits : List Bool} (h : t.HasBinaryContent bits) (i : β„•) : + t.cells (i + 1) = paddedBinarySymbol bits i := by + by_cases hi : i < bits.length + Β· rw [paddedBinarySymbol_of_lt hi, h.1 i hi] + Β· rw [paddedBinarySymbol_of_ge (Nat.le_of_not_gt hi), + h.2 i (Nat.le_of_not_gt hi)] + +/-- Reset only the head of a tape, preserving all cells. -/ +private def tapeAtHead (t : Tape) (head : β„•) : Tape := + { head := head, cells := t.cells } + +@[simp] private theorem tapeAtHead_head (t : Tape) (head : β„•) : + (tapeAtHead t head).head = head := rfl + +@[simp] private theorem tapeAtHead_cells (t : Tape) (head : β„•) : + (tapeAtHead t head).cells = t.cells := rfl + +private theorem tapeAtHead_eq_self {t : Tape} {head : β„•} + (hhead : t.head = head) : tapeAtHead t head = t := by + ext <;> simp [tapeAtHead, hhead] + +/-- Put the two comparison cursors at the same head position and leave every +other work tape untouched. -/ +private def binaryForWorkAt (work : Fin n β†’ Tape) + (counterIdx limitIdx : Fin n) (head : β„•) : Fin n β†’ Tape := + fun i => + if i = counterIdx then tapeAtHead (work i) head + else if i = limitIdx then tapeAtHead (work i) head + else work i + +private theorem binaryForWorkAt_counter (work : Fin n β†’ Tape) + (counterIdx limitIdx : Fin n) (head : β„•) : + binaryForWorkAt work counterIdx limitIdx head counterIdx = + tapeAtHead (work counterIdx) head := by + simp [binaryForWorkAt] + +private theorem binaryForWorkAt_limit (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) (head : β„•) : + binaryForWorkAt work counterIdx limitIdx head limitIdx = + tapeAtHead (work limitIdx) head := by + simp [binaryForWorkAt, Ne.symm hne] + +private theorem binaryForWorkAt_other (work : Fin n β†’ Tape) + {counterIdx limitIdx i : Fin n} (hic : i β‰  counterIdx) + (hil : i β‰  limitIdx) (head : β„•) : + binaryForWorkAt work counterIdx limitIdx head i = work i := by + simp [binaryForWorkAt, hic, hil] + +private theorem binaryForWorkAt_one_eq (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} + (hcounter : (work counterIdx).head = 1) + (hlimit : (work limitIdx).head = 1) : + binaryForWorkAt work counterIdx limitIdx 1 = work := by + funext i + by_cases hic : i = counterIdx + Β· subst i + rw [binaryForWorkAt_counter, tapeAtHead_eq_self hcounter] + Β· by_cases hil : i = limitIdx + Β· subst i + simp only [binaryForWorkAt, hic, ↓reduceIte] + exact tapeAtHead_eq_self hlimit + Β· exact binaryForWorkAt_other work hic hil 1 + +private theorem binaryForWorkAt_selected_cells (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (head : β„•) (i : Fin n) + (hi : i = counterIdx ∨ i = limitIdx) : + (binaryForWorkAt work counterIdx limitIdx head i).cells = (work i).cells := by + rcases hi with rfl | rfl + Β· simp [binaryForWorkAt_counter] + Β· simp [binaryForWorkAt] + +private theorem binaryForWorkAt_move_right (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) (head : β„•) : + Function.update + (Function.update (binaryForWorkAt work counterIdx limitIdx head) + counterIdx + ((binaryForWorkAt work counterIdx limitIdx head counterIdx).move + Dir3.right)) + limitIdx + ((binaryForWorkAt work counterIdx limitIdx head limitIdx).move + Dir3.right) = + binaryForWorkAt work counterIdx limitIdx (head + 1) := by + funext i + by_cases hic : i = counterIdx + Β· subst i + simp [Function.update, hne, binaryForWorkAt, tapeAtHead, Tape.move] + Β· by_cases hil : i = limitIdx + Β· subst i + simp [Function.update, hic, binaryForWorkAt, tapeAtHead, Tape.move] + Β· simp [Function.update, hic, hil, binaryForWorkAt] + +private theorem binaryForWorkAt_move_left (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) (head : β„•) : + Function.update + (Function.update (binaryForWorkAt work counterIdx limitIdx head) + counterIdx + ((binaryForWorkAt work counterIdx limitIdx head counterIdx).move + Dir3.left)) + limitIdx + ((binaryForWorkAt work counterIdx limitIdx head limitIdx).move + Dir3.left) = + binaryForWorkAt work counterIdx limitIdx (head - 1) := by + funext i + by_cases hic : i = counterIdx + Β· subst i + simp [Function.update, hne, binaryForWorkAt, tapeAtHead, Tape.move] + Β· by_cases hil : i = limitIdx + Β· subst i + simp [Function.update, hic, binaryForWorkAt, tapeAtHead, Tape.move] + Β· simp [Function.update, hic, hil, binaryForWorkAt] + +/-- A comparison-phase configuration with synchronized counter and limit +cursors. -/ +private def binaryForCompareCfg (body : TM n) + (counterIdx limitIdx : Fin n) (phase : BinaryForPhase) + (head : β„•) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) : + Cfg n (binaryForTM body counterIdx limitIdx).Q := + { state := .inl phase + input := inp + work := binaryForWorkAt work counterIdx limitIdx head + output := out } + +private theorem binaryForCompareCfg_one_eq + (body : TM n) (counterIdx limitIdx : Fin n) (phase : BinaryForPhase) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hcounter : (work counterIdx).head = 1) + (hlimit : (work limitIdx).head = 1) : + binaryForCompareCfg body counterIdx limitIdx phase 1 inp work out = + { state := .inl phase + input := inp + work := work + output := out } := by + simp only [binaryForCompareCfg, binaryForWorkAt_one_eq work hcounter hlimit] + +private theorem binaryForCompareCfg_work_read_ne_start + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (phase : BinaryForPhase) {head : β„•} (hhead : 1 ≀ head) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) : + βˆ€ i, ((binaryForCompareCfg body counterIdx limitIdx phase head + inp work out).work i).read β‰  Ξ“.start := by + intro i + by_cases hic : i = counterIdx + Β· subst i + simp only [binaryForCompareCfg, binaryForWorkAt_counter, Tape.read, + tapeAtHead_head, tapeAtHead_cells] + exact hcounter.cells_ne_start head hhead + Β· by_cases hil : i = limitIdx + Β· subst i + simp only [binaryForCompareCfg, binaryForWorkAt_limit work hne, + Tape.read, tapeAtHead_head, tapeAtHead_cells] + exact hlimit.cells_ne_start head hhead + Β· rw [show (binaryForCompareCfg body counterIdx limitIdx phase head + inp work out).work i = work i by + exact binaryForWorkAt_other work hic hil head] + exact hother i hic hil + +private theorem binaryForCompareCfg_counter_read + (body : TM n) (work : Fin n β†’ Tape) + (counterIdx limitIdx : Fin n) (phase : BinaryForPhase) + (inp out : Tape) {bits : List Bool} + (hbits : (work counterIdx).HasBinaryContent bits) (i : β„•) : + ((binaryForCompareCfg body counterIdx limitIdx phase (i + 1) + inp work out).work counterIdx).read = paddedBinarySymbol bits i := by + simp only [binaryForCompareCfg, binaryForWorkAt_counter, Tape.read, + tapeAtHead_head, tapeAtHead_cells] + exact HasBinaryContent.cells_paddedBinarySymbol hbits i + +private theorem binaryForCompareCfg_limit_read + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (phase : BinaryForPhase) (inp out : Tape) {bits : List Bool} + (hbits : (work limitIdx).HasBinaryContent bits) (i : β„•) : + ((binaryForCompareCfg body counterIdx limitIdx phase (i + 1) + inp work out).work limitIdx).read = paddedBinarySymbol bits i := by + simp only [binaryForCompareCfg, binaryForWorkAt_limit work hne, + Tape.read, tapeAtHead_head, tapeAtHead_cells] + exact HasBinaryContent.cells_paddedBinarySymbol hbits i + +private theorem binaryForCompareCfg_step_scan + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) (i : β„•) (hi : i < limitBits.length) : + (binaryForTM body counterIdx limitIdx).step + (binaryForCompareCfg body counterIdx limitIdx + (.scan (paddedBinaryPrefixEq counterBits limitBits i)) + (i + 1) inp work out) = + some (binaryForCompareCfg body counterIdx limitIdx + (.scan (paddedBinaryPrefixEq counterBits limitBits (i + 1))) + (i + 1 + 1) inp work out) := by + let c := binaryForCompareCfg body counterIdx limitIdx + (.scan (paddedBinaryPrefixEq counterBits limitBits i)) + (i + 1) inp work out + have hcounterRead : (c.work counterIdx).read = + paddedBinarySymbol counterBits i := + binaryForCompareCfg_counter_read body work counterIdx limitIdx _ inp out + hcounter i + have hlimitRead : (c.work limitIdx).read = + paddedBinarySymbol limitBits i := + binaryForCompareCfg_limit_read body work hne _ inp out hlimit i + have hmore : Β¬((c.work counterIdx).read = Ξ“.blank ∧ + (c.work limitIdx).read = Ξ“.blank) := by + intro hblank + rw [hlimitRead, paddedBinarySymbol_of_lt hi] at hblank + exact Ξ“.ofBool_ne_blank _ hblank.2 + have hwork : βˆ€ j, (c.work j).read β‰  Ξ“.start := by + dsimp only [c] + exact binaryForCompareCfg_work_read_ne_start body work hne + (.scan (paddedBinaryPrefixEq counterBits limitBits i)) + (head := i + 1) (by omega) inp out hcounter hlimit hother + have hstep := binaryForTM_step_scan_internal body counterIdx limitIdx hne + (paddedBinaryPrefixEq counterBits limitBits i) c rfl hmore hinp hwork hout + rw [hcounterRead, hlimitRead] at hstep + dsimp only [c, binaryForCompareCfg] at hstep + rw [binaryForWorkAt_move_right work hne] at hstep + simpa only [c, binaryForCompareCfg, paddedBinaryPrefixEq] using hstep + +private theorem binaryForCompareCfg_scan_reachesIn + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + βˆ€ width, width ≀ limitBits.length β†’ + (binaryForTM body counterIdx limitIdx).reachesIn width + (binaryForCompareCfg body counterIdx limitIdx (.scan true) + 1 inp work out) + (binaryForCompareCfg body counterIdx limitIdx + (.scan (paddedBinaryPrefixEq counterBits limitBits width)) + (width + 1) inp work out) := by + intro width + induction width with + | zero => + intro _ + simpa only [paddedBinaryPrefixEq] using + (TM.reachesIn.zero : + (binaryForTM body counterIdx limitIdx).reachesIn 0 + (binaryForCompareCfg body counterIdx limitIdx (.scan true) + 1 inp work out) + (binaryForCompareCfg body counterIdx limitIdx (.scan true) + 1 inp work out)) + | succ width ih => + intro hwidth + have hprefix := ih (by omega) + have hstep := binaryForCompareCfg_step_scan body work hne inp out + hcounter hlimit hinp hother hout width (by omega) + exact (binaryForTM body counterIdx limitIdx).reachesIn_snoc hprefix hstep + +private theorem binaryForCompareCfg_step_scan_blank + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) (equalSoFar : Bool) (width : β„•) + (hcounterWidth : counterBits.length ≀ width) + (hlimitWidth : limitBits.length ≀ width) : + (binaryForTM body counterIdx limitIdx).step + (binaryForCompareCfg body counterIdx limitIdx + (.scan equalSoFar) (width + 1) inp work out) = + some (binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) width inp work out) := by + let c := binaryForCompareCfg body counterIdx limitIdx + (.scan equalSoFar) (width + 1) inp work out + have hcounterRead : (c.work counterIdx).read = Ξ“.blank := by + rw [binaryForCompareCfg_counter_read body work counterIdx limitIdx + (.scan equalSoFar) inp out hcounter width] + exact paddedBinarySymbol_of_ge hcounterWidth + have hlimitRead : (c.work limitIdx).read = Ξ“.blank := by + rw [binaryForCompareCfg_limit_read body work hne + (.scan equalSoFar) inp out hlimit width] + exact paddedBinarySymbol_of_ge hlimitWidth + have hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start := by + dsimp only [c] + exact binaryForCompareCfg_work_read_ne_start body work hne + (.scan equalSoFar) (head := width + 1) (by omega) + inp out hcounter hlimit hother + have hstep := binaryForTM_step_scan_blank_internal body counterIdx + limitIdx hne equalSoFar c rfl hcounterRead hlimitRead hinp hwork hout + dsimp only [c, binaryForCompareCfg] at hstep + rw [binaryForWorkAt_move_left work hne] at hstep + simpa using! hstep + +private theorem binaryForCompareCfg_step_rewind + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) (equalSoFar : Bool) (head : β„•) : + (binaryForTM body counterIdx limitIdx).step + (binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) (head + 1) inp work out) = + some (binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) head inp work out) := by + let c := binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) (head + 1) inp work out + have hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start := by + dsimp only [c] + exact binaryForCompareCfg_work_read_ne_start body work hne + (.rewind equalSoFar) (head := head + 1) (by omega) + inp out hcounter hlimit hother + have hstep := binaryForTM_step_rewind_internal body counterIdx limitIdx + hne equalSoFar c rfl hinp hwork hout + dsimp only [c, binaryForCompareCfg] at hstep + rw [binaryForWorkAt_move_left work hne] at hstep + simpa using! hstep + +private theorem binaryForCompareCfg_rewind_reachesIn + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) (equalSoFar : Bool) : + βˆ€ head, + (binaryForTM body counterIdx limitIdx).reachesIn head + (binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) head inp work out) + (binaryForCompareCfg body counterIdx limitIdx + (.rewind equalSoFar) 0 inp work out) := by + intro head + induction head with + | zero => exact .zero + | succ head ih => + exact .step (binaryForCompareCfg_step_rewind body work hne inp out + hcounter hlimit hinp hother hout equalSoFar head) ih + +private theorem binaryForCompareCfg_step_rewind_true + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) + (hcounterStart : (work counterIdx).cells 0 = Ξ“.start) + (hlimitStart : (work limitIdx).cells 0 = Ξ“.start) + (hcounterHead : (work counterIdx).head = 1) + (hlimitHead : (work limitIdx).head = 1) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step + (binaryForCompareCfg body counterIdx limitIdx + (.rewind true) 0 inp work out) = + some + { state := .inl .done + input := inp + work := work + output := out } := by + let c := binaryForCompareCfg body counterIdx limitIdx + (.rewind true) 0 inp work out + have hcounterRead : (c.work counterIdx).read = Ξ“.start := by + simp [c, binaryForCompareCfg, binaryForWorkAt_counter, tapeAtHead, + Tape.read, hcounterStart] + have hlimitRead : (c.work limitIdx).read = Ξ“.start := by + simp [c, binaryForCompareCfg, binaryForWorkAt_limit work hne, + tapeAtHead, Tape.read, hlimitStart] + have hcounterHead0 : (c.work counterIdx).head = 0 := by + simp [c, binaryForCompareCfg, binaryForWorkAt_counter] + have hlimitHead0 : (c.work limitIdx).head = 0 := by + simp [c, binaryForCompareCfg, binaryForWorkAt_limit work hne] + have hother' : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (c.work i).read β‰  Ξ“.start := by + intro i hic hil + rw [show c.work i = work i by + exact binaryForWorkAt_other work hic hil 0] + exact hother i hic hil + have hstep := binaryForTM_step_rewind_equal_internal body counterIdx + limitIdx hne c rfl hcounterRead hlimitRead hcounterHead0 hlimitHead0 + hinp hother' hout + dsimp only [c, binaryForCompareCfg] at hstep + rw [binaryForWorkAt_move_right work hne, + binaryForWorkAt_one_eq work hcounterHead hlimitHead] at hstep + exact hstep + +private theorem binaryForCompareCfg_step_rewind_false + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) + (hcounterStart : (work counterIdx).cells 0 = Ξ“.start) + (hlimitStart : (work limitIdx).cells 0 = Ξ“.start) + (hcounterHead : (work counterIdx).head = 1) + (hlimitHead : (work limitIdx).head = 1) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step + (binaryForCompareCfg body counterIdx limitIdx + (.rewind false) 0 inp work out) = + some + { state := .inr (binaryForIterationTM body counterIdx).qstart + input := inp + work := work + output := out } := by + let c := binaryForCompareCfg body counterIdx limitIdx + (.rewind false) 0 inp work out + have hcounterRead : (c.work counterIdx).read = Ξ“.start := by + simp [c, binaryForCompareCfg, binaryForWorkAt_counter, tapeAtHead, + Tape.read, hcounterStart] + have hlimitRead : (c.work limitIdx).read = Ξ“.start := by + simp [c, binaryForCompareCfg, binaryForWorkAt_limit work hne, + tapeAtHead, Tape.read, hlimitStart] + have hcounterHead0 : (c.work counterIdx).head = 0 := by + simp [c, binaryForCompareCfg, binaryForWorkAt_counter] + have hlimitHead0 : (c.work limitIdx).head = 0 := by + simp [c, binaryForCompareCfg, binaryForWorkAt_limit work hne] + have hother' : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (c.work i).read β‰  Ξ“.start := by + intro i hic hil + rw [show c.work i = work i by + exact binaryForWorkAt_other work hic hil 0] + exact hother i hic hil + have hstep := binaryForTM_step_rewind_unequal_internal body counterIdx + limitIdx hne c rfl hcounterRead hlimitRead hcounterHead0 hlimitHead0 + hinp hother' hout + dsimp only [c, binaryForCompareCfg] at hstep + rw [binaryForWorkAt_move_right work hne, + binaryForWorkAt_one_eq work hcounterHead hlimitHead] at hstep + exact hstep + +private theorem binaryForCompareCfg_reachesIn_rewind_zero + (body : TM n) (work : Fin n β†’ Tape) + {counterIdx limitIdx : Fin n} (hne : counterIdx β‰  limitIdx) + (inp out : Tape) {counterBits limitBits : List Bool} + (hcounter : (work counterIdx).HasBinaryContent counterBits) + (hlimit : (work limitIdx).HasBinaryContent limitBits) + (hinp : inp.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (work i).read β‰  Ξ“.start) + (hout : out.read β‰  Ξ“.start) (width : β„•) + (hcounterWidth : counterBits.length ≀ width) + (hlimitWidth : limitBits.length = width) : + (binaryForTM body counterIdx limitIdx).reachesIn (2 * width + 1) + (binaryForCompareCfg body counterIdx limitIdx (.scan true) + 1 inp work out) + (binaryForCompareCfg body counterIdx limitIdx + (.rewind (paddedBinaryPrefixEq counterBits limitBits width)) + 0 inp work out) := by + have hscan := binaryForCompareCfg_scan_reachesIn body work hne inp out + hcounter hlimit hinp hother hout width (by omega) + have hblank := binaryForCompareCfg_step_scan_blank body work hne inp out + hcounter hlimit hinp hother hout + (paddedBinaryPrefixEq counterBits limitBits width) width + hcounterWidth (by omega) + have hscanRewind := + (binaryForTM body counterIdx limitIdx).reachesIn_snoc hscan hblank + have hrewind := binaryForCompareCfg_rewind_reachesIn body work hne inp out + hcounter hlimit hinp hother hout + (paddedBinaryPrefixEq counterBits limitBits width) width + have hrun := reachesIn_trans (binaryForTM body counterIdx limitIdx) + hscanRewind hrewind + convert! hrun using 1 + omega + +/-- At equality, the full-width comparison preserves every tape exactly and +reaches the loop's `done` state in the advertised exact time. -/ +theorem binaryForTM_compare_reachesIn_frame_of_eq_internal + (body : TM n) (counterIdx limitIdx : Fin n) + (hne : counterIdx β‰  limitIdx) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat value) + (hlimit : (workβ‚€ limitIdx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForCompareTime value) + { state := .inl (.scan true) + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + { state := .inl .done + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } := by + have hwidth : value.bits.length = value.size := + Nat.size_eq_bits_len value + have hrewind := binaryForCompareCfg_reachesIn_rewind_zero body workβ‚€ hne + inpβ‚€ outβ‚€ hcounter.2.2 hlimit.2.2 hinp hother hout value.size + (by omega) hwidth + rw [paddedBinaryPrefixEq_self] at hrewind + have hexit := binaryForCompareCfg_step_rewind_true body workβ‚€ hne + inpβ‚€ outβ‚€ hcounter.1 hlimit.1 hcounter.2.1 hlimit.2.1 + hinp hother hout + have hrun := + (binaryForTM body counterIdx limitIdx).reachesIn_snoc hrewind hexit + rw [binaryForCompareCfg_one_eq body counterIdx limitIdx (.scan true) + inpβ‚€ workβ‚€ outβ‚€ hcounter.2.1 hlimit.2.1] at hrun + simpa [binaryForCompareTime] using hrun + +/-- Strictly below the limit, the full-width comparison preserves every tape +exactly and reaches the composite iteration start in the advertised time. -/ +theorem binaryForTM_compare_reachesIn_frame_of_lt_internal + (body : TM n) (counterIdx limitIdx : Fin n) + (hne : counterIdx β‰  limitIdx) (value limitValue : β„•) + (hlt : value < limitValue) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat value) + (hlimit : (workβ‚€ limitIdx).HasBinaryNat limitValue) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForCompareTime limitValue) + { state := .inl (.scan true) + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + { state := .inr (binaryForIterationTM body counterIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } := by + have hcounterWidth : value.bits.length ≀ limitValue.size := by + rw [Nat.size_eq_bits_len value] + exact Nat.size_le_size (Nat.le_of_lt hlt) + have hlimitWidth : limitValue.bits.length = limitValue.size := + Nat.size_eq_bits_len limitValue + have hflag : paddedBinaryPrefixEq value.bits limitValue.bits + limitValue.size = false := by + cases hprefix : paddedBinaryPrefixEq value.bits limitValue.bits + limitValue.size with + | false => rfl + | true => + have hbits := (paddedBinaryPrefixEq_eq_true_iff hcounterWidth + (by omega)).mp hprefix + have hvalues := congrArg Nat.fromBitsLE hbits + simp only [Nat.fromBitsLE_bits] at hvalues + omega + have hrewind := binaryForCompareCfg_reachesIn_rewind_zero body workβ‚€ hne + inpβ‚€ outβ‚€ hcounter.2.2 hlimit.2.2 hinp hother hout + limitValue.size hcounterWidth hlimitWidth + rw [hflag] at hrewind + have hexit := binaryForCompareCfg_step_rewind_false body workβ‚€ hne + inpβ‚€ outβ‚€ hcounter.1 hlimit.1 hcounter.2.1 hlimit.2.1 + hinp hother hout + have hrun := + (binaryForTM body counterIdx limitIdx).reachesIn_snoc hrewind hexit + rw [binaryForCompareCfg_one_eq body counterIdx limitIdx (.scan true) + inpβ‚€ workβ‚€ outβ‚€ hcounter.2.1 hlimit.2.1] at hrun + simpa [binaryForCompareTime] using hrun + +/-- A complete canonical comparison has one exact, fully framed endpoint. +The endpoint enters the composite iteration exactly below the limit and is +the final `done` configuration exactly at equality. -/ +theorem binaryForTM_compare_reachesIn_frame_internal + (body : TM n) (counterIdx limitIdx : Fin n) + (hne : counterIdx β‰  limitIdx) (value limitValue : β„•) + (hle : value ≀ limitValue) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hcounter : (workβ‚€ counterIdx).HasBinaryNat value) + (hlimit : (workβ‚€ limitIdx).HasBinaryNat limitValue) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForCompareTime limitValue) + { state := .inl (.scan true) + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + c'.input = inpβ‚€ ∧ + c'.work = workβ‚€ ∧ + c'.output = outβ‚€ ∧ + (c'.state = .inr (binaryForIterationTM body counterIdx).qstart ↔ + value < limitValue) ∧ + (c'.state = .inl .done ↔ value = limitValue) := by + by_cases heq : value = limitValue + Β· subst limitValue + have hrun := binaryForTM_compare_reachesIn_frame_of_eq_internal + body counterIdx limitIdx hne value inpβ‚€ workβ‚€ outβ‚€ + hcounter hlimit hinp hother hout + refine ⟨_, hrun, rfl, rfl, rfl, ?_, ?_⟩ + Β· simp + Β· simp + rfl + Β· have hlt : value < limitValue := by omega + have hrun := binaryForTM_compare_reachesIn_frame_of_lt_internal + body counterIdx limitIdx hne value limitValue hlt inpβ‚€ workβ‚€ outβ‚€ + hcounter hlimit hinp hother hout + refine ⟨_, hrun, rfl, rfl, rfl, ?_, ?_⟩ + Β· simp [hlt] + rfl + Β· simp [heq] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Control.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Control.lean new file mode 100644 index 0000000000..f1a81181ba --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Control.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs + +/-! +# Canonical binary count-up loops β€” control proofs + +This module supplies the local proof interface for `TM.binaryForTM`. It lifts +runs of the composite body-plus-successor iteration through the outer control +state and gives exact, full-frame transition lemmas for scanning, rewinding, +entering an iteration, and returning from a completed iteration. + +The canonical multi-step comparison run and loop induction are intentionally +left to later proof layers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Embed a composite iteration configuration into the iteration phase of +`binaryForTM`. -/ +def binaryForIterationWrap (body : TM n) (counterIdx limitIdx : Fin n) + (c : Cfg n (binaryForIterationTM body counterIdx).Q) : + Cfg n (binaryForTM body counterIdx limitIdx).Q := + { state := .inr c.state + input := c.input + work := c.work + output := c.output } + +/-- Every nonhalting composite-iteration step is simulated exactly by one +`binaryForTM` step. -/ +theorem binaryForTM_iteration_step_internal (body : TM n) + (counterIdx limitIdx : Fin n) + {c c' : Cfg n (binaryForIterationTM body counterIdx).Q} + (hstep : (binaryForIterationTM body counterIdx).step c = some c') : + (binaryForTM body counterIdx limitIdx).step + (binaryForIterationWrap body counterIdx limitIdx c) = + some (binaryForIterationWrap body counterIdx limitIdx c') := by + have hne : c.state β‰  (binaryForIterationTM body counterIdx).qhalt := + state_ne_qhalt_of_step hstep + rw [TM.step, ite_eq_right (by simp [binaryForIterationWrap, binaryForTM])] + simp only [binaryForIterationWrap, binaryForTM, hne, ↓reduceIte] + rw [TM.step, ite_eq_right hne] at hstep + simpa only [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, Option.map_some, binaryForIterationWrap] using! + congrArg (Option.map (binaryForIterationWrap body counterIdx limitIdx)) hstep + +/-- Exact runs of the composite iteration lift through the iteration phase of +`binaryForTM`. -/ +theorem binaryForTM_iteration_reachesIn_internal (body : TM n) + (counterIdx limitIdx : Fin n) + {t : β„•} {c c' : Cfg n (binaryForIterationTM body counterIdx).Q} + (hreach : (binaryForIterationTM body counterIdx).reachesIn t c c') : + (binaryForTM body counterIdx limitIdx).reachesIn t + (binaryForIterationWrap body counterIdx limitIdx c) + (binaryForIterationWrap body counterIdx limitIdx c') := + reachesIn_map (binaryForIterationWrap body counterIdx limitIdx) + (fun _ _ => binaryForTM_iteration_step_internal body counterIdx limitIdx) hreach + +/-- Away from the common terminating blank, one scanner step compares the +current symbols and advances both designated tapes, preserving the full +off-start frame. -/ +theorem binaryForTM_step_scan_internal (body : TM n) + (counterIdx limitIdx : Fin n) (hne : counterIdx β‰  limitIdx) + (equalSoFar : Bool) (c : Cfg n (binaryForTM body counterIdx limitIdx).Q) + (hstate : c.state = .inl (.scan equalSoFar)) + (hmore : Β¬((c.work counterIdx).read = Ξ“.blank ∧ + (c.work limitIdx).read = Ξ“.blank)) + (hinput : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step c = some + { state := .inl (.scan + (equalSoFar && decide ((c.work counterIdx).read = (c.work limitIdx).read))) + input := c.input + work := Function.update + (Function.update c.work counterIdx ((c.work counterIdx).move Dir3.right)) + limitIdx ((c.work limitIdx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [binaryForTM])] + simp only [binaryForTM, hstate] + rw [ite_eq_right hmore] + dsimp only + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hic : i = counterIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_of_ne hne, Function.update_self, + writeAndMove_readBack _ (hwork counterIdx)] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (hwork limitIdx)] + Β· rw [ite_eq_right hil, Function.update_of_ne hil, Function.update_of_ne hic] + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +/-- At the common terminating blank, one scanner step enters rewind and moves +both designated tapes left, preserving the full off-start frame. -/ +theorem binaryForTM_step_scan_blank_internal (body : TM n) + (counterIdx limitIdx : Fin n) (hne : counterIdx β‰  limitIdx) + (equalSoFar : Bool) (c : Cfg n (binaryForTM body counterIdx limitIdx).Q) + (hstate : c.state = .inl (.scan equalSoFar)) + (hcounter : (c.work counterIdx).read = Ξ“.blank) + (hlimit : (c.work limitIdx).read = Ξ“.blank) + (hinput : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step c = some + { state := .inl (.rewind equalSoFar) + input := c.input + work := Function.update + (Function.update c.work counterIdx ((c.work counterIdx).move Dir3.left)) + limitIdx ((c.work limitIdx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [binaryForTM])] + simp only [binaryForTM, hstate] + rw [ite_eq_left ⟨hcounter, hlimit⟩] + dsimp only + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hic : i = counterIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_of_ne hne, Function.update_self, + writeAndMove_readBack _ (hwork counterIdx)] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (hwork limitIdx)] + Β· rw [ite_eq_right hil, Function.update_of_ne hil, Function.update_of_ne hic] + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +/-- One ordinary rewind step moves both designated tapes left, preserving the +full off-start frame. -/ +theorem binaryForTM_step_rewind_internal (body : TM n) + (counterIdx limitIdx : Fin n) (hne : counterIdx β‰  limitIdx) + (equalSoFar : Bool) (c : Cfg n (binaryForTM body counterIdx limitIdx).Q) + (hstate : c.state = .inl (.rewind equalSoFar)) + (hinput : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step c = some + { state := .inl (.rewind equalSoFar) + input := c.input + work := Function.update + (Function.update c.work counterIdx ((c.work counterIdx).move Dir3.left)) + limitIdx ((c.work limitIdx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [binaryForTM])] + have hnotboth : Β¬((c.work counterIdx).read = Ξ“.start ∧ + (c.work limitIdx).read = Ξ“.start) := by + intro h + exact hwork counterIdx h.1 + simp only [binaryForTM, hstate] + rw [ite_eq_right hnotboth] + dsimp only + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hic : i = counterIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_of_ne hne, Function.update_self, + writeAndMove_readBack _ (hwork counterIdx)] + simp [moveLeftDir, hwork counterIdx] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (hwork limitIdx)] + simp [moveLeftDir, hwork limitIdx] + Β· rw [ite_eq_right hil, Function.update_of_ne hil, Function.update_of_ne hic] + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +/-- When an equal comparison rewinds to both left markers, one preserving +step returns both designated heads to cell one and halts the loop. -/ +theorem binaryForTM_step_rewind_equal_internal (body : TM n) + (counterIdx limitIdx : Fin n) (hne : counterIdx β‰  limitIdx) + (c : Cfg n (binaryForTM body counterIdx limitIdx).Q) + (hstate : c.state = .inl (.rewind true)) + (hcounter : (c.work counterIdx).read = Ξ“.start) + (hlimit : (c.work limitIdx).read = Ξ“.start) + (hcounterHead : (c.work counterIdx).head = 0) + (hlimitHead : (c.work limitIdx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step c = some + { state := .inl .done + input := c.input + work := Function.update + (Function.update c.work counterIdx ((c.work counterIdx).move Dir3.right)) + limitIdx ((c.work limitIdx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [binaryForTM])] + simp only [binaryForTM, hstate] + rw [ite_eq_left ⟨hcounter, hlimit⟩] + dsimp only + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hic : i = counterIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_of_ne hne, Function.update_self] + show (((c.work counterIdx).write _).move Dir3.right) = + (c.work counterIdx).move Dir3.right + rw [Tape.write, ite_eq_left hcounterHead] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self] + show (((c.work limitIdx).write _).move Dir3.right) = + (c.work limitIdx).move Dir3.right + rw [Tape.write, ite_eq_left hlimitHead] + Β· rw [ite_eq_right hil, Function.update_of_ne hil, Function.update_of_ne hic] + exact transitionTape_eq_self (hother i hic hil) + Β· exact transitionTape_eq_self houtput + +/-- When an unequal comparison rewinds to both left markers, one preserving +step returns both designated heads to cell one and enters the composite +iteration. -/ +theorem binaryForTM_step_rewind_unequal_internal (body : TM n) + (counterIdx limitIdx : Fin n) (hne : counterIdx β‰  limitIdx) + (c : Cfg n (binaryForTM body counterIdx limitIdx).Q) + (hstate : c.state = .inl (.rewind false)) + (hcounter : (c.work counterIdx).read = Ξ“.start) + (hlimit : (c.work limitIdx).read = Ξ“.start) + (hcounterHead : (c.work counterIdx).head = 0) + (hlimitHead : (c.work limitIdx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  counterIdx β†’ i β‰  limitIdx β†’ + (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step c = some + { state := .inr (binaryForIterationTM body counterIdx).qstart + input := c.input + work := Function.update + (Function.update c.work counterIdx ((c.work counterIdx).move Dir3.right)) + limitIdx ((c.work limitIdx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (by rw [hstate]; simp [binaryForTM])] + simp only [binaryForTM, hstate] + rw [ite_eq_left ⟨hcounter, hlimit⟩] + dsimp only + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hic : i = counterIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_of_ne hne, Function.update_self] + show (((c.work counterIdx).write _).move Dir3.right) = + (c.work counterIdx).move Dir3.right + rw [Tape.write, ite_eq_left hcounterHead] + Β· rw [ite_eq_right hic] + by_cases hil : i = limitIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self] + show (((c.work limitIdx).write _).move Dir3.right) = + (c.work limitIdx).move Dir3.right + rw [Tape.write, ite_eq_left hlimitHead] + Β· rw [ite_eq_right hil, Function.update_of_ne hil, Function.update_of_ne hic] + exact transitionTape_eq_self (hother i hic hil) + Β· exact transitionTape_eq_self houtput + +/-- A halted composite iteration takes one preserving outer seam step back to +a fresh equality scan. -/ +theorem binaryForTM_step_iteration_halt_internal (body : TM n) + (counterIdx limitIdx : Fin n) + (c : Cfg n (binaryForIterationTM body counterIdx).Q) + (hhalt : (binaryForIterationTM body counterIdx).halted c) + (hinput : c.input.read β‰  Ξ“.start) + (hwork : βˆ€ i, (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryForTM body counterIdx limitIdx).step + (binaryForIterationWrap body counterIdx limitIdx c) = some + { state := .inl (.scan true) + input := c.input + work := c.work + output := c.output } := by + rw [TM.step, ite_eq_right (by simp [binaryForIterationWrap, binaryForTM])] + simp only [binaryForIterationWrap, binaryForTM, hhalt, allReadBack, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + exact transitionTape_eq_self (hwork i) + Β· exact transitionTape_eq_self houtput + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Loop.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Loop.lean new file mode 100644 index 0000000000..6622992fd5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryFor/Internal/Loop.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryFor.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Internal + +/-! +# Canonical binary count-up loops β€” proof internals + +This module turns the wrapper-free loop certificates from `BinaryFor.Defs` +into exact executions and all-prefix auxiliary-space bounds. It also proves +that the binary loop driver preserves the one-way-output discipline of its +body. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- A certified canonical binary count-up loop has its advertised exact +remaining run. -/ +theorem BinaryForLoopSpec.reachesIn_internal {body : TM n} + {counterIdx limitIdx : Fin n} {bodyTime : β„• β†’ β„•} {limitValue : β„•} + (spec : BinaryForLoopSpec body counterIdx limitIdx bodyTime limitValue) : + βˆ€ count value, value + count = limitValue β†’ + (binaryForTM body counterIdx limitIdx).reachesIn + (binaryForLoopTime bodyTime limitValue value count) + (spec.scanCfg value) spec.doneCfg := by + intro count + induction count with + | zero => + intro value hlimit + have hvalue : value = limitValue := by omega + subst value + exact spec.doneRun + | succ count ih => + intro value hlimit + have hvalue : value < limitValue := by omega + have htest := spec.testRun value hvalue + have hiteration := spec.iterationRun value hvalue + have hloopback : (binaryForTM body counterIdx limitIdx).reachesIn 1 + (spec.iterationDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have htail := ih (value + 1) (by omega) + have hreach := reachesIn_trans (binaryForTM body counterIdx limitIdx) htest + (reachesIn_trans (binaryForTM body counterIdx limitIdx) hiteration + (reachesIn_trans (binaryForTM body counterIdx limitIdx) hloopback htail)) + convert hreach using 1 + simp only [binaryForLoopTime] + omega + +/-- Scanner bounds are the reflexive prefixes of the comparison obligation. -/ +theorem BinaryForLoopSpaceSpec.scanWithin_internal + {body : TM n} {counterIdx limitIdx : Fin n} {bodyTime : β„• β†’ β„•} + {limitValue inputLength spaceBound value : β„•} + {spec : BinaryForLoopSpec body counterIdx limitIdx bodyTime limitValue} + (spaceSpec : BinaryForLoopSpaceSpec spec inputLength spaceBound) + (hvalue : value ≀ limitValue) : + (spec.scanCfg value).WithinAuxSpace inputLength spaceBound := + spaceSpec.testPrefixWithin value 0 (spec.scanCfg value) hvalue + (Nat.zero_le _) .zero + +/-- The final-state bound is the complete final comparison prefix. -/ +theorem BinaryForLoopSpaceSpec.doneWithin_internal + {body : TM n} {counterIdx limitIdx : Fin n} {bodyTime : β„• β†’ β„•} + {limitValue inputLength spaceBound : β„•} + {spec : BinaryForLoopSpec body counterIdx limitIdx bodyTime limitValue} + (spaceSpec : BinaryForLoopSpaceSpec spec inputLength spaceBound) : + spec.doneCfg.WithinAuxSpace inputLength spaceBound := + spaceSpec.testPrefixWithin limitValue (binaryForCompareTime limitValue) + spec.doneCfg le_rfl le_rfl spec.doneRun + +/-- Every configuration reached no later than a certified binary loop's exact +remaining runtime satisfies its auxiliary-space budget. -/ +theorem BinaryForLoopSpaceSpec.prefix_withinAuxSpace_internal + {body : TM n} {counterIdx limitIdx : Fin n} {bodyTime : β„• β†’ β„•} + {limitValue inputLength spaceBound : β„•} + {spec : BinaryForLoopSpec body counterIdx limitIdx bodyTime limitValue} + (spaceSpec : BinaryForLoopSpaceSpec spec inputLength spaceBound) : + βˆ€ count value t (c : Cfg n (binaryForTM body counterIdx limitIdx).Q), + value + count = limitValue β†’ + (binaryForTM body counterIdx limitIdx).reachesIn t (spec.scanCfg value) c β†’ + t ≀ binaryForLoopTime bodyTime limitValue value count β†’ + c.WithinAuxSpace inputLength spaceBound := by + intro count + induction count with + | zero => + intro value t c hlimit hreach htime + have hvalue : value = limitValue := by omega + subst value + simp only [binaryForLoopTime] at htime + exact spaceSpec.testPrefixWithin limitValue t c le_rfl htime hreach + | succ count ih => + intro value t c hlimit hreach htime + have hvalue : value < limitValue := by omega + by_cases htest : t ≀ binaryForCompareTime limitValue + Β· exact spaceSpec.testPrefixWithin value t c (Nat.le_of_lt hvalue) + htest hreach + Β· let iterationTime := t - binaryForCompareTime limitValue + have htimeEq : binaryForCompareTime limitValue + iterationTime = t := by + dsimp only [iterationTime] + exact Nat.add_sub_of_le (by omega) + by_cases hiteration : + iterationTime ≀ binaryForIterationTime bodyTime value + Β· obtain ⟨d, hprefix, _hsuffix⟩ := reachesIn_prefix_internal + (spec.iterationRun value hvalue) hiteration + have hcanonical : (binaryForTM body counterIdx limitIdx).reachesIn t + (spec.scanCfg value) d := by + have htotalRun := reachesIn_trans + (binaryForTM body counterIdx limitIdx) + (spec.testRun value hvalue) hprefix + simpa [htimeEq] using htotalRun + have hc := (binaryForTM body counterIdx limitIdx).reachesIn_right_unique + hreach hcanonical + rw [hc] + exact spaceSpec.iterationPrefixWithin value iterationTime d hvalue + hiteration hprefix + Β· let prefixTime := binaryForCompareTime limitValue + + binaryForIterationTime bodyTime value + 1 + have hprefixTime : prefixTime ≀ t := by + dsimp only [prefixTime, iterationTime] at ⊒ hiteration + omega + let tailTime := t - prefixTime + have htailEq : prefixTime + tailTime = t := by + dsimp only [tailTime] + exact Nat.add_sub_of_le hprefixTime + have htailBound : + tailTime ≀ + binaryForLoopTime bodyTime limitValue (value + 1) count := by + rw [binaryForLoopTime] at htime + dsimp only [prefixTime, tailTime] at ⊒ + omega + have htailFull := spec.reachesIn_internal count (value + 1) (by omega) + obtain ⟨d, htail, _hsuffix⟩ := reachesIn_prefix_internal + htailFull htailBound + have hloopback : (binaryForTM body counterIdx limitIdx).reachesIn 1 + (spec.iterationDoneCfg value) (spec.scanCfg (value + 1)) := + .step (spec.loopbackStep value hvalue) .zero + have hcanonical := reachesIn_trans + (binaryForTM body counterIdx limitIdx) (spec.testRun value hvalue) + (reachesIn_trans (binaryForTM body counterIdx limitIdx) + (spec.iterationRun value hvalue) + (reachesIn_trans (binaryForTM body counterIdx limitIdx) + hloopback htail)) + have hcanonical' : (binaryForTM body counterIdx limitIdx).reachesIn t + (spec.scanCfg value) d := by + convert hcanonical using 1 + all_goals + dsimp only [prefixTime] at htailEq ⊒ + omega + have hc := (binaryForTM body counterIdx limitIdx).reachesIn_right_unique + hreach hcanonical' + rw [hc] + exact ih (value + 1) tailTime d (by omega) htail htailBound + +/-- A canonical binary count-up loop preserves the body's one-way-output +discipline. -/ +theorem IsTransducer.binaryForTM_internal {body : TM n} + (hbody : body.IsTransducer) (counterIdx limitIdx : Fin n) : + (binaryForTM body counterIdx limitIdx).IsTransducer := by + have hiteration : (binaryForIterationTM body counterIdx).IsTransducer := by + exact hbody.seqTM_internal (binarySuccTM_isTransducer_internal counterIdx) + intro state iHead wHeads oHead + cases state with + | inl phase => + cases phase with + | scan equalSoFar => + simp only [binaryForTM] + split <;> simp [idleDir] <;> split <;> decide + | rewind equalSoFar => + simp only [binaryForTM] + split <;> simp [idleDir] <;> split <;> decide + | done => + simp [binaryForTM, allIdle, idleDir] + split <;> decide + | inr q => + by_cases hq : q = (binaryForIterationTM body counterIdx).qhalt + Β· simp [binaryForTM, hq, allReadBack, idleDir] + split <;> decide + Β· simpa [binaryForTM, hq] using hiteration q iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred.lean new file mode 100644 index 0000000000..7b08cb9bb0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Internal + +/-! +# Little-endian binary predecessor + +This module exposes the canonical semantics and compositional contracts for +`TM.binaryPredTM`. Natural numbers use little-endian `Nat.bits`. On positive +input `value + 1`, borrow propagates through initial zero bits, canonicalizes +the high bit when decrementing a power of two, and rewinds the target tape. + +The machine is total on canonical zero and leaves its empty representation +unchanged, but the decrement theorems deliberately require the target to +represent `value + 1`; they make no underflow claim. + +## Main results + +- `BinaryPred.ripple_succ_natBits` β€” pure borrow computes predecessor. +- `TM.binaryPredTM_reachesIn_frame` β€” exact execution with a full tape frame. +- `TM.binaryPredTM_hoareTimeSpace_frame` β€” terminating and all-reachable + width-based space contract. +- `TM.binaryPredTM_isTransducer` β€” the output head never moves left. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryPred + +/-- Ripple borrow on the canonical bits of a positive natural computes its +predecessor, including high-bit erasure for powers of two. -/ +theorem ripple_succ_natBits (value : β„•) : + ripple (value + 1).bits = value.bits := + ripple_succ_natBits_internal value + +/-- The exact transition count is at most twice the represented positive +input width, plus two. -/ +theorem steps_le (bits : List Bool) : + steps bits ≀ 2 * bits.length + 2 := + steps_le_internal bits + +end BinaryPred + +namespace TM + +/-- Exact predecessor time is bounded linearly in the binary width of the +positive input `value + 1`. -/ +theorem binaryPredTime_le (value : β„•) : + binaryPredTime value ≀ 2 * (value + 1).size + 2 := + binaryPredTime_le_internal value + +/-- Starting on canonical positive `value + 1`, `binaryPredTM` halts after +exactly `binaryPredTime value` transitions with canonical `value`. Input, +output, and every unrelated work tape are preserved exactly. The positive +precondition is the explicit no-underflow boundary of this contract. -/ +theorem binaryPredTM_reachesIn_frame {n : β„•} + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryPredTM idx).reachesIn (binaryPredTime value) + { state := (binaryPredTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryPredTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryNat value ∧ + c'.output = outβ‚€ := + binaryPredTM_reachesIn_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout + +/-- Time-bounded compositional form of `binaryPredTM_reachesIn_frame`. -/ +theorem binaryPredTM_hoareTime_frame {n : β„•} + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binaryPredTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat value ∧ + out = outβ‚€) + (binaryPredTime value) := + binaryPredTM_hoareTime_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout + +/-- Time-and-space contract for positive canonical predecessor. Every +reachable configuration stays inside the explicit width-based budget +`binaryPredSpace initialSpace value`; this is independent of the represented +numeric magnitude except through its binary width. -/ +theorem binaryPredTM_hoareTimeSpace_frame {n : β„•} + (idx : Fin n) (value inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (hinitial : + ({ state := (binaryPredTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryPredTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (binaryPredTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat value ∧ + out = outβ‚€) + (binaryPredTime value) inputLength + (binaryPredSpace initialSpace value) := + binaryPredTM_hoareTimeSpace_frame_internal idx value inputLength initialSpace + inpβ‚€ workβ‚€ outβ‚€ hvalue hinp hother hout hinitial + +/-- `binaryPredTM` never moves the output head left, so it is safe in +one-way-output, space-bounded compositions. -/ +theorem binaryPredTM_isTransducer {n : β„•} (idx : Fin n) : + (binaryPredTM idx).IsTransducer := + binaryPredTM_isTransducer_internal idx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Defs.lean new file mode 100644 index 0000000000..b3bc78b87c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Defs.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import Mathlib.Data.Nat.Bits + +/-! +# Little-endian binary predecessor β€” definitions + +This module defines the finite controller for in-place predecessor on a +positive canonical binary natural. Borrow turns initial low-order zero bits +into ones. The first one becomes zero; when it was the unique high bit, a +one-cell lookahead detects the terminating blank and erases that now-redundant +zero before rewinding. + +The controller is total on zero, where it simply rewinds the unchanged empty +representation. Public correctness theorems intentionally start from +`value + 1`, so no underflow behavior is claimed. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryPred + +/-- Ripple one borrow through a little-endian bit string, dropping a vacated +unique high bit. The empty case defines underflow as unchanged zero. -/ +def ripple : List Bool β†’ List Bool + | [] => [] + | false :: rest => true :: ripple rest + | [true] => [] + | true :: bit :: rest => false :: bit :: rest + +/-- Exact transition count used by `binaryPredTM` on a canonical bit string. -/ +def steps : List Bool β†’ β„• + | [] => 2 + | false :: rest => steps rest + 2 + | true :: _ => 4 + +end BinaryPred + +namespace TM + +/-- Finite phases of ripple-borrow predecessor. -/ +inductive BinaryPredPhase where + | borrow + | check + | erase + | rewind + | done + deriving DecidableEq + +/-- `BinaryPredPhase` has exactly five states. -/ +instance instFintypeBinaryPredPhase : Fintype BinaryPredPhase where + elems := {.borrow, .check, .erase, .rewind, .done} + complete := fun state => by cases state <;> simp + +/-- Exact running time for decrementing canonical `value + 1` to `value`. -/ +def binaryPredTime (value : β„•) : β„• := + BinaryPred.steps (value + 1).bits + +/-- Explicit width-based all-prefix space budget for predecessor. -/ +def binaryPredSpace (initialSpace value : β„•) : β„• := + initialSpace + 2 * (value + 1).size + 2 + +/-- Decrement a positive canonical little-endian natural on work tape `idx`. + +The borrow phase flips initial zeros to ones and replaces the first one by +zero. A lookahead distinguishes an internal bit from the terminating blank; +the latter case erases the vacated high zero. The machine finally rewinds to +cell one. On canonical zero it takes the blank branch and leaves zero intact. +-/ +def binaryPredTM {n : β„•} (idx : Fin n) : TM n where + Q := BinaryPredPhase + qstart := .borrow + qhalt := .done + Ξ΄ := fun phase iHead wHeads oHead => + match phase with + | .borrow => + match wHeads idx with + | .zero => + (.borrow, + fun i => if i = idx then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .one => + (.check, + fun i => if i = idx then Ξ“w.zero else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .blank => + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .start => + (.borrow, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .check => + match wHeads idx with + | .blank => + (.erase, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .start => + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .zero | .one => + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .erase => + if wHeads idx = Ξ“.start then + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewind, + fun i => if i = idx then Ξ“w.blank else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .rewind => + if wHeads idx = Ξ“.start then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro phase iHead wHeads oHead + match phase with + | .borrow => + dsimp only + match htarget : wHeads idx with + | .zero | .one | .blank => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + rw [htarget] at hi + exact absurd hi (by decide) + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .start => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .check => + dsimp only + match htarget : wHeads idx with + | .zero | .one | .blank => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + rw [htarget] at hi + exact absurd hi (by decide) + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .start => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, + idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .erase => + dsimp only + split + Β· simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + Β· next hnotStart => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + exact absurd hi hnotStart + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .rewind => + dsimp only + split + Β· simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + Β· next hnotStart => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + exact absurd hi hnotStart + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Internal.lean new file mode 100644 index 0000000000..141f1f17d5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryPred/Internal.lean @@ -0,0 +1,918 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryPred.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import Mathlib.Algebra.Order.Ring.Nat +public import Mathlib.Algebra.Order.Sub.Basic + +/-! +# Little-endian binary predecessor β€” proof internals + +This file proves pure ripple-borrow semantics and the exact full-frame +execution of `TM.binaryPredTM`. The machine proof tracks the already-borrowed +low-order prefix independently of the target head, including the canonical +high-bit erasure needed when decrementing a power of two. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryPred + +/-- Internal proof that ripple borrow on a positive canonical value computes +its predecessor. -/ +theorem ripple_succ_natBits_internal (value : β„•) : + ripple (value + 1).bits = value.bits := by + induction value using Nat.binaryRec' with + | zero => simp [ripple] + | bit bit value hcanonical ih => + rw [Nat.bits_append_bit value bit hcanonical] + cases bit with + | false => + have hvalue : value β‰  0 := by + intro hzero + have := hcanonical hzero + contradiction + rw [show Nat.bit false value + 1 = Nat.bit true value by + simp [Nat.bit]] + rw [Nat.bits_append_bit value true (fun _ => rfl)] + cases hbits : value.bits with + | nil => + exfalso + apply hvalue + have hdecoded := Nat.fromBitsLE_bits value + rw [hbits] at hdecoded + simpa [Nat.fromBitsLE, Nat.fromBits] using hdecoded.symm + | cons first rest => simp [ripple] + | true => + rw [show Nat.bit true value + 1 = Nat.bit false (value + 1) by + simp [Nat.bit] + omega] + rw [Nat.bits_append_bit (value + 1) false (by omega)] + simp only [ripple] + rw [ih] + +/-- Internal worst-case bound for predecessor's exact transition count. -/ +theorem steps_le_internal (bits : List Bool) : + steps bits ≀ 2 * bits.length + 2 := by + induction bits with + | nil => simp [steps] + | cons bit bits ih => + cases bit + Β· simp only [steps, List.length_cons] + omega + Β· simp [steps] + +end BinaryPred + +namespace Tape + +private theorem HasBinaryContent.binaryPred_read_cons {t : Tape} {done : β„•} + {bit : Bool} {rest : List Bool} + (h : t.HasBinaryContent (List.replicate done true ++ bit :: rest)) + (hhead : t.head = done + 1) : t.read = Ξ“.ofBool bit := by + rw [Tape.read, hhead] + have hcell := h.1 done (by simp) + simpa using hcell + +private theorem HasBinaryContent.binaryPred_read_nil {t : Tape} {done : β„•} + (h : t.HasBinaryContent (List.replicate done true)) + (hhead : t.head = done + 1) : t.read = Ξ“.blank := by + rw [Tape.read, hhead] + exact h.2 done (by simp) + +/-- Replacing the last represented bit by blank shortens canonical contents. -/ +private theorem HasBinaryContent.binaryPred_erase_last {t : Tape} + {bitsPrefix : List Bool} + (h : t.HasBinaryContent (bitsPrefix ++ [false])) + (hhead : t.head = bitsPrefix.length + 1) : + (t.write Ξ“.blank).HasBinaryContent bitsPrefix := by + have hhead0 : t.head β‰  0 := by omega + constructor + Β· intro i hi + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [hhead, Function.update_of_ne (by omega)] + have hcell := h.1 i (by simp; omega) + simpa [List.getElem_append, hi] using hcell + Β· intro i hi + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [hhead] + by_cases heq : i = bitsPrefix.length + Β· subst i + rw [Function.update_self] + Β· rw [Function.update_of_ne (by omega)] + exact h.2 i (by simp; omega) + +end Tape + +namespace BinaryPred + +private theorem set_false_to_true (done : β„•) (rest : List Bool) : + (List.replicate done true ++ false :: rest).set done true = + List.replicate (done + 1) true ++ rest := by + induction done with + | zero => rfl + | succ done ih => + change true :: (List.replicate done true ++ false :: rest).set done true = + true :: true :: (List.replicate done true ++ rest) + congr 1 + +private theorem set_true_to_false (done : β„•) (rest : List Bool) : + (List.replicate done true ++ true :: rest).set done false = + List.replicate done true ++ false :: rest := by + induction done with + | zero => rfl + | succ done ih => + change true :: (List.replicate done true ++ true :: rest).set done false = + true :: (List.replicate done true ++ false :: rest) + congr 1 + +end BinaryPred + +namespace TM + +variable {n : β„•} {idx : Fin n} + +private theorem binaryPredTM_ne_halt {phase : BinaryPredPhase} + (hne : phase β‰  .done) {c : Cfg n (binaryPredTM idx).Q} + (hstate : c.state = phase) : + c.state β‰  (binaryPredTM idx).qhalt := by + rw [hstate] + exact hne + +/-- Propagate borrow over one low-order zero. -/ +private theorem binaryPredTM_step_zero (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .borrow) (hread : (c.work idx).read = Ξ“.zero) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .borrow + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.one).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Resolve borrow at the first one and advance to lookahead. -/ +private theorem binaryPredTM_step_one (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .borrow) (hread : (c.work idx).read = Ξ“.one) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .check + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.zero).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Define zero underflow by turning left from the terminating blank. -/ +private theorem binaryPredTM_step_borrow_blank + (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .borrow) (hread : (c.work idx).read = Ξ“.blank) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hread]; decide)] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- A nonblank lookahead turns left and begins rewinding. -/ +private theorem binaryPredTM_step_check_bit (bit : Bool) + (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .check) + (hread : (c.work idx).read = Ξ“.ofBool bit) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + cases bit <;> simp only [Ξ“.ofBool, binaryPredTM, hstate, hread] + all_goals + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hread]; decide)] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- A blank lookahead identifies a vacated unique high bit. -/ +private theorem binaryPredTM_step_check_blank + (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .check) (hread : (c.work idx).read = Ξ“.blank) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .erase + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ (by rw [hread]; decide)] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Erase the vacated high zero and turn left. -/ +private theorem binaryPredTM_step_erase (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .erase) (hread : (c.work idx).read β‰  Ξ“.start) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.blank).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Rewind one ordinary target cell to the left. -/ +private theorem binaryPredTM_step_rewind (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read β‰  Ξ“.start) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ hread] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Bounce right from the left marker and halt. -/ +private theorem binaryPredTM_step_start (c : Cfg n (binaryPredTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read = Ξ“.start) + (hhead : (c.work idx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryPredTM idx).step c = some + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryPredTM_ne_halt (by decide) hstate)] + simp only [binaryPredTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + show (((c.work idx).write _).move Dir3.right) = + (c.work idx).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-! ## Exact rewind and borrow runs -/ + +private theorem binaryPredTM_rewind_run (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ head (c : Cfg n (binaryPredTM idx).Q), + c.state = .rewind β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = workβ‚€ i) β†’ + (c.work idx).HasBinaryContent bits β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (c.work idx).head = head β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binaryPredTM idx).reachesIn (head + 1) c c' ∧ + (binaryPredTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryString bits ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro head + induction head with + | zero => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binaryPredTM_step_start c hstate hread hhead + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + Β· intro i hi + show Function.update c.work idx ((c.work idx).move Dir3.right) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi + Β· show (Function.update c.work idx ((c.work idx).move Dir3.right) idx) + |>.HasBinaryString bits + rw [Function.update_self] + apply Tape.HasBinaryContent.hasBinaryString + Β· simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent + Β· simp [Tape.move, hhead] + Β· show (Function.update c.work idx ((c.work idx).move Dir3.right) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | succ head ih => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read β‰  Ξ“.start := by + rw [Tape.read, hhead] + exact hcontent.cells_ne_start (head + 1) (by omega) + have hstep := binaryPredTM_step_rewind c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx ((c.work idx).move Dir3.left) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx) + |>.HasBinaryContent bits + rw [Function.update_self] + simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).head = + head + rw [Function.update_self] + simp [Tape.move, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ + simpa [Nat.succ_eq_add_one, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + +/-- Borrowing through the last one bit erases it and rewinds the completed predecessor. -/ +private theorem binaryPredTM_borrow_terminal_one + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ done (c : Cfg n (binaryPredTM idx).Q), + c.state = .borrow β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = workβ‚€ i) β†’ + (c.work idx).HasBinaryContent (List.replicate done true ++ [true]) β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (c.work idx).head = done + 1 β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binaryPredTM idx).reachesIn (done + BinaryPred.steps [true]) c c' ∧ + (binaryPredTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryString + (List.replicate done true ++ BinaryPred.ripple [true]) ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro done + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.one := + hcontent.binaryPred_read_cons hhead + have hstep := binaryPredTM_step_one c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target₁ : Tape := + ((c.work idx).write Ξ“.zero).move Dir3.right + have htarget₁Content : target₁.HasBinaryContent + (List.replicate done true ++ [false]) := by + have hwrite := hcontent.write_set false hhead (by simp) + rw [BinaryPred.set_true_to_false] at hwrite + simpa only [target₁, Tape.HasBinaryContent, Tape.move_cells] + using! hwrite + have htarget₁Cell0 : target₁.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.zero Dir3.right hcell0 + have htarget₁Head : target₁.head = done + 2 := by + simp [target₁, Tape.move, Tape.write_head, hhead] + have htarget₁Read : target₁.read = Ξ“.blank := by + rw [Tape.read, htarget₁Head] + exact htarget₁Content.2 (done + 1) (by simp) + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .check + input := c.input + work := Function.update c.work idx target₁ + output := c.output } + have hcheck := binaryPredTM_step_check_blank c₁ rfl + (by simpa [c₁] using htarget₁Read) + (by rw [hinput]; exact hinp) + (fun i hi => by + simp only [c₁, Function.update_of_ne hi] + rw [hwork i hi] + exact hother i hi) + (by rw [houtput]; exact hout) + let targetβ‚‚ : Tape := target₁.move Dir3.left + have htargetβ‚‚Content : targetβ‚‚.HasBinaryContent + (List.replicate done true ++ [false]) := by + simpa only [targetβ‚‚] using htarget₁Content.move Dir3.left + have htargetβ‚‚Cell0 : targetβ‚‚.cells 0 = Ξ“.start := by + simpa [targetβ‚‚, Tape.move_cells] using htarget₁Cell0 + have htargetβ‚‚Head : targetβ‚‚.head = done + 1 := by + simp [targetβ‚‚, Tape.move, htarget₁Head] + have htargetβ‚‚Read : targetβ‚‚.read β‰  Ξ“.start := + htargetβ‚‚Content.cells_ne_start targetβ‚‚.head (by + rw [htargetβ‚‚Head] + omega) + let cβ‚‚ : Cfg n (binaryPredTM idx).Q := + { state := .erase + input := c.input + work := Function.update c.work idx targetβ‚‚ + output := c.output } + have herase := binaryPredTM_step_erase cβ‚‚ rfl + (by simpa [cβ‚‚] using htargetβ‚‚Read) + (by rw [hinput]; exact hinp) + (fun i hi => by + simp only [cβ‚‚, Function.update_of_ne hi] + rw [hwork i hi] + exact hother i hi) + (by rw [houtput]; exact hout) + let target₃ : Tape := + (targetβ‚‚.write Ξ“.blank).move Dir3.left + have htarget₃Content : + target₃.HasBinaryContent (List.replicate done true) := by + have herased := htargetβ‚‚Content.binaryPred_erase_last (by + simpa using htargetβ‚‚Head) + simpa only [target₃] using herased.move Dir3.left + have htarget₃Cell0 : target₃.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.blank Dir3.left htargetβ‚‚Cell0 + have htarget₃Head : target₃.head = done := by + simp [target₃, Tape.move, Tape.write_head, htargetβ‚‚Head] + let c₃ : Cfg n (binaryPredTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target₃ + output := c.output } + have hcheck' : (binaryPredTM idx).step c₁ = some cβ‚‚ := by + simpa [c₁, cβ‚‚, targetβ‚‚] using hcheck + have herase' : (binaryPredTM idx).step cβ‚‚ = some c₃ := by + simpa [cβ‚‚, c₃, target₃] using herase + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, + hcell0', houtput'⟩ := + binaryPredTM_rewind_run (idx := idx) + (List.replicate done true) inpβ‚€ workβ‚€ outβ‚€ hinp hother + hout done c₃ rfl hinput + (fun i hi => by + show Function.update c.work idx target₃ i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target₃ idx) + |>.HasBinaryContent _ + rw [Function.update_self] + exact htarget₃Content) + (by + show (Function.update c.work idx target₃ idx).cells 0 = _ + rw [Function.update_self] + exact htarget₃Cell0) + (by + show (Function.update c.work idx target₃ idx).head = done + rw [Function.update_self] + exact htarget₃Head) + houtput + have hprefix : (binaryPredTM idx).reachesIn 3 c c₃ := by + exact .step hstep (.step hcheck' (.step herase' .zero)) + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· have hrun := reachesIn_trans (binaryPredTM idx) hprefix hreach + convert! hrun using 1 + all_goals simp [BinaryPred.steps] + all_goals omega + Β· simpa [BinaryPred.ripple] using hstring + +private theorem binaryPredTM_borrow_run + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ done bits (c : Cfg n (binaryPredTM idx).Q), + c.state = .borrow β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = workβ‚€ i) β†’ + (c.work idx).HasBinaryContent (List.replicate done true ++ bits) β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (c.work idx).head = done + 1 β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binaryPredTM idx).reachesIn (done + BinaryPred.steps bits) c c' ∧ + (binaryPredTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryString + (List.replicate done true ++ BinaryPred.ripple bits) ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro done bits + induction bits generalizing done with + | nil => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hcontent' : + (c.work idx).HasBinaryContent (List.replicate done true) := by + simpa using hcontent + have hread : (c.work idx).read = Ξ“.blank := + hcontent'.binaryPred_read_nil hhead + have hstep := binaryPredTM_step_borrow_blank c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := (c.work idx).move Dir3.left + have htargetContent : + target.HasBinaryContent (List.replicate done true) := by + simpa only [target] using hcontent'.move Dir3.left + have htargetCell0 : target.cells 0 = Ξ“.start := by + simpa [target, Tape.move_cells] using hcell0 + have htargetHead : target.head = done := by + simp [target, Tape.move, hhead] + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binaryPredTM_rewind_run (idx := idx) (List.replicate done true) + inpβ‚€ workβ‚€ outβ‚€ hinp hother hout done c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = done + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· simpa [BinaryPred.steps, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + Β· simpa [BinaryPred.ripple] using hstring + | cons bit rest ih => + cases bit with + | false => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.zero := + hcontent.binaryPred_read_cons hhead + have hstep := binaryPredTM_step_zero c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Ξ“.one).move Dir3.right + have htargetContent : target.HasBinaryContent + (List.replicate (done + 1) true ++ rest) := by + have hwrite := hcontent.write_set true hhead (by simp) + rw [BinaryPred.set_false_to_true] at hwrite + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using! + hwrite + have htargetCell0 : target.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.one Dir3.right hcell0 + have htargetHead : target.head = (done + 1) + 1 := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .borrow + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih (done + 1) c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = + (done + 1) + 1 + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· convert! TM.reachesIn.step hstep hreach using 1 + all_goals simp [BinaryPred.steps, Nat.add_assoc] + all_goals omega + Β· simpa [BinaryPred.ripple, List.replicate_add, + List.append_assoc] using hstring + | true => + cases rest with + | nil => + exact binaryPredTM_borrow_terminal_one inpβ‚€ workβ‚€ outβ‚€ + hinp hother hout done + | cons next rest => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.one := + hcontent.binaryPred_read_cons hhead + have hstep := binaryPredTM_step_one c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target₁ : Tape := + ((c.work idx).write Ξ“.zero).move Dir3.right + have htarget₁Content : target₁.HasBinaryContent + (List.replicate done true ++ false :: next :: rest) := by + have hwrite := hcontent.write_set false hhead (by simp) + rw [BinaryPred.set_true_to_false] at hwrite + simpa only [target₁, Tape.HasBinaryContent, Tape.move_cells] + using! hwrite + have htarget₁Cell0 : target₁.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.zero Dir3.right hcell0 + have htarget₁Head : target₁.head = done + 2 := by + simp [target₁, Tape.move, Tape.write_head, hhead] + have htarget₁Read : target₁.read = Ξ“.ofBool next := by + rw [Tape.read, htarget₁Head] + have hcell := htarget₁Content.1 (done + 1) (by simp) + simpa [List.getElem_append] using hcell + let c₁ : Cfg n (binaryPredTM idx).Q := + { state := .check + input := c.input + work := Function.update c.work idx target₁ + output := c.output } + have hcheck := binaryPredTM_step_check_bit next c₁ rfl + (by simpa [c₁] using htarget₁Read) + (by rw [hinput]; exact hinp) + (fun i hi => by + simp only [c₁, Function.update_of_ne hi] + rw [hwork i hi] + exact hother i hi) + (by rw [houtput]; exact hout) + let targetβ‚‚ : Tape := target₁.move Dir3.left + have htargetβ‚‚Content : targetβ‚‚.HasBinaryContent + (List.replicate done true ++ false :: next :: rest) := by + simpa only [targetβ‚‚] using htarget₁Content.move Dir3.left + have htargetβ‚‚Cell0 : targetβ‚‚.cells 0 = Ξ“.start := by + simpa [targetβ‚‚, Tape.move_cells] using htarget₁Cell0 + have htargetβ‚‚Head : targetβ‚‚.head = done + 1 := by + simp [targetβ‚‚, Tape.move, htarget₁Head] + let cβ‚‚ : Cfg n (binaryPredTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx targetβ‚‚ + output := c.output } + have hcheck' : (binaryPredTM idx).step c₁ = some cβ‚‚ := by + simpa [c₁, cβ‚‚, targetβ‚‚] using hcheck + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, + hcell0', houtput'⟩ := + binaryPredTM_rewind_run (idx := idx) + (List.replicate done true ++ false :: next :: rest) + inpβ‚€ workβ‚€ outβ‚€ hinp hother hout (done + 1) cβ‚‚ rfl hinput + (fun i hi => by + show Function.update c.work idx targetβ‚‚ i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx targetβ‚‚ idx) + |>.HasBinaryContent _ + rw [Function.update_self] + exact htargetβ‚‚Content) + (by + show (Function.update c.work idx targetβ‚‚ idx).cells 0 = _ + rw [Function.update_self] + exact htargetβ‚‚Cell0) + (by + show (Function.update c.work idx targetβ‚‚ idx).head = done + 1 + rw [Function.update_self] + exact htargetβ‚‚Head) + houtput + have hprefix : (binaryPredTM idx).reachesIn 2 c cβ‚‚ := by + exact .step hstep (.step hcheck' .zero) + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· have hrun := reachesIn_trans (binaryPredTM idx) hprefix hreach + convert! hrun using 1 + all_goals simp [BinaryPred.steps] + all_goals omega + Β· simpa [BinaryPred.ripple] using hstring + +/-! ## Public-theorem internals -/ + +theorem binaryPredTime_le_internal (value : β„•) : + binaryPredTime value ≀ 2 * (value + 1).size + 2 := by + simpa [binaryPredTime, Nat.size_eq_bits_len] using + BinaryPred.steps_le_internal (value + 1).bits + +theorem binaryPredTM_reachesIn_frame_internal + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryPredTM idx).reachesIn (binaryPredTime value) + { state := (binaryPredTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryPredTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryNat value ∧ + c'.output = outβ‚€ := by + let cβ‚€ : Cfg n (binaryPredTM idx).Q := + { state := (binaryPredTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + obtain ⟨c', hreach, hhalt, hinput, hwork, hstring, hcell0, houtput⟩ := + binaryPredTM_borrow_run (idx := idx) inpβ‚€ workβ‚€ outβ‚€ hinp hother hout + 0 (value + 1).bits cβ‚€ (by rfl) (by rfl) (fun _ _ => rfl) + (by simpa [cβ‚€] using hvalue.2.hasBinaryContent) hvalue.1 + (by simpa [cβ‚€] using hvalue.2.1) (by rfl) + refine ⟨c', ?_, hhalt, hinput, hwork, ?_, houtput⟩ + Β· simpa [cβ‚€, binaryPredTime] using hreach + Β· exact ⟨hcell0, by + simpa [BinaryPred.ripple_succ_natBits_internal] using hstring⟩ + +theorem binaryPredTM_hoareTime_frame_internal + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binaryPredTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat value ∧ + out = outβ‚€) + (binaryPredTime value) := by + rintro inp work out ⟨hinputβ‚€, hworkβ‚€, houtputβ‚€βŸ© + obtain ⟨c', hreach, hhalt, hinput, hwork, hvalue', houtput⟩ := + binaryPredTM_reachesIn_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout + refine ⟨c', binaryPredTime value, le_rfl, ?_, hhalt, + hinput, hwork, hvalue', houtput⟩ + simpa [hinputβ‚€, hworkβ‚€, houtputβ‚€] using hreach + +theorem binaryPredTM_hoareTimeSpace_frame_internal + (idx : Fin n) (value inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat (value + 1)) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (hinitial : + ({ state := (binaryPredTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryPredTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (binaryPredTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat value ∧ + out = outβ‚€) + (binaryPredTime value) inputLength + (binaryPredSpace initialSpace value) := by + have htimeSpace := + (binaryPredTM_hoareTime_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout).toHoareTimeSpace (by + rintro inp work out ⟨hinputβ‚€, hworkβ‚€, houtputβ‚€βŸ© + simpa [hinputβ‚€, hworkβ‚€, houtputβ‚€] using hinitial) + refine htimeSpace.consequence (fun _ _ _ h => h) (fun _ _ _ h => h) + le_rfl le_rfl ?_ + have htime := binaryPredTime_le_internal value + simp only [binaryPredSpace] + omega + +theorem binaryPredTM_isTransducer_internal (idx : Fin n) : + (binaryPredTM idx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | borrow => + cases hread : wHeads idx <;> + simp [binaryPredTM, hread, idleDir] <;> + split <;> decide + | check => + cases hread : wHeads idx <;> + simp [binaryPredTM, hread, idleDir] <;> + split <;> decide + | erase => + simp only [binaryPredTM] + split <;> simp [idleDir] <;> split <;> decide + | rewind => + simp only [binaryPredTM] + split <;> simp [idleDir] <;> split <;> decide + | done => + simp [binaryPredTM, allIdle, idleDir] + split <;> decide + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd.lean new file mode 100644 index 0000000000..f965a90414 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal + +/-! +# Linear-time canonical binary addition + +This module exposes a concrete three-tape ripple-carry adder. It preserves two +canonical little-endian operands, writes their canonical sum to a fresh zero +result tape, restores every owned head to cell one, and preserves the complete +external tape frame. Its running time is linear in the operand bit widths. + +The older `TM.binaryAddIntoTM` remains useful as a value-iterating count-up +routine; complexity-sensitive RAM simulation should use this width-linear +machine instead. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleAdd + +/-- Ripple carry over canonical little-endian encodings computes addition. -/ +theorem ripple_natBits (lhs rhs : β„•) : + ripple false lhs.bits rhs.bits = (lhs + rhs).bits := + ripple_natBits_internal lhs rhs + +end BinaryRippleAdd + +namespace TM + +/-- The scan bound is one more than the larger operand width. -/ +theorem binaryRippleAddScanTime_natBits (lhs rhs : β„•) : + binaryRippleAddScanTime lhs.bits rhs.bits = + max lhs.size rhs.size + 1 := + binaryRippleAddScanTime_natBits_internal lhs rhs + +/-- Addition increases binary width by at most one over the larger operand. -/ +theorem binaryRippleAdd_sum_size_le (lhs rhs : β„•) : + (lhs + rhs).size ≀ max lhs.size rhs.size + 1 := + size_add_le_max_add_one_internal lhs rhs + +/-- The complete scan-and-rewind machine has a linear bit-width envelope. -/ +theorem binaryRippleAddTime_le (lhs rhs : β„•) : + binaryRippleAddTime lhs rhs ≀ + 3 * (lhs.size + rhs.size) + 14 := + binaryRippleAddTime_le_internal lhs rhs + +/-- Framed time contract for canonical addition. Both operands are restored, +the initially-zero result becomes their sum, and every unrelated tape is +preserved exactly. -/ +theorem binaryRippleAddTM_hoareTime_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs + rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryRippleAddTime lhs rhs) := + binaryRippleAddTM_hoareTime_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother + houtput + +/-- Reachability form of the framed addition theorem. -/ +theorem binaryRippleAddTM_reachesIn_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆƒ c' time, + time ≀ binaryRippleAddTime lhs rhs ∧ + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).reachesIn time + { state := (binaryRippleAddTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).HasBinaryNat lhs ∧ + (c'.work rhsIdx).HasBinaryNat rhs ∧ + (c'.work resultIdx).HasBinaryNat (lhs + rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + exact binaryRippleAddTM_hoareTime_frame lhsIdx rhsIdx resultIdx hdistinct + lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother houtput + inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + +/-- All-prefix auxiliary-space contract obtained from the concrete linear +time bound. -/ +theorem binaryRippleAddTM_hoareTimeSpace_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryRippleAddTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryRippleAddTM lhsIdx rhsIdx resultIdx).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs + rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryRippleAddTime lhs rhs) inputLength + (initialSpace + binaryRippleAddTime lhs rhs) := + binaryRippleAddTM_hoareTimeSpace_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inputLength initialSpace inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult hinput hother houtput hinitial + +/-- Canonical addition never moves the public output head left. -/ +theorem binaryRippleAddTM_isTransducer {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).IsTransducer := + binaryRippleAddTM_isTransducer_internal lhsIdx rhsIdx resultIdx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Defs.lean new file mode 100644 index 0000000000..d91cf236a0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Defs.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import Mathlib.Data.Nat.Bits + +/-! +# Linear-time canonical binary addition -- definitions + +This module defines a finite-state ripple-carry scan over two preserved +little-endian binary work tapes. Each scan step appends one sum bit to a fresh +result tape. A composed wrapper then rewinds all three owned tapes. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleAdd + +/-- The output bit of a one-column binary addition with incoming carry. -/ +def sumBit (carry lhs rhs : Bool) : Bool := + (lhs.xor rhs).xor carry + +/-- The outgoing carry of a one-column binary addition. -/ +def carryBit (carry lhs rhs : Bool) : Bool := + (lhs && rhs) || (carry && lhs) || (carry && rhs) + +/-- Ripple-carry addition on little-endian bit strings, padding a missing side +with zero and emitting a final high bit exactly when the carry remains set. -/ +def ripple : Bool β†’ List Bool β†’ List Bool β†’ List Bool + | false, [], [] => [] + | true, [], [] => [true] + | carry, lhs :: lhsTail, [] => + sumBit carry lhs false :: ripple (carryBit carry lhs false) lhsTail [] + | carry, [], rhs :: rhsTail => + sumBit carry false rhs :: ripple (carryBit carry false rhs) [] rhsTail + | carry, lhs :: lhsTail, rhs :: rhsTail => + sumBit carry lhs rhs :: ripple (carryBit carry lhs rhs) lhsTail rhsTail + +end BinaryRippleAdd + +namespace TM + +/-- Carry-bearing scan states followed by the unique halt state. -/ +inductive BinaryRippleAddPhase where + | scan (carry : Bool) + | done + deriving DecidableEq + +/-- `BinaryRippleAddPhase` is finite, as required by the concrete machine model. -/ +instance instFintypeBinaryRippleAddPhase : Fintype BinaryRippleAddPhase where + elems := {.scan false, .scan true, .done} + complete := by + intro phase + cases phase with + | scan carry => cases carry <;> simp + | done => simp + +/-- Pairwise distinct work tapes used by the ripple-carry adder. -/ +structure BinaryRippleAddDistinct {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : Prop where + lhs_rhs : lhsIdx β‰  rhsIdx + lhs_result : lhsIdx β‰  resultIdx + rhs_result : rhsIdx β‰  resultIdx + +/-- Scan two canonical little-endian operands and append their sum to a fresh +result tape. Operand cells are written back unchanged. An exhausted operand +stays on its first blank while the longer operand continues to advance. -/ +def binaryRippleAddScanTM {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : TM n where + Q := BinaryRippleAddPhase + qstart := .scan false + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scan carry => + if wHeads lhsIdx = Ξ“.blank ∧ wHeads rhsIdx = Ξ“.blank then + if carry then + (.done, + fun i => if i = resultIdx then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + allReadBack .done iHead wHeads oHead + else + let lhsBit := decide (wHeads lhsIdx = Ξ“.one) + let rhsBit := decide (wHeads rhsIdx = Ξ“.one) + let sum := BinaryRippleAdd.sumBit carry lhsBit rhsBit + let nextCarry := BinaryRippleAdd.carryBit carry lhsBit rhsBit + (.scan nextCarry, + fun i => if i = resultIdx then Ξ“w.ofBool sum else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => + if i = resultIdx then Dir3.right + else if i = lhsIdx then + if wHeads lhsIdx = Ξ“.blank then Dir3.stay else Dir3.right + else if i = rhsIdx then + if wHeads rhsIdx = Ξ“.blank then Dir3.stay else Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | scan carry => + dsimp only + split + Β· split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + dsimp only + by_cases hresult : i = resultIdx + Β· rw [ite_eq_left hresult] + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + Β· exact rightOfStart_allReadBack iHead wHeads oHead + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + dsimp only + by_cases hresult : i = resultIdx + Β· rw [ite_eq_left hresult] + Β· rw [ite_eq_right hresult] + by_cases hlhs : i = lhsIdx + Β· rw [ite_eq_left hlhs] + subst i + simp [hi] + Β· rw [ite_eq_right hlhs] + by_cases hrhs : i = rhsIdx + Β· rw [ite_eq_left hrhs] + subst i + simp [hi] + Β· rw [ite_eq_right hrhs] + exact idleDir_right_of_start hi + | done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Exact number of scan transitions, including the final simultaneous-blank +transition. -/ +def binaryRippleAddScanTime (lhs rhs : List Bool) : β„• := + max lhs.length rhs.length + 1 + +/-- Scan the operands into a fresh result and then rewind both operands and the +result to cell one. -/ +def binaryRippleAddTM {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : TM n := + seqTM (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx) + (seqTM (rewindWorkTM lhsIdx) + (seqTM (rewindWorkTM rhsIdx) (rewindWorkTM resultIdx))) + +/-- Linear width bound for the scan, three rewinds, and three composition seams. -/ +def binaryRippleAddTime (lhs rhs : β„•) : β„• := + max lhs.size rhs.size + lhs.size + rhs.size + (lhs + rhs).size + 13 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal.lean new file mode 100644 index 0000000000..f274b72b60 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Bounds +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Sem + +/-! +# Linear-time canonical binary addition -- proof internals + +This aggregation module collects the pure arithmetic, scan, rewind, resource, +and output-discipline proofs used by the public surface. +-/ diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Bounds.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Bounds.lean new file mode 100644 index 0000000000..9e9a6b9d36 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Bounds.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import Mathlib.Data.Nat.Size + +/-! +# Linear binary addition -- resource-bound internals + +This file relates the concrete scan and composed-machine bounds to the +standard binary widths of the two operands. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +theorem size_add_le_max_add_one_internal (lhs rhs : β„•) : + (lhs + rhs).size ≀ max lhs.size rhs.size + 1 := by + rw [Nat.size_le] + let width := max lhs.size rhs.size + have hlhs : lhs < 2 ^ width := by + exact lt_of_lt_of_le (Nat.lt_size_self lhs) + (Nat.pow_le_pow_right (by decide) (le_max_left _ _)) + have hrhs : rhs < 2 ^ width := by + exact lt_of_lt_of_le (Nat.lt_size_self rhs) + (Nat.pow_le_pow_right (by decide) (le_max_right _ _)) + have hsum : lhs + rhs < 2 ^ width + 2 ^ width := + Nat.add_lt_add hlhs hrhs + simpa [width, pow_succ, Nat.mul_comm, Nat.two_mul] using hsum + +theorem binaryRippleAddTime_le_internal (lhs rhs : β„•) : + binaryRippleAddTime lhs rhs ≀ 3 * (lhs.size + rhs.size) + 14 := by + have hsum := size_add_le_max_add_one_internal lhs rhs + have hmax : max lhs.size rhs.size ≀ lhs.size + rhs.size := by + exact max_le (Nat.le_add_right _ _) (Nat.le_add_left _ _) + simp only [binaryRippleAddTime] + omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Out.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Out.lean new file mode 100644 index 0000000000..f5131e45c5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Out.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Internal + +/-! +# Linear-time canonical binary addition -- output discipline + +The scan and its rewind wrapper leave the public output tape one-way, so both +machines satisfy the transducer discipline required by space-bounded function +computation. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The ripple-add scan never moves the public output head left. -/ +theorem binaryRippleAddScanTM_isTransducer_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | scan carry => + simp only [binaryRippleAddScanTM] + split + Β· split + Β· simp only + simp [idleDir] + split <;> decide + Β· simp [allReadBack, idleDir] + split <;> decide + Β· simp only + simp [idleDir] + split <;> decide + | done => + simp [binaryRippleAddScanTM, allIdle, idleDir] + split <;> decide + +/-- The scan followed by all three rewinds remains a transducer. -/ +theorem binaryRippleAddTM_isTransducer_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).IsTransducer := by + exact (binaryRippleAddScanTM_isTransducer_internal lhsIdx rhsIdx resultIdx).seqTM + ((rewindWorkTM_isTransducer_internal lhsIdx).seqTM + ((rewindWorkTM_isTransducer_internal rhsIdx).seqTM + (rewindWorkTM_isTransducer_internal resultIdx))) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Pure.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Pure.lean new file mode 100644 index 0000000000..a62059c340 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Pure.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import Mathlib.Data.Nat.Size +public import Std.Tactic.BVDecide.Normalize.Bool + +/-! +# Linear-time canonical binary addition -- pure proofs + +This file proves that the finite full-adder recurrence computes addition on +canonical little-endian `Nat.bits`. The generalized theorem includes an +incoming carry so that its induction follows the recurrence exactly. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleAdd + +private theorem ripple_nil_cons (carry rhsBit : Bool) + (rhs : List Bool) : + ripple carry [] (rhsBit :: rhs) = + sumBit carry false rhsBit :: + ripple (carryBit carry false rhsBit) [] rhs := by + cases carry <;> simp [ripple] + +private theorem ripple_cons_nil (carry lhsBit : Bool) + (lhs : List Bool) : + ripple carry (lhsBit :: lhs) [] = + sumBit carry lhsBit false :: + ripple (carryBit carry lhsBit false) lhs [] := by + cases carry <;> simp [ripple] + +private theorem ripple_cons_cons (carry lhsBit rhsBit : Bool) + (lhs rhs : List Bool) : + ripple carry (lhsBit :: lhs) (rhsBit :: rhs) = + sumBit carry lhsBit rhsBit :: + ripple (carryBit carry lhsBit rhsBit) lhs rhs := by + cases carry <;> simp [ripple] + +private theorem fullAdder_value (carry lhsBit rhsBit : Bool) (lhs rhs : β„•) : + Nat.bit lhsBit lhs + Nat.bit rhsBit rhs + (if carry then 1 else 0) = + Nat.bit (sumBit carry lhsBit rhsBit) + (lhs + rhs + (if carryBit carry lhsBit rhsBit then 1 else 0)) := by + cases carry <;> cases lhsBit <;> cases rhsBit <;> + simp [sumBit, carryBit, Nat.bit] <;> omega + +private theorem fullAdder_valid (carry lhsBit rhsBit : Bool) (lhs rhs : β„•) + (hvalue : Nat.bit lhsBit lhs + Nat.bit rhsBit rhs + + (if carry then 1 else 0) β‰  0) : + lhs + rhs + (if carryBit carry lhsBit rhsBit then 1 else 0) = 0 β†’ + sumBit carry lhsBit rhsBit = true := by + apply Nat.bit_ne_zero_iff.mp + rw [← fullAdder_value] + exact hvalue + +/-- Ripple addition with an incoming carry computes the corresponding natural +sum. This is the induction-strengthened form of `ripple_natBits_internal`. -/ +theorem ripple_natBits_carry_internal (carry : Bool) (lhs rhs : β„•) : + ripple carry lhs.bits rhs.bits = + (lhs + rhs + (if carry then 1 else 0)).bits := by + induction lhs using Nat.binaryRec' generalizing rhs carry with + | zero => + simp only [Nat.zero_bits, Nat.zero_add] + induction rhs using Nat.binaryRec' generalizing carry with + | zero => + cases carry <;> simp [ripple] + | bit rhsBit rhs hrhs ih => + have hrhsValue : Nat.bit rhsBit rhs β‰  0 := + Nat.bit_ne_zero_iff.mpr hrhs + have htotal : Nat.bit false 0 + Nat.bit rhsBit rhs + + (if carry then 1 else 0) β‰  0 := by + omega + have hvalid := fullAdder_valid carry false rhsBit 0 rhs htotal + have hvalid' : + rhs + (if carryBit carry false rhsBit then 1 else 0) = 0 β†’ + sumBit carry false rhsBit = true := by + simpa using hvalid + have hadd : Nat.bit rhsBit rhs + (if carry then 1 else 0) = + Nat.bit (sumBit carry false rhsBit) + (rhs + (if carryBit carry false rhsBit then 1 else 0)) := by + simpa using fullAdder_value carry false rhsBit 0 rhs + calc + ripple carry [] (Nat.bit rhsBit rhs).bits = + sumBit carry false rhsBit :: + ripple (carryBit carry false rhsBit) [] rhs.bits := by + rw [Nat.bits_append_bit rhs rhsBit hrhs] + exact ripple_nil_cons carry rhsBit rhs.bits + _ = sumBit carry false rhsBit :: + (rhs + (if carryBit carry false rhsBit then 1 else 0)).bits := by + rw [ih] + _ = (Nat.bit (sumBit carry false rhsBit) + (rhs + (if carryBit carry false rhsBit then 1 else 0))).bits := by + exact (Nat.bits_append_bit _ _ hvalid').symm + _ = (Nat.bit rhsBit rhs + (if carry then 1 else 0)).bits := by + rw [hadd] + | bit lhsBit lhs hlhs ih => + induction rhs using Nat.binaryRec' generalizing carry with + | zero => + have hlhsValue : Nat.bit lhsBit lhs β‰  0 := + Nat.bit_ne_zero_iff.mpr hlhs + have htotal : Nat.bit lhsBit lhs + Nat.bit false 0 + + (if carry then 1 else 0) β‰  0 := by + omega + have hvalid := fullAdder_valid carry lhsBit false lhs 0 htotal + have hvalid' : + lhs + (if carryBit carry lhsBit false then 1 else 0) = 0 β†’ + sumBit carry lhsBit false = true := by + simpa using hvalid + have hadd : Nat.bit lhsBit lhs + (if carry then 1 else 0) = + Nat.bit (sumBit carry lhsBit false) + (lhs + (if carryBit carry lhsBit false then 1 else 0)) := by + simpa using fullAdder_value carry lhsBit false lhs 0 + calc + ripple carry (Nat.bit lhsBit lhs).bits [] = + sumBit carry lhsBit false :: + ripple (carryBit carry lhsBit false) lhs.bits [] := by + rw [Nat.bits_append_bit lhs lhsBit hlhs] + exact ripple_cons_nil carry lhsBit lhs.bits + _ = sumBit carry lhsBit false :: + (lhs + (if carryBit carry lhsBit false then 1 else 0)).bits := by + simpa using congrArg (List.cons (sumBit carry lhsBit false)) + (ih (carryBit carry lhsBit false) 0) + _ = (Nat.bit (sumBit carry lhsBit false) + (lhs + (if carryBit carry lhsBit false then 1 else 0))).bits := by + exact (Nat.bits_append_bit _ _ hvalid').symm + _ = (Nat.bit lhsBit lhs + (if carry then 1 else 0)).bits := by + rw [hadd] + | bit rhsBit rhs hrhs _ => + have hlhsValue : Nat.bit lhsBit lhs β‰  0 := + Nat.bit_ne_zero_iff.mpr hlhs + have htotal : Nat.bit lhsBit lhs + Nat.bit rhsBit rhs + + (if carry then 1 else 0) β‰  0 := by + omega + have hvalid := fullAdder_valid carry lhsBit rhsBit lhs rhs htotal + have hadd := fullAdder_value carry lhsBit rhsBit lhs rhs + calc + ripple carry (Nat.bit lhsBit lhs).bits (Nat.bit rhsBit rhs).bits = + sumBit carry lhsBit rhsBit :: + ripple (carryBit carry lhsBit rhsBit) lhs.bits rhs.bits := by + rw [Nat.bits_append_bit lhs lhsBit hlhs, + Nat.bits_append_bit rhs rhsBit hrhs] + exact ripple_cons_cons carry lhsBit rhsBit lhs.bits rhs.bits + _ = sumBit carry lhsBit rhsBit :: + (lhs + rhs + + (if carryBit carry lhsBit rhsBit then 1 else 0)).bits := by + rw [ih] + _ = (Nat.bit (sumBit carry lhsBit rhsBit) + (lhs + rhs + + (if carryBit carry lhsBit rhsBit then 1 else 0))).bits := by + exact (Nat.bits_append_bit _ _ hvalid).symm + _ = (Nat.bit lhsBit lhs + Nat.bit rhsBit rhs + + (if carry then 1 else 0)).bits := by + rw [hadd] + +/-- Ripple addition without an incoming carry computes canonical addition. -/ +theorem ripple_natBits_internal (lhs rhs : β„•) : + ripple false lhs.bits rhs.bits = (lhs + rhs).bits := by + simpa using ripple_natBits_carry_internal false lhs rhs + +/-- The pure result has exactly the canonical width of the sum. -/ +theorem length_ripple_natBits_internal (lhs rhs : β„•) : + (ripple false lhs.bits rhs.bits).length = (lhs + rhs).size := by + rw [ripple_natBits_internal, Nat.size_eq_bits_len] + +end BinaryRippleAdd + +namespace TM + +/-- Rewrite the list-level scan bound as a bound in natural-number widths. -/ +theorem binaryRippleAddScanTime_natBits_internal (lhs rhs : β„•) : + binaryRippleAddScanTime lhs.bits rhs.bits = max lhs.size rhs.size + 1 := by + simp [binaryRippleAddScanTime, Nat.size_eq_bits_len] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Rewind.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Rewind.lean new file mode 100644 index 0000000000..87e2e614a3 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Rewind.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Internal + +/-! +# Linear-time canonical binary addition -- rewind proof internals + +This module packages the three-rewind tail of `binaryRippleAddTM` into one +framed Hoare-time contract. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Canonical parked tape containing the supplied little-endian binary digits. -/ +def binaryRippleAddCanonicalTape (bits : List Bool) : Tape := + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right + +private theorem binaryRippleAddCanonicalTape_parked (bits : List Bool) : + Parked (binaryRippleAddCanonicalTape bits) := by + refine ⟨by simp [binaryRippleAddCanonicalTape, Tape.move], ?_⟩ + simpa [binaryRippleAddCanonicalTape] using + Tape.init_ofBool_move_right_cells_ne_start bits + +private theorem binaryRippleAddRewindExact_hoareTime {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (rewindWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx (binaryRippleAddCanonicalTape bits) ∧ + out = outβ‚€) + (headBound + 2) := by + have hrewind := rewindBinaryWorkTM_hoareTime_frame_internal idx bits + headBound inpβ‚€ workβ‚€ outβ‚€ htarget htargetStart htargetHead hinput + hother houtput + apply hrewind.consequence (b' := headBound + 2) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hinp, htargetEq, hotherEq, hout⟩ + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + simpa [binaryRippleAddCanonicalTape] using htargetEq + Β· rw [Function.update_of_ne hi] + exact hotherEq i hi + Β· exact le_rfl + +private theorem binaryRippleAddExactFrame_transition {n : β„•} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + transitionInput inp = inpβ‚€ ∧ + (fun i => transitionTape (work i)) = workβ‚€ ∧ + transitionTape out = outβ‚€ := by + rintro _inp _work _out ⟨rfl, rfl, rfl⟩ + exact ⟨hinput.transitionInput_eq_self, + funext fun i => (hwork i).transitionTape_eq_self, + houtput.transitionTape_eq_self⟩ + +theorem binaryRippleAddRewindTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhsBits rhsBits resultBits : List Bool) + (lhsBound rhsBound resultBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryContent lhsBits) + (hlhsStart : (workβ‚€ lhsIdx).cells 0 = Ξ“.start) + (hlhsHead : 1 ≀ (workβ‚€ lhsIdx).head ∧ + (workβ‚€ lhsIdx).head ≀ lhsBound) + (hrhs : (workβ‚€ rhsIdx).HasBinaryContent rhsBits) + (hrhsStart : (workβ‚€ rhsIdx).cells 0 = Ξ“.start) + (hrhsHead : 1 ≀ (workβ‚€ rhsIdx).head ∧ + (workβ‚€ rhsIdx).head ≀ rhsBound) + (hresult : (workβ‚€ resultIdx).HasBinaryContent resultBits) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hresultHead : 1 ≀ (workβ‚€ resultIdx).head ∧ + (workβ‚€ resultIdx).head ≀ resultBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (seqTM (rewindWorkTM lhsIdx) + (seqTM (rewindWorkTM rhsIdx) (rewindWorkTM resultIdx))).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work lhsIdx = binaryRippleAddCanonicalTape lhsBits ∧ + work rhsIdx = binaryRippleAddCanonicalTape rhsBits ∧ + work resultIdx = binaryRippleAddCanonicalTape resultBits ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (lhsBound + rhsBound + resultBound + 8) := by + have hlhsParked : Parked (workβ‚€ lhsIdx) := + ⟨hlhsHead.1, hlhs.cells_ne_start⟩ + have hrhsParked : Parked (workβ‚€ rhsIdx) := + ⟨hrhsHead.1, hrhs.cells_ne_start⟩ + have hresultParked : Parked (workβ‚€ resultIdx) := + ⟨hresultHead.1, hresult.cells_ne_start⟩ + have hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i) := by + intro i + by_cases hlhsIdx : i = lhsIdx + Β· subst i + exact hlhsParked + by_cases hrhsIdx : i = rhsIdx + Β· subst i + exact hrhsParked + by_cases hresultIdx : i = resultIdx + Β· subst i + exact hresultParked + exact hother i hlhsIdx hrhsIdx hresultIdx + + let lhsTape := binaryRippleAddCanonicalTape lhsBits + let rhsTape := binaryRippleAddCanonicalTape rhsBits + let resultTape := binaryRippleAddCanonicalTape resultBits + let work₁ := Function.update workβ‚€ lhsIdx lhsTape + let workβ‚‚ := Function.update work₁ rhsIdx rhsTape + let work₃ := Function.update workβ‚‚ resultIdx resultTape + + have hwork₁ : βˆ€ i, Parked (work₁ i) := by + intro i + by_cases hi : i = lhsIdx + Β· subst i + simpa [work₁, lhsTape] using + binaryRippleAddCanonicalTape_parked lhsBits + Β· simpa only [work₁, Function.update_of_ne hi] using hworkβ‚€ i + have hworkβ‚‚ : βˆ€ i, Parked (workβ‚‚ i) := by + intro i + by_cases hi : i = rhsIdx + Β· subst i + simpa [workβ‚‚, rhsTape] using + binaryRippleAddCanonicalTape_parked rhsBits + Β· simpa only [workβ‚‚, Function.update_of_ne hi] using hwork₁ i + + have hrhs₁ : (work₁ rhsIdx).HasBinaryContent rhsBits := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using hrhs + have hrhsStart₁ : (work₁ rhsIdx).cells 0 = Ξ“.start := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using hrhsStart + have hrhsHead₁ : 1 ≀ (work₁ rhsIdx).head ∧ + (work₁ rhsIdx).head ≀ rhsBound := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using hrhsHead + + have hresultβ‚‚ : (workβ‚‚ resultIdx).HasBinaryContent resultBits := by + simpa only [workβ‚‚, Function.update_of_ne hdistinct.rhs_result.symm, + work₁, Function.update_of_ne hdistinct.lhs_result.symm] using hresult + have hresultStartβ‚‚ : (workβ‚‚ resultIdx).cells 0 = Ξ“.start := by + simpa only [workβ‚‚, Function.update_of_ne hdistinct.rhs_result.symm, + work₁, Function.update_of_ne hdistinct.lhs_result.symm] using hresultStart + have hresultHeadβ‚‚ : 1 ≀ (workβ‚‚ resultIdx).head ∧ + (workβ‚‚ resultIdx).head ≀ resultBound := by + simpa only [workβ‚‚, Function.update_of_ne hdistinct.rhs_result.symm, + work₁, Function.update_of_ne hdistinct.lhs_result.symm] using hresultHead + + have hrewindLhs := binaryRippleAddRewindExact_hoareTime lhsIdx lhsBits + lhsBound inpβ‚€ workβ‚€ outβ‚€ hlhs hlhsStart hlhsHead hinput + (fun i _ => hworkβ‚€ i) houtput + have hrewindRhs := binaryRippleAddRewindExact_hoareTime rhsIdx rhsBits + rhsBound inpβ‚€ work₁ outβ‚€ hrhs₁ hrhsStart₁ hrhsHead₁ hinput + (fun i _ => hwork₁ i) houtput + have hrewindResult := binaryRippleAddRewindExact_hoareTime resultIdx + resultBits resultBound inpβ‚€ workβ‚‚ outβ‚€ hresultβ‚‚ hresultStartβ‚‚ + hresultHeadβ‚‚ hinput (fun i _ => hworkβ‚‚ i) houtput + + have htail := seqTM_hoareTime (rewindWorkTM rhsIdx) + (rewindWorkTM resultIdx) hrewindRhs + (binaryRippleAddExactFrame_transition inpβ‚€ workβ‚‚ outβ‚€ hinput + hworkβ‚‚ houtput) + hrewindResult + have hrun := seqTM_hoareTime (rewindWorkTM lhsIdx) + (seqTM (rewindWorkTM rhsIdx) (rewindWorkTM resultIdx)) hrewindLhs + (binaryRippleAddExactFrame_transition inpβ‚€ work₁ outβ‚€ hinput + hwork₁ houtput) + htail + apply hrun.consequence (b' := lhsBound + rhsBound + resultBound + 8) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hinp, hworkEq, hout⟩ + refine ⟨hinp, ?_, ?_, ?_, ?_, hout⟩ + Β· rw [hworkEq] + simp only [Function.update_of_ne hdistinct.lhs_result, + workβ‚‚, Function.update_of_ne hdistinct.lhs_rhs, + work₁, Function.update_self, lhsTape] + Β· rw [hworkEq] + simp only [Function.update_of_ne hdistinct.rhs_result, + workβ‚‚, Function.update_self, rhsTape] + Β· rw [hworkEq] + simp only [Function.update_self] + Β· intro i hlhsIdx hrhsIdx hresultIdx + rw [hworkEq] + simp only [Function.update_of_ne hresultIdx, + workβ‚‚, Function.update_of_ne hrhsIdx, + work₁, Function.update_of_ne hlhsIdx] + Β· omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Scan.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Scan.lean new file mode 100644 index 0000000000..bd2fc43fd9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Scan.lean @@ -0,0 +1,601 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Linear-time canonical binary addition -- scan proof + +This file proves the exact operational contract for the carry-bearing forward +scan. Rewinding and the complete canonical-natural interface are composed in +later internal layers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private def binaryRippleAddScanAdvanceWork {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (sum : Bool) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := + fun i => + if i = resultIdx then + (work i).writeAndMove (Ξ“w.ofBool sum) Dir3.right + else if i = lhsIdx then + if (work lhsIdx).read = Ξ“.blank then work i + else (work i).move Dir3.right + else if i = rhsIdx then + if (work rhsIdx).read = Ξ“.blank then work i + else (work i).move Dir3.right + else work i + +private theorem writeAndMove_readBack_right {tape : Tape} + (hread : tape.read β‰  Ξ“.start) : + tape.writeAndMove (readBackWrite tape.read) Dir3.right = + tape.move Dir3.right := by + cases tape with + | mk head cells => + simp only [Tape.writeAndMove, Tape.read] at hread ⊒ + rw [toΞ“_readBackWrite_of_ne_start hread] + simp [Tape.write, Tape.move, Function.update_eq_self] + +private theorem writeAndMove_readBack_stay {tape : Tape} + (hread : tape.read β‰  Ξ“.start) : + tape.writeAndMove (readBackWrite tape.read) Dir3.stay = tape := by + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + Β· rfl + Β· simp only [Tape.read, Function.update_eq_self] + +private theorem binaryRippleAddScanTM_step_active {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (carry : Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hactive : Β¬((work lhsIdx).read = Ξ“.blank ∧ + (work rhsIdx).read = Ξ“.blank)) + (hinput : inp.read β‰  Ξ“.start) + (hlhs : (work lhsIdx).read β‰  Ξ“.start) + (hrhs : (work rhsIdx).read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let lhsBit := decide ((work lhsIdx).read = Ξ“.one) + let rhsBit := decide ((work rhsIdx).read = Ξ“.one) + let sum := BinaryRippleAdd.sumBit carry lhsBit rhsBit + let nextCarry := BinaryRippleAdd.carryBit carry lhsBit rhsBit + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).step + { state := .scan carry, input := inp, work := work, output := out } = + some + { state := .scan nextCarry + input := inp + work := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx sum work + output := out } := by + dsimp only + rw [TM.step, ite_eq_right (by simp [binaryRippleAddScanTM])] + simp only [binaryRippleAddScanTM, hactive, ↓reduceIte] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hresultIdx : i = resultIdx + Β· subst i + simp [binaryRippleAddScanAdvanceWork] + Β· by_cases hlhsIdx : i = lhsIdx + Β· subst i + simp only [binaryRippleAddScanAdvanceWork, hresultIdx, ite_false, + ite_eq_left] + by_cases hblank : (work lhsIdx).read = Ξ“.blank + Β· rw [ite_eq_left hblank, ite_eq_left hblank] + simpa [hblank] using + writeAndMove_readBack_stay (show (work lhsIdx).read β‰  Ξ“.start from hlhs) + Β· rw [ite_eq_right hblank, ite_eq_right hblank] + exact writeAndMove_readBack_right hlhs + Β· by_cases hrhsIdx : i = rhsIdx + Β· subst i + simp only [binaryRippleAddScanAdvanceWork, hresultIdx, ite_false, + hlhsIdx, ite_eq_left] + by_cases hblank : (work rhsIdx).read = Ξ“.blank + Β· rw [ite_eq_left hblank, ite_eq_left hblank] + simpa [hblank] using + writeAndMove_readBack_stay (show (work rhsIdx).read β‰  Ξ“.start from hrhs) + Β· rw [ite_eq_right hblank, ite_eq_right hblank] + exact writeAndMove_readBack_right hrhs + Β· simp only [binaryRippleAddScanAdvanceWork, hresultIdx, ite_false, + hlhsIdx, hrhsIdx] + exact transitionTape_eq_self (hother i hlhsIdx hrhsIdx hresultIdx) + +private theorem binaryRippleAddScanTM_step_terminal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (carry : Bool) (emitted : List Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hlhs : (work lhsIdx).read = Ξ“.blank) + (hrhs : (work rhsIdx).read = Ξ“.blank) + (hinput : inp.read β‰  Ξ“.start) + (hresult : (work resultIdx).HasBinaryPrefix emitted) + (hresultStart : (work resultIdx).cells 0 = Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + βˆƒ finalWork, + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).step + { state := .scan carry, input := inp, work := work, output := out } = + some { state := .done, input := inp, work := finalWork, output := out } ∧ + (finalWork lhsIdx).cells = (work lhsIdx).cells ∧ + (finalWork lhsIdx).head = (work lhsIdx).head ∧ + (finalWork rhsIdx).cells = (work rhsIdx).cells ∧ + (finalWork rhsIdx).head = (work rhsIdx).head ∧ + (finalWork resultIdx).HasBinaryPrefix + (emitted ++ BinaryRippleAdd.ripple carry [] []) ∧ + (finalWork resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + finalWork i = work i) := by + cases carry with + | false => + refine ⟨work, ?_, rfl, rfl, rfl, rfl, ?_, hresultStart, ?_⟩ + Β· rw [TM.step, ite_eq_right (by simp [binaryRippleAddScanTM])] + simp only [binaryRippleAddScanTM, hlhs, hrhs, and_self, ite_eq_left, + Bool.false_eq_true, ite_false, allReadBack] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hil : i = lhsIdx + Β· subst i + exact transitionTape_eq_self (by rw [hlhs]; decide) + Β· by_cases hir : i = rhsIdx + Β· subst i + exact transitionTape_eq_self (by rw [hrhs]; decide) + Β· by_cases hires : i = resultIdx + Β· subst i + exact transitionTape_eq_self (by + rw [hresult.read_blank] + decide) + Β· exact transitionTape_eq_self (hother i hil hir hires) + Β· simpa [BinaryRippleAdd.ripple] using hresult + Β· intro i _ _ _ + rfl + | true => + let finalWork := Function.update work resultIdx + ((work resultIdx).writeAndMove Ξ“.one Dir3.right) + refine ⟨finalWork, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [TM.step, ite_eq_right (by simp [binaryRippleAddScanTM])] + simp only [binaryRippleAddScanTM, hlhs, hrhs, and_self, ite_eq_left] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hires : i = resultIdx + Β· subst i + simp [finalWork] + Β· by_cases hil : i = lhsIdx + Β· subst i + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, finalWork, hdistinct.lhs_result] using + transitionTape_eq_self (by rw [hlhs]; decide) + Β· by_cases hir : i = rhsIdx + Β· subst i + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, finalWork, hdistinct.rhs_result] using + transitionTape_eq_self (by rw [hrhs]; decide) + Β· simpa [finalWork, hires] using! + transitionTape_eq_self (hother i hil hir hires) + Β· simp [finalWork, hdistinct.lhs_result] + Β· simp [finalWork, hdistinct.lhs_result] + Β· simp [finalWork, hdistinct.rhs_result] + Β· simp [finalWork, hdistinct.rhs_result] + Β· simpa [finalWork, BinaryRippleAdd.ripple] using! + Tape.hasBinaryPrefix_write_bit true hresult + Β· simpa [finalWork] using! + Tape.hasBinaryPrefix_write_bit_cell0 true hresult hresultStart + Β· intro i _ _ hires + simp [finalWork, hires] + +/-- Writing one ripple-add output bit extends its prefix without changing the start marker. -/ +private theorem binaryRippleAddScanAdvanceWork_result {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (sum : Bool) (emitted : List Bool) + (workβ‚€ : Fin n β†’ Tape) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) : + let work₁ := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx sum workβ‚€ + (work₁ resultIdx).HasBinaryPrefix (emitted ++ [sum]) ∧ + (work₁ resultIdx).cells 0 = Ξ“.start := by + dsimp only + let work₁ := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx sum workβ‚€ + have hresult₁ : + (work₁ resultIdx).HasBinaryPrefix (emitted ++ [sum]) := by + rw [show work₁ resultIdx = + (workβ‚€ resultIdx).writeAndMove (Ξ“w.ofBool sum).toΞ“ + Dir3.right by + simp [work₁, binaryRippleAddScanAdvanceWork]] + rw [Ξ“w.ofBool_toΞ“] + exact Tape.hasBinaryPrefix_write_bit sum hresult + have hresultStart₁ : (work₁ resultIdx).cells 0 = Ξ“.start := by + rw [show work₁ resultIdx = + (workβ‚€ resultIdx).writeAndMove (Ξ“w.ofBool sum).toΞ“ + Dir3.right by + simp [work₁, binaryRippleAddScanAdvanceWork]] + rw [Ξ“w.ofBool_toΞ“] + exact Tape.hasBinaryPrefix_write_bit_cell0 sum hresult hresultStart + exact ⟨hresult₁, hresultStartβ‚βŸ© + +/-- With the left input exhausted, ripple addition consumes the right suffix and carry. -/ +private theorem binaryRippleAddScanTM_suffix_empty_left {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (carry : Bool) (rhs emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix ([] : List Bool)) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleAddScanTime ([] : List Bool) rhs) + { state := .scan carry, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } c' ∧ + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = (workβ‚€ lhsIdx).head + ([] : List Bool).length ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = (workβ‚€ rhsIdx).head + rhs.length ∧ + (c'.work resultIdx).HasBinaryPrefix + (emitted ++ BinaryRippleAdd.ripple carry ([] : List Bool) rhs) ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + induction rhs generalizing carry emitted inpβ‚€ workβ‚€ outβ‚€ with + | nil => + obtain ⟨finalWork, hstep, hfinalLhs, hfinalLhsHead, hfinalRhs, + hfinalRhsHead, hfinalResult, hfinalResultStart, hfinalOther⟩ := + binaryRippleAddScanTM_step_terminal lhsIdx rhsIdx resultIdx + hdistinct carry emitted inpβ‚€ workβ‚€ outβ‚€ hlhs.read_nil + hrhs.read_nil hinput hresult hresultStart hother houtput + let c' : Cfg n BinaryRippleAddPhase := + { state := .done, input := inpβ‚€, work := finalWork, output := outβ‚€ } + refine ⟨c', ?_, rfl, rfl, hfinalLhs, ?_, hfinalRhs, ?_, + hfinalResult, hfinalResultStart, hfinalOther, rfl⟩ + Β· have hreach : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).reachesIn 1 + { state := .scan carry, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } c' := + .step hstep .zero + simpa [binaryRippleAddScanTime] using hreach + Β· simpa using hfinalLhsHead + Β· simpa using hfinalRhsHead + | cons rhsBit rhsTail ih => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = false := by + rw [hlhs.read_nil] + decide + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = rhsBit := by + rw [hrhs.read_cons] + cases rhsBit <;> rfl + let sum := BinaryRippleAdd.sumBit carry false rhsBit + let nextCarry := BinaryRippleAdd.carryBit carry false rhsBit + let work₁ := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx + sum workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hrhs.read_cons] at hblank + cases rhsBit <;> simp [Ξ“.ofBool] at hblank + have hrhsNotBlank : (workβ‚€ rhsIdx).read β‰  Ξ“.blank := by + rw [hrhs.read_cons] + cases rhsBit <;> decide + have hstep : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).step + { state := .scan carry, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextCarry + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, sum, nextCarry, work₁] using + binaryRippleAddScanTM_step_active lhsIdx rhsIdx resultIdx carry + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix [] := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hlhs + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix rhsTail := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank] using hrhs.move_right_cons + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleAddScanAdvanceWork_result lhsIdx rhsIdx resultIdx + sum emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + obtain ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih nextCarry + (emitted ++ [sum]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ hresult₁ + hresultStart₁ hinput hother₁ houtput + refine ⟨c', ?_, hhalt, hfinalInput, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleAddScanTime] using + TM.reachesIn.step hstep hreach + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hfinalLhs + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hfinalLhsHead + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank, Tape.move_cells] using hfinalRhs + Β· rw [hfinalRhsHead] + simp only [work₁, binaryRippleAddScanAdvanceWork, + ite_eq_right hdistinct.rhs_result, + ite_eq_right (Ne.symm hdistinct.lhs_rhs), ite_eq_left, + ite_eq_right hrhsNotBlank, Tape.move, List.length_cons] + omega + Β· simpa [BinaryRippleAdd.ripple, sum, nextCarry, + List.append_assoc] using hfinalResult + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] + +private theorem binaryRippleAddScanTM_suffix_reachesIn {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (carry : Bool) (lhs rhs emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleAddScanTime lhs rhs) + { state := .scan carry, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } c' ∧ + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = (workβ‚€ lhsIdx).head + lhs.length ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = (workβ‚€ rhsIdx).head + rhs.length ∧ + (c'.work resultIdx).HasBinaryPrefix + (emitted ++ BinaryRippleAdd.ripple carry lhs rhs) ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + induction hlength : lhs.length + rhs.length using Nat.strong_induction_on + generalizing lhs rhs carry emitted inpβ‚€ workβ‚€ outβ‚€ with + | h total ih => + cases lhs with + | nil => + exact binaryRippleAddScanTM_suffix_empty_left lhsIdx rhsIdx resultIdx + hdistinct carry rhs emitted inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult + hresultStart hinput hother houtput + | cons lhsBit lhsTail => + cases rhs with + | nil => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = lhsBit := by + rw [hlhs.read_cons] + cases lhsBit <;> rfl + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = false := by + rw [hrhs.read_nil] + decide + let sum := BinaryRippleAdd.sumBit carry lhsBit false + let nextCarry := BinaryRippleAdd.carryBit carry lhsBit false + let work₁ := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx + sum workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hlhs.read_cons] at hblank + cases lhsBit <;> simp [Ξ“.ofBool] at hblank + have hlhsNotBlank : (workβ‚€ lhsIdx).read β‰  Ξ“.blank := by + rw [hlhs.read_cons] + cases lhsBit <;> decide + have hstep : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).step + { state := .scan carry, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextCarry + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, sum, nextCarry, work₁] using + binaryRippleAddScanTM_step_active lhsIdx rhsIdx resultIdx carry + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix lhsTail := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank] using hlhs.move_right_cons + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix [] := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hrhs + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleAddScanAdvanceWork_result lhsIdx rhsIdx resultIdx + sum emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + have htailLength : lhsTail.length < total := by + simp only [List.length_nil, Nat.add_zero, List.length_cons] at hlength + omega + obtain ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih lhsTail.length htailLength nextCarry lhsTail [] + (emitted ++ [sum]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ hresult₁ + hresultStart₁ hinput hother₁ houtput (by simp) + refine ⟨c', ?_, hhalt, hfinalInput, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleAddScanTime] using + TM.reachesIn.step hstep hreach + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank, Tape.move_cells] using + hfinalLhs + Β· rw [hfinalLhsHead] + simp only [work₁, binaryRippleAddScanAdvanceWork, + ite_eq_right hdistinct.lhs_result, ite_eq_left, ite_eq_right hlhsNotBlank, + Tape.move, List.length_cons] + omega + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hfinalRhs + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hfinalRhsHead + Β· simpa [BinaryRippleAdd.ripple, sum, nextCarry, + List.append_assoc] using hfinalResult + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] + | cons rhsBit rhsTail => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = lhsBit := by + rw [hlhs.read_cons] + cases lhsBit <;> rfl + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = rhsBit := by + rw [hrhs.read_cons] + cases rhsBit <;> rfl + let sum := BinaryRippleAdd.sumBit carry lhsBit rhsBit + let nextCarry := BinaryRippleAdd.carryBit carry lhsBit rhsBit + let work₁ := binaryRippleAddScanAdvanceWork lhsIdx rhsIdx resultIdx + sum workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hlhs.read_cons] at hblank + cases lhsBit <;> simp [Ξ“.ofBool] at hblank + have hlhsNotBlank : (workβ‚€ lhsIdx).read β‰  Ξ“.blank := by + rw [hlhs.read_cons] + cases lhsBit <;> decide + have hrhsNotBlank : (workβ‚€ rhsIdx).read β‰  Ξ“.blank := by + rw [hrhs.read_cons] + cases rhsBit <;> decide + have hstep : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).step + { state := .scan carry, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextCarry + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, sum, nextCarry, work₁] using + binaryRippleAddScanTM_step_active lhsIdx rhsIdx resultIdx carry + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix lhsTail := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank] using hlhs.move_right_cons + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix rhsTail := by + simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank] using hrhs.move_right_cons + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleAddScanAdvanceWork_result lhsIdx rhsIdx resultIdx + sum emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + have htailLength : lhsTail.length + rhsTail.length < total := by + simp only [List.length_cons] at hlength + omega + obtain ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih (lhsTail.length + rhsTail.length) htailLength nextCarry lhsTail + rhsTail (emitted ++ [sum]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ + hresult₁ hresultStart₁ hinput hother₁ houtput rfl + refine ⟨c', ?_, hhalt, hfinalInput, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleAddScanTime, Nat.succ_max_succ] using + TM.reachesIn.step hstep hreach + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank, Tape.move_cells] using + hfinalLhs + Β· rw [hfinalLhsHead] + simp only [work₁, binaryRippleAddScanAdvanceWork, + ite_eq_right hdistinct.lhs_result, ite_eq_left, ite_eq_right hlhsNotBlank, + Tape.move, List.length_cons] + omega + Β· simpa [work₁, binaryRippleAddScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank, Tape.move_cells] using hfinalRhs + Β· rw [hfinalRhsHead] + simp only [work₁, binaryRippleAddScanAdvanceWork, + ite_eq_right hdistinct.rhs_result, + ite_eq_right (Ne.symm hdistinct.lhs_rhs), ite_eq_left, + ite_eq_right hrhsNotBlank, Tape.move, List.length_cons] + omega + Β· simpa [BinaryRippleAdd.ripple, sum, nextCarry, + List.append_assoc] using hfinalResult + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleAddScanAdvanceWork, hil, hir, hires] + +theorem binaryRippleAddScanTM_reachesIn_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryString lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryString rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleAddScanTime lhs rhs) + { state := (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = lhs.length + 1 ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = rhs.length + 1 ∧ + (c'.work resultIdx).HasBinaryPrefix + (BinaryRippleAdd.ripple false lhs rhs) ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + obtain ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, hfinalLhsHead, + hfinalRhs, hfinalRhsHead, hfinalResult, hfinalResultStart, + hfinalOther, hfinalOutput⟩ := + binaryRippleAddScanTM_suffix_reachesIn lhsIdx rhsIdx resultIdx hdistinct + false lhs rhs [] inpβ‚€ workβ‚€ outβ‚€ hlhs.hasBinarySuffix + hrhs.hasBinarySuffix hresult hresultStart hinput hother houtput + refine ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, ?_, hfinalRhs, ?_, ?_, + hfinalResultStart, hfinalOther, hfinalOutput⟩ + Β· simpa [hlhs.1, Nat.add_comm] using hfinalLhsHead + Β· simpa [hrhs.1, Nat.add_comm] using hfinalRhsHead + Β· simpa using hfinalResult + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Sem.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Sem.lean new file mode 100644 index 0000000000..f22f394f2e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleAdd/Internal/Sem.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleAdd.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc + +/-! +# Linear-time canonical binary addition -- composed semantics + +This file composes the one-pass full-adder scan with the three checked rewind +contracts. The resulting machine restores both operands, returns a canonical +sum, preserves the complete external tape frame, and carries explicit time and +all-prefix auxiliary-space bounds. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private def binaryRippleAddScanPost {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryContent lhs.bits ∧ + (work lhsIdx).cells 0 = Ξ“.start ∧ + (work lhsIdx).head = lhs.size + 1 ∧ + (work rhsIdx).HasBinaryContent rhs.bits ∧ + (work rhsIdx).cells 0 = Ξ“.start ∧ + (work rhsIdx).head = rhs.size + 1 ∧ + (work resultIdx).HasBinaryContent (lhs + rhs).bits ∧ + (work resultIdx).cells 0 = Ξ“.start ∧ + (work resultIdx).head = (lhs + rhs).size + 1 ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- Postcondition for completed binary ripple addition. -/ +def binaryRippleAddPost {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs + rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryRippleAddScanTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleAddScanPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleAddScanTime lhs.bits rhs.bits) := by + rintro inp work out ⟨hinputEq, hworkEq, houtputEq⟩ + subst inp + subst work + subst out + have hresultPrefix : (workβ‚€ resultIdx).HasBinaryPrefix [] := by + simpa [Tape.HasBinaryString, Tape.HasBinaryPrefix] using hresult.2 + obtain ⟨c', hreach, hhalt, hfinalInput, hfinalLhs, hfinalLhsHead, + hfinalRhs, hfinalRhsHead, hfinalResult, hfinalResultStart, + hfinalOther, hfinalOutput⟩ := + binaryRippleAddScanTM_reachesIn_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs.bits rhs.bits inpβ‚€ workβ‚€ outβ‚€ hlhs.2 hrhs.2 + hresultPrefix hresult.1 hinput hother houtput + refine ⟨c', binaryRippleAddScanTime lhs.bits rhs.bits, le_rfl, + hreach, hhalt, ?_⟩ + refine ⟨hfinalInput, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hfinalResultStart, + ?_, hfinalOther, hfinalOutput⟩ + Β· simpa only [Tape.HasBinaryContent, hfinalLhs] using + hlhs.2.hasBinaryContent + Β· rw [hfinalLhs] + exact hlhs.1 + Β· simpa [Nat.size_eq_bits_len] using hfinalLhsHead + Β· simpa only [Tape.HasBinaryContent, hfinalRhs] using + hrhs.2.hasBinaryContent + Β· rw [hfinalRhs] + exact hrhs.1 + Β· simpa [Nat.size_eq_bits_len] using hfinalRhsHead + Β· simpa [BinaryRippleAdd.ripple_natBits_internal] using! hfinalResult.2 + Β· simpa [BinaryRippleAdd.ripple_natBits_internal, + Nat.size_eq_bits_len] using hfinalResult.1 + +private theorem binaryRippleAddRewindTail_hoareTime_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (seqTM (rewindWorkTM lhsIdx) + (seqTM (rewindWorkTM rhsIdx) (rewindWorkTM resultIdx))).HoareTime + (binaryRippleAddScanPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleAddPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + ((lhs.size + 1) + (rhs.size + 1) + ((lhs + rhs).size + 1) + 8) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hlhs, hlhsStart, hlhsHead, hrhs, hrhsStart, + hrhsHead, hresult, hresultStart, hresultHead, hframe, hout⟩ + have hrewind := binaryRippleAddRewindTM_hoareTime_frame_internal + lhsIdx rhsIdx resultIdx hdistinct lhs.bits rhs.bits (lhs + rhs).bits + (lhs.size + 1) (rhs.size + 1) ((lhs + rhs).size + 1) + inp work out hlhs hlhsStart + ⟨by rw [hlhsHead]; omega, by rw [hlhsHead]⟩ + hrhs hrhsStart + ⟨by rw [hrhsHead]; omega, by rw [hrhsHead]⟩ + hresult hresultStart + ⟨by rw [hresultHead]; omega, by rw [hresultHead]⟩ + (hinp.symm β–Έ hinput) + (fun i hil hir hires => by + rw [hframe i hil hir hires] + exact hother i hil hir hires) + (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalLhs, + hfinalRhs, hfinalResult, hfinalOther, hfinalOutput⟩ := + hrewind inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, htime, hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, hfinalOutput.trans hout⟩ + Β· rw [hfinalLhs] + exact Tape.init_move_right_hasBinaryNat lhs + Β· rw [hfinalRhs] + exact Tape.init_move_right_hasBinaryNat rhs + Β· rw [hfinalResult] + exact Tape.init_move_right_hasBinaryNat (lhs + rhs) + Β· intro i hil hir hires + exact (hfinalOther i hil hir hires).trans (hframe i hil hir hires) + +theorem binaryRippleAddTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleAddPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleAddTime lhs rhs) := by + have hscan := binaryRippleAddScanTM_hoareTime_frame_internal + lhsIdx rhsIdx resultIdx hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult hinput.read_ne_start + (fun i hil hir hires => (hother i hil hir hires).read_ne_start) + houtput.read_ne_start + have htail := binaryRippleAddRewindTail_hoareTime_internal + lhsIdx rhsIdx resultIdx hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hinput hother houtput + have htransition : βˆ€ inp work out, + binaryRippleAddScanPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€ + inp work out β†’ + binaryRippleAddScanPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, hlhsContent, hlhsStart, hlhsHead, + hrhsContent, hrhsStart, hrhsHead, hresultContent, hresultStart, + hresultHead, hframe, hout⟩ + have hworkRead : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hil : i = lhsIdx + Β· subst i + exact hlhsContent.cells_ne_start _ (by rw [hlhsHead]; omega) + by_cases hir : i = rhsIdx + Β· subst i + exact hrhsContent.cells_ne_start _ (by rw [hrhsHead]; omega) + by_cases hires : i = resultIdx + Β· subst i + exact hresultContent.cells_ne_start _ (by rw [hresultHead]; omega) + Β· rw [hframe i hil hir hires] + exact (hother i hil hir hires).read_ne_start + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hworkRead + (hout.symm β–Έ houtput.read_ne_start) + rw [hinputTransition, hworkTransition, houtputTransition] + exact ⟨hinp, hlhsContent, hlhsStart, hlhsHead, hrhsContent, hrhsStart, + hrhsHead, hresultContent, hresultStart, hresultHead, hframe, hout⟩ + have hrun := seqTM_hoareTime + (binaryRippleAddScanTM lhsIdx rhsIdx resultIdx) + (seqTM (rewindWorkTM lhsIdx) + (seqTM (rewindWorkTM rhsIdx) (rewindWorkTM resultIdx))) + hscan htransition htail + unfold binaryRippleAddTM + apply hrun.mono_bound + rw [binaryRippleAddScanTime_natBits_internal] + simp only [binaryRippleAddTime] + omega + +theorem binaryRippleAddTM_hoareTimeSpace_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleAddDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryRippleAddTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryRippleAddTM lhsIdx rhsIdx resultIdx).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryRippleAddTM lhsIdx rhsIdx resultIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleAddPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleAddTime lhs rhs) inputLength + (initialSpace + binaryRippleAddTime lhs rhs) := by + apply (binaryRippleAddTM_hoareTime_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother + houtput).toHoareTimeSpace + rintro inp work out ⟨hinputEq, hworkEq, houtputEq⟩ + subst inp + subst work + subst out + exact hinitial + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub.lean new file mode 100644 index 0000000000..c59bb7ecb2 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Sem +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Out + +/-! +# Linear-time canonical binary subtraction + +This module exposes a concrete three-tape ripple-borrow subtractor. It preserves +two canonical little-endian operands, writes their truncated natural-number +difference to a fresh zero result tape, restores every owned head to cell one, +and preserves the complete external tape frame. Its running time is linear in +the operand bit widths. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleSub + +/-- Canonical ripple-borrow subtraction agrees with natural-number monus. -/ +theorem subtract_natBits (lhs rhs : β„•) : + subtract lhs.bits rhs.bits = (lhs - rhs).bits := + subtract_natBits_internal lhs rhs + +end BinaryRippleSub + +namespace TM + +/-- The complete subtractor has a linear bit-width envelope. -/ +theorem binaryRippleSubTime_le (lhs rhs : β„•) : + binaryRippleSubTime lhs rhs ≀ 3 * (lhs.size + rhs.size) + 10 := + binaryRippleSubTime_le_internal lhs rhs + +/-- Framed time contract for truncated subtraction. Both operands are restored, +the initially-zero result becomes their natural-number difference, and every +unrelated tape is preserved exactly. -/ +theorem binaryRippleSubTM_hoareTime_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs - rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryRippleSubTime lhs rhs) := + binaryRippleSubTM_hoareTime_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother + houtput + +/-- Reachability form of the framed subtraction theorem. -/ +theorem binaryRippleSubTM_reachesIn_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆƒ c' time, + time ≀ binaryRippleSubTime lhs rhs ∧ + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).reachesIn time + { state := (binaryRippleSubTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).HasBinaryNat lhs ∧ + (c'.work rhsIdx).HasBinaryNat rhs ∧ + (c'.work resultIdx).HasBinaryNat (lhs - rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + exact binaryRippleSubTM_hoareTime_frame lhsIdx rhsIdx resultIdx hdistinct + lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother houtput + inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + +/-- All-prefix auxiliary-space contract obtained from the concrete linear +time bound. -/ +theorem binaryRippleSubTM_hoareTimeSpace_frame {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryRippleSubTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryRippleSubTM lhsIdx rhsIdx resultIdx).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs - rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryRippleSubTime lhs rhs) inputLength + (initialSpace + binaryRippleSubTime lhs rhs) := + binaryRippleSubTM_hoareTimeSpace_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inputLength initialSpace inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult hinput hother houtput hinitial + +/-- Canonical subtraction never moves the public output head left. -/ +theorem binaryRippleSubTM_isTransducer {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).IsTransducer := + binaryRippleSubTM_isTransducer_internal lhsIdx rhsIdx resultIdx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Defs.lean new file mode 100644 index 0000000000..5380f2f32b --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Defs.lean @@ -0,0 +1,274 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import Mathlib.Data.Nat.Bits + +/-! +# Linear-time canonical binary subtraction -- definitions + +This module defines a full-borrow scan over two preserved little-endian binary +work tapes. The scan writes a fixed-width difference to a fresh result tape. +A single backward pass then erases the complete result on underflow or removes +only its redundant high zeros, while returning the result head to cell one. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleSub + +/-- The low output bit of one binary-subtraction column. -/ +def diffBit (borrow lhs rhs : Bool) : Bool := + (lhs.xor rhs).xor borrow + +/-- The outgoing borrow of one binary-subtraction column. -/ +def borrowBit (borrow lhs rhs : Bool) : Bool := + (!lhs && rhs) || (!lhs && borrow) || (rhs && borrow) + +/-- Raw fixed-width output of a borrow scan. -/ +structure ScanResult where + /-- Little-endian difference bits produced so far. -/ + bits : List Bool + /-- Borrow propagated beyond the most-significant scanned column. -/ + borrow : Bool + deriving DecidableEq + +/-- Scan two little-endian bit strings with an incoming borrow. A missing side +is padded by zero; the final borrow is retained separately from the raw bits. -/ +def scan : Bool β†’ List Bool β†’ List Bool β†’ ScanResult + | borrow, [], [] => ⟨[], borrow⟩ + | borrow, lhs :: lhsTail, [] => + let tail := scan (borrowBit borrow lhs false) lhsTail [] + ⟨diffBit borrow lhs false :: tail.bits, tail.borrow⟩ + | borrow, [], rhs :: rhsTail => + let tail := scan (borrowBit borrow false rhs) [] rhsTail + ⟨diffBit borrow false rhs :: tail.bits, tail.borrow⟩ + | borrow, lhs :: lhsTail, rhs :: rhsTail => + let tail := scan (borrowBit borrow lhs rhs) lhsTail rhsTail + ⟨diffBit borrow lhs rhs :: tail.bits, tail.borrow⟩ + +/-- Remove redundant most-significant zeros from a little-endian bit string. -/ +def trimHighZeros : List Bool β†’ List Bool + | [] => [] + | bit :: rest => + match trimHighZeros rest with + | [] => if bit then [true] else [] + | high :: tail => bit :: high :: tail + +/-- Canonical truncated subtraction semantics on arbitrary little-endian bit +strings. Underflow is represented by canonical zero. -/ +def subtract (lhs rhs : List Bool) : List Bool := + let raw := scan false lhs rhs + if raw.borrow then [] else trimHighZeros raw.bits + +end BinaryRippleSub + +namespace TM + +/-- Forward-borrow states, backward cleanup states, and the unique halt state. -/ +inductive BinaryRippleSubPhase where + | scan (borrow : Bool) + | erase + | trim (seenOne : Bool) + | done + deriving DecidableEq + +/-- `BinaryRippleSubPhase` is finite, as required by the concrete TM model. -/ +instance instFintypeBinaryRippleSubPhase : Fintype BinaryRippleSubPhase where + elems := {.scan false, .scan true, .erase, .trim false, .trim true, .done} + complete := by + intro phase + cases phase with + | scan borrow => cases borrow <;> simp + | erase => simp + | trim seenOne => cases seenOne <;> simp + | done => simp + +/-- Pairwise distinct work tapes owned by the ripple-borrow subtractor. -/ +structure BinaryRippleSubDistinct {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : Prop where + lhs_rhs : lhsIdx β‰  rhsIdx + lhs_result : lhsIdx β‰  resultIdx + rhs_result : rhsIdx β‰  resultIdx + +/-- Scan two canonical operands, write their fixed-width raw difference, and +canonicalize the result while moving backward. A final borrow erases the whole +result; otherwise high zeros are erased until the first high one is seen. -/ +def binaryRippleSubCoreTM {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : TM n where + Q := BinaryRippleSubPhase + qstart := .scan false + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scan borrow => + if wHeads lhsIdx = Ξ“.blank ∧ wHeads rhsIdx = Ξ“.blank then + (if borrow then .erase else .trim false, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then moveLeftDir (wHeads resultIdx) + else idleDir (wHeads i), + idleDir oHead) + else + let lhsBit := decide (wHeads lhsIdx = Ξ“.one) + let rhsBit := decide (wHeads rhsIdx = Ξ“.one) + let diff := BinaryRippleSub.diffBit borrow lhsBit rhsBit + let nextBorrow := BinaryRippleSub.borrowBit borrow lhsBit rhsBit + (.scan nextBorrow, + fun i => if i = resultIdx then Ξ“w.ofBool diff + else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => + if i = resultIdx then Dir3.right + else if i = lhsIdx then + if wHeads lhsIdx = Ξ“.blank then Dir3.stay else Dir3.right + else if i = rhsIdx then + if wHeads rhsIdx = Ξ“.blank then Dir3.stay else Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .erase => + if wHeads resultIdx = Ξ“.start then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.erase, + fun i => if i = resultIdx then Ξ“w.blank + else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then moveLeftDir (wHeads resultIdx) + else idleDir (wHeads i), + idleDir oHead) + | .trim seenOne => + if wHeads resultIdx = Ξ“.start then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else if seenOne ∨ wHeads resultIdx = Ξ“.one then + (.trim true, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then moveLeftDir (wHeads resultIdx) + else idleDir (wHeads i), + idleDir oHead) + else + (.trim false, + fun i => if i = resultIdx then Ξ“w.blank + else readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = resultIdx then moveLeftDir (wHeads resultIdx) + else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | scan borrow => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + by_cases hresult : i = resultIdx + Β· subst i + rw [ite_eq_left rfl] + exact moveLeftDir_right_of_start hi + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + dsimp only + by_cases hresult : i = resultIdx + Β· rw [ite_eq_left hresult] + Β· rw [ite_eq_right hresult] + by_cases hlhs : i = lhsIdx + Β· rw [ite_eq_left hlhs] + subst i + simp [hi] + Β· rw [ite_eq_right hlhs] + by_cases hrhs : i = rhsIdx + Β· rw [ite_eq_left hrhs] + subst i + simp [hi] + Β· rw [ite_eq_right hrhs] + exact idleDir_right_of_start hi + | erase => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + by_cases hresult : i = resultIdx + Β· rw [ite_eq_left hresult] + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + Β· rename_i hnotStart + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + by_cases hresult : i = resultIdx + Β· subst i + rw [ite_eq_left rfl] + exact moveLeftDir_right_of_start hi + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + | trim seenOne => + dsimp only + split + Β· refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hi + simp only + by_cases hresult : i = resultIdx + Β· rw [ite_eq_left hresult] + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + Β· rename_i hnotStart + split <;> + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + all_goals + intro i hi + simp only + by_cases hresult : i = resultIdx + Β· subst i + rw [ite_eq_left rfl] + exact moveLeftDir_right_of_start hi + Β· rw [ite_eq_right hresult] + exact idleDir_right_of_start hi + | done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Forward scan time, including the simultaneous-blank turn. -/ +def binaryRippleSubScanTime (lhs rhs : List Bool) : β„• := + max lhs.length rhs.length + 1 + +/-- Backward cleanup time, including the final marker bounce. -/ +def binaryRippleSubCleanupTime (lhs rhs : List Bool) : β„• := + max lhs.length rhs.length + 1 + +/-- Exact time of the forward scan followed by backward canonicalization. -/ +def binaryRippleSubCoreTime (lhs rhs : List Bool) : β„• := + 2 * max lhs.length rhs.length + 2 + +/-- Canonical subtraction followed by rewinds of the two preserved operands. -/ +def binaryRippleSubTM {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : TM n := + seqTM (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx) + (seqTM (rewindWorkTM lhsIdx) (rewindWorkTM rhsIdx)) + +/-- Width-linear time bound for the core, two rewinds, and two seams. -/ +def binaryRippleSubTime (lhs rhs : β„•) : β„• := + 2 * max lhs.size rhs.size + lhs.size + rhs.size + 10 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal.lean new file mode 100644 index 0000000000..d5d1b7eaca --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Backward +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Sem + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Backward.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Backward.lean new file mode 100644 index 0000000000..39e62c7f26 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Backward.lean @@ -0,0 +1,623 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import Mathlib.Algebra.Order.Sub.Basic + +/-! +# Linear-time canonical binary subtraction -- backward cleanup + +This module proves the exact backward half of `TM.binaryRippleSubCoreTM`. +Underflow erases the entire fixed-width result. Otherwise the machine erases +only redundant high zeros, preserves the significant suffix after its first +high one, and returns the result head to cell one. All other tapes are framed +literally throughout the run. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Tape + +/-- Blanking the final represented cell shortens canonical binary contents by +one bit. The erased bit may have either value. -/ +theorem HasBinaryContent.write_blank_last_internal {t : Tape} + {bitsPrefix : List Bool} {bit : Bool} + (h : t.HasBinaryContent (bitsPrefix ++ [bit])) + (hhead : t.head = bitsPrefix.length + 1) : + (t.write Ξ“.blank).HasBinaryContent bitsPrefix := by + have hhead0 : t.head β‰  0 := by omega + constructor + Β· intro i hi + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [hhead, Function.update_of_ne (by omega)] + have hcell := h.1 i (by simp; omega) + simpa [List.getElem_append, hi] using hcell + Β· intro i hi + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [hhead] + by_cases heq : i = bitsPrefix.length + Β· subst i + rw [Function.update_self] + Β· rw [Function.update_of_ne (by omega)] + exact h.2 i (by simp; omega) + +end Tape + +namespace TM + +variable {n : β„•} {lhsIdx rhsIdx resultIdx : Fin n} + +private theorem binaryRippleSubCoreTM_ne_halt + {phase : BinaryRippleSubPhase} + (hne : phase β‰  .done) + {c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q} + (hstate : c.state = phase) : + c.state β‰  (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).qhalt := by + rw [hstate] + exact hne + +private theorem binaryRippleSubCoreTM_step_erase + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .erase) + (hread : (c.work resultIdx).read β‰  Ξ“.start) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .erase + input := c.input + work := Function.update c.work resultIdx + (((c.work resultIdx).write Ξ“.blank).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by simp) hstate)] + simp only [binaryRippleSubCoreTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = resultIdx + Β· subst i + simp only [↓reduceIte, Function.update_self] + simp [moveLeftDir, hread] + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +private theorem binaryRippleSubCoreTM_step_trim_false_zero + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .trim false) + (hread : (c.work resultIdx).read = Ξ“.zero) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .trim false + input := c.input + work := Function.update c.work resultIdx + (((c.work resultIdx).write Ξ“.blank).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by decide) hstate)] + simp only [binaryRippleSubCoreTM, hstate] + simp [hread] + refine ⟨transitionInput_eq_self hinput, ?_, transitionTape_eq_self houtput⟩ + funext i + by_cases hi : i = resultIdx + Β· subst i + simp only [↓reduceIte, Function.update_self] + simp [moveLeftDir] + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + +private theorem binaryRippleSubCoreTM_step_trim_false_one + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .trim false) + (hread : (c.work resultIdx).read = Ξ“.one) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .trim true + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by decide) hstate)] + simp only [binaryRippleSubCoreTM, hstate] + simp [hread] + refine ⟨transitionInput_eq_self hinput, ?_, transitionTape_eq_self houtput⟩ + funext i + by_cases hi : i = resultIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self] + change (c.work resultIdx).writeAndMove + (readBackWrite (c.work resultIdx).read) (moveLeftDir Ξ“.one) = _ + rw [writeAndMove_readBack _ (by rw [hread]; decide)] + simp [moveLeftDir] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + +private theorem binaryRippleSubCoreTM_step_trim_true + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .trim true) + (hread : (c.work resultIdx).read β‰  Ξ“.start) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .trim true + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by decide) hstate)] + simp only [binaryRippleSubCoreTM, hstate] + simp [hread] + refine ⟨transitionInput_eq_self hinput, ?_, transitionTape_eq_self houtput⟩ + funext i + by_cases hi : i = resultIdx + Β· subst i + rw [ite_eq_left rfl, Function.update_self] + change (c.work resultIdx).writeAndMove + (readBackWrite (c.work resultIdx).read) + (moveLeftDir (c.work resultIdx).read) = _ + rw [writeAndMove_readBack _ hread] + simp [moveLeftDir, hread] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + +private theorem binaryRippleSubCoreTM_step_erase_start + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .erase) + (hread : (c.work resultIdx).read = Ξ“.start) + (hhead : (c.work resultIdx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .done + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by simp) hstate)] + simp only [binaryRippleSubCoreTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = resultIdx + Β· subst i + simp only [↓reduceIte, Function.update_self] + show (((c.work resultIdx).write _).move Dir3.right) = + (c.work resultIdx).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +private theorem binaryRippleSubCoreTM_step_trim_start + (seenOne : Bool) + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .trim seenOne) + (hread : (c.work resultIdx).read = Ξ“.start) + (hhead : (c.work resultIdx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step c = some + { state := .done + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binaryRippleSubCoreTM_ne_halt (by simp) hstate)] + simp only [binaryRippleSubCoreTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = resultIdx + Β· subst i + simp only [↓reduceIte, Function.update_self] + show (((c.work resultIdx).write _).move Dir3.right) = + (c.work resultIdx).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-! ## Exact backward runs -/ + +private theorem binaryRippleSubCoreTM_trim_true_run + (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ head (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q), + c.state = .trim true β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  resultIdx β†’ c.work i = workβ‚€ i) β†’ + (c.work resultIdx).HasBinaryContent bits β†’ + (c.work resultIdx).cells 0 = Ξ“.start β†’ + (c.work resultIdx).head = head β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (head + 1) c c' ∧ + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  resultIdx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work resultIdx).HasBinaryString bits ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro head + induction head with + | zero => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work resultIdx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binaryRippleSubCoreTM_step_trim_start true c hstate hread + hhead (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .done + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + Β· intro i hi + show Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).HasBinaryString bits + rw [Function.update_self] + apply Tape.HasBinaryContent.hasBinaryString + Β· exact hcontent.move Dir3.right + Β· simp [Tape.move, hhead] + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | succ head ih => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work resultIdx).read β‰  Ξ“.start := by + rw [Tape.read, hhead] + exact hcontent.cells_ne_start (head + 1) (by omega) + have hstep := binaryRippleSubCoreTM_step_trim_true c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .trim true + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) resultIdx).HasBinaryContent bits + rw [Function.update_self] + exact hcontent.move Dir3.left) + (by + show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) resultIdx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0) + (by + show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.left) resultIdx).head = head + rw [Function.update_self] + simp [Tape.move, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ + simpa [Nat.succ_eq_add_one, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + +private theorem binaryRippleSubCoreTM_erase_run + (raw : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .erase) + (hinput : c.input = inpβ‚€) + (hwork : βˆ€ i, i β‰  resultIdx β†’ c.work i = workβ‚€ i) + (hcontent : (c.work resultIdx).HasBinaryContent raw) + (hcell0 : (c.work resultIdx).cells 0 = Ξ“.start) + (hhead : (c.work resultIdx).head = raw.length) + (houtput : c.output = outβ‚€) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (raw.length + 1) c c' ∧ + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  resultIdx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work resultIdx).HasBinaryString [] ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + induction raw using List.reverseRecOn generalizing c with + | nil => + have hread : (c.work resultIdx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binaryRippleSubCoreTM_step_erase_start c hstate hread + hhead (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .done + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + Β· intro i hi + show Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).HasBinaryString [] + rw [Function.update_self] + exact (hcontent.move Dir3.right).hasBinaryString (by simp [Tape.move, hhead]) + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | append_singleton bitsPrefix bit ih => + have hread : (c.work resultIdx).read = Ξ“.ofBool bit := by + rw [Tape.read, hhead] + have hcell := hcontent.1 bitsPrefix.length (by simp) + simpa using hcell + have hreadNe : (c.work resultIdx).read β‰  Ξ“.start := by + rw [hread] + exact Ξ“.ofBool_ne_start bit + have hstep := binaryRippleSubCoreTM_step_erase c hstate hreadNe + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target₁ : Tape := + ((c.work resultIdx).write Ξ“.blank).move Dir3.left + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .erase + input := c.input + work := Function.update c.work resultIdx target₁ + output := c.output } + have hshort : + ((c.work resultIdx).write Ξ“.blank).HasBinaryContent bitsPrefix := + hcontent.write_blank_last_internal (by simpa using hhead) + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work resultIdx target₁ i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work resultIdx target₁ resultIdx) + |>.HasBinaryContent bitsPrefix + rw [Function.update_self] + exact hshort.move Dir3.left) + (by + show (Function.update c.work resultIdx target₁ resultIdx).cells 0 = _ + rw [Function.update_self] + exact Tape.write_move_cell0 Ξ“.blank Dir3.left hcell0) + (by + show (Function.update c.work resultIdx target₁ resultIdx).head = + bitsPrefix.length + rw [Function.update_self] + simp [target₁, Tape.move, Tape.write_head, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ + simpa [List.length_append, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + +private theorem binaryRippleSubCoreTM_trim_false_run + (raw : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (c : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) + (hstate : c.state = .trim false) + (hinput : c.input = inpβ‚€) + (hwork : βˆ€ i, i β‰  resultIdx β†’ c.work i = workβ‚€ i) + (hcontent : (c.work resultIdx).HasBinaryContent raw) + (hcell0 : (c.work resultIdx).cells 0 = Ξ“.start) + (hhead : (c.work resultIdx).head = raw.length) + (houtput : c.output = outβ‚€) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (raw.length + 1) c c' ∧ + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  resultIdx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work resultIdx).HasBinaryString + (BinaryRippleSub.trimHighZeros raw) ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + induction raw using List.reverseRecOn generalizing c with + | nil => + have hread : (c.work resultIdx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binaryRippleSubCoreTM_step_trim_start false c hstate hread + hhead (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .done + input := c.input + work := Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + Β· intro i hi + show Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).HasBinaryString + (BinaryRippleSub.trimHighZeros []) + rw [Function.update_self] + simpa [BinaryRippleSub.trimHighZeros] using + (hcontent.move Dir3.right).hasBinaryString (by simp [Tape.move, hhead]) + Β· show (Function.update c.work resultIdx + ((c.work resultIdx).move Dir3.right) resultIdx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | append_singleton bitsPrefix bit ih => + have hread : (c.work resultIdx).read = Ξ“.ofBool bit := by + rw [Tape.read, hhead] + have hcell := hcontent.1 bitsPrefix.length (by simp) + simpa using hcell + cases bit with + | false => + have hreadZero : (c.work resultIdx).read = Ξ“.zero := by + simpa [Ξ“.ofBool] using hread + have hstep := binaryRippleSubCoreTM_step_trim_false_zero c hstate + hreadZero (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target₁ : Tape := + ((c.work resultIdx).write Ξ“.blank).move Dir3.left + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .trim false + input := c.input + work := Function.update c.work resultIdx target₁ + output := c.output } + have hshort : + ((c.work resultIdx).write Ξ“.blank).HasBinaryContent bitsPrefix := + hcontent.write_blank_last_internal (by simpa using hhead) + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work resultIdx target₁ i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work resultIdx target₁ resultIdx) + |>.HasBinaryContent bitsPrefix + rw [Function.update_self] + exact hshort.move Dir3.left) + (by + show (Function.update c.work resultIdx target₁ resultIdx).cells 0 = _ + rw [Function.update_self] + exact Tape.write_move_cell0 Ξ“.blank Dir3.left hcell0) + (by + show (Function.update c.work resultIdx target₁ resultIdx).head = + bitsPrefix.length + rw [Function.update_self] + simp [target₁, Tape.move, Tape.write_head, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· simpa [List.length_append, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + Β· simpa [BinaryRippleSub.trimHighZeros_append_false_internal] using hstring + | true => + have hreadOne : (c.work resultIdx).read = Ξ“.one := by + simpa [Ξ“.ofBool] using hread + have hstep := binaryRippleSubCoreTM_step_trim_false_one c hstate + hreadOne (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target₁ : Tape := (c.work resultIdx).move Dir3.left + let c₁ : Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q := + { state := .trim true + input := c.input + work := Function.update c.work resultIdx target₁ + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binaryRippleSubCoreTM_trim_true_run (lhsIdx := lhsIdx) + (rhsIdx := rhsIdx) (resultIdx := resultIdx) (bitsPrefix ++ [true]) + inpβ‚€ workβ‚€ outβ‚€ hinp hother hout bitsPrefix.length c₁ rfl hinput + (fun i hi => by + show Function.update c.work resultIdx target₁ i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work resultIdx target₁ resultIdx) + |>.HasBinaryContent (bitsPrefix ++ [true]) + rw [Function.update_self] + exact hcontent.move Dir3.left) + (by + show (Function.update c.work resultIdx target₁ resultIdx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0) + (by + show (Function.update c.work resultIdx target₁ resultIdx).head = + bitsPrefix.length + rw [Function.update_self] + simp [target₁, Tape.move, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· simpa [List.length_append, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + Β· simpa [BinaryRippleSub.trimHighZeros_append_true_internal] using hstring + +/-- Exact framed backward cleanup after the forward scan has turned the result +head left. A final borrow erases the entire raw result; otherwise all and only +its redundant high zeros are erased. -/ +theorem binaryRippleSubCoreTM_cleanup_run_internal + (lhsIdx rhsIdx resultIdx : Fin n) + (raw : List Bool) (borrow : Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  resultIdx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (hcontent : (workβ‚€ resultIdx).HasBinaryContent raw) + (hcell0 : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hhead : (workβ‚€ resultIdx).head = raw.length) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (raw.length + 1) + { state := if borrow then .erase else .trim false + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  resultIdx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work resultIdx).HasBinaryString + (if borrow then [] else BinaryRippleSub.trimHighZeros raw) ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + cases borrow with + | false => + simpa using binaryRippleSubCoreTM_trim_false_run + (lhsIdx := lhsIdx) (rhsIdx := rhsIdx) (resultIdx := resultIdx) + raw inpβ‚€ workβ‚€ outβ‚€ hinp hother hout + { state := .trim false, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } + rfl rfl (fun _ _ => rfl) hcontent hcell0 hhead rfl + | true => + simpa using binaryRippleSubCoreTM_erase_run + (lhsIdx := lhsIdx) (rhsIdx := rhsIdx) (resultIdx := resultIdx) + raw inpβ‚€ workβ‚€ outβ‚€ hinp hother hout + { state := .erase, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } + rfl rfl (fun _ _ => rfl) hcontent hcell0 hhead rfl + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Out.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Out.lean new file mode 100644 index 0000000000..dbc8506403 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Out.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Internal + +/-! +# Linear-time canonical binary subtraction -- output discipline + +The borrow scan, backward cleanup, and operand rewinds leave the public output +tape one-way, so the core and complete machines are safe transducers. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The direct subtraction core never moves the public output head left. -/ +theorem binaryRippleSubCoreTM_isTransducer_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | scan borrow => + simp only [binaryRippleSubCoreTM] + split <;> simp [idleDir] <;> split <;> decide + | erase => + simp only [binaryRippleSubCoreTM] + split <;> simp [idleDir] <;> split <;> decide + | trim seenOne => + simp only [binaryRippleSubCoreTM] + split + Β· simp [idleDir] + split <;> decide + Β· split + Β· simp [idleDir] + split <;> decide + Β· simp [idleDir] + split <;> decide + | done => + simp [binaryRippleSubCoreTM, allIdle, idleDir] + split <;> decide + +/-- Backward canonicalization followed by both operand rewinds remains a +transducer. -/ +theorem binaryRippleSubTM_isTransducer_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).IsTransducer := by + exact (binaryRippleSubCoreTM_isTransducer_internal + lhsIdx rhsIdx resultIdx).seqTM + ((rewindWorkTM_isTransducer_internal lhsIdx).seqTM + (rewindWorkTM_isTransducer_internal rhsIdx)) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Pure.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Pure.lean new file mode 100644 index 0000000000..173b814c0c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Pure.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import Mathlib.Algebra.Order.Ring.Nat +public import Std.Tactic.BVDecide.Normalize.Bool + +/-! +# Linear-time canonical binary subtraction -- pure proofs + +The raw scan is verified through the standard full-subtractor invariant. Its +final borrow decides underflow, while trimming is proved to recover the +canonical `Nat.bits` representation of the raw fixed-width value. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryRippleSub + +/-- Interpret a Boolean bit as a natural number. -/ +def boolValue (bit : Bool) : β„• := + if bit then 1 else 0 + +private theorem fullSub_value (borrow lhs rhs : Bool) : + boolValue lhs + 2 * boolValue (borrowBit borrow lhs rhs) = + boolValue rhs + boolValue borrow + boolValue (diffBit borrow lhs rhs) := by + cases borrow <;> cases lhs <;> cases rhs <;> + simp [boolValue, borrowBit, diffBit] + +private theorem scan_value_step + (borrow lhsBit rhsBit tailBorrow : Bool) + (lhs rhs tailValue width : β„•) + (htail : lhs + (if tailBorrow then 2 ^ width else 0) = + rhs + boolValue (borrowBit borrow lhsBit rhsBit) + tailValue) : + (boolValue lhsBit + 2 * lhs) + + (if tailBorrow then 2 ^ (width + 1) else 0) = + (boolValue rhsBit + 2 * rhs) + boolValue borrow + + (boolValue (diffBit borrow lhsBit rhsBit) + 2 * tailValue) := by + cases borrow <;> cases lhsBit <;> cases rhsBit <;> cases tailBorrow <;> + simp [boolValue, borrowBit, diffBit, pow_succ] at htail ⊒ <;> omega + +/-- The raw borrow scan writes exactly the larger input width. -/ +theorem scan_bits_length_internal (borrow : Bool) (lhs rhs : List Bool) : + (scan borrow lhs rhs).bits.length = max lhs.length rhs.length := by + induction lhs generalizing rhs borrow with + | nil => + induction rhs generalizing borrow with + | nil => simp [scan] + | cons rhsBit rhsTail ih => simp [scan, ih] + | cons lhsBit lhsTail ih => + cases rhs with + | nil => simp [scan, ih] + | cons rhsBit rhsTail => simp [scan, ih] + +/-- Arithmetic invariant for the fixed-width borrow scan. The final borrow is +the coefficient of the width-sized wraparound term. -/ +theorem scan_value_internal (borrow : Bool) (lhs rhs : List Bool) : + Nat.fromBitsLE lhs + + (if (scan borrow lhs rhs).borrow then + 2 ^ max lhs.length rhs.length else 0) = + Nat.fromBitsLE rhs + boolValue borrow + + Nat.fromBitsLE (scan borrow lhs rhs).bits := by + induction lhs generalizing rhs borrow with + | nil => + induction rhs generalizing borrow with + | nil => + cases borrow <;> simp [scan, boolValue, Nat.fromBitsLE, Nat.fromBits] + | cons rhsBit rhsTail ih => + let nextBorrow := borrowBit borrow false rhsBit + let tail := scan nextBorrow [] rhsTail + have htail : 0 + (if tail.borrow then 2 ^ rhsTail.length else 0) = + Nat.fromBitsLE rhsTail + boolValue nextBorrow + + Nat.fromBitsLE tail.bits := by + simpa [tail, nextBorrow, Nat.fromBitsLE, Nat.fromBits] using + ih nextBorrow + have hstep := scan_value_step borrow false rhsBit tail.borrow 0 + (Nat.fromBitsLE rhsTail) (Nat.fromBitsLE tail.bits) + rhsTail.length htail + simpa [scan, tail, nextBorrow, Nat.fromBitsLE_cons] using! hstep + | cons lhsBit lhsTail ih => + cases rhs with + | nil => + let nextBorrow := borrowBit borrow lhsBit false + let tail := scan nextBorrow lhsTail [] + have htail : Nat.fromBitsLE lhsTail + + (if tail.borrow then 2 ^ lhsTail.length else 0) = + 0 + boolValue nextBorrow + Nat.fromBitsLE tail.bits := by + simpa [tail, nextBorrow, Nat.fromBitsLE, Nat.fromBits] using + ih nextBorrow [] + have hstep := scan_value_step borrow lhsBit false tail.borrow + (Nat.fromBitsLE lhsTail) 0 (Nat.fromBitsLE tail.bits) + lhsTail.length htail + simpa [scan, tail, nextBorrow, Nat.fromBitsLE_cons] using! hstep + | cons rhsBit rhsTail => + let nextBorrow := borrowBit borrow lhsBit rhsBit + let tail := scan nextBorrow lhsTail rhsTail + have htail : Nat.fromBitsLE lhsTail + + (if tail.borrow then + 2 ^ max lhsTail.length rhsTail.length else 0) = + Nat.fromBitsLE rhsTail + boolValue nextBorrow + + Nat.fromBitsLE tail.bits := by + simpa [tail, nextBorrow] using ih nextBorrow rhsTail + have hstep := scan_value_step borrow lhsBit rhsBit tail.borrow + (Nat.fromBitsLE lhsTail) (Nat.fromBitsLE rhsTail) + (Nat.fromBitsLE tail.bits) (max lhsTail.length rhsTail.length) htail + simpa [scan, tail, nextBorrow, Nat.fromBitsLE_cons] using! hstep + +/-- Appending a redundant high zero does not change canonical trimming. -/ +theorem trimHighZeros_append_false_internal (bits : List Bool) : + trimHighZeros (bits ++ [false]) = trimHighZeros bits := by + induction bits with + | nil => simp [trimHighZeros] + | cons bit rest ih => + rw [List.cons_append, trimHighZeros, ih] + cases rest <;> rfl + +/-- A high one makes the entire lower prefix significant. -/ +theorem trimHighZeros_append_true_internal (bits : List Bool) : + trimHighZeros (bits ++ [true]) = bits ++ [true] := by + induction bits with + | nil => simp [trimHighZeros] + | cons bit rest ih => + rw [List.cons_append, trimHighZeros, ih] + cases rest <;> rfl + +/-- Trimming arbitrary little-endian bits produces the canonical bits of their +decoded natural value. -/ +theorem trimHighZeros_eq_natBits_internal (bits : List Bool) : + trimHighZeros bits = (Nat.fromBitsLE bits).bits := by + induction bits with + | nil => simp [trimHighZeros, Nat.fromBitsLE, Nat.fromBits] + | cons bit rest ih => + rw [Nat.fromBitsLE_cons] + simp only [trimHighZeros, ih] + by_cases hrest : Nat.fromBitsLE rest = 0 + Β· rw [hrest] + cases bit <;> simp + Β· have hbits : (Nat.fromBitsLE rest).bits β‰  [] := by + intro hnil + have hsize : (Nat.fromBitsLE rest).size = 0 := by + rw [← Nat.size_eq_bits_len, hnil] + rfl + exact hrest (Nat.size_eq_zero.mp hsize) + have hvalue : (if bit then 1 else 0) + 2 * Nat.fromBitsLE rest = + Nat.bit bit (Nat.fromBitsLE rest) := by + cases bit + Β· simp [Nat.bit] + Β· simp [Nat.bit, Nat.add_comm] + rw [hvalue, Nat.bits_append_bit _ bit (fun h => (hrest h).elim)] + cases htail : (Nat.fromBitsLE rest).bits with + | nil => exact (hbits htail).elim + | cons high tail => rfl + +/-- The canonical pure subtraction result agrees with natural-number monus. -/ +theorem subtract_natBits_internal (lhs rhs : β„•) : + subtract lhs.bits rhs.bits = (lhs - rhs).bits := by + let raw := scan false lhs.bits rhs.bits + have hinvariant := scan_value_internal false lhs.bits rhs.bits + have hlength := scan_bits_length_internal false lhs.bits rhs.bits + have hrawBound := Nat.fromBitsLE_lt_pow_length raw.bits + have hlength' : raw.bits.length = max lhs.size rhs.size := by + simpa [raw, Nat.size_eq_bits_len] using hlength + have hinvariant' : lhs + + (if raw.borrow then 2 ^ max lhs.size rhs.size else 0) = + rhs + Nat.fromBitsLE raw.bits := by + simpa [raw, Nat.fromBitsLE_bits, Nat.size_eq_bits_len] using! hinvariant + have hrawBound' : Nat.fromBitsLE raw.bits < 2 ^ max lhs.size rhs.size := by + rw [hlength'] at hrawBound + exact hrawBound + change (if raw.borrow then [] else trimHighZeros raw.bits) = (lhs - rhs).bits + cases hborrow : raw.borrow with + | false => + simp only [Bool.false_eq_true, ite_false] + rw [trimHighZeros_eq_natBits_internal] + have hvalue : Nat.fromBitsLE raw.bits = lhs - rhs := by + simp [hborrow] at hinvariant' + omega + rw [hvalue] + | true => + simp only [if_true] + have hlt : lhs < rhs := by + simp [hborrow] at hinvariant' + omega + rw [Nat.sub_eq_zero_of_le (Nat.le_of_lt hlt), Nat.zero_bits] + +/-- Canonical subtraction has exactly the width of natural-number monus. -/ +theorem length_subtract_natBits_internal (lhs rhs : β„•) : + (subtract lhs.bits rhs.bits).length = (lhs - rhs).size := by + rw [subtract_natBits_internal, Nat.size_eq_bits_len] + +end BinaryRippleSub + +namespace TM + +/-- The scan bound on canonical operands is the larger natural-number width. -/ +theorem binaryRippleSubScanTime_natBits_internal (lhs rhs : β„•) : + binaryRippleSubScanTime lhs.bits rhs.bits = max lhs.size rhs.size + 1 := by + simp [binaryRippleSubScanTime, Nat.size_eq_bits_len] + +/-- The cleanup bound equals the scan bound on canonical operands. -/ +theorem binaryRippleSubCleanupTime_natBits_internal (lhs rhs : β„•) : + binaryRippleSubCleanupTime lhs.bits rhs.bits = max lhs.size rhs.size + 1 := by + simp [binaryRippleSubCleanupTime, Nat.size_eq_bits_len] + +/-- The core bound is twice the larger width plus its two turning steps. -/ +theorem binaryRippleSubCoreTime_natBits_internal (lhs rhs : β„•) : + binaryRippleSubCoreTime lhs.bits rhs.bits = + 2 * max lhs.size rhs.size + 2 := by + simp [binaryRippleSubCoreTime, Nat.size_eq_bits_len] + +/-- The complete subtractor is linear in the sum of the operand widths. -/ +theorem binaryRippleSubTime_le_internal (lhs rhs : β„•) : + binaryRippleSubTime lhs rhs ≀ 3 * (lhs.size + rhs.size) + 10 := by + simp only [binaryRippleSubTime] + have hmax : max lhs.size rhs.size ≀ lhs.size + rhs.size := + max_le (Nat.le_add_right _ _) (Nat.le_add_left _ _) + omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Rewind.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Rewind.lean new file mode 100644 index 0000000000..48ff575bf1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Rewind.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Internal + +/-! +# Linear-time canonical binary subtraction -- operand rewind internals + +The subtraction core already returns its result to cell one. This module +packages the two remaining operand rewinds into one exact framed contract. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Canonical parked tape containing the supplied little-endian binary digits. -/ +def binaryRippleSubCanonicalTape (bits : List Bool) : Tape := + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right + +private theorem binaryRippleSubCanonicalTape_parked (bits : List Bool) : + Parked (binaryRippleSubCanonicalTape bits) := by + refine ⟨by simp [binaryRippleSubCanonicalTape, Tape.move], ?_⟩ + simpa [binaryRippleSubCanonicalTape] using + Tape.init_ofBool_move_right_cells_ne_start bits + +private theorem binaryRippleSubRewindExact_hoareTime {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ + (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (rewindWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + (binaryRippleSubCanonicalTape bits) ∧ + out = outβ‚€) + (headBound + 2) := by + have hrewind := rewindBinaryWorkTM_hoareTime_frame_internal idx bits + headBound inpβ‚€ workβ‚€ outβ‚€ htarget htargetStart htargetHead hinput + hother houtput + apply hrewind.consequence (b' := headBound + 2) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hinp, htargetEq, hotherEq, hout⟩ + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + simpa [binaryRippleSubCanonicalTape] using htargetEq + Β· rw [Function.update_of_ne hi] + exact hotherEq i hi + Β· exact le_rfl + +private theorem binaryRippleSubExactFrame_transition {n : β„•} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + transitionInput inp = inpβ‚€ ∧ + (fun i => transitionTape (work i)) = workβ‚€ ∧ + transitionTape out = outβ‚€ := by + rintro _inp _work _out ⟨rfl, rfl, rfl⟩ + exact ⟨hinput.transitionInput_eq_self, + funext fun i => (hwork i).transitionTape_eq_self, + houtput.transitionTape_eq_self⟩ + +theorem binaryRippleSubRewindTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhsBits rhsBits : List Bool) (lhsBound rhsBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryContent lhsBits) + (hlhsStart : (workβ‚€ lhsIdx).cells 0 = Ξ“.start) + (hlhsHead : 1 ≀ (workβ‚€ lhsIdx).head ∧ + (workβ‚€ lhsIdx).head ≀ lhsBound) + (hrhs : (workβ‚€ rhsIdx).HasBinaryContent rhsBits) + (hrhsStart : (workβ‚€ rhsIdx).cells 0 = Ξ“.start) + (hrhsHead : 1 ≀ (workβ‚€ rhsIdx).head ∧ + (workβ‚€ rhsIdx).head ≀ rhsBound) + (hresult : Parked (workβ‚€ resultIdx)) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (seqTM (rewindWorkTM lhsIdx) (rewindWorkTM rhsIdx)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work lhsIdx = binaryRippleSubCanonicalTape lhsBits ∧ + work rhsIdx = binaryRippleSubCanonicalTape rhsBits ∧ + work resultIdx = workβ‚€ resultIdx ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (lhsBound + rhsBound + 5) := by + have hlhsParked : Parked (workβ‚€ lhsIdx) := + ⟨hlhsHead.1, hlhs.cells_ne_start⟩ + have hrhsParked : Parked (workβ‚€ rhsIdx) := + ⟨hrhsHead.1, hrhs.cells_ne_start⟩ + have hworkβ‚€ : βˆ€ i, Parked (workβ‚€ i) := by + intro i + by_cases hil : i = lhsIdx + Β· subst i + exact hlhsParked + by_cases hir : i = rhsIdx + Β· subst i + exact hrhsParked + by_cases hires : i = resultIdx + Β· subst i + exact hresult + exact hother i hil hir hires + + let lhsTape := binaryRippleSubCanonicalTape lhsBits + let rhsTape := binaryRippleSubCanonicalTape rhsBits + let work₁ := Function.update workβ‚€ lhsIdx lhsTape + let workβ‚‚ := Function.update work₁ rhsIdx rhsTape + + have hwork₁ : βˆ€ i, Parked (work₁ i) := by + intro i + by_cases hi : i = lhsIdx + Β· subst i + simpa [work₁, lhsTape] using + binaryRippleSubCanonicalTape_parked lhsBits + Β· simpa only [work₁, Function.update_of_ne hi] using hworkβ‚€ i + have hrhs₁ : (work₁ rhsIdx).HasBinaryContent rhsBits := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using + hrhs + have hrhsStart₁ : (work₁ rhsIdx).cells 0 = Ξ“.start := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using + hrhsStart + have hrhsHead₁ : 1 ≀ (work₁ rhsIdx).head ∧ + (work₁ rhsIdx).head ≀ rhsBound := by + simpa only [work₁, Function.update_of_ne hdistinct.lhs_rhs.symm] using + hrhsHead + + have hrewindLhs := binaryRippleSubRewindExact_hoareTime lhsIdx lhsBits + lhsBound inpβ‚€ workβ‚€ outβ‚€ hlhs hlhsStart hlhsHead hinput + (fun i _ => hworkβ‚€ i) houtput + have hrewindRhs := binaryRippleSubRewindExact_hoareTime rhsIdx rhsBits + rhsBound inpβ‚€ work₁ outβ‚€ hrhs₁ hrhsStart₁ hrhsHead₁ hinput + (fun i _ => hwork₁ i) houtput + have hrun := seqTM_hoareTime (rewindWorkTM lhsIdx) + (rewindWorkTM rhsIdx) hrewindLhs + (binaryRippleSubExactFrame_transition inpβ‚€ work₁ outβ‚€ hinput + hwork₁ houtput) + hrewindRhs + apply hrun.consequence (b' := lhsBound + rhsBound + 5) + Β· intro _inp _work _out hpre + exact hpre + Β· rintro inp work out ⟨hinp, hwork, hout⟩ + refine ⟨hinp, ?_, ?_, ?_, ?_, hout⟩ + Β· simpa [workβ‚‚, work₁, rhsTape, lhsTape, + hdistinct.lhs_rhs] using congrFun hwork lhsIdx + Β· simpa [workβ‚‚, rhsTape] using congrFun hwork rhsIdx + Β· simpa [workβ‚‚, work₁, hdistinct.rhs_result, + hdistinct.rhs_result.symm, hdistinct.lhs_result, + hdistinct.lhs_result.symm] using congrFun hwork resultIdx + Β· intro i hil hir hires + simpa [workβ‚‚, work₁, hir, hil] using congrFun hwork i + Β· omega + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Scan.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Scan.lean new file mode 100644 index 0000000000..6aec8ffb5f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Scan.lean @@ -0,0 +1,603 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import Mathlib.Algebra.Order.Ring.Nat +public import Mathlib.Tactic.NormNum.Inv +public import Mathlib.Tactic.NormNum.Pow + +/-! +# Linear-time canonical binary subtraction -- forward scan proof + +This file proves the exact framed contract for the forward borrow scan, +including its final turn into backward cleanup. Cleanup itself is proved in a +separate internal layer. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private def binaryRippleSubScanAdvanceWork {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (diff : Bool) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := + fun i => + if i = resultIdx then + (work i).writeAndMove (Ξ“w.ofBool diff) Dir3.right + else if i = lhsIdx then + if (work lhsIdx).read = Ξ“.blank then work i + else (work i).move Dir3.right + else if i = rhsIdx then + if (work rhsIdx).read = Ξ“.blank then work i + else (work i).move Dir3.right + else work i + +private def binaryRippleSubScanTurnWork {n : β„•} (resultIdx : Fin n) + (work : Fin n β†’ Tape) : Fin n β†’ Tape := + Function.update work resultIdx ((work resultIdx).move Dir3.left) + +private theorem binaryRippleSubCoreTM_step_active {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (borrow : Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hactive : Β¬((work lhsIdx).read = Ξ“.blank ∧ + (work rhsIdx).read = Ξ“.blank)) + (hinput : inp.read β‰  Ξ“.start) + (hlhs : (work lhsIdx).read β‰  Ξ“.start) + (hrhs : (work rhsIdx).read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let lhsBit := decide ((work lhsIdx).read = Ξ“.one) + let rhsBit := decide ((work rhsIdx).read = Ξ“.one) + let diff := BinaryRippleSub.diffBit borrow lhsBit rhsBit + let nextBorrow := BinaryRippleSub.borrowBit borrow lhsBit rhsBit + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step + { state := .scan borrow, input := inp, work := work, output := out } = + some + { state := .scan nextBorrow + input := inp + work := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx diff work + output := out } := by + dsimp only + rw [TM.step, ite_eq_right (by simp [binaryRippleSubCoreTM])] + simp only [binaryRippleSubCoreTM, hactive, ↓reduceIte] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hresultIdx : i = resultIdx + Β· subst i + simp [binaryRippleSubScanAdvanceWork] + Β· by_cases hlhsIdx : i = lhsIdx + Β· subst i + simp only [binaryRippleSubScanAdvanceWork, hresultIdx, ite_false, ite_eq_left] + by_cases hblank : (work lhsIdx).read = Ξ“.blank + Β· rw [ite_eq_left hblank, ite_eq_left hblank] + rw [writeAndMove_readBack _ hlhs Dir3.stay] + rfl + Β· rw [ite_eq_right hblank, ite_eq_right hblank] + exact writeAndMove_readBack (work lhsIdx) hlhs Dir3.right + Β· by_cases hrhsIdx : i = rhsIdx + Β· subst i + simp only [binaryRippleSubScanAdvanceWork, hresultIdx, ite_false, + hlhsIdx, ite_eq_left] + by_cases hblank : (work rhsIdx).read = Ξ“.blank + Β· rw [ite_eq_left hblank, ite_eq_left hblank] + rw [writeAndMove_readBack _ hrhs Dir3.stay] + rfl + Β· rw [ite_eq_right hblank, ite_eq_right hblank] + exact writeAndMove_readBack (work rhsIdx) hrhs Dir3.right + Β· simp only [binaryRippleSubScanAdvanceWork, hresultIdx, ite_false, + hlhsIdx, hrhsIdx] + exact transitionTape_eq_self (hother i hlhsIdx hrhsIdx hresultIdx) + +private theorem binaryRippleSubCoreTM_step_terminal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (borrow : Bool) (emitted : List Bool) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hlhs : (work lhsIdx).read = Ξ“.blank) + (hrhs : (work rhsIdx).read = Ξ“.blank) + (hinput : inp.read β‰  Ξ“.start) + (hresult : (work resultIdx).HasBinaryPrefix emitted) + (hresultStart : (work resultIdx).cells 0 = Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work i).read β‰  Ξ“.start) + (houtput : out.read β‰  Ξ“.start) : + let finalWork := binaryRippleSubScanTurnWork resultIdx work + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step + { state := .scan borrow, input := inp, work := work, output := out } = + some + { state := if borrow then .erase else .trim false + input := inp + work := finalWork + output := out } ∧ + (finalWork lhsIdx).cells = (work lhsIdx).cells ∧ + (finalWork lhsIdx).head = (work lhsIdx).head ∧ + (finalWork rhsIdx).cells = (work rhsIdx).cells ∧ + (finalWork rhsIdx).head = (work rhsIdx).head ∧ + (finalWork resultIdx).HasBinaryContent emitted ∧ + (finalWork resultIdx).head = emitted.length ∧ + (finalWork resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + finalWork i = work i) := by + dsimp only + let finalWork := binaryRippleSubScanTurnWork resultIdx work + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [TM.step, ite_eq_right (by simp [binaryRippleSubCoreTM])] + simp only [binaryRippleSubCoreTM, hlhs, hrhs, and_self, ite_eq_left] + refine congrArg some (Cfg.ext rfl (transitionInput_eq_self hinput) ?_ + (transitionTape_eq_self houtput)) + funext i + by_cases hires : i = resultIdx + Β· subst i + simp only [binaryRippleSubScanTurnWork, Function.update_self] + rw [show moveLeftDir (work resultIdx).read = Dir3.left by + rw [hresult.read_blank] + rfl] + exact writeAndMove_readBack (work resultIdx) (by + rw [hresult.read_blank] + decide) Dir3.left + Β· by_cases hil : i = lhsIdx + Β· subst i + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, binaryRippleSubScanTurnWork, + hdistinct.lhs_result] using + transitionTape_eq_self (by rw [hlhs]; decide) + Β· by_cases hir : i = rhsIdx + Β· subst i + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, binaryRippleSubScanTurnWork, + hdistinct.rhs_result] using + transitionTape_eq_self (by rw [hrhs]; decide) + Β· simpa [binaryRippleSubScanTurnWork, hires] using! + transitionTape_eq_self (hother i hil hir hires) + Β· simp [binaryRippleSubScanTurnWork, hdistinct.lhs_result] + Β· simp [binaryRippleSubScanTurnWork, hdistinct.lhs_result] + Β· simp [binaryRippleSubScanTurnWork, hdistinct.rhs_result] + Β· simp [binaryRippleSubScanTurnWork, hdistinct.rhs_result] + Β· simpa [finalWork, binaryRippleSubScanTurnWork, Tape.move_cells] using! + hresult.2 + Β· simp [binaryRippleSubScanTurnWork, Tape.move, hresult.1] + Β· simpa [finalWork, binaryRippleSubScanTurnWork, Tape.move_cells] using + hresultStart + Β· intro i _ _ hires + simp [binaryRippleSubScanTurnWork, hires] + +/-- Writing one ripple-sub output bit extends its prefix without changing the start marker. -/ +private theorem binaryRippleSubScanAdvanceWork_result {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (diff : Bool) (emitted : List Bool) + (workβ‚€ : Fin n β†’ Tape) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) : + let work₁ := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx diff workβ‚€ + (work₁ resultIdx).HasBinaryPrefix (emitted ++ [diff]) ∧ + (work₁ resultIdx).cells 0 = Ξ“.start := by + dsimp only + let work₁ := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx diff workβ‚€ + have hresult₁ : + (work₁ resultIdx).HasBinaryPrefix (emitted ++ [diff]) := by + rw [show work₁ resultIdx = + (workβ‚€ resultIdx).writeAndMove (Ξ“w.ofBool diff).toΞ“ + Dir3.right by + simp [work₁, binaryRippleSubScanAdvanceWork]] + rw [Ξ“w.ofBool_toΞ“] + exact Tape.hasBinaryPrefix_write_bit diff hresult + have hresultStart₁ : (work₁ resultIdx).cells 0 = Ξ“.start := by + rw [show work₁ resultIdx = + (workβ‚€ resultIdx).writeAndMove (Ξ“w.ofBool diff).toΞ“ + Dir3.right by + simp [work₁, binaryRippleSubScanAdvanceWork]] + rw [Ξ“w.ofBool_toΞ“] + exact Tape.hasBinaryPrefix_write_bit_cell0 diff hresult hresultStart + exact ⟨hresult₁, hresultStartβ‚βŸ© + +/-- With the left input exhausted, ripple subtraction consumes the right suffix and borrow. -/ +private theorem binaryRippleSubCoreTM_suffix_empty_left {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (borrow : Bool) (rhs emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix ([] : List Bool)) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleSubScanTime ([] : List Bool) rhs) + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } c' ∧ + c'.state = (if (BinaryRippleSub.scan borrow ([] : List Bool) rhs).borrow then + .erase else .trim false) ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = (workβ‚€ lhsIdx).head + ([] : List Bool).length ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = (workβ‚€ rhsIdx).head + rhs.length ∧ + (c'.work resultIdx).HasBinaryContent + (emitted ++ (BinaryRippleSub.scan borrow ([] : List Bool) rhs).bits) ∧ + (c'.work resultIdx).head = + (emitted ++ (BinaryRippleSub.scan borrow ([] : List Bool) rhs).bits).length ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + induction rhs generalizing borrow emitted inpβ‚€ workβ‚€ outβ‚€ with + | nil => + have hterminal := binaryRippleSubCoreTM_step_terminal + lhsIdx rhsIdx resultIdx hdistinct borrow emitted inpβ‚€ workβ‚€ outβ‚€ + hlhs.read_nil hrhs.read_nil hinput hresult hresultStart hother houtput + let finalWork := binaryRippleSubScanTurnWork resultIdx workβ‚€ + let c' : Cfg n BinaryRippleSubPhase := + { state := if borrow then .erase else .trim false + input := inpβ‚€ + work := finalWork + output := outβ‚€ } + rcases hterminal with ⟨hstep, hfinalLhs, hfinalLhsHead, hfinalRhs, + hfinalRhsHead, hfinalResult, hfinalResultHead, hfinalResultStart, + hfinalOther⟩ + refine ⟨c', ?_, by + cases borrow <;> simp [c', BinaryRippleSub.scan] <;> rfl, rfl, + hfinalLhs, ?_, hfinalRhs, ?_, ?_, ?_, + hfinalResultStart, hfinalOther, rfl⟩ + Β· have hreach : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn 1 + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } c' := + .step hstep .zero + simpa [binaryRippleSubScanTime] using hreach + Β· simpa using hfinalLhsHead + Β· simpa using hfinalRhsHead + Β· simpa [BinaryRippleSub.scan] using hfinalResult + Β· simpa [BinaryRippleSub.scan] using hfinalResultHead + | cons rhsBit rhsTail ih => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = false := by + rw [hlhs.read_nil] + decide + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = rhsBit := by + rw [hrhs.read_cons] + cases rhsBit <;> rfl + let diff := BinaryRippleSub.diffBit borrow false rhsBit + let nextBorrow := BinaryRippleSub.borrowBit borrow false rhsBit + let work₁ := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx + diff workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hrhs.read_cons] at hblank + cases rhsBit <;> simp [Ξ“.ofBool] at hblank + have hrhsNotBlank : (workβ‚€ rhsIdx).read β‰  Ξ“.blank := by + rw [hrhs.read_cons] + cases rhsBit <;> decide + have hstep : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextBorrow + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, diff, nextBorrow, work₁] using + binaryRippleSubCoreTM_step_active lhsIdx rhsIdx resultIdx borrow + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix [] := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hlhs + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix rhsTail := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank] using hrhs.move_right_cons + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleSubScanAdvanceWork_result lhsIdx rhsIdx resultIdx + diff emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + obtain ⟨c', hreach, hstate, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultHead, hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih nextBorrow + (emitted ++ [diff]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ hresult₁ + hresultStart₁ hinput hother₁ houtput + refine ⟨c', ?_, ?_, hfinalInput, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleSubScanTime] using + TM.reachesIn.step hstep hreach + Β· simpa [BinaryRippleSub.scan, nextBorrow] using hstate + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hfinalLhs + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhs.read_nil] using hfinalLhsHead + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank, Tape.move_cells] using hfinalRhs + Β· rw [hfinalRhsHead] + simp only [work₁, binaryRippleSubScanAdvanceWork, + ite_eq_right hdistinct.rhs_result, + ite_eq_right (Ne.symm hdistinct.lhs_rhs), ite_eq_left, + ite_eq_right hrhsNotBlank, Tape.move, List.length_cons] + omega + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResult + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResultHead + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] + +private theorem binaryRippleSubCoreTM_suffix_reachesIn {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (borrow : Bool) (lhs rhs emitted : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinarySuffix lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinarySuffix rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix emitted) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleSubScanTime lhs rhs) + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, output := outβ‚€ } c' ∧ + c'.state = (if (BinaryRippleSub.scan borrow lhs rhs).borrow then + .erase else .trim false) ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = (workβ‚€ lhsIdx).head + lhs.length ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = (workβ‚€ rhsIdx).head + rhs.length ∧ + (c'.work resultIdx).HasBinaryContent + (emitted ++ (BinaryRippleSub.scan borrow lhs rhs).bits) ∧ + (c'.work resultIdx).head = + (emitted ++ (BinaryRippleSub.scan borrow lhs rhs).bits).length ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + induction hlength : lhs.length + rhs.length using Nat.strong_induction_on + generalizing lhs rhs borrow emitted inpβ‚€ workβ‚€ outβ‚€ with + | h total ih => + cases lhs with + | nil => + exact binaryRippleSubCoreTM_suffix_empty_left lhsIdx rhsIdx resultIdx + hdistinct borrow rhs emitted inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult + hresultStart hinput hother houtput + | cons lhsBit lhsTail => + cases rhs with + | nil => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = lhsBit := by + rw [hlhs.read_cons] + cases lhsBit <;> rfl + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = false := by + rw [hrhs.read_nil] + decide + let diff := BinaryRippleSub.diffBit borrow lhsBit false + let nextBorrow := BinaryRippleSub.borrowBit borrow lhsBit false + let work₁ := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx + diff workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hlhs.read_cons] at hblank + cases lhsBit <;> simp [Ξ“.ofBool] at hblank + have hlhsNotBlank : (workβ‚€ lhsIdx).read β‰  Ξ“.blank := by + rw [hlhs.read_cons] + cases lhsBit <;> decide + have hstep : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextBorrow + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, diff, nextBorrow, work₁] using + binaryRippleSubCoreTM_step_active lhsIdx rhsIdx resultIdx borrow + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix lhsTail := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank] using hlhs.move_right_cons + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix [] := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hrhs + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleSubScanAdvanceWork_result lhsIdx rhsIdx resultIdx + diff emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + have htailLength : lhsTail.length < total := by + simp only [List.length_nil, Nat.add_zero, List.length_cons] at hlength + omega + obtain ⟨c', hreach, hstate, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultHead, hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih lhsTail.length htailLength nextBorrow lhsTail [] + (emitted ++ [diff]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ hresult₁ + hresultStart₁ hinput hother₁ houtput (by simp) + refine ⟨c', ?_, ?_, hfinalInput, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleSubScanTime] using + TM.reachesIn.step hstep hreach + Β· simpa [BinaryRippleSub.scan, nextBorrow] using hstate + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank, Tape.move_cells] using + hfinalLhs + Β· rw [hfinalLhsHead] + simp only [work₁, binaryRippleSubScanAdvanceWork, + ite_eq_right hdistinct.lhs_result, ite_eq_left, ite_eq_right hlhsNotBlank, + Tape.move, List.length_cons] + omega + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hfinalRhs + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhs.read_nil] using hfinalRhsHead + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResult + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResultHead + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] + | cons rhsBit rhsTail => + have hlhsBit : decide ((workβ‚€ lhsIdx).read = Ξ“.one) = lhsBit := by + rw [hlhs.read_cons] + cases lhsBit <;> rfl + have hrhsBit : decide ((workβ‚€ rhsIdx).read = Ξ“.one) = rhsBit := by + rw [hrhs.read_cons] + cases rhsBit <;> rfl + let diff := BinaryRippleSub.diffBit borrow lhsBit rhsBit + let nextBorrow := BinaryRippleSub.borrowBit borrow lhsBit rhsBit + let work₁ := binaryRippleSubScanAdvanceWork lhsIdx rhsIdx resultIdx + diff workβ‚€ + have hactive : Β¬((workβ‚€ lhsIdx).read = Ξ“.blank ∧ + (workβ‚€ rhsIdx).read = Ξ“.blank) := by + intro hblank + rw [hlhs.read_cons] at hblank + cases lhsBit <;> simp [Ξ“.ofBool] at hblank + have hlhsNotBlank : (workβ‚€ lhsIdx).read β‰  Ξ“.blank := by + rw [hlhs.read_cons] + cases lhsBit <;> decide + have hrhsNotBlank : (workβ‚€ rhsIdx).read β‰  Ξ“.blank := by + rw [hrhs.read_cons] + cases rhsBit <;> decide + have hstep : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).step + { state := .scan borrow, input := inpβ‚€, work := workβ‚€, + output := outβ‚€ } = + some + { state := .scan nextBorrow + input := inpβ‚€ + work := work₁ + output := outβ‚€ } := by + simpa [hlhsBit, hrhsBit, diff, nextBorrow, work₁] using + binaryRippleSubCoreTM_step_active lhsIdx rhsIdx resultIdx borrow + inpβ‚€ workβ‚€ outβ‚€ hactive hinput hlhs.read_ne_start + hrhs.read_ne_start hother houtput + have hlhs₁ : (work₁ lhsIdx).HasBinarySuffix lhsTail := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank] using hlhs.move_right_cons + have hrhs₁ : (work₁ rhsIdx).HasBinarySuffix rhsTail := by + simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank] using hrhs.move_right_cons + obtain ⟨hresult₁, hresultStartβ‚βŸ© := + binaryRippleSubScanAdvanceWork_result lhsIdx rhsIdx resultIdx + diff emitted workβ‚€ hresult hresultStart + have hother₁ : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (work₁ i).read β‰  Ξ“.start := by + intro i hil hir hires + simpa [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] using + hother i hil hir hires + have htailLength : lhsTail.length + rhsTail.length < total := by + simp only [List.length_cons] at hlength + omega + obtain ⟨c', hreach, hstate, hfinalInput, hfinalLhs, + hfinalLhsHead, hfinalRhs, hfinalRhsHead, hfinalResult, + hfinalResultHead, hfinalResultStart, hfinalOther, hfinalOutput⟩ := + ih (lhsTail.length + rhsTail.length) htailLength nextBorrow lhsTail + rhsTail (emitted ++ [diff]) inpβ‚€ work₁ outβ‚€ hlhs₁ hrhs₁ + hresult₁ hresultStart₁ hinput hother₁ houtput rfl + refine ⟨c', ?_, ?_, hfinalInput, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalResultStart, ?_, hfinalOutput⟩ + Β· simpa [binaryRippleSubScanTime, Nat.succ_max_succ] using + TM.reachesIn.step hstep hreach + Β· simpa [BinaryRippleSub.scan, nextBorrow] using hstate + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.lhs_result, hlhsNotBlank, Tape.move_cells] using + hfinalLhs + Β· rw [hfinalLhsHead] + simp only [work₁, binaryRippleSubScanAdvanceWork, + ite_eq_right hdistinct.lhs_result, ite_eq_left, ite_eq_right hlhsNotBlank, + Tape.move, List.length_cons] + omega + Β· simpa [work₁, binaryRippleSubScanAdvanceWork, + hdistinct.rhs_result, Ne.symm hdistinct.lhs_rhs, + hrhsNotBlank, Tape.move_cells] using hfinalRhs + Β· rw [hfinalRhsHead] + simp only [work₁, binaryRippleSubScanAdvanceWork, + ite_eq_right hdistinct.rhs_result, + ite_eq_right (Ne.symm hdistinct.lhs_rhs), ite_eq_left, + ite_eq_right hrhsNotBlank, Tape.move, List.length_cons] + omega + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResult + Β· simpa [BinaryRippleSub.scan, diff, nextBorrow, + List.append_assoc] using hfinalResultHead + Β· intro i hil hir hires + rw [hfinalOther i hil hir hires] + simp [work₁, binaryRippleSubScanAdvanceWork, hil, hir, hires] + +theorem binaryRippleSubCoreTM_scan_reachesIn_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryString lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryString rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryPrefix []) + (hresultStart : (workβ‚€ resultIdx).cells 0 = Ξ“.start) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + let raw := BinaryRippleSub.scan false lhs rhs + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleSubScanTime lhs rhs) + { state := (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + c'.state = (if raw.borrow then .erase else .trim false) ∧ + c'.input = inpβ‚€ ∧ + (c'.work lhsIdx).cells = (workβ‚€ lhsIdx).cells ∧ + (c'.work lhsIdx).head = lhs.length + 1 ∧ + (c'.work rhsIdx).cells = (workβ‚€ rhsIdx).cells ∧ + (c'.work rhsIdx).head = rhs.length + 1 ∧ + (c'.work resultIdx).HasBinaryContent raw.bits ∧ + (c'.work resultIdx).head = raw.bits.length ∧ + (c'.work resultIdx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + dsimp only + obtain ⟨c', hreach, hstate, hfinalInput, hfinalLhs, hfinalLhsHead, + hfinalRhs, hfinalRhsHead, hfinalResult, hfinalResultHead, + hfinalResultStart, hfinalOther, hfinalOutput⟩ := + binaryRippleSubCoreTM_suffix_reachesIn lhsIdx rhsIdx resultIdx hdistinct + false lhs rhs [] inpβ‚€ workβ‚€ outβ‚€ hlhs.hasBinarySuffix + hrhs.hasBinarySuffix hresult hresultStart hinput hother houtput + refine ⟨c', hreach, hstate, hfinalInput, hfinalLhs, ?_, hfinalRhs, ?_, ?_, + ?_, hfinalResultStart, hfinalOther, hfinalOutput⟩ + Β· simpa [hlhs.1, Nat.add_comm] using hfinalLhsHead + Β· simpa [hrhs.1, Nat.add_comm] using hfinalRhsHead + Β· simpa using hfinalResult + Β· simpa using hfinalResultHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Sem.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Sem.lean new file mode 100644 index 0000000000..6e79a00721 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryRippleSub/Internal/Sem.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Backward +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Rewind +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryRippleSub.Internal.Scan +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc + +/-! +# Linear-time canonical binary subtraction -- composed semantics + +This file composes the exact forward borrow scan with its backward +canonicalization pass, then restores both preserved operands through the +checked rewind tail. The complete machine computes natural-number monus, +preserves the external tape frame literally, and carries explicit time and +all-prefix auxiliary-space bounds. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Postcondition at the end of the core binary ripple-subtraction phase. -/ +def binaryRippleSubCorePost {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryContent lhs.bits ∧ + (work lhsIdx).cells 0 = Ξ“.start ∧ + (work lhsIdx).head = lhs.size + 1 ∧ + (work rhsIdx).HasBinaryContent rhs.bits ∧ + (work rhsIdx).cells 0 = Ξ“.start ∧ + (work rhsIdx).head = rhs.size + 1 ∧ + (work resultIdx).HasBinaryNat (lhs - rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- Postcondition for completed binary ripple subtraction. -/ +def binaryRippleSubPost {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work lhsIdx).HasBinaryNat lhs ∧ + (work rhsIdx).HasBinaryNat rhs ∧ + (work resultIdx).HasBinaryNat (lhs - rhs) ∧ + (βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- The direct core executes its forward and backward passes in exactly twice +the larger operand width plus the two turn/bounce transitions. -/ +theorem binaryRippleSubCoreTM_reachesIn_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn + (binaryRippleSubCoreTime lhs.bits rhs.bits) + { state := (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).halted c' ∧ + binaryRippleSubCorePost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€ + c'.input c'.work c'.output := by + let raw := BinaryRippleSub.scan false lhs.bits rhs.bits + have hresultPrefix : (workβ‚€ resultIdx).HasBinaryPrefix [] := by + simpa [Tape.HasBinaryString, Tape.HasBinaryPrefix] using hresult.2 + obtain ⟨c₁, hscanReach, hscanState, hscanInput, hscanLhsCells, + hscanLhsHead, hscanRhsCells, hscanRhsHead, hscanResult, + hscanResultHead, hscanResultStart, hscanOther, hscanOutput⟩ := + binaryRippleSubCoreTM_scan_reachesIn_frame_internal + lhsIdx rhsIdx resultIdx hdistinct lhs.bits rhs.bits inpβ‚€ workβ‚€ outβ‚€ + hlhs.2 hrhs.2 hresultPrefix hresult.1 hinput hother houtput + have hscanLhsContent : (c₁.work lhsIdx).HasBinaryContent lhs.bits := by + simpa only [Tape.HasBinaryContent, hscanLhsCells] using + hlhs.2.hasBinaryContent + have hscanRhsContent : (c₁.work rhsIdx).HasBinaryContent rhs.bits := by + simpa only [Tape.HasBinaryContent, hscanRhsCells] using + hrhs.2.hasBinaryContent + have hcleanupOther : βˆ€ i, i β‰  resultIdx β†’ + (c₁.work i).read β‰  Ξ“.start := by + intro i hires + by_cases hil : i = lhsIdx + Β· subst i + exact hscanLhsContent.cells_ne_start _ (by rw [hscanLhsHead]; omega) + by_cases hir : i = rhsIdx + Β· subst i + exact hscanRhsContent.cells_ne_start _ (by rw [hscanRhsHead]; omega) + Β· rw [hscanOther i hil hir hires] + exact hother i hil hir hires + obtain ⟨cβ‚‚, hcleanupReach, hcleanupHalt, hcleanupInput, + hcleanupOtherEq, hcleanupResult, hcleanupResultStart, hcleanupOutput⟩ := + binaryRippleSubCoreTM_cleanup_run_internal lhsIdx rhsIdx resultIdx raw.bits + raw.borrow c₁.input c₁.work c₁.output + (hscanInput.symm β–Έ hinput) hcleanupOther + (hscanOutput.symm β–Έ houtput) hscanResult hscanResultStart hscanResultHead + have hcleanupStart : + ({ state := if raw.borrow then .erase else .trim false + input := c₁.input + work := c₁.work + output := c₁.output } : + Cfg n (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).Q) = c₁ := by + exact Cfg.ext hscanState.symm rfl rfl rfl + rw [hcleanupStart] at hcleanupReach + have hrun := (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).reachesIn_trans + hscanReach hcleanupReach + have htime : binaryRippleSubScanTime lhs.bits rhs.bits + + (raw.bits.length + 1) = binaryRippleSubCoreTime lhs.bits rhs.bits := by + have hrawLength : raw.bits.length = max lhs.bits.length rhs.bits.length := by + simpa [raw] using BinaryRippleSub.scan_bits_length_internal + false lhs.bits rhs.bits + rw [hrawLength] + simp only [binaryRippleSubScanTime, binaryRippleSubCoreTime] + omega + have hfinalLhs : cβ‚‚.work lhsIdx = c₁.work lhsIdx := + hcleanupOtherEq lhsIdx hdistinct.lhs_result + have hfinalRhs : cβ‚‚.work rhsIdx = c₁.work rhsIdx := + hcleanupOtherEq rhsIdx hdistinct.rhs_result + have hfinalResult : (cβ‚‚.work resultIdx).HasBinaryNat (lhs - rhs) := by + refine ⟨hcleanupResultStart, ?_⟩ + have hresultBits : + (if raw.borrow then [] else BinaryRippleSub.trimHighZeros raw.bits) = + (lhs - rhs).bits := by + simpa only [BinaryRippleSub.subtract, raw] using + BinaryRippleSub.subtract_natBits_internal lhs rhs + rw [← hresultBits] + exact hcleanupResult + refine ⟨cβ‚‚, ?_, hcleanupHalt, ?_⟩ + Β· simpa [htime] using hrun + Β· refine ⟨hcleanupInput.trans hscanInput, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalResult, ?_, hcleanupOutput.trans hscanOutput⟩ + Β· rw [hfinalLhs] + exact hscanLhsContent + Β· rw [hfinalLhs, hscanLhsCells] + exact hlhs.1 + Β· rw [hfinalLhs, hscanLhsHead, Nat.size_eq_bits_len] + Β· rw [hfinalRhs] + exact hscanRhsContent + Β· rw [hfinalRhs, hscanRhsCells] + exact hrhs.1 + Β· rw [hfinalRhs, hscanRhsHead, Nat.size_eq_bits_len] + Β· intro i hil hir hires + exact (hcleanupOtherEq i hires).trans (hscanOther i hil hir hires) + +/-- Hoare-time form of the exact direct-core execution. -/ +theorem binaryRippleSubCoreTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + (workβ‚€ i).read β‰  Ξ“.start) + (houtput : outβ‚€.read β‰  Ξ“.start) : + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleSubCorePost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleSubCoreTime lhs.bits rhs.bits) := by + rintro inp work out ⟨hinputEq, hworkEq, houtputEq⟩ + subst inp + subst work + subst out + obtain ⟨c', hreach, hhalt, hpost⟩ := + binaryRippleSubCoreTM_reachesIn_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother + houtput + exact ⟨c', binaryRippleSubCoreTime lhs.bits rhs.bits, le_rfl, + hreach, hhalt, hpost⟩ + +private theorem binaryRippleSubRewindTail_hoareTime_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (seqTM (rewindWorkTM lhsIdx) (rewindWorkTM rhsIdx)).HoareTime + (binaryRippleSubCorePost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleSubPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + ((lhs.size + 1) + (rhs.size + 1) + 5) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hlhs, hlhsStart, hlhsHead, hrhs, hrhsStart, + hrhsHead, hresult, hframe, hout⟩ + have hresultParked : Parked (work resultIdx) := + ⟨by rw [hresult.2.1], hresult.2.hasBinaryContent.cells_ne_start⟩ + have hrewind := binaryRippleSubRewindTM_hoareTime_frame_internal + lhsIdx rhsIdx resultIdx hdistinct lhs.bits rhs.bits + (lhs.size + 1) (rhs.size + 1) inp work out hlhs hlhsStart + ⟨by rw [hlhsHead]; omega, by rw [hlhsHead]⟩ + hrhs hrhsStart ⟨by rw [hrhsHead]; omega, by rw [hrhsHead]⟩ + hresultParked (hinp.symm β–Έ hinput) + (fun i hil hir hires => by + rw [hframe i hil hir hires] + exact hother i hil hir hires) + (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalLhs, + hfinalRhs, hfinalResult, hfinalOther, hfinalOutput⟩ := + hrewind inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, htime, hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, hfinalOutput.trans hout⟩ + Β· rw [hfinalLhs] + exact Tape.init_move_right_hasBinaryNat lhs + Β· rw [hfinalRhs] + exact Tape.init_move_right_hasBinaryNat rhs + Β· rw [hfinalResult] + exact hresult + Β· intro i hil hir hires + exact (hfinalOther i hil hir hires).trans (hframe i hil hir hires) + +/-- The complete direct subtraction machine restores both operands and returns +canonical natural-number monus within the advertised width-linear bound. -/ +theorem binaryRippleSubTM_hoareTime_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleSubPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleSubTime lhs rhs) := by + have hcore := binaryRippleSubCoreTM_hoareTime_frame_internal + lhsIdx rhsIdx resultIdx hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + hresult hinput.read_ne_start + (fun i hil hir hires => (hother i hil hir hires).read_ne_start) + houtput.read_ne_start + have htail := binaryRippleSubRewindTail_hoareTime_internal + lhsIdx rhsIdx resultIdx hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hinput hother houtput + have htransition : βˆ€ inp work out, + binaryRippleSubCorePost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€ + inp work out β†’ + binaryRippleSubCorePost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, hlhsContent, hlhsStart, hlhsHead, + hrhsContent, hrhsStart, hrhsHead, hresultNat, hframe, hout⟩ + have hworkRead : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hil : i = lhsIdx + Β· subst i + exact hlhsContent.cells_ne_start _ (by rw [hlhsHead]; omega) + by_cases hir : i = rhsIdx + Β· subst i + exact hrhsContent.cells_ne_start _ (by rw [hrhsHead]; omega) + by_cases hires : i = resultIdx + Β· subst i + exact hresultNat.2.hasBinaryContent.cells_ne_start _ (by + rw [hresultNat.2.1]) + Β· rw [hframe i hil hir hires] + exact (hother i hil hir hires).read_ne_start + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hworkRead + (hout.symm β–Έ houtput.read_ne_start) + rw [hinputTransition, hworkTransition, houtputTransition] + exact ⟨hinp, hlhsContent, hlhsStart, hlhsHead, hrhsContent, hrhsStart, + hrhsHead, hresultNat, hframe, hout⟩ + have hrun := seqTM_hoareTime + (binaryRippleSubCoreTM lhsIdx rhsIdx resultIdx) + (seqTM (rewindWorkTM lhsIdx) (rewindWorkTM rhsIdx)) + hcore htransition htail + unfold binaryRippleSubTM + apply hrun.mono_bound + rw [binaryRippleSubCoreTime_natBits_internal] + simp only [binaryRippleSubTime] + omega + +/-- Time-and-space contract for complete direct subtraction. The generic +all-prefix envelope charges at most one additional cell per possible step. -/ +theorem binaryRippleSubTM_hoareTimeSpace_frame_internal {n : β„•} + (lhsIdx rhsIdx resultIdx : Fin n) + (hdistinct : BinaryRippleSubDistinct lhsIdx rhsIdx resultIdx) + (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ lhsIdx).HasBinaryNat lhs) + (hrhs : (workβ‚€ rhsIdx).HasBinaryNat rhs) + (hresult : (workβ‚€ resultIdx).HasBinaryNat 0) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  lhsIdx β†’ i β‰  rhsIdx β†’ i β‰  resultIdx β†’ + Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryRippleSubTM lhsIdx rhsIdx resultIdx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryRippleSubTM lhsIdx rhsIdx resultIdx).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryRippleSubTM lhsIdx rhsIdx resultIdx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryRippleSubPost lhsIdx rhsIdx resultIdx lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryRippleSubTime lhs rhs) inputLength + (initialSpace + binaryRippleSubTime lhs rhs) := by + apply (binaryRippleSubTM_hoareTime_frame_internal lhsIdx rhsIdx resultIdx + hdistinct lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hresult hinput hother + houtput).toHoareTimeSpace + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact hinitial + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul.lean new file mode 100644 index 0000000000..da3cd1be56 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Sem + +/-! +# Width-driven binary shift-and-add multiplication + +This module exposes a concrete six-work-tape multiplier. It preserves two +canonical little-endian operands, writes their product to an initially-zero +accumulator, restores every owned head to cell one, clears three scratch tapes, +and preserves the complete external tape frame. Its running time is quadratic +in the combined operand width. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryShiftMul + +/-- The generalized shift-and-add fold has its closed arithmetic form. -/ +theorem fold_eq (bits : List Bool) (acc shift : β„•) : + fold bits acc shift = + (acc + shift * Nat.fromBitsLE bits, shift * 2 ^ bits.length) := + fold_eq_internal bits acc shift + +/-- Folding all canonical multiplier bits computes multiplication. -/ +theorem fold_natBits (lhs rhs : β„•) : + fold rhs.bits 0 lhs = (lhs * rhs, lhs * 2 ^ rhs.size) := + fold_natBits_internal lhs rhs + +/-- Binary multiplication produces at most the sum of the operand widths. -/ +theorem size_mul_le_add (lhs rhs : β„•) : + (lhs * rhs).size ≀ lhs.size + rhs.size := + size_mul_le_add_internal lhs rhs + +end BinaryShiftMul + +namespace TM + +/-- The audited multiplier budget is quadratic in combined input width. -/ +theorem binaryShiftMulTime_eq (lhs rhs : β„•) : + binaryShiftMulTime lhs rhs = + 33 * binaryShiftMulWidth lhs rhs ^ 2 + + 170 * binaryShiftMulWidth lhs rhs + 58 := + rfl + +/-- Framed time contract for canonical binary multiplication. Both operands +are restored, the accumulator becomes their product, every scratch tape is +reset to zero, and all unrelated tapes are preserved exactly. -/ +theorem binaryShiftMulTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryNat rhs ∧ + (work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (work abi.shift).HasBinaryNat 0 ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryShiftMulTime lhs rhs) := + binaryShiftMulTM_hoareTime_frame_internal abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hlhs hrhs hacc hshift htmp hdbl hinput hwork houtput + +/-- Reachability form of the framed multiplication theorem. -/ +theorem binaryShiftMulTM_reachesIn_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆƒ c' time, + time ≀ binaryShiftMulTime lhs rhs ∧ + (binaryShiftMulTM abi).reachesIn time + { state := (binaryShiftMulTM abi).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binaryShiftMulTM abi).halted c' ∧ + c'.input = inpβ‚€ ∧ + (c'.work abi.lhs).HasBinaryNat lhs ∧ + (c'.work abi.rhs).HasBinaryNat rhs ∧ + (c'.work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (c'.work abi.shift).HasBinaryNat 0 ∧ + (c'.work abi.tmp).HasBinaryNat 0 ∧ + (c'.work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + c'.work i = workβ‚€ i) ∧ + c'.output = outβ‚€ := by + exact binaryShiftMulTM_hoareTime_frame abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hlhs hrhs hacc hshift htmp hdbl hinput hwork houtput + inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + +/-- All-prefix auxiliary-space contract obtained from the concrete quadratic +time envelope. -/ +theorem binaryShiftMulTM_hoareTimeSpace_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryShiftMulTM abi).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryShiftMulTM abi).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryShiftMulTM abi).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryNat rhs ∧ + (work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (work abi.shift).HasBinaryNat 0 ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€) + (binaryShiftMulTime lhs rhs) inputLength + (initialSpace + binaryShiftMulTime lhs rhs) := + binaryShiftMulTM_hoareTimeSpace_frame_internal abi lhs rhs inputLength + initialSpace inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hacc hshift htmp hdbl hinput + hwork houtput hinitial + +/-- Canonical shift-and-add multiplication never moves the public output head +left. -/ +theorem binaryShiftMulTM_isTransducer {n : β„•} + (abi : BinaryShiftMulABI n) : + (binaryShiftMulTM abi).IsTransducer := + binaryShiftMulTM_isTransducer_internal abi + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Defs.lean new file mode 100644 index 0000000000..475d7592af --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Defs.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs +public import LeanPool.BeyondBethe.Complexitylib.Mathlib.NatBits + +/-! +# Width-driven binary shift-and-add multiplication -- definitions + +This module defines a six-work-tape multiplication ABI and a concrete +least-significant-bit-first shift-and-add machine. The multiplicands are +preserved, the accumulator receives their product, and three scratch tapes are +returned to canonical zero. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryShiftMul + +/-- One pure shift-and-add iteration. The first component is the partial +accumulator and the second is the current shifted multiplicand. -/ +def step (bit : Bool) (acc shift : β„•) : β„• Γ— β„• := + (if bit then acc + shift else acc, 2 * shift) + +/-- Fold little-endian multiplier bits through generalized initial accumulator +and shift values. -/ +def fold : List Bool β†’ β„• β†’ β„• β†’ β„• Γ— β„• + | [], acc, shift => (acc, shift) + | bit :: bits, acc, shift => + let next := step bit acc shift + fold bits next.1 next.2 + +/-- Accumulator value after the first `i` little-endian multiplier bits. -/ +def partialAcc (lhs rhs i : β„•) : β„• := + lhs * Nat.fromBitsLE (rhs.bits.take i) + +/-- Shifted multiplicand after `i` iterations. -/ +def partialShift (lhs i : β„•) : β„• := + lhs * 2 ^ i + +end BinaryShiftMul + +namespace TM + +/-- Compact injective assignment of the six multiplication roles to work +tapes. Injectivity makes every pair of roles structurally distinct. -/ +structure BinaryShiftMulABI (n : β„•) where + /-- Injective map from semantic roles to physical work tapes. -/ + tape : Fin 6 β†ͺ Fin n + +/-- Preserved multiplicand tape. -/ +def BinaryShiftMulABI.lhs {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 0 + +/-- Preserved multiplier and loop-driver tape. -/ +def BinaryShiftMulABI.rhs {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 1 + +/-- Initially-zero output accumulator tape. -/ +def BinaryShiftMulABI.acc {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 2 + +/-- Current shifted multiplicand tape. -/ +def BinaryShiftMulABI.shift {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 3 + +/-- First alternating zero scratch tape. -/ +def BinaryShiftMulABI.tmp {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 4 + +/-- Second alternating zero scratch tape. -/ +def BinaryShiftMulABI.dbl {n : β„•} (abi : BinaryShiftMulABI n) : Fin n := + abi.tape 5 + +/-- Distinct ABI slots map to distinct work tapes. -/ +theorem BinaryShiftMulABI.tape_ne {n : β„•} (abi : BinaryShiftMulABI n) + {first second : Fin 6} (hne : first β‰  second) : + abi.tape first β‰  abi.tape second := by + exact fun heq => hne (abi.tape.injective heq) + +@[simp] theorem BinaryShiftMulABI.lhs_ne_rhs {n : β„•} + (abi : BinaryShiftMulABI n) : abi.lhs β‰  abi.rhs := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.lhs_ne_acc {n : β„•} + (abi : BinaryShiftMulABI n) : abi.lhs β‰  abi.acc := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.lhs_ne_shift {n : β„•} + (abi : BinaryShiftMulABI n) : abi.lhs β‰  abi.shift := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.lhs_ne_tmp {n : β„•} + (abi : BinaryShiftMulABI n) : abi.lhs β‰  abi.tmp := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.lhs_ne_dbl {n : β„•} + (abi : BinaryShiftMulABI n) : abi.lhs β‰  abi.dbl := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.rhs_ne_acc {n : β„•} + (abi : BinaryShiftMulABI n) : abi.rhs β‰  abi.acc := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.rhs_ne_shift {n : β„•} + (abi : BinaryShiftMulABI n) : abi.rhs β‰  abi.shift := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.rhs_ne_tmp {n : β„•} + (abi : BinaryShiftMulABI n) : abi.rhs β‰  abi.tmp := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.rhs_ne_dbl {n : β„•} + (abi : BinaryShiftMulABI n) : abi.rhs β‰  abi.dbl := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.acc_ne_shift {n : β„•} + (abi : BinaryShiftMulABI n) : abi.acc β‰  abi.shift := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.acc_ne_tmp {n : β„•} + (abi : BinaryShiftMulABI n) : abi.acc β‰  abi.tmp := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.acc_ne_dbl {n : β„•} + (abi : BinaryShiftMulABI n) : abi.acc β‰  abi.dbl := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.shift_ne_tmp {n : β„•} + (abi : BinaryShiftMulABI n) : abi.shift β‰  abi.tmp := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.shift_ne_dbl {n : β„•} + (abi : BinaryShiftMulABI n) : abi.shift β‰  abi.dbl := + abi.tape_ne (by decide) + +@[simp] theorem BinaryShiftMulABI.tmp_ne_dbl {n : β„•} + (abi : BinaryShiftMulABI n) : abi.tmp β‰  abi.dbl := + abi.tape_ne (by decide) + +/-- Initialize the shifted multiplicand from `lhs`, using the zero accumulator +as the copy routine's preserved zero scratch. -/ +def binaryShiftMulInitTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + binaryCopyIntoTM abi.lhs abi.shift abi.acc + +/-- Add the current shift into the accumulator. The sum is formed on `tmp`, +copied back through zero scratch `dbl`, and `tmp` is reset. -/ +def binaryShiftMulUpdateTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + seqTM (binaryRippleAddTM abi.acc abi.shift abi.tmp) + (seqTM (binaryCopyIntoTM abi.tmp abi.acc abi.dbl) + (resetBinaryWorkTM abi.tmp)) + +/-- Double `shift`. A copy on `tmp` is added back into `dbl`; after alternating +copy-back and resets, `shift` contains twice its old value and both scratch +tapes are zero. -/ +def binaryShiftMulDoubleTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + seqTM (binaryCopyIntoTM abi.shift abi.tmp abi.dbl) + (seqTM (binaryRippleAddTM abi.shift abi.tmp abi.dbl) + (seqTM (resetBinaryWorkTM abi.tmp) + (seqTM (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl)))) + +/-- Execute the conditional add and then the unconditional doubling step. -/ +def binaryShiftMulOneTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + seqTM (binaryShiftMulUpdateTM abi) (binaryShiftMulDoubleTM abi) + +/-- Branch on the current multiplier bit. A one performs update-and-double; +every other dispatched Boolean symbol performs only the doubling step. -/ +def binaryShiftMulBitBodyTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + branchWorkSymbolTM abi.rhs Ξ“.one + (binaryShiftMulOneTM abi) (binaryShiftMulDoubleTM abi) + +/-- Iterate once per canonical bit on the preserved multiplier tape. -/ +def binaryShiftMulLoopTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + forBinaryWorkTM abi.rhs (binaryShiftMulBitBodyTM abi) + +/-- Restore the multiplier head and reset every non-output scratch tape. -/ +def binaryShiftMulCleanupTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + seqTM (rewindWorkTM abi.rhs) + (resetBinaryWorkManyTM [abi.shift, abi.tmp, abi.dbl]) + +/-- Initialize, scan the multiplier, and clean up the six-tape shift-and-add +implementation. -/ +def binaryShiftMulTM {n : β„•} (abi : BinaryShiftMulABI n) : TM n := + seqTM (binaryShiftMulInitTM abi) + (seqTM (binaryShiftMulLoopTM abi) (binaryShiftMulCleanupTM abi)) + +/-- Combined input width used by the conservative multiplication budget. -/ +def binaryShiftMulWidth (lhs rhs : β„•) : β„• := + lhs.size + rhs.size + +/-- Audited conservative quadratic budget for initialization, all multiplier +iterations, cleanup, and composition seams. -/ +def binaryShiftMulTime (lhs rhs : β„•) : β„• := + let width := binaryShiftMulWidth lhs rhs + 33 * width ^ 2 + 170 * width + 58 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal.lean new file mode 100644 index 0000000000..b9885a675e --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Out +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Sem + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Out.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Out.lean new file mode 100644 index 0000000000..7432a8b30f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Out.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany + +/-! +# Width-driven binary shift-and-add multiplication -- output safety + +This file composes the transducer certificates of every multiplication phase. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private theorem binaryShiftMulUpdateTM_isTransducer {n : β„•} + (abi : BinaryShiftMulABI n) : + (binaryShiftMulUpdateTM abi).IsTransducer := by + unfold binaryShiftMulUpdateTM + exact (binaryRippleAddTM_isTransducer abi.acc abi.shift abi.tmp).seqTM + ((binaryCopyIntoTM_isTransducer abi.tmp abi.acc abi.dbl).seqTM + (resetBinaryWorkTM_isTransducer abi.tmp)) + +private theorem binaryShiftMulDoubleTM_isTransducer {n : β„•} + (abi : BinaryShiftMulABI n) : + (binaryShiftMulDoubleTM abi).IsTransducer := by + unfold binaryShiftMulDoubleTM + exact (binaryCopyIntoTM_isTransducer abi.shift abi.tmp abi.dbl).seqTM + ((binaryRippleAddTM_isTransducer abi.shift abi.tmp abi.dbl).seqTM + ((resetBinaryWorkTM_isTransducer abi.tmp).seqTM + ((binaryCopyIntoTM_isTransducer abi.dbl abi.shift abi.tmp).seqTM + (resetBinaryWorkTM_isTransducer abi.dbl)))) + +private theorem binaryShiftMulBitBodyTM_isTransducer {n : β„•} + (abi : BinaryShiftMulABI n) : + (binaryShiftMulBitBodyTM abi).IsTransducer := by + unfold binaryShiftMulBitBodyTM binaryShiftMulOneTM + exact (binaryShiftMulUpdateTM_isTransducer abi).seqTM + (binaryShiftMulDoubleTM_isTransducer abi) |>.branchWorkSymbolTM + (binaryShiftMulDoubleTM_isTransducer abi) + +/-- Shift-and-add multiplication never moves the public output head left. -/ +theorem binaryShiftMulTM_isTransducer_internal {n : β„•} + (abi : BinaryShiftMulABI n) : + (binaryShiftMulTM abi).IsTransducer := by + unfold binaryShiftMulTM binaryShiftMulInitTM binaryShiftMulLoopTM + binaryShiftMulCleanupTM + exact (binaryCopyIntoTM_isTransducer abi.lhs abi.shift abi.acc).seqTM + ((binaryShiftMulBitBodyTM_isTransducer abi).forBinaryWorkTM.seqTM + ((rewindWorkTM_isTransducer abi.rhs).seqTM + (resetBinaryWorkManyTM_isTransducer [abi.shift, abi.tmp, abi.dbl]))) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Pure.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Pure.lean new file mode 100644 index 0000000000..d95ae9de2a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Pure.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Defs +public import Mathlib.Algebra.Order.Ring.Nat +public import Mathlib.Tactic.Ring.RingNF + +/-! +# Width-driven binary shift-and-add multiplication -- pure proofs + +This file proves the generalized arithmetic invariant of the little-endian +shift-and-add fold, its multiplication specialization, and width bounds for +every partial accumulator and shifted multiplicand. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinaryShiftMul + +/-- The generalized shift-and-add fold accumulates `shift` times the decoded +bit string and doubles `shift` once per consumed bit. -/ +theorem fold_eq_internal (bits : List Bool) (acc shift : β„•) : + fold bits acc shift = + (acc + shift * Nat.fromBitsLE bits, shift * 2 ^ bits.length) := by + induction bits generalizing acc shift with + | nil => simp [fold, Nat.fromBitsLE, Nat.fromBits] + | cons bit bits ih => + cases bit <;> + simp [fold, step, ih, Nat.fromBitsLE_cons, pow_succ, + Prod.ext_iff] <;> + constructor <;> ring + +/-- Taking a low-order prefix cannot increase its little-endian decoded +value. -/ +theorem fromBitsLE_take_le_internal (bits : List Bool) (i : β„•) : + Nat.fromBitsLE (bits.take i) ≀ Nat.fromBitsLE bits := by + induction bits generalizing i with + | nil => simp [Nat.fromBitsLE] + | cons bit bits ih => + cases i with + | zero => + simp only [List.take_zero] + exact Nat.zero_le _ + | succ i => + rw [List.take_succ_cons, Nat.fromBitsLE_cons, + Nat.fromBitsLE_cons] + exact Nat.add_le_add_left (Nat.mul_le_mul_left 2 (ih i)) _ + +/-- If the iteration index is within the canonical multiplier width, folding +its prefix produces the advertised partial accumulator and shift. -/ +theorem fold_take_eq_internal (lhs rhs i : β„•) (hi : i ≀ rhs.size) : + fold (rhs.bits.take i) 0 lhs = + (partialAcc lhs rhs i, partialShift lhs i) := by + rw [fold_eq_internal] + simp [partialAcc, partialShift, List.length_take, Nat.size_eq_bits_len, + min_eq_left hi] + +private theorem fold_append (xs ys : List Bool) (acc shift : β„•) : + fold (xs ++ ys) acc shift = + let middle := fold xs acc shift + fold ys middle.1 middle.2 := by + induction xs generalizing acc shift with + | nil => rfl + | cons bit xs ih => + simp only [List.cons_append, fold] + rw [ih] + +/-- One live multiplier bit advances the partial arithmetic invariant by one +iteration. -/ +theorem step_partial_internal (lhs rhs i : β„•) (hi : i < rhs.size) : + step (rhs.bits.get ⟨i, by simpa [Nat.size_eq_bits_len] using hi⟩) + (partialAcc lhs rhs i) (partialShift lhs i) = + (partialAcc lhs rhs (i + 1), partialShift lhs (i + 1)) := by + have hcurrent := fold_take_eq_internal lhs rhs i (Nat.le_of_lt hi) + have hnext := fold_take_eq_internal lhs rhs (i + 1) (by omega) + rw [List.take_succ_eq_append_getElem (by + simpa [Nat.size_eq_bits_len] using hi), fold_append, hcurrent] at hnext + simpa [fold] using hnext + +/-- Folding all canonical multiplier bits computes multiplication and leaves +the shift advanced by the multiplier width. -/ +theorem fold_natBits_internal (lhs rhs : β„•) : + fold rhs.bits 0 lhs = (lhs * rhs, lhs * 2 ^ rhs.size) := by + rw [fold_eq_internal, Nat.fromBitsLE_bits, Nat.size_eq_bits_len] + simp + +/-- The complete partial accumulator is the product. -/ +theorem partialAcc_full_internal (lhs rhs : β„•) : + partialAcc lhs rhs rhs.size = lhs * rhs := by + unfold partialAcc + rw [← Nat.size_eq_bits_len, List.take_length, Nat.fromBitsLE_bits] + +/-- The complete partial shift has advanced by the multiplier width. -/ +theorem partialShift_full_internal (lhs rhs : β„•) : + partialShift lhs rhs.size = lhs * 2 ^ rhs.size := by + rfl + +/-- The accumulator component of the complete pure fold is the product. -/ +theorem fold_natBits_fst_internal (lhs rhs : β„•) : + (fold rhs.bits 0 lhs).1 = lhs * rhs := by + rw [fold_natBits_internal] + +/-- Every partial accumulator is bounded by the complete product. -/ +theorem partialAcc_le_mul_internal (lhs rhs i : β„•) : + partialAcc lhs rhs i ≀ lhs * rhs := by + unfold partialAcc + simpa only [Nat.fromBitsLE_bits] using + Nat.mul_le_mul_left lhs (fromBitsLE_take_le_internal rhs.bits i) + +/-- Binary width is subadditive under multiplication. -/ +theorem size_mul_le_add_internal (lhs rhs : β„•) : + (lhs * rhs).size ≀ lhs.size + rhs.size := by + by_cases hrhs : rhs = 0 + Β· simp [hrhs] + rw [Nat.size_le] + calc + lhs * rhs < 2 ^ lhs.size * rhs := + Nat.mul_lt_mul_of_pos_right (Nat.lt_size_self lhs) (Nat.pos_of_ne_zero hrhs) + _ < 2 ^ lhs.size * 2 ^ rhs.size := + Nat.mul_lt_mul_of_pos_left (Nat.lt_size_self rhs) (Nat.two_pow_pos _) + _ = 2 ^ (lhs.size + rhs.size) := by rw [pow_add] + +/-- Every partial accumulator fits in the combined input width. -/ +theorem partialAcc_size_le_width_internal (lhs rhs i : β„•) : + (partialAcc lhs rhs i).size ≀ lhs.size + rhs.size := by + exact le_trans (Nat.size_le_size (partialAcc_le_mul_internal lhs rhs i)) + (size_mul_le_add_internal lhs rhs) + +/-- Shifting left by `i` grows binary width by at most `i`. -/ +theorem partialShift_size_le_internal (lhs i : β„•) : + (partialShift lhs i).size ≀ lhs.size + i := by + by_cases hlhs : lhs = 0 + Β· simp [partialShift, hlhs] + rw [partialShift, ← Nat.shiftLeft_eq_mul_pow, Nat.size_shiftLeft hlhs] + +/-- At any live multiplier iteration, both arithmetic values fit in the +combined input width. -/ +theorem partial_widths_le_internal (lhs rhs i : β„•) (hi : i ≀ rhs.size) : + (partialAcc lhs rhs i).size ≀ lhs.size + rhs.size ∧ + (partialShift lhs i).size ≀ lhs.size + rhs.size := by + exact ⟨partialAcc_size_le_width_internal lhs rhs i, + le_trans (partialShift_size_le_internal lhs i) + (Nat.add_le_add_left hi lhs.size)⟩ + +end BinaryShiftMul + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Sem.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Sem.lean new file mode 100644 index 0000000000..bbc5fd957c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinaryShiftMul/Internal/Sem.lean @@ -0,0 +1,1789 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.ForBinaryWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.WorkSymbolBranch +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryCopy +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinaryShiftMul.Internal.Pure +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany + +/-! +# Width-driven binary shift-and-add multiplication -- composed semantics + +This file composes the width-linear copy and ripple-add primitives through a +bit-driven work-tape loop. The multiplier cursor is preserved by every body +phase and advanced only by the loopback seam. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +private def binaryShiftMulNatTape (value : β„•) : Tape := + (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right + +private theorem binaryShiftMulNatTape_hasBinaryNat (value : β„•) : + (binaryShiftMulNatTape value).HasBinaryNat value := by + simpa [binaryShiftMulNatTape] using Tape.init_move_right_hasBinaryNat value + +private theorem hasBinaryNat_parked {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : Parked t := + ⟨by rw [h.2.1], h.2.hasBinaryContent.cells_ne_start⟩ + +private theorem binaryShiftMulExactFrame_transition {n : β„•} + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆ€ inp work out, + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + transitionInput inp = inpβ‚€ ∧ + (fun i => transitionTape (work i)) = workβ‚€ ∧ + transitionTape out = outβ‚€ := by + intro inp work out hpre + rcases hpre with ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + exact phaseTransition_eq_self_of_reads_ne_start hinput.read_ne_start + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + +private def binaryShiftMulUpdateTime (acc shift : β„•) : β„• := + binaryRippleAddTime acc shift + 1 + + binaryCopyTime (acc + shift) acc + 1 + + resetBinaryWorkTime 1 (acc + shift).size + +private def binaryShiftMulUpdatePost {n : β„•} (abi : BinaryShiftMulABI n) + (acc shift : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.acc).HasBinaryNat (acc + shift) ∧ + (work abi.shift).HasBinaryNat shift ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.acc β†’ i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryShiftMulUpdateTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (acc shift : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hacc : (workβ‚€ abi.acc).HasBinaryNat acc) + (hshift : (workβ‚€ abi.shift).HasBinaryNat shift) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulUpdateTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulUpdatePost abi acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulUpdateTime acc shift) := by + have hdistinctAdd : BinaryRippleAddDistinct abi.acc abi.shift abi.tmp := + ⟨abi.acc_ne_shift, abi.acc_ne_tmp, abi.shift_ne_tmp⟩ + have hadd := binaryRippleAddTM_hoareTime_frame abi.acc abi.shift abi.tmp + hdistinctAdd acc shift inpβ‚€ workβ‚€ outβ‚€ hacc hshift htmp hinput + (fun i _ _ _ => hwork i) houtput + let AddPost : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + (work abi.acc).HasBinaryNat acc ∧ + (work abi.shift).HasBinaryNat shift ∧ + (work abi.tmp).HasBinaryNat (acc + shift) ∧ + (βˆ€ i, i β‰  abi.acc β†’ i β‰  abi.shift β†’ i β‰  abi.tmp β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + have hadd' : (binaryRippleAddTM abi.acc abi.shift abi.tmp).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + AddPost (binaryRippleAddTime acc shift) := by + simpa only [AddPost] using hadd + have htail : + (seqTM (binaryCopyIntoTM abi.tmp abi.acc abi.dbl) + (resetBinaryWorkTM abi.tmp)).HoareTime + AddPost (binaryShiftMulUpdatePost abi acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryCopyTime (acc + shift) acc + 1 + + resetBinaryWorkTime 1 (acc + shift).size) := by + intro inp work out hpre + rcases hpre with ⟨hinp, haccNow, hshiftNow, htmpNow, hframe, hout⟩ + have hworkNow : βˆ€ i, Parked (work i) := by + intro i + by_cases haccIdx : i = abi.acc + Β· subst i + exact hasBinaryNat_parked haccNow + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshiftNow + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmpNow + rw [hframe i haccIdx hshiftIdx htmpIdx] + exact hwork i + have hdblNow : (work abi.dbl).HasBinaryNat 0 := by + rw [hframe abi.dbl abi.acc_ne_dbl.symm abi.shift_ne_dbl.symm + abi.tmp_ne_dbl.symm] + exact hdbl + have hcopy := binaryCopyIntoTM_hoareTime_frame abi.tmp abi.acc abi.dbl + abi.acc_ne_tmp.symm abi.tmp_ne_dbl abi.acc_ne_dbl + (acc + shift) acc inp work out htmpNow haccNow hdblNow + (hinp.symm β–Έ hinput) (fun i _ _ _ => hworkNow i) + (hout.symm β–Έ houtput) + let workβ‚‚ := Function.update work abi.acc + (binaryShiftMulNatTape (acc + shift)) + have hcopy' : (binaryCopyIntoTM abi.tmp abi.acc abi.dbl).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = workβ‚‚ ∧ out' = out) + (binaryCopyTime (acc + shift) acc) := by + simpa only [workβ‚‚, binaryShiftMulNatTape] using hcopy + have hworkβ‚‚ : βˆ€ i, Parked (workβ‚‚ i) := by + intro i + by_cases hi : i = abi.acc + Β· subst i + simp only [workβ‚‚, Function.update_self] + exact hasBinaryNat_parked + (binaryShiftMulNatTape_hasBinaryNat (acc + shift)) + simp only [workβ‚‚, Function.update_of_ne hi] + exact hworkNow i + have htmpβ‚‚ : (workβ‚‚ abi.tmp).HasBinaryNat (acc + shift) := by + simpa only [workβ‚‚, Function.update_of_ne abi.acc_ne_tmp.symm] using + htmpNow + have hreset := resetBinaryWorkTM_hoareTime_frame abi.tmp + (acc + shift).bits 1 inp workβ‚‚ out htmpβ‚‚.2.hasBinaryContent htmpβ‚‚.1 + ⟨by rw [htmpβ‚‚.2.1], by rw [htmpβ‚‚.2.1]⟩ (hinp.symm β–Έ hinput) + (fun i _ => hworkβ‚‚ i) (hout.symm β–Έ houtput) + have htransition : βˆ€ inp' work' out', + (inp' = inp ∧ work' = workβ‚‚ ∧ out' = out) β†’ + (transitionInput inp' = inp ∧ + (fun i => transitionTape (work' i)) = workβ‚‚ ∧ + transitionTape out' = out) := by + rintro _ _ _ ⟨rfl, rfl, rfl⟩ + exact phaseTransition_eq_self_of_reads_ne_start + ((hinp.symm β–Έ hinput).read_ne_start) + (fun i => (hworkβ‚‚ i).read_ne_start) + ((hout.symm β–Έ houtput).read_ne_start) + have hrun := seqTM_hoareTime + (binaryCopyIntoTM abi.tmp abi.acc abi.dbl) + (resetBinaryWorkTM abi.tmp) hcopy' htransition hreset + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalWork, + hfinalOutput⟩ := hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, (by simpa [Nat.size_eq_bits_len] using htime), + hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, ?_, + hfinalOutput.trans hout⟩ + Β· rw [hfinalWork] + simp only [Function.update_of_ne abi.acc_ne_tmp, + workβ‚‚, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat (acc + shift) + Β· rw [hfinalWork] + simp only [Function.update_of_ne abi.shift_ne_tmp, + workβ‚‚, Function.update_of_ne abi.acc_ne_shift.symm] + exact hshiftNow + Β· rw [hfinalWork, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat 0 + Β· rw [hfinalWork] + simp only [Function.update_of_ne abi.tmp_ne_dbl.symm, + workβ‚‚, Function.update_of_ne abi.acc_ne_dbl.symm] + exact hdblNow + Β· intro i haccIdx hshiftIdx htmpIdx hdblIdx + rw [hfinalWork, Function.update_of_ne htmpIdx] + simp only [workβ‚‚, Function.update_of_ne haccIdx] + exact hframe i haccIdx hshiftIdx htmpIdx + have htransition : βˆ€ inp work out, AddPost inp work out β†’ + AddPost (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, haccNow, hshiftNow, htmpNow, hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases haccIdx : i = abi.acc + Β· subst i + exact (hasBinaryNat_parked haccNow).read_ne_start + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshiftNow).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmpNow).read_ne_start + rw [hframe i haccIdx hshiftIdx htmpIdx] + exact (hwork i).read_ne_start + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hinputTransition, hworkTransition, houtputTransition] + exact ⟨hinp, haccNow, hshiftNow, htmpNow, hframe, hout⟩ + have hrun := seqTM_hoareTime + (binaryRippleAddTM abi.acc abi.shift abi.tmp) + (seqTM (binaryCopyIntoTM abi.tmp abi.acc abi.dbl) + (resetBinaryWorkTM abi.tmp)) hadd' htransition htail + simpa [binaryShiftMulUpdateTM, binaryShiftMulUpdateTime, + Nat.add_assoc] using hrun + +private def binaryShiftMulDoubleTime (shift : β„•) : β„• := + binaryCopyTime shift 0 + 1 + + binaryRippleAddTime shift shift + 1 + + resetBinaryWorkTime 1 shift.size + 1 + + binaryCopyTime (shift + shift) shift + 1 + + resetBinaryWorkTime 1 (shift + shift).size + +private def binaryShiftMulDoublePost {n : β„•} (abi : BinaryShiftMulABI n) + (shift : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.shift).HasBinaryNat (2 * shift) ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- Replacing one work tape by a natural-number encoding preserves parking of every tape. -/ +private theorem binaryShiftMulUpdate_parked {n : β„•} + (work : Fin n β†’ Tape) (index : Fin n) (value : β„•) + (hwork : βˆ€ i, Parked (work i)) : + βˆ€ i, Parked (Function.update work index (binaryShiftMulNatTape value) i) := by + intro i + by_cases hi : i = index + Β· subst i + simp only [Function.update_self] + exact hasBinaryNat_parked (binaryShiftMulNatTape_hasBinaryNat value) + simp only [Function.update_of_ne hi] + exact hwork i + +private theorem binaryShiftMulDoubleTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (shift : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hshift : (workβ‚€ abi.shift).HasBinaryNat shift) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulDoubleTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulDoublePost abi shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulDoubleTime shift) := by + have hcopy₁ := binaryCopyIntoTM_hoareTime_frame abi.shift abi.tmp abi.dbl + abi.shift_ne_tmp abi.shift_ne_dbl abi.tmp_ne_dbl shift 0 + inpβ‚€ workβ‚€ outβ‚€ hshift htmp hdbl hinput (fun i _ _ _ => hwork i) + houtput + let work₁ := Function.update workβ‚€ abi.tmp (binaryShiftMulNatTape shift) + have hcopy₁' : (binaryCopyIntoTM abi.shift abi.tmp abi.dbl).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ work = work₁ ∧ out = outβ‚€) + (binaryCopyTime shift 0) := by + simpa only [work₁, binaryShiftMulNatTape] using hcopy₁ + have hwork₁ : βˆ€ i, Parked (work₁ i) := + binaryShiftMulUpdate_parked workβ‚€ abi.tmp shift hwork + have hshift₁ : (work₁ abi.shift).HasBinaryNat shift := by + simpa only [work₁, Function.update_of_ne abi.shift_ne_tmp] using hshift + have htmp₁ : (work₁ abi.tmp).HasBinaryNat shift := by + simp only [work₁, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat shift + have hdbl₁ : (work₁ abi.dbl).HasBinaryNat 0 := by + simpa only [work₁, Function.update_of_ne abi.tmp_ne_dbl.symm] using hdbl + let AddPost : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + (work abi.shift).HasBinaryNat shift ∧ + (work abi.tmp).HasBinaryNat shift ∧ + (work abi.dbl).HasBinaryNat (shift + shift) ∧ + (βˆ€ i, i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = work₁ i) ∧ + out = outβ‚€ + have hdistinctAdd : BinaryRippleAddDistinct abi.shift abi.tmp abi.dbl := + ⟨abi.shift_ne_tmp, abi.shift_ne_dbl, abi.tmp_ne_dbl⟩ + have hadd := binaryRippleAddTM_hoareTime_frame abi.shift abi.tmp abi.dbl + hdistinctAdd shift shift inpβ‚€ work₁ outβ‚€ hshift₁ htmp₁ hdbl₁ + hinput (fun i _ _ _ => hwork₁ i) houtput + have hadd' : (binaryRippleAddTM abi.shift abi.tmp abi.dbl).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = work₁ ∧ out = outβ‚€) + AddPost (binaryRippleAddTime shift shift) := by + simpa only [AddPost] using hadd + have hfinish : + (seqTM (resetBinaryWorkTM abi.tmp) + (seqTM (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl))).HoareTime + AddPost (binaryShiftMulDoublePost abi shift inpβ‚€ workβ‚€ outβ‚€) + (resetBinaryWorkTime 1 shift.size + 1 + + (binaryCopyTime (shift + shift) shift + 1 + + resetBinaryWorkTime 1 (shift + shift).size)) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hshiftNow, htmpNow, hdblNow, hframe, hout⟩ + have hworkNow : βˆ€ i, Parked (work i) := by + intro i + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshiftNow + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmpNow + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact hasBinaryNat_parked hdblNow + rw [hframe i hshiftIdx htmpIdx hdblIdx] + exact hwork₁ i + have hresetTmp := resetBinaryWorkTM_hoareTime_frame abi.tmp shift.bits 1 + inp work out htmpNow.2.hasBinaryContent htmpNow.1 + ⟨by rw [htmpNow.2.1], by rw [htmpNow.2.1]⟩ + (hinp.symm β–Έ hinput) (fun i _ => hworkNow i) + (hout.symm β–Έ houtput) + let workβ‚‚ := Function.update work abi.tmp (binaryShiftMulNatTape 0) + have hresetTmp' : (resetBinaryWorkTM abi.tmp).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = work ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = workβ‚‚ ∧ out' = out) + (resetBinaryWorkTime 1 shift.size) := by + simpa only [workβ‚‚, binaryShiftMulNatTape, + Nat.size_eq_bits_len] using! hresetTmp + have hworkβ‚‚ : βˆ€ i, Parked (workβ‚‚ i) := + binaryShiftMulUpdate_parked work abi.tmp 0 hworkNow + have hdblβ‚‚ : (workβ‚‚ abi.dbl).HasBinaryNat (shift + shift) := by + simpa only [workβ‚‚, Function.update_of_ne abi.tmp_ne_dbl.symm] using + hdblNow + have hshiftβ‚‚ : (workβ‚‚ abi.shift).HasBinaryNat shift := by + simpa only [workβ‚‚, Function.update_of_ne abi.shift_ne_tmp] using + hshiftNow + have htmpβ‚‚ : (workβ‚‚ abi.tmp).HasBinaryNat 0 := by + simp only [workβ‚‚, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat 0 + have hcopyβ‚‚ := binaryCopyIntoTM_hoareTime_frame abi.dbl abi.shift abi.tmp + abi.shift_ne_dbl.symm abi.tmp_ne_dbl.symm abi.shift_ne_tmp + (shift + shift) shift inp workβ‚‚ out hdblβ‚‚ hshiftβ‚‚ htmpβ‚‚ + (hinp.symm β–Έ hinput) (fun i _ _ _ => hworkβ‚‚ i) + (hout.symm β–Έ houtput) + let work₃ := Function.update workβ‚‚ abi.shift + (binaryShiftMulNatTape (shift + shift)) + have hcopyβ‚‚' : (binaryCopyIntoTM abi.dbl abi.shift abi.tmp).HoareTime + (fun inp' work' out' => inp' = inp ∧ work' = workβ‚‚ ∧ out' = out) + (fun inp' work' out' => inp' = inp ∧ work' = work₃ ∧ out' = out) + (binaryCopyTime (shift + shift) shift) := by + simpa only [work₃, binaryShiftMulNatTape] using hcopyβ‚‚ + have hwork₃ : βˆ€ i, Parked (work₃ i) := + binaryShiftMulUpdate_parked workβ‚‚ abi.shift (shift + shift) hworkβ‚‚ + have hdbl₃ : (work₃ abi.dbl).HasBinaryNat (shift + shift) := by + simpa only [work₃, Function.update_of_ne abi.shift_ne_dbl.symm] using + hdblβ‚‚ + have hresetDbl := resetBinaryWorkTM_hoareTime_frame abi.dbl + (shift + shift).bits 1 inp work₃ out hdbl₃.2.hasBinaryContent hdbl₃.1 + ⟨by rw [hdbl₃.2.1], by rw [hdbl₃.2.1]⟩ + (hinp.symm β–Έ hinput) (fun i _ => hwork₃ i) + (hout.symm β–Έ houtput) + have hcopyTail := seqTM_hoareTime + (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl) hcopyβ‚‚' + (binaryShiftMulExactFrame_transition inp work₃ out + (hinp.symm β–Έ hinput) hwork₃ (hout.symm β–Έ houtput)) hresetDbl + have hresetTail := seqTM_hoareTime (resetBinaryWorkTM abi.tmp) + (seqTM (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl)) hresetTmp' + (binaryShiftMulExactFrame_transition inp workβ‚‚ out + (hinp.symm β–Έ hinput) hworkβ‚‚ (hout.symm β–Έ houtput)) hcopyTail + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalWork, + hfinalOutput⟩ := hresetTail inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, (by + simpa [Nat.size_eq_bits_len, Nat.add_assoc] using htime), + hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, + hfinalOutput.trans hout⟩ + Β· rw [hfinalWork] + simp only [Function.update_of_ne abi.shift_ne_dbl, + work₃, Function.update_self] + simpa [two_mul] using + binaryShiftMulNatTape_hasBinaryNat (shift + shift) + Β· rw [hfinalWork] + simp only [Function.update_of_ne abi.tmp_ne_dbl, + work₃, Function.update_of_ne abi.shift_ne_tmp.symm, + workβ‚‚, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat 0 + Β· rw [hfinalWork, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat 0 + Β· intro i hshiftIdx htmpIdx hdblIdx + rw [hfinalWork, Function.update_of_ne hdblIdx] + simp only [work₃, Function.update_of_ne hshiftIdx, + workβ‚‚, Function.update_of_ne htmpIdx] + exact (hframe i hshiftIdx htmpIdx hdblIdx).trans (by + simp only [work₁, Function.update_of_ne htmpIdx]) + have haddTail := seqTM_hoareTime + (binaryRippleAddTM abi.shift abi.tmp abi.dbl) + (seqTM (resetBinaryWorkTM abi.tmp) + (seqTM (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl))) hadd' + (by + intro inp work out hpost + rcases hpost with ⟨hinp, hshiftNow, htmpNow, hdblNow, hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshiftNow).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmpNow).read_ne_start + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact (hasBinaryNat_parked hdblNow).read_ne_start + rw [hframe i hshiftIdx htmpIdx hdblIdx] + exact (hwork₁ i).read_ne_start + obtain ⟨hi, hw, ho⟩ := phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hshiftNow, htmpNow, hdblNow, hframe, hout⟩) + hfinish + have hrun := seqTM_hoareTime + (binaryCopyIntoTM abi.shift abi.tmp abi.dbl) + (seqTM (binaryRippleAddTM abi.shift abi.tmp abi.dbl) + (seqTM (resetBinaryWorkTM abi.tmp) + (seqTM (binaryCopyIntoTM abi.dbl abi.shift abi.tmp) + (resetBinaryWorkTM abi.dbl)))) hcopy₁' + (binaryShiftMulExactFrame_transition inpβ‚€ work₁ outβ‚€ hinput hwork₁ + houtput) haddTail + simpa [binaryShiftMulDoubleTM, binaryShiftMulDoubleTime, + Nat.add_assoc] using hrun + +private def binaryShiftMulOneTime (acc shift : β„•) : β„• := + binaryShiftMulUpdateTime acc shift + 1 + binaryShiftMulDoubleTime shift + +private def binaryShiftMulOnePost {n : β„•} (abi : BinaryShiftMulABI n) + (acc shift : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.acc).HasBinaryNat (acc + shift) ∧ + (work abi.shift).HasBinaryNat (2 * shift) ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.acc β†’ i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryShiftMulOneTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (acc shift : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hacc : (workβ‚€ abi.acc).HasBinaryNat acc) + (hshift : (workβ‚€ abi.shift).HasBinaryNat shift) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulOneTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulOnePost abi acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulOneTime acc shift) := by + have hupdate := binaryShiftMulUpdateTM_hoareTime_frame abi acc shift + inpβ‚€ workβ‚€ outβ‚€ hacc hshift htmp hdbl hinput hwork houtput + have hdouble : (binaryShiftMulDoubleTM abi).HoareTime + (binaryShiftMulUpdatePost abi acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulOnePost abi acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulDoubleTime shift) := by + intro inp work out hpre + rcases hpre with ⟨hinp, haccNow, hshiftNow, htmpNow, hdblNow, + hframe, hout⟩ + have hworkNow : βˆ€ i, Parked (work i) := by + intro i + by_cases haccIdx : i = abi.acc + Β· subst i + exact hasBinaryNat_parked haccNow + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshiftNow + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmpNow + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact hasBinaryNat_parked hdblNow + rw [hframe i haccIdx hshiftIdx htmpIdx hdblIdx] + exact hwork i + have hrun := binaryShiftMulDoubleTM_hoareTime_frame abi shift + inp work out hshiftNow htmpNow hdblNow (hinp.symm β–Έ hinput) + hworkNow (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalShift, + hfinalTmp, hfinalDbl, hfinalFrame, hfinalOutput⟩ := + hrun inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, htime, hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, hfinalShift, hfinalTmp, hfinalDbl, + ?_, hfinalOutput.trans hout⟩ + Β· rw [hfinalFrame abi.acc abi.acc_ne_shift abi.acc_ne_tmp + abi.acc_ne_dbl] + exact haccNow + Β· intro i haccIdx hshiftIdx htmpIdx hdblIdx + exact (hfinalFrame i hshiftIdx htmpIdx hdblIdx).trans + (hframe i haccIdx hshiftIdx htmpIdx hdblIdx) + have htransition : βˆ€ inp work out, + binaryShiftMulUpdatePost abi acc shift inpβ‚€ workβ‚€ outβ‚€ inp work out β†’ + binaryShiftMulUpdatePost abi acc shift inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, haccNow, hshiftNow, htmpNow, hdblNow, + hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases haccIdx : i = abi.acc + Β· subst i + exact (hasBinaryNat_parked haccNow).read_ne_start + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshiftNow).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmpNow).read_ne_start + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact (hasBinaryNat_parked hdblNow).read_ne_start + rw [hframe i haccIdx hshiftIdx htmpIdx hdblIdx] + exact (hwork i).read_ne_start + obtain ⟨hi, hw, ho⟩ := phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, haccNow, hshiftNow, htmpNow, hdblNow, hframe, hout⟩ + have hrun := seqTM_hoareTime (binaryShiftMulUpdateTM abi) + (binaryShiftMulDoubleTM abi) hupdate htransition hdouble + simpa [binaryShiftMulOneTM, binaryShiftMulOneTime] using hrun + +private def binaryShiftMulBodyTime (bit : Bool) (acc shift : β„•) : β„• := + (if bit then binaryShiftMulOneTime acc shift + else binaryShiftMulDoubleTime shift) + 1 + +private theorem binaryShiftMulUpdateTime_le (acc shift width : β„•) + (hacc : acc.size ≀ width) (hshift : shift.size ≀ width) : + binaryShiftMulUpdateTime acc shift ≀ 13 * width + 50 := by + have haddSize := binaryRippleAdd_sum_size_le acc shift + have hsum : (acc + shift).size ≀ width + 1 := by + exact haddSize.trans (Nat.add_le_add_right (max_le hacc hshift) 1) + have haddTime := binaryRippleAddTime_le acc shift + have hcopyTime := binaryCopyTime_le (acc + shift) acc + simp only [binaryShiftMulUpdateTime, resetBinaryWorkTime, + clearWorkTimeBound] + omega + +private theorem binaryShiftMulDoubleTime_le (shift width : β„•) + (hshift : shift.size ≀ width) : + binaryShiftMulDoubleTime shift ≀ 20 * width + 110 := by + have hdoubleSize := binaryRippleAdd_sum_size_le shift shift + have hsum : (shift + shift).size ≀ width + 1 := by + exact hdoubleSize.trans + (Nat.add_le_add_right (max_le hshift hshift) 1) + have hcopy₁ := binaryCopyTime_le shift 0 + simp only [Nat.size_zero, Nat.mul_zero, Nat.add_zero] at hcopy₁ + have hadd := binaryRippleAddTime_le shift shift + have hcopyβ‚‚ := binaryCopyTime_le (shift + shift) shift + simp only [binaryShiftMulDoubleTime, resetBinaryWorkTime, + clearWorkTimeBound] + omega + +private theorem binaryShiftMulBodyTime_le (bit : Bool) (acc shift width : β„•) + (hacc : acc.size ≀ width) (hshift : shift.size ≀ width) : + binaryShiftMulBodyTime bit acc shift ≀ 33 * width + 162 := by + have hupdate := binaryShiftMulUpdateTime_le acc shift width hacc hshift + have hdouble := binaryShiftMulDoubleTime_le shift width hshift + cases bit <;> + simp only [binaryShiftMulBodyTime, binaryShiftMulOneTime, + Bool.false_eq_true, ite_false, if_true] <;> + omega + +private theorem forBinaryWorkLoopTime_le + (bodyTime : β„• β†’ β„•) (total bound : β„•) + (hbody : βˆ€ i, i < total β†’ bodyTime i ≀ bound) : + βˆ€ count value, value + count = total β†’ + forBinaryWorkLoopTime bodyTime value count ≀ count * (bound + 2) + 1 := by + intro count + induction count with + | zero => + intro value _ + simp [forBinaryWorkLoopTime] + | succ count ih => + intro value htotal + have hvalue : value < total := by omega + have htail := ih (value + 1) (by omega) + have hhead := hbody value hvalue + simp only [forBinaryWorkLoopTime] + rw [Nat.succ_mul] + omega + +private def binaryShiftMulBodyPost {n : β„•} (abi : BinaryShiftMulABI n) + (bit : Bool) (acc shift : β„•) (inpβ‚€ : Tape) + (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.acc).HasBinaryNat (BinaryShiftMul.step bit acc shift).1 ∧ + (work abi.shift).HasBinaryNat (BinaryShiftMul.step bit acc shift).2 ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.acc β†’ i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ + work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryShiftMulBitBodyTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (bit : Bool) (acc shift : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hbit : (workβ‚€ abi.rhs).read = Ξ“.ofBool bit) + (hacc : (workβ‚€ abi.acc).HasBinaryNat acc) + (hshift : (workβ‚€ abi.shift).HasBinaryNat shift) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulBitBodyTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulBodyPost abi bit acc shift inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulBodyTime bit acc shift) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + cases bit with + | false => + have hrun := binaryShiftMulDoubleTM_hoareTime_frame abi shift + inpβ‚€ workβ‚€ outβ‚€ hshift htmp hdbl hinput hwork houtput + inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalShift, + hfinalTmp, hfinalDbl, hfinalFrame, hfinalOutput⟩ := hrun + have hne : (workβ‚€ abi.rhs).read β‰  Ξ“.one := by + rw [hbit] + decide + obtain ⟨C, hbranch, hbranchHalt, hinputEq, hworkEq, houtputEq⟩ := + branchWorkSymbolTM_reachesIn_different_frame abi.rhs Ξ“.one + (binaryShiftMulOneTM abi) (binaryShiftMulDoubleTM abi) + inpβ‚€ workβ‚€ outβ‚€ hne hinput.read_ne_start + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + hreach hhalt + refine ⟨C, time + 1, ?_, hbranch, hbranchHalt, ?_⟩ + Β· simpa [binaryShiftMulBodyTime] using Nat.add_le_add_right htime 1 + Β· refine ⟨hinputEq.trans hfinalInput, ?_, ?_, ?_, ?_, ?_, + houtputEq.trans hfinalOutput⟩ + Β· rw [hworkEq, hfinalFrame abi.acc abi.acc_ne_shift abi.acc_ne_tmp + abi.acc_ne_dbl] + simpa [BinaryShiftMul.step] using hacc + Β· rw [hworkEq] + simpa [BinaryShiftMul.step] using hfinalShift + Β· rw [hworkEq] + exact hfinalTmp + Β· rw [hworkEq] + exact hfinalDbl + Β· intro i haccIdx hshiftIdx htmpIdx hdblIdx + rw [hworkEq, hfinalFrame i hshiftIdx htmpIdx hdblIdx] + | true => + have hrun := binaryShiftMulOneTM_hoareTime_frame abi acc shift + inpβ‚€ workβ‚€ outβ‚€ hacc hshift htmp hdbl hinput hwork houtput + inpβ‚€ workβ‚€ outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalAcc, + hfinalShift, hfinalTmp, hfinalDbl, hfinalFrame, + hfinalOutput⟩ := hrun + have heq : (workβ‚€ abi.rhs).read = Ξ“.one := by + simpa using! hbit + obtain ⟨C, hbranch, hbranchHalt, hinputEq, hworkEq, houtputEq⟩ := + branchWorkSymbolTM_reachesIn_equal_frame abi.rhs Ξ“.one + (binaryShiftMulOneTM abi) (binaryShiftMulDoubleTM abi) + inpβ‚€ workβ‚€ outβ‚€ heq hinput.read_ne_start + (fun i => (hwork i).read_ne_start) houtput.read_ne_start + hreach hhalt + refine ⟨C, time + 1, ?_, hbranch, hbranchHalt, ?_⟩ + Β· simpa [binaryShiftMulBodyTime] using Nat.add_le_add_right htime 1 + Β· refine ⟨hinputEq.trans hfinalInput, ?_, ?_, ?_, ?_, ?_, + houtputEq.trans hfinalOutput⟩ + Β· rw [hworkEq] + simpa [BinaryShiftMul.step] using hfinalAcc + Β· rw [hworkEq] + simpa [BinaryShiftMul.step] using hfinalShift + Β· rw [hworkEq] + exact hfinalTmp + Β· rw [hworkEq] + exact hfinalDbl + Β· intro i haccIdx hshiftIdx htmpIdx hdblIdx + rw [hworkEq, hfinalFrame i haccIdx hshiftIdx htmpIdx hdblIdx] + +private def binaryShiftMulBitAt (rhs i : β„•) : Bool := + (rhs.bits[i]?).getD false + +private theorem binaryShiftMulBitAt_eq_get (rhs i : β„•) (hi : i < rhs.size) : + binaryShiftMulBitAt rhs i = + rhs.bits.get ⟨i, by simpa [Nat.size_eq_bits_len] using hi⟩ := by + simp [binaryShiftMulBitAt, + show i < rhs.bits.length by simpa [Nat.size_eq_bits_len] using hi] + +private def binaryShiftMulCursorTape (tape : Tape) (index : β„•) : Tape := + { head := index + 1, cells := tape.cells } + +private def binaryShiftMulLoopWork {n : β„•} (abi : BinaryShiftMulABI n) + (workβ‚€ : Fin n β†’ Tape) (index acc shift : β„•) : Fin n β†’ Tape := + Function.update + (Function.update + (Function.update + (Function.update + (Function.update workβ‚€ abi.rhs + (binaryShiftMulCursorTape (workβ‚€ abi.rhs) index)) + abi.acc (binaryShiftMulNatTape acc)) + abi.shift (binaryShiftMulNatTape shift)) + abi.tmp (binaryShiftMulNatTape 0)) + abi.dbl (binaryShiftMulNatTape 0) + +private theorem binaryShiftMulLoopWork_rhs {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.rhs = + binaryShiftMulCursorTape (workβ‚€ abi.rhs) index := by + simp [binaryShiftMulLoopWork] + +private theorem binaryShiftMulLoopWork_acc {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.acc = + binaryShiftMulNatTape acc := by + simp [binaryShiftMulLoopWork] + +private theorem binaryShiftMulLoopWork_shift {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.shift = + binaryShiftMulNatTape shift := by + simp [binaryShiftMulLoopWork] + +private theorem binaryShiftMulLoopWork_tmp {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.tmp = + binaryShiftMulNatTape 0 := by + simp [binaryShiftMulLoopWork] + +private theorem binaryShiftMulLoopWork_dbl {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.dbl = + binaryShiftMulNatTape 0 := by + simp [binaryShiftMulLoopWork] + +private theorem binaryShiftMulLoopWork_other {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) (i : Fin n) + (hrhs : i β‰  abi.rhs) (hacc : i β‰  abi.acc) + (hshift : i β‰  abi.shift) (htmp : i β‰  abi.tmp) + (hdbl : i β‰  abi.dbl) : + binaryShiftMulLoopWork abi workβ‚€ index acc shift i = workβ‚€ i := by + simp [binaryShiftMulLoopWork, hrhs, hacc, hshift, htmp, hdbl] + +private theorem binaryShiftMulCursorTape_parked {tape : Tape} + (h : Parked tape) (index : β„•) : + Parked (binaryShiftMulCursorTape tape index) := by + exact ⟨by simp [binaryShiftMulCursorTape], by + simpa [binaryShiftMulCursorTape] using h.2⟩ + +private theorem binaryShiftMulLoopWork_parked {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) (hwork : βˆ€ i, Parked (workβ‚€ i)) : + βˆ€ i, Parked (binaryShiftMulLoopWork abi workβ‚€ index acc shift i) := by + intro i + by_cases hrhs : i = abi.rhs + Β· subst i + rw [binaryShiftMulLoopWork_rhs] + exact binaryShiftMulCursorTape_parked (hwork abi.rhs) index + by_cases hacc : i = abi.acc + Β· subst i + rw [binaryShiftMulLoopWork_acc] + exact hasBinaryNat_parked (binaryShiftMulNatTape_hasBinaryNat acc) + by_cases hshift : i = abi.shift + Β· subst i + rw [binaryShiftMulLoopWork_shift] + exact hasBinaryNat_parked (binaryShiftMulNatTape_hasBinaryNat shift) + by_cases htmp : i = abi.tmp + Β· subst i + rw [binaryShiftMulLoopWork_tmp] + exact hasBinaryNat_parked (binaryShiftMulNatTape_hasBinaryNat 0) + by_cases hdbl : i = abi.dbl + Β· subst i + rw [binaryShiftMulLoopWork_dbl] + exact hasBinaryNat_parked (binaryShiftMulNatTape_hasBinaryNat 0) + rw [binaryShiftMulLoopWork_other abi workβ‚€ index acc shift i hrhs hacc + hshift htmp hdbl] + exact hwork i + +private theorem binaryShiftMulLoopWork_read_bit {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (rhs index acc shift : β„•) (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hi : index < rhs.size) : + (binaryShiftMulLoopWork abi workβ‚€ index acc shift abi.rhs).read = + Ξ“.ofBool (binaryShiftMulBitAt rhs index) := by + rw [binaryShiftMulLoopWork_rhs, Tape.read] + simp only [binaryShiftMulCursorTape] + rw [binaryShiftMulBitAt_eq_get rhs index hi] + exact hrhs.2.2.1 index (by simpa [Nat.size_eq_bits_len] using hi) + +private theorem binaryShiftMulLoopWork_read_blank {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (rhs acc shift : β„•) (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) : + (binaryShiftMulLoopWork abi workβ‚€ rhs.size acc shift abi.rhs).read = + Ξ“.blank := by + rw [binaryShiftMulLoopWork_rhs, Tape.read] + simp only [binaryShiftMulCursorTape] + exact hrhs.2.2.2 rhs.size (by simp [Nat.size_eq_bits_len]) + +private theorem binaryShiftMulLoopWork_advance {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (index acc shift : β„•) : + (fun i => if i = abi.rhs then + (binaryShiftMulLoopWork abi workβ‚€ index acc shift i).move Dir3.right + else binaryShiftMulLoopWork abi workβ‚€ index acc shift i) = + binaryShiftMulLoopWork abi workβ‚€ (index + 1) acc shift := by + funext i + by_cases hrhs : i = abi.rhs + Β· subst i + simp only [ite_eq_left, binaryShiftMulLoopWork_rhs] + simp [binaryShiftMulCursorTape, Tape.move] + Β· rw [ite_eq_right hrhs] + by_cases hacc : i = abi.acc + Β· subst i + rw [binaryShiftMulLoopWork_acc, binaryShiftMulLoopWork_acc] + by_cases hshift : i = abi.shift + Β· subst i + rw [binaryShiftMulLoopWork_shift, binaryShiftMulLoopWork_shift] + by_cases htmp : i = abi.tmp + Β· subst i + rw [binaryShiftMulLoopWork_tmp, binaryShiftMulLoopWork_tmp] + by_cases hdbl : i = abi.dbl + Β· subst i + rw [binaryShiftMulLoopWork_dbl, binaryShiftMulLoopWork_dbl] + rw [binaryShiftMulLoopWork_other abi workβ‚€ index acc shift i hrhs hacc + hshift htmp hdbl, + binaryShiftMulLoopWork_other abi workβ‚€ (index + 1) acc shift i hrhs + hacc hshift htmp hdbl] + +private def binaryShiftMulPartialWork {n : β„•} (abi : BinaryShiftMulABI n) + (workβ‚€ : Fin n β†’ Tape) (lhs rhs index : β„•) : Fin n β†’ Tape := + binaryShiftMulLoopWork abi workβ‚€ index + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) + +private def binaryShiftMulBodyDoneWork {n : β„•} + (abi : BinaryShiftMulABI n) (workβ‚€ : Fin n β†’ Tape) + (lhs rhs index : β„•) : Fin n β†’ Tape := + binaryShiftMulLoopWork abi workβ‚€ index + (BinaryShiftMul.partialAcc lhs rhs (index + 1)) + (BinaryShiftMul.partialShift lhs (index + 1)) + +private def binaryShiftMulScanCfg {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs index : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : + Cfg n (forBinaryWorkTM abi.rhs (binaryShiftMulBitBodyTM abi)).Q := + { state := .inl .scan + input := inpβ‚€ + work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs index + output := outβ‚€ } + +private def binaryShiftMulBodyStartCfg {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs index : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : + Cfg n (forBinaryWorkTM abi.rhs (binaryShiftMulBitBodyTM abi)).Q := + { state := .inr (binaryShiftMulBitBodyTM abi).qstart + input := inpβ‚€ + work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs index + output := outβ‚€ } + +private def binaryShiftMulBodyDoneCfg {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs index : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) : + Cfg n (forBinaryWorkTM abi.rhs (binaryShiftMulBitBodyTM abi)).Q := + { state := .inr (binaryShiftMulBitBodyTM abi).qhalt + input := inpβ‚€ + work := binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index + output := outβ‚€ } + +private def binaryShiftMulDoneCfg {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : + Cfg n (forBinaryWorkTM abi.rhs (binaryShiftMulBitBodyTM abi)).Q := + { state := .inl .done + input := inpβ‚€ + work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs rhs.size + output := outβ‚€ } + +private theorem binaryShiftMulBody_run {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs index : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) (hi : index < rhs.size) : + βˆƒ time, + time ≀ binaryShiftMulBodyTime (binaryShiftMulBitAt rhs index) + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) ∧ + (binaryShiftMulBitBodyTM abi).reachesIn time + { state := (binaryShiftMulBitBodyTM abi).qstart + input := inpβ‚€ + work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs index + output := outβ‚€ } + { state := (binaryShiftMulBitBodyTM abi).qhalt + input := inpβ‚€ + work := binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index + output := outβ‚€ } := by + let acc := BinaryShiftMul.partialAcc lhs rhs index + let shift := BinaryShiftMul.partialShift lhs index + let work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs index + have hworkParked : βˆ€ i, Parked (work i) := by + exact binaryShiftMulLoopWork_parked abi workβ‚€ index acc shift hwork + have hacc : (work abi.acc).HasBinaryNat acc := by + rw [show work = binaryShiftMulLoopWork abi workβ‚€ index acc shift by rfl, + binaryShiftMulLoopWork_acc] + exact binaryShiftMulNatTape_hasBinaryNat acc + have hshift : (work abi.shift).HasBinaryNat shift := by + rw [show work = binaryShiftMulLoopWork abi workβ‚€ index acc shift by rfl, + binaryShiftMulLoopWork_shift] + exact binaryShiftMulNatTape_hasBinaryNat shift + have htmp : (work abi.tmp).HasBinaryNat 0 := by + rw [show work = binaryShiftMulLoopWork abi workβ‚€ index acc shift by rfl, + binaryShiftMulLoopWork_tmp] + exact binaryShiftMulNatTape_hasBinaryNat 0 + have hdbl : (work abi.dbl).HasBinaryNat 0 := by + rw [show work = binaryShiftMulLoopWork abi workβ‚€ index acc shift by rfl, + binaryShiftMulLoopWork_dbl] + exact binaryShiftMulNatTape_hasBinaryNat 0 + have hbit : (work abi.rhs).read = + Ξ“.ofBool (binaryShiftMulBitAt rhs index) := by + exact binaryShiftMulLoopWork_read_bit abi workβ‚€ rhs index acc shift + hrhs hi + have hrun := binaryShiftMulBitBodyTM_hoareTime_frame abi + (binaryShiftMulBitAt rhs index) acc shift inpβ‚€ work outβ‚€ hbit hacc + hshift htmp hdbl hinput hworkParked houtput + inpβ‚€ work outβ‚€ ⟨rfl, rfl, rfl⟩ + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalAcc, + hfinalShift, hfinalTmp, hfinalDbl, hfinalFrame, hfinalOutput⟩ := hrun + have hstep := BinaryShiftMul.step_partial_internal lhs rhs index hi + rw [← binaryShiftMulBitAt_eq_get rhs index hi] at hstep + have hfinalAcc' : (c'.work abi.acc).HasBinaryNat + (BinaryShiftMul.partialAcc lhs rhs (index + 1)) := by + simpa [acc, shift, hstep] using hfinalAcc + have hfinalShift' : (c'.work abi.shift).HasBinaryNat + (BinaryShiftMul.partialShift lhs (index + 1)) := by + simpa [acc, shift, hstep] using hfinalShift + have hfinalWork : c'.work = + binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index := by + funext i + by_cases haccIdx : i = abi.acc + Β· subst i + rw [binaryShiftMulBodyDoneWork, binaryShiftMulLoopWork_acc] + exact hfinalAcc'.eq_init_move_right + by_cases hshiftIdx : i = abi.shift + Β· subst i + rw [binaryShiftMulBodyDoneWork, binaryShiftMulLoopWork_shift] + exact hfinalShift'.eq_init_move_right + by_cases htmpIdx : i = abi.tmp + Β· subst i + rw [binaryShiftMulBodyDoneWork, binaryShiftMulLoopWork_tmp] + exact hfinalTmp.eq_init_move_right + by_cases hdblIdx : i = abi.dbl + Β· subst i + rw [binaryShiftMulBodyDoneWork, binaryShiftMulLoopWork_dbl] + exact hfinalDbl.eq_init_move_right + rw [hfinalFrame i haccIdx hshiftIdx htmpIdx hdblIdx] + simp [work, binaryShiftMulPartialWork, binaryShiftMulBodyDoneWork, + binaryShiftMulLoopWork, haccIdx, hshiftIdx, htmpIdx, hdblIdx] + refine ⟨time, htime, ?_⟩ + have hc : c' = + { state := (binaryShiftMulBitBodyTM abi).qhalt + input := inpβ‚€ + work := binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index + output := outβ‚€ } := by + exact Cfg.ext hhalt hfinalInput hfinalWork hfinalOutput + simpa [work, hc] using hreach + +private def binaryShiftMulLoopBound (lhs rhs : β„•) : β„• := + rhs.size * (33 * binaryShiftMulWidth lhs rhs + 164) + 1 + +private def binaryShiftMulLoopPost {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryContent rhs.bits ∧ + (work abi.rhs).cells 0 = Ξ“.start ∧ + (work abi.rhs).head = rhs.size + 1 ∧ + (work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (work abi.shift).HasBinaryNat (lhs * 2 ^ rhs.size) ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- The completed bit loop has the full multiplication result and preserves its outside frame. -/ +private theorem binaryShiftMulDoneCfg_post {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) : + binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€).input + (binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€).work + (binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€).output := by + let doneWork := binaryShiftMulPartialWork abi workβ‚€ lhs rhs rhs.size + let doneCfg := binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + refine ⟨rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, rfl⟩ + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_other abi workβ‚€ rhs.size + (BinaryShiftMul.partialAcc lhs rhs rhs.size) + (BinaryShiftMul.partialShift lhs rhs.size) abi.lhs + abi.lhs_ne_rhs abi.lhs_ne_acc abi.lhs_ne_shift abi.lhs_ne_tmp + abi.lhs_ne_dbl] + exact hlhs + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_rhs] + simpa [binaryShiftMulCursorTape, Tape.HasBinaryContent] using + hrhs.2.hasBinaryContent + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_rhs] + simpa [binaryShiftMulCursorTape] using hrhs.1 + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_rhs] + simp [binaryShiftMulCursorTape] + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_acc, + BinaryShiftMul.partialAcc_full_internal] + exact binaryShiftMulNatTape_hasBinaryNat (lhs * rhs) + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_shift, + BinaryShiftMul.partialShift_full_internal] + exact binaryShiftMulNatTape_hasBinaryNat (lhs * 2 ^ rhs.size) + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_tmp] + exact binaryShiftMulNatTape_hasBinaryNat 0 + Β· rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_dbl] + exact binaryShiftMulNatTape_hasBinaryNat 0 + Β· intro i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + rw [show doneCfg.work = doneWork by rfl] + dsimp only [doneWork] + rw [binaryShiftMulPartialWork, + binaryShiftMulLoopWork_other abi workβ‚€ rhs.size + (BinaryShiftMul.partialAcc lhs rhs rhs.size) + (BinaryShiftMul.partialShift lhs rhs.size) i hrhsIdx haccIdx + hshiftIdx htmpIdx hdblIdx] + +private theorem binaryShiftMulLoopTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat lhs) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulLoopTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulLoopBound lhs rhs) := by + classical + let body := binaryShiftMulBitBodyTM abi + have hbodyExists : βˆ€ index, βˆƒ time, index < rhs.size β†’ + time ≀ binaryShiftMulBodyTime (binaryShiftMulBitAt rhs index) + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) ∧ + body.reachesIn time + { state := body.qstart + input := inpβ‚€ + work := binaryShiftMulPartialWork abi workβ‚€ lhs rhs index + output := outβ‚€ } + { state := body.qhalt + input := inpβ‚€ + work := binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index + output := outβ‚€ } := by + intro index + by_cases hi : index < rhs.size + Β· obtain ⟨time, htime, hrun⟩ := binaryShiftMulBody_run abi lhs rhs + index inpβ‚€ workβ‚€ outβ‚€ hrhs hinput hwork houtput hi + exact ⟨time, fun _ => ⟨htime, hrun⟩⟩ + Β· exact ⟨0, fun h => (hi h).elim⟩ + choose bodyTime hbody using hbodyExists + let spec : ForBinaryWorkLoopSpec abi.rhs body bodyTime rhs.size := + { scanCfg := fun index => + binaryShiftMulScanCfg abi lhs rhs index inpβ‚€ workβ‚€ outβ‚€ + bodyStartCfg := fun index => + binaryShiftMulBodyStartCfg abi lhs rhs index inpβ‚€ workβ‚€ outβ‚€ + bodyDoneCfg := fun index => + binaryShiftMulBodyDoneCfg abi lhs rhs index inpβ‚€ workβ‚€ outβ‚€ + doneCfg := binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + scanStep := by + intro index hi + apply forBinaryWorkTM_step_scan_bit_internal abi.rhs body + (binaryShiftMulBitAt rhs index) + Β· rfl + Β· exact binaryShiftMulLoopWork_read_bit abi workβ‚€ rhs index + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) hrhs hi + Β· exact hinput.read_ne_start + Β· exact fun i => (binaryShiftMulLoopWork_parked abi workβ‚€ index + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) hwork i).read_ne_start + Β· exact houtput.read_ne_start + bodyRun := by + intro index hi + exact forBinaryWorkTM_body_reachesIn_internal abi.rhs body + (hbody index hi).2 + loopbackStep := by + intro index hi + let acc := BinaryShiftMul.partialAcc lhs rhs (index + 1) + let shift := BinaryShiftMul.partialShift lhs (index + 1) + let work := binaryShiftMulBodyDoneWork abi workβ‚€ lhs rhs index + have hworkParked : βˆ€ i, Parked (work i) := by + exact binaryShiftMulLoopWork_parked abi workβ‚€ index acc shift + hwork + have hstep := forBinaryWorkTM_step_body_halt_internal abi.rhs body + ({ state := body.qhalt + input := inpβ‚€ + work := work + output := outβ‚€ } : Cfg n body.Q) rfl hinput.read_ne_start + (fun i => (hworkParked i).read_ne_start) houtput.read_ne_start + have hadvance := binaryShiftMulLoopWork_advance abi workβ‚€ index + acc shift + simpa [binaryShiftMulBodyDoneCfg, binaryShiftMulScanCfg, + binaryShiftMulPartialWork, work, acc, shift, + binaryShiftMulBodyDoneWork, body, hadvance] using! hstep + stopStep := by + apply forBinaryWorkTM_step_scan_blank_internal abi.rhs body + Β· rfl + Β· exact binaryShiftMulLoopWork_read_blank abi workβ‚€ rhs + (BinaryShiftMul.partialAcc lhs rhs rhs.size) + (BinaryShiftMul.partialShift lhs rhs.size) hrhs + Β· exact hinput.read_ne_start + Β· exact fun i => (binaryShiftMulLoopWork_parked abi workβ‚€ rhs.size + (BinaryShiftMul.partialAcc lhs rhs rhs.size) + (BinaryShiftMul.partialShift lhs rhs.size) hwork i).read_ne_start + Β· exact houtput.read_ne_start } + have hbodyBound : βˆ€ index, index < rhs.size β†’ + bodyTime index ≀ 33 * binaryShiftMulWidth lhs rhs + 162 := by + intro index hi + have hwidths := BinaryShiftMul.partial_widths_le_internal lhs rhs index + (Nat.le_of_lt hi) + exact (hbody index hi).1.trans + (binaryShiftMulBodyTime_le (binaryShiftMulBitAt rhs index) + (BinaryShiftMul.partialAcc lhs rhs index) + (BinaryShiftMul.partialShift lhs index) + (binaryShiftMulWidth lhs rhs) hwidths.1 hwidths.2) + have hloop := spec.reachesIn (count := rhs.size) (value := 0) (by simp) + have hloopTime := forBinaryWorkLoopTime_le bodyTime rhs.size + (33 * binaryShiftMulWidth lhs rhs + 162) hbodyBound rhs.size 0 (by simp) + have hinitialWork : binaryShiftMulPartialWork abi workβ‚€ lhs rhs 0 = workβ‚€ := by + funext i + by_cases hrhsIdx : i = abi.rhs + Β· subst i + rw [binaryShiftMulPartialWork, binaryShiftMulLoopWork_rhs] + apply Tape.ext + Β· simpa [binaryShiftMulCursorTape] using hrhs.2.1.symm + Β· rfl + by_cases haccIdx : i = abi.acc + Β· subst i + rw [binaryShiftMulPartialWork, binaryShiftMulLoopWork_acc] + simpa [BinaryShiftMul.partialAcc] using! hacc.eq_init_move_right.symm + by_cases hshiftIdx : i = abi.shift + Β· subst i + rw [binaryShiftMulPartialWork, binaryShiftMulLoopWork_shift] + simpa [BinaryShiftMul.partialShift] using! hshift.eq_init_move_right.symm + by_cases htmpIdx : i = abi.tmp + Β· subst i + rw [binaryShiftMulPartialWork, binaryShiftMulLoopWork_tmp] + exact htmp.eq_init_move_right.symm + by_cases hdblIdx : i = abi.dbl + Β· subst i + rw [binaryShiftMulPartialWork, binaryShiftMulLoopWork_dbl] + exact hdbl.eq_init_move_right.symm + exact binaryShiftMulLoopWork_other abi workβ‚€ 0 + (BinaryShiftMul.partialAcc lhs rhs 0) + (BinaryShiftMul.partialShift lhs 0) i hrhsIdx haccIdx hshiftIdx + htmpIdx hdblIdx + intro inp work out hpre + rcases hpre with ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + let doneWork := binaryShiftMulPartialWork abi workβ‚€ lhs rhs rhs.size + let doneCfg := binaryShiftMulDoneCfg abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + have hreach : (binaryShiftMulLoopTM abi).reachesIn + (forBinaryWorkLoopTime bodyTime 0 rhs.size) + { state := (binaryShiftMulLoopTM abi).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } doneCfg := by + simpa [binaryShiftMulLoopTM, spec, binaryShiftMulScanCfg, + hinitialWork, doneCfg, body] using! hloop + refine ⟨doneCfg, forBinaryWorkLoopTime bodyTime 0 rhs.size, + (by simpa [binaryShiftMulLoopBound] using hloopTime), hreach, rfl, ?_⟩ + exact binaryShiftMulDoneCfg_post abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs + +private def binaryShiftMulCleanupBits {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) (i : Fin n) : List Bool := + if i = abi.shift then (lhs * 2 ^ rhs.size).bits else [] + +private def binaryShiftMulCleanupHead {n : β„•} (_abi : BinaryShiftMulABI n) + (_i : Fin n) : β„• := + 1 + +private def binaryShiftMulCleanupTime {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) : β„• := + rhs.size + 3 + 1 + + resetBinaryWorkManyTime (binaryShiftMulCleanupBits abi lhs rhs) + (binaryShiftMulCleanupHead abi) [abi.shift, abi.tmp, abi.dbl] + +private def binaryShiftMulCleanupMid {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryNat rhs ∧ + (work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (work abi.shift).HasBinaryNat (lhs * 2 ^ rhs.size) ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + +/-- Postcondition for completed shift-and-add binary multiplication. -/ +def binaryShiftMulPost {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryNat rhs ∧ + (work abi.acc).HasBinaryNat (lhs * rhs) ∧ + (work abi.shift).HasBinaryNat 0 ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryShiftMulRewindTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (rewindWorkTM abi.rhs).HoareTime + (binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulCleanupMid abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (rhs.size + 3) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hlhs, hrhsContent, hrhsStart, hrhsHead, + hacc, hshift, htmp, hdbl, hframe, hout⟩ + have hworkParked : βˆ€ i, Parked (work i) := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact hasBinaryNat_parked hlhs + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact ⟨by rw [hrhsHead]; omega, hrhsContent.cells_ne_start⟩ + by_cases haccIdx : i = abi.acc + Β· subst i + exact hasBinaryNat_parked hacc + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshift + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmp + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact hasBinaryNat_parked hdbl + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact hwork i + have hrewind := rewindBinaryWorkTM_hoareTime_frame abi.rhs rhs.bits + (rhs.size + 1) inp work out hrhsContent hrhsStart + ⟨by rw [hrhsHead]; omega, by rw [hrhsHead]⟩ + (hinp.symm β–Έ hinput) (fun i _ => hworkParked i) (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalRhs, + hfinalOther, hfinalOutput⟩ := + hrewind inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, (by simpa using htime), hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalOutput.trans hout⟩ + Β· rw [hfinalOther abi.lhs abi.lhs_ne_rhs] + exact hlhs + Β· rw [hfinalRhs] + exact Tape.init_move_right_hasBinaryNat rhs + Β· rw [hfinalOther abi.acc (Ne.symm abi.rhs_ne_acc)] + exact hacc + Β· rw [hfinalOther abi.shift (Ne.symm abi.rhs_ne_shift)] + exact hshift + Β· rw [hfinalOther abi.tmp (Ne.symm abi.rhs_ne_tmp)] + exact htmp + Β· rw [hfinalOther abi.dbl (Ne.symm abi.rhs_ne_dbl)] + exact hdbl + Β· intro i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + exact (hfinalOther i hrhsIdx).trans + (hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx) + +private theorem binaryShiftMulResetTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (resetBinaryWorkManyTM [abi.shift, abi.tmp, abi.dbl]).HoareTime + (binaryShiftMulCleanupMid abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (resetBinaryWorkManyTime (binaryShiftMulCleanupBits abi lhs rhs) + (binaryShiftMulCleanupHead abi) [abi.shift, abi.tmp, abi.dbl]) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, + hframe, hout⟩ + have hworkParked : βˆ€ i, Parked (work i) := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact hasBinaryNat_parked hlhs + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact hasBinaryNat_parked hrhs + by_cases haccIdx : i = abi.acc + Β· subst i + exact hasBinaryNat_parked hacc + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshift + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmp + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact hasBinaryNat_parked hdbl + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact hwork i + have htargets : [abi.shift, abi.tmp, abi.dbl].Nodup := by + simp + have htarget : βˆ€ i, i ∈ [abi.shift, abi.tmp, abi.dbl] β†’ + (work i).HasBinaryContent (binaryShiftMulCleanupBits abi lhs rhs i) := by + intro i hi + simp only [List.mem_cons, List.not_mem_nil, or_false] at hi + rcases hi with rfl | rfl | rfl + Β· simpa [binaryShiftMulCleanupBits] using hshift.2.hasBinaryContent + Β· simpa [binaryShiftMulCleanupBits, Ne.symm abi.shift_ne_tmp] using + htmp.2.hasBinaryContent + Β· simpa [binaryShiftMulCleanupBits, Ne.symm abi.shift_ne_dbl] using + hdbl.2.hasBinaryContent + have htargetStart : βˆ€ i, i ∈ [abi.shift, abi.tmp, abi.dbl] β†’ + (work i).cells 0 = Ξ“.start := by + intro i hi + simp only [List.mem_cons, List.not_mem_nil, or_false] at hi + rcases hi with rfl | rfl | rfl + Β· exact hshift.1 + Β· exact htmp.1 + Β· exact hdbl.1 + have htargetHead : βˆ€ i, i ∈ [abi.shift, abi.tmp, abi.dbl] β†’ + (work i).head ≀ binaryShiftMulCleanupHead abi i := by + intro i hi + simp only [List.mem_cons, List.not_mem_nil, or_false] at hi + rcases hi with rfl | rfl | rfl + Β· simpa [binaryShiftMulCleanupHead] using hshift.2.1.le + Β· simpa [binaryShiftMulCleanupHead] using htmp.2.1.le + Β· simpa [binaryShiftMulCleanupHead] using hdbl.2.1.le + have hreset := resetBinaryWorkManyTM_hoareTime_frame + [abi.shift, abi.tmp, abi.dbl] (binaryShiftMulCleanupBits abi lhs rhs) + (binaryShiftMulCleanupHead abi) inp work out htargets htarget + htargetStart htargetHead (hinp.symm β–Έ hinput) hworkParked + (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalWork, + hfinalOutput⟩ := hreset inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, htime, hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, ?_, ?_, ?_, ?_, ?_, ?_, ?_, + hfinalOutput.trans hout⟩ + Β· rw [hfinalWork, resetBinaryWorkManyResult_eq_of_not_mem] + Β· exact hlhs + Β· simp + Β· rw [hfinalWork, resetBinaryWorkManyResult_eq_of_not_mem] + Β· exact hrhs + Β· simp + Β· rw [hfinalWork, resetBinaryWorkManyResult_eq_of_not_mem] + Β· exact hacc + Β· simp + Β· rw [hfinalWork, + resetBinaryWorkManyResult_eq_blank_of_mem work _ abi.shift (by simp)] + simpa [resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + Β· rw [hfinalWork, + resetBinaryWorkManyResult_eq_blank_of_mem work _ abi.tmp (by simp)] + simpa [resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + Β· rw [hfinalWork, + resetBinaryWorkManyResult_eq_blank_of_mem work _ abi.dbl (by simp)] + simpa [resetBinaryBlank] using Tape.init_move_right_hasBinaryNat 0 + Β· intro i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + rw [hfinalWork, resetBinaryWorkManyResult_eq_of_not_mem] + Β· exact hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + Β· simp [hshiftIdx, htmpIdx, hdblIdx] + +private theorem binaryShiftMulCleanupTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulCleanupTM abi).HoareTime + (binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulCleanupTime abi lhs rhs) := by + have hrewind := binaryShiftMulRewindTM_hoareTime_frame abi lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hinput hwork houtput + have hreset := binaryShiftMulResetTM_hoareTime_frame abi lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hinput hwork houtput + have htransition : βˆ€ inp work out, + binaryShiftMulCleanupMid abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ inp work out β†’ + binaryShiftMulCleanupMid abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hmid + rcases hmid with ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, + hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact (hasBinaryNat_parked hlhs).read_ne_start + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact (hasBinaryNat_parked hrhs).read_ne_start + by_cases haccIdx : i = abi.acc + Β· subst i + exact (hasBinaryNat_parked hacc).read_ne_start + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshift).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmp).read_ne_start + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact (hasBinaryNat_parked hdbl).read_ne_start + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact (hwork i).read_ne_start + obtain ⟨hi, hw, ho⟩ := phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, hframe, hout⟩ + have hrun := seqTM_hoareTime (rewindWorkTM abi.rhs) + (resetBinaryWorkManyTM [abi.shift, abi.tmp, abi.dbl]) + hrewind htransition hreset + simpa [binaryShiftMulCleanupTM, binaryShiftMulCleanupTime] using hrun + +private def binaryShiftMulInitPost {n : β„•} (abi : BinaryShiftMulABI n) + (lhs rhs : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (outβ‚€ : Tape) : TapePred n := + fun inp work out => + inp = inpβ‚€ ∧ + (work abi.lhs).HasBinaryNat lhs ∧ + (work abi.rhs).HasBinaryNat rhs ∧ + (work abi.acc).HasBinaryNat 0 ∧ + (work abi.shift).HasBinaryNat lhs ∧ + (work abi.tmp).HasBinaryNat 0 ∧ + (work abi.dbl).HasBinaryNat 0 ∧ + (βˆ€ i, i β‰  abi.lhs β†’ i β‰  abi.rhs β†’ i β‰  abi.acc β†’ + i β‰  abi.shift β†’ i β‰  abi.tmp β†’ i β‰  abi.dbl β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + +private theorem binaryShiftMulInitTM_hoareTime_frame {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulInitTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulInitPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryCopyTime lhs 0) := by + have hcopy := binaryCopyIntoTM_hoareTime_frame abi.lhs abi.shift abi.acc + abi.lhs_ne_shift abi.lhs_ne_acc (Ne.symm abi.acc_ne_shift) lhs 0 + inpβ‚€ workβ‚€ outβ‚€ hlhs hshift hacc hinput (fun i _ _ _ => hwork i) + houtput + unfold binaryShiftMulInitTM + apply hcopy.strengthen_post + intro inp work out hpost + rcases hpost with ⟨hinp, hworkEq, hout⟩ + refine ⟨hinp, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hout⟩ + Β· rw [hworkEq, Function.update_of_ne abi.lhs_ne_shift] + exact hlhs + Β· rw [hworkEq, Function.update_of_ne abi.rhs_ne_shift] + exact hrhs + Β· rw [hworkEq, Function.update_of_ne abi.acc_ne_shift] + exact hacc + Β· rw [hworkEq, Function.update_self] + exact binaryShiftMulNatTape_hasBinaryNat lhs + Β· rw [hworkEq, Function.update_of_ne (Ne.symm abi.shift_ne_tmp)] + exact htmp + Β· rw [hworkEq, Function.update_of_ne (Ne.symm abi.shift_ne_dbl)] + exact hdbl + Β· intro i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + rw [hworkEq, Function.update_of_ne hshiftIdx] + +private theorem binaryShiftMulLoopTM_hoareTime_from_init {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulLoopTM abi).HoareTime + (binaryShiftMulInitPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulLoopBound lhs rhs) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, + hframe, hout⟩ + have hworkParked : βˆ€ i, Parked (work i) := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact hasBinaryNat_parked hlhs + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact hasBinaryNat_parked hrhs + by_cases haccIdx : i = abi.acc + Β· subst i + exact hasBinaryNat_parked hacc + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact hasBinaryNat_parked hshift + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact hasBinaryNat_parked htmp + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact hasBinaryNat_parked hdbl + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact hwork i + have hloop := binaryShiftMulLoopTM_hoareTime_frame abi lhs rhs + inp work out hlhs hrhs hacc hshift htmp hdbl (hinp.symm β–Έ hinput) + hworkParked (hout.symm β–Έ houtput) + obtain ⟨c', time, htime, hreach, hhalt, hfinalInput, hfinalLhs, + hfinalRhsContent, hfinalRhsStart, hfinalRhsHead, hfinalAcc, + hfinalShift, hfinalTmp, hfinalDbl, hfinalFrame, hfinalOutput⟩ := + hloop inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨c', time, htime, hreach, hhalt, ?_⟩ + refine ⟨hfinalInput.trans hinp, hfinalLhs, hfinalRhsContent, + hfinalRhsStart, hfinalRhsHead, hfinalAcc, hfinalShift, hfinalTmp, + hfinalDbl, ?_, hfinalOutput.trans hout⟩ + intro i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx + exact (hfinalFrame i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx + hdblIdx).trans + (hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx) + +private theorem binaryShiftMulInitPost_transition {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆ€ inp work out, + binaryShiftMulInitPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ inp work out β†’ + binaryShiftMulInitPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, + hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact (hasBinaryNat_parked hlhs).read_ne_start + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact (hasBinaryNat_parked hrhs).read_ne_start + by_cases haccIdx : i = abi.acc + Β· subst i + exact (hasBinaryNat_parked hacc).read_ne_start + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshift).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmp).read_ne_start + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact (hasBinaryNat_parked hdbl).read_ne_start + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact (hwork i).read_ne_start + obtain ⟨hi, hw, ho⟩ := phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hlhs, hrhs, hacc, hshift, htmp, hdbl, hframe, hout⟩ + +private theorem binaryShiftMulLoopPost_transition {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + βˆ€ inp work out, + binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ inp work out β†’ + binaryShiftMulLoopPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out) := by + intro inp work out hpost + rcases hpost with ⟨hinp, hlhs, hrhsContent, hrhsStart, hrhsHead, + hacc, hshift, htmp, hdbl, hframe, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hlhsIdx : i = abi.lhs + Β· subst i + exact (hasBinaryNat_parked hlhs).read_ne_start + by_cases hrhsIdx : i = abi.rhs + Β· subst i + exact hrhsContent.cells_ne_start _ (by rw [hrhsHead]; omega) + by_cases haccIdx : i = abi.acc + Β· subst i + exact (hasBinaryNat_parked hacc).read_ne_start + by_cases hshiftIdx : i = abi.shift + Β· subst i + exact (hasBinaryNat_parked hshift).read_ne_start + by_cases htmpIdx : i = abi.tmp + Β· subst i + exact (hasBinaryNat_parked htmp).read_ne_start + by_cases hdblIdx : i = abi.dbl + Β· subst i + exact (hasBinaryNat_parked hdbl).read_ne_start + rw [hframe i hlhsIdx hrhsIdx haccIdx hshiftIdx htmpIdx hdblIdx] + exact (hwork i).read_ne_start + obtain ⟨hi, hw, ho⟩ := phaseTransition_eq_self_of_reads_ne_start + (hinp.symm β–Έ hinput.read_ne_start) hreads + (hout.symm β–Έ houtput.read_ne_start) + rw [hi, hw, ho] + exact ⟨hinp, hlhs, hrhsContent, hrhsStart, hrhsHead, hacc, hshift, + htmp, hdbl, hframe, hout⟩ + +private theorem binaryShiftMulCleanupTime_le {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) : + binaryShiftMulCleanupTime abi lhs rhs ≀ + 3 * binaryShiftMulWidth lhs rhs + 35 := by + have hshift := (BinaryShiftMul.partial_widths_le_internal lhs rhs + rhs.size le_rfl).2 + have hshiftBits : (lhs * 2 ^ rhs.size).bits.length ≀ + binaryShiftMulWidth lhs rhs := by + simpa [BinaryShiftMul.partialShift, Nat.size_eq_bits_len, + binaryShiftMulWidth] using hshift + have hrhs : rhs.size ≀ binaryShiftMulWidth lhs rhs := by + simp [binaryShiftMulWidth] + simp only [binaryShiftMulCleanupTime, resetBinaryWorkManyTime, + binaryShiftMulCleanupBits, binaryShiftMulCleanupHead, + resetBinaryWorkTime, clearWorkTimeBound, ite_eq_left] + simp only [ite_eq_right (Ne.symm abi.shift_ne_tmp), + ite_eq_right (Ne.symm abi.shift_ne_dbl), List.length_nil] + omega + +/-- The concrete shift-and-add multiplier preserves both operands, writes +their product to the accumulator, clears all three scratch tapes, and +preserves the complete external frame. -/ +theorem binaryShiftMulTM_hoareTime_frame_internal {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (binaryShiftMulTM abi).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulTime lhs rhs) := by + have hinit := binaryShiftMulInitTM_hoareTime_frame abi lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hlhs hrhs hacc hshift htmp hdbl hinput hwork houtput + have hloop := binaryShiftMulLoopTM_hoareTime_from_init abi lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hinput hwork houtput + have hcleanup := binaryShiftMulCleanupTM_hoareTime_frame abi lhs rhs + inpβ‚€ workβ‚€ outβ‚€ hinput hwork houtput + have htail := seqTM_hoareTime (binaryShiftMulLoopTM abi) + (binaryShiftMulCleanupTM abi) hloop + (binaryShiftMulLoopPost_transition abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hinput hwork houtput) + hcleanup + have hrun := seqTM_hoareTime (binaryShiftMulInitTM abi) + (seqTM (binaryShiftMulLoopTM abi) (binaryShiftMulCleanupTM abi)) + hinit + (binaryShiftMulInitPost_transition abi lhs rhs inpβ‚€ workβ‚€ outβ‚€ + hinput hwork houtput) + htail + unfold binaryShiftMulTM + apply hrun.mono_bound + have hinitBound := binaryCopyTime_le lhs 0 + simp only [Nat.size_zero, Nat.mul_zero, Nat.add_zero] at hinitBound + have hlhsWidth : lhs.size ≀ binaryShiftMulWidth lhs rhs := by + simp [binaryShiftMulWidth] + have hloopBound : binaryShiftMulLoopBound lhs rhs ≀ + 33 * binaryShiftMulWidth lhs rhs ^ 2 + + 164 * binaryShiftMulWidth lhs rhs + 1 := by + have hrhsWidth : rhs.size ≀ binaryShiftMulWidth lhs rhs := by + simp [binaryShiftMulWidth] + unfold binaryShiftMulLoopBound + calc + rhs.size * (33 * binaryShiftMulWidth lhs rhs + 164) + 1 ≀ + binaryShiftMulWidth lhs rhs * + (33 * binaryShiftMulWidth lhs rhs + 164) + 1 := by + exact Nat.add_le_add_right + (Nat.mul_le_mul_right _ hrhsWidth) 1 + _ = 33 * binaryShiftMulWidth lhs rhs ^ 2 + + 164 * binaryShiftMulWidth lhs rhs + 1 := by ring + have hcleanupBound := binaryShiftMulCleanupTime_le abi lhs rhs + simp only [binaryShiftMulTime] + omega + +/-- Coarse all-prefix auxiliary-space contract inherited from the concrete +quadratic time envelope. -/ +theorem binaryShiftMulTM_hoareTimeSpace_frame_internal {n : β„•} + (abi : BinaryShiftMulABI n) (lhs rhs inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hlhs : (workβ‚€ abi.lhs).HasBinaryNat lhs) + (hrhs : (workβ‚€ abi.rhs).HasBinaryNat rhs) + (hacc : (workβ‚€ abi.acc).HasBinaryNat 0) + (hshift : (workβ‚€ abi.shift).HasBinaryNat 0) + (htmp : (workβ‚€ abi.tmp).HasBinaryNat 0) + (hdbl : (workβ‚€ abi.dbl).HasBinaryNat 0) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) + (hinitial : + ({ state := (binaryShiftMulTM abi).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binaryShiftMulTM abi).Q).WithinAuxSpace + inputLength initialSpace) : + (binaryShiftMulTM abi).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (binaryShiftMulPost abi lhs rhs inpβ‚€ workβ‚€ outβ‚€) + (binaryShiftMulTime lhs rhs) inputLength + (initialSpace + binaryShiftMulTime lhs rhs) := by + apply (binaryShiftMulTM_hoareTime_frame_internal abi lhs rhs inpβ‚€ workβ‚€ + outβ‚€ hlhs hrhs hacc hshift htmp hdbl hinput hwork houtput).toHoareTimeSpace + rintro inp work out ⟨hinp, hworkEq, hout⟩ + subst inp + subst work + subst out + exact hinitial + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc.lean new file mode 100644 index 0000000000..bf8f2297c0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Internal + +/-! +# Little-endian binary successor + +This module exposes the canonical semantics and compositional contracts for +`TM.binarySuccTM`. Natural numbers use `Nat.bits`, with the least significant +bit first and zero represented by the empty string. Successor propagates carry +through the initial one bits, appends on overflow, and rewinds the target work +tape to cell one. + +## Main results + +- `BinarySucc.ripple_natBits` β€” the pure ripple function computes successor. +- `TM.binarySuccTM_reachesIn_frame` β€” exact execution with a full tape frame. +- `TM.binarySuccTM_hoareTimeSpace_frame` β€” terminating and all-reachable space + contract. +- `TM.binarySuccTM_isTransducer` β€” the output head never moves left. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinarySucc + +/-- Ripple carry on canonical little-endian bits computes natural-number +successor, including the empty representation of zero and overflow. -/ +theorem ripple_natBits (value : β„•) : + ripple value.bits = (value + 1).bits := + ripple_natBits_internal value + +/-- The exact transition count is at most twice the represented bit length, +plus two. -/ +theorem steps_le (bits : List Bool) : + steps bits ≀ 2 * bits.length + 2 := + steps_le_internal bits + +end BinarySucc + +namespace Tape + +/-- `HasBinaryNat` determines the entire canonical initialized tape, including +its head position, left marker, digits, and blank tail. -/ +theorem HasBinaryNat.eq_init_move_right {t : Tape} {value : β„•} + (h : t.HasBinaryNat value) : + t = (Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right := + eq_init_move_right_of_hasBinaryString h.2 h.1 + +/-- The standard initialized natural-number tape satisfies `HasBinaryNat`. -/ +theorem init_move_right_hasBinaryNat (value : β„•) : + ((Tape.init (value.bits.map Ξ“.ofBool)).move Dir3.right).HasBinaryNat value := by + refine ⟨?_, init_move_right_hasBinaryString value.bits⟩ + simp [Tape.init, Tape.move] + +end Tape + +namespace TM + +/-- The exact successor running time is at most twice the standard binary +size of the input value, plus two. -/ +theorem binarySuccTime_le (value : β„•) : + binarySuccTime value ≀ 2 * value.size + 2 := + binarySuccTime_le_internal value + +/-- Starting on a canonical rewound natural number, `binarySuccTM` halts after +exactly `binarySuccTime value` transitions with the canonical representation +of `value + 1`. Input, output, and every unrelated work tape are preserved +exactly. The off-marker hypotheses are precisely what makes the structurally +mandatory idle moves preserve those tape heads. -/ +theorem binarySuccTM_reachesIn_frame {n : β„•} + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binarySuccTM idx).reachesIn (binarySuccTime value) + { state := (binarySuccTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binarySuccTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryNat (value + 1) ∧ + c'.output = outβ‚€ := + binarySuccTM_reachesIn_frame_internal + idx value inpβ‚€ workβ‚€ outβ‚€ hvalue hinp hother hout + +/-- Time-bounded compositional form of `binarySuccTM_reachesIn_frame`. -/ +theorem binarySuccTM_hoareTime_frame {n : β„•} + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binarySuccTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat (value + 1) ∧ + out = outβ‚€) + (binarySuccTime value) := + binarySuccTM_hoareTime_frame_internal + idx value inpβ‚€ workβ‚€ outβ‚€ hvalue hinp hother hout + +/-- Time-and-space contract for canonical successor. The space component +bounds every reachable configuration, not just the terminal one. Starting +from auxiliary-space budget `initialSpace`, one cell per possible transition +gives the explicit bound `initialSpace + binarySuccTime value`. -/ +theorem binarySuccTM_hoareTimeSpace_frame {n : β„•} + (idx : Fin n) (value inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (hinitial : + ({ state := (binarySuccTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binarySuccTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (binarySuccTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat (value + 1) ∧ + out = outβ‚€) + (binarySuccTime value) inputLength + (initialSpace + binarySuccTime value) := + binarySuccTM_hoareTimeSpace_frame_internal idx value inputLength initialSpace + inpβ‚€ workβ‚€ outβ‚€ hvalue hinp hother hout hinitial + +/-- `binarySuccTM` never moves the output head left, so it is safe to use in +one-way-output, space-bounded compositions. -/ +theorem binarySuccTM_isTransducer {n : β„•} (idx : Fin n) : + (binarySuccTM idx).IsTransducer := + binarySuccTM_isTransducer_internal idx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Defs.lean new file mode 100644 index 0000000000..67dc18df55 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Defs.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import Mathlib.Data.Nat.Bits + +/-! +# Little-endian binary successor β€” definitions + +This module defines the canonical tape representation and finite controller +for ripple-carry successor. Natural numbers use `Nat.bits`, whose least +significant bit comes first and whose representation of zero is empty. +Overflow therefore appends one new high bit at the first blank cell. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinarySucc + +/-- Ripple one carry through a little-endian bit string. -/ +def ripple : List Bool β†’ List Bool + | [] => [true] + | false :: rest => true :: rest + | true :: rest => false :: ripple rest + +/-- Exact number of transitions used by `binarySuccTM` on a canonical bit +string. It is twice the successor of the number of initial low-order one bits. -/ +def steps : List Bool β†’ β„• + | [] => 2 + | false :: _ => 2 + | true :: rest => steps rest + 2 + +end BinarySucc + +namespace Tape + +/-- A rewound tape containing the canonical little-endian representation of +one natural number, including its immutable left-end marker. -/ +def HasBinaryNat (t : Tape) (value : β„•) : Prop := + t.cells 0 = Ξ“.start ∧ t.HasBinaryString value.bits + +end Tape + +namespace TM + +/-- Finite phases of ripple-carry successor. -/ +inductive BinarySuccPhase where + | carry + | rewind + | done + deriving DecidableEq + +/-- `BinarySuccPhase` has exactly three states. -/ +instance instFintypeBinarySuccPhase : Fintype BinarySuccPhase where + elems := {.carry, .rewind, .done} + complete := fun state => by cases state <;> simp + +/-- Exact running time of canonical successor on `value.bits`. -/ +def binarySuccTime (value : β„•) : β„• := + BinarySucc.steps value.bits + +/-- Increment the canonical little-endian natural on work tape `idx`. + +The carry phase turns initial one bits into zero bits. The first zero becomes +one; if the carry reaches the terminating blank, one is appended there. The +machine then rewinds to cell one. Input, output, and unrelated work tapes use +the structurally safe read-back/idle action. -/ +def binarySuccTM {n : β„•} (idx : Fin n) : TM n where + Q := BinarySuccPhase + qstart := .carry + qhalt := .done + Ξ΄ := fun phase iHead wHeads oHead => + match phase with + | .carry => + match wHeads idx with + | .zero => + (.rewind, + fun i => if i = idx then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .one => + (.carry, + fun i => if i = idx then Ξ“w.zero else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .blank => + (.rewind, + fun i => if i = idx then Ξ“w.one else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .start => + (.carry, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .rewind => + if wHeads idx = Ξ“.start then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewind, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro phase iHead wHeads oHead + match phase with + | .carry => + dsimp only + match htarget : wHeads idx with + | .zero | .one | .blank => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + rw [htarget] at hi + exact absurd hi (by decide) + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .start => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .rewind => + dsimp only + split + Β· simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· rw [ite_eq_left hitarget] + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + Β· next hnotStart => + simp only + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + by_cases hitarget : i = idx + Β· subst i + exact absurd hi hnotStart + Β· rw [ite_eq_right hitarget] + exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Internal.lean new file mode 100644 index 0000000000..dc4845c8d4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/BinarySucc/Internal.lean @@ -0,0 +1,605 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.BinarySucc.Defs +public import Mathlib.Data.Nat.Size + +/-! +# Little-endian binary successor β€” proof internals + +This file proves the pure ripple semantics and the exact full-frame execution +of `TM.binarySuccTM`. The carry proof uses a private head-independent binary +content predicate, generalized over the already-zeroed low-order prefix. +-/ + + +@[expose] public section + +namespace Complexity + +namespace BinarySucc + +/-- Internal proof that ripple carry computes successor on canonical +little-endian natural-number bits. -/ +theorem ripple_natBits_internal (value : β„•) : + ripple value.bits = (value + 1).bits := by + induction value using Nat.binaryRec' with + | zero => simp [ripple] + | bit bit value hvalue ih => + rw [Nat.bits_append_bit value bit hvalue] + cases bit + Β· simp [ripple, Nat.bit] + Β· simp only [ripple] + rw [show Nat.bit true value + 1 = 2 * (value + 1) by + simp [Nat.bit, Nat.mul_add]] + rw [Nat.bit0_bits (value + 1) (Nat.succ_ne_zero value)] + rw [ih] + +/-- Internal worst-case bound for the exact successor step count. -/ +theorem steps_le_internal (bits : List Bool) : + steps bits ≀ 2 * bits.length + 2 := by + induction bits with + | nil => simp [steps] + | cons bit bits ih => + cases bit + Β· simp [steps] + Β· simp only [steps, List.length_cons] + omega + +end BinarySucc + +namespace Tape + +private theorem HasBinaryContent.read_cons {t : Tape} {done : β„•} + {bit : Bool} {rest : List Bool} + (h : t.HasBinaryContent (List.replicate done false ++ bit :: rest)) + (hhead : t.head = done + 1) : t.read = Ξ“.ofBool bit := by + rw [Tape.read, hhead] + have hcell := h.1 done (by simp) + simpa using hcell + +private theorem HasBinaryContent.read_nil {t : Tape} {done : β„•} + (h : t.HasBinaryContent (List.replicate done false)) + (hhead : t.head = done + 1) : t.read = Ξ“.blank := by + rw [Tape.read, hhead] + exact h.2 done (by simp) + +end Tape + +namespace BinarySucc + +private theorem set_true_to_false (done : β„•) (rest : List Bool) : + (List.replicate done false ++ true :: rest).set done false = + List.replicate (done + 1) false ++ rest := by + induction done with + | zero => rfl + | succ done ih => + change false :: (List.replicate done false ++ true :: rest).set done false = + false :: false :: (List.replicate done false ++ rest) + congr 1 + +private theorem set_false_to_true (done : β„•) (rest : List Bool) : + (List.replicate done false ++ false :: rest).set done true = + List.replicate done false ++ true :: rest := by + induction done with + | zero => rfl + | succ done ih => + change false :: (List.replicate done false ++ false :: rest).set done true = + false :: (List.replicate done false ++ true :: rest) + congr 1 + +end BinarySucc + +namespace TM + +variable {n : β„•} {idx : Fin n} + +private theorem binarySuccTM_ne_halt {phase : BinarySuccPhase} + (hne : phase β‰  .done) {c : Cfg n (binarySuccTM idx).Q} + (hstate : c.state = phase) : + c.state β‰  (binarySuccTM idx).qhalt := by + rw [hstate] + exact hne + +/-- Carry over one low-order one: write zero and advance right. -/ +private theorem binarySuccTM_step_one (c : Cfg n (binarySuccTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Ξ“.one) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binarySuccTM idx).step c = some + { state := .carry + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.zero).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binarySuccTM_ne_halt (by decide) hstate)] + simp only [binarySuccTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Resolve a carry on zero: write one and turn left. -/ +private theorem binarySuccTM_step_zero (c : Cfg n (binarySuccTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Ξ“.zero) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binarySuccTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.one).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binarySuccTM_ne_halt (by decide) hstate)] + simp only [binarySuccTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Resolve overflow on the terminating blank: append one and turn left. -/ +private theorem binarySuccTM_step_blank (c : Cfg n (binarySuccTM idx).Q) + (hstate : c.state = .carry) (hread : (c.work idx).read = Ξ“.blank) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binarySuccTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx + (((c.work idx).write Ξ“.one).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binarySuccTM_ne_halt (by decide) hstate)] + simp only [binarySuccTM, hstate, hread] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + rfl + Β· rw [Function.update_of_ne hi] + simpa only [ite_eq_right hi] using! transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Rewind one ordinary target cell to the left. -/ +private theorem binarySuccTM_step_rewind (c : Cfg n (binarySuccTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read β‰  Ξ“.start) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binarySuccTM idx).step c = some + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } := by + rw [TM.step, ite_eq_right (binarySuccTM_ne_halt (by decide) hstate)] + simp only [binarySuccTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + rw [ite_eq_left rfl, Function.update_self, + writeAndMove_readBack _ hread] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-- Bounce right from the left marker and halt. -/ +private theorem binarySuccTM_step_start (c : Cfg n (binarySuccTM idx).Q) + (hstate : c.state = .rewind) (hread : (c.work idx).read = Ξ“.start) + (hhead : (c.work idx).head = 0) + (hinput : c.input.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (c.work i).read β‰  Ξ“.start) + (houtput : c.output.read β‰  Ξ“.start) : + (binarySuccTM idx).step c = some + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } := by + rw [TM.step, ite_eq_right (binarySuccTM_ne_halt (by decide) hstate)] + simp only [binarySuccTM, hstate, hread, ↓reduceIte] + refine congrArg some ((Cfg.mk.injEq ..).mpr ⟨rfl, ?_, ?_, ?_⟩) + Β· exact transitionInput_eq_self hinput + Β· funext i + by_cases hi : i = idx + Β· subst i + simp only [↓reduceIte, Function.update_self] + show (((c.work idx).write _).move Dir3.right) = + (c.work idx).move Dir3.right + rw [Tape.write, ite_eq_left hhead] + Β· rw [ite_eq_right hi, Function.update_of_ne hi] + exact transitionTape_eq_self (hother i hi) + Β· exact transitionTape_eq_self houtput + +/-! ## Exact rewind and carry runs -/ + +private theorem binarySuccTM_rewind_run (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ head (c : Cfg n (binarySuccTM idx).Q), + c.state = .rewind β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = workβ‚€ i) β†’ + (c.work idx).HasBinaryContent bits β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (c.work idx).head = head β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binarySuccTM idx).reachesIn (head + 1) c c' ∧ + (binarySuccTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryString bits ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro head + induction head with + | zero => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.start := by + rw [Tape.read, hhead] + exact hcell0 + have hstep := binarySuccTM_step_start c hstate hread hhead + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binarySuccTM idx).Q := + { state := .done + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.right) + output := c.output } + refine ⟨c₁, .step hstep .zero, rfl, hinput, ?_, ?_, ?_, houtput⟩ + Β· intro i hi + show Function.update c.work idx ((c.work idx).move Dir3.right) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi + Β· show (Function.update c.work idx ((c.work idx).move Dir3.right) idx) + |>.HasBinaryString bits + rw [Function.update_self] + apply Tape.HasBinaryContent.hasBinaryString + Β· simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent + Β· simp [Tape.move, hhead] + Β· show (Function.update c.work idx ((c.work idx).move Dir3.right) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0 + | succ head ih => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read β‰  Ξ“.start := by + rw [Tape.read, hhead] + exact hcontent.cells_ne_start (head + 1) (by omega) + have hstep := binarySuccTM_step_rewind c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let c₁ : Cfg n (binarySuccTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx ((c.work idx).move Dir3.left) + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx ((c.work idx).move Dir3.left) i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx) + |>.HasBinaryContent bits + rw [Function.update_self] + simpa only [Tape.HasBinaryContent, Tape.move_cells] using hcontent) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).cells 0 = _ + rw [Function.update_self, Tape.move_cells] + exact hcell0) + (by + show (Function.update c.work idx ((c.work idx).move Dir3.left) idx).head = head + rw [Function.update_self] + simp [Tape.move, hhead]) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ + simpa [Nat.succ_eq_add_one, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + +private theorem binarySuccTM_carry_run + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆ€ done bits (c : Cfg n (binarySuccTM idx).Q), + c.state = .carry β†’ + c.input = inpβ‚€ β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = workβ‚€ i) β†’ + (c.work idx).HasBinaryContent (List.replicate done false ++ bits) β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (c.work idx).head = done + 1 β†’ + c.output = outβ‚€ β†’ + βˆƒ c', + (binarySuccTM idx).reachesIn (done + BinarySucc.steps bits) c c' ∧ + (binarySuccTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryString + (List.replicate done false ++ BinarySucc.ripple bits) ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + c'.output = outβ‚€ := by + intro done bits + induction bits generalizing done with + | nil => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hcontent' : (c.work idx).HasBinaryContent (List.replicate done false) := by + simpa using hcontent + have hread : (c.work idx).read = Ξ“.blank := + hcontent'.read_nil hhead + have hstep := binarySuccTM_step_blank c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Ξ“.one).move Dir3.left + have htargetContent : target.HasBinaryContent + (List.replicate done false ++ [true]) := by + have hwrite := hcontent'.write_append true (by simpa using hhead) + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using! hwrite + have htargetCell0 : target.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.one Dir3.left hcell0 + have htargetHead : target.head = done := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binarySuccTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binarySuccTM_rewind_run (idx := idx) + (List.replicate done false ++ [true]) inpβ‚€ workβ‚€ outβ‚€ hinp hother hout + done c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = done + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· simpa [BinarySucc.steps, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + Β· simpa [BinarySucc.ripple] using hstring + | cons bit rest ih => + cases bit with + | false => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.zero := + hcontent.read_cons hhead + have hstep := binarySuccTM_step_zero c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Ξ“.one).move Dir3.left + have htargetContent : target.HasBinaryContent + (List.replicate done false ++ true :: rest) := by + have hwrite := hcontent.write_set true hhead (by simp) + rw [BinarySucc.set_false_to_true] at hwrite + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using! hwrite + have htargetCell0 : target.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.one Dir3.left hcell0 + have htargetHead : target.head = done := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binarySuccTM idx).Q := + { state := .rewind + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + binarySuccTM_rewind_run (idx := idx) + (List.replicate done false ++ true :: rest) + inpβ‚€ workβ‚€ outβ‚€ hinp hother hout done c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = done + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· simpa [BinarySucc.steps, Nat.add_assoc] using + (TM.reachesIn.step hstep hreach) + Β· simpa [BinarySucc.ripple] using hstring + | true => + intro c hstate hinput hwork hcontent hcell0 hhead houtput + have hread : (c.work idx).read = Ξ“.one := + hcontent.read_cons hhead + have hstep := binarySuccTM_step_one c hstate hread + (by rw [hinput]; exact hinp) + (fun i hi => by rw [hwork i hi]; exact hother i hi) + (by rw [houtput]; exact hout) + let target : Tape := ((c.work idx).write Ξ“.zero).move Dir3.right + have htargetContent : target.HasBinaryContent + (List.replicate (done + 1) false ++ rest) := by + have hwrite := hcontent.write_set false hhead (by simp) + rw [BinarySucc.set_true_to_false] at hwrite + simpa only [target, Tape.HasBinaryContent, Tape.move_cells] using! hwrite + have htargetCell0 : target.cells 0 = Ξ“.start := by + exact Tape.write_move_cell0 Ξ“.zero Dir3.right hcell0 + have htargetHead : target.head = (done + 1) + 1 := by + simp [target, Tape.move, Tape.write_head, hhead] + let c₁ : Cfg n (binarySuccTM idx).Q := + { state := .carry + input := c.input + work := Function.update c.work idx target + output := c.output } + obtain ⟨c', hreach, hhalt, hinput', hwork', hstring, hcell0', houtput'⟩ := + ih (done + 1) c₁ rfl hinput + (fun i hi => by + show Function.update c.work idx target i = workβ‚€ i + rw [Function.update_of_ne hi] + exact hwork i hi) + (by + show (Function.update c.work idx target idx).HasBinaryContent _ + rw [Function.update_self] + exact htargetContent) + (by + show (Function.update c.work idx target idx).cells 0 = _ + rw [Function.update_self] + exact htargetCell0) + (by + show (Function.update c.work idx target idx).head = (done + 1) + 1 + rw [Function.update_self] + exact htargetHead) + houtput + refine ⟨c', ?_, hhalt, hinput', hwork', ?_, hcell0', houtput'⟩ + Β· convert! TM.reachesIn.step hstep hreach using 1 + all_goals simp [BinarySucc.steps, Nat.add_assoc] + all_goals omega + Β· simpa [BinarySucc.ripple, List.replicate_add, + List.append_assoc] using hstring + +/-! ## Public-theorem internals -/ + +theorem binarySuccTime_le_internal (value : β„•) : + binarySuccTime value ≀ 2 * value.size + 2 := by + simpa [binarySuccTime, Nat.size_eq_bits_len] using + BinarySucc.steps_le_internal value.bits + +theorem binarySuccTM_reachesIn_frame_internal + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + βˆƒ c', + (binarySuccTM idx).reachesIn (binarySuccTime value) + { state := (binarySuccTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } c' ∧ + (binarySuccTM idx).halted c' ∧ + c'.input = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = workβ‚€ i) ∧ + (c'.work idx).HasBinaryNat (value + 1) ∧ + c'.output = outβ‚€ := by + let cβ‚€ : Cfg n (binarySuccTM idx).Q := + { state := (binarySuccTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } + obtain ⟨c', hreach, hhalt, hinput, hwork, hstring, hcell0, houtput⟩ := + binarySuccTM_carry_run (idx := idx) inpβ‚€ workβ‚€ outβ‚€ hinp hother hout + 0 value.bits cβ‚€ (by rfl) (by rfl) (fun _ _ => rfl) + (by simpa [cβ‚€] using hvalue.2.hasBinaryContent) hvalue.1 + (by simpa [cβ‚€] using hvalue.2.1) (by rfl) + refine ⟨c', ?_, hhalt, hinput, hwork, ?_, houtput⟩ + Β· simpa [cβ‚€, binarySuccTime] using hreach + Β· exact ⟨hcell0, by + simpa [BinarySucc.ripple_natBits_internal] using hstring⟩ + +theorem binarySuccTM_hoareTime_frame_internal + (idx : Fin n) (value : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) : + (binarySuccTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat (value + 1) ∧ + out = outβ‚€) + (binarySuccTime value) := by + rintro inp work out ⟨hinputβ‚€, hworkβ‚€, houtputβ‚€βŸ© + obtain ⟨c', hreach, hhalt, hinput, hwork, hvalue', houtput⟩ := + binarySuccTM_reachesIn_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout + refine ⟨c', binarySuccTime value, le_rfl, ?_, hhalt, + hinput, hwork, hvalue', houtput⟩ + simpa [hinputβ‚€, hworkβ‚€, houtputβ‚€] using hreach + +theorem binarySuccTM_hoareTimeSpace_frame_internal + (idx : Fin n) (value inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hvalue : (workβ‚€ idx).HasBinaryNat value) + (hinp : inpβ‚€.read β‰  Ξ“.start) + (hother : βˆ€ i, i β‰  idx β†’ (workβ‚€ i).read β‰  Ξ“.start) + (hout : outβ‚€.read β‰  Ξ“.start) + (hinitial : + ({ state := (binarySuccTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (binarySuccTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (binarySuccTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + (work idx).HasBinaryNat (value + 1) ∧ + out = outβ‚€) + (binarySuccTime value) inputLength + (initialSpace + binarySuccTime value) := by + apply (binarySuccTM_hoareTime_frame_internal idx value inpβ‚€ workβ‚€ outβ‚€ + hvalue hinp hother hout).toHoareTimeSpace + rintro inp work out ⟨hinputβ‚€, hworkβ‚€, houtputβ‚€βŸ© + simpa [hinputβ‚€, hworkβ‚€, houtputβ‚€] using hinitial + +theorem binarySuccTM_isTransducer_internal (idx : Fin n) : + (binarySuccTM idx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | carry => + cases hread : wHeads idx <;> + simp [binarySuccTM, hread, idleDir] <;> + split <;> decide + | rewind => + simp only [binarySuccTM] + split <;> simp [idleDir] <;> split <;> decide + | done => + simp [binarySuccTM, allIdle, idleDir] + split <;> decide + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork.lean new file mode 100644 index 0000000000..317828107a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Internal + +/-! +# Clearing a binary work tape + +This module exposes a literal-frame contract for erasing a canonical Boolean +work tape and returning its head to cell one. It also records the one-way-output +discipline of the clearing, rewinding, and composite machines. + +## Main results + +- `clearWorkTM_hoareTime_frame` β€” clear and rewind with a full external frame. +- `clearWorkTM_hoareTimeSpace_frame` β€” the corresponding all-prefix space contract. +- `clearWorkTM_isTransducer` β€” clearing never moves the output head left. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- Clearing a canonical Boolean work tape preserves the input, output, and +every unrelated work tape literally, and resets the target to the standard +parked blank tape within `2 * bits.length + 5` steps. -/ +theorem clearWorkTM_hoareTime_frame + (idx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : workβ‚€ idx = + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (clearWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (clearWorkTimeBound bits.length) := + clearWorkTM_hoareTime_frame_internal idx bits inpβ‚€ workβ‚€ outβ‚€ + htarget hinp hother hout + +/-- Time-and-space form of `clearWorkTM_hoareTime_frame`. Starting from an +`initialSpace` budget, one extra cell per possible transition yields an honest +all-reachable bound. -/ +theorem clearWorkTM_hoareTimeSpace_frame + (idx : Fin n) (bits : List Bool) (inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : workβ‚€ idx = + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hinitial : + ({ state := (clearWorkTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (clearWorkTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (clearWorkTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (clearWorkTimeBound bits.length) inputLength + (initialSpace + clearWorkTimeBound bits.length) := + clearWorkTM_hoareTimeSpace_frame_internal idx bits inputLength initialSpace + inpβ‚€ workβ‚€ outβ‚€ htarget hinp hother hout hinitial + +/-- Blanking a work tape never moves the output head left. -/ +theorem blankWorkTM_isTransducer (idx : Fin n) : + (blankWorkTM idx).IsTransducer := + blankWorkTM_isTransducer_internal idx + +/-- Rewinding a work tape never moves the output head left. -/ +theorem rewindWorkTM_isTransducer (idx : Fin n) : + (rewindWorkTM idx).IsTransducer := + rewindWorkTM_isTransducer_internal idx + +/-- Clearing and rewinding a work tape never moves the output head left. -/ +theorem clearWorkTM_isTransducer (idx : Fin n) : + (clearWorkTM idx).IsTransducer := + clearWorkTM_isTransducer_internal idx + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Defs.lean new file mode 100644 index 0000000000..02e66becfb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Defs.lean @@ -0,0 +1,35 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Finset.Attr +public import Mathlib.Data.Nat.Notation +public import Mathlib.Tactic.Finiteness.Attr +public import Mathlib.Tactic.SetLike +public import Mathlib.Tactic.ToAdditive + +/-! +# Clearing a binary work tape β€” definitions + +This module names the concrete time bound used by the public framed contract +for `TM.clearWorkTM`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Concrete running-time bound for clearing and rewinding a Boolean work tape +whose represented string has `length` bits. -/ +def clearWorkTimeBound (length : β„•) : β„• := + 2 * length + 5 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Internal.lean new file mode 100644 index 0000000000..a8f80eae69 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ClearWork/Internal.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Space +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal + +/-! +# Clearing a binary work tape β€” proof internals + +This module packages the legacy rich clear/rewind proof behind a literal frame +contract and proves that its component machines never move the output head +left. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +theorem clearWorkTM_hoareTime_frame_internal + (idx : Fin n) (bits : List Bool) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : workβ‚€ idx = + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) : + (clearWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (clearWorkTimeBound bits.length) := by + let Frame : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ out = outβ‚€ + have hclear := clearWorkTM_hoareTime_frame_of_binaryString idx bits + (P := Frame) (by + intro inp work out inp' work' out' hframe _htarget hinp' hout' hwork' + rcases hframe with ⟨hinpβ‚€, hworkβ‚€, houtβ‚€βŸ© + refine ⟨hinp'.trans hinpβ‚€, ?_, hout'.trans houtβ‚€βŸ© + intro i hi + exact (hwork' i hi).trans (hworkβ‚€ i hi)) + refine hclear.consequence ?_ ?_ (by simp [clearWorkTimeBound]; omega) + Β· rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨htarget, hinp.read_ne_start, hout.read_ne_start, hout.1, ?_, ?_⟩ + Β· intro i hi + exact ⟨(hother i hi).read_ne_start, (hother i hi).1⟩ + Β· exact ⟨rfl, fun _ _ => rfl, rfl⟩ + Β· rintro inp work out ⟨htarget', hinp', hother', hout'⟩ + refine ⟨hinp', ?_, hout'⟩ + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + exact htarget' + Β· rw [Function.update_of_ne hi] + exact hother' i hi + +theorem clearWorkTM_hoareTimeSpace_frame_internal + (idx : Fin n) (bits : List Bool) (inputLength initialSpace : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : workβ‚€ idx = + (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right) + (hinp : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (hout : Parked outβ‚€) + (hinitial : + ({ state := (clearWorkTM idx).qstart + input := inpβ‚€ + work := workβ‚€ + output := outβ‚€ } : + Cfg n (clearWorkTM idx).Q).WithinAuxSpace inputLength initialSpace) : + (clearWorkTM idx).HoareTimeSpace + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx + ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (clearWorkTimeBound bits.length) inputLength + (initialSpace + clearWorkTimeBound bits.length) := by + apply (clearWorkTM_hoareTime_frame_internal idx bits inpβ‚€ workβ‚€ outβ‚€ + htarget hinp hother hout).toHoareTimeSpace + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact hinitial + +theorem blankWorkTM_isTransducer_internal (idx : Fin n) : + (blankWorkTM idx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | scanning => + simp only [blankWorkTM] + split <;> simp [idleDir] <;> split <;> decide + | done => + simp [blankWorkTM, allIdle, idleDir] + split <;> decide + +theorem rewindWorkTM_isTransducer_internal (idx : Fin n) : + (rewindWorkTM idx).IsTransducer := by + intro phase iHead wHeads oHead + cases phase with + | moveLeft => + simp only [rewindWorkTM] + split <;> simp [idleDir] <;> split <;> decide + | moveRight => + simp [rewindWorkTM, idleDir] + split <;> decide + | done => + simp [rewindWorkTM, allIdle, idleDir] + split <;> decide + +theorem clearWorkTM_isTransducer_internal (idx : Fin n) : + (clearWorkTM idx).IsTransducer := + (blankWorkTM_isTransducer_internal idx).seqTM + (rewindWorkTM_isTransducer_internal idx) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyOutput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyOutput.lean new file mode 100644 index 0000000000..32077bea0f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyOutput.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyOutput + +/-! +# Input-to-output copy subroutine + +Public correctness theorem for `TM.copyInputToOutputTM`. The machine copies +its Boolean input verbatim to its output tape in the exact linear bound +`|x| + 2`, without using the contents of its fixed work-tape bank. + +## Main result + +- `TM.copyInputToOutputTM_computesInTime` β€” the copy machine computes `id` + within time `m + 2` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The input-to-output copy machine computes the identity function within +the exact linear time bound `m + 2`. -/ +theorem copyInputToOutputTM_computesInTime (n : β„•) : + (copyInputToOutputTM (n := n)).ComputesInTime id (fun m => m + 2) := by + exact copyInputToOutputTM_computesInTime_internal n + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean new file mode 100644 index 0000000000..24842c43c0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetTapes + +/-! +# Copying a value into virtual-input shape + +`TM.retargetInputStartedCfg` expects the virtual-input work tape in the exact +shape `(Tape.init (y.map Ξ“.ofBool)).move Dir3.right` β€” head parked at cell `1`. +A value produced elsewhere lands with its head *past* its content, so one more +rewind closes the gap. + +## Main results + +- `TM.copyToVirtualInputTM` β€” move a value into virtual-input position +- `TM.copyToVirtualInputTM_hoareTime` β€” its contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Copy the value held at `src` into `dst`, then rewind `dst` to cell `1` β€” +the exact shape `retargetInputStartedCfg` expects of a virtual input. Every +tape besides `src`/`dst`, the real input, and the real output are held at +fixed `Parked` values throughout. -/ +theorem copyToVirtualInput_hoareTime {n : β„•} (src dst : Fin n) (hne : src β‰  dst) + (x : List Bool) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrcHead : (workβ‚€ src).head = 1) (hsrcOut : (workβ‚€ src).HasOutput x) + (hsrcParked : Parked (workβ‚€ src)) + (hdst : workβ‚€ dst = (Tape.init []).move Dir3.right) + (hinp : Parked inpβ‚€) (hout : Parked outβ‚€) + (hother : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ Parked (workβ‚€ i)) : + (seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + work dst = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + (work src).cells = (workβ‚€ src).cells ∧ + (work src).head = x.length + 1 ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i)) + (2 * x.length + 5) := by + have hP : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + (inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i) β†’ + (work' src).cells = (workβ‚€ src).cells β†’ + (work' src).head = x.length + 1 β†’ + (work' src).HasOutput x β†’ + (work' dst).HasBinaryPrefix x β†’ + (work' dst).cells 0 = Ξ“.start β†’ + inp' = inp β†’ out' = out β†’ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = work i) β†’ + (inp' = inpβ‚€ ∧ out' = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = workβ‚€ i) := by + rintro inp work out inp' work' out' ⟨rfl, rfl, hrest⟩ _ _ _ _ _ rfl rfl hkeep + exact ⟨rfl, rfl, fun i hisrc hidst => (hkeep i hisrc hidst).trans (hrest i hisrc hidst)⟩ + have hcopy := copyWorkToWorkTM_hoareTime_frame_of_hasOutput src dst hne x (workβ‚€ src) hP + have hpre_imp : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape), + (inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) β†’ + (work src = workβ‚€ src ∧ (workβ‚€ src).head = 1 ∧ (workβ‚€ src).HasOutput x ∧ + work dst = (Tape.init []).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ out.read β‰  Ξ“.start ∧ 1 ≀ out.head ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ (work i).read β‰  Ξ“.start ∧ 1 ≀ (work i).head) ∧ + (inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i)) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨rfl, hsrcHead, hsrcOut, hdst, hinp.read_ne_start, hout.read_ne_start, hout.1, + fun i hisrc hidst => ⟨(hother i hisrc hidst).read_ne_start, (hother i hisrc hidst).1⟩, + rfl, rfl, fun i _ _ => rfl⟩ + have h₁ := hcopy.weaken_pre hpre_imp + have hP2 : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + ((work dst).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work src).cells = (workβ‚€ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i) β†’ + (work' dst).cells = (work dst).cells β†’ + (work' dst).head = 1 β†’ + (βˆ€ i, i β‰  dst β†’ work' i = work i) β†’ + inp' = inp β†’ + out'.cells = out.cells β†’ + out'.head = out.head β†’ + ((work' dst).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work' src).cells = (workβ‚€ src).cells ∧ + (work' src).head = x.length + 1 ∧ + inp' = inpβ‚€ ∧ out' = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = workβ‚€ i) := by + rintro inp work out inp' work' out' ⟨hcellsP, hsc, hsh, rfl, rfl, hrest⟩ hcells' _ hkeep rfl + hout'c hout'h + refine ⟨hcells'.trans hcellsP, ?_, ?_, rfl, Tape.ext hout'h hout'c, + fun i hisrc hidst => (hkeep i hidst).trans (hrest i hisrc hidst)⟩ + Β· rw [hkeep src hne]; exact hsc + Β· rw [hkeep src hne]; exact hsh + have hβ‚‚ := rewindWorkTM_hoareTime_frame (n := n) dst (x.length + 1) + (P := fun inp work out => + (work dst).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work src).cells = (workβ‚€ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i) hP2 + have hcomb : (seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => (work dst).head = 1 ∧ + (work dst).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work src).cells = (workβ‚€ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work i = workβ‚€ i) + (2 * x.length + 5) := by + refine (seqTM_hoareTime (copyWorkToWorkTM src dst) (rewindWorkTM dst) h₁ ?_ hβ‚‚).mono_bound + (by omega) + rintro inp work out ⟨hcells, hhead, hout_, hprefix, hcell0, hPinp, hPout, hPrest⟩ + have hread_src : (work src).read β‰  Ξ“.start := by + show (work src).cells (work src).head β‰  Ξ“.start + rw [hhead, hcells] + exact hsrcParked.2 (x.length + 1) (by omega) + have hread_dst : (work dst).read β‰  Ξ“.start := by + rw [hprefix.read_blank]; decide + have hread_other : βˆ€ i, i β‰  dst β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1 := by + intro i hidst + by_cases hisrc : i = src + Β· subst hisrc; exact ⟨hread_src, by omega⟩ + Β· rw [hPrest i hisrc hidst] + exact ⟨(hother i hisrc hidst).read_ne_start, (hother i hisrc hidst).1⟩ + have hinp_ns : inp.read β‰  Ξ“.start := by rw [hPinp]; exact hinp.read_ne_start + have hout_ns : out.read β‰  Ξ“.start := by rw [hPout]; exact hout.read_ne_start + have ht1 : transitionInput inp = inp := transitionInput_eq_self hinp_ns + have ht2 : (fun i => transitionTape (work i)) = work := + funext fun i => by + by_cases hidst : i = dst + Β· subst hidst; exact transitionTape_eq_self hread_dst + Β· exact transitionTape_eq_self (hread_other i hidst).1 + have ht3 : transitionTape out = out := transitionTape_eq_self hout_ns + rw [ht1, ht2, ht3] + have hcellsP : (work dst).cells = (Tape.init (x.map Ξ“.ofBool)).cells := + hprefix.cells_eq_init hcell0 + refine ⟨hcell0, ?_, le_of_eq hprefix.1, hinp_ns, hout_ns, ?_, + fun i hidst => hread_other i hidst, + hcellsP, hcells, hhead, hPinp, hPout, hPrest⟩ + Β· intro j hj + have hj1 : j - 1 + 1 = j := by omega + by_cases hle : j ≀ x.length + Β· rw [← hj1, hprefix.2.1 (j - 1) (by omega)] + cases x[j - 1]'(by omega) <;> decide + Β· rw [← hj1, hprefix.2.2 (j - 1) (by omega)] + decide + Β· rw [hPout]; exact hout.1 + exact hcomb.strengthen_post (by + rintro inp work out ⟨hhead1, hcellsP, hsc, hsh, hPinp, hPout, hPrest⟩ + exact ⟨hPinp, hPout, Tape.ext hhead1 hcellsP, hsc, hsh, hPrest⟩) + +/-- Copy a work tape's value into another and park the result at cell `1`. -/ +def copyToVirtualInputTM {n : β„•} (src dst : Fin n) : TM n := + seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst) + +/-- **The copy, with the whole tape family pinned down.** The source keeps its +cells but ends with its head past the copied value; the destination holds the +value parked at cell `1`; nothing else moves. This determined form is what +`TM.seqTM_det` chains. -/ +theorem copyToVirtualInputTM_hoareTime {n : β„•} (src dst : Fin n) (hne : src β‰  dst) + (x : List Bool) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hsrcHead : (workβ‚€ src).head = 1) (hsrcOut : (workβ‚€ src).HasOutput x) + (hsrcParked : Parked (workβ‚€ src)) + (hdst : workβ‚€ dst = (Tape.init []).move Dir3.right) + (hinp : Parked inpβ‚€) (hout : Parked outβ‚€) + (hother : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ Parked (workβ‚€ i)) : + (copyToVirtualInputTM src dst).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (Function.update workβ‚€ dst + ((Tape.init (x.map Ξ“.ofBool)).move Dir3.right)) + src (⟨x.length + 1, (workβ‚€ src).cells⟩ : Tape) ∧ + out = outβ‚€) + (2 * x.length + 5) := by + refine (copyToVirtualInput_hoareTime src dst hne x inpβ‚€ workβ‚€ outβ‚€ hsrcHead hsrcOut + hsrcParked hdst hinp hout hother).strengthen_post ?_ + rintro inp work out ⟨hi, ho, hd, hsc, hsh, hrest⟩ + refine ⟨hi, ?_, ho⟩ + funext j + by_cases hjs : j = src + Β· rw [hjs, Function.update_self] + exact Tape.ext (hjs β–Έ hsh) (hjs β–Έ hsc) + Β· rw [Function.update_of_ne hjs] + by_cases hjd : j = dst + Β· rw [hjd, Function.update_self] + exact hjd β–Έ hd + Β· rw [Function.update_of_ne hjd] + exact hrest j hjs hjd + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyWorkOutput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyWorkOutput.lean new file mode 100644 index 0000000000..006b09158d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/CopyWorkOutput.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal.CopyWorkOutput + +/-! +# Copy a raw work-tape output + +These theorems let `TM.copyWorkToWorkTM` consume a source satisfying +`Tape.HasOutput`, even when cells after the terminating blank contain arbitrary +junk. The fresh destination receives a canonical `Tape.HasBinaryPrefix`. + +## Main results + +- `TM.copyWorkToWorkTM_reachesIn_of_hasOutput` β€” exact concrete copy run +- `TM.copyWorkToWorkTM_hoareTime_of_hasOutput` β€” exact raw-output copy +- `TM.copyWorkToWorkTM_hoareTime_frame_of_hasOutput` β€” copy with frame preservation +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Starting at cell one, copy exactly the source's advertised output in +`|x| + 1` steps, preserving all source cells and the destination's cell zero. -/ +theorem copyWorkToWorkTM_reachesIn_of_hasOutput {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) + {inp out : Tape} {work : Fin n β†’ Tape} + (hsrcHead : (work src).head = 1) + (hsrcOutput : (work src).HasOutput x) + (hdst : (work dst).HasBinaryPrefix []) : + βˆƒ c', + (copyWorkToWorkTM src dst).reachesIn (x.length + 1) + { state := (copyWorkToWorkTM src dst).qstart, + input := inp, work := work, output := out } c' ∧ + (copyWorkToWorkTM src dst).halted c' ∧ + (c'.work src).cells = (work src).cells ∧ + (c'.work src).head = x.length + 1 ∧ + (c'.work src).HasOutput x ∧ + (c'.work dst).HasBinaryPrefix x ∧ + (c'.work dst).cells 0 = (work dst).cells 0 := by + exact copyWorkToWorkTM_reachesIn_of_hasOutput_internal + src dst hne x hsrcHead hsrcOutput hdst + +/-- Copy a raw `HasOutput` source to a fresh destination in exactly the usual +linear bound. Source cells are preserved, including arbitrary trailing junk. -/ +theorem copyWorkToWorkTM_hoareTime_of_hasOutput {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (source : Tape) : + (copyWorkToWorkTM src dst).HoareTime + (fun _inp work _out => + work src = source ∧ source.head = 1 ∧ source.HasOutput x ∧ + (work dst).HasBinaryPrefix []) + (fun _inp work _out => + (work src).cells = source.cells ∧ + (work src).head = x.length + 1 ∧ + (work src).HasOutput x ∧ + (work dst).HasBinaryPrefix x) + (x.length + 1) := by + exact copyWorkToWorkTM_hoareTime_of_hasOutput_internal src dst hne x source + +/-- Frame-rich raw-output copy. The input, output, and unrelated work tapes +are preserved exactly while the source is copied to the fresh destination. -/ +theorem copyWorkToWorkTM_hoareTime_frame_of_hasOutput {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (source : Tape) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' src).cells = source.cells β†’ + (work' src).head = x.length + 1 β†’ + (work' src).HasOutput x β†’ + (work' dst).HasBinaryPrefix x β†’ + (work' dst).cells 0 = Ξ“.start β†’ + inp' = inp β†’ out' = out β†’ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = work i) β†’ + P inp' work' out') : + (copyWorkToWorkTM src dst).HoareTime + (fun inp work out => + work src = source ∧ source.head = 1 ∧ source.HasOutput x ∧ + work dst = (Tape.init []).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ out.read β‰  Ξ“.start ∧ 1 ≀ out.head ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ + (work i).read β‰  Ξ“.start ∧ 1 ≀ (work i).head) ∧ + P inp work out) + (fun inp work out => + (work src).cells = source.cells ∧ + (work src).head = x.length + 1 ∧ + (work src).HasOutput x ∧ + (work dst).HasBinaryPrefix x ∧ + (work dst).cells 0 = Ξ“.start ∧ + P inp work out) + (x.length + 1) := by + exact copyWorkToWorkTM_hoareTime_frame_of_hasOutput_internal + src dst hne x source hP + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Counter.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Counter.lean new file mode 100644 index 0000000000..d8fc3b6fcb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Counter.lean @@ -0,0 +1,1303 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# Counter-building TM subroutines + +Deterministic helper machines for materializing unary counters on work tapes. + +The SAT-specific NP construction only needs a linear witness bound: +`assignment.length ≀ input.length + 1`. This file defines a small machine +that writes exactly `|input| + 1` unary marks to a designated counter tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Tape + +/-- A counter tape while it is being built: cells `1..used` contain unary + marks, the head is at cell `used + 1`, and the tail from that cell onward + is blank. -/ +def HasUnaryPrefix (t : Tape) (used : β„•) : Prop := + t.head = used + 1 ∧ + (βˆ€ i, i < used β†’ t.cells (i + 1) = Ξ“.one) ∧ + (βˆ€ i, used ≀ i β†’ t.cells (i + 1) = Ξ“.blank) + +/-- An empty tape moved one cell right has the empty unary prefix: the head is + at cell 1 and every cell after `β–·` is blank. -/ +theorem init_nil_move_right_hasUnaryPrefix_zero : + ((Tape.init []).move Dir3.right).HasUnaryPrefix 0 := by + simp [HasUnaryPrefix, Tape.init, Tape.move] + +/-- Writing one mark at the current head and moving right extends a unary + prefix by one cell. -/ +theorem hasUnaryPrefix_write_one {t : Tape} {used : β„•} + (h : t.HasUnaryPrefix used) : + (t.writeAndMove Ξ“.one Dir3.right).HasUnaryPrefix (used + 1) := by + refine ⟨?_, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.write, Tape.move, h.1] + Β· intro i hi + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + by_cases hidx : i = used + Β· have hcellidx : i + 1 = t.head := by rw [h.1, hidx] + rw [hcellidx, Function.update_self] + Β· have hi_used : i < used := by omega + have hcell := h.2.1 i hi_used + have hne : t.head β‰  i + 1 := by rw [h.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact hcell + Β· intro i hi + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  i + 1 := by rw [h.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact h.2.2 i (by omega) + +/-- Writing the next unary mark preserves the left-end marker cell. -/ +theorem hasUnaryPrefix_write_one_cell0 {t : Tape} {used : β„•} + (h : t.HasUnaryPrefix used) (h0 : t.cells 0 = Ξ“.start) : + (t.writeAndMove Ξ“.one Dir3.right).cells 0 = Ξ“.start := by + unfold Tape.writeAndMove + rw [Tape.move_cells] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  0 := by rw [h.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact h0 + +/-- A unary prefix never contains `β–·` after the left-end marker. -/ +theorem hasUnaryPrefix_cells_ne_start {t : Tape} {used : β„•} + (h : t.HasUnaryPrefix used) : + βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start := by + intro j hj + let i := j - 1 + have hj_eq : j = i + 1 := by omega + by_cases hi : i < used + Β· rw [hj_eq, h.2.1 i hi] + decide + Β· have hge : used ≀ i := by omega + rw [hj_eq, h.2.2 i hge] + decide + +/-- A unary counter tape positioned at its first data cell. + +`HasUnaryCounter t B` means cells `1..B` contain `1`, cell `B+1` is blank, +and the head is at cell `1`. -/ +def HasUnaryCounter (t : Tape) (B : β„•) : Prop := + t.head = 1 ∧ + (βˆ€ i, i < B β†’ t.cells (i + 1) = Ξ“.one) ∧ + t.cells (B + 1) = Ξ“.blank + +/-- Rewinding a built unary prefix to cell 1 yields the public counter shape. -/ +theorem hasUnaryCounter_of_hasUnaryPrefix {t t' : Tape} {B : β„•} + (hprefix : t.HasUnaryPrefix B) + (hhead : t'.head = 1) + (hcells : t'.cells = t.cells) : + t'.HasUnaryCounter B := by + refine ⟨hhead, ?_, ?_⟩ + Β· intro i hi + rw [hcells] + exact hprefix.2.1 i hi + Β· rw [hcells] + exact hprefix.2.2 B le_rfl + +/-- A tape holding a zero-length unary counter reads blank at its head. -/ +theorem hasUnaryCounter_read_zero {t : Tape} + (h : t.HasUnaryCounter 0) : t.read = Ξ“.blank := by + simp [Tape.read, h.1, h.2.2] + +/-- A tape holding a positive-length unary counter reads `1` at its head. -/ +theorem hasUnaryCounter_read_pos {t : Tape} {B : β„•} + (h : t.HasUnaryCounter B) (hB : 0 < B) : t.read = Ξ“.one := by + have hcell := h.2.1 0 hB + simp [Tape.read, h.1, hcell] + +/-- Counter shape after `used` marks have already been consumed. The head is +at the next unconsumed counter cell, previous cells are blanked, remaining +marks are `1`, and the first cell after the total bound is blank. -/ +def HasCounterRemainder (t : Tape) (used total : β„•) : Prop := + used ≀ total ∧ + t.head = used + 1 ∧ + (βˆ€ i, i < used β†’ t.cells (i + 1) = Ξ“.blank) ∧ + (βˆ€ i, used ≀ i β†’ i < total β†’ t.cells (i + 1) = Ξ“.one) ∧ + t.cells (total + 1) = Ξ“.blank + +/-- A fresh unary counter is exactly a counter remainder with zero marks + consumed. -/ +theorem hasUnaryCounter_iff_remainder_zero {t : Tape} {B : β„•} : + t.HasUnaryCounter B ↔ t.HasCounterRemainder 0 B := by + constructor + Β· intro h + refine ⟨Nat.zero_le B, h.1, ?_, ?_, h.2.2⟩ + Β· intro i hi + omega + Β· intro i _ hi + exact h.2.1 i hi + Β· intro h + exact ⟨h.2.1, fun i hi => h.2.2.2.1 i (by omega) hi, h.2.2.2.2⟩ + +/-- Once all counter marks are consumed, the head reads blank. -/ +theorem hasCounterRemainder_read_blank_of_done {t : Tape} {B : β„•} + (h : t.HasCounterRemainder B B) : t.read = Ξ“.blank := by + simp [Tape.read, h.2.1, h.2.2.2.2] + +/-- While counter marks remain unconsumed, the head reads `1`. -/ +theorem hasCounterRemainder_read_one_of_remaining {t : Tape} {used total : β„•} + (h : t.HasCounterRemainder used total) (hlt : used < total) : + t.read = Ξ“.one := by + have hcell := h.2.2.2.1 used (le_rfl) hlt + simp [Tape.read, h.2.1, hcell] + +/-- A well-shaped counter remainder never reads the left-end marker. -/ +theorem hasCounterRemainder_read_ne_start {t : Tape} {used total : β„•} + (h : t.HasCounterRemainder used total) : t.read β‰  Ξ“.start := by + by_cases hremaining : used < total + Β· rw [hasCounterRemainder_read_one_of_remaining h hremaining] + decide + Β· have hle : used ≀ total := h.1 + have hdone : used = total := by omega + subst total + rw [hasCounterRemainder_read_blank_of_done h] + decide + +/-- Blanking the current counter mark and moving right advances the unary + counter remainder by one. -/ +theorem hasCounterRemainder_consume {t : Tape} {used total : β„•} + (h : t.HasCounterRemainder used total) (hlt : used < total) : + (t.writeAndMove Ξ“.blank Dir3.right).HasCounterRemainder (used + 1) total := by + refine ⟨by omega, ?_, ?_, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.write, Tape.move, h.2.1] + Β· intro i hi + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.2.1]; omega + simp only [hhead_ne, ↓reduceIte] + by_cases hidx : i = used + Β· have hcellidx : i + 1 = t.head := by rw [h.2.1, hidx] + rw [hcellidx, Function.update_self] + Β· have hi_used : i < used := by omega + have hcell := h.2.2.1 i hi_used + have hne : t.head β‰  i + 1 := by rw [h.2.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact hcell + Β· intro i hge hltotal + have hcell := h.2.2.2.1 i (by omega) hltotal + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.2.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  i + 1 := by rw [h.2.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact hcell + Β· unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.2.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  total + 1 := by rw [h.2.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact h.2.2.2.2 + +/-- Writing back the currently read non-start symbol and idling preserves a + tape. This is the basic preservation fact for non-active tapes in the + counter and guessing machines. -/ +theorem writeAndMove_readBack_idle_of_ne_start (t : Tape) + (hread : t.read β‰  Ξ“.start) : + t.writeAndMove (TM.readBackWrite t.read) (TM.idleDir t.read) = t := by + have hback : (TM.readBackWrite t.read).toΞ“ = t.read := by + cases h : t.read with + | zero => rfl + | one => rfl + | blank => rfl + | start => exact (hread h).elim + have hdir : TM.idleDir t.read = Dir3.stay := by + simp [TM.idleDir, hread] + rw [hback] + simp only [Tape.writeAndMove, hdir, Tape.move] + by_cases h0 : t.head = 0 + Β· simp [Tape.write, h0] + Β· simp [Tape.write, h0, Tape.read, Function.update_eq_self] + +end Tape + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- Small alphabet / Tape.init helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem started_ofBool_tape_read_ne_start (x : List Bool) : + (((Tape.init (x.map Ξ“.ofBool)).move Dir3.right).read) β‰  Ξ“.start := by + exact Tape.init_ofBool_move_right_read_ne_start x + +-- ════════════════════════════════════════════════════════════════════════ +-- inputLengthPlusOneCounterTM +-- ════════════════════════════════════════════════════════════════════════ + +/-- Control states for `inputLengthPlusOneCounterTM`. -/ +inductive LinearCounterPhase where + | scan + | rewind + | done + deriving DecidableEq + +/-- `LinearCounterPhase` has exactly the three states `scan`, `rewind`, + `done`. -/ +instance : Fintype LinearCounterPhase where + elems := {.scan, .rewind, .done} + complete := fun x => by cases x <;> simp + +/-- Preserve every writable work-tape symbol. -/ +def counterPreserveWork (wHeads : Fin n β†’ Ξ“) : Fin n β†’ Ξ“w := + fun i => readBackWrite (wHeads i) + +/-- Keep every work head stationary, except when bouncing off the start marker. -/ +def counterIdleDirs (wHeads : Fin n β†’ Ξ“) : Fin n β†’ Dir3 := + fun i => idleDir (wHeads i) + +private theorem counterIdleDirs_right_of_start (wHeads : Fin n β†’ Ξ“) : + βˆ€ i, wHeads i = Ξ“.start β†’ counterIdleDirs wHeads i = Dir3.right := by + intro i hi + exact idleDir_right_of_start hi + +/-- Write one unary mark on the counter tape and preserve every other tape. -/ +def counterWriteOneWork (counterIdx : Fin n) (wHeads : Fin n β†’ Ξ“) : + Fin n β†’ Ξ“w := + fun i => if i = counterIdx then Ξ“w.one else readBackWrite (wHeads i) + +/-- Advance the counter head and idle every other work head. -/ +def counterAdvanceDirs (counterIdx : Fin n) (wHeads : Fin n β†’ Ξ“) : + Fin n β†’ Dir3 := + fun i => if i = counterIdx then Dir3.right else idleDir (wHeads i) + +private theorem counterAdvanceDirs_right_of_start (counterIdx : Fin n) + (wHeads : Fin n β†’ Ξ“) : + βˆ€ i, wHeads i = Ξ“.start β†’ counterAdvanceDirs counterIdx wHeads i = Dir3.right := by + intro i hi + by_cases hidx : i = counterIdx + Β· simp [counterAdvanceDirs, hidx] + Β· simp [counterAdvanceDirs, hidx, idleDir_right_of_start hi] + +/-- Rewind the counter head and idle every other work head. -/ +def counterRewindDirs (counterIdx : Fin n) (wHeads : Fin n β†’ Ξ“) : + Fin n β†’ Dir3 := + fun i => if i = counterIdx then moveLeftDir (wHeads i) else idleDir (wHeads i) + +private theorem counterRewindDirs_right_of_start (counterIdx : Fin n) + (wHeads : Fin n β†’ Ξ“) : + βˆ€ i, wHeads i = Ξ“.start β†’ counterRewindDirs counterIdx wHeads i = Dir3.right := by + intro i hi + by_cases hidx : i = counterIdx + Β· subst hidx + simp [counterRewindDirs, moveLeftDir_right_of_start hi] + Β· simp [counterRewindDirs, hidx, idleDir_right_of_start hi] + +private theorem counterRightOfStart_idle (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ idleDir iHead = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ counterIdleDirs wHeads i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, counterIdleDirs_right_of_start wHeads, + idleDir_right_of_start⟩ + +private theorem counterRightOfStart_advance (counterIdx : Fin n) + (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ Dir3.right = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ counterAdvanceDirs counterIdx wHeads i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨fun _ => rfl, counterAdvanceDirs_right_of_start counterIdx wHeads, + idleDir_right_of_start⟩ + +private theorem counterRightOfStart_scanStart + (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ Dir3.right = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ counterIdleDirs wHeads i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨fun _ => rfl, counterIdleDirs_right_of_start wHeads, idleDir_right_of_start⟩ + +private theorem counterRightOfStart_idleInput_advance (counterIdx : Fin n) + (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ idleDir iHead = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ counterAdvanceDirs counterIdx wHeads i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, counterAdvanceDirs_right_of_start counterIdx wHeads, + idleDir_right_of_start⟩ + +private theorem counterRightOfStart_rewind (counterIdx : Fin n) + (iHead : Ξ“) (wHeads : Fin n β†’ Ξ“) (oHead : Ξ“) : + (iHead = Ξ“.start β†’ idleDir iHead = Dir3.right) ∧ + (βˆ€ i, wHeads i = Ξ“.start β†’ counterRewindDirs counterIdx wHeads i = Dir3.right) ∧ + (oHead = Ξ“.start β†’ idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, counterRewindDirs_right_of_start counterIdx wHeads, + idleDir_right_of_start⟩ + +/-- Write a unary counter of length `|input| + 1` to `counterIdx`. + +Starting with the input head on `β–·` and an empty counter tape, the `scan` +phase skips the input start cell, writes one counter mark per input bit, +then writes one extra mark when the input head reaches blank. The `rewind` +phase rewinds the counter tape to cell 1 and halts. + +The machine does not try to restore the input head; later composition layers +can rewind or retarget input as needed. -/ +def inputLengthPlusOneCounterTM (counterIdx : Fin n) : TM n where + Q := LinearCounterPhase + qstart := .scan + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .scan => + if iHead = Ξ“.start then + (.scan, counterPreserveWork wHeads, readBackWrite oHead, + Dir3.right, counterIdleDirs wHeads, idleDir oHead) + else if iHead = Ξ“.blank then + (.rewind, counterWriteOneWork counterIdx wHeads, readBackWrite oHead, + idleDir iHead, counterAdvanceDirs counterIdx wHeads, idleDir oHead) + else + (.scan, counterWriteOneWork counterIdx wHeads, readBackWrite oHead, + Dir3.right, counterAdvanceDirs counterIdx wHeads, idleDir oHead) + | .rewind => + if wHeads counterIdx = Ξ“.start then + (.done, counterPreserveWork wHeads, readBackWrite oHead, + idleDir iHead, counterAdvanceDirs counterIdx wHeads, idleDir oHead) + else + (.rewind, counterPreserveWork wHeads, readBackWrite oHead, + idleDir iHead, counterRewindDirs counterIdx wHeads, idleDir oHead) + | .done => + (.done, counterPreserveWork wHeads, readBackWrite oHead, + idleDir iHead, counterIdleDirs wHeads, idleDir oHead) + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state + Β· by_cases hiStart : iHead = Ξ“.start + Β· simpa [hiStart] using counterRightOfStart_scanStart iHead wHeads oHead + Β· by_cases hiBlank : iHead = Ξ“.blank + Β· simpa [hiStart, hiBlank] using + counterRightOfStart_idleInput_advance counterIdx iHead wHeads oHead + Β· simpa [hiStart, hiBlank] using + counterRightOfStart_advance counterIdx iHead wHeads oHead + Β· by_cases hcounter : wHeads counterIdx = Ξ“.start + Β· simpa [hcounter] using + counterRightOfStart_idleInput_advance counterIdx iHead wHeads oHead + Β· simpa [hcounter] using + counterRightOfStart_rewind counterIdx iHead wHeads oHead + Β· exact counterRightOfStart_idle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- One-step transition API +-- ════════════════════════════════════════════════════════════════════════ + +/-- In the `scan` phase, reading `β–·` on the input keeps the machine in + `scan`. -/ +theorem inputLengthPlusOneCounterTM_scan_start_state + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp : inp.read = Ξ“.start) : + (((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).state = + LinearCounterPhase.scan := by + simp [TM.step, inputLengthPlusOneCounterTM, hinp] + +/-- The start-skip step positions an initially empty counter tape at cell 1, + giving the zero-length unary-prefix invariant. -/ +theorem inputLengthPlusOneCounterTM_scan_start_initializes_counter + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp : inp.read = Ξ“.start) + (hcounter : work counterIdx = Tape.init []) : + ((((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).work counterIdx).HasUnaryPrefix 0 := by + simp [TM.step, inputLengthPlusOneCounterTM, hinp, counterPreserveWork, + counterIdleDirs, hcounter] + simpa [idleDir, Tape.read, Tape.init, Tape.writeAndMove, Tape.write] using + Tape.init_nil_move_right_hasUnaryPrefix_zero + +/-- In the `scan` phase, reading blank on the input moves the machine to the + `rewind` phase. -/ +theorem inputLengthPlusOneCounterTM_scan_blank_state + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp : inp.read = Ξ“.blank) : + (((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).state = + LinearCounterPhase.rewind := by + simp [TM.step, inputLengthPlusOneCounterTM, hinp] + +/-- In the `scan` phase, reading an input bit (neither `β–·` nor blank) keeps + the machine in `scan`. -/ +theorem inputLengthPlusOneCounterTM_scan_bit_state + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hstart : inp.read β‰  Ξ“.start) (hblank : inp.read β‰  Ξ“.blank) : + (((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).state = + LinearCounterPhase.scan := by + simp [TM.step, inputLengthPlusOneCounterTM, hstart, hblank] + +/-- Scanning an input bit writes one unary mark and advances the counter + prefix by one. -/ +theorem inputLengthPlusOneCounterTM_scan_bit_extends_counter + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {used : β„•} + (hprefix : (work counterIdx).HasUnaryPrefix used) + (hstart : inp.read β‰  Ξ“.start) (hblank : inp.read β‰  Ξ“.blank) : + ((((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).work counterIdx).HasUnaryPrefix + (used + 1) := by + simp [TM.step, inputLengthPlusOneCounterTM, hstart, hblank, + counterWriteOneWork, counterAdvanceDirs, Tape.hasUnaryPrefix_write_one hprefix] + +/-- Scanning the input blank writes the final extra unary mark and enters the + rewind phase. -/ +theorem inputLengthPlusOneCounterTM_scan_blank_extends_counter + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + {used : β„•} + (hprefix : (work counterIdx).HasUnaryPrefix used) + (hinp : inp.read = Ξ“.blank) : + ((((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).work counterIdx).HasUnaryPrefix + (used + 1) := by + have hstart : inp.read β‰  Ξ“.start := by rw [hinp]; simp + simp [TM.step, inputLengthPlusOneCounterTM, hinp, + counterWriteOneWork, counterAdvanceDirs, Tape.hasUnaryPrefix_write_one hprefix] + +/-- In the `rewind` phase, reading `β–·` on the counter tape moves the machine + to `done`. -/ +theorem inputLengthPlusOneCounterTM_rewind_start_state + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hcounter : (work counterIdx).read = Ξ“.start) : + (((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.rewind, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).state = + LinearCounterPhase.done := by + simp [TM.step, inputLengthPlusOneCounterTM, hcounter] + +/-- In the `rewind` phase, a counter-tape read other than `β–·` keeps the + machine in `rewind`. -/ +theorem inputLengthPlusOneCounterTM_rewind_left_state + (counterIdx : Fin n) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hcounter : (work counterIdx).read β‰  Ξ“.start) : + (((inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.rewind, input := inp, work := work, output := out }).get + (by simp [TM.step, inputLengthPlusOneCounterTM])).state = + LinearCounterPhase.rewind := by + simp [TM.step, inputLengthPlusOneCounterTM, hcounter] + +/-- One NTM trace step of the lifted counter machine leaves a non-counter work + tape unchanged when that tape is the started blank tape. -/ +theorem inputLengthPlusOneCounterTM_toNTM_trace_one_preserves_started_blank_other_work + (counterIdx : Fin n) (choice : Bool) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (i : Fin n) (hi : i β‰  counterIdx) + (hwork : c.work i = (Tape.init []).move Dir3.right) : + (((inputLengthPlusOneCounterTM counterIdx).toNTM).trace 1 + (fun _ => choice) c).work i = (Tape.init []).move Dir3.right := by + cases c with + | mk state input work output => + change work i = (Tape.init []).move Dir3.right at hwork + cases state + Β· by_cases hstart : input.cells input.head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, + counterPreserveWork, counterIdleDirs, hwork, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· by_cases hblank : input.cells input.head = Ξ“.blank + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hblank, + counterWriteOneWork, counterAdvanceDirs, hwork, hi, + Tape.writeAndMove, Tape.write, Tape.move, Tape.read, readBackWrite, + idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, hblank, + counterWriteOneWork, counterAdvanceDirs, hwork, hi, + Tape.writeAndMove, Tape.write, Tape.move, Tape.read, readBackWrite, + idleDir, Tape.init] + Β· by_cases hcounter : (work counterIdx).cells (work counterIdx).head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + counterPreserveWork, counterAdvanceDirs, hwork, hi, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + counterPreserveWork, counterRewindDirs, hwork, hi, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hwork] + +/-- One NTM trace step of the lifted counter machine (in a non-halted state) + moves a fresh blank non-counter work tape past its `β–·` marker, turning it + into the started blank tape. -/ +theorem inputLengthPlusOneCounterTM_toNTM_trace_one_initializes_blank_other_work + (counterIdx : Fin n) (choice : Bool) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (i : Fin n) (hi : i β‰  counterIdx) + (hstate : c.state β‰  LinearCounterPhase.done) + (hwork : c.work i = Tape.init []) : + (((inputLengthPlusOneCounterTM counterIdx).toNTM).trace 1 + (fun _ => choice) c).work i = (Tape.init []).move Dir3.right := by + cases c with + | mk state input work output => + change work i = Tape.init [] at hwork + cases state + Β· by_cases hstart : input.cells input.head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, + counterPreserveWork, counterIdleDirs, hwork, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· by_cases hblank : input.cells input.head = Ξ“.blank + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hblank, + counterWriteOneWork, counterAdvanceDirs, hwork, hi, + Tape.writeAndMove, Tape.write, Tape.move, Tape.read, readBackWrite, + idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, hblank, + counterWriteOneWork, counterAdvanceDirs, hwork, hi, + Tape.writeAndMove, Tape.write, Tape.move, Tape.read, readBackWrite, + idleDir, Tape.init] + Β· by_cases hcounter : (work counterIdx).cells (work counterIdx).head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + counterPreserveWork, counterAdvanceDirs, hwork, hi, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + counterPreserveWork, counterRewindDirs, hwork, hi, Tape.writeAndMove, + Tape.write, Tape.move, Tape.read, readBackWrite, idleDir, Tape.init] + Β· exact (hstate rfl).elim + +/-- One NTM trace step of the lifted counter machine leaves a started blank + output tape unchanged. -/ +theorem inputLengthPlusOneCounterTM_toNTM_trace_one_preserves_started_blank_output + (counterIdx : Fin n) (choice : Bool) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (houtput : c.output = (Tape.init []).move Dir3.right) : + (((inputLengthPlusOneCounterTM counterIdx).toNTM).trace 1 + (fun _ => choice) c).output = (Tape.init []).move Dir3.right := by + cases c with + | mk state input work output => + change output = (Tape.init []).move Dir3.right at houtput + cases state + Β· by_cases hstart : input.cells input.head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· by_cases hblank : input.cells input.head = Ξ“.blank + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hblank, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, hblank, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· by_cases hcounter : (work counterIdx).cells (work counterIdx).head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, houtput] + +/-- One NTM trace step of the lifted counter machine (in a non-halted state) + moves a fresh blank output tape past its `β–·` marker, turning it into the + started blank tape. -/ +theorem inputLengthPlusOneCounterTM_toNTM_trace_one_initializes_blank_output + (counterIdx : Fin n) (choice : Bool) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (hstate : c.state β‰  LinearCounterPhase.done) + (houtput : c.output = Tape.init []) : + (((inputLengthPlusOneCounterTM counterIdx).toNTM).trace 1 + (fun _ => choice) c).output = (Tape.init []).move Dir3.right := by + cases c with + | mk state input work output => + change output = Tape.init [] at houtput + cases state + Β· by_cases hstart : input.cells input.head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· by_cases hblank : input.cells input.head = Ξ“.blank + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hblank, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hstart, hblank, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· by_cases hcounter : (work counterIdx).cells (work counterIdx).head = Ξ“.start + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· simp [NTM.trace, TM.toNTM, inputLengthPlusOneCounterTM, hcounter, + houtput, Tape.writeAndMove, Tape.write, Tape.move, Tape.read, + readBackWrite, idleDir, Tape.init] + Β· exact (hstate rfl).elim + +-- ════════════════════════════════════════════════════════════════════════ +-- Multi-step correctness for inputLengthPlusOneCounterTM +-- ════════════════════════════════════════════════════════════════════════ + +private theorem inputLengthPlusOneCounterTM_start_step + (counterIdx : Fin n) (x : List Bool) (work : Fin n β†’ Tape) (out : Tape) + (hcounter : work counterIdx = Tape.init []) : + βˆƒ c₁, + (inputLengthPlusOneCounterTM counterIdx).step + { state := LinearCounterPhase.scan, + input := Tape.init (x.map Ξ“.ofBool), + work := work, output := out } = some c₁ ∧ + c₁.state = LinearCounterPhase.scan ∧ + c₁.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c₁.input.head = 1 ∧ + (c₁.work counterIdx).HasUnaryPrefix 0 ∧ + (c₁.work counterIdx).cells 0 = Ξ“.start := by + have hread : (Tape.init (x.map Ξ“.ofBool)).read = Ξ“.start := by + simp [Tape.read, Tape.init] + simp only [TM.step, inputLengthPlusOneCounterTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· rw [Tape.move_cells] + Β· simp [Tape.init, Tape.move] + Β· have hcounter_read : (work counterIdx).read = Ξ“.start := by + rw [hcounter] + simp [Tape.read, Tape.init] + simpa [idleDir, Tape.read, Tape.init, counterPreserveWork, counterIdleDirs, + hcounter, hcounter_read, + Tape.writeAndMove, Tape.write] using + Tape.init_nil_move_right_hasUnaryPrefix_zero + Β· simp [counterIdleDirs, hcounter, Tape.writeAndMove, Tape.move_cells, + Tape.write, Tape.init] + +private theorem inputLengthPlusOneCounterTM_scan_bit_step + (counterIdx : Fin n) (x : List Bool) (k : β„•) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (hk : k < x.length) + (hstate : c.state = LinearCounterPhase.scan) + (hinput_cells : c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells) + (hinput_head : c.input.head = k + 1) + (hprefix : (c.work counterIdx).HasUnaryPrefix k) + (hcell0 : (c.work counterIdx).cells 0 = Ξ“.start) : + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).step c = some c' ∧ + c'.state = LinearCounterPhase.scan ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = k + 2 ∧ + (c'.work counterIdx).HasUnaryPrefix (k + 1) ∧ + (c'.work counterIdx).cells 0 = Ξ“.start := by + have hread : c.input.read = Ξ“.ofBool (x[k]'hk) := by + change c.input.cells c.input.head = _ + rw [hinput_head, hinput_cells] + exact Tape.init_ofBool_cells_lt x k hk + have hstart : c.input.read β‰  Ξ“.start := by + rw [hread] + exact Ξ“.ofBool_ne_start _ + have hblank : c.input.read β‰  Ξ“.blank := by + rw [hread] + exact Ξ“.ofBool_ne_blank _ + simp only [TM.step, hstate, inputLengthPlusOneCounterTM, hstart, hblank] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· rw [Tape.move_cells] + exact hinput_cells + Β· simp [Tape.move, hinput_head] + Β· simpa [counterWriteOneWork, counterAdvanceDirs] using + Tape.hasUnaryPrefix_write_one hprefix + Β· simpa [counterWriteOneWork, counterAdvanceDirs] using + Tape.hasUnaryPrefix_write_one_cell0 hprefix hcell0 + +private theorem inputLengthPlusOneCounterTM_scan_bits_loop + (counterIdx : Fin n) (x : List Bool) : + βˆ€ (m k : β„•) (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q), + k + m ≀ x.length β†’ + c.state = LinearCounterPhase.scan β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + (c.work counterIdx).HasUnaryPrefix k β†’ + (c.work counterIdx).cells 0 = Ξ“.start β†’ + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).reachesIn m c c' ∧ + c'.state = LinearCounterPhase.scan ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = k + m + 1 ∧ + (c'.work counterIdx).HasUnaryPrefix (k + m) ∧ + (c'.work counterIdx).cells 0 = Ξ“.start := by + intro m + induction m with + | zero => + intro k c _ hstate hcells hhead hprefix hcell0 + refine ⟨c, .zero, hstate, hcells, ?_, ?_, hcell0⟩ + Β· omega + Β· simpa using hprefix + | succ m ih => + intro k c hle hstate hcells hhead hprefix hcell0 + have hk : k < x.length := by omega + obtain ⟨c₁, hstep, hstate₁, hcells₁, hhead₁, hprefix₁, hcell0β‚βŸ© := + inputLengthPlusOneCounterTM_scan_bit_step counterIdx x k c hk hstate + hcells hhead hprefix hcell0 + have hle₁ : (k + 1) + m ≀ x.length := by omega + obtain ⟨c', hreach, hstate', hcells', hhead', hprefix', hcell0'⟩ := + ih (k + 1) c₁ hle₁ hstate₁ hcells₁ (by omega) hprefix₁ hcell0₁ + refine ⟨c', .step hstep hreach, hstate', hcells', ?_, ?_, hcell0'⟩ + Β· rw [hhead'] + omega + Β· convert hprefix' using 1 + omega + +private theorem inputLengthPlusOneCounterTM_scan_blank_step + (counterIdx : Fin n) (x : List Bool) + (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (hstate : c.state = LinearCounterPhase.scan) + (hinput_cells : c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells) + (hinput_head : c.input.head = x.length + 1) + (hprefix : (c.work counterIdx).HasUnaryPrefix x.length) + (hcell0 : (c.work counterIdx).cells 0 = Ξ“.start) : + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).step c = some c' ∧ + c'.state = LinearCounterPhase.rewind ∧ + c'.input = c.input ∧ + (c'.work counterIdx).HasUnaryPrefix (x.length + 1) ∧ + (c'.work counterIdx).cells 0 = Ξ“.start := by + have hread : c.input.read = Ξ“.blank := by + change c.input.cells c.input.head = _ + rw [hinput_head, hinput_cells] + exact Tape.init_ofBool_cells_ge x x.length le_rfl + simp only [TM.step, hstate, inputLengthPlusOneCounterTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.idleDir, Tape.move] + Β· simpa [counterWriteOneWork, counterAdvanceDirs] using + Tape.hasUnaryPrefix_write_one hprefix + Β· simpa [counterWriteOneWork, counterAdvanceDirs] using + Tape.hasUnaryPrefix_write_one_cell0 hprefix hcell0 + +private theorem inputLengthPlusOneCounterTM_rewind_step_left + (counterIdx : Fin n) (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (hstate : c.state = LinearCounterPhase.rewind) + (hinp : c.input.read β‰  Ξ“.start) + (hread : (c.work counterIdx).read β‰  Ξ“.start) + (_ : (c.work counterIdx).cells 0 = Ξ“.start) + (_ : βˆ€ j, j β‰₯ 1 β†’ (c.work counterIdx).cells j β‰  Ξ“.start) : + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).step c = some c' ∧ + c'.state = LinearCounterPhase.rewind ∧ + c'.input = c.input ∧ + (c'.work counterIdx).head = (c.work counterIdx).head - 1 ∧ + (c'.work counterIdx).cells = (c.work counterIdx).cells := by + simp only [TM.step, hstate, inputLengthPlusOneCounterTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + Β· change c.input.move (TM.idleDir c.input.read) = c.input + exact TM.transitionInput_eq_self hinp + Β· by_cases h0 : (c.work counterIdx).head = 0 + Β· simp [counterRewindDirs, moveLeftDir, hread, Tape.writeAndMove, Tape.move, + Tape.write, h0] + Β· simp [counterRewindDirs, moveLeftDir, hread, Tape.writeAndMove, Tape.move, + Tape.write, h0] + Β· simp only [Tape.writeAndMove, Tape.move_cells] + change ((c.work counterIdx).write + ((readBackWrite (c.work counterIdx).read).toΞ“)).cells = + (c.work counterIdx).cells + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write, Tape.read] + split + Β· rfl + Β· exact Function.update_eq_self _ _ + +private theorem inputLengthPlusOneCounterTM_rewind_step_base + (counterIdx : Fin n) (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q) + (hstate : c.state = LinearCounterPhase.rewind) + (hinp : c.input.read β‰  Ξ“.start) + (hread : (c.work counterIdx).read = Ξ“.start) + (_ : (c.work counterIdx).cells 0 = Ξ“.start) + (hnostart : βˆ€ j, j β‰₯ 1 β†’ (c.work counterIdx).cells j β‰  Ξ“.start) : + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).step c = some c' ∧ + c'.state = LinearCounterPhase.done ∧ + c'.input = c.input ∧ + (c'.work counterIdx).head = 1 ∧ + (c'.work counterIdx).cells = (c.work counterIdx).cells := by + have hhead : (c.work counterIdx).head = 0 := by + by_contra h + exact hnostart (c.work counterIdx).head (by omega) (by rwa [Tape.read] at hread) + simp only [TM.step, hstate, inputLengthPlusOneCounterTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + Β· change c.input.move (TM.idleDir c.input.read) = c.input + exact TM.transitionInput_eq_self hinp + Β· simp [counterAdvanceDirs, Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· simp [counterAdvanceDirs, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + +private theorem inputLengthPlusOneCounterTM_rewind_loop (counterIdx : Fin n) : + βˆ€ (h : β„•) (c : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q), + c.state = LinearCounterPhase.rewind β†’ + c.input.read β‰  Ξ“.start β†’ + (c.work counterIdx).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (c.work counterIdx).cells j β‰  Ξ“.start) β†’ + (c.work counterIdx).head = h β†’ + βˆƒ c', + (inputLengthPlusOneCounterTM counterIdx).reachesIn (h + 1) c c' ∧ + (inputLengthPlusOneCounterTM counterIdx).halted c' ∧ + c'.input = c.input ∧ + (c'.work counterIdx).head = 1 ∧ + (c'.work counterIdx).cells = (c.work counterIdx).cells := by + intro h + induction h with + | zero => + intro c hstate hinp hcell0 hnostart hhead + have hread : (c.work counterIdx).read = Ξ“.start := by + simp [Tape.read, hhead, hcell0] + obtain ⟨c', hstep, hstate', hinp', hhead', hcells'⟩ := + inputLengthPlusOneCounterTM_rewind_step_base counterIdx c hstate hinp hread hcell0 hnostart + exact ⟨c', .step hstep .zero, hstate', hinp', hhead', hcells'⟩ + | succ h ih => + intro c hstate hinp hcell0 hnostart hhead + have hread : (c.work counterIdx).read β‰  Ξ“.start := by + simpa only [Tape.read, hhead] using hnostart (h + 1) (by omega) + obtain ⟨c1, hstep, hstate1, hinput1_eq, hhead1, hcells1⟩ := + inputLengthPlusOneCounterTM_rewind_step_left counterIdx c hstate hinp hread hcell0 hnostart + have hinp1_ns : c1.input.read β‰  Ξ“.start := by + rw [hinput1_eq] + exact hinp + have hhead1' : (c1.work counterIdx).head = h := by + rw [hhead1, hhead] + omega + obtain ⟨c', hreach, hhalt, hinp', hhead', hcells'⟩ := + ih c1 hstate1 hinp1_ns (by rw [hcells1]; exact hcell0) + (by intro j hj; rw [hcells1]; exact hnostart j hj) hhead1' + exact ⟨c', .step hstep hreach, hhalt, by rw [hinp', hinput1_eq], hhead', + by rw [hcells', hcells1]⟩ + +/-- A convenient linear upper bound for `inputLengthPlusOneCounterTM`. -/ +def inputLengthPlusOneCounterTime (xLen : β„•) : β„• := + 3 * xLen + 10 + +/-- `inputLengthPlusOneCounterTM` materializes a unary counter of length + `|x| + 1` on the designated work tape and rewinds it to cell 1. -/ +theorem inputLengthPlusOneCounterTM_hoareTime + (counterIdx : Fin n) (x : List Bool) : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work _ => + inp = Tape.init (x.map Ξ“.ofBool) ∧ + work counterIdx = Tape.init []) + (fun _ work _ => + (work counterIdx).HasUnaryCounter (x.length + 1)) + (inputLengthPlusOneCounterTime x.length) := by + intro inp work out ⟨hinput, hcounter⟩ + subst inp + let c0 : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q := + { state := LinearCounterPhase.scan, + input := Tape.init (x.map Ξ“.ofBool), + work := work, + output := out } + obtain ⟨c1, hstep_start, hstate1, hcells1, hhead1, hprefix1, hcell01⟩ := + inputLengthPlusOneCounterTM_start_step counterIdx x work out hcounter + obtain ⟨c2, hreach_scan, hstate2, hcells2, hhead2, hprefix2, hcell02⟩ := + inputLengthPlusOneCounterTM_scan_bits_loop counterIdx x x.length 0 c1 + (by omega) hstate1 hcells1 hhead1 hprefix1 hcell01 + have hhead2' : c2.input.head = x.length + 1 := by + rw [hhead2] + omega + have hprefix2' : (c2.work counterIdx).HasUnaryPrefix x.length := by + simpa using hprefix2 + obtain ⟨c3, hstep_blank, hstate3, hinput3, hprefix3, hcell03⟩ := + inputLengthPlusOneCounterTM_scan_blank_step counterIdx x c2 + hstate2 hcells2 hhead2' hprefix2' hcell02 + have hinp3 : c3.input.read β‰  Ξ“.start := by + rw [hinput3] + show c2.input.read β‰  Ξ“.start + rw [show c2.input.read = c2.input.cells c2.input.head by rfl, hhead2', hcells2] + rw [Tape.init_ofBool_cells_ge x x.length le_rfl] + decide + have hnostart3 : βˆ€ j, j β‰₯ 1 β†’ (c3.work counterIdx).cells j β‰  Ξ“.start := + Tape.hasUnaryPrefix_cells_ne_start hprefix3 + have hhead3 : (c3.work counterIdx).head = x.length + 2 := by + rw [hprefix3.1] + obtain ⟨c4, hreach_rewind, hhalt4, hinput4, hhead4, hcells4⟩ := + inputLengthPlusOneCounterTM_rewind_loop counterIdx (x.length + 2) c3 + hstate3 hinp3 hcell03 hnostart3 hhead3 + have hpost : (c4.work counterIdx).HasUnaryCounter (x.length + 1) := + Tape.hasUnaryCounter_of_hasUnaryPrefix hprefix3 hhead4 hcells4 + have hreach_start : (inputLengthPlusOneCounterTM counterIdx).reachesIn 1 c0 c1 := by + exact .step hstep_start .zero + have hreach_02 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (1 + x.length) c0 c2 := + reachesIn_trans _ hreach_start hreach_scan + have hreach_03 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (1 + x.length + 1) c0 c3 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_02 (.step hstep_blank .zero) + have hreach_04 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (1 + x.length + 1 + (x.length + 2 + 1)) c0 c4 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_03 hreach_rewind + refine ⟨c4, 1 + x.length + 1 + (x.length + 2 + 1), ?_, ?_, hhalt4, hpost⟩ + Β· simp [inputLengthPlusOneCounterTime] + omega + Β· simpa [c0] using! hreach_04 + +/-- Started-tape variant of `inputLengthPlusOneCounterTM_hoareTime`: if the +input is already positioned at cell `1` and the counter tape is the started +blank tape, the machine still builds a unary counter of length `|x| + 1`. +The postcondition also exposes the structural fact that the resulting counter +tape has no `β–·` markers beyond cell `0`. -/ +theorem inputLengthPlusOneCounterTM_started_hoareTime + (counterIdx : Fin n) (x : List Bool) : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work _ => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work counterIdx = (Tape.init []).move Dir3.right) + (fun _ work _ => + (work counterIdx).HasUnaryCounter (x.length + 1) ∧ + (work counterIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work counterIdx).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := by + intro inp work out hpre + rcases hpre with ⟨hinput, hcounter⟩ + subst inp + let c0 : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q := + { state := LinearCounterPhase.scan, + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right, + work := work, + output := out } + have hcells0 : c0.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simp [c0, Tape.move_cells] + have hhead0 : c0.input.head = 1 := by + simp [c0, Tape.move, Tape.init] + have hprefix0 : (c0.work counterIdx).HasUnaryPrefix 0 := by + rw [show c0.work counterIdx = work counterIdx by rfl, hcounter] + exact Tape.init_nil_move_right_hasUnaryPrefix_zero + have hcell00 : (c0.work counterIdx).cells 0 = Ξ“.start := by + rw [show c0.work counterIdx = work counterIdx by rfl, hcounter] + simp [Tape.move, Tape.init] + obtain ⟨c2, hreach_scan, hstate2, hcells2, hhead2, hprefix2, hcell02⟩ := + inputLengthPlusOneCounterTM_scan_bits_loop counterIdx x x.length 0 c0 + (by omega) rfl hcells0 hhead0 hprefix0 hcell00 + have hhead2' : c2.input.head = x.length + 1 := by + rw [hhead2] + omega + have hprefix2' : (c2.work counterIdx).HasUnaryPrefix x.length := by + simpa using hprefix2 + obtain ⟨c3, hstep_blank, hstate3, hinput3, hprefix3, hcell03⟩ := + inputLengthPlusOneCounterTM_scan_blank_step counterIdx x c2 + hstate2 hcells2 hhead2' hprefix2' hcell02 + have hinp3 : c3.input.read β‰  Ξ“.start := by + rw [hinput3] + show c2.input.read β‰  Ξ“.start + rw [show c2.input.read = c2.input.cells c2.input.head by rfl, hhead2', hcells2] + rw [Tape.init_ofBool_cells_ge x x.length le_rfl] + decide + have hnostart3 : βˆ€ j, j β‰₯ 1 β†’ (c3.work counterIdx).cells j β‰  Ξ“.start := + Tape.hasUnaryPrefix_cells_ne_start hprefix3 + have hhead3 : (c3.work counterIdx).head = x.length + 2 := by + rw [hprefix3.1] + obtain ⟨c4, hreach_rewind, hhalt4, hinput4, hhead4, hcells4⟩ := + inputLengthPlusOneCounterTM_rewind_loop counterIdx (x.length + 2) c3 + hstate3 hinp3 hcell03 hnostart3 hhead3 + have hcounter4 : (c4.work counterIdx).HasUnaryCounter (x.length + 1) := + Tape.hasUnaryCounter_of_hasUnaryPrefix hprefix3 hhead4 hcells4 + have hcell04 : (c4.work counterIdx).cells 0 = Ξ“.start := by + rw [hcells4] + exact hcell03 + have hnostart4 : βˆ€ j, j β‰₯ 1 β†’ (c4.work counterIdx).cells j β‰  Ξ“.start := by + intro j hj + rw [hcells4] + exact hnostart3 j hj + have hreach_03 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (x.length + 1) c0 c3 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_scan (.step hstep_blank .zero) + have hreach_04 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (x.length + 1 + (x.length + 2 + 1)) c0 c4 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_03 hreach_rewind + refine ⟨c4, x.length + 1 + (x.length + 2 + 1), ?_, ?_, hhalt4, + ⟨hcounter4, hcell04, hnostart4⟩⟩ + Β· simp [inputLengthPlusOneCounterTime] + omega + Β· simpa [c0] using! hreach_04 + +/-- Started-tape variant of the unary counter builder that also records the +final input position. The input cells are unchanged, and the input head ends at +the first blank after the scanned Boolean string. -/ +theorem inputLengthPlusOneCounterTM_started_tracksInput_hoareTime + (counterIdx : Fin n) (x : List Bool) : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work _ => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work counterIdx = (Tape.init []).move Dir3.right) + (fun inp work _ => + inp.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + inp.head = x.length + 1 ∧ + (work counterIdx).HasUnaryCounter (x.length + 1) ∧ + (work counterIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work counterIdx).cells j β‰  Ξ“.start)) + (inputLengthPlusOneCounterTime x.length) := by + intro inp work out hpre + rcases hpre with ⟨hinput, hcounter⟩ + subst inp + let c0 : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q := + { state := LinearCounterPhase.scan, + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right, + work := work, + output := out } + have hcells0 : c0.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simp [c0, Tape.move_cells] + have hhead0 : c0.input.head = 1 := by + simp [c0, Tape.move, Tape.init] + have hprefix0 : (c0.work counterIdx).HasUnaryPrefix 0 := by + rw [show c0.work counterIdx = work counterIdx by rfl, hcounter] + exact Tape.init_nil_move_right_hasUnaryPrefix_zero + have hcell00 : (c0.work counterIdx).cells 0 = Ξ“.start := by + rw [show c0.work counterIdx = work counterIdx by rfl, hcounter] + simp [Tape.move, Tape.init] + obtain ⟨c2, hreach_scan, hstate2, hcells2, hhead2, hprefix2, hcell02⟩ := + inputLengthPlusOneCounterTM_scan_bits_loop counterIdx x x.length 0 c0 + (by omega) rfl hcells0 hhead0 hprefix0 hcell00 + have hhead2' : c2.input.head = x.length + 1 := by + rw [hhead2] + omega + have hprefix2' : (c2.work counterIdx).HasUnaryPrefix x.length := by + simpa using hprefix2 + obtain ⟨c3, hstep_blank, hstate3, hinput3, hprefix3, hcell03⟩ := + inputLengthPlusOneCounterTM_scan_blank_step counterIdx x c2 + hstate2 hcells2 hhead2' hprefix2' hcell02 + have hinp3 : c3.input.read β‰  Ξ“.start := by + rw [hinput3] + show c2.input.read β‰  Ξ“.start + rw [show c2.input.read = c2.input.cells c2.input.head by rfl, hhead2', hcells2] + rw [Tape.init_ofBool_cells_ge x x.length le_rfl] + decide + have hnostart3 : βˆ€ j, j β‰₯ 1 β†’ (c3.work counterIdx).cells j β‰  Ξ“.start := + Tape.hasUnaryPrefix_cells_ne_start hprefix3 + have hhead3 : (c3.work counterIdx).head = x.length + 2 := by + rw [hprefix3.1] + obtain ⟨c4, hreach_rewind, hhalt4, hinput4, hhead4, hcells4⟩ := + inputLengthPlusOneCounterTM_rewind_loop counterIdx (x.length + 2) c3 + hstate3 hinp3 hcell03 hnostart3 hhead3 + have hcounter4 : (c4.work counterIdx).HasUnaryCounter (x.length + 1) := + Tape.hasUnaryCounter_of_hasUnaryPrefix hprefix3 hhead4 hcells4 + have hcell04 : (c4.work counterIdx).cells 0 = Ξ“.start := by + rw [hcells4] + exact hcell03 + have hnostart4 : βˆ€ j, j β‰₯ 1 β†’ (c4.work counterIdx).cells j β‰  Ξ“.start := by + intro j hj + rw [hcells4] + exact hnostart3 j hj + have hinput4_cells : c4.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + rw [hinput4, hinput3] + exact hcells2 + have hinput4_head : c4.input.head = x.length + 1 := by + rw [hinput4, hinput3] + exact hhead2' + have hreach_03 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (x.length + 1) c0 c3 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_scan (.step hstep_blank .zero) + have hreach_04 : (inputLengthPlusOneCounterTM counterIdx).reachesIn + (x.length + 1 + (x.length + 2 + 1)) c0 c4 := by + simpa [Nat.add_assoc] using + reachesIn_trans _ hreach_03 hreach_rewind + refine ⟨c4, x.length + 1 + (x.length + 2 + 1), ?_, ?_, hhalt4, + ⟨hinput4_cells, hinput4_head, hcounter4, hcell04, hnostart4⟩⟩ + Β· simp [inputLengthPlusOneCounterTime] + omega + Β· simpa [c0] using! hreach_04 + +/-- One-step preservation of a passive started Boolean work tape distinct from +the active counter tape. -/ +private theorem inputLengthPlusOneCounterTM_step_preserves_started_other_work + (counterIdx passiveIdx : Fin n) (hne : passiveIdx β‰  counterIdx) + (y : List Bool) + {c c' : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q} + (hstep : (inputLengthPlusOneCounterTM counterIdx).step c = some c') + (hpassive : c.work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right) : + c'.work passiveIdx = c.work passiveIdx := by + have hpassive_read : (c.work passiveIdx).read β‰  Ξ“.start := by + rw [hpassive] + exact started_ofBool_tape_read_ne_start y + cases c with + | mk state input work output => + change work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right at hpassive + cases state with + | scan => + by_cases hstart : input.read = Ξ“.start + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hstart] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [counterPreserveWork, counterIdleDirs] using + Tape.writeAndMove_readBack_idle_of_ne_start (work passiveIdx) + (by simpa [hpassive] using hpassive_read) + Β· by_cases hblank : input.read = Ξ“.blank + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hblank] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [counterWriteOneWork, counterAdvanceDirs, hne] using + Tape.writeAndMove_readBack_idle_of_ne_start (work passiveIdx) + (by simpa [hpassive] using hpassive_read) + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hstart, hblank] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [counterWriteOneWork, counterAdvanceDirs, hne] using + Tape.writeAndMove_readBack_idle_of_ne_start (work passiveIdx) + (by simpa [hpassive] using hpassive_read) + | rewind => + by_cases hcounter : (work counterIdx).read = Ξ“.start + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hcounter] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [counterPreserveWork, counterAdvanceDirs, hne] using + Tape.writeAndMove_readBack_idle_of_ne_start (work passiveIdx) + (by simpa [hpassive] using hpassive_read) + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hcounter] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [counterPreserveWork, counterRewindDirs, hne] using + Tape.writeAndMove_readBack_idle_of_ne_start (work passiveIdx) + (by simpa [hpassive] using hpassive_read) + | done => + simp [TM.step, inputLengthPlusOneCounterTM] at hstep + +/-- Multi-step preservation of a passive started Boolean work tape distinct +from the active counter tape. -/ +private theorem inputLengthPlusOneCounterTM_reachesIn_preserves_started_other_work + (counterIdx passiveIdx : Fin n) (hne : passiveIdx β‰  counterIdx) + (y : List Bool) + {t : β„•} {c c' : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q} + (hreach : (inputLengthPlusOneCounterTM counterIdx).reachesIn t c c') + (hpassive : c.work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right) : + c'.work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right := by + induction hreach with + | zero => + exact hpassive + | step hstep _ ih => + have hmid : _ = _ := + inputLengthPlusOneCounterTM_step_preserves_started_other_work + counterIdx passiveIdx hne y hstep hpassive + exact ih (by simpa [hmid] using hpassive) + +/-- One-step preservation of a started blank output tape. -/ +private theorem inputLengthPlusOneCounterTM_step_preserves_started_blank_output + (counterIdx : Fin n) + {c c' : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q} + (hstep : (inputLengthPlusOneCounterTM counterIdx).step c = some c') + (hout : c.output = (Tape.init []).move Dir3.right) : + c'.output = c.output := by + have hout_read : c.output.read β‰  Ξ“.start := by + rw [hout] + simp [Tape.read, Tape.move, Tape.init] + cases c with + | mk state input work output => + change output = (Tape.init []).move Dir3.right at hout + cases state with + | scan => + by_cases hstart : input.read = Ξ“.start + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hstart] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [hout] using + Tape.writeAndMove_readBack_idle_of_ne_start output + hout_read + Β· by_cases hblank : input.read = Ξ“.blank + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hblank] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [hout] using + Tape.writeAndMove_readBack_idle_of_ne_start output + hout_read + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hstart, hblank] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [hout] using + Tape.writeAndMove_readBack_idle_of_ne_start output + hout_read + | rewind => + by_cases hcounter : (work counterIdx).read = Ξ“.start + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hcounter] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [hout] using + Tape.writeAndMove_readBack_idle_of_ne_start output + hout_read + Β· simp only [TM.step, inputLengthPlusOneCounterTM, hcounter] at hstep + have hcfg := Option.some.inj hstep + subst c' + simpa [hout] using + Tape.writeAndMove_readBack_idle_of_ne_start output + hout_read + | done => + simp [TM.step, inputLengthPlusOneCounterTM] at hstep + +/-- Multi-step preservation of a started blank output tape. -/ +private theorem inputLengthPlusOneCounterTM_reachesIn_preserves_started_blank_output + (counterIdx : Fin n) + {t : β„•} {c c' : Cfg n (inputLengthPlusOneCounterTM counterIdx).Q} + (hreach : (inputLengthPlusOneCounterTM counterIdx).reachesIn t c c') + (hout : c.output = (Tape.init []).move Dir3.right) : + c'.output = (Tape.init []).move Dir3.right := by + induction hreach with + | zero => + exact hout + | step hstep _ ih => + have hmid : _ = _ := + inputLengthPlusOneCounterTM_step_preserves_started_blank_output + counterIdx hstep hout + exact ih (by simpa [hmid] using hout) + +/-- Started-tape variant of the unary counter builder that also records the +final input position and preserves one passive started Boolean work tape +exactly. -/ +theorem inputLengthPlusOneCounterTM_started_tracksInput_preserves_work_hoareTime + (counterIdx passiveIdx : Fin n) (hne : passiveIdx β‰  counterIdx) + (x y : List Bool) : + (inputLengthPlusOneCounterTM counterIdx).HoareTime + (fun inp work out => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work counterIdx = (Tape.init []).move Dir3.right ∧ + work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => + inp.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + inp.head = x.length + 1 ∧ + work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right ∧ + (work counterIdx).HasUnaryCounter (x.length + 1) ∧ + (work counterIdx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work counterIdx).cells j β‰  Ξ“.start) ∧ + out = (Tape.init []).move Dir3.right) + (inputLengthPlusOneCounterTime x.length) := by + intro inp work out hpre + rcases hpre with ⟨hinput, hcounter, hpassive, hout⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := + inputLengthPlusOneCounterTM_started_tracksInput_hoareTime counterIdx x inp work out + ⟨hinput, hcounter⟩ + have hpassive' : + c'.work passiveIdx = (Tape.init (y.map Ξ“.ofBool)).move Dir3.right := + inputLengthPlusOneCounterTM_reachesIn_preserves_started_other_work + counterIdx passiveIdx hne y hreach hpassive + have hout' : + c'.output = (Tape.init []).move Dir3.right := + inputLengthPlusOneCounterTM_reachesIn_preserves_started_blank_output + counterIdx hreach hout + exact ⟨c', t, ht, hreach, hhalt, ⟨hpost.1, hpost.2.1, hpassive', hpost.2.2.1, + hpost.2.2.2.1, hpost.2.2.2.2, hout'⟩⟩ + +/-- Nondeterministic form of `inputLengthPlusOneCounterTM_hoareTime`, for use + inside NTM constructions after lifting the deterministic setup machine. -/ +theorem inputLengthPlusOneCounterTM_toNTM_hoareTime + (counterIdx : Fin n) (x : List Bool) : + ((inputLengthPlusOneCounterTM counterIdx).toNTM).HoareTime + (fun inp work _ => + inp = Tape.init (x.map Ξ“.ofBool) ∧ + work counterIdx = Tape.init []) + (fun _ work _ => + (work counterIdx).HasUnaryCounter (x.length + 1)) + (inputLengthPlusOneCounterTime x.length) := + (inputLengthPlusOneCounterTM_hoareTime counterIdx x).toNTM + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean new file mode 100644 index 0000000000..2c2e2058be --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean @@ -0,0 +1,2001 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# TM Subroutines: proof internals + +Simulation lemmas and `HoareTime` proofs for the rewind, blank, clear, and +copy subroutine machines defined in +`Complexitylib.Models.TuringMachine.Subroutines`. Each subroutine gets a +basic Hoare-style spec, and where needed a rich "frame" variant that threads +an arbitrary predicate `P` on the untouched tapes through the run. + +## Main results + +- `writeTM_hoareTime` β€” writes `sym.toΞ“` to output cell 1 +- `rewindWorkTM_hoareTime` β€” rewinds work tape `idx` to cell 1 +- `rewindWorkTM_hoareTime_frame` β€” work-tape rewind preserving a predicate P +- `rewindInputTM_hoareTime` β€” rewinds the input tape to cell 1 +- `rewindInputTM_hoareTime_frame` β€” input rewind preserving a predicate P +- `rewindInputTM_toNTM_hoareTime` β€” NTM-lifted input rewind spec +- `rewindInputTM_toNTM_hoareTime_frame` β€” NTM-lifted rich input rewind spec +- `blankWorkTM_started_hoareTime` β€” blank a started work tape in linear time +- `blankWorkTM_hoareTime_frame_of_binaryString` β€” frame-preserving blank +- `clearWorkTM_hoareTime_frame_of_binaryString` β€” blank then rewind to the + started empty tape, preserving the frame +- `copyInputToWorkTM_started_hoareTime` β€” copy the Boolean input to a work tape +- `copyWorkToWorkTM_started_hoareTime` β€” copy one started work tape to another +- `copyWorkToWorkTM_hoareTime_frame_of_binaryString` β€” frame-preserving + work-to-work copy +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +private theorem writeTM_rewind_step_left (sym : Ξ“w) (c : Cfg n (writeTM sym).Q) + (hst : c.state = WritePhase.rewind) (hread : c.output.read β‰  Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (writeTM sym).step c = some c' ∧ + c'.state = WritePhase.rewind ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hst, writeTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp only [Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write, Tape.read]; split <;> simp + Β· simp only [Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + +private theorem writeTM_rewind_step_base (sym : Ξ“w) (c : Cfg n (writeTM sym).Q) + (hst : c.state = WritePhase.rewind) (hread : c.output.read = Ξ“.start) + (_ : c.output.cells 0 = Ξ“.start) + (hns : βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) : + βˆƒ c', (writeTM sym).step c = some c' ∧ + c'.state = WritePhase.goRight ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hhead : c.output.head = 0 := by + by_contra h; exact hns c.output.head (by omega) (by rwa [Tape.read] at hread) + simp only [TM.step, ↓reduceIte, hst, writeTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + +private theorem writeTM_rewind_loop (sym : Ξ“w) : + βˆ€ (h : β„•) (c : Cfg n (writeTM sym).Q), + c.state = WritePhase.rewind β†’ + c.output.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.output.cells j β‰  Ξ“.start) β†’ + c.output.head = h β†’ + βˆƒ c', + (writeTM sym).reachesIn (h + 1) c c' ∧ + c'.state = WritePhase.goRight ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := + exists_reachesIn_of_rewindStep_output (writeTM sym) + (fun c hst hread hc0 hns => writeTM_rewind_step_left sym c hst hread hc0 hns) + (fun c hst hread hc0 hns => writeTM_rewind_step_base sym c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: goRight and write steps +-- ════════════════════════════════════════════════════════════════════════ + +private theorem writeTM_goRight_to_done (sym : Ξ“w) (c : Cfg n (writeTM sym).Q) + (hstate : c.state = WritePhase.goRight) + (hhead : c.output.head = 1) + (hnostart1 : c.output.cells 1 β‰  Ξ“.start) : + βˆƒ c', + (writeTM sym).reachesIn 2 c c' ∧ + (writeTM sym).halted c' ∧ + c'.output.cells 1 = sym.toΞ“ := by + have hoDir : idleDir (c.output.read) = Dir3.stay := by + simp [idleDir, Tape.read, hhead, hnostart1] + -- Step 1: goRight β†’ write + have hstep1 : βˆƒ c₁, (writeTM sym).step c = some c₁ ∧ + c₁.state = WritePhase.write ∧ + c₁.output.head = 1 ∧ + c₁.output.cells 1 = Ξ“.blank := by + simp only [TM.step, hstate, writeTM] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead, hoDir] + Β· simp [Tape.writeAndMove, Tape.move, Tape.write, hhead, hoDir, + Function.update_self, Ξ“w.toΞ“] + obtain ⟨c₁, hstep1', hst1, hhead1, hcell1_blank⟩ := hstep1 + -- Step 2: write β†’ done + have hoDir2 : idleDir (c₁.output.read) = Dir3.stay := by + simp [idleDir, Tape.read, hhead1, hcell1_blank] + have hstep2 : βˆƒ cβ‚‚, (writeTM sym).step c₁ = some cβ‚‚ ∧ + cβ‚‚.state = WritePhase.done ∧ + cβ‚‚.output.cells 1 = sym.toΞ“ := by + simp only [TM.step, hst1, writeTM] + refine ⟨_, rfl, rfl, ?_⟩ + simp [Tape.writeAndMove, Tape.move, Tape.write, hhead1, hoDir2, + Function.update_self] + obtain ⟨cβ‚‚, hstep2', hst2, hcells2⟩ := hstep2 + exact ⟨cβ‚‚, .step hstep1' (.step hstep2' .zero), hst2, hcells2⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `writeTM sym` writes `sym.toΞ“` to output cell 1 and halts. + **Pre**: output tape well-formed (cell 0 = β–·, cells β‰₯ 1 β‰  β–·), head ≀ B. + **Post**: output cell 1 = sym.toΞ“. + **Time**: B + 3 steps. -/ +theorem writeTM_hoareTime (sym : Ξ“w) (B : β„•) : + (writeTM (n := n) sym).HoareTime + (fun _ _ out => out.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ out.cells j β‰  Ξ“.start) ∧ + out.head ≀ B) + (fun _ _ out => out.cells 1 = sym.toΞ“) + (B + 3) := by + intro inp work out ⟨hcell0, hnostart, hhead_le⟩ + obtain ⟨c_go, hreach_rw, hst_go, hhead_go, hcells_go⟩ := + writeTM_rewind_loop sym out.head + { state := WritePhase.rewind, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl + have hnostart_go : c_go.output.cells 1 β‰  Ξ“.start := by + rw [hcells_go]; exact hnostart 1 (by omega) + obtain ⟨c_done, hreach_wr, hhalt, hwrite⟩ := + writeTM_goRight_to_done sym c_go hst_go hhead_go hnostart_go + refine ⟨c_done, (out.head + 1) + 2, ?_, + reachesIn_trans (writeTM sym) hreach_rw hreach_wr, hhalt, hwrite⟩ + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +private theorem rewindWorkTM_rewind_step_left (idx : Fin n) (c : Cfg n (rewindWorkTM idx).Q) + (hst : c.state = RewindPhase.moveLeft) (hread : (c.work idx).read β‰  Ξ“.start) + (_ : (c.work idx).cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ (c.work idx).cells j β‰  Ξ“.start) : + βˆƒ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveLeft ∧ + (c'.work idx).head = (c.work idx).head - 1 ∧ + (c'.work idx).cells = (c.work idx).cells := by + simp only [TM.step, ↓reduceIte, hst, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· dsimp only []; simp only [↓reduceIte, Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write, Tape.read]; split <;> simp + Β· dsimp only []; simp only [↓reduceIte, Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread] + simp only [Tape.write, Tape.read]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + +private theorem rewindWorkTM_rewind_step_base (idx : Fin n) (c : Cfg n (rewindWorkTM idx).Q) + (hst : c.state = RewindPhase.moveLeft) (hread : (c.work idx).read = Ξ“.start) + (_ : (c.work idx).cells 0 = Ξ“.start) + (hns : βˆ€ j, j β‰₯ 1 β†’ (c.work idx).cells j β‰  Ξ“.start) : + βˆƒ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells := by + have hhead : (c.work idx).head = 0 := by + by_contra h; exact hns (c.work idx).head (by omega) (by rwa [Tape.read] at hread) + simp only [TM.step, ↓reduceIte, hst, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· dsimp only []; simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· dsimp only []; simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + +private theorem rewindWorkTM_rewind_loop (idx : Fin n) : + βˆ€ (h : β„•) (c : Cfg n (rewindWorkTM idx).Q), + c.state = RewindPhase.moveLeft β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (c.work idx).cells j β‰  Ξ“.start) β†’ + (c.work idx).head = h β†’ + βˆƒ c', + (rewindWorkTM idx).reachesIn (h + 1) c c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells := + exists_reachesIn_of_rewindStep_tape (rewindWorkTM idx) (fun c => c.work idx) + (fun c hst hread hc0 hns => rewindWorkTM_rewind_step_left idx c hst hread hc0 hns) + (fun c hst hread hc0 hns => rewindWorkTM_rewind_step_base idx c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: moveRight step +-- ════════════════════════════════════════════════════════════════════════ + +private theorem rewindWorkTM_moveRight_to_done (idx : Fin n) + (c : Cfg n (rewindWorkTM idx).Q) + (hstate : c.state = RewindPhase.moveRight) + (hread_ne : (c.work idx).read β‰  Ξ“.start) : + βˆƒ c', + (rewindWorkTM idx).reachesIn 1 c c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = (c.work idx).head := by + have hoDir : idleDir ((c.work idx).read) = Dir3.stay := by + simp [idleDir, hread_ne] + have hstep : βˆƒ c', (rewindWorkTM idx).step c = some c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = (c.work idx).head := by + simp only [TM.step, hstate, rewindWorkTM, allIdle] + refine ⟨_, rfl, rfl, ?_⟩ + dsimp only [] + rw [Tape.writeAndMove, hoDir] + simp [Tape.move, Tape.write] + split <;> rfl + obtain ⟨c', hstep', hhalt, hhead⟩ := hstep + exact ⟨c', .step hstep' .zero, hhalt, hhead⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `rewindWorkTM idx` rewinds work tape `idx` to cell 1 and halts. + **Pre**: work tape `idx` well-formed (cell 0 = β–·, cells β‰₯ 1 β‰  β–·), head ≀ B. + **Post**: work tape `idx` head = 1. + **Time**: B + 2 steps. -/ +theorem rewindWorkTM_hoareTime (idx : Fin n) (B : β„•) : + (rewindWorkTM idx).HoareTime + (fun _ work _ => (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work idx).cells j β‰  Ξ“.start) ∧ + (work idx).head ≀ B) + (fun _ work _ => (work idx).head = 1) + (B + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le⟩ + obtain ⟨c_mr, hreach_rw, hst_mr, hhead_mr, hcells_mr⟩ := + rewindWorkTM_rewind_loop idx (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl + have hread_mr : (c_mr.work idx).read β‰  Ξ“.start := by + simp [Tape.read, hhead_mr, hcells_mr]; exact hnostart 1 (by omega) + obtain ⟨c_done, hreach_mr, hhalt, hhead_done⟩ := + rewindWorkTM_moveRight_to_done idx c_mr hst_mr hread_mr + refine ⟨c_done, ((work idx).head + 1) + 1, ?_, + reachesIn_trans (rewindWorkTM idx) hreach_rw hreach_mr, hhalt, + by dsimp only []; rw [hhead_done, hhead_mr]⟩ + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindInputTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +private theorem rewindInputTM_rewind_step_left (c : Cfg n (rewindInputTM (n := n)).Q) + (hst : c.state = RewindPhase.moveLeft) (hread : c.input.read β‰  Ξ“.start) + (_ : c.input.cells 0 = Ξ“.start) (_ : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) : + βˆƒ c', (rewindInputTM (n := n)).step c = some c' ∧ + c'.state = RewindPhase.moveLeft ∧ + c'.input.head = c.input.head - 1 ∧ + c'.input.cells = c.input.cells := by + simp only [TM.step, ↓reduceIte, hst, rewindInputTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.move, moveLeftDir, hread] + Β· simp [Tape.move_cells] + +private theorem rewindInputTM_rewind_step_base (c : Cfg n (rewindInputTM (n := n)).Q) + (hst : c.state = RewindPhase.moveLeft) (hread : c.input.read = Ξ“.start) + (_ : c.input.cells 0 = Ξ“.start) + (hns : βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) : + βˆƒ c', (rewindInputTM (n := n)).step c = some c' ∧ + c'.state = RewindPhase.moveRight ∧ + c'.input.head = 1 ∧ + c'.input.cells = c.input.cells := by + have hhead : c.input.head = 0 := by + by_contra h; exact hns c.input.head (by omega) (by rwa [Tape.read] at hread) + simp only [TM.step, ↓reduceIte, hst, rewindInputTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.move, hhead] + Β· simp [Tape.move_cells] + +private theorem rewindInputTM_rewind_loop : + βˆ€ (h : β„•) (c : Cfg n (rewindInputTM (n := n)).Q), + c.state = RewindPhase.moveLeft β†’ + c.input.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + c.input.head = h β†’ + βˆƒ c', + (rewindInputTM (n := n)).reachesIn (h + 1) c c' ∧ + c'.state = RewindPhase.moveRight ∧ + c'.input.head = 1 ∧ + c'.input.cells = c.input.cells := + exists_reachesIn_of_rewindStep_tape (rewindInputTM (n := n)) (fun c => c.input) + (fun c hst hread hc0 hns => rewindInputTM_rewind_step_left c hst hread hc0 hns) + (fun c hst hread hc0 hns => rewindInputTM_rewind_step_base c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindInputTM: moveRight step +-- ════════════════════════════════════════════════════════════════════════ + +private theorem rewindInputTM_moveRight_to_done + (c : Cfg n (rewindInputTM (n := n)).Q) + (hstate : c.state = RewindPhase.moveRight) + (hread_ne : c.input.read β‰  Ξ“.start) : + βˆƒ c', + (rewindInputTM (n := n)).reachesIn 1 c c' ∧ + (rewindInputTM (n := n)).halted c' ∧ + c'.input.head = c.input.head ∧ + c'.input.cells = c.input.cells := by + have hiDir : idleDir c.input.read = Dir3.stay := by + simp [idleDir, hread_ne] + have hstep : βˆƒ c', (rewindInputTM (n := n)).step c = some c' ∧ + (rewindInputTM (n := n)).halted c' ∧ + c'.input.head = c.input.head ∧ + c'.input.cells = c.input.cells := by + simp only [TM.step, hstate, rewindInputTM] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + Β· simp [Tape.move, hiDir] + Β· simp [Tape.move_cells] + obtain ⟨c', hstep', hhalt, hhead, hcells⟩ := hstep + exact ⟨c', .step hstep' .zero, hhalt, hhead, hcells⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindInputTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `rewindInputTM` rewinds the input tape to cell 1 and halts. + **Pre**: input tape well-formed (cell 0 = β–·, cells β‰₯ 1 β‰  β–·), head ≀ B. + **Post**: input head = 1. + **Time**: B + 2 steps. -/ +theorem rewindInputTM_hoareTime (B : β„•) : + (rewindInputTM (n := n)).HoareTime + (fun inp _ _ => inp.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start) ∧ + inp.head ≀ B) + (fun inp _ _ => inp.head = 1) + (B + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le⟩ + obtain ⟨c_mr, hreach_rw, hst_mr, hhead_mr, hcells_mr⟩ := + rewindInputTM_rewind_loop (n := n) inp.head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl + have hread_mr : c_mr.input.read β‰  Ξ“.start := by + simp [Tape.read, hhead_mr, hcells_mr]; exact hnostart 1 (by omega) + obtain ⟨c_done, hreach_mr, hhalt, hhead_done, _hcells_done⟩ := + rewindInputTM_moveRight_to_done (n := n) c_mr hst_mr hread_mr + refine ⟨c_done, (inp.head + 1) + 1, ?_, + reachesIn_trans (rewindInputTM (n := n)) hreach_rw hreach_mr, hhalt, + by dsimp only []; rw [hhead_done, hhead_mr]⟩ + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindInputTM: rich HoareTime preserving arbitrary data +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rich HoareTime for `rewindInputTM` that preserves an arbitrary predicate P + through the rewind, provided P is stable when the input cells are unchanged + and the input head is reset to 1. Work and output tapes are preserved + exactly under the usual non-start-under-head side conditions. -/ +theorem rewindInputTM_hoareTime_frame {n : β„•} (B_input : β„•) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + inp'.cells = inp.cells β†’ + inp'.head = 1 β†’ + work' = work β†’ + out' = out β†’ + P inp' work' out') : + (rewindInputTM (n := n)).HoareTime + (fun inp work out => + inp.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start) ∧ + inp.head ≀ B_input ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + inp.head = 1 ∧ + P inp work out) + (B_input + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le, hout_ns, hout_h, hwork_wf, hP⟩ + have tape_idle_preserve : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ t.head β‰₯ 1 β†’ + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + intro t hns hh + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + Β· omega + Β· simp only [Tape.read] at hns ⊒ + rw [toΞ“_readBackWrite_of_ne_start hns, Function.update_eq_self] + have input_idle_preserve : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ + t.move (idleDir t.read) = t := by + intro t hns + simp [idleDir, hns, Tape.move] + suffices h_loop : βˆ€ (h : β„•) (c : Cfg n (rewindInputTM (n := n)).Q), + c.state = RewindPhase.moveLeft β†’ + c.input.cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ c.input.cells j β‰  Ξ“.start) β†’ + c.input.head = h β†’ + c.work = work β†’ c.output = out β†’ + βˆƒ c', + (rewindInputTM (n := n)).reachesIn (h + 2) c c' ∧ + (rewindInputTM (n := n)).halted c' ∧ + c'.input.head = 1 ∧ c'.input.cells = c.input.cells ∧ + c'.work = work ∧ c'.output = out by + obtain ⟨c', hreach, hhalt, hh1, hcells, hwork', hout'⟩ := + h_loop inp.head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl rfl rfl + refine ⟨c', _, by omega, hreach, hhalt, hh1, ?_⟩ + exact hP_preserved inp work out c'.input c'.work c'.output hP + (by rw [hcells]) hh1 hwork' hout' + intro h; induction h with + | zero => + intro c hstate hcell0_c hnostart_c hhead hwork_c hout_c + have hread : c.input.read = Ξ“.start := by simp [Tape.read, hhead, hcell0_c] + have hstep1 : βˆƒ c₁, + (rewindInputTM (n := n)).step c = some c₁ ∧ + c₁.state = RewindPhase.moveRight ∧ + c₁.input.head = 1 ∧ c₁.input.cells = c.input.cells ∧ + c₁.work = work ∧ c₁.output = out := by + simp only [TM.step, ↓reduceIte, hstate, rewindInputTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· simp [Tape.move, hhead] + Β· simp [Tape.move_cells] + Β· funext i; dsimp only [] + rw [hwork_c] + exact tape_idle_preserve (work i) (hwork_wf i).1 (hwork_wf i).2 + Β· dsimp only []; rw [hout_c] + exact tape_idle_preserve out hout_ns hout_h + obtain ⟨c₁, hstep1', hst1, hh1, hcells1, hwork1, hout1⟩ := hstep1 + have hread1 : c₁.input.read β‰  Ξ“.start := by + simp [Tape.read, hh1, hcells1]; exact hnostart_c 1 (by omega) + have hstep2 : βˆƒ cβ‚‚, + (rewindInputTM (n := n)).step c₁ = some cβ‚‚ ∧ + (rewindInputTM (n := n)).halted cβ‚‚ ∧ + cβ‚‚.input.head = 1 ∧ cβ‚‚.input.cells = c₁.input.cells ∧ + cβ‚‚.work = work ∧ cβ‚‚.output = out := by + simp only [TM.step, hst1, rewindInputTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· have := input_idle_preserve c₁.input hread1 + show (c₁.input.move (idleDir c₁.input.read)).head = 1 + rw [this]; exact hh1 + Β· have := input_idle_preserve c₁.input hread1 + show (c₁.input.move (idleDir c₁.input.read)).cells = c₁.input.cells + rw [this] + Β· funext i; dsimp only [] + rw [hwork1] + exact tape_idle_preserve (work i) (hwork_wf i).1 (hwork_wf i).2 + Β· dsimp only []; rw [hout1] + exact tape_idle_preserve out hout_ns hout_h + obtain ⟨cβ‚‚, hstep2', hhalt, hh2, hcells2, hwork2, hout2⟩ := hstep2 + exact ⟨cβ‚‚, .step hstep1' (.step hstep2' .zero), hhalt, hh2, + by rw [hcells2, hcells1], hwork2, hout2⟩ + | succ h ih => + intro c hstate hcell0_c hnostart_c hhead hwork_c hout_c + have hread_ne : c.input.read β‰  Ξ“.start := by + simp [Tape.read, hhead]; exact hnostart_c (h + 1) (by omega) + have hstep : βˆƒ c₁, + (rewindInputTM (n := n)).step c = some c₁ ∧ + c₁.state = RewindPhase.moveLeft ∧ + c₁.input.head = h ∧ c₁.input.cells = c.input.cells ∧ + c₁.work = work ∧ c₁.output = out := by + simp only [TM.step, ↓reduceIte, hstate, rewindInputTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + Β· simp [Tape.move, moveLeftDir, hread_ne, hhead] + Β· simp [Tape.move_cells] + Β· funext i; dsimp only [] + rw [hwork_c] + exact tape_idle_preserve (work i) (hwork_wf i).1 (hwork_wf i).2 + Β· dsimp only []; rw [hout_c] + exact tape_idle_preserve out hout_ns hout_h + obtain ⟨c₁, hstep', hst1, hh1, hcells1, hwork1, hout1⟩ := hstep + obtain ⟨c_f, hreach_f, hhalt_f, hh_f, hcells_f, hwork_f, hout_f⟩ := + ih c₁ hst1 (by rw [hcells1]; exact hcell0_c) + (by intro j hj; rw [hcells1]; exact hnostart_c j hj) hh1 hwork1 hout1 + exact ⟨c_f, .step hstep' hreach_f, hhalt_f, hh_f, + by rw [hcells_f, hcells1], hwork_f, hout_f⟩ + +/-- Nondeterministic form of `rewindInputTM_hoareTime`, for phase compositions + that run deterministic setup subroutines through `TM.toNTM`. -/ +theorem rewindInputTM_toNTM_hoareTime (B : β„•) : + ((rewindInputTM (n := n)).toNTM).HoareTime + (fun inp _ _ => inp.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start) ∧ + inp.head ≀ B) + (fun inp _ _ => inp.head = 1) + (B + 2) := + (rewindInputTM_hoareTime (n := n) B).toNTM + +/-- Nondeterministic form of `rewindInputTM_hoareTime_frame`. -/ +theorem rewindInputTM_toNTM_hoareTime_frame {n : β„•} (B_input : β„•) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + inp'.cells = inp.cells β†’ + inp'.head = 1 β†’ + work' = work β†’ + out' = out β†’ + P inp' work' out') : + ((rewindInputTM (n := n)).toNTM).HoareTime + (fun inp work out => + inp.cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ inp.cells j β‰  Ξ“.start) ∧ + inp.head ≀ B_input ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + inp.head = 1 ∧ + P inp work out) + (B_input + 2) := + (rewindInputTM_hoareTime_frame (n := n) B_input hP_preserved).toNTM + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rich HoareTime preserving arbitrary data +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rich HoareTime for `rewindWorkTM` that preserves an arbitrary predicate P + through the rewind, provided P depends on cells (not heads) of the target + tape. This is the key tool for threading invariants (e.g., simulation state, + encoded data) through rewind steps in `seqTM` compositions. + + The caller provides `hP_preserved` showing that P is stable under: + - target tape cells unchanged, head set to 1 + - all other work tapes unchanged + - input and output unchanged -/ +theorem rewindWorkTM_hoareTime_frame {n : β„•} (idx : Fin n) (B_tape : β„•) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' idx).cells = (work idx).cells β†’ + (work' idx).head = 1 β†’ + (βˆ€ i, i β‰  idx β†’ work' i = work i) β†’ + inp' = inp β†’ + out'.cells = out.cells β†’ + out'.head = out.head β†’ + P inp' work' out') : + (rewindWorkTM idx).HoareTime + (fun inp work out => + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work idx).cells j β‰  Ξ“.start) ∧ + (work idx).head ≀ B_tape ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + (work idx).head = 1 ∧ + P inp work out) + (B_tape + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le, hinp_ns, hout_ns, hout_h, hother_wf, hP⟩ + -- Helper: idle-step identity for stable tapes + have tape_idle_preserve : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ t.head β‰₯ 1 β†’ + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + intro t hns hh + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + Β· omega + Β· simp only [Tape.read] at hns ⊒ + rw [toΞ“_readBackWrite_of_ne_start hns, Function.update_eq_self] + -- Rich rewind loop: tracks ALL tapes, not just work tape idx + suffices h_loop : βˆ€ (h : β„•) (c : Cfg n (rewindWorkTM idx).Q), + c.state = RewindPhase.moveLeft β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (βˆ€ j, j β‰₯ 1 β†’ (c.work idx).cells j β‰  Ξ“.start) β†’ + (c.work idx).head = h β†’ + c.input = inp β†’ c.output = out β†’ (βˆ€ i, i β‰  idx β†’ c.work i = work i) β†’ + βˆƒ c', + (rewindWorkTM idx).reachesIn (h + 2) c c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = 1 ∧ (c'.work idx).cells = (c.work idx).cells ∧ + c'.input = inp ∧ c'.output = out ∧ (βˆ€ i, i β‰  idx β†’ c'.work i = work i) by + obtain ⟨c', hreach, hhalt, hh1, hcells, hinp', hout', hw'⟩ := + h_loop (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl rfl rfl (fun _ _ => rfl) + refine ⟨c', _, by omega, hreach, hhalt, hh1, ?_⟩ + exact hP_preserved inp work out c'.input c'.work c'.output hP + (by rw [hcells]) hh1 hw' hinp' + (by rw [hout']) (by rw [hout']) + intro h; induction h with + | zero => + intro c hstate hcell0_c hnostart_c hhead hinp_c hout_c hw_c + have hread : (c.work idx).read = Ξ“.start := by simp [Tape.read, hhead, hcell0_c] + -- Step 1: moveLeft, read β–· β†’ moveRight + have hstep1 : βˆƒ c₁, + (rewindWorkTM idx).step c = some c₁ ∧ + c₁.state = RewindPhase.moveRight ∧ + (c₁.work idx).head = 1 ∧ (c₁.work idx).cells = (c.work idx).cells ∧ + c₁.input = inp ∧ c₁.output = out ∧ (βˆ€ i, i β‰  idx β†’ c₁.work i = work i) := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· dsimp only []; simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + Β· dsimp only []; simp [Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + Β· dsimp only []; rw [hinp_c]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + Β· dsimp only []; rw [hout_c]; exact tape_idle_preserve out hout_ns hout_h + Β· intro i hne; dsimp only [] + simp only [show Β¬(i = idx) from hne, ↓reduceIte] + rw [hw_c i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨c₁, hstep1', hst1, hh1, hcells1, hinp1, hout1, hw1⟩ := hstep1 + -- Step 2: moveRight β†’ done + have hread1 : (c₁.work idx).read β‰  Ξ“.start := by + simp [Tape.read, hh1, hcells1]; exact hnostart_c 1 (by omega) + have hstep2 : βˆƒ cβ‚‚, + (rewindWorkTM idx).step c₁ = some cβ‚‚ ∧ + (rewindWorkTM idx).halted cβ‚‚ ∧ + (cβ‚‚.work idx).head = 1 ∧ (cβ‚‚.work idx).cells = (c₁.work idx).cells ∧ + cβ‚‚.input = inp ∧ cβ‚‚.output = out ∧ (βˆ€ i, i β‰  idx β†’ cβ‚‚.work i = work i) := by + simp only [TM.step, hst1, rewindWorkTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· dsimp only [] + have := tape_idle_preserve (c₁.work idx) hread1 (by omega) + show ((c₁.work idx).writeAndMove (readBackWrite (c₁.work idx).read) + (idleDir (c₁.work idx).read)).head = 1 + rw [this]; exact hh1 + Β· dsimp only [] + have := tape_idle_preserve (c₁.work idx) hread1 (by omega) + show ((c₁.work idx).writeAndMove (readBackWrite (c₁.work idx).read) + (idleDir (c₁.work idx).read)).cells = (c₁.work idx).cells + rw [this] + Β· dsimp only []; rw [hinp1]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + Β· dsimp only []; rw [hout1]; exact tape_idle_preserve out hout_ns hout_h + Β· intro i hne; dsimp only [] + rw [hw1 i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨cβ‚‚, hstep2', hhalt, hh2, hcells2, hinp2, hout2, hw2⟩ := hstep2 + exact ⟨cβ‚‚, .step hstep1' (.step hstep2' .zero), hhalt, hh2, + by rw [hcells2, hcells1], hinp2, hout2, hw2⟩ + | succ h ih => + intro c hstate hcell0_c hnostart_c hhead hinp_c hout_c hw_c + have hread_ne : (c.work idx).read β‰  Ξ“.start := by + simp [Tape.read, hhead]; exact hnostart_c (h + 1) (by omega) + -- Step: moveLeft, read non-β–· β†’ stay in moveLeft, move left + have hstep : βˆƒ c₁, + (rewindWorkTM idx).step c = some c₁ ∧ + c₁.state = RewindPhase.moveLeft ∧ + (c₁.work idx).head = h ∧ (c₁.work idx).cells = (c.work idx).cells ∧ + c₁.input = inp ∧ c₁.output = out ∧ (βˆ€ i, i β‰  idx β†’ c₁.work i = work i) := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write]; split + Β· omega + Β· simp [hhead] + Β· dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move_cells] + rw [toΞ“_readBackWrite_of_ne_start hread_ne] + simp only [Tape.write]; split + Β· rfl + Β· exact Function.update_eq_self _ _ + Β· dsimp only []; rw [hinp_c]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + Β· dsimp only []; rw [hout_c]; exact tape_idle_preserve out hout_ns hout_h + Β· intro i hne; dsimp only [] + simp only [show Β¬(i = idx) from hne, ↓reduceIte] + rw [hw_c i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨c₁, hstep', hst1, hh1, hcells1, hinp1, hout1, hw1⟩ := hstep + obtain ⟨c_f, hreach_f, hhalt_f, hh_f, hcells_f, hinp_f, hout_f, hw_f⟩ := + ih c₁ hst1 (by rw [hcells1]; exact hcell0_c) + (by intro j hj; rw [hcells1]; exact hnostart_c j hj) hh1 hinp1 hout1 hw1 + exact ⟨c_f, .step hstep' hreach_f, hhalt_f, hh_f, + by rw [hcells_f, hcells1], hinp_f, hout_f, hw_f⟩ + +/-- Starting from cell `k + 1` of a started Boolean work tape whose first `k` +cells have already been blanked, `blankWorkTM idx` clears the remaining suffix +and halts with the entire tape blank from cell `1` onward. -/ +private theorem blankWorkTM_loop {n : β„•} (idx : Fin n) (x : List Bool) : + βˆ€ rem k (c : Cfg n (blankWorkTM idx).Q), + rem = x.length - k β†’ + k ≀ x.length β†’ + c.state = ScanPhase.scanning β†’ + (c.work idx).head = k + 1 β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (βˆ€ i, i < k β†’ (c.work idx).cells (i + 1) = Ξ“.blank) β†’ + (βˆ€ i, βˆ€ _ : k ≀ i, βˆ€ hi : i < x.length, + (c.work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi)) β†’ + (βˆ€ i, x.length ≀ i β†’ (c.work idx).cells (i + 1) = Ξ“.blank) β†’ + βˆƒ c', + (blankWorkTM idx).reachesIn (rem + 1) c c' ∧ + (blankWorkTM idx).halted c' ∧ + (c'.work idx).head = x.length + 1 ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, (c'.work idx).cells (i + 1) = Ξ“.blank) := by + intro rem + induction rem with + | zero => + intro k c hrem hk_le hstate hhead hcell0 hblank_prefix hdata hblank_tail + have hk_eq : k = x.length := by omega + subst hk_eq + have hread : (c.work idx).read = Ξ“.blank := by + simp [Tape.read, hhead, hblank_tail x.length le_rfl] + have hstep : + βˆƒ c1, + (blankWorkTM idx).step c = some c1 ∧ + (blankWorkTM idx).halted c1 ∧ + (c1.work idx).head = x.length + 1 ∧ + (c1.work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, (c1.work idx).cells (i + 1) = Ξ“.blank) := by + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.done + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (TM.readBackWrite ((c.work i).read)).toΞ“ + (TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hkeep : c1.work idx = c.work idx := by + have hread_ne : (c.work idx).read β‰  Ξ“.start := by simp [hread] + simpa [c1, hread, TM.transitionTape] using + (TM.transitionTape_eq_self (t := c.work idx) hread_ne) + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, blankWorkTM, hread, c1, allIdle] + Β· rw [hkeep, hhead] + Β· rw [hkeep] + exact hcell0 + Β· intro i + rw [hkeep] + by_cases hi : i < x.length + Β· exact hblank_prefix i hi + Β· exact hblank_tail i (by omega) + obtain ⟨c1, hstep1, hhalt1, hhead1, hcell01, hblank1⟩ := hstep + exact ⟨c1, .step hstep1 .zero, hhalt1, hhead1, hcell01, hblank1⟩ + | succ rem ih => + intro k c hrem hk_le hstate hhead hcell0 hblank_prefix hdata hblank_tail + have hk_lt : k < x.length := by omega + have hread : (c.work idx).read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hdata k le_rfl hk_lt] + have hstep : + βˆƒ c1, + (blankWorkTM idx).step c = some c1 ∧ + c1.state = ScanPhase.scanning ∧ + (c1.work idx).head = k + 2 ∧ + (c1.work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i < k + 1 β†’ (c1.work idx).cells (i + 1) = Ξ“.blank) ∧ + (βˆ€ i, βˆ€ _ : k + 1 ≀ i, βˆ€ hi : i < x.length, + (c1.work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi)) ∧ + (βˆ€ i, x.length ≀ i β†’ (c1.work idx).cells (i + 1) = Ξ“.blank) := by + cases hbit : x[k]'hk_lt with + | false => + have hread0 : (c.work idx).read = Ξ“.zero := by simpa [hbit] using! hread + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.scanning + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.blank else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, blankWorkTM, hread0, c1] + Β· simp [c1, hhead, Tape.writeAndMove, Tape.move, Tape.write_head] + Β· simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead, hcell0] + Β· intro i hi + by_cases hik : i < k + Β· have hblanki := hblank_prefix i hik + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hblanki + Β· have hik_eq : i = k := by omega + subst hik_eq + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + Β· intro i hi hix + have hcell := hdata i (by omega) hix + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + Β· intro i hi + have hcell := hblank_tail i hi + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + | true => + have hread1 : (c.work idx).read = Ξ“.one := by simpa [hbit] using! hread + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.scanning + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.blank else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, blankWorkTM, hread1, c1] + Β· simp [c1, hhead, Tape.writeAndMove, Tape.move, Tape.write_head] + Β· simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead, hcell0] + Β· intro i hi + by_cases hik : i < k + Β· have hblanki := hblank_prefix i hik + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hblanki + Β· have hik_eq : i = k := by omega + subst hik_eq + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + Β· intro i hi hix + have hcell := hdata i (by omega) hix + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + Β· intro i hi + have hcell := hblank_tail i hi + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + obtain ⟨c1, hstep1, hstate1, hhead1, hcell01, hblank_prefix1, + hdata1, hblank_tail1⟩ := hstep + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hhead', hcell0', hblank'⟩ := + ih (k + 1) c1 hrem1 (by omega) hstate1 hhead1 hcell01 hblank_prefix1 hdata1 hblank_tail1 + exact ⟨c', .step hstep1 hreach, hhalt, hhead', hcell0', hblank'⟩ + +/-- If work tape `idx` holds a started Boolean string `x`, then `blankWorkTM +idx` clears that tape in `|x| + 1` steps and leaves the head at the first +blank cell after the erased string. -/ +theorem blankWorkTM_started_hoareTime {n : β„•} + (idx : Fin n) (x : List Bool) : + (blankWorkTM idx).HoareTime + (fun _inp work _out => + work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right) + (fun _inp work _out => + (work idx).head = x.length + 1 ∧ + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, (work idx).cells (i + 1) = Ξ“.blank)) + (x.length + 1) := by + intro inp work out hpre + have hwork : work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right := hpre + have hhead0 : (work idx).head = 1 := by + rw [hwork] + simp [Tape.move, Tape.init] + have hcell00 : (work idx).cells 0 = Ξ“.start := by + rw [hwork] + simp [Tape.move, Tape.init] + have hblank0 : βˆ€ i, i < 0 β†’ (work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + exact (Nat.not_lt_zero i hi).elim + have hdata0 : βˆ€ i, βˆ€ _ : 0 ≀ i, βˆ€ hi : i < x.length, + (work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi) := by + intro i _ hi + rw [hwork] + exact Tape.init_ofBool_cells_lt x i hi + have htail0 : βˆ€ i, x.length ≀ i β†’ (work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + rw [hwork] + exact Tape.init_ofBool_cells_ge x i hi + obtain ⟨c', hreach, hhalt, hhead, hcell0, hblank⟩ := + blankWorkTM_loop idx x x.length 0 + { state := ScanPhase.scanning, input := inp, work := work, output := out } + (by simp) + (Nat.zero_le _) + rfl + hhead0 hcell00 hblank0 hdata0 htail0 + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hhead, hcell0, hblank⟩ + +/-- The blanking scan erases the remaining Boolean suffix and preserves the tape frame. -/ +private theorem blankWorkTM_loop_frame {n : β„•} + (idx : Fin n) (x : List Bool) (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp_ns : inp.read β‰  Ξ“.start) (hout_ns : out.read β‰  Ξ“.start) + (hout_h : out.head β‰₯ 1) + (hother_wf : βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) : + βˆ€ rem k (c : Cfg n (blankWorkTM idx).Q), + rem = x.length - k β†’ + k ≀ x.length β†’ + c.state = ScanPhase.scanning β†’ + (c.work idx).head = k + 1 β†’ + (c.work idx).cells 0 = Ξ“.start β†’ + (βˆ€ i, i < k β†’ (c.work idx).cells (i + 1) = Ξ“.blank) β†’ + (βˆ€ i, βˆ€ _ : k ≀ i, βˆ€ hi : i < x.length, + (c.work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi)) β†’ + (βˆ€ i, x.length ≀ i β†’ (c.work idx).cells (i + 1) = Ξ“.blank) β†’ + c.input = inp β†’ + c.output = out β†’ + (βˆ€ i, i β‰  idx β†’ c.work i = work i) β†’ + βˆƒ c', + (blankWorkTM idx).reachesIn (rem + 1) c c' ∧ + (blankWorkTM idx).halted c' ∧ + (c'.work idx).head = x.length + 1 ∧ + (c'.work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, (c'.work idx).cells (i + 1) = Ξ“.blank) ∧ + c'.input = inp ∧ + c'.output = out ∧ + (βˆ€ i, i β‰  idx β†’ c'.work i = work i) := by + have tape_idle_preserve : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ t.head β‰₯ 1 β†’ + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + intro t hns hh + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + Β· omega + Β· simp only [Tape.read] at hns ⊒ + rw [toΞ“_readBackWrite_of_ne_start hns, Function.update_eq_self] + have input_idle_preserve : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ + t.move (idleDir t.read) = t := by + intro t hns + simp [idleDir, hns, Tape.move] + intro rem + induction rem with + | zero => + intro k c hrem hk_le hstate hhead hcell0 hblank_prefix hdata hblank_tail + hinp_c hout_c hw_c + have hk_eq : k = x.length := by omega + subst hk_eq + have hread : (c.work idx).read = Ξ“.blank := by + simp [Tape.read, hhead, hblank_tail x.length le_rfl] + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.done + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (TM.readBackWrite ((c.work i).read)).toΞ“ + (TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (blankWorkTM idx).step c = some c1 := by + simp [TM.step, hstate, blankWorkTM, hread, c1] + have hinput_keep : c1.input = inp := by + change c.input.move (TM.idleDir c.input.read) = inp + rw [hinp_c] + exact input_idle_preserve _ hinp_ns + have htarget_keep : c1.work idx = c.work idx := by + have hread_ne : (c.work idx).read β‰  Ξ“.start := by + simp [hread] + have hh : (c.work idx).head β‰₯ 1 := by + rw [hhead] + omega + change (c.work idx).writeAndMove (TM.readBackWrite ((c.work idx).read)).toΞ“ + (TM.idleDir ((c.work idx).read)) = c.work idx + exact tape_idle_preserve (c.work idx) hread_ne hh + have hout_keep : c1.output = out := by + change c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) = out + rw [hout_c] + exact tape_idle_preserve out hout_ns hout_h + have hwork_keep : βˆ€ i, i β‰  idx β†’ c1.work i = work i := by + intro i hi + change (c.work i).writeAndMove (TM.readBackWrite ((c.work i).read)).toΞ“ + (TM.idleDir ((c.work i).read)) = work i + rw [hw_c i hi] + exact tape_idle_preserve (work i) (hother_wf i hi).1 (hother_wf i hi).2 + have hblank_all : βˆ€ i, (c1.work idx).cells (i + 1) = Ξ“.blank := by + intro i + rw [htarget_keep] + by_cases hi : i < x.length + Β· exact hblank_prefix i hi + Β· exact hblank_tail i (by omega) + exact ⟨c1, .step hstep1 .zero, rfl, by rw [htarget_keep, hhead], + by rw [htarget_keep]; exact hcell0, + hblank_all, hinput_keep, hout_keep, hwork_keep⟩ + | succ rem ih => + intro k c hrem hk_le hstate hhead hcell0 hblank_prefix hdata hblank_tail + hinp_c hout_c hw_c + have hk_lt : k < x.length := by omega + have hread : (c.work idx).read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hdata k le_rfl hk_lt] + cases hbit : x[k]'hk_lt with + | false => + have hread0 : (c.work idx).read = Ξ“.zero := by simpa [hbit] using! hread + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.scanning + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.blank else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (blankWorkTM idx).step c = some c1 := by + simp [TM.step, hstate, blankWorkTM, hread0, c1] + have hinput_keep : c1.input = inp := by + simpa [c1, hinp_c] using input_idle_preserve inp hinp_ns + have houtput_keep : c1.output = out := by + simpa [c1, hout_c] using tape_idle_preserve out hout_ns hout_h + have hwork_keep : βˆ€ i, i β‰  idx β†’ c1.work i = work i := by + intro i hi + simpa [c1, hi, hw_c i hi] using + tape_idle_preserve (work i) (hother_wf i hi).1 (hother_wf i hi).2 + have hhead1 : (c1.work idx).head = k + 2 := by + simp [c1, hhead, Tape.writeAndMove, Tape.move, Tape.write_head] + have hcell01 : (c1.work idx).cells 0 = Ξ“.start := by + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead, hcell0] + have hblank_prefix1 : βˆ€ i, i < k + 1 β†’ (c1.work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + by_cases hik : i < k + Β· have hblanki := hblank_prefix i hik + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hblanki + Β· have hik_eq : i = k := by omega + subst hik_eq + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + have hdata1 : βˆ€ i, βˆ€ _ : k + 1 ≀ i, βˆ€ hi : i < x.length, + (c1.work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi) := by + intro i _ hix + have hcell := hdata i (by omega) hix + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + have hblank_tail1 : βˆ€ i, x.length ≀ i β†’ (c1.work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + have hcell := hblank_tail i hi + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hhead', hcell0', hblank', hinp', hout', hwork'⟩ := + ih (k + 1) c1 hrem1 (by omega) rfl hhead1 hcell01 hblank_prefix1 hdata1 + hblank_tail1 hinput_keep houtput_keep hwork_keep + exact ⟨c', .step hstep1 hreach, hhalt, hhead', hcell0', hblank', hinp', hout', hwork'⟩ + | true => + have hread1 : (c.work idx).read = Ξ“.one := by simpa [hbit] using! hread + let c1 : Cfg n (blankWorkTM idx).Q := + { state := ScanPhase.scanning + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.blank else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (blankWorkTM idx).step c = some c1 := by + simp [TM.step, hstate, blankWorkTM, hread1, c1] + have hinput_keep : c1.input = inp := by + simpa [c1, hinp_c] using input_idle_preserve inp hinp_ns + have houtput_keep : c1.output = out := by + simpa [c1, hout_c] using tape_idle_preserve out hout_ns hout_h + have hwork_keep : βˆ€ i, i β‰  idx β†’ c1.work i = work i := by + intro i hi + simpa [c1, hi, hw_c i hi] using + tape_idle_preserve (work i) (hother_wf i hi).1 (hother_wf i hi).2 + have hhead1 : (c1.work idx).head = k + 2 := by + simp [c1, hhead, Tape.writeAndMove, Tape.move, Tape.write_head] + have hcell01 : (c1.work idx).cells 0 = Ξ“.start := by + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead, hcell0] + have hblank_prefix1 : βˆ€ i, i < k + 1 β†’ (c1.work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + by_cases hik : i < k + Β· have hblanki := hblank_prefix i hik + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hblanki + Β· have hik_eq : i = k := by omega + subst hik_eq + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + have hdata1 : βˆ€ i, βˆ€ _ : k + 1 ≀ i, βˆ€ hi : i < x.length, + (c1.work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi) := by + intro i _ hix + have hcell := hdata i (by omega) hix + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + have hblank_tail1 : βˆ€ i, x.length ≀ i β†’ (c1.work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + have hcell := hblank_tail i hi + have hne : i + 1 β‰  k + 1 := by omega + simp [c1, Tape.writeAndMove, Tape.move_cells, Tape.write, hhead] + rw [Function.update_of_ne hne] + exact hcell + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hhead', hcell0', hblank', hinp', hout', hwork'⟩ := + ih (k + 1) c1 hrem1 (by omega) rfl hhead1 hcell01 hblank_prefix1 hdata1 + hblank_tail1 hinput_keep houtput_keep hwork_keep + exact ⟨c', .step hstep1 hreach, hhalt, hhead', hcell0', hblank', hinp', hout', hwork'⟩ + +/-- Rich HoareTime for `blankWorkTM`: erase a started Boolean work tape while +preserving arbitrary frame data on the input tape, output tape, and all other +work tapes. This is the form needed to recycle a staged work tape inside a +larger verifier pipeline. -/ +theorem blankWorkTM_hoareTime_frame_of_binaryString {n : β„•} + (idx : Fin n) (x : List Bool) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' idx).head = x.length + 1 β†’ + (work' idx).cells 0 = Ξ“.start β†’ + (βˆ€ i, (work' idx).cells (i + 1) = Ξ“.blank) β†’ + inp' = inp β†’ + out' = out β†’ + (βˆ€ i, i β‰  idx β†’ work' i = work i) β†’ + P inp' work' out') : + (blankWorkTM idx).HoareTime + (fun inp work out => + work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + (work idx).head = x.length + 1 ∧ + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, (work idx).cells (i + 1) = Ξ“.blank) ∧ + P inp work out) + (x.length + 1) := by + intro inp work out ⟨hwork, hinp_ns, hout_ns, hout_h, hother_wf, hP⟩ + have h_loop := blankWorkTM_loop_frame idx x inp work out + hinp_ns hout_ns hout_h hother_wf + have hhead0 : (work idx).head = 1 := by + rw [hwork] + simp [Tape.move, Tape.init] + have hcell00 : (work idx).cells 0 = Ξ“.start := by + rw [hwork] + simp [Tape.move, Tape.init] + have hblank0 : βˆ€ i, i < 0 β†’ (work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + exact (Nat.not_lt_zero i hi).elim + have hdata0 : βˆ€ i, βˆ€ _ : 0 ≀ i, βˆ€ hi : i < x.length, + (work idx).cells (i + 1) = Ξ“.ofBool (x[i]'hi) := by + intro i _ hi + rw [hwork] + exact Tape.init_ofBool_cells_lt x i hi + have htail0 : βˆ€ i, x.length ≀ i β†’ (work idx).cells (i + 1) = Ξ“.blank := by + intro i hi + rw [hwork] + exact Tape.init_ofBool_cells_ge x i hi + obtain ⟨c', hreach, hhalt, hhead, hcell0, hblank, hinp', hout', hwork'⟩ := + h_loop x.length 0 + { state := ScanPhase.scanning, input := inp, work := work, output := out } + (by simp) + (Nat.zero_le _) + rfl + hhead0 hcell00 hblank0 hdata0 htail0 + rfl rfl (fun _ _ => rfl) + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hhead, hcell0, hblank, ?_⟩ + exact hP_preserved inp work out c'.input c'.work c'.output hP + hhead hcell0 hblank hinp' hout' hwork' + +/-- Rich HoareTime for `clearWorkTM`: erase a started Boolean work tape and +rewind it to the standard started blank tape while preserving the external +frame. The user predicate only needs to be stable once the target tape has +reached the final started blank configuration. -/ +theorem clearWorkTM_hoareTime_frame_of_binaryString {n : β„•} + (idx : Fin n) (x : List Bool) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + work' idx = (Tape.init []).move Dir3.right β†’ + inp' = inp β†’ + out' = out β†’ + (βˆ€ i, i β‰  idx β†’ work' i = work i) β†’ + P inp' work' out') : + (clearWorkTM idx).HoareTime + (fun inp work out => + work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + work idx = (Tape.init []).move Dir3.right ∧ + P inp work out) + ((x.length + 1) + 1 + (x.length + 1 + 2)) := by + intro inp work out hpre + rcases hpre with ⟨hwork, hinp_ns, hout_ns, hout_h, hother_wf, hP⟩ + let FrameEq : TapePred n := fun inp' work' out' => + inp' = inp ∧ + out' = out ∧ + (βˆ€ i, i β‰  idx β†’ work' i = work i) + let BlankFrame : TapePred n := fun inp' work' out' => + FrameEq inp' work' out' ∧ + (work' idx).cells 0 = Ξ“.start ∧ + (βˆ€ j, (work' idx).cells (j + 1) = Ξ“.blank) + have hblank : + (blankWorkTM idx).HoareTime + (fun inp work out => + work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + FrameEq inp work out) + (fun inp work out => + (work idx).head = x.length + 1 ∧ + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ j, (work idx).cells (j + 1) = Ξ“.blank) ∧ + FrameEq inp work out) + (x.length + 1) := by + refine blankWorkTM_hoareTime_frame_of_binaryString idx x ?_ + intro inp0 work0 out0 inp' work' out' hframe _hhead _hcell0 _hblank hinp' hout' hwork' + rcases hframe with ⟨hinp0, hout0, hwork0⟩ + exact ⟨by rw [hinp', hinp0], by rw [hout', hout0], by + intro i hi + rw [hwork' i hi, hwork0 i hi]⟩ + have hrew : + (rewindWorkTM idx).HoareTime + (fun inp work out => + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ j, j β‰₯ 1 β†’ (work idx).cells j β‰  Ξ“.start) ∧ + (work idx).head ≀ x.length + 1 ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + BlankFrame inp work out) + (fun inp work out => + (work idx).head = 1 ∧ + BlankFrame inp work out) + (x.length + 1 + 2) := by + refine rewindWorkTM_hoareTime_frame idx (x.length + 1) ?_ + intro inp0 work0 out0 inp' work' out' hblankframe hcells _hhead hwork_eq hinp' + hout_cells hout_head + rcases hblankframe with ⟨hframe, hcell0, hblank⟩ + rcases hframe with ⟨hinp0, hout0, hwork0⟩ + have hout_eq0 : out' = out0 := by + cases out' + cases out0 + simp at hout_cells hout_head + simp [hout_cells, hout_head] + refine ⟨?_, ?_, ?_⟩ + Β· exact ⟨by rw [hinp', hinp0], by rw [hout_eq0, hout0], by + intro i hi + rw [hwork_eq i hi, hwork0 i hi]⟩ + Β· rw [hcells] + exact hcell0 + Β· intro j + rw [hcells] + exact hblank j + have hseq : + (clearWorkTM idx).HoareTime + (fun inp work out => + work idx = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  idx β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + FrameEq inp work out) + (fun inp work out => + (work idx).head = 1 ∧ + BlankFrame inp work out) + ((x.length + 1) + 1 + (x.length + 1 + 2)) := + seqTM_hoareTime (blankWorkTM idx) (rewindWorkTM idx) + hblank + (by + intro inp1 work1 out1 hmid + rcases hmid with ⟨hhead1, hcell01, hblank1, hframe1⟩ + rcases hframe1 with ⟨hinp1, hout1, hwork1⟩ + have htarget_read_ne : (work1 idx).read β‰  Ξ“.start := by + rw [Tape.read, hhead1, hblank1 x.length] + decide + have htarget_tr : TM.transitionTape (work1 idx) = work1 idx := + TM.transitionTape_eq_self htarget_read_ne + have hinput_tr : TM.transitionInput inp1 = inp1 := by + rw [hinp1] + exact TM.transitionInput_eq_self hinp_ns + have hout_tr : TM.transitionTape out1 = out1 := by + rw [hout1] + exact TM.transitionTape_eq_self hout_ns + have hwork_tr : βˆ€ i, i β‰  idx β†’ TM.transitionTape (work1 i) = work1 i := by + intro i hi + rw [hwork1 i hi] + exact TM.transitionTape_eq_self (hother_wf i hi).1 + refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· change (TM.transitionTape (work1 idx)).cells 0 = Ξ“.start + rw [htarget_tr] + exact hcell01 + Β· intro j hj + cases j with + | zero => omega + | succ j => + change (TM.transitionTape (work1 idx)).cells j.succ β‰  Ξ“.start + rw [htarget_tr] + rw [show j.succ = j + 1 by omega, hblank1 j] + decide + Β· change (TM.transitionTape (work1 idx)).head ≀ x.length + 1 + rw [htarget_tr, hhead1] + Β· rw [hinput_tr, hinp1] + exact hinp_ns + Β· change (TM.transitionTape out1).read β‰  Ξ“.start + rw [hout_tr, hout1] + exact hout_ns + Β· change (TM.transitionTape out1).head β‰₯ 1 + rw [hout_tr, hout1] + exact hout_h + Β· intro i hi + constructor + Β· change (TM.transitionTape (work1 i)).read β‰  Ξ“.start + rw [hwork_tr i hi, hwork1 i hi] + exact (hother_wf i hi).1 + Β· change (TM.transitionTape (work1 i)).head β‰₯ 1 + rw [hwork_tr i hi, hwork1 i hi] + exact (hother_wf i hi).2 + Β· refine ⟨?_, ?_, ?_⟩ + Β· refine ⟨?_, ?_, ?_⟩ + Β· change TM.transitionInput inp1 = inp + rw [hinput_tr, hinp1] + Β· change TM.transitionTape out1 = out + rw [hout_tr, hout1] + Β· intro i hi + change TM.transitionTape (work1 i) = work i + rw [hwork_tr i hi, hwork1 i hi] + Β· change (TM.transitionTape (work1 idx)).cells 0 = Ξ“.start + rw [htarget_tr] + exact hcell01 + Β· intro j + change (TM.transitionTape (work1 idx)).cells (j + 1) = Ξ“.blank + rw [htarget_tr] + exact hblank1 j) + hrew + have hclear := hseq.strengthen_post (by + intro inp' work' out' hpost + rcases hpost with ⟨hhead, hblankframe⟩ + rcases hblankframe with ⟨hframe, hcell0, hblank⟩ + rcases hframe with ⟨hinp', hout', hwork'⟩ + have hbits : (work' idx).HasBinaryString [] := by + refine ⟨hhead, ?_, ?_⟩ + Β· intro i hi + exact (Nat.not_lt_zero i hi).elim + Β· intro i _ + exact hblank i + have hclear : work' idx = (Tape.init []).move Dir3.right := + Tape.eq_init_move_right_of_hasBinaryString hbits hcell0 + exact show work' idx = (Tape.init []).move Dir3.right ∧ P inp' work' out' from + ⟨hclear, hP_preserved inp work out inp' work' out' hP hclear hinp' hout' hwork'⟩) + exact hclear inp work out ⟨hwork, hinp_ns, hout_ns, hout_h, hother_wf, ⟨rfl, rfl, fun _ _ => rfl⟩⟩ + +/-- Starting from cell `k + 1` of a Boolean input tape and an already-copied +prefix `x.take k` on work tape `idx`, `copyInputToWorkTM idx` copies the +remaining suffix and halts with the full prefix `x` on the target tape. -/ +private theorem copyInputToWorkTM_loop {n : β„•} (idx : Fin n) (x : List Bool) : + βˆ€ rem k (c : Cfg n (copyInputToWorkTM idx).Q), + rem = x.length - k β†’ + c.state = CopyPhase.copying β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + (c.work idx).HasBinaryPrefix (x.take k) β†’ + k ≀ x.length β†’ + βˆƒ c', + (copyInputToWorkTM idx).reachesIn (rem + 1) c c' ∧ + (copyInputToWorkTM idx).halted c' ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = x.length + 1 ∧ + (c'.work idx).HasBinaryPrefix x := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_eq : k = x.length := by + omega + subst hk_eq + have hread : c.input.read = Ξ“.blank := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : (c.work idx).HasBinaryPrefix x := by + simpa using hprefix + have hwork_blank : (c.work idx).read = Ξ“.blank := by + have hblank := hprefix_full.2.2 x.length le_rfl + simp [Tape.read, hprefix_full.1, hblank] + have hstep : + βˆƒ c1, + (copyInputToWorkTM idx).step c = some c1 ∧ + (copyInputToWorkTM idx).halted c1 ∧ + c1.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c1.input.head = x.length + 1 ∧ + (c1.work idx).HasBinaryPrefix x := by + let c1 : Cfg n (copyInputToWorkTM idx).Q := + { state := CopyPhase.done + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove Ξ“.blank (TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove Ξ“.blank (TM.idleDir c.output.read) } + have hinput_keep : + c.input.move (TM.idleDir c.input.read) = c.input := by + simp [TM.idleDir, hread, Tape.move] + have hwork_keep : + (c.work idx).writeAndMove Ξ“.blank (TM.idleDir ((c.work idx).read)) = c.work idx := by + simpa [transitionTape, hwork_blank] using! + (transitionTape_eq_self (t := c.work idx) (by simp [hwork_blank])) + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyInputToWorkTM, hread, c1, allIdle] + Β· rw [show c1.input = c.input by simpa [c1] using hinput_keep] + exact hcells + Β· rw [show c1.input = c.input by simpa [c1] using hinput_keep] + exact hhead + Β· rw [show c1.work idx = c.work idx by + simpa [c1] using hwork_keep] + exact hprefix_full + obtain ⟨c1, hstep1, hhalt1, hcells1, hhead1, hprefix1⟩ := hstep + exact ⟨c1, .step hstep1 .zero, hhalt1, hcells1, hhead1, hprefix1⟩ + | succ rem ih => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_lt : k < x.length := by + omega + have hread : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hprefix_next : + ((c.work idx).writeAndMove (Ξ“.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + simpa [List.take_concat_get' x k hk_lt] using hwrite + have hstep : + βˆƒ c1, + (copyInputToWorkTM idx).step c = some c1 ∧ + c1.state = CopyPhase.copying ∧ + c1.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c1.input.head = k + 2 ∧ + (c1.work idx).HasBinaryPrefix (x.take (k + 1)) := by + cases hbit : x[k]'hk_lt with + | false => + have hread0 : c.input.read = Ξ“.zero := by + simpa [hbit] using! hread + let c1 : Cfg n (copyInputToWorkTM idx).Q := + { state := CopyPhase.copying + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.zero else Ξ“w.blank).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove Ξ“.blank (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyInputToWorkTM, hread0, c1] + Β· simpa [c1, Tape.move_cells] using hcells + Β· simp [c1, Tape.move, hhead] + Β· have hwidx : + c1.work idx = (c.work idx).writeAndMove Ξ“.zero Dir3.right := by + simp [c1] + rw [hwidx] + simpa [hbit] using! hprefix_next + | true => + have hread1 : c.input.read = Ξ“.one := by + simpa [hbit] using! hread + let c1 : Cfg n (copyInputToWorkTM idx).Q := + { state := CopyPhase.copying + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove + ((if i = idx then Ξ“w.one else Ξ“w.blank).toΞ“) + (if i = idx then Dir3.right else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove Ξ“.blank (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyInputToWorkTM, hread1, c1] + Β· simpa [c1, Tape.move_cells] using hcells + Β· simp [c1, Tape.move, hhead] + Β· have hwidx : + c1.work idx = (c.work idx).writeAndMove Ξ“.one Dir3.right := by + simp [c1] + rw [hwidx] + simpa [hbit] using! hprefix_next + obtain ⟨c1, hstep1, hstate1, hcells1, hhead1, hprefix1⟩ := hstep + have hrem1 : rem = x.length - (k + 1) := by + omega + obtain ⟨c', hreach, hhalt, hcells', hhead', hprefix'⟩ := + ih (k + 1) c1 hrem1 hstate1 hcells1 hhead1 hprefix1 (by omega) + exact ⟨c', .step hstep1 hreach, hhalt, hcells', hhead', hprefix'⟩ + +/-- `copyInputToWorkTM idx` can be started with the input and target work tape +already positioned at cell `1`: it copies the entire Boolean input to a binary +prefix on work tape `idx` and halts within `|x| + 1` steps. -/ +theorem copyInputToWorkTM_started_hoareTime {n : β„•} (idx : Fin n) (x : List Bool) : + (copyInputToWorkTM idx).HoareTime + (fun inp work _out => + inp = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + (work idx).HasBinaryPrefix []) + (fun inp work _out => + inp.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + inp.head = x.length + 1 ∧ + (work idx).HasBinaryPrefix x) + (x.length + 1) := by + intro inp work out hpre + rcases hpre with ⟨hinp, hprefix⟩ + subst inp + obtain ⟨c', hreach, hhalt, hcells, hhead, hprefix'⟩ := + copyInputToWorkTM_loop idx x x.length 0 + { state := CopyPhase.copying + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := work + output := out } + (by simp) + rfl + (by simp [Tape.move]) + rfl + (by simpa using hprefix) + (Nat.zero_le _) + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hcells, hhead, hprefix'⟩ + +private theorem copyWorkToWorkTM_loop {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) : + βˆ€ rem k (c : Cfg n (copyWorkToWorkTM src dst).Q), + rem = x.length - k β†’ + c.state = CopyPhase.copying β†’ + (c.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + (c.work src).head = k + 1 β†’ + (c.work dst).HasBinaryPrefix (x.take k) β†’ + k ≀ x.length β†’ + βˆƒ c', + (copyWorkToWorkTM src dst).reachesIn (rem + 1) c c' ∧ + (copyWorkToWorkTM src dst).halted c' ∧ + (c'.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (c'.work src).head = x.length + 1 ∧ + (c'.work dst).HasBinaryPrefix x := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hsrc_cells hsrc_head hprefix hk_le + have hk_eq : k = x.length := by + omega + subst hk_eq + have hsrc_read : (c.work src).read = Ξ“.blank := by + simp [Tape.read, hsrc_head, hsrc_cells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : (c.work dst).HasBinaryPrefix x := by + simpa using hprefix + have hdst_read : (c.work dst).read = Ξ“.blank := by + have hblank := hprefix_full.2.2 x.length le_rfl + simp [Tape.read, hprefix_full.1, hblank] + have hstep : + βˆƒ c1, + (copyWorkToWorkTM src dst).step c = some c1 ∧ + (copyWorkToWorkTM src dst).halted c1 ∧ + (c1.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (c1.work src).head = x.length + 1 ∧ + (c1.work dst).HasBinaryPrefix x := by + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.done + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (TM.readBackWrite ((c.work i).read)).toΞ“ + (TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hsrc_keep : c1.work src = c.work src := by + have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hsrc_read] + decide + simpa [c1, hsrc_read, TM.transitionTape] using + (TM.transitionTape_eq_self (t := c.work src) hsrc_ne) + have hdst_keep : c1.work dst = c.work dst := by + have hdst_ne : (c.work dst).read β‰  Ξ“.start := by + rw [hdst_read] + decide + simpa [c1, hdst_read, TM.transitionTape] using + (TM.transitionTape_eq_self (t := c.work dst) hdst_ne) + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyWorkToWorkTM, hsrc_read, c1, allIdle] + Β· rw [hsrc_keep] + exact hsrc_cells + Β· rw [hsrc_keep, hsrc_head] + Β· rw [hdst_keep] + exact hprefix_full + obtain ⟨c1, hstep1, hhalt1, hsrc_cells1, hsrc_head1, hprefix1⟩ := hstep + exact ⟨c1, .step hstep1 .zero, hhalt1, hsrc_cells1, hsrc_head1, hprefix1⟩ + | succ rem ih => + intro k c hrem hstate hsrc_cells hsrc_head hprefix hk_le + have hk_lt : k < x.length := by + omega + have hsrc_read : (c.work src).read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hsrc_head, hsrc_cells, Tape.init_ofBool_cells_lt x k hk_lt] + have hprefix_next : + ((c.work dst).writeAndMove (Ξ“.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + simpa [List.take_concat_get' x k hk_lt] using hwrite + have hstep : + βˆƒ c1, + (copyWorkToWorkTM src dst).step c = some c1 ∧ + c1.state = CopyPhase.copying ∧ + (c1.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (c1.work src).head = k + 2 ∧ + (c1.work dst).HasBinaryPrefix (x.take (k + 1)) := by + cases hbit : x[k]'hk_lt with + | false => + have hread0 : (c.work src).read = Ξ“.zero := by + simpa [hbit] using! hsrc_read + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.copying + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = dst then Ξ“w.zero else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = dst then Dir3.right else if i = src then Dir3.right + else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyWorkToWorkTM, hread0, c1, TM.readBackWrite] + Β· have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hread0] + decide + have hsrc_pres : + (c1.work src).cells = (c.work src).cells := by + simpa [c1, hread0, hne, TM.readBackWrite] using + (TM.tape_readBackWrite_preserves (c.work src) Dir3.right (Or.inr hsrc_ne)) + rw [hsrc_pres] + exact hsrc_cells + Β· simp [c1, hsrc_head, hne, Tape.writeAndMove, Tape.move, Tape.write_head] + Β· have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.zero Dir3.right := by + simp [c1] + rw [hdst] + simpa [hbit] using! hprefix_next + | true => + have hread1 : (c.work src).read = Ξ“.one := by + simpa [hbit] using! hsrc_read + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.copying + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = dst then Ξ“w.one else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = dst then Dir3.right else if i = src then Dir3.right + else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyWorkToWorkTM, hread1, c1, TM.readBackWrite] + Β· have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hread1] + decide + have hsrc_pres : + (c1.work src).cells = (c.work src).cells := by + simpa [c1, hread1, hne, TM.readBackWrite] using + (TM.tape_readBackWrite_preserves (c.work src) Dir3.right (Or.inr hsrc_ne)) + rw [hsrc_pres] + exact hsrc_cells + Β· simp [c1, hsrc_head, hne, Tape.writeAndMove, Tape.move, Tape.write_head] + Β· have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.one Dir3.right := by + simp [c1] + rw [hdst] + simpa [hbit] using! hprefix_next + obtain ⟨c1, hstep1, hstate1, hsrc_cells1, hsrc_head1, hprefix1⟩ := hstep + have hrem1 : rem = x.length - (k + 1) := by + omega + obtain ⟨c', hreach, hhalt, hsrc_cells', hsrc_head', hprefix'⟩ := + ih (k + 1) c1 hrem1 hstate1 hsrc_cells1 hsrc_head1 hprefix1 (by omega) + exact ⟨c', .step hstep1 hreach, hhalt, hsrc_cells', hsrc_head', hprefix'⟩ + +/-- If `src` holds a started Boolean string `x` and `dst` is a started blank +work tape, then `copyWorkToWorkTM src dst` copies `x` onto `dst` within +`|x| + 1` steps. The source contents are preserved, while its head advances +to the first blank cell after the copied data. -/ +theorem copyWorkToWorkTM_started_hoareTime {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) : + (copyWorkToWorkTM src dst).HoareTime + (fun _inp work _out => + work src = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + (work dst).HasBinaryPrefix []) + (fun _inp work _out => + (work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work src).head = x.length + 1 ∧ + (work dst).HasBinaryPrefix x) + (x.length + 1) := by + intro inp work out hpre + rcases hpre with ⟨hsrc, hdst⟩ + have hsrc_cells0 : (work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + rw [hsrc] + exact Tape.move_cells _ _ + have hsrc_head0 : (work src).head = 1 := by + rw [hsrc] + simp [Tape.move, Tape.init] + obtain ⟨c', hreach, hhalt, hsrc_cells, hsrc_head, hprefix⟩ := + copyWorkToWorkTM_loop src dst hne x x.length 0 + { state := CopyPhase.copying + input := inp + work := work + output := out } + (by simp) + rfl + hsrc_cells0 + hsrc_head0 + (by simpa using hdst) + (Nat.zero_le _) + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hsrc_cells, hsrc_head, hprefix⟩ + +private theorem copyWorkToWork_idleTape : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ t.head β‰₯ 1 β†’ + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + intro t hns hh + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + Β· omega + Β· simp only [Tape.read] at hns ⊒ + rw [toΞ“_readBackWrite_of_ne_start hns, Function.update_eq_self] + +private theorem copyWorkToWork_idleInput : βˆ€ (t : Tape), t.read β‰  Ξ“.start β†’ + t.move (idleDir t.read) = t := by + intro t hns + simp [idleDir, hns, Tape.move] + +/-- A single copying step advances both tape heads and preserves the complete outside frame. -/ +private theorem copyWorkToWork_copyStep {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (k : β„•) (hk_lt : k < x.length) + (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (hinp_ns : inp.read β‰  Ξ“.start) (hout_ns : out.read β‰  Ξ“.start) (hout_h : out.head β‰₯ 1) + (hother_wf : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) + (c : Cfg n (copyWorkToWorkTM src dst).Q) (hstate : c.state = CopyPhase.copying) + (hsrc_cells : (c.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells) + (hsrc_head : (c.work src).head = k + 1) + (hprefix : (c.work dst).HasBinaryPrefix (x.take k)) + (hdst_cell0 : (c.work dst).cells 0 = Ξ“.start) + (hinp_c : c.input = inp) (hout_c : c.output = out) + (hw_c : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c.work i = work i) : + βˆƒ c1 : Cfg n (copyWorkToWorkTM src dst).Q, + (copyWorkToWorkTM src dst).step c = some c1 ∧ c1.state = CopyPhase.copying ∧ + (c1.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (c1.work src).head = k + 2 ∧ (c1.work dst).HasBinaryPrefix (x.take (k + 1)) ∧ + (c1.work dst).cells 0 = Ξ“.start ∧ c1.input = inp ∧ c1.output = out ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c1.work i = work i) := by + have hsrc_read : (c.work src).read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hsrc_head, hsrc_cells, Tape.init_ofBool_cells_lt x k hk_lt] + have hprefix_next : + ((c.work dst).writeAndMove (Ξ“.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + simpa [List.take_concat_get' x k hk_lt] using hwrite + cases hbit : x[k]'hk_lt with + | false => + have hread0 : (c.work src).read = Ξ“.zero := by + simpa [hbit] using! hsrc_read + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.copying + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = dst then Ξ“w.zero else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = dst then Dir3.right else if i = src then Dir3.right + else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (copyWorkToWorkTM src dst).step c = some c1 := by + simp [TM.step, hstate, copyWorkToWorkTM, hread0, c1, TM.readBackWrite] + have hinput_keep : c1.input = inp := by + simpa [c1, hinp_c] using copyWorkToWork_idleInput inp hinp_ns + have houtput_keep : c1.output = out := by + simpa [c1, hout_c] using copyWorkToWork_idleTape out hout_ns hout_h + have hother_keep : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c1.work i = work i := by + intro i hi_src hi_dst + simpa [c1, hi_src, hi_dst, hw_c i hi_src hi_dst] using + copyWorkToWork_idleTape (work i) (hother_wf i hi_src hi_dst).1 + (hother_wf i hi_src hi_dst).2 + have hsrc_cells1 : (c1.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hread0] + decide + have hsrc_pres : + (c1.work src).cells = (c.work src).cells := by + simpa [c1, hread0, hne, TM.readBackWrite] using + (TM.tape_readBackWrite_preserves (c.work src) Dir3.right (Or.inr hsrc_ne)) + rw [hsrc_pres] + exact hsrc_cells + have hsrc_head1 : (c1.work src).head = k + 2 := by + simp [c1, hsrc_head, hne, Tape.writeAndMove, Tape.move, Tape.write_head] + have hdst_prefix1 : (c1.work dst).HasBinaryPrefix (x.take (k + 1)) := by + have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.zero Dir3.right := by + simp [c1] + rw [hdst] + simpa [hbit] using! hprefix_next + have hdst_cell01 : (c1.work dst).cells 0 = Ξ“.start := by + have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.zero Dir3.right := by + simp [c1] + rw [hdst] + exact Tape.hasBinaryPrefix_write_bit_cell0 false hprefix hdst_cell0 + exact ⟨c1, hstep1, rfl, hsrc_cells1, hsrc_head1, hdst_prefix1, hdst_cell01, + hinput_keep, houtput_keep, hother_keep⟩ + | true => + have hread1 : (c.work src).read = Ξ“.one := by + simpa [hbit] using! hsrc_read + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.copying + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + ((if i = dst then Ξ“w.one else TM.readBackWrite ((c.work i).read)).toΞ“) + (if i = dst then Dir3.right else if i = src then Dir3.right + else TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (copyWorkToWorkTM src dst).step c = some c1 := by + simp [TM.step, hstate, copyWorkToWorkTM, hread1, c1, TM.readBackWrite] + have hinput_keep : c1.input = inp := by + simpa [c1, hinp_c] using copyWorkToWork_idleInput inp hinp_ns + have houtput_keep : c1.output = out := by + simpa [c1, hout_c] using copyWorkToWork_idleTape out hout_ns hout_h + have hother_keep : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c1.work i = work i := by + intro i hi_src hi_dst + simpa [c1, hi_src, hi_dst, hw_c i hi_src hi_dst] using + copyWorkToWork_idleTape (work i) (hother_wf i hi_src hi_dst).1 + (hother_wf i hi_src hi_dst).2 + have hsrc_cells1 : (c1.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hread1] + decide + have hsrc_pres : + (c1.work src).cells = (c.work src).cells := by + simpa [c1, hread1, hne, TM.readBackWrite] using + (TM.tape_readBackWrite_preserves (c.work src) Dir3.right (Or.inr hsrc_ne)) + rw [hsrc_pres] + exact hsrc_cells + have hsrc_head1 : (c1.work src).head = k + 2 := by + simp [c1, hsrc_head, hne, Tape.writeAndMove, Tape.move, Tape.write_head] + have hdst_prefix1 : (c1.work dst).HasBinaryPrefix (x.take (k + 1)) := by + have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.one Dir3.right := by + simp [c1] + rw [hdst] + simpa [hbit] using! hprefix_next + have hdst_cell01 : (c1.work dst).cells 0 = Ξ“.start := by + have hdst : + c1.work dst = (c.work dst).writeAndMove Ξ“.one Dir3.right := by + simp [c1] + rw [hdst] + exact Tape.hasBinaryPrefix_write_bit_cell0 true hprefix hdst_cell0 + exact ⟨c1, hstep1, rfl, hsrc_cells1, hsrc_head1, hdst_prefix1, hdst_cell01, + hinput_keep, houtput_keep, hother_keep⟩ + +/-- Rich HoareTime for `copyWorkToWorkTM`: copy a started Boolean work tape to +another started blank work tape while preserving arbitrary frame data on the +input tape, output tape, and all unrelated work tapes. The source cells are +preserved while its head advances to the first blank after the copied string, +and the destination accumulates the copied prefix without losing its left-end +marker. -/ +theorem copyWorkToWorkTM_hoareTime_frame_of_binaryString {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP_preserved : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' src).cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + (work' src).head = x.length + 1 β†’ + (work' dst).HasBinaryPrefix x β†’ + (work' dst).cells 0 = Ξ“.start β†’ + inp' = inp β†’ + out' = out β†’ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = work i) β†’ + P inp' work' out') : + (copyWorkToWorkTM src dst).HoareTime + (fun inp work out => + work src = (Tape.init (x.map Ξ“.ofBool)).move Dir3.right ∧ + work dst = (Tape.init []).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ + out.read β‰  Ξ“.start ∧ out.head β‰₯ 1 ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ (work i).read β‰  Ξ“.start ∧ (work i).head β‰₯ 1) ∧ + P inp work out) + (fun inp work out => + (work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (work src).head = x.length + 1 ∧ + (work dst).HasBinaryPrefix x ∧ + (work dst).cells 0 = Ξ“.start ∧ + P inp work out) + (x.length + 1) := by + intro inp work out hpre + rcases hpre with ⟨hsrc, hdst, hinp_ns, hout_ns, hout_h, hother_wf, hP⟩ + suffices h_loop : βˆ€ rem k (c : Cfg n (copyWorkToWorkTM src dst).Q), + rem = x.length - k β†’ + c.state = CopyPhase.copying β†’ + (c.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + (c.work src).head = k + 1 β†’ + (c.work dst).HasBinaryPrefix (x.take k) β†’ + (c.work dst).cells 0 = Ξ“.start β†’ + k ≀ x.length β†’ + c.input = inp β†’ + c.output = out β†’ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c.work i = work i) β†’ + βˆƒ c', + (copyWorkToWorkTM src dst).reachesIn (rem + 1) c c' ∧ + (copyWorkToWorkTM src dst).halted c' ∧ + (c'.work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + (c'.work src).head = x.length + 1 ∧ + (c'.work dst).HasBinaryPrefix x ∧ + (c'.work dst).cells 0 = Ξ“.start ∧ + c'.input = inp ∧ + c'.output = out ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c'.work i = work i) by + have hsrc_cells0 : (work src).cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + rw [hsrc] + exact Tape.move_cells _ _ + have hsrc_head0 : (work src).head = 1 := by + rw [hsrc] + simp [Tape.move, Tape.init] + have hdst_prefix0 : (work dst).HasBinaryPrefix [] := by + rw [hdst] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hdst_cell00 : (work dst).cells 0 = Ξ“.start := by + rw [hdst] + simp [Tape.move, Tape.init] + obtain ⟨c', hreach, hhalt, hsrc_cells, hsrc_head, hprefix, hcell0, hinp', hout', + hwork'⟩ := + h_loop x.length 0 + { state := CopyPhase.copying, input := inp, work := work, output := out } + (by simp) + rfl + hsrc_cells0 + hsrc_head0 + hdst_prefix0 + hdst_cell00 + (Nat.zero_le _) + rfl + rfl + (fun _ _ _ => rfl) + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hsrc_cells, hsrc_head, hprefix, + hcell0, ?_⟩ + exact hP_preserved inp work out c'.input c'.work c'.output hP + hsrc_cells hsrc_head hprefix hcell0 hinp' hout' hwork' + intro rem + induction rem with + | zero => + intro k c hrem hstate hsrc_cells hsrc_head hprefix hdst_cell0 hk_le hinp_c hout_c hw_c + have hk_eq : k = x.length := by + omega + subst hk_eq + have hsrc_read : (c.work src).read = Ξ“.blank := by + simp [Tape.read, hsrc_head, hsrc_cells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : (c.work dst).HasBinaryPrefix x := by + simpa using hprefix + have hdst_read : (c.work dst).read = Ξ“.blank := by + have hblank := hprefix_full.2.2 x.length le_rfl + simp [Tape.read, hprefix_full.1, hblank] + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.done + input := c.input.move (TM.idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (TM.readBackWrite ((c.work i).read)).toΞ“ + (TM.idleDir ((c.work i).read)) + output := c.output.writeAndMove (TM.readBackWrite c.output.read).toΞ“ + (TM.idleDir c.output.read) } + have hstep1 : (copyWorkToWorkTM src dst).step c = some c1 := by + simp [TM.step, hstate, copyWorkToWorkTM, hsrc_read, c1, allIdle] + have hinput_keep : c1.input = inp := by + simpa [c1, hinp_c] using copyWorkToWork_idleInput inp hinp_ns + have houtput_keep : c1.output = out := by + simpa [c1, hout_c] using copyWorkToWork_idleTape out hout_ns hout_h + have hother_keep : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c1.work i = work i := by + intro i hi_src hi_dst + simpa [c1, hi_src, hi_dst, hw_c i hi_src hi_dst] using + copyWorkToWork_idleTape (work i) (hother_wf i hi_src hi_dst).1 + (hother_wf i hi_src hi_dst).2 + have hsrc_keep : c1.work src = c.work src := by + have hsrc_ne : (c.work src).read β‰  Ξ“.start := by + rw [hsrc_read] + decide + simpa [c1, hsrc_read, TM.transitionTape] using + (TM.transitionTape_eq_self (t := c.work src) hsrc_ne) + have hdst_keep : c1.work dst = c.work dst := by + have hdst_ne : (c.work dst).read β‰  Ξ“.start := by + rw [hdst_read] + decide + simpa [c1, hdst_read, TM.transitionTape] using + (TM.transitionTape_eq_self (t := c.work dst) hdst_ne) + refine ⟨c1, .step hstep1 .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [hsrc_keep] + exact hsrc_cells + Β· rw [hsrc_keep, hsrc_head] + Β· rw [hdst_keep] + exact hprefix_full + Β· rw [hdst_keep] + exact hdst_cell0 + Β· exact hinput_keep + Β· exact houtput_keep + Β· exact hother_keep + | succ rem ih => + intro k c hrem hstate hsrc_cells hsrc_head hprefix hdst_cell0 hk_le hinp_c hout_c hw_c + have hk_lt : k < x.length := by + omega + obtain ⟨c1, hstep1, hstate1, hsrc_cells1, hsrc_head1, hdst_prefix1, hdst_cell01, + hinput_keep, houtput_keep, hother_keep⟩ := + copyWorkToWork_copyStep src dst hne x k hk_lt inp work out + hinp_ns hout_ns hout_h hother_wf c hstate hsrc_cells hsrc_head + hprefix hdst_cell0 hinp_c hout_c hw_c + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hsrc_cells', hsrc_head', hprefix', hcell0', hinp', + hout', hwork'⟩ := + ih (k + 1) c1 hrem1 hstate1 hsrc_cells1 hsrc_head1 hdst_prefix1 hdst_cell01 + (by omega) hinput_keep houtput_keep hother_keep + exact ⟨c', .step hstep1 hreach, hhalt, hsrc_cells', hsrc_head', hprefix', hcell0', + hinp', hout', hwork'⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyOutput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyOutput.lean new file mode 100644 index 0000000000..20ae56cb92 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyOutput.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# Input-to-output copy correctness + +Exact simulation proof for `TM.copyInputToOutputTM`. Starting from the initial +configuration on `x`, the machine skips the two left-end markers, copies one +Boolean symbol per step, and halts at the first input blank after exactly +`|x| + 2` steps with output `x`. + +The public theorem is stated in +`Complexitylib.Models.TuringMachine.Subroutines.CopyOutput`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-! ## Copy loop -/ + +/-- From the first uncopied input cell and an output holding `x.take k`, the +copy loop consumes the remaining `rem = |x| - k` bits and one terminating +blank step. -/ +private theorem copyInputToOutputTM_loop {n : β„•} (x : List Bool) : + βˆ€ rem k (c : Cfg n (copyInputToOutputTM (n := n)).Q), + rem = x.length - k β†’ + c.state = CopyPhase.copying β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + c.output.HasBinaryPrefix (x.take k) β†’ + k ≀ x.length β†’ + βˆƒ c', + (copyInputToOutputTM (n := n)).reachesIn (rem + 1) c c' ∧ + (copyInputToOutputTM (n := n)).halted c' ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = x.length + 1 ∧ + c'.output.HasBinaryPrefix x := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_eq : k = x.length := by omega + subst hk_eq + have hread : c.input.read = Ξ“.blank := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : c.output.HasBinaryPrefix x := by + simpa using hprefix + have houtput_blank : c.output.read = Ξ“.blank := by + have hblank := hprefix_full.2.2 x.length le_rfl + simp [Tape.read, hprefix_full.1, hblank] + let c1 : Cfg n (copyInputToOutputTM (n := n)).Q := + { state := CopyPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hinput_keep : c.input.move (idleDir c.input.read) = c.input := by + simp [idleDir, hread, Tape.move] + have houtput_keep : + c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) = c.output := by + exact transitionTape_eq_self (t := c.output) (by simp [houtput_blank]) + have hstep : (copyInputToOutputTM (n := n)).step c = some c1 := by + simp [TM.step, hstate, copyInputToOutputTM, hread, c1] + refine ⟨c1, .step hstep .zero, rfl, ?_, ?_, ?_⟩ + Β· rw [show c1.input = c.input by simpa [c1] using hinput_keep] + exact hcells + Β· rw [show c1.input = c.input by simpa [c1] using hinput_keep] + exact hhead + Β· rw [show c1.output = c.output by simpa [c1] using houtput_keep] + exact hprefix_full + | succ rem ih => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_lt : k < x.length := by omega + have hread : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hprefix_next : + (c.output.writeAndMove (Ξ“.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + simpa [List.take_concat_get' x k hk_lt] using hwrite + have hstep : + βˆƒ c1, + (copyInputToOutputTM (n := n)).step c = some c1 ∧ + c1.state = CopyPhase.copying ∧ + c1.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c1.input.head = k + 2 ∧ + c1.output.HasBinaryPrefix (x.take (k + 1)) := by + cases hbit : x[k]'hk_lt with + | false => + have hread0 : c.input.read = Ξ“.zero := by + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, hbit] using hread + let c1 : Cfg n (copyInputToOutputTM (n := n)).Q := + { state := CopyPhase.copying + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove Ξ“.zero Dir3.right } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyInputToOutputTM, hread0, c1, readBackWrite] + Β· simpa [c1, Tape.move_cells] using hcells + Β· simp [c1, Tape.move, hhead] + Β· simpa [c1, hbit] using! hprefix_next + | true => + have hread1 : c.input.read = Ξ“.one := by + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, hbit] using hread + let c1 : Cfg n (copyInputToOutputTM (n := n)).Q := + { state := CopyPhase.copying + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove Ξ“.one Dir3.right } + refine ⟨c1, ?_, rfl, ?_, ?_, ?_⟩ + Β· simp [TM.step, hstate, copyInputToOutputTM, hread1, c1, readBackWrite] + Β· simpa [c1, Tape.move_cells] using hcells + Β· simp [c1, Tape.move, hhead] + Β· simpa [c1, hbit] using! hprefix_next + obtain ⟨c1, hstep1, hstate1, hcells1, hhead1, hprefix1⟩ := hstep + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hcells', hhead', hprefix'⟩ := + ih (k + 1) c1 hrem1 hstate1 hcells1 hhead1 hprefix1 (by omega) + exact ⟨c', .step hstep1 hreach, hhalt, hcells', hhead', hprefix'⟩ + +/-! ## Initial-configuration correctness -/ + +/-- Internal implementation theorem: the copy machine computes identity in +the exact linear bound `m + 2`. -/ +theorem copyInputToOutputTM_computesInTime_internal (n : β„•) : + (copyInputToOutputTM (n := n)).ComputesInTime id (fun m => m + 2) := by + intro x + let c1 : Cfg n (copyInputToOutputTM (n := n)).Q := + { state := CopyPhase.copying + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep : + (copyInputToOutputTM (n := n)).step + ((copyInputToOutputTM (n := n)).initCfg x) = some c1 := by + simp [TM.step, copyInputToOutputTM, c1, Tape.read, Tape.init, readBackWrite, + idleDir, Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c', hreach, hhalt, _hcells, _hhead, hprefix⟩ := + copyInputToOutputTM_loop (n := n) x x.length 0 c1 (by simp) rfl + (by simp [c1, Tape.move]) (by simp [c1, Tape.move]) + (by simpa [c1] using Tape.init_nil_move_right_hasBinaryPrefix_nil) + (Nat.zero_le _) + refine ⟨c', x.length + 2, le_rfl, ?_, hhalt, ?_⟩ + Β· simpa [Nat.add_assoc] using TM.reachesIn.step hstep hreach + Β· simpa using (show c'.output.HasOutput x from + ⟨hprefix.2.1, hprefix.2.2 x.length le_rfl⟩) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyWorkOutput.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyWorkOutput.lean new file mode 100644 index 0000000000..eac5dc9898 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/Internal/CopyWorkOutput.lean @@ -0,0 +1,351 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Copy a raw work-tape output β€” proof internals + +`Tape.HasOutput` deliberately leaves cells after the terminating blank +unconstrained. This module proves that `TM.copyWorkToWorkTM` nevertheless +copies such an output to a fresh work tape: it reads only the advertised bits +and their first blank delimiter. + +Public statements are in +`Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-! ## Exact copy loop -/ + +/-- Copy the unread suffix of a raw output while preserving the source cells. -/ +private theorem copyWorkOutput_loop {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (source : Tape) : + βˆ€ rem k (c : Cfg n (copyWorkToWorkTM src dst).Q) (dstCell0 : Ξ“), + rem = x.length - k β†’ + c.state = CopyPhase.copying β†’ + (c.work src).cells = source.cells β†’ + (c.work src).head = k + 1 β†’ + source.HasOutput x β†’ + (c.work dst).HasBinaryPrefix (x.take k) β†’ + (c.work dst).cells 0 = dstCell0 β†’ + k ≀ x.length β†’ + βˆƒ c', + (copyWorkToWorkTM src dst).reachesIn (rem + 1) c c' ∧ + (copyWorkToWorkTM src dst).halted c' ∧ + (c'.work src).cells = source.cells ∧ + (c'.work src).head = x.length + 1 ∧ + (c'.work src).HasOutput x ∧ + (c'.work dst).HasBinaryPrefix x ∧ + (c'.work dst).cells 0 = dstCell0 := by + intro rem + induction rem with + | zero => + intro k c dstCell0 hrem hstate hsrcCells hsrcHead hsource hprefix hdst0 hk + have hkEq : k = x.length := by omega + subst hkEq + have hsrcRead : (c.work src).read = Ξ“.blank := by + rw [Tape.read, hsrcHead, hsrcCells] + exact hsource.2 + have hprefixFull : (c.work dst).HasBinaryPrefix x := by + simpa using hprefix + have hdstRead : (c.work dst).read = Ξ“.blank := by + rw [Tape.read, hprefixFull.1] + exact hprefixFull.2.2 x.length le_rfl + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read).toΞ“ + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΞ“ + (idleDir c.output.read) } + have hstep : (copyWorkToWorkTM src dst).step c = some c1 := by + simp [TM.step, hstate, copyWorkToWorkTM, hsrcRead, c1, allIdle] + have hsrcKeep : c1.work src = c.work src := by + have hneStart : (c.work src).read β‰  Ξ“.start := by + rw [hsrcRead] + decide + simpa [c1, hsrcRead, transitionTape] using + (transitionTape_eq_self (t := c.work src) hneStart) + have hdstKeep : c1.work dst = c.work dst := by + have hneStart : (c.work dst).read β‰  Ξ“.start := by + rw [hdstRead] + decide + simpa [c1, hdstRead, transitionTape] using + (transitionTape_eq_self (t := c.work dst) hneStart) + refine ⟨c1, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [hsrcKeep] + exact hsrcCells + Β· rw [hsrcKeep, hsrcHead] + Β· rw [hsrcKeep] + exact (Tape.hasOutput_congr hsrcCells x).mpr hsource + Β· rw [hdstKeep] + exact hprefixFull + Β· rw [hdstKeep] + exact hdst0 + | succ rem ih => + intro k c dstCell0 hrem hstate hsrcCells hsrcHead hsource hprefix hdst0 hk + have hkLt : k < x.length := by omega + let bit := x[k]'hkLt + have hsrcRead : (c.work src).read = Ξ“.ofBool bit := by + rw [Tape.read, hsrcHead, hsrcCells] + exact hsource.1 k hkLt + have hprefixNext : + ((c.work dst).writeAndMove (Ξ“.ofBool bit) Dir3.right).HasBinaryPrefix + (x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit bit hprefix + simpa [bit, List.take_concat_get' x k hkLt] using hwrite + let c1 : Cfg n (copyWorkToWorkTM src dst).Q := + { state := CopyPhase.copying + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove + (if i = dst then (Ξ“w.ofBool bit).toΞ“ + else (readBackWrite (c.work i).read).toΞ“) + (if i = dst then Dir3.right + else if i = src then Dir3.right else idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΞ“ + (idleDir c.output.read) } + have hstep : (copyWorkToWorkTM src dst).step c = some c1 := by + cases hbit : bit + Β· simp [TM.step, hstate, copyWorkToWorkTM, hsrcRead, hbit, bit, c1, + Ξ“.ofBool, Ξ“w.ofBool, Ξ“w.toΞ“, readBackWrite] + funext i + by_cases hi : i = dst <;> simp [hi] + Β· simp [TM.step, hstate, copyWorkToWorkTM, hsrcRead, hbit, bit, c1, + Ξ“.ofBool, Ξ“w.ofBool, Ξ“w.toΞ“, readBackWrite] + funext i + by_cases hi : i = dst <;> simp [hi] + have hsrcCells1 : (c1.work src).cells = source.cells := by + have hneStart : (c.work src).read β‰  Ξ“.start := by + rw [hsrcRead] + exact Ξ“.ofBool_ne_start bit + have hpres : (c1.work src).cells = (c.work src).cells := by + simpa [c1, hne, hsrcRead] using + (tape_readBackWrite_preserves (c.work src) Dir3.right (Or.inr hneStart)) + rw [hpres] + exact hsrcCells + have hsrcHead1 : (c1.work src).head = k + 2 := by + simp [c1, hsrcHead, hne, Tape.writeAndMove, Tape.move, Tape.write_head] + have hdstTape : + c1.work dst = (c.work dst).writeAndMove (Ξ“.ofBool bit) Dir3.right := by + dsimp only [c1] + simp only [ite_eq_left] + rw [Ξ“w.ofBool_toΞ“] + have hdstPrefix1 : (c1.work dst).HasBinaryPrefix (x.take (k + 1)) := by + rw [hdstTape] + exact hprefixNext + have hdst01 : (c1.work dst).cells 0 = dstCell0 := by + rw [hdstTape] + simp only [Tape.writeAndMove, Tape.move_cells, Tape.write] + rw [ite_eq_right (by rw [hprefix.1]; omega)] + change Function.update (c.work dst).cells (c.work dst).head + (Ξ“.ofBool bit) 0 = dstCell0 + rw [Function.update_of_ne (by rw [hprefix.1]; omega)] + exact hdst0 + have hrem1 : rem = x.length - (k + 1) := by omega + obtain ⟨c', hreach, hhalt, hsrcCells', hsrcHead', hsrcOutput', hprefix', + hdst0'⟩ := + ih (k + 1) c1 dstCell0 hrem1 rfl hsrcCells1 hsrcHead1 hsource + hdstPrefix1 hdst01 (by omega) + exact ⟨c', .step hstep hreach, hhalt, hsrcCells', hsrcHead', hsrcOutput', + hprefix', hdst0'⟩ + +/-! ## Hoare specification -/ + +/-- Exact raw-output copy from a concrete tape configuration. -/ +theorem copyWorkToWorkTM_reachesIn_of_hasOutput_internal {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) + {inp out : Tape} {work : Fin n β†’ Tape} + (hsrcHead : (work src).head = 1) + (hsrcOutput : (work src).HasOutput x) + (hdst : (work dst).HasBinaryPrefix []) : + βˆƒ c', + (copyWorkToWorkTM src dst).reachesIn (x.length + 1) + { state := (copyWorkToWorkTM src dst).qstart, + input := inp, work := work, output := out } c' ∧ + (copyWorkToWorkTM src dst).halted c' ∧ + (c'.work src).cells = (work src).cells ∧ + (c'.work src).head = x.length + 1 ∧ + (c'.work src).HasOutput x ∧ + (c'.work dst).HasBinaryPrefix x ∧ + (c'.work dst).cells 0 = (work dst).cells 0 := by + exact copyWorkOutput_loop src dst hne x (work src) x.length 0 + { state := CopyPhase.copying, input := inp, work := work, output := out } + ((work dst).cells 0) (by simp) rfl rfl hsrcHead hsrcOutput + (by simpa using hdst) rfl (Nat.zero_le _) + +/-- A raw `HasOutput` source is copied exactly through its first blank. +Arbitrary source cells after that delimiter are preserved and ignored. -/ +theorem copyWorkToWorkTM_hoareTime_of_hasOutput_internal {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (source : Tape) : + (copyWorkToWorkTM src dst).HoareTime + (fun _inp work _out => + work src = source ∧ source.head = 1 ∧ source.HasOutput x ∧ + (work dst).HasBinaryPrefix []) + (fun _inp work _out => + (work src).cells = source.cells ∧ + (work src).head = x.length + 1 ∧ + (work src).HasOutput x ∧ + (work dst).HasBinaryPrefix x) + (x.length + 1) := by + intro inp work out hpre + rcases hpre with ⟨hsrc, hsourceHead, hsourceOutput, hdst⟩ + have hsrcCells : (work src).cells = source.cells := by rw [hsrc] + have hsrcHead : (work src).head = 1 := by rw [hsrc, hsourceHead] + obtain ⟨c', hreach, hhalt, hsrcCells', hsrcHead', hsrcOutput', hprefix', _⟩ := + copyWorkOutput_loop src dst hne x source x.length 0 + { state := CopyPhase.copying, input := inp, work := work, output := out } + ((work dst).cells 0) (by simp) rfl hsrcCells hsrcHead hsourceOutput + (by simpa using hdst) rfl (Nat.zero_le _) + exact ⟨c', x.length + 1, le_rfl, hreach, hhalt, hsrcCells', hsrcHead', + hsrcOutput', hprefix'⟩ + +/-! ## Exact frame preservation -/ + +/-- A stable tape is unchanged by the copy machine's idle action. -/ +private theorem idle_writeBack_eq (t : Tape) + (hread : t.read β‰  Ξ“.start) (hhead : 1 ≀ t.head) : + t.writeAndMove (readBackWrite t.read).toΞ“ (idleDir t.read) = t := by + simp only [Tape.writeAndMove, idleDir, hread, ↓reduceIte, Tape.move, Tape.write] + split + Β· omega + Β· simp only [Tape.read] at hread ⊒ + rw [toΞ“_readBackWrite_of_ne_start hread, Function.update_eq_self] + +/-- A stable read-only tape is unchanged by the input idle action. -/ +private theorem idle_input_eq (t : Tape) (hread : t.read β‰  Ξ“.start) : + t.move (idleDir t.read) = t := by + simp [idleDir, hread, Tape.move] + +/-- One copy step preserves the input, output, and every unrelated work tape +when those tapes are already off the left-end marker. -/ +private theorem copyWorkOutput_step_frame {n : β„•} (src dst : Fin n) + {c c' : Cfg n (copyWorkToWorkTM src dst).Q} + (hstep : (copyWorkToWorkTM src dst).step c = some c') + (hin : c.input.read β‰  Ξ“.start) + (hout : c.output.read β‰  Ξ“.start) (houtHead : 1 ≀ c.output.head) + (hother : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ + (c.work i).read β‰  Ξ“.start ∧ 1 ≀ (c.work i).head) : + c'.input = c.input ∧ c'.output = c.output ∧ + βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c'.work i = c.work i := by + have hneHalt := state_ne_qhalt_of_step hstep + cases hstate : c.state with + | done => + exfalso + exact hneHalt (by simpa [copyWorkToWorkTM] using hstate) + | copying => + unfold TM.step at hstep + rw [ite_eq_right hneHalt] at hstep + have hc := Option.some.inj hstep + rw [← hc] + rw [hstate] + dsimp only [copyWorkToWorkTM] + split + Β· refine ⟨idle_input_eq c.input hin, idle_writeBack_eq c.output hout houtHead, ?_⟩ + intro i hiSrc hiDst + exact idle_writeBack_eq (c.work i) (hother i hiSrc hiDst).1 + (hother i hiSrc hiDst).2 + Β· refine ⟨idle_input_eq c.input hin, idle_writeBack_eq c.output hout houtHead, ?_⟩ + intro i hiSrc hiDst + simp only [hiDst, hiSrc, ↓reduceIte] + exact idle_writeBack_eq (c.work i) (hother i hiSrc hiDst).1 + (hother i hiSrc hiDst).2 + +/-- Exact frame preservation over an arbitrary finite copy run. -/ +private theorem copyWorkOutput_reachesIn_frame {n : β„•} (src dst : Fin n) + {t : β„•} {c c' : Cfg n (copyWorkToWorkTM src dst).Q} + (hreach : (copyWorkToWorkTM src dst).reachesIn t c c') + (hin : c.input.read β‰  Ξ“.start) + (hout : c.output.read β‰  Ξ“.start) (houtHead : 1 ≀ c.output.head) + (hother : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ + (c.work i).read β‰  Ξ“.start ∧ 1 ≀ (c.work i).head) : + c'.input = c.input ∧ c'.output = c.output ∧ + βˆ€ i, i β‰  src β†’ i β‰  dst β†’ c'.work i = c.work i := by + induction hreach with + | zero => exact ⟨rfl, rfl, fun _ _ _ => rfl⟩ + | @step c0 c1 _ _ hstep _ ih => + obtain ⟨hin1, hout1, hwork1⟩ := + copyWorkOutput_step_frame src dst hstep hin hout houtHead hother + have hother1 : βˆ€ i, i β‰  src β†’ i β‰  dst β†’ + (c1.work i).read β‰  Ξ“.start ∧ 1 ≀ (c1.work i).head := by + intro i hiSrc hiDst + rw [hwork1 i hiSrc hiDst] + exact hother i hiSrc hiDst + have ih' := ih (by rw [hin1]; exact hin) (by rw [hout1]; exact hout) + (by rw [hout1]; exact houtHead) hother1 + exact ⟨ih'.1.trans hin1, ih'.2.1.trans hout1, fun i hiSrc hiDst => + (ih'.2.2 i hiSrc hiDst).trans (hwork1 i hiSrc hiDst)⟩ + +/-- Frame-rich raw-output copy. The input tape, output tape, and unrelated work +tapes are preserved exactly, allowing an arbitrary predicate to be threaded +through the copy. -/ +theorem copyWorkToWorkTM_hoareTime_frame_of_hasOutput_internal {n : β„•} + (src dst : Fin n) (hne : src β‰  dst) (x : List Bool) (source : Tape) + {P : Tape β†’ (Fin n β†’ Tape) β†’ Tape β†’ Prop} + (hP : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + P inp work out β†’ + (work' src).cells = source.cells β†’ + (work' src).head = x.length + 1 β†’ + (work' src).HasOutput x β†’ + (work' dst).HasBinaryPrefix x β†’ + (work' dst).cells 0 = Ξ“.start β†’ + inp' = inp β†’ out' = out β†’ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ work' i = work i) β†’ + P inp' work' out') : + (copyWorkToWorkTM src dst).HoareTime + (fun inp work out => + work src = source ∧ source.head = 1 ∧ source.HasOutput x ∧ + work dst = (Tape.init []).move Dir3.right ∧ + inp.read β‰  Ξ“.start ∧ out.read β‰  Ξ“.start ∧ 1 ≀ out.head ∧ + (βˆ€ i, i β‰  src β†’ i β‰  dst β†’ + (work i).read β‰  Ξ“.start ∧ 1 ≀ (work i).head) ∧ + P inp work out) + (fun inp work out => + (work src).cells = source.cells ∧ + (work src).head = x.length + 1 ∧ + (work src).HasOutput x ∧ + (work dst).HasBinaryPrefix x ∧ + (work dst).cells 0 = Ξ“.start ∧ + P inp work out) + (x.length + 1) := by + intro inp work out hpre + rcases hpre with + ⟨hsrc, hsourceHead, hsourceOutput, hdst, hin, hout, houtHead, hother, hPred⟩ + have hsrcCells0 : (work src).cells = source.cells := by rw [hsrc] + have hsrcHead0 : (work src).head = 1 := by rw [hsrc, hsourceHead] + have hdstPrefix0 : (work dst).HasBinaryPrefix [] := by + rw [hdst] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil + have hdst0Start : (work dst).cells 0 = Ξ“.start := by rw [hdst]; rfl + obtain ⟨c', hreach, hhalt, hsrcCells, hsrcHead, hsrcOutput, hdstPrefix, + hdst0⟩ := + copyWorkOutput_loop src dst hne x source x.length 0 + { state := CopyPhase.copying, input := inp, work := work, output := out } + Ξ“.start (by simp) rfl hsrcCells0 hsrcHead0 hsourceOutput hdstPrefix0 + hdst0Start (Nat.zero_le _) + obtain ⟨hinFrame, houtFrame, hworkFrame⟩ := + copyWorkOutput_reachesIn_frame src dst hreach hin hout houtHead hother + refine ⟨c', x.length + 1, le_rfl, hreach, hhalt, hsrcCells, hsrcHead, hsrcOutput, + hdstPrefix, hdst0, ?_⟩ + exact hP inp work out c'.input c'.work c'.output hPred hsrcCells hsrcHead + hsrcOutput hdstPrefix hdst0 hinFrame houtFrame hworkFrame + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean new file mode 100644 index 0000000000..ad344e8de5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeStep + +/-! +# Moving left unconditionally + +Before scratch tapes can be wiped (`TM.wipeStepTM` scans rightward), every head +needs to be at a *known* position. The `β–·` marker at cell `0` is immutable, so +moving left far enough always reaches it whatever the content: +`TM.moveLeftStepTM`, run enough times, is a content-agnostic bulk rewind for a +whole list of tapes, exactly as `TM.wipeStepTM` is a content-agnostic bulk wipe. + +## Main results + +- `TM.moveLeftStepTM` β€” move every targeted tape one cell left +- `TM.moveLeftStepTM_hoareTime` β€” its one-step contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Unconditional write-then-move collapses to a pure move whenever the +tape's only possible `β–·` is at cell `0` β€” regardless of whether the head is +currently on it. -/ +theorem writeAndMove_readBack_of_startInvariant (t : Tape) (h : Tape.StartInvariant t) + (d : Dir3) : t.writeAndMove (readBackWrite t.read) d = t.move d := by + by_cases hh : t.head = 0 + Β· show (t.write _).move d = t.move d + congr 1 + rw [Tape.write, ite_eq_left hh] + Β· exact writeAndMove_readBack t (h.read_ne_start (by omega)) d + +/-- One unconditional step: every work tape named in `targets` moves left +(bouncing off `β–·` via `moveLeftDir`); every other work tape, the input, and +the output are held by `readBackWrite`/`idleDir`. Content is always preserved. -/ +def moveLeftStepTM {n : β„•} (targets : List (Fin n)) : TM n where + Q := WipeStepPhase + qstart := .running + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .running => + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i ∈ targets then moveLeftDir (wHeads i) else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .running => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + Β· exact moveLeftDir_right_of_start hi + Β· exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **`moveLeftStepTM`'s exact one-step Hoare contract.** Targeted tapes need +only `StartInvariant` (their `β–·`, if any, is at cell `0` β€” true regardless of +current head position); every other work tape, the input, and the output +must be `Parked`. -/ +theorem moveLeftStepTM_hoareTime {n : β„•} (targets : List (Fin n)) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : Parked inpβ‚€) (hout : Parked outβ‚€) + (htarget : βˆ€ i, i ∈ targets β†’ Tape.StartInvariant (workβ‚€ i)) + (hother : βˆ€ i, i βˆ‰ targets β†’ Parked (workβ‚€ i)) : + (moveLeftStepTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + βˆ€ i, work i = if i ∈ targets then (workβ‚€ i).move (moveLeftDir (workβ‚€ i).read) + else workβ‚€ i) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨(⟨WipeStepPhase.done, + inp.move (idleDir inp.read), + (fun i => if i ∈ targets then (work i).move (moveLeftDir (work i).read) + else (work i).writeAndMove (readBackWrite (work i).read) (idleDir (work i).read)), + out.writeAndMove (readBackWrite out.read) (idleDir out.read)⟩ : + Cfg n (moveLeftStepTM targets).Q), + 1, le_refl 1, ?_, rfl, hinp.move_idle, hout.writeAndMove_readBack_idle, fun i => ?_⟩ + Β· refine TM.reachesIn.step ?_ .zero + simp only [TM.step, moveLeftStepTM, + ite_eq_right (show WipeStepPhase.running β‰  WipeStepPhase.done by decide)] + congr 1 + congr 1 + funext i + by_cases hi : i ∈ targets + Β· simp only [ite_eq_left hi] + exact writeAndMove_readBack_of_startInvariant (work i) (htarget i hi) _ + Β· simp only [ite_eq_right hi] + Β· dsimp only + split + Β· rfl + Β· next hi => exact (hother i hi).writeAndMove_readBack_idle + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit.lean new file mode 100644 index 0000000000..1ca53b49b9 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Internal + +/-! +# Pair emission from the input and a work tape + +The emitter reads a delimited first component from a designated work tape, +doubles its bits, writes the pair separator, and copies the real input as the +second component. + +## Main results + +- `TM.pairInputWorkTM_reachesIn` β€” exact execution from a concrete tape boundary +- `TM.pairInputWorkTM_hoareTime` β€” compositional time-bounded contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Exact pair emission preserves the source cells and every unrelated work +tape, consumes both sources through their delimiters, and leaves the output as +an appendable prefix containing the canonical pair. -/ +theorem pairInputWorkTM_reachesIn {n : β„•} + (firstIdx : Fin n) (first second : List Bool) + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : inp = (Tape.init (second.map Ξ“.ofBool)).move Dir3.right) + (hsourceHead : (work firstIdx).head = 1) + (hsourceOutput : (work firstIdx).HasOutput first) + (hwork : βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) + (houtput : out = (Tape.init []).move Dir3.right) : + βˆƒ c', + (pairInputWorkTM firstIdx).reachesIn (pairInputWorkTime first second) + { state := (pairInputWorkTM firstIdx).qstart, + input := inp, work := work, output := out } c' ∧ + (pairInputWorkTM firstIdx).halted c' ∧ + c'.input.HasBinarySuffix [] ∧ + c'.input.cells = inp.cells ∧ + (c'.work firstIdx).HasBinarySuffix [] ∧ + (c'.work firstIdx).cells = (work firstIdx).cells ∧ + (c'.work firstIdx).HasOutput first ∧ + (βˆ€ i, i β‰  firstIdx β†’ c'.work i = work i) ∧ + c'.output.HasBinaryPrefix (pair first second) := + pairInputWorkTM_reachesIn_internal firstIdx first second hinput + hsourceHead hsourceOutput hwork houtput + +/-- Emit `pair first second` within +`2 * first.length + second.length + 3` steps. -/ +theorem pairInputWorkTM_hoareTime {n : β„•} + (firstIdx : Fin n) (first second : List Bool) : + (pairInputWorkTM firstIdx).HoareTime + (fun inp work out => + inp = (Tape.init (second.map Ξ“.ofBool)).move Dir3.right ∧ + (work firstIdx).head = 1 ∧ + (work firstIdx).HasOutput first ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right) + (fun _inp _work out => out.HasOutput (pair first second)) + (pairInputWorkTime first second) := + pairInputWorkTM_hoareTime_internal firstIdx first second + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Defs.lean new file mode 100644 index 0000000000..67703c74af --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Defs.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Pair emission from the input and a work tape + +This file defines a small deterministic transducer that emits `pair first second`. +The first component is scanned on a designated work tape and doubled on the +output; the second component is then copied verbatim from the real input tape. +Both sources are consumed only through their first blank delimiter. + +## Main definitions + +- `TM.PairInputWorkPhase` β€” the five control phases of the emitter +- `TM.pairInputWorkTM` β€” emit a pair from one work tape and the input +- `TM.pairInputWorkTime` β€” the exact running time on canonical sources +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Control phases for `pairInputWorkTM`. `firstAgain bit` remembers the first +component bit while emitting its second copy. -/ +inductive PairInputWorkPhase where + | first + | firstAgain (bit : Bool) + | separator + | second + | done + deriving DecidableEq + +/-- `PairInputWorkPhase` is finite, as required for a Turing-machine state +space. -/ +instance : Fintype PairInputWorkPhase where + elems := {.first, .firstAgain false, .firstAgain true, .separator, .second, .done} + complete := by + intro state + cases state with + | first => simp + | firstAgain bit => cases bit <;> simp + | separator => simp + | second => simp + | done => simp + +/-- Emit `pair first second`, reading `first` from work tape `firstIdx` and +`second` from the real input. Sources begin at cell one and advance to their +first blank delimiters. The output is the fresh empty tape parked at cell one +and is left immediately after the emitted pair, without a rewind. -/ +def pairInputWorkTM {n : β„•} (firstIdx : Fin n) : TM n where + Q := PairInputWorkPhase + qstart := .first + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .first => + match wHeads firstIdx with + | .zero => + (.firstAgain false, fun i => readBackWrite (wHeads i), .zero, + idleDir iHead, fun i => idleDir (wHeads i), .right) + | .one => + (.firstAgain true, fun i => readBackWrite (wHeads i), .one, + idleDir iHead, fun i => idleDir (wHeads i), .right) + | .blank => + (.separator, fun i => readBackWrite (wHeads i), .zero, + idleDir iHead, fun i => idleDir (wHeads i), .right) + | .start => allIdle .first iHead wHeads oHead + | .firstAgain bit => + (.first, fun i => readBackWrite (wHeads i), Ξ“w.ofBool bit, + idleDir iHead, + fun i => if i = firstIdx then .right else idleDir (wHeads i), + .right) + | .separator => + (.second, fun i => readBackWrite (wHeads i), .one, + idleDir iHead, fun i => idleDir (wHeads i), .right) + | .second => + match iHead with + | .zero => + (.second, fun i => readBackWrite (wHeads i), .zero, + .right, fun i => idleDir (wHeads i), .right) + | .one => + (.second, fun i => readBackWrite (wHeads i), .one, + .right, fun i => idleDir (wHeads i), .right) + | .blank => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .start => allIdle .second iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + cases state with + | first => + cases hfirst : wHeads firstIdx + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + Β· exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + Β· exact rightOfStart_allIdle iHead wHeads oHead + | firstAgain bit => + refine ⟨idleDir_right_of_start, ?_, fun _ => rfl⟩ + intro i hi + by_cases hidx : i = firstIdx + Β· simp [hidx] + Β· simp [hidx, idleDir_right_of_start hi] + | separator => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + | second => + cases iHead + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + Β· exact rightOfStart_allIdle Ξ“.blank wHeads oHead + Β· exact rightOfStart_allIdle Ξ“.start wHeads oHead + | done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Exact running time of `pairInputWorkTM` on components `first` and +`second`: two steps per first-component bit, two separator steps, one step per +second-component bit, and one final blank-detection step. -/ +def pairInputWorkTime (first second : List Bool) : β„• := + 2 * first.length + second.length + 3 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Internal.lean new file mode 100644 index 0000000000..23ee1ce6c8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairEmit/Internal.lean @@ -0,0 +1,350 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairEmit.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Pair emission from the input and a work tape β€” proof internals + +This module verifies the exact two-pass controller in `PairEmit.Defs`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Bits emitted for the first component of the pairing codec. -/ +private def doubled (bits : List Bool) : List Bool := + bits.flatMap fun bit => [bit, bit] + +@[simp] private theorem doubled_cons (bit : Bool) (bits : List Bool) : + doubled (bit :: bits) = bit :: bit :: doubled bits := by + simp [doubled] + +/-- Emit the doubled first component and the two-bit separator. -/ +private theorem pairInputWorkTM_first_loop {n : β„•} (firstIdx : Fin n) : + βˆ€ (first emitted : List Bool) + (c : Cfg n (pairInputWorkTM firstIdx).Q), + c.state = PairInputWorkPhase.first β†’ + (c.work firstIdx).HasBinarySuffix first β†’ + c.input.read β‰  Ξ“.start β†’ + (βˆ€ i, i β‰  firstIdx β†’ (c.work i).read β‰  Ξ“.start) β†’ + c.output.HasBinaryPrefix emitted β†’ + βˆƒ c', + (pairInputWorkTM firstIdx).reachesIn (2 * first.length + 2) c c' ∧ + c'.state = PairInputWorkPhase.second ∧ + c'.input = c.input ∧ + (c'.work firstIdx).HasBinarySuffix [] ∧ + (c'.work firstIdx).cells = (c.work firstIdx).cells ∧ + (βˆ€ i, i β‰  firstIdx β†’ c'.work i = c.work i) ∧ + c'.output.HasBinaryPrefix (emitted ++ doubled first ++ [false, true]) := by + intro first + induction first with + | nil => + intro emitted c hstate hsource hinput hother houtput + have hsourceRead : (c.work firstIdx).read = Ξ“.blank := hsource.read_nil + let c₁ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.separator + input := transitionInput c.input + work := fun i => transitionTape (c.work i) + output := c.output.writeAndMove Ξ“.zero Dir3.right } + have hstep₁ : (pairInputWorkTM firstIdx).step c = some c₁ := by + simp [TM.step, hstate, pairInputWorkTM, hsourceRead, c₁, transitionInput, + transitionTape] + have hinputKeep₁ : c₁.input = c.input := by + simpa [c₁] using transitionInput_eq_self hinput + have hsourceKeep₁ : c₁.work firstIdx = c.work firstIdx := by + simpa [c₁] using transitionTape_eq_self (by rw [hsourceRead]; decide) + have hotherKeep₁ (i) (hi : i β‰  firstIdx) : c₁.work i = c.work i := by + simpa [c₁] using transitionTape_eq_self (hother i hi) + have houtput₁ : c₁.output.HasBinaryPrefix (emitted ++ [false]) := by + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, c₁] using + Tape.hasBinaryPrefix_write_bit false houtput + let cβ‚‚ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.second + input := transitionInput c₁.input + work := fun i => transitionTape (c₁.work i) + output := c₁.output.writeAndMove Ξ“.one Dir3.right } + have hstepβ‚‚ : (pairInputWorkTM firstIdx).step c₁ = some cβ‚‚ := by + simp [TM.step, c₁, pairInputWorkTM, cβ‚‚, transitionInput, transitionTape] + have hinputKeepβ‚‚ : cβ‚‚.input = c.input := by + have hstable : transitionInput c₁.input = c₁.input := + transitionInput_eq_self (by rw [hinputKeep₁]; exact hinput) + rw [show cβ‚‚.input = transitionInput c₁.input by rfl, hstable, + hinputKeep₁] + have hsourceKeepβ‚‚ : cβ‚‚.work firstIdx = c.work firstIdx := by + have hstable : transitionTape (c₁.work firstIdx) = c₁.work firstIdx := + transitionTape_eq_self (by rw [hsourceKeep₁, hsourceRead]; decide) + rw [show cβ‚‚.work firstIdx = transitionTape (c₁.work firstIdx) by rfl, + hstable, hsourceKeep₁] + have hotherKeepβ‚‚ (i) (hi : i β‰  firstIdx) : cβ‚‚.work i = c.work i := by + have hstable : transitionTape (c₁.work i) = c₁.work i := + transitionTape_eq_self (by rw [hotherKeep₁ i hi]; exact hother i hi) + rw [show cβ‚‚.work i = transitionTape (c₁.work i) by rfl, + hstable, hotherKeep₁ i hi] + have houtputβ‚‚ : cβ‚‚.output.HasBinaryPrefix (emitted ++ [false, true]) := by + have hwrite := Tape.hasBinaryPrefix_write_bit true houtput₁ + simpa [Ξ“.ofBool, transitionTape, Ξ“w.toΞ“, cβ‚‚, List.append_assoc] using hwrite + refine ⟨cβ‚‚, ?_, rfl, hinputKeepβ‚‚, ?_, ?_, hotherKeepβ‚‚, ?_⟩ + Β· simpa using TM.reachesIn.step hstep₁ (TM.reachesIn.step hstepβ‚‚ .zero) + Β· rw [hsourceKeepβ‚‚] + exact hsource + Β· rw [hsourceKeepβ‚‚] + Β· simpa [doubled] using houtputβ‚‚ + | cons bit bits ih => + intro emitted c hstate hsource hinput hother houtput + have hsourceRead : (c.work firstIdx).read = Ξ“.ofBool bit := + hsource.read_cons + let c₁ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.firstAgain bit + input := transitionInput c.input + work := fun i => transitionTape (c.work i) + output := c.output.writeAndMove (Ξ“.ofBool bit) Dir3.right } + have hstep₁ : (pairInputWorkTM firstIdx).step c = some c₁ := by + cases bit <;> + simp [TM.step, hstate, pairInputWorkTM, hsourceRead, c₁, transitionInput, + transitionTape, Ξ“.ofBool, Ξ“w.toΞ“, readBackWrite] + have hinputKeep₁ : c₁.input = c.input := by + simpa [c₁] using transitionInput_eq_self hinput + have hsourceKeep₁ : c₁.work firstIdx = c.work firstIdx := by + simpa [c₁] using transitionTape_eq_self hsource.read_ne_start + have hotherKeep₁ (i) (hi : i β‰  firstIdx) : c₁.work i = c.work i := by + simpa [c₁] using transitionTape_eq_self (hother i hi) + have houtput₁ : c₁.output.HasBinaryPrefix (emitted ++ [bit]) := by + simpa [c₁] using Tape.hasBinaryPrefix_write_bit bit houtput + let cβ‚‚ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.first + input := transitionInput c₁.input + work := fun i => + (c₁.work i).writeAndMove (readBackWrite (c₁.work i).read) + (if i = firstIdx then Dir3.right else idleDir (c₁.work i).read) + output := c₁.output.writeAndMove (Ξ“.ofBool bit) Dir3.right } + have hstepβ‚‚ : (pairInputWorkTM firstIdx).step c₁ = some cβ‚‚ := by + cases bit <;> + simp [TM.step, c₁, pairInputWorkTM, cβ‚‚, transitionInput, Ξ“.ofBool, + Ξ“w.ofBool, Ξ“w.toΞ“] + have hinputKeepβ‚‚ : cβ‚‚.input = c.input := by + have hstable : transitionInput c₁.input = c₁.input := + transitionInput_eq_self (by rw [hinputKeep₁]; exact hinput) + rw [show cβ‚‚.input = transitionInput c₁.input by rfl, hstable, + hinputKeep₁] + have hsourceMove : cβ‚‚.work firstIdx = (c.work firstIdx).move Dir3.right := by + rw [show cβ‚‚.work firstIdx = + (c₁.work firstIdx).writeAndMove (readBackWrite (c₁.work firstIdx).read) + Dir3.right by simp [cβ‚‚]] + rw [writeAndMove_readBack _ (by rw [hsourceKeep₁]; exact hsource.read_ne_start)] + rw [hsourceKeep₁] + have hotherKeepβ‚‚ (i) (hi : i β‰  firstIdx) : cβ‚‚.work i = c.work i := by + have hstable : transitionTape (c₁.work i) = c₁.work i := + transitionTape_eq_self (by rw [hotherKeep₁ i hi]; exact hother i hi) + have hcβ‚‚ : cβ‚‚.work i = transitionTape (c₁.work i) := by + simp [cβ‚‚, hi, transitionTape] + rw [hcβ‚‚, hstable, hotherKeep₁ i hi] + have hsourceβ‚‚ : (cβ‚‚.work firstIdx).HasBinarySuffix bits := by + rw [hsourceMove] + exact hsource.move_right_cons + have houtputβ‚‚ : cβ‚‚.output.HasBinaryPrefix (emitted ++ [bit, bit]) := by + have hwrite := Tape.hasBinaryPrefix_write_bit bit houtput₁ + simpa [cβ‚‚, List.append_assoc] using hwrite + obtain ⟨c', hreach, hstate', hinput', hsource', hsourceCells', hother', + houtput'⟩ := + ih (emitted ++ [bit, bit]) cβ‚‚ rfl hsourceβ‚‚ + (by rw [hinputKeepβ‚‚]; exact hinput) + (by intro i hi + rw [hotherKeepβ‚‚ i hi] + exact hother i hi) + houtputβ‚‚ + refine ⟨c', ?_, hstate', ?_, hsource', ?_, ?_, ?_⟩ + Β· simpa [Nat.mul_add, Nat.add_assoc] using! + TM.reachesIn.step hstep₁ (TM.reachesIn.step hstepβ‚‚ hreach) + Β· exact hinput'.trans hinputKeepβ‚‚ + Β· rw [hsourceCells', hsourceMove, Tape.move_cells] + Β· intro i hi + exact (hother' i hi).trans (hotherKeepβ‚‚ i hi) + Β· simpa [List.append_assoc] using houtput' + +/-- Copy the second component verbatim and halt at its delimiter. -/ +private theorem pairInputWorkTM_second_loop {n : β„•} (firstIdx : Fin n) : + βˆ€ (second emitted : List Bool) + (c : Cfg n (pairInputWorkTM firstIdx).Q), + c.state = PairInputWorkPhase.second β†’ + c.input.HasBinarySuffix second β†’ + (βˆ€ i, (c.work i).read β‰  Ξ“.start) β†’ + c.output.HasBinaryPrefix emitted β†’ + βˆƒ c', + (pairInputWorkTM firstIdx).reachesIn (second.length + 1) c c' ∧ + (pairInputWorkTM firstIdx).halted c' ∧ + c'.input.HasBinarySuffix [] ∧ + c'.input.cells = c.input.cells ∧ + c'.work = c.work ∧ + c'.output.HasBinaryPrefix (emitted ++ second) := by + intro second + induction second with + | nil => + intro emitted c hstate hinput hwork houtput + have hinputRead : c.input.read = Ξ“.blank := hinput.read_nil + have houtputRead : c.output.read = Ξ“.blank := houtput.read_blank + let c' : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.done + input := transitionInput c.input + work := fun i => transitionTape (c.work i) + output := transitionTape c.output } + have hstep : (pairInputWorkTM firstIdx).step c = some c' := by + simp [TM.step, hstate, pairInputWorkTM, hinputRead, c', transitionInput, + transitionTape] + have hinputKeep : c'.input = c.input := by + simpa [c'] using transitionInput_eq_self (by rw [hinputRead]; decide) + have hworkKeep : c'.work = c.work := by + funext i + simpa [c'] using transitionTape_eq_self (hwork i) + have houtputKeep : c'.output = c.output := by + simpa [c'] using transitionTape_eq_self (by rw [houtputRead]; decide) + refine ⟨c', .step hstep .zero, rfl, ?_, ?_, hworkKeep, ?_⟩ + Β· rw [hinputKeep] + exact hinput + Β· rw [hinputKeep] + Β· simpa [houtputKeep] using houtput + | cons bit bits ih => + intro emitted c hstate hinput hwork houtput + have hinputRead : c.input.read = Ξ“.ofBool bit := hinput.read_cons + let c₁ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := PairInputWorkPhase.second + input := c.input.move Dir3.right + work := fun i => transitionTape (c.work i) + output := c.output.writeAndMove (Ξ“.ofBool bit) Dir3.right } + have hstep : (pairInputWorkTM firstIdx).step c = some c₁ := by + cases bit <;> + simp [TM.step, hstate, pairInputWorkTM, hinputRead, c₁, transitionTape, + Ξ“.ofBool, Ξ“w.toΞ“, readBackWrite] + have hinput₁ : c₁.input.HasBinarySuffix bits := by + simpa [c₁] using hinput.move_right_cons + have hworkKeep : c₁.work = c.work := by + funext i + simpa [c₁] using transitionTape_eq_self (hwork i) + have hwork₁ (i) : (c₁.work i).read β‰  Ξ“.start := by + rw [hworkKeep] + exact hwork i + have houtput₁ : c₁.output.HasBinaryPrefix (emitted ++ [bit]) := by + simpa [c₁] using Tape.hasBinaryPrefix_write_bit bit houtput + obtain ⟨c', hreach, hhalt, hinput', hinputCells', hwork', houtput'⟩ := + ih (emitted ++ [bit]) c₁ rfl hinput₁ hwork₁ houtput₁ + refine ⟨c', ?_, hhalt, hinput', ?_, ?_, ?_⟩ + Β· simpa using TM.reachesIn.step hstep hreach + Β· rw [hinputCells'] + simpa [c₁] using Tape.move_cells c.input Dir3.right + Β· exact hwork'.trans hworkKeep + Β· simpa [List.append_assoc] using houtput' + +/-- Exact execution from the concrete tape boundary used by the generic +fanout combinator. -/ +theorem pairInputWorkTM_reachesIn_internal {n : β„•} + (firstIdx : Fin n) (first second : List Bool) + {inp out : Tape} {work : Fin n β†’ Tape} + (hinput : inp = (Tape.init (second.map Ξ“.ofBool)).move Dir3.right) + (hsourceHead : (work firstIdx).head = 1) + (hsourceOutput : (work firstIdx).HasOutput first) + (hwork : βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) + (houtput : out = (Tape.init []).move Dir3.right) : + βˆƒ c', + (pairInputWorkTM firstIdx).reachesIn (pairInputWorkTime first second) + { state := (pairInputWorkTM firstIdx).qstart, + input := inp, work := work, output := out } c' ∧ + (pairInputWorkTM firstIdx).halted c' ∧ + c'.input.HasBinarySuffix [] ∧ + c'.input.cells = inp.cells ∧ + (c'.work firstIdx).HasBinarySuffix [] ∧ + (c'.work firstIdx).cells = (work firstIdx).cells ∧ + (c'.work firstIdx).HasOutput first ∧ + (βˆ€ i, i β‰  firstIdx β†’ c'.work i = work i) ∧ + c'.output.HasBinaryPrefix (pair first second) := by + have hsourceSuffix : (work firstIdx).HasBinarySuffix first := + hsourceOutput.hasBinarySuffix hsourceHead (hwork firstIdx).1 + let cβ‚€ : Cfg n (pairInputWorkTM firstIdx).Q := + { state := (pairInputWorkTM firstIdx).qstart, + input := inp, work := work, output := out } + obtain ⟨c₁, hreach₁, hstate₁, hinput₁, hsource₁, hsourceCells₁, + hother₁, houtputβ‚βŸ© := + pairInputWorkTM_first_loop firstIdx first [] cβ‚€ rfl + (by simpa [cβ‚€] using hsourceSuffix) + (by rw [show cβ‚€.input = inp by rfl, hinput] + exact Tape.init_ofBool_move_right_read_ne_start second) + (by + intro i hi + show (work i).cells (work i).head β‰  Ξ“.start + exact (hwork i).1.2 (work i).head (hwork i).2) + (by rw [show cβ‚€.output = out by rfl, houtput] + exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + have hinputSuffix₁ : c₁.input.HasBinarySuffix second := by + rw [hinput₁] + change inp.HasBinarySuffix second + rw [hinput] + exact Tape.init_move_right_hasBinarySuffix second + have hworkRead₁ : βˆ€ i, (c₁.work i).read β‰  Ξ“.start := by + intro i + by_cases hi : i = firstIdx + Β· subst i + exact hsource₁.read_ne_start + Β· rw [hother₁ i hi] + show (work i).cells (work i).head β‰  Ξ“.start + exact (hwork i).1.2 (work i).head (hwork i).2 + obtain ⟨cβ‚‚, hreachβ‚‚, hhaltβ‚‚, hinputβ‚‚, hinputCellsβ‚‚, hworkβ‚‚, + houtputβ‚‚βŸ© := + pairInputWorkTM_second_loop firstIdx second + (doubled first ++ [false, true]) c₁ hstate₁ hinputSuffix₁ + hworkRead₁ (by simpa using houtput₁) + refine ⟨cβ‚‚, ?_, hhaltβ‚‚, hinputβ‚‚, ?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· have htime : 2 * first.length + 2 + (second.length + 1) = + pairInputWorkTime first second := by + simp only [pairInputWorkTime] + omega + rw [← htime] + simpa only [cβ‚€] using + reachesIn_trans (pairInputWorkTM firstIdx) hreach₁ hreachβ‚‚ + Β· rw [hinputCellsβ‚‚, hinput₁] + Β· rw [hworkβ‚‚] + exact hsource₁ + Β· rw [hworkβ‚‚] + exact hsourceCells₁ + Β· apply (Tape.hasOutput_congr ?_ first).mpr hsourceOutput + rw [hworkβ‚‚] + exact hsourceCells₁ + Β· intro i hi + rw [hworkβ‚‚] + exact hother₁ i hi + Β· simpa [pair, delimit, doubled, List.append_assoc] using houtputβ‚‚ + +/-- Internal compact Hoare contract for pair emission. -/ +theorem pairInputWorkTM_hoareTime_internal {n : β„•} + (firstIdx : Fin n) (first second : List Bool) : + (pairInputWorkTM firstIdx).HoareTime + (fun inp work out => + inp = (Tape.init (second.map Ξ“.ofBool)).move Dir3.right ∧ + (work firstIdx).head = 1 ∧ + (work firstIdx).HasOutput first ∧ + (βˆ€ i, (work i).StartInvariant ∧ 1 ≀ (work i).head) ∧ + out = (Tape.init []).move Dir3.right) + (fun _inp _work out => out.HasOutput (pair first second)) + (pairInputWorkTime first second) := by + intro inp work out hpre + rcases hpre with ⟨hinput, hsourceHead, hsourceOutput, hwork, houtput⟩ + obtain ⟨c', hreach, hhalt, _hinput, _hinputCells, _hsource, + _hsourceCells, _hsourceOutput, _hother, hprefix⟩ := + pairInputWorkTM_reachesIn_internal firstIdx first second hinput + hsourceHead hsourceOutput hwork houtput + exact ⟨c', pairInputWorkTime first second, le_rfl, hreach, hhalt, + hprefix.hasOutput⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate.lean new file mode 100644 index 0000000000..a0cd9f7b03 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Internal + +/-! +# Validate paired machine inputs + +`pairValidateTM` is a total finite-state recognizer for the image of the +library's self-delimiting `pair` codec. It rejects every malformed outer input +and runs in exactly the generic scanner budget `n + 2`. + +This complements `pairSplitCoreTM`: validate first when arbitrary input strings +need rejecting semantics, then rewind and use the canonical splitter to stage +the two decoded components. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Decoder-facing characterization of membership in `validPairEncoding`. -/ +theorem mem_validPairEncoding_iff (bits : List Bool) : + bits ∈ validPairEncoding ↔ (unpair? bits).isSome = true := + Iff.rfl + +/-- Extensional characterization: valid encodings are exactly canonical +encodings of some pair of Boolean strings. -/ +theorem mem_validPairEncoding_iff_exists_pair (bits : List Bool) : + bits ∈ validPairEncoding ↔ βˆƒ x y, bits = pair x y := by + constructor + Β· intro hmem + change (unpair? bits).isSome = true at hmem + cases hdecode : unpair? bits with + | none => simp [hdecode] at hmem + | some decoded => + obtain ⟨x, y⟩ := decoded + exact ⟨x, y, eq_pair_of_unpair?_eq_some hdecode⟩ + Β· rintro ⟨x, y, rfl⟩ + simp [validPairEncoding] + +/-- Failure of the partial decoder is exactly nonmembership in the valid-pair +language. -/ +theorem not_mem_validPairEncoding_iff (bits : List Bool) : + bits βˆ‰ validPairEncoding ↔ unpair? bits = none := by + cases hdecode : unpair? bits <;> simp [validPairEncoding, hdecode] + +/-- Every canonical `pair` is a valid pair encoding. -/ +@[simp] theorem pair_mem_validPairEncoding (x y : List Bool) : + pair x y ∈ validPairEncoding := by + simp [validPairEncoding] + +namespace TM + +/-- The pair-validator fold accepts exactly when the canonical decoder succeeds. -/ +theorem pairValidateAccept_fold_eq_true_iff (bits : List Bool) : + pairValidateAccept (bits.foldl pairValidateStep .next) = true ↔ + (unpair? bits).isSome = true := + pairValidateAccept_fold_eq_true_iff_internal bits + +/-- The finite-state pair validator decides `validPairEncoding` in linear time. -/ +theorem pairValidateTM_decidesInTime : + pairValidateTM.DecidesInTime validPairEncoding (fun n => n + 2) := + pairValidateTM_decidesInTime_internal + +/-- Adding arbitrary unused work tapes preserves the validator's language and +exact linear time bound. This is the form used by larger machine pipelines. -/ +theorem pairValidateTM_lift_decidesInTime (workTapes : β„•) : + (pairValidateTM.liftTM workTapes).DecidesInTime + validPairEncoding (fun n => n + 2) := + liftTM_decidesInTime pairValidateTM workTapes pairValidateTM_decidesInTime + +/-- Frame-rich initialized specification for the lifted validator. Besides the +verdict, it exposes the read-only input cells, head bounds, well-formedness of +all tapes, and the fact that every added work tape is parked and blank. These +are the seams needed by `ifTM` and a subsequent input rewind. -/ +theorem pairValidateTM_lift_hoareTime (workTapes : β„•) (bits : List Bool) : + (pairValidateTM.liftTM workTapes).HoareTime + (fun inp work out => + inp = Tape.init (bits.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ + out = Tape.init []) + (fun inp work out => + AllTapesWF inp work out ∧ + inp.cells = (Tape.init (bits.map Ξ“.ofBool)).cells ∧ + inp.head ≀ bits.length + 2 ∧ + (βˆ€ i, work i = (Tape.init []).move Dir3.right) ∧ + out.head ≀ bits.length + 2 ∧ + (bits ∈ validPairEncoding β†’ out.cells 1 = Ξ“.one) ∧ + (bits βˆ‰ validPairEncoding β†’ out.cells 1 = Ξ“.zero)) + (bits.length + 2) := + pairValidateTM_lift_hoareTime_internal workTapes bits + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Defs.lean new file mode 100644 index 0000000000..4c05bd2841 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Defs.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Encoding.Pairing +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Pair-encoding validator β€” definitions + +This file defines a finite-state scanner for the image of the library's +self-delimiting binary `pair` codec. Unlike `pairSplitCoreTM`, the validator +has total semantics: it writes `1` exactly when `unpair?` succeeds and writes +`0` on every malformed encoding. +-/ + + +@[expose] public section + +namespace Complexity + +/-- The language of strings on which the canonical pair decoder succeeds. -/ +def validPairEncoding : Language := + {z | (unpair? z).isSome = true} + +namespace TM + +/-- Finite control for recognizing the doubled prefix and `01` separator of a +pair encoding. Once the separator has been seen, every remaining bit belongs +to the unrestricted right component. -/ +inductive PairValidateState where + /-- Expect the first copy of the next doubled bit. -/ + | next + /-- The first copy was `0`; `0` continues the prefix and `1` is the separator. -/ + | afterZero + /-- The first copy was `1`; only a second `1` is valid. -/ + | afterOne + /-- The separator has been seen; the remaining suffix is unrestricted. -/ + | suffix + /-- A mismatched doubled bit was seen. -/ + | invalid + deriving DecidableEq + +instance : Fintype PairValidateState where + elems := {.next, .afterZero, .afterOne, .suffix, .invalid} + complete := by + intro state + cases state <;> simp + +/-- One automaton step for the pair-encoding validator. -/ +def pairValidateStep : PairValidateState β†’ Bool β†’ PairValidateState + | .next, false => .afterZero + | .next, true => .afterOne + | .afterZero, false => .next + | .afterZero, true => .suffix + | .afterOne, false => .invalid + | .afterOne, true => .next + | .suffix, _ => .suffix + | .invalid, _ => .invalid + +/-- The scanner accepts exactly after it has seen the pair separator. -/ +def pairValidateAccept : PairValidateState β†’ Bool + | .suffix => true + | _ => false + +/-- A total, zero-work-tape validator for the image of `pair`. + +The generic scanner consumes the whole input, folds `pairValidateStep` in +finite control, and writes the final Boolean verdict to output cell `1`. -/ +def pairValidateTM : TM 0 := + scannerTM .next pairValidateStep + (fun state => if pairValidateAccept state then .one else .zero) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Internal.lean new file mode 100644 index 0000000000..e15d7d99dd --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/PairValidate/Internal.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Hoare +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Lift +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.PairValidate.Defs + +/-! +# Pair-encoding validator β€” proof internals + +The finite-state fold is related to `unpair?`, then the generic scanner +correctness theorem supplies the executable machine proof and exact time bound. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Semantic meaning of a validator state with a yet-unread suffix. The three +prefix states reconstruct the pending decoder input; the absorbing states have +constant verdicts. -/ +private def pairValidateSuffix : PairValidateState β†’ List Bool β†’ Bool + | .next, bits => (unpair? bits).isSome + | .afterZero, bits => (unpair? (false :: bits)).isSome + | .afterOne, bits => (unpair? (true :: bits)).isSome + | .suffix, _ => true + | .invalid, _ => false + +/-- Folding the validator over a suffix produces exactly the semantic verdict +associated with the incoming control state. -/ +private theorem pairValidate_fold_correct (state : PairValidateState) (bits : List Bool) : + pairValidateAccept (bits.foldl pairValidateStep state) = + pairValidateSuffix state bits := by + induction bits generalizing state with + | nil => + cases state <;> simp [pairValidateAccept, pairValidateSuffix, unpair?] + | cons bit bits ih => + rw [List.foldl_cons, ih] + cases state <;> cases bit <;> + simp [pairValidateStep, pairValidateSuffix, unpair?] + +/-- The pair-validator fold accepts exactly when `unpair?` succeeds. -/ +theorem pairValidateAccept_fold_eq_true_iff_internal (bits : List Bool) : + pairValidateAccept (bits.foldl pairValidateStep .next) = true ↔ + (unpair? bits).isSome = true := by + rw [pairValidate_fold_correct] + rfl + +/-- The finite-state pair validator decides all well-formed pair encodings in +the generic scanner's exact `n + 2` time bound. -/ +theorem pairValidateTM_decidesInTime_internal : + pairValidateTM.DecidesInTime validPairEncoding (fun n => n + 2) := by + apply scannerTM_decidesInTime .next pairValidateStep pairValidateAccept + intro bits + change (unpair? bits).isSome = true ↔ + pairValidateAccept (bits.foldl pairValidateStep .next) = true + exact (pairValidateAccept_fold_eq_true_iff_internal bits).symm + +/-- Frame-rich initialized specification for the lifted validator. -/ +theorem pairValidateTM_lift_hoareTime_internal (workTapes : β„•) (bits : List Bool) : + (pairValidateTM.liftTM workTapes).HoareTime + (fun inp work out => + inp = Tape.init (bits.map Ξ“.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ + out = Tape.init []) + (fun inp work out => + AllTapesWF inp work out ∧ + inp.cells = (Tape.init (bits.map Ξ“.ofBool)).cells ∧ + inp.head ≀ bits.length + 2 ∧ + (βˆ€ i, work i = (Tape.init []).move Dir3.right) ∧ + out.head ≀ bits.length + 2 ∧ + (bits ∈ validPairEncoding β†’ out.cells 1 = Ξ“.one) ∧ + (bits βˆ‰ validPairEncoding β†’ out.cells 1 = Ξ“.zero)) + (bits.length + 2) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + obtain ⟨c', hreach, hhalt, hout⟩ := + scannerTM_reachesIn .next pairValidateStep + (fun state => if pairValidateAccept state then .one else .zero) bits + let C := pairValidateTM.liftCfg workTapes c' + have hreachLift : + (pairValidateTM.liftTM workTapes).reachesIn (bits.length + 2) + ((pairValidateTM.liftTM workTapes).initCfg bits) C := by + exact liftTM_reachesIn_initCfg_of_pos pairValidateTM workTapes bits + (by omega) hreach + have hinputCells : + c'.input.cells = (Tape.init (bits.map Ξ“.ofBool)).cells := + input_cells_eq_of_reachesIn hreach + have hheads := head_le_of_reachesIn pairValidateTM hreach + have hwork : βˆ€ i, C.work i = (Tape.init []).move Dir3.right := by + intro i + exact liftCfg_work_ge pairValidateTM workTapes c' i (by omega) + have houtput0 : c'.output.cells 0 = Ξ“.start := + output_cells_zero_eq_start_of_reachesIn hreach rfl + have houtputNoStart : βˆ€ j, j β‰₯ 1 β†’ c'.output.cells j β‰  Ξ“.start := + output_cells_ne_start_of_reachesIn hreach (by + intro j hj + cases j with + | zero => omega + | succ j => simp [Tape.init]) + have hwf : AllTapesWF C.input C.work C.output := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ + Β· rw [show C.input = c'.input from rfl, hinputCells] + rfl + Β· intro j hj + rw [show C.input = c'.input from rfl, hinputCells] + exact Tape.init_ofBool_cells_ne_start bits j hj + Β· intro i + rw [hwork i] + rfl + Β· intro i j hj + rw [hwork i] + cases j with + | zero => omega + | succ j => simp [Tape.move, Tape.init] + Β· simpa only [liftCfg_output] using! houtput0 + Β· simpa only [liftCfg_output] using! houtputNoStart + have hyes : bits ∈ validPairEncoding β†’ C.output.cells 1 = Ξ“.one := by + intro hmem + rw [show C.output = c'.output from rfl, hout] + have haccept : + pairValidateAccept (bits.foldl pairValidateStep .next) = true := + (pairValidateAccept_fold_eq_true_iff_internal bits).2 hmem + simp [haccept] + have hno : bits βˆ‰ validPairEncoding β†’ C.output.cells 1 = Ξ“.zero := by + intro hmem + rw [show C.output = c'.output from rfl, hout] + have haccept : + pairValidateAccept (bits.foldl pairValidateStep .next) = false := by + cases hstate : pairValidateAccept (bits.foldl pairValidateStep .next) with + | false => rfl + | true => + exact absurd + ((pairValidateAccept_fold_eq_true_iff_internal bits).1 hstate) hmem + simp [haccept] + refine ⟨C, bits.length + 2, le_rfl, hreachLift, ?_, hwf, ?_, ?_, hwork, ?_, + hyes, hno⟩ + Β· exact hhalt + Β· exact hinputCells + Β· exact hheads.1 + Β· exact hheads.2.1 + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean new file mode 100644 index 0000000000..f3ee71b91a --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep + +/-! +# Parking every tape at once + +Rewinding tapes one at a time needs every tape *not* being rewound to be +`Parked` already β€” a tape still reading `β–·` would bounce to cell `1` as a side +effect. One `TM.skipTM` step with no target achieves that uniformly: from +`Tape.StartInvariant` alone, cell-`0` tapes bounce to cell `1` and parked tapes +stay put. + +## Main results + +- `TM.parkAll_hoareTime` β€” one step parks every tape +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- One idle step on a `StartInvariant` tape is exactly a bounce off `β–·` if it +was there, and otherwise a no-op: the resulting head is `max t.head 1`. -/ +theorem move_idleDir_eq_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + t.move (idleDir t.read) = ⟨max t.head 1, t.cells⟩ := by + by_cases hh : t.read = Ξ“.start + Β· have hh0 : t.head = 0 := by + by_contra hc + exact (h.2 t.head (by omega)) hh + rw [idleDir, ite_eq_left hh] + refine Tape.ext ?_ (Tape.move_cells t Dir3.right) + show t.head + 1 = max t.head 1 + omega + Β· have hh0 : t.head β‰  0 := fun hc => hh (by rw [Tape.read, hc]; exact h.1) + rw [idleDir, ite_eq_right hh] + show t = ⟨max t.head 1, t.cells⟩ + have : max t.head 1 = t.head := by omega + rw [this] + +/-- One idle step parks a `StartInvariant` tape: bounces it off `β–·` if it was +there, and otherwise leaves it exactly as it was. -/ +theorem parked_move_idleDir_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + Parked (t.move (idleDir t.read)) ∧ (t.move (idleDir t.read)).cells = t.cells := by + rw [move_idleDir_eq_of_startInvariant h] + exact ⟨⟨le_max_right _ _, fun j hj => h.2 j hj⟩, rfl⟩ + +/-- **Parking every tape at once.** From tapes satisfying only +`StartInvariant`, one `skipTM` step brings every one of them to `Parked`, +preserving all cell contents exactly. -/ +theorem parkAll_hoareTime {n : β„•} (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : Tape.StartInvariant inpβ‚€) (hwork : βˆ€ i, Tape.StartInvariant (workβ‚€ i)) + (hout : Tape.StartInvariant outβ‚€) : + (skipTM (n := n)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = (⟨max inpβ‚€.head 1, inpβ‚€.cells⟩ : Tape) ∧ + (βˆ€ i, work i = (⟨max (workβ‚€ i).head 1, (workβ‚€ i).cells⟩ : Tape)) ∧ + out = (⟨max outβ‚€.head 1, outβ‚€.cells⟩ : Tape)) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨⟨(skipTM (n := n)).qhalt, + inp.move (idleDir inp.read), + fun i => (work i).move (idleDir (work i).read), + out.move (idleDir out.read)⟩, + 1, le_refl 1, ?_, rfl, ?_, ?_, ?_⟩ + Β· refine TM.reachesIn.step ?_ .zero + simp only [TM.step, skipTM, + ite_eq_right (show BumpPhase.go β‰  BumpPhase.done by decide), + writeAndMove_readBack_of_startInvariant out hout] + congr 2 + funext i + exact writeAndMove_readBack_of_startInvariant (work i) (hwork i) _ + Β· exact move_idleDir_eq_of_startInvariant hinp + Β· exact fun i => move_idleDir_eq_of_startInvariant (hwork i) + Β· exact move_idleDir_eq_of_startInvariant hout + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary.lean new file mode 100644 index 0000000000..7bf1c5f848 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Internal + +/-! +# Resetting a binary work tape + +This module exposes the framed time and space contracts for rewinding an +arbitrary canonical binary cursor and clearing it to the standard blank tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Rewind canonical binary contents to cell one while preserving the complete +external tape frame. -/ +theorem rewindBinaryWorkTM_hoareTime_frame {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (rewindWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work idx = (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out = outβ‚€) + (headBound + 2) := + rewindBinaryWorkTM_hoareTime_frame_internal idx bits headBound inpβ‚€ workβ‚€ + outβ‚€ htarget htargetStart htargetHead hinput hother houtput + +/-- Rewind and clear canonical binary contents while preserving the complete +external tape frame. -/ +theorem resetBinaryWorkTM_hoareTime_frame {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (resetBinaryWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (resetBinaryWorkTime headBound bits.length) := + resetBinaryWorkTM_hoareTime_frame_internal idx bits headBound inpβ‚€ workβ‚€ outβ‚€ + htarget htargetStart htargetHead hinput hother houtput + +/-- Coarse all-prefix auxiliary-space envelope for binary reset. -/ +theorem resetBinaryWorkTM_prefix_withinAuxSpace {n : β„•} + (idx : Fin n) (headBound bitLength inputLength initialSpace time : β„•) + (start current : Cfg n (resetBinaryWorkTM idx).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (resetBinaryWorkTM idx).reachesIn time start current) + (htime : time ≀ resetBinaryWorkTime headBound bitLength) : + current.WithinAuxSpace inputLength + (initialSpace + resetBinaryWorkTime headBound bitLength) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +/-- Binary reset preserves one-way output safety. -/ +theorem resetBinaryWorkTM_isTransducer {n : β„•} (idx : Fin n) : + (resetBinaryWorkTM idx).IsTransducer := by + unfold resetBinaryWorkTM + exact (rewindWorkTM_isTransducer idx).seqTM (clearWorkTM_isTransducer idx) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Defs.lean new file mode 100644 index 0000000000..779c3da812 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Defs.lean @@ -0,0 +1,36 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ClearWork.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines + +/-! +# Resetting a binary work tape β€” definitions + +`resetBinaryWorkTM` first rewinds an arbitrary cursor over canonical binary +contents and then clears the resulting completed string to the standard blank +work tape. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Rewind and clear one canonical binary work tape. -/ +def resetBinaryWorkTM {n : β„•} (idx : Fin n) : TM n := + seqTM (rewindWorkTM idx) (clearWorkTM idx) + +/-- Time bound in terms of the initial head bound and represented bit length. -/ +def resetBinaryWorkTime (headBound bitLength : β„•) : β„• := + headBound + 2 + 1 + clearWorkTimeBound bitLength + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Internal.lean new file mode 100644 index 0000000000..9b9a06d479 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinary/Internal.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.Internal +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Defs + +/-! +# Resetting a binary work tape β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +theorem rewindBinaryWorkTM_hoareTime_frame_internal {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (rewindWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work idx = (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out = outβ‚€) + (headBound + 2) := by + let RewindFrame : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ + (work idx).HasBinaryContent bits ∧ + (work idx).cells 0 = Ξ“.start ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out = outβ‚€ + have hrewindBase := rewindWorkTM_hoareTime_frame idx headBound + (P := RewindFrame) (by + intro inp work out inp' work' out' hframe hcells _hhead hwork hinp + houtCells houtHead + rcases hframe with ⟨hframeInput, hframeContent, hframeStart, + hframeOther, hframeOutput⟩ + refine ⟨hinp.trans hframeInput, ?_, ?_, ?_, ?_⟩ + Β· simpa only [Tape.HasBinaryContent, hcells] using hframeContent + Β· rw [hcells] + exact hframeStart + Β· intro i hi + exact (hwork i hi).trans (hframeOther i hi) + Β· exact (Tape.ext houtHead houtCells).trans hframeOutput) + apply hrewindBase.consequence (b' := headBound + 2) + Β· rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨htargetStart, htarget.cells_ne_start, htargetHead.2, + hinput.read_ne_start, houtput.read_ne_start, houtput.1, ?_, + rfl, htarget, htargetStart, (fun _ _ => rfl), rfl⟩ + intro i hi + exact ⟨(hother i hi).read_ne_start, (hother i hi).1⟩ + Β· intro inp work out hpost + rcases hpost with ⟨hhead, hframeInput, hcontent, hstart, + hframeOther, hframeOutput⟩ + refine ⟨hframeInput, ?_, hframeOther, hframeOutput⟩ + exact Tape.eq_init_move_right_of_hasBinaryString + (hcontent.hasBinaryString hhead) hstart + Β· exact le_rfl + +theorem resetBinaryWorkTM_hoareTime_frame_internal {n : β„•} + (idx : Fin n) (bits : List Bool) (headBound : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (htarget : (workβ‚€ idx).HasBinaryContent bits) + (htargetStart : (workβ‚€ idx).cells 0 = Ξ“.start) + (htargetHead : 1 ≀ (workβ‚€ idx).head ∧ (workβ‚€ idx).head ≀ headBound) + (hinput : Parked inpβ‚€) + (hother : βˆ€ i, i β‰  idx β†’ Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (resetBinaryWorkTM idx).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (resetBinaryWorkTime headBound bits.length) := by + have hrewind := rewindBinaryWorkTM_hoareTime_frame_internal idx bits + headBound inpβ‚€ workβ‚€ outβ‚€ htarget htargetStart htargetHead hinput + hother houtput + let ClearFrame : TapePred n := fun inp work out => + inp = inpβ‚€ ∧ (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ out = outβ‚€ + have hclear := clearWorkTM_hoareTime_frame_of_binaryString idx bits + (P := ClearFrame) (by + intro inp work out inp' work' out' hframe _htarget hinp hout hwork + rcases hframe with ⟨hframeInput, hframeOther, hframeOutput⟩ + exact ⟨hinp.trans hframeInput, fun i hi => + (hwork i hi).trans (hframeOther i hi), hout.trans hframeOutput⟩) + have hclear' : (clearWorkTM idx).HoareTime + (fun inp work out => + inp = inpβ‚€ ∧ + work idx = (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right ∧ + (βˆ€ i, i β‰  idx β†’ work i = workβ‚€ i) ∧ + out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = Function.update workβ‚€ idx ((Tape.init []).move Dir3.right) ∧ + out = outβ‚€) + (clearWorkTimeBound bits.length) := by + apply hclear.consequence (b' := clearWorkTimeBound bits.length) + Β· intro inp work out hpre + rcases hpre with ⟨hinp, htargetEq, hwork, hout⟩ + refine ⟨htargetEq, ?_, ?_, ?_, ?_, hinp, hwork, hout⟩ + Β· rw [hinp] + exact hinput.read_ne_start + Β· rw [hout] + exact houtput.read_ne_start + Β· rw [hout] + exact houtput.1 + Β· intro i hi + rw [hwork i hi] + exact ⟨(hother i hi).read_ne_start, (hother i hi).1⟩ + Β· intro inp work out hpost + rcases hpost with ⟨htargetEq, hinp, hwork, hout⟩ + refine ⟨hinp, ?_, hout⟩ + funext i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + exact htargetEq + Β· rw [Function.update_of_ne hi] + exact hwork i hi + Β· unfold clearWorkTimeBound + omega + unfold resetBinaryWorkTM resetBinaryWorkTime + exact seqTM_hoareTime (rewindWorkTM idx) (clearWorkTM idx) hrewind + (by + intro inp work out hmid + rcases hmid with ⟨hinp, htargetEq, hwork, hout⟩ + have hreads : βˆ€ i, (work i).read β‰  Ξ“.start := by + intro i + by_cases hi : i = idx + Β· subst i + rw [htargetEq] + exact Tape.init_ofBool_move_right_read_ne_start bits + Β· rw [hwork i hi] + exact (hother i hi).read_ne_start + obtain ⟨hinputTransition, hworkTransition, houtputTransition⟩ := + phaseTransition_eq_self_of_reads_ne_start + (hinp β–Έ hinput.read_ne_start) hreads (hout β–Έ houtput.read_ne_start) + rw [hinputTransition, hworkTransition, houtputTransition] + exact ⟨hinp, htargetEq, hwork, hout⟩) + hclear' + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany.lean new file mode 100644 index 0000000000..dc7f423752 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Internal + +/-! +# Resetting several binary work tapes + +This module exposes a framed compositional contract for resetting a fixed list +of distinct canonical binary work tapes. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +/-- A reset list has a uniform linear bound when every target head and +represented bit string is bounded uniformly. -/ +theorem resetBinaryWorkManyTime_le + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) (maxHead maxWidth : β„•) + (hhead : βˆ€ i, i ∈ targets β†’ headBound i ≀ maxHead) + (hwidth : βˆ€ i, i ∈ targets β†’ (bits i).length ≀ maxWidth) : + resetBinaryWorkManyTime bits headBound targets ≀ + targets.length * (maxHead + 2 * maxWidth + 9) + 1 := + resetBinaryWorkManyTime_le_internal targets bits headBound maxHead maxWidth + hhead hwidth + +/-- Every targeted work tape is the standard parked blank after the reset +sequence. -/ +theorem resetBinaryWorkManyResult_eq_blank_of_mem + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) (idx : Fin n) + (hidx : idx ∈ targets) : + resetBinaryWorkManyResult workβ‚€ targets idx = resetBinaryBlank := + resetBinaryWorkManyResult_eq_blank_of_mem_internal workβ‚€ targets idx hidx + +/-- Work tapes outside the target list are preserved literally. -/ +theorem resetBinaryWorkManyResult_eq_of_not_mem + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) (idx : Fin n) + (hidx : idx βˆ‰ targets) : + resetBinaryWorkManyResult workβ‚€ targets idx = workβ‚€ idx := + resetBinaryWorkManyResult_eq_of_not_mem_internal workβ‚€ targets idx hidx + +/-- Resetting a list of work tapes preserves parkedness of the whole work +family. -/ +theorem resetBinaryWorkManyResult_parked + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) + (hwork : βˆ€ i, Parked (workβ‚€ i)) : + βˆ€ i, Parked (resetBinaryWorkManyResult workβ‚€ targets i) := + resetBinaryWorkManyResult_parked_internal workβ‚€ targets hwork + +/-- The reset-sequence time depends on head bounds only at named targets. -/ +theorem resetBinaryWorkManyTime_congr_headBound + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (left right : Fin n β†’ β„•) + (heq : βˆ€ i, i ∈ targets β†’ left i = right i) : + resetBinaryWorkManyTime bits left targets = + resetBinaryWorkManyTime bits right targets := + resetBinaryWorkManyTime_congr_headBound_internal targets bits left right heq + +/-- Sequentially reset a distinct list of canonical binary work tapes while +preserving the complete external frame. -/ +theorem resetBinaryWorkManyTM_hoareTime_frame + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hnodup : targets.Nodup) + (htarget : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).HasBinaryContent (bits i)) + (htargetStart : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).cells 0 = Ξ“.start) + (htargetHead : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).head ≀ headBound i) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (resetBinaryWorkManyTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = resetBinaryWorkManyResult workβ‚€ targets ∧ + out = outβ‚€) + (resetBinaryWorkManyTime bits headBound targets) := + resetBinaryWorkManyTM_hoareTime_frame_internal targets bits headBound inpβ‚€ + workβ‚€ outβ‚€ hnodup htarget htargetStart htargetHead hinput hwork houtput + +/-- Resetting several binary work tapes preserves one-way output safety. -/ +theorem resetBinaryWorkManyTM_isTransducer (targets : List (Fin n)) : + (resetBinaryWorkManyTM targets).IsTransducer := + resetBinaryWorkManyTM_isTransducer_internal targets + +/-- Coarse all-prefix auxiliary-space envelope for a reset sequence. -/ +theorem resetBinaryWorkManyTM_prefix_withinAuxSpace + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) (inputLength initialSpace time : β„•) + (start current : Cfg n (resetBinaryWorkManyTM targets).Q) + (hinitial : start.WithinAuxSpace inputLength initialSpace) + (hreach : (resetBinaryWorkManyTM targets).reachesIn time start current) + (htime : time ≀ resetBinaryWorkManyTime bits headBound targets) : + current.WithinAuxSpace inputLength + (initialSpace + resetBinaryWorkManyTime bits headBound targets) := + (hinitial.reachesIn hreach).mono le_rfl (by omega) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Defs.lean new file mode 100644 index 0000000000..deb531568c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Defs.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary.Defs + +/-! +# Resetting several binary work tapes β€” definitions + +`resetBinaryWorkManyTM targets` sequentially rewinds and clears every work +tape named by `targets`. The executable machine depends only on the tape-index +list; represented contents and resource bounds occur only in its contracts. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The standard parked blank work tape produced by binary reset. -/ +def resetBinaryBlank : Tape := + (Tape.init []).move Dir3.right + +/-- Sequentially reset every work tape in `targets`, with `skipTM` as the +empty-list identity. -/ +def resetBinaryWorkManyTM {n : β„•} : List (Fin n) β†’ TM n + | [] => skipTM + | idx :: rest => seqTM (resetBinaryWorkTM idx) (resetBinaryWorkManyTM rest) + +/-- Exact work family obtained by applying the advertised resets in order. -/ +def resetBinaryWorkManyResult {n : β„•} : + (Fin n β†’ Tape) β†’ List (Fin n) β†’ Fin n β†’ Tape + | work, [] => work + | work, idx :: rest => + resetBinaryWorkManyResult (Function.update work idx resetBinaryBlank) rest + +/-- Compositional time bound: every reset is followed by one sequencing seam, +and the empty-list `skipTM` costs one final step. -/ +def resetBinaryWorkManyTime {n : β„•} (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) : List (Fin n) β†’ β„• + | [] => 1 + | idx :: rest => + resetBinaryWorkTime (headBound idx) (bits idx).length + 1 + + resetBinaryWorkManyTime bits headBound rest + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Internal.lean new file mode 100644 index 0000000000..330a94968d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetBinaryMany/Internal.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinary +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ResetBinaryMany.Defs + +/-! +# Resetting several binary work tapes β€” proof internals +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {n : β„•} + +theorem resetBinaryWorkManyTime_le_internal + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) (maxHead maxWidth : β„•) + (hhead : βˆ€ i, i ∈ targets β†’ headBound i ≀ maxHead) + (hwidth : βˆ€ i, i ∈ targets β†’ (bits i).length ≀ maxWidth) : + resetBinaryWorkManyTime bits headBound targets ≀ + targets.length * (maxHead + 2 * maxWidth + 9) + 1 := by + induction targets with + | nil => simp [resetBinaryWorkManyTime] + | cons idx rest ih => + have hheadIdx := hhead idx (by simp) + have hwidthIdx := hwidth idx (by simp) + have ih' := ih + (fun i hi => hhead i (by simp [hi])) + (fun i hi => hwidth i (by simp [hi])) + simp only [resetBinaryWorkManyTime, resetBinaryWorkTime, + clearWorkTimeBound, List.length_cons] + calc + headBound idx + 2 + 1 + (2 * (bits idx).length + 5) + 1 + + resetBinaryWorkManyTime bits headBound rest ≀ + (maxHead + 2 * maxWidth + 9) + + resetBinaryWorkManyTime bits headBound rest := by omega + _ ≀ (maxHead + 2 * maxWidth + 9) + + (rest.length * (maxHead + 2 * maxWidth + 9) + 1) := + Nat.add_le_add_left ih' _ + _ = (rest.length + 1) * (maxHead + 2 * maxWidth + 9) + 1 := by + rw [Nat.add_mul] + omega + +private theorem resetBinaryBlank_parked : Parked resetBinaryBlank := by + constructor + Β· simp [resetBinaryBlank, Tape.init, Tape.move] + Β· intro j hj + simpa [resetBinaryBlank, Tape.init, Tape.move] using + (show j β‰  0 by omega) + +theorem resetBinaryWorkManyResult_parked_internal + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) + (hwork : βˆ€ i, Parked (workβ‚€ i)) : + βˆ€ i, Parked (resetBinaryWorkManyResult workβ‚€ targets i) := by + induction targets generalizing workβ‚€ with + | nil => exact hwork + | cons idx rest ih => + apply ih + intro i + by_cases hi : i = idx + Β· subst i + rw [Function.update_self] + exact resetBinaryBlank_parked + Β· simpa [Function.update_of_ne hi] using hwork i + +theorem resetBinaryWorkManyResult_eq_of_not_mem_internal + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) (idx : Fin n) + (hidx : idx βˆ‰ targets) : + resetBinaryWorkManyResult workβ‚€ targets idx = workβ‚€ idx := by + induction targets generalizing workβ‚€ with + | nil => rfl + | cons target rest ih => + have hne : idx β‰  target := by + intro heq + exact hidx (by simp [heq]) + have hrest : idx βˆ‰ rest := by + intro hmem + exact hidx (by simp [hmem]) + simpa [resetBinaryWorkManyResult, Function.update_of_ne hne] using + ih (Function.update workβ‚€ target resetBinaryBlank) hrest + +theorem resetBinaryWorkManyResult_eq_blank_of_mem_internal + (workβ‚€ : Fin n β†’ Tape) (targets : List (Fin n)) (idx : Fin n) + (hidx : idx ∈ targets) : + resetBinaryWorkManyResult workβ‚€ targets idx = resetBinaryBlank := by + induction targets generalizing workβ‚€ with + | nil => simp at hidx + | cons target rest ih => + by_cases heq : idx = target + Β· subst idx + by_cases hmem : target ∈ rest + Β· exact ih (Function.update workβ‚€ target resetBinaryBlank) hmem + Β· exact resetBinaryWorkManyResult_eq_of_not_mem_internal + (Function.update workβ‚€ target resetBinaryBlank) rest target hmem + |>.trans (Function.update_self ..) + Β· have hrest : idx ∈ rest := by + simpa [heq] using hidx + exact ih (Function.update workβ‚€ target resetBinaryBlank) hrest + +theorem resetBinaryWorkManyTime_congr_headBound_internal + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (left right : Fin n β†’ β„•) + (heq : βˆ€ i, i ∈ targets β†’ left i = right i) : + resetBinaryWorkManyTime bits left targets = + resetBinaryWorkManyTime bits right targets := by + induction targets with + | nil => rfl + | cons idx rest ih => + simp only [resetBinaryWorkManyTime] + rw [heq idx (by simp)] + exact congrArg + (fun time => resetBinaryWorkTime (right idx) (bits idx).length + 1 + time) + (ih fun i hi => heq i (by simp [hi])) + +theorem resetBinaryWorkManyTM_hoareTime_frame_internal + (targets : List (Fin n)) (bits : Fin n β†’ List Bool) + (headBound : Fin n β†’ β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hnodup : targets.Nodup) + (htarget : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).HasBinaryContent (bits i)) + (htargetStart : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).cells 0 = Ξ“.start) + (htargetHead : βˆ€ i, i ∈ targets β†’ (workβ‚€ i).head ≀ headBound i) + (hinput : Parked inpβ‚€) (hwork : βˆ€ i, Parked (workβ‚€ i)) + (houtput : Parked outβ‚€) : + (resetBinaryWorkManyTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => + inp = inpβ‚€ ∧ + work = resetBinaryWorkManyResult workβ‚€ targets ∧ + out = outβ‚€) + (resetBinaryWorkManyTime bits headBound targets) := by + induction targets generalizing workβ‚€ with + | nil => + simpa [resetBinaryWorkManyTM, resetBinaryWorkManyResult, + resetBinaryWorkManyTime] using + skipTM_hoareTime_frame inpβ‚€ workβ‚€ outβ‚€ hinput hwork houtput + | cons idx rest ih => + have hidxNotMem : idx βˆ‰ rest := (List.nodup_cons.mp hnodup).1 + have hrestNodup : rest.Nodup := (List.nodup_cons.mp hnodup).2 + let work₁ := Function.update workβ‚€ idx resetBinaryBlank + have hreset := resetBinaryWorkTM_hoareTime_frame idx (bits idx) + (headBound idx) inpβ‚€ workβ‚€ outβ‚€ + (htarget idx (by simp)) (htargetStart idx (by simp)) + ⟨(hwork idx).1, htargetHead idx (by simp)⟩ hinput + (fun i _ => hwork i) houtput + have hwork₁ : βˆ€ i, Parked (work₁ i) := by + intro i + by_cases hi : i = idx + Β· subst i + simpa [work₁, resetBinaryBlank] using resetBinaryBlank_parked + Β· simpa [work₁, Function.update_of_ne hi] using hwork i + have htarget₁ : βˆ€ i, i ∈ rest β†’ + (work₁ i).HasBinaryContent (bits i) := by + intro i hi + have hne : i β‰  idx := fun hieq => hidxNotMem (hieq β–Έ hi) + simpa [work₁, Function.update_of_ne hne] using + htarget i (by simp [hi]) + have htargetStart₁ : βˆ€ i, i ∈ rest β†’ + (work₁ i).cells 0 = Ξ“.start := by + intro i hi + have hne : i β‰  idx := fun hieq => hidxNotMem (hieq β–Έ hi) + simpa [work₁, Function.update_of_ne hne] using + htargetStart i (by simp [hi]) + have htargetHead₁ : βˆ€ i, i ∈ rest β†’ + (work₁ i).head ≀ headBound i := by + intro i hi + have hne : i β‰  idx := fun hieq => hidxNotMem (hieq β–Έ hi) + simpa [work₁, Function.update_of_ne hne] using + htargetHead i (by simp [hi]) + have hrest := ih work₁ hrestNodup htarget₁ htargetStart₁ + htargetHead₁ hwork₁ + have hseq := seqTM_hoareTime (resetBinaryWorkTM idx) + (resetBinaryWorkManyTM rest) hreset + (by + intro inp work out hmid + rcases hmid with ⟨hinp, hworkEq, hout⟩ + have hworkParked : βˆ€ i, Parked (work i) := by + intro i + rw [hworkEq] + exact hwork₁ i + obtain ⟨hinpTransition, hworkTransition, houtTransition⟩ := + phaseTransition_eq_self_of_reads_ne_start + (hinp β–Έ hinput.read_ne_start) + (fun i => (hworkParked i).read_ne_start) + (hout β–Έ houtput.read_ne_start) + rw [hinpTransition, hworkTransition, houtTransition] + exact ⟨hinp, hworkEq, hout⟩) + hrest + simpa [resetBinaryWorkManyTM, resetBinaryWorkManyResult, + resetBinaryWorkManyTime, work₁] using hseq + +theorem resetBinaryWorkManyTM_isTransducer_internal + (targets : List (Fin n)) : + (resetBinaryWorkManyTM targets).IsTransducer := by + induction targets with + | nil => + intro state iHead wHeads oHead + cases state <;> cases oHead <;> simp [resetBinaryWorkManyTM, skipTM, + idleDir] + | cons idx rest ih => + simpa [resetBinaryWorkManyTM] using + (resetBinaryWorkTM_isTransducer idx).seqTM ih + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean new file mode 100644 index 0000000000..906bcee6c1 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean @@ -0,0 +1,309 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeLoop + +/-! +# Resetting a list of tapes to blank, content-agnostically + +The full reset an opaque machine's scratch needs between calls: park everything +(`TM.parkAll_hoareTime`), rewind every targeted tape to cell `1` +(`TM.rewindList_hoareTime`), then wipe `H` cells forward from there +(`TM.wipeLoop_hoareTime`). A fuel register disjoint from the targets drives the +wipe and is left exactly as it started. + +## Main results + +- `TM.resetTapesTM` β€” the composite reset machine +- `TM.resetTapesTM_hoareTime` / `TM.resetTapesTM_hoareTime_of_bounds` β€” its contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- **Resetting a list of tapes.** Regardless of their current content or head +position (bounded by `H`), every tape in `targets` ends up blanked from cell +`1` through cell `H`, with its tail beyond cell `H` untouched; the fuel +register `r` (disjoint from `targets`) and every other tape are exactly as +they were. -/ +theorem resetTapes_hoareTime {n : β„•} (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r βˆ‰ targets) (H : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinpSI : Tape.StartInvariant inpβ‚€) (hinpP : Parked inpβ‚€) + (hout0 : outβ‚€ = (Tape.init []).move Dir3.right) + (hworkSI : βˆ€ j, j β‰  r β†’ Tape.StartInvariant (workβ‚€ j)) + (htargetHead : βˆ€ j, j ∈ targets β†’ (workβ‚€ j).head ≀ H) + (hworkR : workβ‚€ r = regTape H) + (hother : βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ Parked (workβ‚€ j)) : + (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = wipedTape (⟨1, (workβ‚€ j).cells⟩ : Tape) H) ∧ + work r = regTape H ∧ + (βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ work j = workβ‚€ j)) + (targets.length * (H + 4) + H * 4 + 8) := by + have hregParked : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i β‰  Ξ“.start + simp only [regCells]; split + Β· omega + Β· split <;> decide⟩ + have houtSI : Tape.StartInvariant outβ‚€ := by + rw [hout0] + refine ⟨?_, fun j hj => ?_⟩ + Β· rw [Tape.move_cells]; exact Tape.init_cells_zero [] + Β· rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + decide + have houtP : Parked outβ‚€ := by rw [hout0]; exact parked_parkedBlank + have hworkSI' : βˆ€ j, Tape.StartInvariant (workβ‚€ j) := by + intro j + by_cases hjr : j = r + Β· subst hjr; rw [hworkR]; exact ⟨rfl, hregParked.2⟩ + Β· exact hworkSI j hjr + set workA : Fin n β†’ Tape := fun j => (⟨max (workβ‚€ j).head 1, (workβ‚€ j).cells⟩ : Tape) + with hworkA + have hAP : βˆ€ j, Parked (workA j) := fun j => ⟨le_max_right _ _, fun i hi => (hworkSI' j).2 i hi⟩ + have hAtarget : βˆ€ j, j ∈ targets β†’ (workA j).cells 0 = Ξ“.start ∧ (workA j).head ≀ H + 1 := by + intro j hj + refine ⟨(hworkSI' j).1, ?_⟩ + show max (workβ‚€ j).head 1 ≀ H + 1 + have := htargetHead j hj + omega + have hA := parkAll_hoareTime inpβ‚€ workβ‚€ outβ‚€ hinpSI hworkSI' houtSI + have hinpAeq : (⟨max inpβ‚€.head 1, inpβ‚€.cells⟩ : Tape) = inpβ‚€ := + Tape.ext (by show max inpβ‚€.head 1 = inpβ‚€.head; have := hinpP.1; omega) rfl + have houtAeq : (⟨max outβ‚€.head 1, outβ‚€.cells⟩ : Tape) = outβ‚€ := + Tape.ext (by show max outβ‚€.head 1 = outβ‚€.head; have := houtP.1; omega) rfl + have hApost_imp : βˆ€ inp work out, + (inp = (⟨max inpβ‚€.head 1, inpβ‚€.cells⟩ : Tape) ∧ + (βˆ€ i, work i = workA i) ∧ out = (⟨max outβ‚€.head 1, outβ‚€.cells⟩ : Tape)) β†’ + (inp = inpβ‚€ ∧ work = workA ∧ out = outβ‚€) := by + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi.trans hinpAeq, funext hw, ho.trans houtAeq⟩ + have hA' := hA.strengthen_post hApost_imp + have hB0 := rewindList_hoareTime targets hnodup (H + 1) inpβ‚€ workA outβ‚€ hinpP houtP hAP hAtarget + have hB : (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = (⟨1, (workβ‚€ j).cells⟩ : Tape)) ∧ + (βˆ€ j, j βˆ‰ targets β†’ work j = workA j)) + (1 + 1 + targets.length * ((H + 1) + 3) + 1) := by + refine seqTM_hoareTime skipTM (bigSeqTM (targets.map rewindWorkTM)) hA' ?_ hB0 + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨transitionInput_eq_self hinpP.read_ne_start, ?_, + transitionTape_eq_self houtP.read_ne_start⟩ + funext i + exact transitionTape_eq_self (hAP i).read_ne_start + set workC : Fin n β†’ Tape := fun j => if j ∈ targets then (⟨1, (workβ‚€ j).cells⟩ : Tape) + else workβ‚€ j with hworkC + have hCother : βˆ€ j, j β‰  r β†’ Parked (workC j) := by + intro j hjr + rw [hworkC] + dsimp only + split + Β· next hjt => exact ⟨le_refl 1, (hworkSI' j).2⟩ + Β· next hjt => exact hother j hjr hjt + have hC0 := wipeLoop_hoareTime targets r hr H inpβ‚€ workC hinpP hCother + have hworkeq : βˆ€ (work : Fin n β†’ Tape), + (βˆ€ j, j ∈ targets β†’ work j = (⟨1, (workβ‚€ j).cells⟩ : Tape)) β†’ + (βˆ€ j, j βˆ‰ targets β†’ work j = workA j) β†’ + work = Function.update workC r (regTape H) := by + intro work hts hnts + funext j + by_cases hjr : j = r + Β· rw [hjr, Function.update_self] + rw [hnts r hr] + show (⟨max (workβ‚€ r).head 1, (workβ‚€ r).cells⟩ : Tape) = regTape H + rw [hworkR] + exact Tape.ext (by show max 1 1 = 1; omega) (by rw [regT_cells]) + Β· rw [Function.update_of_ne hjr] + by_cases hjt : j ∈ targets + Β· rw [hts j hjt, hworkC]; simp [hjt] + Β· rw [hnts j hjt, hworkC] + simp only [hjt, ite_false] + exact Tape.ext (by + show max (workβ‚€ j).head 1 = (workβ‚€ j).head + have := (hother j hjr hjt).1 + omega) rfl + have hread : βˆ€ (work : Fin n β†’ Tape), + (βˆ€ j, j ∈ targets β†’ work j = (⟨1, (workβ‚€ j).cells⟩ : Tape)) β†’ + (βˆ€ j, j βˆ‰ targets β†’ work j = workA j) β†’ + βˆ€ j, (work j).read β‰  Ξ“.start := by + intro work hts hnts j + by_cases hjt : j ∈ targets + Β· rw [hts j hjt] + exact (hworkSI' j).2 1 le_rfl + Β· rw [hnts j hjt] + exact (hAP j).read_ne_start + have htrans : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape), + (inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = (⟨1, (workβ‚€ j).cells⟩ : Tape)) ∧ + (βˆ€ j, j βˆ‰ targets β†’ work j = workA j)) β†’ + transitionInput inp = inpβ‚€ ∧ + (fun i => transitionTape (work i)) = Function.update workC r (regTape H) ∧ + transitionTape out = (Tape.init []).move Dir3.right := by + rintro inp work out ⟨hi, ho, hts, hnts⟩ + refine ⟨by rw [hi]; exact transitionInput_eq_self hinpP.read_ne_start, + ?_, by rw [ho, transitionTape_eq_self houtP.read_ne_start]; exact hout0⟩ + rw [← hworkeq work hts hnts] + funext j + exact transitionTape_eq_self (hread work hts hnts j) + have hFull := seqTM_hoareTime (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r) hB htrans hC0 + have hpost_imp : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape), + (inp = inpβ‚€ ∧ + work = Function.update (fun j => if j ∈ targets then wipedTape (workC j) H else workC j) + r (regTape H) ∧ + out = (Tape.init []).move Dir3.right) β†’ + (inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = wipedTape (⟨1, (workβ‚€ j).cells⟩ : Tape) H) ∧ + work r = regTape H ∧ + (βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ work j = workβ‚€ j)) := by + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ho.trans hout0.symm, fun j hjt => ?_, ?_, fun j hjr hjt => ?_⟩ + Β· rw [hw, Function.update_of_ne (fun h => hr (by rw [h] at hjt; exact hjt)), + ite_eq_left hjt, hworkC] + simp [hjt] + Β· rw [hw, Function.update_self] + Β· rw [hw, Function.update_of_ne hjr, hworkC] + simp [hjt] + refine (hFull.strengthen_post hpost_imp).mono_bound ?_ + ring_nf + omega + +/-- The composite reset machine: park everything, rewind the targets, wipe +`H` cells forward, then rewind the targets again. -/ +def resetTapesTM {n : β„•} (targets : List (Fin n)) (r : Fin n) : TM n := + seqTM (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)) + (bigSeqTM (targets.map rewindWorkTM)) + +/-- **The full reset.** Every tape in `targets` whose content is confined to +cells `1 … H` β€” no matter *where* in that range, and no matter where its head +currently sits β€” ends up literally blank and parked at cell `1`. The fuel +register `r` and all other tapes are returned exactly as they were. -/ +theorem resetTapesTM_hoareTime {n : β„•} (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r βˆ‰ targets) (H : β„•) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinpSI : Tape.StartInvariant inpβ‚€) (hinpP : Parked inpβ‚€) + (hout0 : outβ‚€ = (Tape.init []).move Dir3.right) + (hworkSI : βˆ€ j, j β‰  r β†’ Tape.StartInvariant (workβ‚€ j)) + (htargetHead : βˆ€ j, j ∈ targets β†’ (workβ‚€ j).head ≀ H) + (htargetFar : βˆ€ j, j ∈ targets β†’ βˆ€ i, H < i β†’ (workβ‚€ j).cells i = Ξ“.blank) + (hworkR : workβ‚€ r = regTape H) + (hother : βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ Parked (workβ‚€ j)) : + (resetTapesTM targets r).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = (Tape.init []).move Dir3.right) ∧ + work r = regTape H ∧ + (βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ work j = workβ‚€ j)) + (targets.length * (H + 4) + H * 4 + 8 + 1 + (targets.length * (H + 4) + 1)) := by + have houtP : Parked outβ‚€ := by rw [hout0]; exact parked_parkedBlank + have hregParked : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i β‰  Ξ“.start + simp only [regCells]; split + Β· omega + Β· split <;> decide⟩ + -- the wipe's exact effect on a targeted tape, spelled out + have hwiped : βˆ€ j, j ∈ targets β†’ + wipedTape (⟨1, (workβ‚€ j).cells⟩ : Tape) H = (⟨H + 1, (Tape.init []).cells⟩ : Tape) := by + intro j hj + refine wipedTape_eq_blank H rfl ?_ (fun i hi => htargetFar j hj i hi) + exact (hworkSI j (fun h => hr (h β–Έ hj))).1 + -- the tape family after the wipe phase + set workD : Fin n β†’ Tape := fun j => + if j ∈ targets then (⟨H + 1, (Tape.init []).cells⟩ : Tape) + else if j = r then regTape H else workβ‚€ j with hworkD + have hDP : βˆ€ j, Parked (workD j) := by + intro j + rw [hworkD] + dsimp only + split + Β· exact ⟨show 1 ≀ H + 1 by omega, + fun i hi => by rw [initNil_cells, ite_eq_right (by omega)]; decide⟩ + Β· split + Β· exact hregParked + Β· next hjt hjr => exact hother j hjr hjt + have hDtarget : βˆ€ j, j ∈ targets β†’ + (workD j).cells 0 = Ξ“.start ∧ (workD j).head ≀ H + 1 := by + intro j hj + rw [hworkD] + simp only [ite_eq_left hj] + exact ⟨by rw [initNil_cells, ite_eq_left rfl], le_refl _⟩ + have hfirst := resetTapes_hoareTime targets hnodup r hr H inpβ‚€ workβ‚€ outβ‚€ hinpSI hinpP + hout0 hworkSI htargetHead hworkR hother + have hsecond := rewindList_hoareTime targets hnodup (H + 1) inpβ‚€ workD outβ‚€ hinpP houtP + hDP hDtarget + refine seqTM_hoareTime _ _ hfirst ?_ hsecond |>.strengthen_post ?_ + Β· -- the boundary: everything is parked, so the seam is the identity + rintro inp work out ⟨hi, ho, hts, hR, hrest⟩ + have hworkD_eq : work = workD := by + funext j + by_cases hjt : j ∈ targets + Β· rw [hts j hjt, hwiped j hjt, hworkD]; simp [hjt] + Β· by_cases hjr : j = r + Β· rw [hjr, hR, hworkD]; simp [hr] + Β· rw [hrest j hjr hjt, hworkD]; simp [hjt, hjr] + subst hworkD_eq + refine ⟨by rw [hi]; exact transitionInput_eq_self hinpP.read_ne_start, ?_, + by rw [ho]; exact transitionTape_eq_self houtP.read_ne_start⟩ + funext j + exact transitionTape_eq_self (hDP j).read_ne_start + Β· rintro inp work out ⟨hi, ho, hts, hnts⟩ + refine ⟨hi, ho, fun j hj => ?_, ?_, fun j hjr hjt => ?_⟩ + Β· rw [hts j hj, hworkD] + simp only [ite_eq_left hj] + rfl + Β· rw [hnts r hr, hworkD] + simp [hr] + Β· rw [hnts j hjt, hworkD] + simp [hjt, hjr] + +/-- **The reset, keyed on bounds rather than on a named tape family.** The +tapes an opaque machine leaves behind are only known through bounds, never as +a closed form, so this is the shape the loop body actually needs: the exact +starting family is instantiated inside the proof. -/ +theorem resetTapesTM_hoareTime_of_bounds {n : β„•} (targets : List (Fin n)) + (hnodup : targets.Nodup) (r : Fin n) (hr : r βˆ‰ targets) (H : β„•) + (inpβ‚€ : Tape) (extras : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinpSI : Tape.StartInvariant inpβ‚€) (hinpP : Parked inpβ‚€) + (hout0 : outβ‚€ = (Tape.init []).move Dir3.right) + (hextraP : βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ Parked (extras j)) : + (resetTapesTM targets r).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j β‰  r β†’ Tape.StartInvariant (work j)) ∧ + (βˆ€ j, j ∈ targets β†’ (work j).head ≀ H ∧ βˆ€ i, H < i β†’ (work j).cells i = Ξ“.blank) ∧ + work r = regTape H ∧ + (βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ work j = extras j)) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = (Tape.init []).move Dir3.right) ∧ + work r = regTape H ∧ + (βˆ€ j, j β‰  r β†’ j βˆ‰ targets β†’ work j = extras j)) + (targets.length * (H + 4) + H * 4 + 8 + 1 + (targets.length * (H + 4) + 1)) := by + intro inp work out hpre + obtain ⟨hi, ho, hSI, hbnd, hR, hext⟩ := hpre + rw [hi, ho] + obtain ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', hrest⟩ := + resetTapesTM_hoareTime targets hnodup r hr H inpβ‚€ work outβ‚€ hinpSI hinpP hout0 hSI + (fun j hj => (hbnd j hj).1) (fun j hj i hii => (hbnd j hj).2 i hii) hR + (fun j hjr hjt => by rw [hext j hjr hjt]; exact hextraP j hjr hjt) + inpβ‚€ work outβ‚€ ⟨rfl, rfl, rfl⟩ + exact ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', + fun j hjr hjt => (hrest j hjr hjt).trans (hext j hjr hjt)⟩ + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean new file mode 100644 index 0000000000..98828d9c6d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Tactic.Ring +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.ParkAll + +/-! +# Rewinding a list of tapes, one at a time + +Rewinding cannot be done in one uniform pass the way wiping can: +`TM.rewindWorkTM` bounces at `β–·` rather than saturating there, so moving +everyone left the same number of times oscillates. Doing it one tape at a time +via `TM.bigSeqTM` works once every tape has been parked once +(`TM.parkAll_hoareTime`). + +## Main results + +- `TM.rewindList_hoareTime` β€” rewind every targeted tape to cell `1` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- **Rewinding a list of tapes, one at a time.** Given a uniform head bound +`B` and that *every* tape (not just the targets) is already `Parked` β€” the +state after `parkAll_hoareTime` β€” sequentially rewinding each named tape +lands it at cell `1` with its cells unchanged, leaving every other tape +(targeted-but-not-yet-reached, or never targeted) exactly as it was. -/ +theorem rewindList_hoareTime {n : β„•} : + βˆ€ (targets : List (Fin n)), targets.Nodup β†’ + βˆ€ (B : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape), + Parked inpβ‚€ β†’ Parked outβ‚€ β†’ (βˆ€ j, Parked (workβ‚€ j)) β†’ + (βˆ€ j, j ∈ targets β†’ (workβ‚€ j).cells 0 = Ξ“.start ∧ (workβ‚€ j).head ≀ B) β†’ + (bigSeqTM (targets.map rewindWorkTM)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ targets β†’ work j = ⟨1, (workβ‚€ j).cells⟩) ∧ + (βˆ€ j, j βˆ‰ targets β†’ work j = workβ‚€ j)) + (targets.length * (B + 3) + 1) := by + intro targets + induction targets with + | nil => + intro _ B inpβ‚€ workβ‚€ outβ‚€ hinp hout hwork _ + simp only [List.map_nil, List.length_nil, Nat.zero_mul, Nat.zero_add] + refine (skipTM_hoareTime_frame inpβ‚€ workβ‚€ outβ‚€ hinp hwork hout).strengthen_post ?_ + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, nofun, fun j _ => rfl⟩ + | cons t ts ih => + intro hnodup B inpβ‚€ workβ‚€ outβ‚€ hinp hout hwork htarget + have htnts : t βˆ‰ ts := (List.nodup_cons.mp hnodup).1 + have htsnodup : ts.Nodup := (List.nodup_cons.mp hnodup).2 + have hP : βˆ€ (inp : Tape) (work : Fin n β†’ Tape) (out : Tape) + (inp' : Tape) (work' : Fin n β†’ Tape) (out' : Tape), + ((work t).cells = (workβ‚€ t).cells ∧ + inp = inpβ‚€ ∧ out = outβ‚€ ∧ βˆ€ j, j β‰  t β†’ work j = workβ‚€ j) β†’ + (work' t).cells = (work t).cells β†’ (work' t).head = 1 β†’ + (βˆ€ j, j β‰  t β†’ work' j = work j) β†’ + inp' = inp β†’ out'.cells = out.cells β†’ out'.head = out.head β†’ + ((work' t).cells = (workβ‚€ t).cells ∧ + inp' = inpβ‚€ ∧ out' = outβ‚€ ∧ βˆ€ j, j β‰  t β†’ work' j = workβ‚€ j) := by + rintro inp work out inp' work' out' ⟨hcellsP, rfl, rfl, hrest⟩ hcells' _ hkeep rfl + hout'c hout'h + exact ⟨hcells'.trans hcellsP, rfl, Tape.ext hout'h hout'c, + fun j hjt => (hkeep j hjt).trans (hrest j hjt)⟩ + have h1 := rewindWorkTM_hoareTime_frame t B hP + have h1' := h1.weaken_pre + (show (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) ≀ _ by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨(htarget t (by simp)).1, fun j hj => (hwork t).2 j hj, (htarget t (by simp)).2, + hinp.read_ne_start, hout.read_ne_start, hout.1, + fun i _ => ⟨(hwork i).read_ne_start, (hwork i).1⟩, rfl, rfl, rfl, fun _ _ => rfl⟩) + set work₁ : Fin n β†’ Tape := Function.update workβ‚€ t (⟨1, (workβ‚€ t).cells⟩ : Tape) with hwork₁ + have hwork₁P : βˆ€ j, Parked (work₁ j) := by + intro j + by_cases hjt : j = t + Β· rw [hjt, hwork₁, Function.update_self] + exact ⟨le_refl 1, fun i hi => (hwork t).2 i hi⟩ + Β· rw [hwork₁, Function.update_of_ne hjt]; exact hwork j + have hwork₁target : βˆ€ j, j ∈ ts β†’ (work₁ j).cells 0 = Ξ“.start ∧ (work₁ j).head ≀ B := by + intro j hj + have hjt : j β‰  t := by rintro rfl; exact htnts hj + rw [hwork₁, Function.update_of_ne hjt] + exact htarget j (by simp [hj]) + have ih' := ih htsnodup B inpβ‚€ work₁ outβ‚€ hinp hout hwork₁P hwork₁target + have hread_t : βˆ€ (work : Fin n β†’ Tape), (work t).cells = (workβ‚€ t).cells β†’ + (work t).head = 1 β†’ (work t).read β‰  Ξ“.start := by + intro work hcells hhead + show (work t).cells (work t).head β‰  Ξ“.start + rw [hhead, hcells] + exact (hwork t).2 1 le_rfl + have h2 : (bigSeqTM ((t :: ts).map rewindWorkTM)).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + (βˆ€ j, j ∈ ts β†’ work j = ⟨1, (work₁ j).cells⟩) ∧ + (βˆ€ j, j βˆ‰ ts β†’ work j = work₁ j)) + ((B + 2) + 1 + (ts.length * (B + 3) + 1)) := by + simp only [List.map_cons, bigSeqTM] + refine seqTM_hoareTime (rewindWorkTM t) (bigSeqTM (ts.map rewindWorkTM)) h1' ?_ ih' + rintro inp work out ⟨hhead1, hcellsP, hpinp, hpout, hprest⟩ + have hreadt : (work t).read β‰  Ξ“.start := hread_t work hcellsP hhead1 + have ht1 : transitionInput inp = inpβ‚€ := by + rw [hpinp]; exact transitionInput_eq_self hinp.read_ne_start + have ht3 : transitionTape out = outβ‚€ := by + rw [hpout]; exact transitionTape_eq_self hout.read_ne_start + have ht2 : (fun i => transitionTape (work i)) = work₁ := by + funext j + by_cases hjt : j = t + Β· rw [hjt, transitionTape_eq_self hreadt, hwork₁, Function.update_self] + exact Tape.ext hhead1 hcellsP + Β· rw [hprest j hjt, transitionTape_eq_self (hwork j).read_ne_start, + hwork₁, Function.update_of_ne hjt] + rw [ht1, ht2, ht3] + exact ⟨rfl, rfl, rfl⟩ + refine h2.consequence (fun _ _ _ h => h) + (fun inp work out ⟨hinpeq, houteq, hts, hnts⟩ => ?_) + (by rw [List.length_cons]; ring_nf; omega) + refine ⟨hinpeq, houteq, fun j hj => ?_, fun j hj => ?_⟩ + Β· rw [List.mem_cons] at hj + rcases hj with hjeqt | hjts + Β· rw [hnts j (hjeqt β–Έ htnts), hjeqt, hwork₁, Function.update_self] + Β· rw [hts j hjts] + congr 1 + have hjt : j β‰  t := fun h => htnts (h β–Έ hjts) + rw [hwork₁, Function.update_of_ne hjt] + Β· have hjt : j β‰  t := fun h => hj (List.mem_cons.mpr (Or.inl h)) + have hjts : j βˆ‰ ts := fun h => hj (List.mem_cons.mpr (Or.inr h)) + rw [hnts j hjts, hwork₁, Function.update_of_ne hjt] + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength.lean new file mode 100644 index 0000000000..fd467a3f94 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Internal + +/-! +# Unary input-length transducer + +Public correctness theorem for `TM.unaryLengthTM`. On input `x`, the machine +emits `List.replicate x.length true` within the linear bound `|x| + 2`. + +## Main result + +- `TM.unaryLengthTM_computesInTime` β€” unary input-length computation in + linear time +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The unary input-length transducer computes `List.replicate |x| true` +within the linear time bound `m + 2`. -/ +theorem unaryLengthTM_computesInTime (n : β„•) : + (unaryLengthTM (n := n)).ComputesInTime + (fun x => List.replicate x.length true) (fun m => m + 2) := by + exact unaryLengthTM_computesInTime_internal n + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Defs.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Defs.lean new file mode 100644 index 0000000000..04946a7d80 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Defs.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators + +/-! +# Unary input-length transducer β€” definitions + +This module defines a deterministic transducer that scans its Boolean input +once and writes one `true` bit per input bit. Its output is therefore the +unary representation `List.replicate x.length true` of the input length. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Control states for `unaryLengthTM`: scan the input, then halt at its first +trailing blank. -/ +inductive UnaryLengthPhase where + | copying + | done + deriving DecidableEq + +instance : Fintype UnaryLengthPhase where + elems := {.copying, .done} + complete := fun state => by cases state <;> simp + +/-- Scan the Boolean input from left to right and emit one `true` bit per +input bit. The first step skips the left-end markers, and the machine halts +when the input head reaches its first trailing blank. -/ +def unaryLengthTM {n : β„•} : TM n where + Q := UnaryLengthPhase + qstart := .copying + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .copying => + if iHead = Ξ“.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.copying, fun i => readBackWrite (wHeads i), .one, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copying => + dsimp only [] + split + Β· exact rightOfStart_allIdle iHead wHeads oHead + Β· exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Internal.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Internal.lean new file mode 100644 index 0000000000..9875c13eba --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/UnaryLength/Internal.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.UnaryLength.Defs +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Unary input-length transducer β€” proof internals + +This module proves the exact execution contract for `TM.unaryLengthTM`. +Starting from an initial configuration on `x`, it skips the left-end marker, +writes one `true` bit per input bit, and halts on the first input blank after +exactly `|x| + 2` transitions. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- From the first unvisited input cell and an output containing `k` unary +marks, the scan consumes the remaining `|x| - k` bits and the terminating +blank. -/ +private theorem unaryLengthTM_loop {n : β„•} (x : List Bool) : + βˆ€ rem k (c : Cfg n (unaryLengthTM (n := n)).Q), + rem = x.length - k β†’ + c.state = UnaryLengthPhase.copying β†’ + c.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells β†’ + c.input.head = k + 1 β†’ + c.output.HasBinaryPrefix (List.replicate k true) β†’ + k ≀ x.length β†’ + βˆƒ c', + (unaryLengthTM (n := n)).reachesIn (rem + 1) c c' ∧ + (unaryLengthTM (n := n)).halted c' ∧ + c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells ∧ + c'.input.head = x.length + 1 ∧ + c'.output.HasBinaryPrefix (List.replicate x.length true) := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead hprefix hk + have hk_eq : k = x.length := by omega + subst k + have hread : c.input.read = Ξ“.blank := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_ge x x.length] + have houtputRead : c.output.read = Ξ“.blank := hprefix.read_blank + let c' : Cfg n (unaryLengthTM (n := n)).Q := + { state := UnaryLengthPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hinputKeep : c.input.move (idleDir c.input.read) = c.input := by + simp [idleDir, hread, Tape.move] + have houtputKeep : + c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) = c.output := by + exact transitionTape_eq_self (by simp [houtputRead]) + have hstep : (unaryLengthTM (n := n)).step c = some c' := by + simp [TM.step, hstate, unaryLengthTM, hread, c'] + refine ⟨c', .step hstep .zero, rfl, ?_, ?_, ?_⟩ + Β· rw [show c'.input = c.input by simpa [c'] using hinputKeep] + exact hcells + Β· rw [show c'.input = c.input by simpa [c'] using hinputKeep] + exact hhead + Β· rw [show c'.output = c.output by simpa [c'] using houtputKeep] + exact hprefix + | succ rem ih => + intro k c hrem hstate hcells hhead hprefix hk + have hk_lt : k < x.length := by omega + have hread : c.input.read = Ξ“.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hnotBlank : c.input.read β‰  Ξ“.blank := by + rw [hread] + exact Ξ“.ofBool_ne_blank _ + have hreplicate : + List.replicate k true ++ [true] = List.replicate (k + 1) true := by + change List.replicate k true ++ List.replicate 1 true = _ + rw [← List.replicate_add] + have hprefix' : + (c.output.writeAndMove Ξ“.one Dir3.right).HasBinaryPrefix + (List.replicate (k + 1) true) := by + rw [← hreplicate] + exact Tape.hasBinaryPrefix_write_bit true hprefix + let c' : Cfg n (unaryLengthTM (n := n)).Q := + { state := UnaryLengthPhase.copying + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove Ξ“.one Dir3.right } + have hstep : (unaryLengthTM (n := n)).step c = some c' := by + simp [TM.step, hstate, unaryLengthTM, hnotBlank, c'] + have hcells' : c'.input.cells = (Tape.init (x.map Ξ“.ofBool)).cells := by + simpa [c', Tape.move_cells] using hcells + have hhead' : c'.input.head = (k + 1) + 1 := by + simp [c', Tape.move, hhead] + have hrem' : rem = x.length - (k + 1) := by omega + obtain ⟨c'', hreach, hhalt, hcells'', hhead'', hprefix''⟩ := + ih (k + 1) c' hrem' rfl hcells' hhead' (by simpa [c'] using hprefix') (by omega) + exact ⟨c'', .step hstep hreach, hhalt, hcells'', hhead'', hprefix''⟩ + +/-- Internal implementation theorem: `unaryLengthTM` emits the unary input +length within the linear bound `m + 2`. -/ +theorem unaryLengthTM_computesInTime_internal (n : β„•) : + (unaryLengthTM (n := n)).ComputesInTime + (fun x => List.replicate x.length true) (fun m => m + 2) := by + intro x + let c₁ : Cfg n (unaryLengthTM (n := n)).Q := + { state := UnaryLengthPhase.copying + input := (Tape.init (x.map Ξ“.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep : + (unaryLengthTM (n := n)).step ((unaryLengthTM (n := n)).initCfg x) = some c₁ := by + simp [TM.step, unaryLengthTM, c₁, Tape.read, Tape.init, readBackWrite, + idleDir, Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c', hreach, hhalt, _hcells, _hhead, hprefix⟩ := + unaryLengthTM_loop (n := n) x x.length 0 c₁ (by simp) rfl + (by simp [c₁, Tape.move]) (by simp [c₁, Tape.move]) + (by simpa [c₁] using Tape.init_nil_move_right_hasBinaryPrefix_nil) + (Nat.zero_le _) + refine ⟨c', x.length + 2, le_rfl, ?_, hhalt, ?_⟩ + Β· simpa [Nat.add_assoc] using TM.reachesIn.step hstep hreach + Β· exact hprefix.hasOutput + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean new file mode 100644 index 0000000000..1da8a957eb --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Registers.ForReg +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Subroutines.WipeStep + +/-! +# The wipe loop + +`TM.forRegTM` drives a body an exact number of times off a dedicated unary fuel +register. Running `TM.wipeStepTM` through it, fueled by a register holding `v` +marks unrelated to any targeted tape's content, blanks the leading `v` cells of +every target whatever was there. + +## Main results + +- `TM.wipedTape` β€” the closed form of `v` wipe steps applied to a tape +- `TM.wipeLoop_hoareTime` β€” the loop's contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Wipe-step applied `i` times to `t`, in closed form. -/ +def wipedTape (t : Tape) (i : β„•) : Tape := + (fun s : Tape => s.writeAndMove Ξ“w.blank.toΞ“ Dir3.right)^[i] t + +@[simp] theorem wipedTape_zero (t : Tape) : wipedTape t 0 = t := rfl + +theorem wipedTape_succ (t : Tape) (i : β„•) : + wipedTape t (i + 1) = (wipedTape t i).writeAndMove Ξ“w.blank.toΞ“ Dir3.right := + Function.iterate_succ_apply' _ i t + +/-- Wiping advances the head one cell per step. -/ +theorem wipedTape_head (t : Tape) (i : β„•) : (wipedTape t i).head = t.head + i := by + induction i with + | zero => rfl + | succ i ih => + rw [wipedTape_succ] + show (((wipedTape t i).write Ξ“w.blank.toΞ“).move Dir3.right).head = t.head + (i + 1) + rw [show (((wipedTape t i).write Ξ“w.blank.toΞ“).move Dir3.right).head + = ((wipedTape t i).write Ξ“w.blank.toΞ“).head + 1 from rfl, + Tape.write_head, ih] + omega + +/-- **What wiping does.** From a head parked at cell `1`, wiping `H` times +blanks exactly cells `1 … H` and leaves every other cell alone. -/ +theorem wipedTape_cells_of_head_one {t : Tape} (hh : t.head = 1) (H j : β„•) : + (wipedTape t H).cells j = if 1 ≀ j ∧ j ≀ H then Ξ“.blank else t.cells j := by + induction H with + | zero => rw [wipedTape_zero, ite_eq_right (by omega : Β¬(1 ≀ j ∧ j ≀ 0))] + | succ H ih => + have hheadH : (wipedTape t H).head = H + 1 := by rw [wipedTape_head, hh]; omega + rw [wipedTape_succ] + show (((wipedTape t H).write Ξ“w.blank.toΞ“).move Dir3.right).cells j = _ + rw [Tape.move_cells, Tape.write, ite_eq_right (by rw [hheadH]; omega)] + show Function.update (wipedTape t H).cells (wipedTape t H).head Ξ“w.blank.toΞ“ j = _ + rw [hheadH] + by_cases hj : j = H + 1 + Β· rw [hj, Function.update_self, ite_eq_left ⟨by omega, by omega⟩] + rfl + Β· rw [Function.update_of_ne hj, ih] + by_cases hc : 1 ≀ j ∧ j ≀ H + Β· rw [ite_eq_left hc, ite_eq_left ⟨hc.1, by omega⟩] + Β· have hc' : Β¬(1 ≀ j ∧ j ≀ H + 1) := by + rintro ⟨h1, h2⟩ + exact hc ⟨h1, by omega⟩ + rw [ite_eq_right hc, ite_eq_right hc'] + +/-- The canonical blank tape's cells, spelled out. -/ +theorem initNil_cells (j : β„•) : + (Tape.init ([] : List Ξ“)).cells j = if j = 0 then Ξ“.start else Ξ“.blank := by + cases j with + | zero => exact Tape.init_cells_zero [] + | succ i => rw [Tape.init_cells_ge [] i (by simp), ite_eq_right (Nat.succ_ne_zero i)] + +/-- **Wiping really blanks the tape.** A tape parked at cell `1` whose content +is confined to cells `1 … H` becomes literally the blank tape (head at `H + 1`) +after `H` wipe steps β€” this is where the content-agnostic wipe pays off: no +assumption is made about *where* inside `1 … H` the nonblank cells sit. -/ +theorem wipedTape_eq_blank {t : Tape} (H : β„•) (hh : t.head = 1) + (h0 : t.cells 0 = Ξ“.start) (hfar : βˆ€ j, H < j β†’ t.cells j = Ξ“.blank) : + wipedTape t H = (⟨H + 1, (Tape.init ([] : List Ξ“)).cells⟩ : Tape) := by + refine Tape.ext (by rw [wipedTape_head, hh]; show 1 + H = H + 1; omega) (funext fun j => ?_) + rw [wipedTape_cells_of_head_one hh, initNil_cells] + by_cases hj0 : j = 0 + Β· rw [hj0, ite_eq_right (by omega : Β¬(1 ≀ 0 ∧ 0 ≀ H)), ite_eq_left rfl, h0] + Β· rw [ite_eq_right hj0] + by_cases hc : 1 ≀ j ∧ j ≀ H + Β· rw [ite_eq_left hc] + Β· rw [ite_eq_right hc, hfar j (by omega)] + +/-- Wiping preserves `Parked`-ness: the head only advances, and every +written or untouched cell beyond the marker stays off `β–·`. -/ +theorem wipedTape_parked {t : Tape} (h : Parked t) (i : β„•) : Parked (wipedTape t i) := by + induction i with + | zero => exact h + | succ i ih => + rw [wipedTape_succ] + have hheq : (wipedTape t i).writeAndMove Ξ“w.blank.toΞ“ Dir3.right = + ((wipedTape t i).write Ξ“w.blank.toΞ“).move Dir3.right := rfl + have hhead_ne : (wipedTape t i).head β‰  0 := by + have := ih.1; omega + refine ⟨?_, fun j hj => ?_⟩ + Β· rw [hheq] + show 1 ≀ ((wipedTape t i).write Ξ“w.blank.toΞ“).head + 1 + omega + Β· rw [hheq, Tape.move_cells] + simp only [Tape.write, ite_eq_right hhead_ne] + show Function.update (wipedTape t i).cells (wipedTape t i).head Ξ“w.blank.toΞ“ j β‰  Ξ“.start + by_cases hje : j = (wipedTape t i).head + Β· rw [hje, Function.update_self]; decide + Β· rw [Function.update_of_ne hje]; exact ih.2 j hj + +/-- A fresh output tape (`(Tape.init []).move Dir3.right`) is `Parked`. -/ +theorem parked_parkedBlank : Parked ((Tape.init []).move Dir3.right) := by + refine ⟨le_refl 1, fun j hj => ?_⟩ + rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + decide + +/-- A fresh output tape satisfies the empty output accumulator. -/ +theorem outAcc_nil_of_parkedBlank : + OutAcc [] ((Tape.init []).move Dir3.right) := by + refine ⟨rfl, ?_, nofun, fun j hj => ?_⟩ + Β· rw [Tape.move_cells]; exact Tape.init_cells_zero [] + Β· rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + +/-- The only tape satisfying the empty output accumulator is the fresh +parked blank tape. -/ +theorem eq_parkedBlank_of_outAcc_nil {t : Tape} (h : OutAcc [] t) : + t = (Tape.init []).move Dir3.right := by + obtain ⟨hhead, hcell0, -, htail⟩ := h + refine Tape.ext ?_ ?_ + Β· rw [hhead]; rfl + Β· rw [Tape.move_cells] + funext j + rcases Nat.eq_zero_or_pos j with hj0 | hj1 + Β· subst hj0; rw [hcell0, Tape.init_cells_zero] + Β· rw [htail j (by simpa using! hj1), show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + +/-- The register-shaped tape at iteration `i` is `Parked`. -/ +theorem regIterCells_parked (v i : β„•) : Parked (⟨i + 2, regCells v⟩ : Tape) := by + refine ⟨show 1 ≀ i + 2 by omega, fun j _ => ?_⟩ + show regCells v j β‰  Ξ“.start + simp only [regCells] + split + Β· omega + Β· split <;> decide + +/-- **The wipe loop.** Fueled by a register at `r` holding `v` marks (`r` +disjoint from `targets`), `forRegTM (wipeStepTM targets) r` blanks the leading +`v` cells of every tape in `targets`, leaving every other tape β€” including the +fuel register itself β€” exactly as it was. -/ +theorem wipeLoop_hoareTime {n : β„•} (targets : List (Fin n)) (r : Fin n) + (hr : r βˆ‰ targets) (v : β„•) (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) + (hinpβ‚€ : Parked inpβ‚€) + (hother : βˆ€ j, j β‰  r β†’ Parked (workβ‚€ j)) : + (forRegTM (wipeStepTM targets) r).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update workβ‚€ r (regTape v) ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update + (fun j => if j ∈ targets then wipedTape (workβ‚€ j) v else workβ‚€ j) r (regTape v) ∧ + out = (Tape.init []).move Dir3.right) + (v * 3 + (v + 2)) := by + set w : β„• β†’ Fin n β†’ Tape := fun i j => + if j = r then regTape v else if j ∈ targets then wipedTape (workβ‚€ j) i else workβ‚€ j + with hw + have hw0 : w 0 = Function.update workβ‚€ r (regTape v) := by + funext j + by_cases hjr : j = r + Β· subst hjr; simp [hw, Function.update_self] + Β· rw [Function.update_of_ne hjr] + simp only [hw, ite_eq_right hjr] + split + Β· rfl + Β· rfl + have hwv : w v = Function.update + (fun j => if j ∈ targets then wipedTape (workβ‚€ j) v else workβ‚€ j) r (regTape v) := by + funext j + by_cases hjr : j = r + Β· subst hjr; simp [hw, Function.update_self] + Β· rw [Function.update_of_ne hjr]; simp [hw, ite_eq_right hjr] + have hwork_parked : βˆ€ i j, j β‰  r β†’ Parked (w i j) := by + intro i j hjr + by_cases hjt : j ∈ targets + Β· simp only [hw, ite_eq_right hjr, ite_eq_left hjt] + exact wipedTape_parked (hother j hjr) i + Β· simp only [hw, ite_eq_right hjr, ite_eq_right hjt] + exact hother j hjr + have hbody : βˆ€ i, i < v β†’ (wipeStepTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w i) r (⟨i + 2, regCells v⟩ : Tape) ∧ OutAcc [] out) + (fun inp work out => inp = inpβ‚€ ∧ + work = Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) ∧ OutAcc [] out) + 1 := by + intro i _ + set W : Fin n β†’ Tape := Function.update (w i) r (⟨i + 2, regCells v⟩ : Tape) with hW + have hcopy := wipeStepTM_hoareTime targets inpβ‚€ W ((Tape.init []).move Dir3.right) + hinpβ‚€ parked_parkedBlank + (fun k _ => by + by_cases hkr : k = r + Β· subst hkr; rw [hW, Function.update_self]; exact regIterCells_parked v i + Β· rw [hW, Function.update_of_ne hkr]; exact hwork_parked i k hkr) + refine (hcopy.weaken_pre ?_).strengthen_post ?_ + Β· rintro inp work out ⟨rfl, rfl, hout⟩ + exact ⟨rfl, rfl, eq_parkedBlank_of_outAcc_nil hout⟩ + Β· rintro inp work out ⟨rfl, hout, hwork⟩ + refine ⟨rfl, ?_, hout β–Έ outAcc_nil_of_parkedBlank⟩ + funext j + rw [hwork j] + by_cases hjr : j = r + Β· subst hjr + rw [ite_eq_right hr, hW, Function.update_self, Function.update_self] + Β· by_cases hjt : j ∈ targets + Β· rw [ite_eq_left hjt] + have hWj : W j = wipedTape (workβ‚€ j) i := by + rw [hW, Function.update_of_ne hjr, hw]; simp [ite_eq_right hjr, ite_eq_left hjt] + have hRj : Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) j = + wipedTape (workβ‚€ j) (i + 1) := by + rw [Function.update_of_ne hjr, hw]; simp [ite_eq_right hjr, ite_eq_left hjt] + rw [hWj, hRj, wipedTape_succ] + Β· rw [ite_eq_right hjt] + have hWj : W j = workβ‚€ j := by + rw [hW, Function.update_of_ne hjr, hw]; simp [ite_eq_right hjr, ite_eq_right hjt] + have hRj : Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) j = workβ‚€ j := by + rw [Function.update_of_ne hjr, hw]; simp [ite_eq_right hjr, ite_eq_right hjt] + rw [hWj, hRj] + have key := forRegTM_hoareTime (wipeStepTM targets) r v inpβ‚€ w (fun _ => []) 1 hinpβ‚€ + (fun i => by simp [hw]) hwork_parked hbody + refine key.consequence + (fun inp work out ⟨h1, h2, h3⟩ => ⟨h1, by rw [h2, hw0], h3 β–Έ outAcc_nil_of_parkedBlank⟩) + (fun inp work out ⟨h1, h2, h3⟩ => ⟨h1, by rw [h2, hwv], (eq_parkedBlank_of_outAcc_nil h3)⟩) + (by omega) + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean new file mode 100644 index 0000000000..77621e97f0 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Frame + +/-! +# An unconditional, content-agnostic wipe step + +Reusing an opaque machine's scratch tapes across calls needs them genuinely +blank in between, but an arbitrary machine may leave *gaps* β€” an isolated blank +cell with more content beyond it β€” and a content-driven scanner +(`TM.blankWorkTM` stops at the first blank) under-wipes there. `TM.wipeStepTM` +writes `Ξ“.blank` to every targeted tape and advances, unconditionally, never +reading what it overwrites; iterated a known number of times it blanks an exact +number of cells whatever was there. + +## Main results + +- `TM.wipeStepTM` β€” blank one cell of every targeted tape and advance +- `TM.wipeStepTM_hoareTime` β€” its one-step contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Control states of the unconditional wipe-step machine. -/ +inductive WipeStepPhase where + /-- Write blank to every targeted tape and advance; then halt. -/ + | running + /-- Halted. -/ + | done + deriving DecidableEq + +instance instFintypeWipeStepPhase : Fintype WipeStepPhase where + elems := {.running, .done} + complete := fun p => by cases p <;> simp + +/-- One unconditional step: every work tape named in `targets` is written +`Ξ“.blank` and its head advances right; every other work tape, the input, and +the output are held by `readBackWrite`/`idleDir`. Does not inspect the +targeted tapes' contents at all. -/ +def wipeStepTM {n : β„•} (targets : List (Fin n)) : TM n where + Q := WipeStepPhase + qstart := .running + qhalt := .done + Ξ΄ := fun state iHead wHeads oHead => + match state with + | .running => + (.done, + fun i => if i ∈ targets then Ξ“w.blank else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i ∈ targets then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + Ξ΄_right_of_start := by + intro state iHead wHeads oHead + match state with + | .running => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + Β· rfl + Β· exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **`wipeStepTM`'s exact one-step Hoare contract.** From tapes where every +non-targeted work tape, the input, and the output are `Parked`, one step +unconditionally blanks and advances every targeted work tape and preserves +everything else exactly. -/ +theorem wipeStepTM_hoareTime {n : β„•} (targets : List (Fin n)) + (inpβ‚€ : Tape) (workβ‚€ : Fin n β†’ Tape) (outβ‚€ : Tape) + (hinp : Parked inpβ‚€) (hout : Parked outβ‚€) + (hother : βˆ€ i, i βˆ‰ targets β†’ Parked (workβ‚€ i)) : + (wipeStepTM targets).HoareTime + (fun inp work out => inp = inpβ‚€ ∧ work = workβ‚€ ∧ out = outβ‚€) + (fun inp work out => inp = inpβ‚€ ∧ out = outβ‚€ ∧ + βˆ€ i, work i = if i ∈ targets then (workβ‚€ i).writeAndMove Ξ“w.blank.toΞ“ Dir3.right + else workβ‚€ i) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨(⟨WipeStepPhase.done, + inp.move (idleDir inp.read), + (fun i => if i ∈ targets then (work i).writeAndMove Ξ“w.blank.toΞ“ Dir3.right + else (work i).writeAndMove (readBackWrite (work i).read) (idleDir (work i).read)), + out.writeAndMove (readBackWrite out.read) (idleDir out.read)⟩ : + Cfg n (wipeStepTM targets).Q), + 1, le_refl 1, ?_, rfl, hinp.move_idle, hout.writeAndMove_readBack_idle, fun i => ?_⟩ + Β· refine TM.reachesIn.step ?_ .zero + simp only [TM.step, wipeStepTM, + ite_eq_right (show WipeStepPhase.running β‰  WipeStepPhase.done by decide)] + congr 1 + congr 1 + funext i + split <;> rfl + Β· dsimp only + split + Β· rfl + Β· next hi => exact (hother i hi).writeAndMove_readBack_idle + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape.lean new file mode 100644 index 0000000000..b1f521ed3f --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape/Encoding.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape/Encoding.lean new file mode 100644 index 0000000000..de229811df --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/Tape/Encoding.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine + +/-! +# Binary string encodings on Turing-machine tapes + +Generic predicates and lemmas for tapes containing canonical binary strings. +`Tape.HasBinaryPrefix` describes a string being written from left to right, +`Tape.HasBinaryString` describes the same contents after rewinding the head to +cell one, `Tape.HasBinaryContent` forgets the head while an in-place arithmetic +cursor moves, and `Tape.HasBinarySuffix` describes a read cursor at the +beginning of a remaining suffix. These shapes are shared by deterministic and +nondeterministic machine constructions. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Tape + +/-- A tape while a binary string is being written: cells `1..|bits|` contain + the bits, the head is at the next cell, and the remaining tail is blank. -/ +def HasBinaryPrefix (t : Tape) (bits : List Bool) : Prop := + t.head = bits.length + 1 ∧ + (βˆ€ i, (h : i < bits.length) β†’ t.cells (i + 1) = Ξ“.ofBool (bits[i]'h)) ∧ + (βˆ€ i, bits.length ≀ i β†’ t.cells (i + 1) = Ξ“.blank) + +/-- A completed binary string: the bits are present and the head has been + rewound to cell one. -/ +def HasBinaryString (t : Tape) (bits : List Bool) : Prop := + t.head = 1 ∧ + (βˆ€ i, (h : i < bits.length) β†’ t.cells (i + 1) = Ξ“.ofBool (bits[i]'h)) ∧ + (βˆ€ i, bits.length ≀ i β†’ t.cells (i + 1) = Ξ“.blank) + +/-- Canonical binary contents independently of the tape head. This is the +stable invariant for in-place arithmetic cursors that scan and rewind. -/ +def HasBinaryContent (t : Tape) (bits : List Bool) : Prop := + (βˆ€ i, (h : i < bits.length) β†’ t.cells (i + 1) = Ξ“.ofBool (bits[i]'h)) ∧ + βˆ€ i, bits.length ≀ i β†’ t.cells (i + 1) = Ξ“.blank + +/-- A read cursor at the beginning of a remaining binary suffix. The suffix +starts under the current off-marker head, is followed immediately by blank, +and the tape has no stray left markers. -/ +def HasBinarySuffix (t : Tape) (bits : List Bool) : Prop := + t.head β‰₯ 1 ∧ + (βˆ€ i, (h : i < bits.length) β†’ + t.cells (t.head + i) = Ξ“.ofBool (bits[i]'h)) ∧ + t.cells (t.head + bits.length) = Ξ“.blank ∧ + (βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start) + +/-- A completed binary string whose length is at most `B`. -/ +def HasBoundedBinaryString (t : Tape) (B : β„•) : Prop := + βˆƒ bits : List Bool, bits.length ≀ B ∧ t.HasBinaryString bits + +/-- A completed binary string has the same canonical contents after forgetting +its parked head. -/ +theorem HasBinaryString.hasBinaryContent {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : t.HasBinaryContent bits := + h.2 + +/-- Canonical contents become a completed binary string when the head is at +cell one. -/ +theorem HasBinaryContent.hasBinaryString {t : Tape} {bits : List Bool} + (h : t.HasBinaryContent bits) (hhead : t.head = 1) : + t.HasBinaryString bits := + ⟨hhead, h⟩ + +/-- Moving a cursor preserves its canonical binary contents. -/ +theorem HasBinaryContent.move {t : Tape} {bits : List Bool} + (h : t.HasBinaryContent bits) (dir : Dir3) : + (t.move dir).HasBinaryContent bits := by + simpa only [HasBinaryContent, Tape.move_cells] using h + +/-- Canonical binary contents contain no stray left marker after cell zero. -/ +theorem HasBinaryContent.cells_ne_start {t : Tape} {bits : List Bool} + (h : t.HasBinaryContent bits) : + βˆ€ j, 1 ≀ j β†’ t.cells j β‰  Ξ“.start := by + intro j hj + let i := j - 1 + have hji : j = i + 1 := by omega + by_cases hi : i < bits.length + Β· rw [hji, h.1 i hi] + exact Ξ“.ofBool_ne_start _ + Β· rw [hji, h.2 i (Nat.le_of_not_gt hi)] + decide + +/-- Overwriting one in-range binary cell preserves canonical contents and +updates exactly that bit. -/ +theorem HasBinaryContent.write_set {t : Tape} {bits : List Bool} + {i : β„•} (bit : Bool) (h : t.HasBinaryContent bits) + (hhead : t.head = i + 1) (hi : i < bits.length) : + (t.write (Ξ“.ofBool bit)).HasBinaryContent (bits.set i bit) := by + rcases h with ⟨hbits, htail⟩ + have hhead0 : Β¬t.head = 0 := by omega + constructor + Β· intro j hj + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [List.length_set] at hj + rw [hhead] + by_cases hij : i = j + Β· subst j + rw [Function.update_self, List.getElem_set] + simp + Β· have hne : i + 1 β‰  j + 1 := by omega + rw [Function.update_of_ne (Ne.symm hne), hbits j hj, + List.getElem_set] + simp [hij] + Β· intro j hj + rw [Tape.write, ite_eq_right hhead0] + simp only + rw [List.length_set] at hj + rw [hhead] + have hne : i + 1 β‰  j + 1 := by omega + rw [Function.update_of_ne (Ne.symm hne)] + exact htail j hj + +/-- Writing away from cell zero and then moving preserves the left marker. -/ +theorem write_move_cell0 {t : Tape} (symbol : Ξ“) (dir : Dir3) + (h0 : t.cells 0 = Ξ“.start) : + ((t.write symbol).move dir).cells 0 = Ξ“.start := by + rw [Tape.move_cells, Tape.write] + split + Β· exact h0 + Β· simp only + rw [Function.update_of_ne (by omega)] + exact h0 + +/-- A completed binary tape encodes exactly `bits` as its output string. -/ +theorem hasOutput_of_hasBinaryString {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : t.HasOutput bits := + ⟨h.2.1, h.2.2 bits.length le_rfl⟩ + +/-- A completed binary tape never contains `β–·` after the left-end marker. -/ +theorem cells_ne_start_of_hasBinaryString {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : + βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start := by + intro j hj + let i := j - 1 + have hj_eq : j = i + 1 := by omega + by_cases hi : i < bits.length + Β· rw [hj_eq, h.2.1 i hi] + cases bits[i]'hi <;> simp [Ξ“.ofBool] + Β· have hge : bits.length ≀ i := by omega + rw [hj_eq, h.2.2 i hge] + decide + +/-- A completed binary tape with the left marker at cell `0` is exactly the + standard initialized tape for those bits, moved to cell `1`. -/ +theorem eq_init_move_right_of_hasBinaryString {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) (h0 : t.cells 0 = Ξ“.start) : + t = (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right := by + cases t with + | mk head cells => + simp only [HasBinaryString] at h + rcases h with ⟨hhead, hbits, htail⟩ + simp only at h0 hbits htail + subst head + simp only [Tape.move] + congr + funext j + by_cases hj0 : j = 0 + Β· subst hj0 + simp [Tape.init, h0] + Β· let i := j - 1 + have hj : j = i + 1 := by omega + rw [hj] + by_cases hi : i < bits.length + Β· rw [hbits i hi, Tape.init_ofBool_cells_lt bits i hi] + Β· have hge : bits.length ≀ i := by omega + rw [htail i hge, Tape.init_ofBool_cells_ge bits i hge] + +/-- A binary prefix with the left marker at cell zero has exactly the +canonical initialized cell contents, independently of its current head. -/ +theorem HasBinaryPrefix.cells_eq_init {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) (h0 : t.cells 0 = Ξ“.start) : + t.cells = (Tape.init (bits.map Ξ“.ofBool)).cells := by + funext j + cases j with + | zero => simpa using h0 + | succ i => + by_cases hi : i < bits.length + Β· rw [h.2.1 i hi, Tape.init_ofBool_cells_lt bits i hi] + Β· have hge : bits.length ≀ i := by omega + rw [h.2.2 i hge, Tape.init_ofBool_cells_ge bits i hge] + +/-- Bounded completed binary tapes expose exact initialized tape shape for + some string whose length satisfies the same bound. -/ +theorem exists_eq_init_move_right_of_hasBoundedBinaryString {t : Tape} {B : β„•} + (h : t.HasBoundedBinaryString B) (h0 : t.cells 0 = Ξ“.start) : + βˆƒ bits : List Bool, bits.length ≀ B ∧ + t = (Tape.init (bits.map Ξ“.ofBool)).move Dir3.right := by + obtain ⟨bits, hlen, hbits⟩ := h + exact ⟨bits, hlen, eq_init_move_right_of_hasBinaryString hbits h0⟩ + +/-- A freshly initialized empty tape, moved right past `β–·`, is an empty + binary prefix. -/ +theorem init_nil_move_right_hasBinaryPrefix_nil : + ((Tape.init []).move Dir3.right).HasBinaryPrefix [] := by + simp [HasBinaryPrefix, Tape.init, Tape.move] + +/-- A standard initialized binary tape moved right to its first data cell is +a completed binary string. -/ +theorem init_move_right_hasBinaryString (bits : List Bool) : + ((Tape.init (bits.map Ξ“.ofBool)).move Dir3.right).HasBinaryString bits := by + refine ⟨by simp [Tape.move], ?_, ?_⟩ + Β· intro i hi + exact Tape.init_ofBool_cells_lt bits i hi + Β· intro i hi + exact Tape.init_ofBool_cells_ge bits i hi + +/-- The head of an appendable binary prefix reads its first trailing blank. -/ +theorem HasBinaryPrefix.read_blank {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : t.read = Ξ“.blank := by + rw [Tape.read, h.1] + exact h.2.2 bits.length le_rfl + +/-- An appendable binary prefix already contains the advertised delimited +output, independently of its current head. -/ +theorem HasBinaryPrefix.hasOutput {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : t.HasOutput bits := + ⟨h.2.1, h.2.2 bits.length le_rfl⟩ + +/-- A freshly initialized binary tape starts with its whole string as the +remaining suffix. -/ +theorem init_move_right_hasBinarySuffix (bits : List Bool) : + ((Tape.init (bits.map Ξ“.ofBool)).move Dir3.right).HasBinarySuffix bits := by + refine ⟨by simp [Tape.move, Tape.init], ?_, ?_, ?_⟩ + Β· intro i hi + simpa [Tape.move, Tape.init, Nat.add_comm] using + Tape.init_ofBool_cells_lt bits i hi + Β· simp [Tape.move, Tape.init, Nat.add_comm] + Β· intro j hj + simp [Tape.move] + exact Tape.init_ofBool_cells_ne_start bits j hj + +/-- A completed binary string exposes the same bits as its remaining suffix. -/ +theorem HasBinaryString.hasBinarySuffix {t : Tape} {bits : List Bool} + (h : t.HasBinaryString bits) : t.HasBinarySuffix bits := by + refine ⟨by rw [h.1], ?_, ?_, cells_ne_start_of_hasBinaryString h⟩ + Β· intro i hi + rw [h.1] + simpa [Nat.add_comm] using h.2.1 i hi + Β· rw [h.1] + simpa [Nat.add_comm] using h.2.2 bits.length le_rfl + +/-- A delimited output parked at cell one is a binary suffix cursor when the +tape has no stray left-end markers. -/ +theorem HasOutput.hasBinarySuffix {t : Tape} {bits : List Bool} + (h : t.HasOutput bits) (hhead : t.head = 1) (hinv : t.StartInvariant) : + t.HasBinarySuffix bits := by + refine ⟨by rw [hhead], ?_, ?_, hinv.2⟩ + Β· intro i hi + simpa [hhead, Nat.add_comm] using h.1 i hi + Β· simpa [hhead, Nat.add_comm] using h.2 + +/-- The first symbol of a nonempty binary suffix is under the tape head. -/ +theorem HasBinarySuffix.read_cons {t : Tape} {bit : Bool} {bits : List Bool} + (h : t.HasBinarySuffix (bit :: bits)) : + t.read = Ξ“.ofBool bit := by + have hzero := h.2.1 0 (by simp) + simpa [Tape.read] using hzero + +/-- Moving right after reading the first bit exposes the remaining suffix. -/ +theorem HasBinarySuffix.move_right_cons {t : Tape} {bit : Bool} + {bits : List Bool} (h : t.HasBinarySuffix (bit :: bits)) : + (t.move Dir3.right).HasBinarySuffix bits := by + refine ⟨by simp [Tape.move], ?_, ?_, ?_⟩ + Β· intro i hi + have hcell := h.2.1 (i + 1) (by simpa using hi) + simpa [Tape.move, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hcell + Β· have hcell := h.2.2.1 + simpa [Tape.move, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hcell + Β· intro j hj + simpa [Tape.move_cells] using h.2.2.2 j hj + +/-- An empty remaining suffix reads the terminating blank. -/ +theorem HasBinarySuffix.read_nil {t : Tape} (h : t.HasBinarySuffix []) : + t.read = Ξ“.blank := by + simpa [Tape.read] using h.2.2.1 + +/-- A binary suffix cursor never reads the left-end marker. -/ +theorem HasBinarySuffix.read_ne_start {t : Tape} {bits : List Bool} + (h : t.HasBinarySuffix bits) : t.read β‰  Ξ“.start := + h.2.2.2 t.head h.1 + +/-- Writing the next bit extends a binary prefix by one cell. -/ +theorem hasBinaryPrefix_write_bit {t : Tape} {bits : List Bool} (bit : Bool) + (h : t.HasBinaryPrefix bits) : + (t.writeAndMove (Ξ“.ofBool bit) Dir3.right).HasBinaryPrefix (bits ++ [bit]) := by + refine ⟨?_, ?_, ?_⟩ + Β· simp [Tape.writeAndMove, Tape.write, Tape.move, h.1] + Β· intro i hi + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + by_cases hidx : i = bits.length + Β· have hcellidx : i + 1 = t.head := by rw [h.1, hidx] + have hget : (bits ++ [bit])[i]'hi = bit := by + subst hidx + simp + rw [hcellidx, Function.update_self, hget] + Β· have hi_bits : i < bits.length := by + rw [List.length_append, List.length_singleton] at hi + omega + have hcell := h.2.1 i hi_bits + have hget : (bits ++ [bit])[i]'hi = bits[i]'hi_bits := by + exact List.getElem_append_left (as := bits) (bs := [bit]) hi_bits + have hne : t.head β‰  i + 1 := by rw [h.1]; omega + rw [Function.update_of_ne (Ne.symm hne), hcell, hget] + Β· intro i hi + unfold Tape.writeAndMove + simp only [Tape.move] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  i + 1 := by + rw [List.length_append, List.length_singleton] at hi + rw [h.1] + omega + rw [Function.update_of_ne (Ne.symm hne)] + exact h.2.2 i (by + rw [List.length_append, List.length_singleton] at hi + omega) + +/-- Writing at the first blank appends one canonical binary cell. -/ +theorem HasBinaryContent.write_append {t : Tape} {bits : List Bool} + (bit : Bool) (h : t.HasBinaryContent bits) + (hhead : t.head = bits.length + 1) : + (t.write (Ξ“.ofBool bit)).HasBinaryContent (bits ++ [bit]) := by + have hprefix : t.HasBinaryPrefix bits := ⟨hhead, h⟩ + exact (hasBinaryPrefix_write_bit bit hprefix).2 + +/-- Writing the next bit preserves the left-end marker cell. -/ +theorem hasBinaryPrefix_write_bit_cell0 {t : Tape} {bits : List Bool} (bit : Bool) + (h : t.HasBinaryPrefix bits) (h0 : t.cells 0 = Ξ“.start) : + (t.writeAndMove (Ξ“.ofBool bit) Dir3.right).cells 0 = Ξ“.start := by + unfold Tape.writeAndMove + rw [Tape.move_cells] + unfold Tape.write + have hhead_ne : Β¬t.head = 0 := by rw [h.1]; omega + simp only [hhead_ne, ↓reduceIte] + have hne : t.head β‰  0 := by rw [h.1]; omega + rw [Function.update_of_ne (Ne.symm hne)] + exact h0 + +/-- A binary prefix never contains `β–·` after the left-end marker. -/ +theorem cells_ne_start_of_hasBinaryPrefix {t : Tape} {bits : List Bool} + (h : t.HasBinaryPrefix bits) : + βˆ€ j, j β‰₯ 1 β†’ t.cells j β‰  Ξ“.start := by + intro j hj + let i := j - 1 + have hj_eq : j = i + 1 := by omega + by_cases hi : i < bits.length + Β· rw [hj_eq, h.2.1 i hi] + cases bits[i]'hi <;> simp [Ξ“.ofBool] + Β· have hge : bits.length ≀ i := by omega + rw [hj_eq, h.2.2 i hge] + decide + +/-- Moving a completed binary string's head to the first blank, without + changing its cells, yields the corresponding appendable prefix. -/ +theorem hasBinaryPrefix_of_hasBinaryString {t t' : Tape} {bits : List Bool} + (hstring : t.HasBinaryString bits) + (hhead : t'.head = bits.length + 1) + (hcells : t'.cells = t.cells) : + t'.HasBinaryPrefix bits := by + refine ⟨hhead, ?_, ?_⟩ + Β· intro i hi + rw [hcells] + exact hstring.2.1 i hi + Β· intro i hi + rw [hcells] + exact hstring.2.2 i hi + +/-- Rewinding a binary prefix to cell one yields a completed binary string. -/ +theorem hasBinaryString_of_hasBinaryPrefix {t t' : Tape} {bits : List Bool} + (hprefix : t.HasBinaryPrefix bits) + (hhead : t'.head = 1) + (hcells : t'.cells = t.cells) : + t'.HasBinaryString bits := by + refine ⟨hhead, ?_, ?_⟩ + Β· intro i hi + rw [hcells] + exact hprefix.2.1 i hi + Β· intro i hi + rw [hcells] + exact hprefix.2.2 i hi + +end Tape + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/WorkReadOnly.lean b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/WorkReadOnly.lean new file mode 100644 index 0000000000..64dbc00a7d --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/Models/TuringMachine/WorkReadOnly.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# Read-only work-tape certificates + +`TM.WorkReadOnly tm idx` records the local syntactic fact that every transition +of `tm` writes the symbol already read on work tape `idx`. The head may move, +but valid tape contents are preserved through every finite run. +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Every transition writes back the symbol read on the selected work tape. -/ +def WorkReadOnly (tm : TM n) (idx : Fin n) : Prop := + βˆ€ state inputHead workHeads outputHead, + state β‰  tm.qhalt β†’ + (tm.Ξ΄ state inputHead workHeads outputHead).2.1 idx = + readBackWrite (workHeads idx) + +/-- A read-only transition preserves all cells of a valid selected tape. -/ +theorem WorkReadOnly.cells_eq_of_step {tm : TM n} {idx : Fin n} + (hreadonly : tm.WorkReadOnly idx) {c c' : Cfg n tm.Q} + (hstep : tm.step c = some c') + (hnostart : βˆ€ j, 1 ≀ j β†’ (c.work idx).cells j β‰  Ξ“.start) : + (c'.work idx).cells = (c.work idx).cells := by + have hne := state_ne_qhalt_of_step hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst c' + change + ((c.work idx).writeAndMove + ((tm.Ξ΄ c.state c.input.read (fun i => (c.work i).read) + c.output.read).2.1 idx).toΞ“ + ((tm.Ξ΄ c.state c.input.read (fun i => (c.work i).read) + c.output.read).2.2.2.2.1 idx)).cells = (c.work idx).cells + rw [hreadonly _ _ _ _ hne] + apply tape_readBackWrite_preserves + by_cases hhead : (c.work idx).head = 0 + Β· exact Or.inl hhead + Β· exact Or.inr (by + apply hnostart + omega) + +/-- A read-only work tape retains its complete cell function through an exact +finite run. -/ +theorem WorkReadOnly.cells_eq_of_reachesIn {tm : TM n} {idx : Fin n} + (hreadonly : tm.WorkReadOnly idx) {time : β„•} {start final : Cfg n tm.Q} + (hreach : tm.reachesIn time start final) + (hnostart : βˆ€ j, 1 ≀ j β†’ (start.work idx).cells j β‰  Ξ“.start) : + (final.work idx).cells = (start.work idx).cells := by + induction hreach with + | zero => rfl + | step hstep _ ih => + have hcells := hreadonly.cells_eq_of_step hstep hnostart + apply Eq.trans (ih ?_) hcells + intro j hj + rw [hcells] + exact hnostart j hj + +/-- Sequential composition preserves a shared read-only work tape. -/ +theorem WorkReadOnly.seqTM {first second : TM n} {idx : Fin n} + (hfirst : first.WorkReadOnly idx) + (hsecond : second.WorkReadOnly idx) : + (seqTM first second).WorkReadOnly idx := by + intro state inputHead workHeads outputHead hstate + cases state with + | inl state => + unfold Complexity.TM.seqTM + dsimp only + split + Β· rfl + Β· next hne => exact hfirst state inputHead workHeads outputHead hne + | inr state => + unfold Complexity.TM.seqTM + dsimp only + split + Β· next heq => + subst state + exact (hstate rfl).elim + Β· next hne => exact hsecond state inputHead workHeads outputHead hne + +end TM + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT.lean b/LeanPool/BeyondBethe/Complexitylib/SAT.lean new file mode 100644 index 0000000000..35f8646d48 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.Complexitylib.SAT.Encoding +public import LeanPool.BeyondBethe.Complexitylib.SAT.Language +public import LeanPool.BeyondBethe.Complexitylib.SAT.Rename +public import LeanPool.BeyondBethe.Complexitylib.SAT.Semantics +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeCNF +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT +public import LeanPool.BeyondBethe.Complexitylib.SAT.Verifier + +/-! Supporting modules for Beyond the Bethe approximation of the permanent. -/ + +@[expose] public section diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/Encoding.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/Encoding.lean new file mode 100644 index 0000000000..e342a817f5 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/Encoding.lean @@ -0,0 +1,299 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.Semantics +public import Mathlib.Tactic.Ring.RingNF +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# SAT: Encoding Layer + +This file pins down how CNFs and literals are written as `List Bool`, which +is the bit-string format that the TM verifier will actually parse. + +## Format summary + +``` + data bit b ↦ [b, b] (doubled) + literal separator "|" ↦ [false, true] (one undoubled pair) + clause separator "#" ↦ [true, false] (one undoubled pair) +``` + +- A variable index `v : β„•` is encoded **in unary** as `replicate v true` β€” + that is, `v` consecutive `1`-bits. `Unary.encode 0 = []`. + Unary is chosen (over binary) so that `|encode v| β‰₯ v`, which makes + `maxVar Ο† ≀ |Ο†.encode|` automatic. This is what powers the + `PolyBalanced` step in the NP-membership proof. +- A literal `(sign, var)` is encoded as `[sign] ++ Unary.encode var` β€” + call this the *raw* literal encoding (a list of single bits). +- A clause is a list of raw-encoded literals, each *doubled* bit-by-bit, + separated (and terminated) by `|`. An empty clause is the empty list. +- A CNF is a list of encoded clauses, each terminated by `#`. An empty + CNF is the empty list. + +Inside a clause, every bit is doubled, so the only pairs that appear are +`00`, `11` (data), `01` (lit sep), `10` (clause sep). The four patterns +cover all four two-bit combinations and are mutually exclusive, giving a +well-defined token stream for any valid encoding. + +## Why this format + +- `|` and `#` can't collide with data because all data bits are doubled. +- No length prefixes β€” parsing is a single pass over the input. +- Unary variables give `|encodeRaw β„“| = β„“.var + 1`, which propagates to + `maxVar Ο† ≀ |Ο†.encode|` (key for `PolyBalanced`). +- Distinguishes `[]` (true CNF) from `[[]]` (one unsatisfiable clause): + the former encodes to `[]`, the latter to `[true, false]`. + +The matching executable decoder `CNF.decode?`, its round-trip theorem, and its +soundness theorem live with the token parser in `Complexitylib.SAT.Verifier`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +-- ════════════════════════════════════════════════════════════════════════ +-- Unary encoding of natural numbers (used for variable indices) +-- ════════════════════════════════════════════════════════════════════════ + +namespace Unary + +/-- Unary encoding of `n`: `n` consecutive `true` bits. `encode 0 = []`. -/ +def encode (n : Nat) : List Bool := List.replicate n true + +/-- The unary encoding of `n` has length exactly `n`. -/ +@[simp] theorem length_encode (n : Nat) : (encode n).length = n := by + simp [encode] + +/-- Zero encodes to the empty bit list. -/ +@[simp] theorem encode_zero : encode 0 = [] := rfl + +/-- Every bit in a unary encoding is `true`. -/ +theorem encode_all_true (n : Nat) : βˆ€ b ∈ encode n, b = true := by + intro b hb + simp [encode, List.mem_replicate] at hb + exact hb.2 + +end Unary + +-- ════════════════════════════════════════════════════════════════════════ +-- Literal raw encoding: sign bit + unary var +-- ════════════════════════════════════════════════════════════════════════ + +namespace Lit + +/-- Raw literal encoding: `[sign] ++ unary(var)`. Produces a list of + single (undoubled) bits; the doubling happens at the clause level. -/ +def encodeRaw (β„“ : Lit) : List Bool := β„“.sign :: Unary.encode β„“.var + +/-- The raw literal encoding has length `β„“.var + 1`: one sign bit plus a unary var. -/ +@[simp] theorem encodeRaw_length (β„“ : Lit) : β„“.encodeRaw.length = β„“.var + 1 := by + simp [encodeRaw] + +/-- The raw encoding of a literal has `β„“.var ≀ |encodeRaw| - 1`. Key for + `maxVar ≀ |encode|`. -/ +theorem var_lt_encodeRaw_length (β„“ : Lit) : β„“.var < β„“.encodeRaw.length := by + simp + +/-- The raw literal encoding is injective: sign and var are recoverable. -/ +theorem encodeRaw_injective : Function.Injective Lit.encodeRaw := by + rintro ⟨s₁, vβ‚βŸ© ⟨sβ‚‚, vβ‚‚βŸ© h + have hlen : v₁ + 1 = vβ‚‚ + 1 := by + have := congrArg List.length h + simpa using this + have hvar : v₁ = vβ‚‚ := by omega + subst hvar + have hsign : s₁ = sβ‚‚ := by simpa [encodeRaw] using h + subst hsign + rfl + +end Lit + +-- ════════════════════════════════════════════════════════════════════════ +-- Bit doubling +-- ════════════════════════════════════════════════════════════════════════ + +/-- Double each bit: `b ↦ [b, b]`. The image consists only of `00` and `11` + two-bit patterns, so `01` and `10` cannot appear in doubled data. -/ +def doubleBits (bs : List Bool) : List Bool := bs.flatMap (fun b => [b, b]) + +/-- Doubling the empty bit list yields the empty list. -/ +@[simp] theorem doubleBits_nil : doubleBits [] = [] := rfl + +/-- Doubling a cons prepends the head bit twice: `doubleBits (b :: bs) = b :: b :: …`. -/ +@[simp] theorem doubleBits_cons (b : Bool) (bs : List Bool) : + doubleBits (b :: bs) = b :: b :: doubleBits bs := by + simp [doubleBits] + +/-- Doubling exactly doubles the length: `|doubleBits bs| = 2 * |bs|`. -/ +@[simp] theorem doubleBits_length (bs : List Bool) : + (doubleBits bs).length = 2 * bs.length := by + induction bs with + | nil => rfl + | cons b bs ih => simp [ih]; ring + +-- ════════════════════════════════════════════════════════════════════════ +-- Clause and CNF encoding +-- ════════════════════════════════════════════════════════════════════════ + +namespace Clause + +/-- Encoded clause: each literal's raw bits doubled, followed by `[0,1]`. -/ +def encode : Clause β†’ List Bool + | [] => [] + | β„“ :: β„“s => doubleBits β„“.encodeRaw ++ [false, true] ++ encode β„“s + +/-- The empty clause encodes to the empty bit list. -/ +@[simp] theorem encode_nil : encode ([] : Clause) = [] := rfl + +/-- Unfolding lemma: encoding `β„“ :: β„“s` emits the doubled raw literal, + the `[false, true]` literal separator, then the encoded tail. -/ +theorem encode_cons (β„“ : Lit) (β„“s : Clause) : + encode (β„“ :: β„“s) = doubleBits β„“.encodeRaw ++ [false, true] ++ encode β„“s := rfl + +/-- Length bound on the encoded clause: each literal contributes at most + `2 * |encodeRaw| + 2` bits (doubling + separator). -/ +theorem length_encode (c : Clause) : + c.encode.length = c.foldr (fun β„“ acc => 2 * β„“.encodeRaw.length + 2 + acc) 0 := by + induction c with + | nil => rfl + | cons β„“ β„“s ih => + simp only [encode_cons, List.length_append, List.length_cons, List.length_nil, + doubleBits_length, List.foldr_cons, ih] + +end Clause + +namespace CNF + +/-- Encoded CNF: each clause followed by `[1,0]`. -/ +def encode : CNF β†’ List Bool + | [] => [] + | c :: cs => c.encode ++ [true, false] ++ encode cs + +/-- The empty CNF encodes to the empty bit list. -/ +@[simp] theorem encode_nil : encode ([] : CNF) = [] := rfl + +/-- Unfolding lemma: encoding `c :: cs` emits the encoded clause, the + `[true, false]` clause separator, then the encoded tail. -/ +theorem encode_cons (c : Clause) (cs : CNF) : + encode (c :: cs) = c.encode ++ [true, false] ++ encode cs := rfl + +/-- Length bound: each clause contributes `|c.encode| + 2` bits to the CNF. -/ +theorem length_encode (Ο† : CNF) : + Ο†.encode.length = Ο†.foldr (fun c acc => c.encode.length + 2 + acc) 0 := by + induction Ο† with + | nil => rfl + | cons c cs ih => + simp only [encode_cons, List.length_append, List.length_cons, List.length_nil, ih, + List.foldr_cons] + +/-- `CNF.encode` is a `++`-homomorphism β€” the per-family reduction emitters + compose by output concatenation. -/ +theorem encode_append (Ο† ψ : CNF) : encode (Ο† ++ ψ) = encode Ο† ++ encode ψ := by + induction Ο† with + | nil => rfl + | cons c cs ih => + rw [List.cons_append, encode_cons, encode_cons, ih] + simp [List.append_assoc] + +end CNF + +/-- Doubling a run of `true`s doubles its length. -/ +theorem doubleBits_replicate_true (v : β„•) : + doubleBits (List.replicate v true) = List.replicate (2 * v) true := by + induction v with + | zero => rfl + | succ v ih => + rw [List.replicate_succ, doubleBits_cons, ih, + show 2 * (v + 1) = (2 * v + 1) + 1 from by omega, + List.replicate_succ, List.replicate_succ] + +/-- The encoded form of one literal inside a clause: doubled sign, doubled + unary variable index, separator β€” exactly the word the reduction's + literal emitter appends. -/ +theorem Clause.encode_cons' (β„“ : Lit) (β„“s : Clause) : + Clause.encode (β„“ :: β„“s) + = ([β„“.sign, β„“.sign] ++ List.replicate (2 * β„“.var) true ++ [false, true]) + ++ Clause.encode β„“s := by + rw [Clause.encode_cons, Lit.encodeRaw, Unary.encode, doubleBits_cons, + doubleBits_replicate_true] + simp [List.append_assoc] + +-- ════════════════════════════════════════════════════════════════════════ +-- maxVar ≀ |encode| (the key bound for PolyBalanced) +-- ════════════════════════════════════════════════════════════════════════ +-- +-- With unary variables, each literal `β„“` contributes `2 * (β„“.var + 1)` bits +-- to its doubled block, so `β„“.var ≀ |c.encode|` and hence `c.maxVar ≀ |c.encode|`, +-- and `Ο†.maxVar ≀ |Ο†.encode|`. + +namespace Clause + +/-- Every variable in a clause has index `≀ |c.encode|`. Immediate from unary. -/ +theorem maxVar_le_encode_length (c : Clause) : c.maxVar ≀ c.encode.length := by + induction c with + | nil => simp + | cons β„“ β„“s ih => + simp only [maxVar_cons, encode_cons, List.length_append, List.length_cons, List.length_nil, + doubleBits_length, Lit.encodeRaw_length] + have h_var : β„“.var ≀ 2 * (β„“.var + 1) + 2 + (Clause.encode β„“s).length := by omega + have h_tail : Clause.maxVar β„“s ≀ 2 * (β„“.var + 1) + 2 + (Clause.encode β„“s).length := + le_trans ih (by omega) + exact max_le h_var h_tail + +end Clause + +namespace CNF + +/-- **Key bound for `PolyBalanced`.** Every variable mentioned in `Ο†` has + index at most `|Ο†.encode|`. Hence any satisfying assignment `Ξ±` (with + unused positions truncated) has length at most `|Ο†.encode| + 1`. -/ +theorem maxVar_le_encode_length (Ο† : CNF) : Ο†.maxVar ≀ Ο†.encode.length := by + induction Ο† with + | nil => simp + | cons c cs ih => + simp only [maxVar_cons, encode_cons, List.length_append, List.length_cons, List.length_nil] + have h_c : c.maxVar ≀ c.encode.length + 2 + (CNF.encode cs).length := + le_trans c.maxVar_le_encode_length (by omega) + have h_tail : CNF.maxVar cs ≀ c.encode.length + 2 + (CNF.encode cs).length := + le_trans ih (by omega) + exact max_le h_c h_tail + +end CNF + +-- ════════════════════════════════════════════════════════════════════════ +-- Lemmas about doubled data: only `00` and `11` appear +-- ════════════════════════════════════════════════════════════════════════ + +/-- `doubleBits bs` contains no `[false, true]` or `[true, false]` pair at + an even-index boundary. Concretely: every pair `(b_{2k}, b_{2k+1})` in + `doubleBits bs` has `b_{2k} = b_{2k+1}`. -/ +theorem doubleBits_pair_eq (bs : List Bool) (k : Nat) (h : 2 * k + 1 < (doubleBits bs).length) : + (doubleBits bs)[2 * k]? = (doubleBits bs)[2 * k + 1]? := by + induction bs generalizing k with + | nil => simp at h + | cons b bs ih => + match k with + | 0 => simp [doubleBits_cons] + | k + 1 => + simp only [doubleBits_cons, List.length_cons] at h + have h2 : 2 * k + 1 < (doubleBits bs).length := by omega + have ih' := ih k h2 + show (b :: b :: doubleBits bs)[2 * (k + 1)]? = (b :: b :: doubleBits bs)[2 * (k + 1) + 1]? + have e1 : 2 * (k + 1) = (2 * k) + 2 := by ring + have e2 : 2 * (k + 1) + 1 = (2 * k + 1) + 2 := by ring + rw [e2, e1] + simp only [List.getElem?_cons_succ] + exact ih' + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/Language.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/Language.lean new file mode 100644 index 0000000000..3c9e9871f6 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/Language.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.Encoding +public import LeanPool.BeyondBethe.Complexitylib.Classes.NP.Witness + +/-! +# SAT: Language and Witness Relation + +This file defines the formal SAT language `language` and the NP witness +relation `Witness`, and proves the two core bridge theorems: + +- `mem_language_iff_witness` β€” `z ∈ language ↔ βˆƒ Ξ±, Witness z Ξ±` + (a CNF is satisfiable iff it admits a short satisfying assignment) +- `polyBalanced_witness` β€” witness length is bounded by `|z| + 1` + (satisfying assignments can always be truncated to length `Ο†.maxVar + 1`, + and `Ο†.maxVar ≀ |Ο†.encode|` from the unary encoding) + +These are the semantic and witness-length ingredients used by both routes to +`SAT ∈ NP`. The executable verifier is specified in `SAT/Verifier.lean`, its +polynomial-time TM implementation is proved in `SAT/VerifierTM.lean`, and the +SAT-specialized guess-and-verify construction is assembled into the +unconditional headline theorem in `SAT/Headline.lean`. +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +/-- **The SAT language.** A bitstring `z` is in `language` iff it encodes + some satisfiable CNF formula. + + Note: `encode` is injective on well-formed CNFs, but we don't need + injectivity for any of the downstream theorems β€” we only need + "there exists some `Ο†` …". -/ +def language : Language := {z | βˆƒ Ο† : CNF, z = Ο†.encode ∧ Ο†.Satisfiable} + +/-- **The SAT witness relation.** `Witness z Ξ±` holds when `z` encodes + some CNF `Ο†`, `Ξ±` is a bit-string of length at most `|z| + 1`, and + `Ξ±` satisfies `Ο†`. + + The `|z| + 1` length bound is what gives `PolyBalanced Witness`. It's + always achievable because any satisfying assignment can be truncated + to length `Ο†.maxVar + 1 ≀ |Ο†.encode| + 1 = |z| + 1` + (`satisfiable_iff_short_witness` + `CNF.maxVar_le_encode_length`). -/ +def Witness (z Ξ± : List Bool) : Prop := + βˆƒ Ο† : CNF, z = Ο†.encode ∧ Ξ±.length ≀ z.length + 1 ∧ CNF.eval Ξ± Ο† = true + +-- ════════════════════════════════════════════════════════════════════════ +-- Witness characterization: language iff βˆƒ witness +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Witness characterization of `language`.** A string `z` is in `language` + iff there exists a witness `Ξ±` with `Witness z Ξ±`. + + The forward direction uses `CNF.satisfiable_iff_short_witness` to + produce a truncated witness, then applies `CNF.maxVar_le_encode_length` + to bound its length by `|z| + 1`. + + The reverse direction is immediate: any `Ξ±` satisfying `Ο†` proves + `Ο†.Satisfiable`. -/ +theorem mem_language_iff_witness (z : List Bool) : + z ∈ language ↔ βˆƒ Ξ±, Witness z Ξ± := by + constructor + Β· rintro βŸ¨Ο†, hz, hsat⟩ + -- Extract a short witness using truncation lemma. + rw [CNF.satisfiable_iff_short_witness] at hsat + obtain ⟨α, hlen, heval⟩ := hsat + refine ⟨α, Ο†, hz, ?_, heval⟩ + -- Ξ±.length ≀ Ο†.maxVar + 1 ≀ |Ο†.encode| + 1 = |z| + 1 + have : Ξ±.length ≀ Ο†.encode.length + 1 := + le_trans hlen (by have := CNF.maxVar_le_encode_length Ο†; omega) + rw [hz]; exact this + Β· rintro ⟨α, Ο†, hz, _, heval⟩ + exact βŸ¨Ο†, hz, Ξ±, heval⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- PolyBalanced: witness length is bounded by a polynomial in |z| +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Short-witness property for SAT.** The witness relation `Witness` is + polynomially balanced: every valid witness has length at most + `|z| + 1`, which is bounded by the degree-1 polynomial `X + 1`. + + This is the key structural fact that makes `SAT` a candidate for NP: + we never need to guess more than linearly many bits. -/ +theorem polyBalanced_witness : PolyBalanced Witness := by + refine ⟨Polynomial.X + Polynomial.C 1, ?_⟩ + intro z Ξ± hR + obtain ⟨_, _, hlen, _⟩ := hR + simp only [Polynomial.eval_add, Polynomial.eval_X, Polynomial.eval_C] + exact hlen + +-- ════════════════════════════════════════════════════════════════════════ +-- Route to SAT ∈ NP +-- ════════════════════════════════════════════════════════════════════════ +-- +-- With `polyBalanced_witness` in hand, one route to SAT ∈ NP asks whether +-- the verifier's pair language `pairLang Witness` is in P. That is, whether +-- there is a poly-time deterministic TM that, given +-- `pair(z, Ξ±)`, decides whether `Witness z Ξ±` holds β€” equivalently, that +-- parses `z` as a CNF and evaluates it at `Ξ±`. +-- +-- `SAT/VerifierTM.lean` now discharges that verifier obligation. The generic +-- theorem below remains parameterized by `WitnessNTMConstruction`; the +-- unconditional SAT headline instead uses the specialized construction from +-- `SAT/Internal/GuessVerify.lean`. + +/-- **SAT is in FNP modulo the verifier.** If the verifier's pair language + is in P, then `Witness` is an FNP relation β€” and hence a candidate NP + witness relation for `language`. The only nontrivial content is + `polyBalanced_witness`. -/ +theorem witness_mem_FNP_of_verifier (h : pairLang Witness ∈ P) : Witness ∈ FNP := + ⟨polyBalanced_witness, h⟩ + +/-- **SAT is in NP modulo the verifier and generic guess-and-verify construction.** + If the verifier's pair language is in P and the generic FNP-witness to NP + construction has been built, then `language ∈ NP`. + + Combines `witness_mem_FNP_of_verifier` (SAT's FNP witness relation) with + the generic NP witness theorem `mem_NP_of_FNP_witness`. This theorem + deliberately retains the generic construction as an explicit hypothesis; + the SAT-specific unconditional route is provided by `SAT/Headline.lean`. -/ +theorem language_mem_NP_of_verifier + (hwitness : NP.WitnessNTMConstruction) (h : pairLang Witness ∈ P) : + language ∈ NP := + NP.mem_NP_of_FNP_witness hwitness (witness_mem_FNP_of_verifier h) mem_language_iff_witness + +-- ════════════════════════════════════════════════════════════════════════ +-- Worked examples: end-to-end sanity check of the semantic layer +-- ════════════════════════════════════════════════════════════════════════ + +/-- `[[xβ‚€]]` is satisfiable. Checked by the `decide` tactic using + `CNF.decidableSatisfiable`. -/ +example : CNF.Satisfiable [[{sign := true, var := 0}]] := by decide + +/-- `[[xβ‚€], [Β¬xβ‚€]]` is unsatisfiable: no assignment can make both clauses true. -/ +example : Β¬ CNF.Satisfiable [[{sign := true, var := 0}], [{sign := false, var := 0}]] := by + decide + +/-- `[[xβ‚€, Β¬x₁], [x₁]]` is satisfiable: `Ξ± = [true, true]` works. -/ +example : CNF.Satisfiable [[{sign := true, var := 0}, {sign := false, var := 1}], + [{sign := true, var := 1}]] := by decide + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/Rename.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/Rename.lean new file mode 100644 index 0000000000..96c8fd7805 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/Rename.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.Semantics + +/-! +# Variable renaming and satisfiability transport + +Renaming the variables of a CNF along an *injective* map preserves +satisfiability. This justifies re-indexing the Cook–Levin tableau variables +from the `Nat.pair`-based scheme (convenient for injectivity bookkeeping in +the correctness proof) to a flat mixed-radix scheme computable by a Turing +machine with unary multiplication and addition only β€” the form the reduction +machine actually emits (`docs/A5-ReductionEmitter.md`). + +## Main definitions + +- `SAT.Lit.mapVar`, `SAT.Clause.mapVar`, `SAT.CNF.mapVar` β€” variable renaming + +## Main results + +- `SAT.CNF.eval_mapVar_eq` β€” evaluation commutes with renaming, given + pointwise-agreeing assignments on the occurring variables +- `SAT.CNF.satisfiable_mapVar_iff` β€” renaming along an injective map + preserves satisfiability +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +-- ════════════════════════════════════════════════════════════════════════ +-- Renaming +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rename a literal's variable along `f`. -/ +def Lit.mapVar (f : β„• β†’ β„•) (β„“ : Lit) : Lit := βŸ¨β„“.sign, f β„“.var⟩ + +/-- Rename every variable of a clause along `f`. -/ +def Clause.mapVar (f : β„• β†’ β„•) (c : Clause) : Clause := c.map (Lit.mapVar f) + +/-- Rename every variable of a CNF along `f`. -/ +def CNF.mapVar (f : β„• β†’ β„•) (Ο† : CNF) : CNF := Ο†.map (Clause.mapVar f) + +/-- Renaming the empty CNF yields the empty CNF. -/ +@[simp] theorem CNF.mapVar_nil (f : β„• β†’ β„•) : CNF.mapVar f [] = [] := rfl + +/-- Renaming distributes over `cons`: rename the head clause and the tail CNF. -/ +theorem CNF.mapVar_cons (f : β„• β†’ β„•) (c : Clause) (Ο† : CNF) : + CNF.mapVar f (c :: Ο†) = Clause.mapVar f c :: CNF.mapVar f Ο† := rfl + +/-- Renaming distributes over CNF concatenation. -/ +theorem CNF.mapVar_append (f : β„• β†’ β„•) (Ο† ψ : CNF) : + CNF.mapVar f (Ο† ++ ψ) = CNF.mapVar f Ο† ++ CNF.mapVar f ψ := + List.map_append .. + +-- ════════════════════════════════════════════════════════════════════════ +-- Assignment helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Out-of-range variables read `false`. -/ +theorem Assignment.get_of_length_le {Ξ± : Assignment} {v : β„•} (h : Ξ±.length ≀ v) : + Ξ±.get v = false := by + rw [Assignment.get, List.getElem?_eq_none h] + rfl + +/-- Tabulate the first `M` values of a Boolean function as an assignment. -/ +def Assignment.ofFn (M : β„•) (g : β„• β†’ Bool) : Assignment := (List.range M).map g + +/-- The tabulated assignment `Assignment.ofFn M g` has length `M`. -/ +@[simp] theorem Assignment.ofFn_length (M : β„•) (g : β„• β†’ Bool) : + (Assignment.ofFn M g).length = M := by + simp [Assignment.ofFn] + +/-- Reading `Assignment.ofFn M g` at an in-range variable `v < M` returns `g v`. -/ +theorem Assignment.ofFn_get {M v : β„•} (g : β„• β†’ Bool) (h : v < M) : + (Assignment.ofFn M g).get v = g v := by + simp [Assignment.ofFn, Assignment.get, List.getElem?_map, List.getElem?_range h] + +/-- Every member is at most the `foldr max` of its list. -/ +private theorem le_foldr_max' {v : β„•} {l : List β„•} (h : v ∈ l) : + v ≀ l.foldr max 0 := by + induction l with + | nil => exact (List.not_mem_nil h).elim + | cons a l ih => + rcases List.mem_cons.mp h with rfl | h + Β· exact le_max_left _ _ + Β· exact le_trans (ih h) (le_max_right _ _) + +-- ════════════════════════════════════════════════════════════════════════ +-- Evaluation commutes with renaming +-- ════════════════════════════════════════════════════════════════════════ + +/-- Clause evaluation commutes with renaming, given assignments that agree + pointwise (through `f`) on the clause's variables. -/ +theorem Clause.eval_mapVar_eq (Ξ± Ξ² : Assignment) (f : β„• β†’ β„•) (c : Clause) + (h : βˆ€ β„“ ∈ c, Ξ±.get (f β„“.var) = Ξ².get β„“.var) : + Clause.eval Ξ± (c.mapVar f) = Clause.eval Ξ² c := by + induction c with + | nil => rfl + | cons β„“ β„“s ih => + have h1 : Lit.eval Ξ± (Lit.mapVar f β„“) = Lit.eval Ξ² β„“ := by + simp only [Lit.eval, Lit.mapVar] + rw [h β„“ List.mem_cons_self] + have h2 := ih (fun β„“' hβ„“' => h β„“' (List.mem_cons_of_mem _ hβ„“')) + simp only [Clause.mapVar, List.map_cons, Clause.eval, List.any_cons] at h2 ⊒ + rw [h1, h2] + +/-- CNF evaluation commutes with renaming, given assignments that agree + pointwise (through `f`) on the formula's variables. -/ +theorem CNF.eval_mapVar_eq (Ξ± Ξ² : Assignment) (f : β„• β†’ β„•) (Ο† : CNF) + (h : βˆ€ c ∈ Ο†, βˆ€ β„“ ∈ c, Ξ±.get (f β„“.var) = Ξ².get β„“.var) : + CNF.eval Ξ± (CNF.mapVar f Ο†) = CNF.eval Ξ² Ο† := by + induction Ο† with + | nil => rfl + | cons c Ο† ih => + have h1 := Clause.eval_mapVar_eq Ξ± Ξ² f c (h c List.mem_cons_self) + have h2 := ih (fun c' hc' => h c' (List.mem_cons_of_mem _ hc')) + simp only [CNF.mapVar, List.map_cons, CNF.eval, List.all_cons] at h2 ⊒ + rw [h1, h2] + +-- ════════════════════════════════════════════════════════════════════════ +-- Satisfiability transport +-- ════════════════════════════════════════════════════════════════════════ + +/-- Renaming preserves satisfiability, forward direction: push the satisfying + assignment along the (injective) renaming. -/ +theorem CNF.Satisfiable.mapVar {f : β„• β†’ β„•} (hf : Function.Injective f) {Ο† : CNF} + (h : CNF.Satisfiable Ο†) : CNF.Satisfiable (CNF.mapVar f Ο†) := by + classical + obtain ⟨β, hβ⟩ := h + set M := ((List.range Ξ².length).map f).foldr max 0 + 1 with hM + set Ξ± := Assignment.ofFn M + (fun w => decide (βˆƒ v, v < Ξ².length ∧ f v = w ∧ Ξ².get v = true)) with hΞ± + have hpoint : βˆ€ v, Ξ±.get (f v) = Ξ².get v := by + intro v + by_cases hv : v < Ξ².length + Β· have hfv : f v < M := by + rw [hM] + exact Nat.lt_succ_of_le + (le_foldr_max' (List.mem_map_of_mem (List.mem_range.mpr hv))) + rw [hΞ±, Assignment.ofFn_get _ hfv] + cases hΞ²v : Ξ².get v with + | false => + apply decide_eq_false + rintro ⟨v', _, hfeq, hget⟩ + cases hf hfeq + rw [hΞ²v] at hget + exact Bool.noConfusion hget + | true => exact decide_eq_true ⟨v, hv, rfl, hΞ²v⟩ + Β· rw [Assignment.get_of_length_le (by omega : Ξ².length ≀ v)] + by_cases hfv : f v < M + Β· rw [hΞ±, Assignment.ofFn_get _ hfv] + apply decide_eq_false + rintro ⟨v', hv', hfeq, _⟩ + cases hf hfeq + exact hv hv' + Β· exact Assignment.get_of_length_le (by rw [hΞ±, Assignment.ofFn_length]; omega) + refine ⟨α, ?_⟩ + rw [CNF.eval_mapVar_eq Ξ± Ξ² f Ο† (fun c _ β„“ _ => hpoint β„“.var)] + exact hΞ² + +/-- Renaming reflects satisfiability, backward direction: pull the satisfying + assignment back through the renaming (no injectivity needed). -/ +theorem CNF.Satisfiable.of_mapVar {f : β„• β†’ β„•} {Ο† : CNF} + (h : CNF.Satisfiable (CNF.mapVar f Ο†)) : CNF.Satisfiable Ο† := by + obtain ⟨α, hα⟩ := h + refine ⟨Assignment.ofFn (CNF.maxVar Ο† + 1) (fun v => Ξ±.get (f v)), ?_⟩ + rw [← CNF.eval_mapVar_eq Ξ± _ f Ο† ?_] + Β· exact hΞ± + Β· intro c hc β„“ hβ„“ + have hle : β„“.var ≀ CNF.maxVar Ο† := + le_trans (Clause.var_le_maxVar hβ„“) (CNF.clause_maxVar_le_maxVar hc) + rw [Assignment.ofFn_get _ (by omega)] + +/-- **Satisfiability is invariant under injective variable renaming.** -/ +theorem CNF.satisfiable_mapVar_iff {f : β„• β†’ β„•} (hf : Function.Injective f) (Ο† : CNF) : + CNF.Satisfiable (CNF.mapVar f Ο†) ↔ CNF.Satisfiable Ο† := + ⟨CNF.Satisfiable.of_mapVar, fun h => h.mapVar hf⟩ + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/Semantics.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/Semantics.lean new file mode 100644 index 0000000000..92417cc2a4 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/Semantics.lean @@ -0,0 +1,381 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Rat.Cast.Order +public import Mathlib.Tactic.NormNum.Abs +public import Mathlib.Tactic.NormNum.DivMod +public import Mathlib.Tactic.NormNum.OfScientific +public import Mathlib.Tactic.NormNum.Pow + +/-! +# SAT: Semantic Layer + +This file contains the mathematical definition of Boolean satisfiability. +**No Turing machines are used here.** Everything is pure recursion on +inductive types; a reader can audit these definitions in a few minutes +and check that they really capture "Ξ± satisfies Ο†". + +All later claims about the SAT verifier are stated against the predicates +defined here. If this file is wrong, nothing downstream rescues us. + +## Definitions + +- `Lit` β€” a literal `(sign, var)` where `var : Nat` is a variable index + and `sign : Bool` says whether the literal is positive. +- `Clause` β€” a list of literals (disjunction). +- `CNF` β€” a list of clauses (conjunction). +- `Assignment` β€” a `List Bool` giving the value of each variable. +- `Lit.eval` β€” `Ξ±[β„“.var] = β„“.sign` (out-of-range reads as `false`). +- `Clause.eval` β€” disjunction over literals. +- `CNF.eval` β€” conjunction over clauses. +- `CNF.Satisfiable` β€” some assignment makes `CNF.eval` true. + +## Out-of-range convention + +A variable index `i β‰₯ Ξ±.length` is treated as assigned to `false`. This is +standard in SAT textbooks ("unassigned variables default to 0") and makes +the language closed under padding: a short satisfying assignment always +exists, equal to a prefix of any longer one. This is essential for +polynomial balance in the NP reduction. +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +-- ════════════════════════════════════════════════════════════════════════ +-- Literals, clauses, CNF +-- ════════════════════════════════════════════════════════════════════════ + +/-- A literal: `sign = true` means the positive literal `x_var`; + `sign = false` means `Β¬x_var`. -/ +structure Lit where + /-- Polarity of the literal: `true` for `x_var`, `false` for `Β¬x_var`. -/ + sign : Bool + /-- Index of the variable this literal mentions. -/ + var : Nat + deriving DecidableEq + +/-- A clause is a disjunction of literals. The empty clause is + unsatisfiable (an empty disjunction is `false`). -/ +abbrev Clause := List Lit + +/-- A CNF formula is a conjunction of clauses. The empty CNF is + satisfiable (an empty conjunction is `true`). -/ +abbrev CNF := List Clause + +/-- An assignment is a bit-string. Position `i` holds the value of + variable `i`. Indices past the end read as `false`. -/ +abbrev Assignment := List Bool + +-- ════════════════════════════════════════════════════════════════════════ +-- Evaluation +-- ════════════════════════════════════════════════════════════════════════ + +namespace Assignment +/-- Value of variable `i` under assignment `Ξ±`, with out-of-range = `false`. -/ +@[inline] def get (Ξ± : Assignment) (i : Nat) : Bool := + (Ξ±[i]?).getD false +end Assignment + +namespace Lit +/-- `β„“ = (s, v)` is satisfied by `Ξ±` iff `Ξ±.get v = s`. -/ +@[inline] def eval (Ξ± : Assignment) (β„“ : Lit) : Bool := + Ξ±.get β„“.var == β„“.sign +end Lit + +namespace Clause +/-- A clause is satisfied iff at least one literal is. -/ +@[inline] def eval (Ξ± : Assignment) (c : Clause) : Bool := + c.any (Lit.eval Ξ±) +end Clause + +namespace CNF +/-- A CNF is satisfied iff every clause is. -/ +@[inline] def eval (Ξ± : Assignment) (Ο† : CNF) : Bool := + Ο†.all (Clause.eval Ξ±) + +/-- `Ο†` is satisfiable if some assignment makes `CNF.eval` true. -/ +def Satisfiable (Ο† : CNF) : Prop := βˆƒ Ξ± : Assignment, eval Ξ± Ο† = true + +-- ════════════════════════════════════════════════════════════════════════ +-- Basic sanity lemmas (proved here so downstream files can rely on them) +-- ════════════════════════════════════════════════════════════════════════ + +/-- The empty CNF evaluates to `true` (empty conjunction). -/ +@[simp] theorem eval_nil (Ξ± : Assignment) : eval Ξ± [] = true := rfl + +/-- Evaluating `c :: Ο†` is the conjunction of evaluating `c` and evaluating `Ο†`. -/ +@[simp] theorem eval_cons (Ξ± : Assignment) (c : Clause) (Ο† : CNF) : + eval Ξ± (c :: Ο†) = (Clause.eval Ξ± c && eval Ξ± Ο†) := by + simp [eval, List.all_cons] + +/-- The empty formula is trivially satisfiable. -/ +theorem satisfiable_nil : Satisfiable [] := ⟨[], rfl⟩ + +/-- The formula `[[]]` (one empty clause) is unsatisfiable. -/ +theorem not_satisfiable_empty_clause : Β¬ Satisfiable [([] : Clause)] := by + rintro ⟨α, h⟩ + simp [eval, Clause.eval] at h + +end CNF + +-- ════════════════════════════════════════════════════════════════════════ +-- Max variable index β€” used to show polynomial-length witnesses exist +-- ════════════════════════════════════════════════════════════════════════ + +/-- Largest variable index appearing in a literal (just `β„“.var`). -/ +@[inline] def Lit.maxVar (β„“ : Lit) : Nat := β„“.var + +/-- Largest variable index in a clause (0 if empty). -/ +def Clause.maxVar : Clause β†’ Nat + | [] => 0 + | β„“ :: β„“s => max β„“.var (maxVar β„“s) + +/-- The empty clause has `maxVar = 0`. -/ +@[simp] theorem Clause.maxVar_nil : Clause.maxVar [] = 0 := rfl + +/-- `maxVar` of `β„“ :: β„“s` is the max of `β„“.var` and `maxVar β„“s`. -/ +@[simp] theorem Clause.maxVar_cons (β„“ : Lit) (β„“s : Clause) : + Clause.maxVar (β„“ :: β„“s) = max β„“.var (Clause.maxVar β„“s) := rfl + +/-- Every literal's var in a clause is at most `c.maxVar`. -/ +theorem Clause.var_le_maxVar {β„“ : Lit} {c : Clause} (hβ„“ : β„“ ∈ c) : + β„“.var ≀ c.maxVar := by + induction c with + | nil => exact (List.not_mem_nil hβ„“).elim + | cons β„“' β„“s ih => + rcases List.mem_cons.mp hβ„“ with h | h + Β· subst h; simp + Β· calc β„“.var ≀ Clause.maxVar β„“s := ih h + _ ≀ max β„“'.var (Clause.maxVar β„“s) := le_max_right _ _ + _ = Clause.maxVar (β„“' :: β„“s) := by simp + +/-- Largest variable index in a CNF (0 if empty). -/ +def CNF.maxVar : CNF β†’ Nat + | [] => 0 + | c :: cs => max c.maxVar (maxVar cs) + +/-- The empty CNF has `maxVar = 0`. -/ +@[simp] theorem CNF.maxVar_nil : CNF.maxVar [] = 0 := rfl + +/-- `maxVar` of `c :: cs` is the max of `c.maxVar` and `maxVar cs`. -/ +@[simp] theorem CNF.maxVar_cons (c : Clause) (cs : CNF) : + CNF.maxVar (c :: cs) = max c.maxVar (CNF.maxVar cs) := rfl + +/-- Every clause's maxVar is at most `Ο†.maxVar`. -/ +theorem CNF.clause_maxVar_le_maxVar {c : Clause} {Ο† : CNF} (hc : c ∈ Ο†) : + c.maxVar ≀ Ο†.maxVar := by + induction Ο† with + | nil => exact (List.not_mem_nil hc).elim + | cons c' cs ih => + rcases List.mem_cons.mp hc with h | h + Β· subst h; simp + Β· calc c.maxVar ≀ CNF.maxVar cs := ih h + _ ≀ max c'.maxVar (CNF.maxVar cs) := le_max_right _ _ + _ = CNF.maxVar (c' :: cs) := by simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Padding: truncating Ξ± below maxVar doesn't matter for out-of-range vars, +-- and extending Ξ± with false never changes eval. +-- ════════════════════════════════════════════════════════════════════════ + +/-- `Assignment.get` on `Ξ± ++ Ξ²` agrees with `Ξ±` at in-range indices. -/ +theorem Assignment.get_append_left (Ξ± Ξ² : Assignment) (i : Nat) (h : i < Ξ±.length) : + Assignment.get (Ξ± ++ Ξ²) i = Assignment.get Ξ± i := by + simp only [Assignment.get, List.getElem?_append_left h] + +/-- Appending to an assignment doesn't change `Lit.eval` for in-range literals. -/ +theorem Lit.eval_append_of_lt (Ξ± Ξ² : Assignment) (β„“ : Lit) (h : β„“.var < Ξ±.length) : + β„“.eval (Ξ± ++ Ξ²) = β„“.eval Ξ± := by + simp [Lit.eval, Assignment.get_append_left Ξ± Ξ² β„“.var h] + +-- ════════════════════════════════════════════════════════════════════════ +-- Truncation: assignments agree on eval below `maxVar + 1` +-- ════════════════════════════════════════════════════════════════════════ +-- +-- These lemmas say that if two assignments agree on all variable positions +-- that actually appear in Ο†, they produce the same evaluation. In particular, +-- truncating Ξ± to length `Ο†.maxVar + 1` preserves `CNF.eval Ξ± Ο†`. +-- +-- This is what powers `PolyBalanced`: given *any* satisfying Ξ±, we get a +-- short satisfying witness of length ≀ `Ο†.maxVar + 1 ≀ |Ο†.encode| + 1`. + +/-- `Ξ±.get i` is preserved by truncating to any length `k > i`. -/ +theorem Assignment.get_take (Ξ± : Assignment) (i k : Nat) (hi : i < k) : + Assignment.get (Ξ±.take k) i = Assignment.get Ξ± i := by + simp only [Assignment.get] + by_cases hl : i < Ξ±.length + Β· have htl : i < (Ξ±.take k).length := by + simp only [List.length_take]; omega + rw [List.getElem?_eq_getElem hl, List.getElem?_eq_getElem htl, + List.getElem_take] + Β· push Not at hl + have h1 : Ξ±[i]? = none := List.getElem?_eq_none hl + have h2 : (Ξ±.take k)[i]? = none := by + apply List.getElem?_eq_none + simp only [List.length_take]; omega + rw [h1, h2] + +/-- `Lit.eval` is invariant under truncation when the literal's var is in range. -/ +theorem Lit.eval_take (Ξ± : Assignment) (β„“ : Lit) (k : Nat) (hk : β„“.var < k) : + Lit.eval (Ξ±.take k) β„“ = Lit.eval Ξ± β„“ := by + simp only [Lit.eval] + rw [Assignment.get_take Ξ± β„“.var k hk] + +/-- `Clause.eval` is preserved by truncation of Ξ± to length above `c.maxVar`. -/ +theorem Clause.eval_take (Ξ± : Assignment) (c : Clause) (k : Nat) (hk : c.maxVar < k) : + Clause.eval (Ξ±.take k) c = Clause.eval Ξ± c := by + induction c with + | nil => rfl + | cons β„“ β„“s ih => + simp only [maxVar_cons] at hk + have hβ„“ : β„“.var < k := by omega + have hβ„“s : Clause.maxVar β„“s < k := by omega + show ((β„“ :: β„“s).any (Lit.eval (Ξ±.take k))) = ((β„“ :: β„“s).any (Lit.eval Ξ±)) + simp only [List.any_cons, Lit.eval_take _ _ _ hβ„“] + exact congrArg _ (ih hβ„“s) + +/-- `CNF.eval` is preserved by truncation of Ξ± to length above `Ο†.maxVar`. -/ +theorem CNF.eval_take (Ξ± : Assignment) (Ο† : CNF) (k : Nat) (hk : Ο†.maxVar < k) : + CNF.eval (Ξ±.take k) Ο† = CNF.eval Ξ± Ο† := by + induction Ο† with + | nil => rfl + | cons c cs ih => + simp only [maxVar_cons] at hk + have hc : c.maxVar < k := by omega + have hcs : CNF.maxVar cs < k := by omega + show ((c :: cs).all (Clause.eval (Ξ±.take k))) = ((c :: cs).all (Clause.eval Ξ±)) + simp only [List.all_cons, Clause.eval_take _ _ _ hc] + exact congrArg _ (ih hcs) + +/-- **PolyBalanced witness lemma.** A satisfiable formula has a satisfying + assignment of length at most `Ο†.maxVar + 1`. -/ +theorem CNF.satisfiable_iff_short_witness (Ο† : CNF) : + Ο†.Satisfiable ↔ βˆƒ Ξ± : Assignment, + Ξ±.length ≀ Ο†.maxVar + 1 ∧ CNF.eval Ξ± Ο† = true := by + constructor + Β· rintro ⟨α, hα⟩ + refine ⟨α.take (Ο†.maxVar + 1), ?_, ?_⟩ + Β· exact le_trans (List.length_take_le _ _) (by omega) + Β· rw [CNF.eval_take Ξ± Ο† (Ο†.maxVar + 1) (by omega)] + exact hΞ± + Β· rintro ⟨α, _, hα⟩ + exact ⟨α, hα⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Pointwise agreement and decidability of `Satisfiable` +-- ════════════════════════════════════════════════════════════════════════ + +/-- If two assignments give the same value at every index (via `Assignment.get`), + they produce the same literal evaluation. -/ +theorem Lit.eval_eq_of_agree (Ξ± Ξ² : Assignment) (β„“ : Lit) + (h : Assignment.get Ξ± β„“.var = Assignment.get Ξ² β„“.var) : + Lit.eval Ξ± β„“ = Lit.eval Ξ² β„“ := by + simp [Lit.eval, h] + +/-- Pointwise agreement of `Assignment.get` implies equal `Clause.eval`. -/ +theorem Clause.eval_eq_of_agree (Ξ± Ξ² : Assignment) (c : Clause) + (h : βˆ€ i, Assignment.get Ξ± i = Assignment.get Ξ² i) : + Clause.eval Ξ± c = Clause.eval Ξ² c := by + induction c with + | nil => rfl + | cons β„“ β„“s ih => + show ((β„“ :: β„“s).any (Lit.eval Ξ±)) = ((β„“ :: β„“s).any (Lit.eval Ξ²)) + simp only [List.any_cons, Lit.eval_eq_of_agree Ξ± Ξ² β„“ (h β„“.var)] + exact congrArg _ ih + +/-- Pointwise agreement of `Assignment.get` implies equal `CNF.eval`. -/ +theorem CNF.eval_eq_of_agree (Ξ± Ξ² : Assignment) (Ο† : CNF) + (h : βˆ€ i, Assignment.get Ξ± i = Assignment.get Ξ² i) : + CNF.eval Ξ± Ο† = CNF.eval Ξ² Ο† := by + induction Ο† with + | nil => rfl + | cons c cs ih => + show ((c :: cs).all (Clause.eval Ξ±)) = ((c :: cs).all (Clause.eval Ξ²)) + simp only [List.all_cons, Clause.eval_eq_of_agree Ξ± Ξ² c h] + exact congrArg _ ih + +/-- Appending `false`s doesn't change `Assignment.get`: out-of-range positions + default to `false` anyway. -/ +theorem Assignment.get_append_replicate_false (Ξ± : Assignment) (k i : Nat) : + Assignment.get (Ξ± ++ List.replicate k false) i = Assignment.get Ξ± i := by + simp only [Assignment.get] + by_cases hi : i < Ξ±.length + Β· rw [List.getElem?_append_left hi] + Β· push Not at hi + rw [List.getElem?_eq_none hi] + by_cases hi' : i < Ξ±.length + k + Β· rw [List.getElem?_append_right hi] + have hrepl : (i - Ξ±.length) < (List.replicate k false : List Bool).length := by + simp; omega + rw [List.getElem?_eq_getElem hrepl] + simp [List.getElem_replicate] + Β· push Not at hi' + rw [List.getElem?_eq_none (by simp; omega)] + +/-- Padding an assignment with `false`s doesn't change `CNF.eval`. -/ +theorem CNF.eval_append_replicate_false (Ξ± : Assignment) (k : Nat) (Ο† : CNF) : + CNF.eval (Ξ± ++ List.replicate k false) Ο† = CNF.eval Ξ± Ο† := + CNF.eval_eq_of_agree _ _ _ (fun _ => Assignment.get_append_replicate_false Ξ± k _) + +/-- **Brute-force decidability.** Satisfiability is decidable by enumerating + all `2^(Ο†.maxVar + 1)` assignments of length `Ο†.maxVar + 1`. Not + poly-time, but establishes that the semantic layer is concretely + computable and enables `decide` on small instances. -/ +instance CNF.decidableSatisfiable (Ο† : CNF) : Decidable Ο†.Satisfiable := by + suffices h : Ο†.Satisfiable ↔ + βˆƒ f : Fin (Ο†.maxVar + 1) β†’ Bool, CNF.eval (List.ofFn f) Ο† = true from + decidable_of_iff _ h.symm + rw [CNF.satisfiable_iff_short_witness] + constructor + Β· rintro ⟨α, hlen, heval⟩ + -- Pad Ξ± with `false`s up to length `maxVar + 1`, then identify with a Fin-indexed function. + let Ξ±' : Assignment := Ξ± ++ List.replicate (Ο†.maxVar + 1 - Ξ±.length) false + have hΞ±'_len : Ξ±'.length = Ο†.maxVar + 1 := by + simp only [Ξ±', List.length_append, List.length_replicate]; omega + refine ⟨fun i => Ξ±'[i.val]'(by rw [hΞ±'_len]; exact i.isLt), ?_⟩ + rw [← CNF.eval_append_replicate_false Ξ± (Ο†.maxVar + 1 - Ξ±.length) Ο†] at heval + change CNF.eval Ξ±' Ο† = true at heval + -- List.ofFn (fun i => Ξ±'[i.val]) agrees pointwise with Ξ±' via Assignment.get, + -- so CNF.eval is the same. + rw [CNF.eval_eq_of_agree _ Ξ±' Ο† (fun i => ?_)] + Β· exact heval + Β· simp only [Assignment.get] + by_cases hi : i < Ο†.maxVar + 1 + Β· have h1 : i < (List.ofFn (fun j : Fin (Ο†.maxVar + 1) => + Ξ±'[j.val]'(by rw [hΞ±'_len]; exact j.isLt))).length := by simp [hi] + have hi' : i < Ξ±'.length := by rw [hΞ±'_len]; exact hi + rw [List.getElem?_eq_getElem h1, List.getElem_ofFn, + List.getElem?_eq_getElem hi'] + Β· push Not at hi + rw [List.getElem?_eq_none (by simp; omega), + List.getElem?_eq_none (by rw [hΞ±'_len]; exact hi)] + Β· rintro ⟨f, hf⟩ + exact ⟨List.ofFn f, by simp, hf⟩ + +/-- Evaluating a concatenation of clauses is the disjunction of the evaluations. -/ +@[simp] theorem Clause.eval_append (Ξ± : Assignment) (c d : Clause) : + Clause.eval Ξ± (c ++ d) = (Clause.eval Ξ± c || Clause.eval Ξ± d) := by + induction c with + | nil => simp [Clause.eval] + | cons _ _ _ => simp [Clause.eval, List.any_cons, Bool.or_assoc] + +/-- Evaluating a concatenation of CNFs is the conjunction of the evaluations. -/ +@[simp] theorem CNF.eval_append (Ξ± : Assignment) (Ο† ψ : CNF) : + CNF.eval Ξ± (Ο† ++ ψ) = (CNF.eval Ξ± Ο† && CNF.eval Ξ± ψ) := by + induction Ο† with + | nil => simp [CNF.eval] + | cons _ _ _ => simp [CNF.eval, List.all_cons, Bool.and_assoc] + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeCNF.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeCNF.lean new file mode 100644 index 0000000000..aad6da5dd8 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeCNF.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.Rename +public import Std.Tactic.BVDecide.Normalize.Prop + +/-! +# 3-CNF formulas + +The **3-CNF** refinement of the existing `CNF` type: a CNF is in 3-CNF when every +clause has exactly three literals. Following the roadmap (track N3), 3-CNF is +introduced here as a *predicate* on the existing `CNF = List Clause`, so that all +of the `CNF` semantics (`CNF.eval`, `CNF.Satisfiable`, `CNF.maxVar`, renaming) +apply unchanged and a 3-CNF is literally a CNF. + +## Main definitions and results + +- `CNF.Is3CNF` β€” every clause has length `3`; decidable +- `CNF.is3CNF_cons` β€” the cons characterization +- `CNF.Is3CNF.mapVar` β€” variable renaming preserves the 3-CNF shape + +The substantive N3 milestone β€” a size-controlled clause-padding transformation +turning an arbitrary CNF into an equisatisfiable 3-CNF β€” builds on this predicate +and is tracked separately. +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +/-- A CNF is in **3-CNF** when every clause is a disjunction of exactly three + literals. This is a predicate on the existing `CNF` type, so a 3-CNF formula + is literally a `CNF` and inherits all of its semantics. -/ +def CNF.Is3CNF (Ο† : CNF) : Prop := βˆ€ c ∈ Ο†, c.length = 3 + +instance (Ο† : CNF) : Decidable (CNF.Is3CNF Ο†) := List.decidableBAll _ _ + +/-- The empty CNF is trivially in 3-CNF. -/ +@[simp] theorem CNF.is3CNF_nil : CNF.Is3CNF [] := by + simp [CNF.Is3CNF] + +/-- `c :: Ο†` is 3-CNF iff `c` has three literals and `Ο†` is 3-CNF. -/ +@[simp] theorem CNF.is3CNF_cons {c : Clause} {Ο† : CNF} : + CNF.Is3CNF (c :: Ο†) ↔ c.length = 3 ∧ CNF.Is3CNF Ο† := + List.forall_mem_cons + +/-- Variable renaming preserves the 3-CNF shape: `Clause.mapVar` maps literals + one-for-one, so it does not change clause lengths. -/ +theorem CNF.Is3CNF.mapVar {Ο† : CNF} (h : CNF.Is3CNF Ο†) (f : β„• β†’ β„•) : + CNF.Is3CNF (CNF.mapVar f Ο†) := by + intro c hc + rw [CNF.mapVar] at hc + obtain ⟨c', hc', rfl⟩ := List.mem_map.mp hc + rw [Clause.mapVar, List.length_map] + exact h c' hc' + +/-! ### Padding short clauses to width three + +A clause with one or two literals is padded to exactly three literals by +repeating its last literal. This changes neither the clause's models nor its +satisfiability (repeating a literal in a disjunction is idempotent), and turns a +CNF whose clauses all have width `1 … 3` into an equivalent 3-CNF. Splitting +*wide* clauses (width `> 3`) needs fresh Tseitin variables and is tracked +separately. -/ + +/-- Pad a clause of one or two literals to width three by repeating a literal; + clauses of any other width are left unchanged. -/ +def Clause.padTo3 : Clause β†’ Clause + | [a] => [a, a, a] + | [a, b] => [a, b, b] + | c => c + +/-- Padding preserves the clause's value under every assignment (repeating a + literal in a disjunction is idempotent). -/ +theorem Clause.padTo3_eval (Ξ± : Assignment) (c : Clause) : + Clause.eval Ξ± (Clause.padTo3 c) = Clause.eval Ξ± c := by + match c with + | [] => rfl + | [a] => simp [Clause.padTo3, Clause.eval] + | [a, b] => simp [Clause.padTo3, Clause.eval] + | a :: b :: _ :: _ => rfl + +/-- A clause of width `1 … 3` is padded to width exactly three. -/ +theorem Clause.padTo3_length {c : Clause} (h1 : 1 ≀ c.length) (h2 : c.length ≀ 3) : + (Clause.padTo3 c).length = 3 := by + match c with + | [a] => rfl + | [a, b] => rfl + | [a, b, d] => rfl + | [] => simp at h1 + | a :: b :: d :: e :: t => simp only [List.length_cons] at h2; omega + +/-- Pad every clause of a CNF to width three. -/ +def CNF.padTo3 (Ο† : CNF) : CNF := Ο†.map Clause.padTo3 + +/-- Padding preserves the CNF's value under every assignment β€” hence + satisfiability. -/ +theorem CNF.padTo3_eval (Ξ± : Assignment) (Ο† : CNF) : + CNF.eval Ξ± (CNF.padTo3 Ο†) = CNF.eval Ξ± Ο† := by + unfold CNF.padTo3 + induction Ο† with + | nil => rfl + | cons c Ο† ih => + simp only [List.map_cons, CNF.eval_cons, Clause.padTo3_eval, ih] + +/-- Padding preserves satisfiability. -/ +theorem CNF.padTo3_satisfiable_iff (Ο† : CNF) : + CNF.Satisfiable (CNF.padTo3 Ο†) ↔ CNF.Satisfiable Ο† := by + simp only [CNF.Satisfiable, CNF.padTo3_eval] + +/-- If every clause of `Ο†` has width `1 … 3`, then `CNF.padTo3 Ο†` is a genuine + 3-CNF equivalent to `Ο†`. -/ +theorem CNF.is3CNF_padTo3 {Ο† : CNF} + (h : βˆ€ c ∈ Ο†, 1 ≀ c.length ∧ c.length ≀ 3) : CNF.Is3CNF (CNF.padTo3 Ο†) := by + intro c hc + obtain ⟨c', hc', rfl⟩ := List.mem_map.mp hc + obtain ⟨h1, h2⟩ := h c' hc' + exact Clause.padTo3_length h1 h2 + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT.lean new file mode 100644 index 0000000000..bcba218502 --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeCNF +public import LeanPool.BeyondBethe.Complexitylib.SAT.Verifier + +/-! +# Encoded CNF-SAT and 3SAT languages + +This module names the existing encoded SAT problem as `CNFSAT` and defines +`ThreeSAT` by restricting decoded CNFs to clauses of exactly three literals. +It is a semantic and codec interface only; no complexity-class membership or +reduction claim is made here. + +## Main definitions and results + +- `CNF.decode3?` β€” decode a bit string only when it encodes an exact 3-CNF +- `CNFSAT.language` β€” compatibility name for the existing `SAT.language` +- `ThreeSAT.language` β€” satisfiable, exactly-three-literal CNF encodings +- `ThreeSAT.falseFormula` β€” a fixed unsatisfiable exact 3-CNF +- `ThreeSAT.fallbackEncoding` β€” valid no-instance output for malformed inputs +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +namespace CNF + +/-- Decode a concrete SAT bit string and accept it only when every decoded +clause contains exactly three literals. -/ +def decode3? (z : List Bool) : Option CNF := do + let Ο† ← decode? z + if Ο†.Is3CNF then some Ο† else none + +/-- An exact 3-CNF survives encoding followed by restricted decoding. -/ +@[simp] theorem decode3?_encode {Ο† : CNF} (h3 : Ο†.Is3CNF) : + decode3? Ο†.encode = some Ο† := by + simp [decode3?, h3] + +/-- Restricted decoding is sound for both the concrete encoding and the +exact-three-literal shape. -/ +theorem decode3?_sound {z : List Bool} {Ο† : CNF} + (h : decode3? z = some Ο†) : z = Ο†.encode ∧ Ο†.Is3CNF := by + cases hdecode : decode? z with + | none => + simp [decode3?, hdecode] at h + | some ψ => + by_cases h3 : ψ.Is3CNF + Β· simp [decode3?, hdecode, h3] at h + subst Ο† + exact ⟨decode?_sound hdecode, h3⟩ + Β· simp [decode3?, hdecode, h3] at h + +/-- Characterization of successful exact-3 decoding. -/ +theorem decode3?_eq_some_iff {z : List Bool} {Ο† : CNF} : + decode3? z = some Ο† ↔ z = Ο†.encode ∧ Ο†.Is3CNF := by + constructor + Β· exact decode3?_sound + Β· rintro ⟨rfl, h3⟩ + exact decode3?_encode h3 + +/-- The concrete CNF encoding is injective. -/ +theorem encode_injective : Function.Injective CNF.encode := by + intro Ο† ψ h + have hdecode := congrArg decode? h + simpa using hdecode + +end CNF + +/-! ## CNF-SAT compatibility surface -/ + +namespace CNFSAT + +/-- Compatibility name for the library's existing SAT language, whose inputs +are concrete encodings of satisfiable CNF formulas. -/ +abbrev language : Language := Complexity.SAT.language + +/-- The compatibility name denotes exactly the existing SAT language. -/ +theorem language_eq_sat : language = Complexity.SAT.language := rfl + +/-- Membership through the compatibility name is definitionally the existing +SAT membership predicate. -/ +@[simp] theorem mem_language_iff_sat (z : List Bool) : + z ∈ language ↔ z ∈ Complexity.SAT.language := Iff.rfl + +/-- A bit string is in CNF-SAT exactly when it decodes to a satisfiable CNF. -/ +theorem mem_language_iff_decode (z : List Bool) : + z ∈ language ↔ βˆƒ Ο† : CNF, CNF.decode? z = some Ο† ∧ Ο†.Satisfiable := by + constructor + Β· rintro βŸ¨Ο†, rfl, hsat⟩ + exact βŸ¨Ο†, CNF.decode?_encode Ο†, hsat⟩ + Β· rintro βŸ¨Ο†, hdecode, hsat⟩ + exact βŸ¨Ο†, CNF.decode?_sound hdecode, hsat⟩ + +/-- Encoding a typed CNF is in CNF-SAT exactly when that formula is +satisfiable. -/ +@[simp] theorem encode_mem_language_iff (Ο† : CNF) : + Ο†.encode ∈ language ↔ Ο†.Satisfiable := by + constructor + Β· rintro ⟨ψ, hencode, hsat⟩ + have hΟ†Οˆ : Ο† = ψ := CNF.encode_injective hencode + simpa [hΟ†Οˆ] using hsat + Β· exact fun hsat => βŸ¨Ο†, rfl, hsat⟩ + +end CNFSAT + +/-! ## 3SAT -/ + +namespace ThreeSAT + +/-- **3SAT** consists of concrete encodings of satisfiable CNFs in which every +clause has exactly three literals. -/ +def language : Language := + {z | βˆƒ Ο† : CNF, z = Ο†.encode ∧ Ο†.Is3CNF ∧ Ο†.Satisfiable} + +/-- A bit string is in 3SAT exactly when restricted decoding succeeds with a +satisfiable formula. -/ +theorem mem_language_iff_decode3 (z : List Bool) : + z ∈ language ↔ βˆƒ Ο† : CNF, CNF.decode3? z = some Ο† ∧ Ο†.Satisfiable := by + constructor + Β· rintro βŸ¨Ο†, rfl, h3, hsat⟩ + exact βŸ¨Ο†, CNF.decode3?_encode h3, hsat⟩ + Β· rintro βŸ¨Ο†, hdecode, hsat⟩ + obtain ⟨hz, h3⟩ := CNF.decode3?_sound hdecode + exact βŸ¨Ο†, hz, h3, hsat⟩ + +/-- Encoding a typed CNF belongs to 3SAT exactly when it is an exact 3-CNF +and is satisfiable. -/ +@[simp] theorem encode_mem_language_iff (Ο† : CNF) : + Ο†.encode ∈ language ↔ Ο†.Is3CNF ∧ Ο†.Satisfiable := by + constructor + Β· rintro ⟨ψ, hencode, h3, hsat⟩ + have hΟ†Οˆ : Ο† = ψ := CNF.encode_injective hencode + simpa [hΟ†Οˆ] using And.intro h3 hsat + Β· rintro ⟨h3, hsat⟩ + exact βŸ¨Ο†, rfl, h3, hsat⟩ + +/-- Every 3SAT instance is, after forgetting the shape restriction, a CNF-SAT +instance. -/ +theorem language_subset_cnfsat : language βŠ† CNFSAT.language := by + rintro z βŸ¨Ο†, hz, _h3, hsat⟩ + exact βŸ¨Ο†, hz, hsat⟩ + +/-- A fixed unsatisfiable exact 3-CNF: one clause forces `xβ‚€`, while the other +forces `Β¬xβ‚€`. Repeated literals make both clauses have width exactly three. -/ +def falseFormula : CNF := + [[{ sign := true, var := 0 }, { sign := true, var := 0 }, + { sign := true, var := 0 }], + [{ sign := false, var := 0 }, { sign := false, var := 0 }, + { sign := false, var := 0 }]] + +/-- `falseFormula` has exactly three literals in each clause. -/ +@[simp] theorem falseFormula_is3CNF : falseFormula.Is3CNF := by + decide + +/-- `falseFormula` is unsatisfiable. -/ +theorem falseFormula_not_satisfiable : Β¬falseFormula.Satisfiable := by + rintro ⟨α, hα⟩ + simp [falseFormula, CNF.eval, Clause.eval, Lit.eval] at hΞ± + +/-- A valid encoded 3-CNF no-instance suitable as the target of malformed or +otherwise invalid source inputs in later total reductions. -/ +def fallbackEncoding : List Bool := falseFormula.encode + +/-- The fallback encoding decodes successfully as `falseFormula`. -/ +@[simp] theorem decode3?_fallbackEncoding : + CNF.decode3? fallbackEncoding = some falseFormula := by + exact CNF.decode3?_encode falseFormula_is3CNF + +/-- The fallback encoding is not a member of 3SAT. -/ +theorem fallbackEncoding_not_mem_language : fallbackEncoding βˆ‰ language := by + rw [fallbackEncoding, encode_mem_language_iff] + exact fun h => falseFormula_not_satisfiable h.2 + +end ThreeSAT + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT/Syntax.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT/Syntax.lean new file mode 100644 index 0000000000..88f504e6ea --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/ThreeSAT/Syntax.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.ThreeSAT +public import LeanPool.BeyondBethe.Complexitylib.Models.TuringMachine.Combinators.Internal.Scanner + +/-! +# Regular syntax checker for exact 3-CNF encodings + +Exact-3 shape is a regular property of the concrete CNF encoding. This module +gives a finite-state left-to-right scanner for it and proves that the scanner +accepts an encoded CNF exactly when every clause has three literals. The syntax +language deliberately need not reject every malformed word: intersecting it +with `CNFSAT.language` supplies well-formedness, which keeps this checker small +and makes the intended 3SAT decomposition explicit. + +## Main results + +- `ThreeSAT.Syntax.encode_mem_language_iff` -- correctness on encoded CNFs +- `ThreeSAT.Syntax.language_mem_P` -- exact-3 syntax is decidable in linear time +- `ThreeSAT.language_eq_cnfsat_inter_syntax` -- semantic decomposition of 3SAT +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +namespace ThreeSAT + +namespace Syntax + +/-- Parser state after consuming whole two-bit encoding tokens. `between k` +means that `k` complete literals have been seen in the current clause. -/ +inductive TokenState where + | between (count : Fin 4) + | inLit (count : Fin 4) + | invalid + deriving DecidableEq, Fintype + +/-- Initial token parser state: between clauses with no current literals. -/ +def tokenStart : TokenState := .between 0 + +/-- One transition of the exact-3 grammar at token granularity. -/ +def tokenStep : TokenState β†’ EncToken β†’ TokenState + | .invalid, _ => .invalid + | .between count, .bit _ => .inLit count + | .between _, .litSep => .invalid + | .between count, .clauseSep => + if count.val = 3 then tokenStart else .invalid + | .inLit count, .bit true => .inLit count + | .inLit _, .bit false => .invalid + | .inLit count, .litSep => + if h : count.val < 3 then .between ⟨count.val + 1, by omega⟩ else .invalid + | .inLit _, .clauseSep => .invalid + +/-- Bit-level scanner state. `half state b` remembers the first bit of the +next two-bit encoding token. -/ +inductive BitState where + | ready (state : TokenState) + | half (state : TokenState) (first : Bool) + deriving DecidableEq, Fintype + +/-- Initial bit-level scanner state. -/ +def bitStart : BitState := .ready tokenStart + +/-- Decode one of the four two-bit concrete token patterns. -/ +def tokenOfBits : Bool β†’ Bool β†’ EncToken + | false, false => .bit false + | true, true => .bit true + | false, true => .litSep + | true, false => .clauseSep + +/-- One input-bit transition of the exact-3 syntax scanner. -/ +def bitStep : BitState β†’ Bool β†’ BitState + | .ready state, b => .half state b + | .half state first, second => .ready (tokenStep state (tokenOfBits first second)) + +/-- The scanner accepts precisely at a token boundary between clauses. -/ +def accept (state : BitState) : Bool := decide (state = bitStart) + +/-- The regular language recognized by the exact-3 syntax scanner. -/ +def language : Language := + {z | accept (z.foldl bitStep bitStart) = true} + +/-- An invalid token state remains invalid under every suffix. -/ +@[simp] private theorem foldl_invalid (toks : List EncToken) : + toks.foldl tokenStep .invalid = .invalid := by + induction toks with + | nil => rfl + | cons tok toks ih => + rw [List.foldl_cons] + exact ih + +/-- Scanning one concrete token implements its token-level transition. -/ +private theorem foldl_encode_token (state : TokenState) (tok : EncToken) : + tok.encode.foldl bitStep (.ready state) = .ready (tokenStep state tok) := by + cases tok with + | bit b => cases b <;> rfl + | litSep => rfl + | clauseSep => rfl + +/-- Scanning a flattened token stream agrees with folding the token parser. -/ +private theorem foldl_encodeTokens (toks : List EncToken) (state : TokenState) : + (encodeTokens toks).foldl bitStep (.ready state) = + .ready (toks.foldl tokenStep state) := by + induction toks generalizing state with + | nil => rfl + | cons tok toks ih => + rw [encodeTokens_cons, List.foldl_append, foldl_encode_token, ih] + rfl + +/-- Unary variable bodies leave the parser inside the current literal. -/ +@[simp] private theorem foldl_true_tokens (count : Fin 4) (n : β„•) : + (List.replicate n (EncToken.bit true)).foldl tokenStep (.inLit count) = + .inLit count := by + induction n with + | zero => rfl + | succ n ih => + rw [List.replicate_succ, List.foldl_cons] + exact ih + +/-- A typed literal's raw tokens leave the parser inside that literal with +the clause count unchanged. -/ +@[simp] private theorem foldl_rawTokens (count : Fin 4) (lit : Lit) : + lit.rawTokens.foldl tokenStep (.between count) = .inLit count := by + rcases lit with ⟨sign, var⟩ + simp only [Lit.rawTokens, Lit.encodeRaw, Unary.encode, List.map_cons, + List.map_replicate, List.foldl_cons, tokenStep] + exact foldl_true_tokens count var + +/-- Scanning one well-formed source literal increments the current clause +count, or becomes invalid if three literals were already complete. -/ +private theorem foldl_literal (count : Fin 4) (lit : Lit) : + (lit.rawTokens ++ [EncToken.litSep]).foldl tokenStep (.between count) = + if h : count.val < 3 then .between ⟨count.val + 1, by omega⟩ else .invalid := by + rw [List.foldl_append, foldl_rawTokens] + simp only [List.foldl_cons, List.foldl_nil, tokenStep] + +/-- One encoded clause followed by its separator returns to the initial state +exactly when the clause has width three. -/ +private theorem foldl_clause (clause : Clause) : + (clause.tokens ++ [EncToken.clauseSep]).foldl tokenStep tokenStart = + if clause.length = 3 then tokenStart else .invalid := by + rcases clause with _ | ⟨a, _ | ⟨b, _ | ⟨c, _ | ⟨d, rest⟩⟩⟩⟩ + all_goals + simp [Clause.tokens, List.foldl_append, tokenStart, tokenStep] + +/-- Token-level recognition theorem for typed CNFs. -/ +private theorem foldl_cnf_eq_start_iff (formula : CNF) : + formula.tokens.foldl tokenStep tokenStart = tokenStart ↔ formula.Is3CNF := by + induction formula with + | nil => simp [CNF.tokens, CNF.Is3CNF] + | cons clause rest ih => + rw [CNF.tokens, List.foldl_append] + rw [foldl_clause] + by_cases hclause : clause.length = 3 + Β· rw [ite_eq_left hclause, ih] + simp [CNF.is3CNF_cons, hclause] + Β· rw [ite_eq_right hclause, foldl_invalid] + simp [tokenStart, CNF.is3CNF_cons, hclause] + +/-- A typed CNF's bit encoding is accepted exactly when it is exact 3-CNF. -/ +@[simp] theorem encode_mem_language_iff (formula : CNF) : + formula.encode ∈ language ↔ formula.Is3CNF := by + change accept (formula.encode.foldl bitStep bitStart) = true ↔ formula.Is3CNF + rw [← CNF.encodeTokens_tokens formula] + change accept ((encodeTokens formula.tokens).foldl bitStep (.ready tokenStart)) = true ↔ _ + rw [foldl_encodeTokens] + change decide (.ready (formula.tokens.foldl tokenStep tokenStart) = bitStart) = true ↔ _ + rw [decide_eq_true_iff] + unfold bitStart + simp only [BitState.ready.injEq] + exact foldl_cnf_eq_start_iff formula + +/-- Concrete zero-work-tape finite-state checker for exact-3 syntax. -/ +def syntaxTM : TM 0 := + TM.scannerTM bitStart bitStep (fun state => if accept state then .one else .zero) + +/-- The syntax checker decides its regular language in exactly `n + 2` steps. -/ +theorem syntaxTM_decidesInTime : + syntaxTM.DecidesInTime language (fun n => n + 2) := by + exact TM.scannerTM_decidesInTime bitStart bitStep accept (fun _ => Iff.rfl) + +/-- The exact-3 syntax language is decidable in linear time. -/ +theorem language_mem_P : language ∈ P := by + refine Set.mem_iUnion.mpr ⟨1, 0, syntaxTM, fun n => n + 2, + syntaxTM_decidesInTime, ?_⟩ + refine BigO.add ?_ (BigO.const_le_pow 2 1) + simpa using BigO.refl (fun n : β„• => n) + +end Syntax + +/-- 3SAT is CNF-SAT intersected with the regular exact-3 syntax language. -/ +theorem language_eq_cnfsat_inter_syntax : + language = CNFSAT.language ∩ Syntax.language := by + ext z + constructor + Β· rintro ⟨formula, rfl, hshape, hsat⟩ + exact ⟨⟨formula, rfl, hsat⟩, (Syntax.encode_mem_language_iff formula).2 hshape⟩ + Β· rintro ⟨⟨formula, rfl, hsat⟩, hshape⟩ + exact ⟨formula, rfl, (Syntax.encode_mem_language_iff formula).1 hshape, hsat⟩ + +end ThreeSAT + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Complexitylib/SAT/Verifier.lean b/LeanPool/BeyondBethe/Complexitylib/SAT/Verifier.lean new file mode 100644 index 0000000000..1ada65105c --- /dev/null +++ b/LeanPool/BeyondBethe/Complexitylib/SAT/Verifier.lean @@ -0,0 +1,456 @@ +/- +Copyright (c) 2025 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +module +public import LeanPool.BeyondBethe.Complexitylib.SAT.Language +public import Std.Tactic.BVDecide.Normalize.BitVec + +/-! +# SAT verifier specification + +This file defines an executable verifier for `pairLang Witness`: + +1. split `pair(z, Ξ±)` back into `(z, Ξ±)` via `unpair?`, +2. decode `z` as a CNF in SAT's concrete bit encoding, +3. check the witness length bound `|Ξ±| ≀ |z| + 1`, +4. evaluate the decoded formula under `Ξ±`. + +The deterministic implementation `verifyPairTM` in `SAT/VerifierTM.lean` +computes this specification and proves `pairLang Witness ∈ P`; this file is +the small executable/semantic audit surface for that machine proof. +-/ + + +@[expose] public section + +namespace Complexity + +namespace SAT + +-- ════════════════════════════════════════════════════════════════════════ +-- Tokenization of the SAT bit-level encoding +-- ════════════════════════════════════════════════════════════════════════ + +/-- The four two-bit tokens used by SAT's concrete encoding. -/ +inductive EncToken where + /-- A doubled data bit: `false` is encoded as `00`, `true` as `11`. -/ + | bit (b : Bool) + /-- The literal separator `|`, encoded as `01`. -/ + | litSep + /-- The clause separator `#`, encoded as `10`. -/ + | clauseSep + deriving DecidableEq, Repr + +namespace EncToken + +/-- Concrete two-bit representation of one SAT encoding token. -/ +def encode : EncToken β†’ List Bool + | .bit false => [false, false] + | .bit true => [true, true] + | .litSep => [false, true] + | .clauseSep => [true, false] + +end EncToken + +/-- Flatten a token stream back into concrete bits. -/ +def encodeTokens (toks : List EncToken) : List Bool := + toks.flatMap EncToken.encode + +/-- Split a bitstring into SAT encoding tokens. Odd-length strings are invalid. -/ +def tokenize? : List Bool β†’ Option (List EncToken) + | [] => some [] + | [_] => none + | false :: false :: rest => Option.map (EncToken.bit false :: Β·) (tokenize? rest) + | true :: true :: rest => Option.map (EncToken.bit true :: Β·) (tokenize? rest) + | false :: true :: rest => Option.map (EncToken.litSep :: Β·) (tokenize? rest) + | true :: false :: rest => Option.map (EncToken.clauseSep :: Β·) (tokenize? rest) + +/-- The empty token stream encodes to the empty bitstring. -/ +@[simp] theorem encodeTokens_nil : encodeTokens [] = [] := rfl + +/-- `encodeTokens` unfolds on `cons`: the head token's bits precede the tail's encoding. -/ +@[simp] theorem encodeTokens_cons (tok : EncToken) (toks : List EncToken) : + encodeTokens (tok :: toks) = tok.encode ++ encodeTokens toks := by + cases tok <;> rfl + +/-- `encodeTokens` is a monoid homomorphism: it distributes over list append. -/ +@[simp] theorem encodeTokens_append (xs ys : List EncToken) : + encodeTokens (xs ++ ys) = encodeTokens xs ++ encodeTokens ys := by + induction xs with + | nil => rfl + | cons x xs ih => + simp [List.append_assoc, ih] + +/-- Round trip: tokenizing an encoded token stream recovers the original tokens. -/ +@[simp] theorem tokenize?_encodeTokens (toks : List EncToken) : + tokenize? (encodeTokens toks) = some toks := by + induction toks with + | nil => simp [encodeTokens, tokenize?] + | cons tok toks ih => + cases tok with + | bit b => + cases b with + | false => + change tokenize? (false :: false :: encodeTokens toks) + = some (EncToken.bit false :: toks) + simp [tokenize?, ih] + | true => + change tokenize? (true :: true :: encodeTokens toks) + = some (EncToken.bit true :: toks) + simp [tokenize?, ih] + | litSep => + change tokenize? (false :: true :: encodeTokens toks) = some (EncToken.litSep :: toks) + simp [tokenize?, ih] + | clauseSep => + change tokenize? (true :: false :: encodeTokens toks) = some (EncToken.clauseSep :: toks) + simp [tokenize?, ih] + +/-- Soundness of `tokenize?`: any successfully tokenized bitstring is the +encoding of the resulting token stream. -/ +theorem tokenize?_sound {z : List Bool} {toks : List EncToken} + (h : tokenize? z = some toks) : z = encodeTokens toks := by + let rec hsound : βˆ€ z toks, tokenize? z = some toks β†’ z = encodeTokens toks + | [], toks, htok => by + simp [tokenize?] at htok + cases htok + rfl + | [_], _, htok => by + simp [tokenize?] at htok + | false :: false :: rest, toks, htok => by + simp [tokenize?] at htok + rcases htok with ⟨toks', hrest, rfl⟩ + have henc := hsound rest toks' hrest + simp [encodeTokens, EncToken.encode, henc] + | true :: true :: rest, toks, htok => by + simp [tokenize?] at htok + rcases htok with ⟨toks', hrest, rfl⟩ + have henc := hsound rest toks' hrest + simp [encodeTokens, EncToken.encode, henc] + | false :: true :: rest, toks, htok => by + simp [tokenize?] at htok + rcases htok with ⟨toks', hrest, rfl⟩ + have henc := hsound rest toks' hrest + simp [encodeTokens, EncToken.encode, henc] + | true :: false :: rest, toks, htok => by + simp [tokenize?] at htok + rcases htok with ⟨toks', hrest, rfl⟩ + have henc := hsound rest toks' hrest + simp [encodeTokens, EncToken.encode, henc] + exact hsound z toks h + +/-- Encoding a stream of `bit` tokens doubles each underlying bit. -/ +@[simp] theorem encodeTokens_map_bit (bs : List Bool) : + encodeTokens (bs.map EncToken.bit) = doubleBits bs := by + induction bs with + | nil => rfl + | cons b bs ih => + cases b <;> simp [encodeTokens_cons, doubleBits_cons, EncToken.encode, ih] + +-- ════════════════════════════════════════════════════════════════════════ +-- Literal decoding +-- ════════════════════════════════════════════════════════════════════════ + +namespace Lit + +/-- Decode a raw literal bitstring `[sign] ++ replicate var true`. -/ +def decodeRaw? : List Bool β†’ Option Lit + | [] => none + | sign :: rest => + if _h : βˆ€ b ∈ rest, b = true then + some { sign := sign, var := rest.length } + else + none + +/-- Round trip: decoding a literal's raw encoding recovers the literal. -/ +@[simp] theorem decodeRaw?_encodeRaw (β„“ : Lit) : + decodeRaw? β„“.encodeRaw = some β„“ := by + cases β„“ with + | mk sign var => + simp [decodeRaw?, encodeRaw, Unary.encode] + +/-- Soundness of `decodeRaw?`: any successfully decoded bitstring is the raw +encoding of the resulting literal. -/ +theorem decodeRaw?_sound {bs : List Bool} {β„“ : Lit} + (h : decodeRaw? bs = some β„“) : bs = β„“.encodeRaw := by + cases bs with + | nil => + simp [decodeRaw?] at h + | cons sign rest => + simp only [decodeRaw?] at h + split at h + Β· cases h + have hrep : rest = List.replicate rest.length true := by + rw [List.eq_replicate_length] + intro b hb + exact β€Ήβˆ€ b ∈ rest, b = trueβ€Ί b hb + change sign :: rest = sign :: Unary.encode rest.length + rw [Unary.encode] + exact congrArg (List.cons sign) hrep + Β· simp at h + +/-- Token-level raw literal encoding. -/ +def rawTokens (β„“ : Lit) : List EncToken := + β„“.encodeRaw.map EncToken.bit + +/-- A literal's token-level encoding flattens to its raw bits, doubled. -/ +@[simp] theorem encodeTokens_rawTokens (β„“ : Lit) : + encodeTokens β„“.rawTokens = doubleBits β„“.encodeRaw := by + simp [rawTokens] + +end Lit + +-- ════════════════════════════════════════════════════════════════════════ +-- Clause/CNF token encodings +-- ════════════════════════════════════════════════════════════════════════ + +namespace Clause + +/-- Token-level clause encoding: doubled raw literal bits, each terminated by `|`. -/ +def tokens : Clause β†’ List EncToken + | [] => [] + | β„“ :: β„“s => β„“.rawTokens ++ [EncToken.litSep] ++ tokens β„“s + +/-- A clause's token-level encoding flattens to its concrete bit encoding. -/ +@[simp] theorem encodeTokens_tokens (c : Clause) : + encodeTokens (tokens c) = c.encode := by + induction c with + | nil => rfl + | cons β„“ β„“s ih => + simp [tokens, encode_cons, ih, List.append_assoc, EncToken.encode] + +/-- `Clause.tokens` distributes over list append. -/ +@[simp] theorem tokens_append (c₁ cβ‚‚ : Clause) : + tokens (c₁ ++ cβ‚‚) = tokens c₁ ++ tokens cβ‚‚ := by + induction c₁ with + | nil => rfl + | cons β„“ β„“s ih => + simp [tokens, ih, List.append_assoc] + +end Clause + +namespace CNF + +/-- Token-level CNF encoding: each clause is terminated by `#`. -/ +def tokens : CNF β†’ List EncToken + | [] => [] + | c :: cs => c.tokens ++ [EncToken.clauseSep] ++ tokens cs + +/-- A CNF's token-level encoding flattens to its concrete bit encoding. -/ +@[simp] theorem encodeTokens_tokens (Ο† : CNF) : + encodeTokens (tokens Ο†) = Ο†.encode := by + induction Ο† with + | nil => rfl + | cons c cs ih => + simp [tokens, encode_cons, ih, List.append_assoc, EncToken.encode] + +/-- `CNF.tokens` distributes over list append. -/ +@[simp] theorem tokens_append (Ο† ψ : CNF) : + tokens (Ο† ++ ψ) = tokens Ο† ++ tokens ψ := by + induction Ο† with + | nil => rfl + | cons c cs ih => + simp [tokens, ih, List.append_assoc] + +end CNF + +-- ════════════════════════════════════════════════════════════════════════ +-- Token parser for CNFs +-- ════════════════════════════════════════════════════════════════════════ + +/-- Core parser state: +`rawRev` is the reversed current raw literal, `clauseRev` the reversed current +clause, and `cnfRev` the reversed list of completed clauses. -/ +def parseTokensAux : + List EncToken β†’ List Bool β†’ Clause β†’ CNF β†’ Option CNF + | [], rawRev, clauseRev, cnfRev => + if _hraw : rawRev = [] then + if _hclause : clauseRev = [] then + some cnfRev.reverse + else + none + else + none + | EncToken.bit b :: toks, rawRev, clauseRev, cnfRev => + parseTokensAux toks (b :: rawRev) clauseRev cnfRev + | EncToken.litSep :: toks, rawRev, clauseRev, cnfRev => + match Lit.decodeRaw? rawRev.reverse with + | some β„“ => parseTokensAux toks [] (β„“ :: clauseRev) cnfRev + | none => none + | EncToken.clauseSep :: toks, rawRev, clauseRev, cnfRev => + if _hraw : rawRev = [] then + parseTokensAux toks [] [] (clauseRev.reverse :: cnfRev) + else + none + +private theorem parseTokensAux_map_bit + (bs : List Bool) (toks : List EncToken) + (rawRev : List Bool) (clauseRev : Clause) (cnfRev : CNF) : + parseTokensAux (bs.map EncToken.bit ++ toks) rawRev clauseRev cnfRev = + parseTokensAux toks (bs.reverse ++ rawRev) clauseRev cnfRev := by + induction bs generalizing rawRev with + | nil => simp + | cons b bs ih => + cases b <;> simp [parseTokensAux, ih, List.reverse_cons, List.append_assoc] + +private theorem parseTokensAux_clause_tokens + (c : Clause) (toks : List EncToken) (clauseRev : Clause) (cnfRev : CNF) : + parseTokensAux (c.tokens ++ EncToken.clauseSep :: toks) [] clauseRev cnfRev = + parseTokensAux toks [] [] ((clauseRev.reverse ++ c) :: cnfRev) := by + induction c generalizing clauseRev with + | nil => + simp [Clause.tokens, parseTokensAux] + | cons β„“ β„“s ih => + simp [Clause.tokens, Lit.rawTokens] + rw [parseTokensAux_map_bit β„“.encodeRaw] + simp [parseTokensAux, Lit.decodeRaw?_encodeRaw, List.reverse_reverse, ih, + List.reverse_cons, List.append_assoc] + +private theorem parseTokensAux_cnf_tokens + (Ο† : CNF) (toks : List EncToken) (cnfRev : CNF) : + parseTokensAux (Ο†.tokens ++ toks) [] [] cnfRev = + parseTokensAux toks [] [] (Ο†.reverse ++ cnfRev) := by + induction Ο† generalizing cnfRev with + | nil => simp [CNF.tokens] + | cons c cs ih => + rw [CNF.tokens] + have hclause := parseTokensAux_clause_tokens c (CNF.tokens cs ++ toks) [] cnfRev + rw [show c.tokens ++ [EncToken.clauseSep] ++ CNF.tokens cs ++ toks = + c.tokens ++ EncToken.clauseSep :: (CNF.tokens cs ++ toks) by simp [List.append_assoc]] + rw [hclause] + simp [ih, List.reverse_cons, List.append_assoc] + +private theorem parseTokensAux_sound + {toks : List EncToken} {rawRev : List Bool} {clauseRev : Clause} + {cnfRev Ο† : CNF} + (h : parseTokensAux toks rawRev clauseRev cnfRev = some Ο†) : + CNF.tokens cnfRev.reverse ++ Clause.tokens clauseRev.reverse ++ + rawRev.reverse.map EncToken.bit ++ toks = + CNF.tokens Ο† := by + induction toks generalizing rawRev clauseRev cnfRev Ο† with + | nil => + cases rawRev <;> cases clauseRev <;> simp [parseTokensAux, Clause.tokens] at h ⊒ + cases h + simp + | cons tok toks ih => + cases tok with + | bit b => + simp [parseTokensAux] at h + have hrec := ih h + simpa [List.reverse_cons, List.append_assoc] using hrec + | litSep => + simp [parseTokensAux] at h + rcases hdecode : Lit.decodeRaw? rawRev.reverse with _ | β„“ + Β· simp [hdecode] at h + Β· simp [hdecode] at h + have hrec := ih h + have hraw : rawRev.reverse = β„“.encodeRaw := Lit.decodeRaw?_sound hdecode + simpa [hraw, Clause.tokens, Clause.tokens_append, Lit.rawTokens, + List.reverse_cons, List.append_assoc] using hrec + | clauseSep => + simp [parseTokensAux] at h + rcases h with ⟨hraw, hrest⟩ + have hrec := ih hrest + simpa [hraw, CNF.tokens, CNF.tokens_append, Clause.tokens, + List.reverse_cons, List.append_assoc] using hrec + +/-- Decode a concrete SAT-encoded bitstring as a CNF. -/ +def CNF.decode? (z : List Bool) : Option CNF := do + let toks <- tokenize? z + parseTokensAux toks [] [] [] + +/-- Round trip: decoding an encoded CNF recovers the formula. -/ +@[simp] theorem CNF.decode?_encode (Ο† : CNF) : + CNF.decode? Ο†.encode = some Ο† := by + rw [CNF.decode?, ← CNF.encodeTokens_tokens Ο†, tokenize?_encodeTokens] + simp + have hparse := parseTokensAux_cnf_tokens Ο† [] [] + simpa [parseTokensAux] using hparse + +/-- Soundness of `CNF.decode?`: any successfully decoded bitstring is the +encoding of the resulting CNF. -/ +theorem CNF.decode?_sound {z : List Bool} {Ο† : CNF} + (h : CNF.decode? z = some Ο†) : z = Ο†.encode := by + unfold CNF.decode? at h + cases htok : tokenize? z with + | none => + simp [htok] at h + | some toks => + simp [htok] at h + have hz : z = encodeTokens toks := tokenize?_sound htok + have htoks : toks = CNF.tokens Ο† := by + simpa using! (parseTokensAux_sound h) + calc + z = encodeTokens toks := hz + _ = encodeTokens (CNF.tokens Ο†) := by rw [htoks] + _ = Ο†.encode := CNF.encodeTokens_tokens Ο† + +-- ════════════════════════════════════════════════════════════════════════ +-- Executable verifier specification +-- ════════════════════════════════════════════════════════════════════════ + +/-- Boolean verifier for SAT's witness relation on paired inputs. -/ +def verifyPair (w : List Bool) : Bool := + match unpair? w with + | none => false + | some (z, Ξ±) => + match CNF.decode? z with + | none => false + | some Ο† => decide (Ξ±.length ≀ z.length + 1) && CNF.eval Ξ± Ο† + +/-- On a well-formed pair `pair(Ο†.encode, Ξ±)`, `verifyPair` reduces to the +witness length check conjoined with evaluating `Ο†` under `Ξ±`. -/ +@[simp] theorem verifyPair_pair_encode (Ο† : CNF) (Ξ± : Assignment) : + verifyPair (pair Ο†.encode Ξ±) = (decide (Ξ±.length ≀ Ο†.encode.length + 1) && CNF.eval Ξ± Ο†) := by + simp [verifyPair, CNF.decode?_encode] + +/-- Completeness: `verifyPair` accepts the pairing of any witnessed instance. -/ +theorem verifyPair_true_of_witness {z Ξ± : List Bool} (hR : Witness z Ξ±) : + verifyPair (pair z Ξ±) = true := by + obtain βŸ¨Ο†, hz, hlen, heval⟩ := hR + subst hz + simp [verifyPair_pair_encode, hlen, heval] + +/-- Correctness of the verifier: `verifyPair` accepts exactly the members of +`pairLang Witness`. -/ +theorem verifyPair_eq_true_iff_mem_pairLang (w : List Bool) : + verifyPair w = true ↔ w ∈ pairLang Witness := by + constructor + Β· intro h + unfold verifyPair at h + cases hunpair : unpair? w with + | none => + simp [hunpair] at h + | some zw => + rcases zw with ⟨z, α⟩ + simp [hunpair] at h + cases hdecode : CNF.decode? z with + | none => + simp [hdecode] at h + | some Ο† => + simp [hdecode] at h + have hz : z = Ο†.encode := CNF.decode?_sound hdecode + have hw : w = pair z Ξ± := eq_pair_of_unpair?_eq_some hunpair + have hlen : Ξ±.length ≀ z.length + 1 := by + simpa [decide_eq_true_eq] using h.1 + refine ⟨z, Ξ±, hw, ?_⟩ + exact βŸ¨Ο†, hz, hlen, h.2⟩ + Β· rintro ⟨z, Ξ±, rfl, hR⟩ + exact verifyPair_true_of_witness hR + +/-- `verifyPair_eq_true_iff_mem_pairLang` with the biconditional flipped. -/ +theorem mem_pairLang_iff_verifyPair (w : List Bool) : + w ∈ pairLang Witness ↔ verifyPair w = true := by + rw [verifyPair_eq_true_iff_mem_pairLang] + +/-- `pairLang Witness` equals the language decided by `verifyPair`, as sets. -/ +theorem pairLang_witness_eq_verifyPairLang : + pairLang Witness = {w | verifyPair w = true} := by + ext w + exact mem_pairLang_iff_verifyPair w + +end SAT + +end Complexity diff --git a/LeanPool/BeyondBethe/Solution.lean b/LeanPool/BeyondBethe/Solution.lean new file mode 100644 index 0000000000..f73bea471a --- /dev/null +++ b/LeanPool/BeyondBethe/Solution.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Nima Anari. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nima Anari +-/ +module + + +public import LeanPool.BeyondBethe.BeyondBethe.Main +public import LeanPool.BeyondBethe.BeyondBethe.PalomarComplexity +public import LeanPool.BeyondBethe.Complexitylib.Classes.P.Cobham + +/-! +# Proved solution for the Palomar statement + +Comparator checks that `Palomar.beyond_bethe_permanent` has exactly the same +type as its counterpart in `Challenge.lean`. The proof below extracts the +concrete algorithm and its finite-word Turing-machine implementation from the +fully internal theorem `BeyondBethe.theoremOne`, then applies Complexitylib's +formal proof of Cobham's characterization of polynomial time. +-/ + +@[expose] public section + +namespace Palomar + +theorem beyond_bethe_permanent : + βˆƒ (c : ℝ) + (alg : βˆ€ n, Matrix (Fin n) (Fin n) β„š β†’ β„š) + (F : List Bool β†’ List Bool), + BeyondBethe.ApproximationGuarantee alg c ∧ + F ∈ BeyondBethe.PalomarComplexity.CobhamFP ∧ + BeyondBethe.StringRealizes F alg := by + obtain ⟨spec⟩ := BeyondBethe.theoremOne + obtain ⟨F, hF, hrealizes⟩ := spec.polynomialTime + refine ⟨spec.c, spec.alg, F, spec.guarantee, ?_, hrealizes⟩ + apply BeyondBethe.PalomarComplexity.cobhamFP_of_complexity + rw [Complexity.CobhamFP_eq_FP] + exact hF + +end Palomar diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index f9a22a33a3..2e950cc549 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -11640,3 +11640,38 @@ projects: - 17A15 - 46L70 provenance: AI + - title: Beyond the Bethe approximation of the permanent + summary: Constructs a deterministic polynomial-time approximation algorithm for the permanent of + every nonnegative rational matrix, with exponential base strictly smaller than the square root + of two. The development includes stable-polynomial inequalities, rational convex optimization, + finite-precision arithmetic, and a Turing-machine complexity proof. + branch: theoretical computer science + provenance: AI + main_declarations: + - BeyondBethe.theoremOne + main_results: + - declaration: BeyondBethe.theoremOne + informal: There is a fixed rational algorithm approximating the permanent of every nonnegative + rational n-by-n matrix within c^n for an absolute c below sqrt(2), with a deterministic polynomial-time + Turing-machine implementation. + tags: + - permanent + - approximation-algorithms + - computational-complexity + - stable-polynomials + msc: + - 68W25 + - 15A15 + slug: formalization-beyond-bethe + entry_module: LeanPool.BeyondBethe + authors: + - Nima Anari + - Samuel Schlesinger + - Bolton Bailey + - Christian Reitwiessner + source: + url: https://github.com/nimaanari/formalization-beyond-bethe + github_repo: nimaanari/formalization-beyond-bethe + commit: 325cda6d2118870f7f121a9a986b7ea9ffdd7a26 + license: Apache-2.0 + status: verified